1module m_wxml_core 2 3use m_wxml_buffer 4use m_wxml_array_str, only: assign_array_to_str 5use m_wxml_array_str, only: assign_str_to_array 6use m_wxml_escape, only: check_Name 7use m_wxml_elstack 8use m_wxml_dictionary 9 10implicit none 11 12logical, private, save :: pcdata_advance_line_default = .false. 13logical, private, save :: pcdata_advance_space_default = .false. 14 15integer, private, parameter :: sp = selected_real_kind(6,30) 16integer, private, parameter :: dp = selected_real_kind(14,100) 17 18private 19 20type, public :: xmlf_t 21 character, pointer :: filename(:) 22 integer :: lun 23 type(buffer_t) :: buffer 24 type(elstack_t) :: stack 25 type(wxml_dictionary_t) :: dict 26 logical :: start_tag_closed 27 logical :: root_element_output 28 logical :: indenting_requested 29end type xmlf_t 30 31public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close 32public :: xml_AddXMLDeclaration 33public :: xml_AddXMLStylesheet 34public :: xml_AddXMLPI 35public :: xml_AddComment, xml_AddCdataSection 36public :: xml_AddPcdata, xml_AddAttribute 37interface xml_AddPcdata 38 module procedure xml_AddPcdata_Ch 39end interface 40! 41interface xml_AddAttribute 42 module procedure xml_AddAttribute_Ch 43end interface 44! 45public :: xml_AddArray 46interface xml_AddArray 47 module procedure xml_AddArray_integer, & 48 xml_AddArray_real_dp, xml_AddArray_real_sp 49end interface 50private :: xml_AddArray_integer, xml_AddArray_real_dp, xml_AddArray_real_sp 51 52private :: get_unit 53private :: add_eol 54private :: write_attributes 55 56!overload error handlers to allow file info 57interface wxml_warning 58 module procedure wxml_warning_xf 59end interface 60interface wxml_error 61 module procedure wxml_error_xf 62end interface 63interface wxml_fatal 64 module procedure wxml_fatal_xf 65end interface 66 67! 68! Heuristic (approximate) target for justification of output 69! Large unbroken pcdatas will go beyond this limit 70! 71integer, private, parameter :: COLUMNS = 80 72 73! TOHW - This is the longest string that may be output without 74! a newline. The buffer must not be larger than this, but its size 75! can be tuned for performance. 76integer, private, parameter :: xml_recl = 4096 77 78CONTAINS 79 80!------------------------------------------------------------------- 81subroutine xml_OpenFile(filename, xf, indent) 82character(len=*), intent(in) :: filename 83type(xmlf_t), intent(inout) :: xf 84logical, intent(in), optional :: indent 85 86integer :: iostat 87 88allocate(xf%filename(len(filename))) 89call assign_str_to_array(xf%filename,filename) 90 91call get_unit(xf%lun,iostat) 92if (iostat /= 0) call wxml_fatal(xf, "cannot open file") 93! 94! Use large I/O buffer in case the O.S./Compiler combination 95! has hard-limits by default (i.e., NAGWare f95's 1024 byte limit) 96! This is related to the maximum size of the buffer. 97! TOHW - This is the longest string that may be output without 98! a newline. The buffer must not be larger than this, but its size 99! can be tuned for performance. 100 101open(unit=xf%lun, file=filename, form="formatted", status="replace", & 102 action="write", position="rewind", recl=xml_recl) 103 104call init_elstack(xf%stack) 105 106call init_dict(xf%dict) 107call reset_buffer(xf%buffer) 108 109xf%start_tag_closed = .true. 110xf%root_element_output = .false. 111 112xf%indenting_requested = .false. 113if (present(indent)) then 114 xf%indenting_requested = indent 115endif 116end subroutine xml_OpenFile 117 118!------------------------------------------------------------------- 119subroutine xml_AddXMLDeclaration(xf,encoding) 120type(xmlf_t), intent(inout) :: xf 121character(len=*), intent(in), optional :: encoding 122 123if (present(encoding)) then 124 call add_to_buffer("<?xml version=""1.0"" encoding=""" & 125 // trim(encoding) // """ ?>", xf%buffer) 126else 127 call add_to_buffer("<?xml version=""1.0"" ?>", xf%buffer) 128endif 129end subroutine xml_AddXMLDeclaration 130 131!------------------------------------------------------------------- 132subroutine xml_AddXMLStylesheet(xf, href, type, title, media, charset, alternate) 133type(xmlf_t), intent(inout) :: xf 134character(len=*), intent(in) :: href 135character(len=*), intent(in) :: type 136character(len=*), intent(in), optional :: title 137character(len=*), intent(in), optional :: media 138character(len=*), intent(in), optional :: charset 139logical, intent(in), optional :: alternate 140 141call add_eol(xf) 142call add_to_buffer("<?xml-stylesheet href=""" //trim(href)// & 143 """ type=""" //trim(type)// """", xf%buffer) 144 145if (present(title)) call add_to_buffer(" title="""//trim(title)// """", xf%buffer) 146if (present(media)) call add_to_buffer(" media="""//trim(media)// """", xf%buffer) 147if (present(charset)) call add_to_buffer(" charset="""//trim(charset)// """", xf%buffer) 148if (present(alternate)) then 149 if (alternate) then 150 call add_to_buffer(" alternate=""yes""", xf%buffer) 151 else 152 call add_to_buffer(" alternate=""no""", xf%buffer) 153 endif 154endif 155call add_to_buffer(" ?>", xf%buffer) 156 157end subroutine xml_AddXMLStylesheet 158 159!------------------------------------------------------------------- 160subroutine xml_AddXMLPI(xf, name, data) 161type(xmlf_t), intent(inout) :: xf 162character(len=*), intent(in) :: name 163character(len=*), intent(in), optional :: data 164 165call add_eol(xf) 166call add_to_buffer("<?" // trim(name) // " ", xf%buffer) 167if(present(data)) call add_to_buffer(data, xf%buffer) 168call add_to_buffer(" ?>", xf%buffer) 169 170end subroutine xml_AddXMLPI 171 172 173!------------------------------------------------------------------- 174subroutine xml_AddComment(xf,comment) 175type(xmlf_t), intent(inout) :: xf 176character(len=*), intent(in) :: comment 177 178call close_start_tag(xf,">") 179call add_eol(xf) 180call add_to_buffer("<!--", xf%buffer) 181call add_to_buffer(comment, xf%buffer) 182call add_to_buffer("-->", xf%buffer) 183end subroutine xml_AddComment 184 185!------------------------------------------------------------------- 186subroutine xml_AddCdataSection(xf,cdata) 187type(xmlf_t), intent(inout) :: xf 188character(len=*), intent(in) :: cdata 189 190call close_start_tag(xf,">") 191call add_to_buffer("<![CDATA[", xf%buffer) 192call add_to_buffer(cdata, xf%buffer) 193call add_to_buffer("]]>", xf%buffer) 194end subroutine xml_AddCdataSection 195 196!------------------------------------------------------------------- 197subroutine xml_NewElement(xf,name) 198type(xmlf_t), intent(inout) :: xf 199character(len=*), intent(in) :: name 200 201if (is_empty(xf%stack)) then 202 if (xf%root_element_output) call wxml_error(xf, "two root elements") 203 xf%root_element_output = .true. 204endif 205 206if (.not.check_Name(name)) then 207 call wxml_warning(xf, 'attribute name '//name//' is not valid') 208endif 209 210 211call close_start_tag(xf,">") 212call push_elstack(name,xf%stack) 213call add_eol(xf) 214call add_to_buffer("<" // trim(name),xf%buffer) 215xf%start_tag_closed = .false. 216call reset_dict(xf%dict) 217 218end subroutine xml_NewElement 219!------------------------------------------------------------------- 220subroutine xml_AddPcdata_Ch(xf,pcdata,space,line_feed) 221type(xmlf_t), intent(inout) :: xf 222character(len=*), intent(in) :: pcdata 223logical, intent(in), optional :: space 224logical, intent(in), optional :: line_feed 225 226logical :: advance_line , advance_space 227 228advance_line = pcdata_advance_line_default 229if (present(line_feed)) then 230 advance_line = line_feed 231endif 232 233advance_space = pcdata_advance_space_default 234if (present(space)) then 235 advance_space = space 236endif 237 238if (is_empty(xf%stack)) then 239 call wxml_error(xf, "pcdata outside element content") 240endif 241 242call close_start_tag(xf,">") 243 244if (advance_line) then 245 call add_eol(xf) 246 advance_space = .false. 247else 248 if (xf%indenting_requested) then 249 if ((len(xf%buffer) + len_trim(pcdata) + 1) > COLUMNS ) then 250 call add_eol(xf) 251 advance_space = .false. 252 endif 253 endif 254endif 255if (advance_space) call add_to_buffer(" ",xf%buffer) 256 257call add_to_buffer_escaping_markup(pcdata, xf%buffer) 258 259end subroutine xml_AddPcdata_Ch 260 261!------------------------------------------------------------------- 262subroutine xml_AddAttribute_Ch(xf,name,value) 263type(xmlf_t), intent(inout) :: xf 264character(len=*), intent(in) :: name 265character(len=*), intent(in) :: value 266 267if (is_empty(xf%stack)) then 268 call wxml_error(xf, "attributes outside element content") 269endif 270 271if (xf%start_tag_closed) then 272 call wxml_error(xf, "attributes outside start tag") 273endif 274 275if (has_key(xf%dict,name)) then 276 call wxml_error(xf, "duplicate att name") 277endif 278 279call add_item_to_dict(xf%dict, name, value) 280 281end subroutine xml_AddAttribute_Ch 282 283!----------------------------------------------------------- 284subroutine xml_EndElement(xf,name) 285type(xmlf_t), intent(inout) :: xf 286character(len=*), intent(in) :: name 287 288character(len=2000) :: current 289 290if (is_empty(xf%stack)) then 291 call wxml_fatal(xf, "Out of elements to close") 292endif 293 294call get_top_elstack(xf%stack,current) 295if (current /= name) then 296 call wxml_fatal(xf, 'Trying to close '//Trim(name)//' but '//Trim(current)//' is open.') 297endif 298if (.not. xf%start_tag_closed) then ! Empty element 299 if (len(xf%dict) > 0) call write_attributes(xf) 300 call add_to_buffer(" />",xf%buffer) 301 xf%start_tag_closed = .true. 302else 303 call add_eol(xf) 304 call add_to_buffer("</" // trim(name) // ">", xf%buffer) 305endif 306call pop_elstack(xf%stack,current) 307 308end subroutine xml_EndElement 309 310!---------------------------------------------------------------- 311 312subroutine xml_Close(xf) 313type(xmlf_t), intent(inout) :: xf 314 315character(len=2000) :: name 316 317do 318 if (is_empty(xf%stack)) exit 319 call get_top_elstack(xf%stack,name) 320 call xml_EndElement(xf,trim(name)) 321enddo 322 323write(unit=xf%lun,fmt="(a)") char(xf%buffer) 324close(unit=xf%lun) 325 326deallocate(xf%filename) 327 328end subroutine xml_Close 329 330!================================================================== 331!------------------------------------------------------------------- 332subroutine get_unit(lun,iostat) 333 334! Get an available Fortran unit number 335 336integer, intent(out) :: lun 337integer, intent(out) :: iostat 338 339integer :: i 340logical :: unit_used 341 342do i = 10, 99 343 lun = i 344 inquire(unit=lun,opened=unit_used) 345 if (.not. unit_used) then 346 iostat = 0 347 return 348 endif 349enddo 350iostat = -1 351lun = -1 352end subroutine get_unit 353 354!---------------------------------------------------------- 355subroutine add_eol(xf) 356type(xmlf_t), intent(inout) :: xf 357 358integer :: indent_level 359 360! In case we still have a zero-length stack, we must make 361! sure indent_level is not less than zero. 362indent_level = max(len(xf%stack) - 1, 0) 363 364!We must flush here (rather than just adding an eol character) 365!since we don't know what the eol character is on this system. 366!Flushing with a linefeed will get it automatically, though. 367write(unit=xf%lun,fmt="(a)") char(xf%buffer) 368call reset_buffer(xf%buffer) 369 370if (xf%indenting_requested) & 371 call add_to_buffer(repeat(' ',indent_level),xf%buffer) 372 373end subroutine add_eol 374!------------------------------------------------------------ 375subroutine dump_buffer(xf,lf) 376type(xmlf_t), intent(inout) :: xf 377logical, intent(in), optional :: lf 378 379if (present(lf)) then 380 if (lf) then 381 write(unit=xf%lun,fmt="(a)",advance="yes") char(xf%buffer) 382 else 383 write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer) 384 endif 385else 386 write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer) 387endif 388call reset_buffer(xf%buffer) 389 390end subroutine dump_buffer 391 392!------------------------------------------------------------ 393subroutine close_start_tag(xf,s) 394type(xmlf_t), intent(inout) :: xf 395character(len=*), intent(in) :: s 396 397if (.not. xf%start_tag_closed) then 398 if (len(xf%dict) > 0) call write_attributes(xf) 399 call add_to_buffer(s, xf%buffer) 400 xf%start_tag_closed = .true. 401endif 402 403end subroutine close_start_tag 404 405!------------------------------------------------------------- 406subroutine write_attributes(xf) 407type(xmlf_t), intent(inout) :: xf 408 409integer :: i, status, size, key_len, value_len 410character(len=2000) :: key, value 411 412do i = 1, len(xf%dict) 413 call get_key(xf%dict,i,key,key_len,status) 414 call get_value(xf%dict,i,value,value_len,status) 415 size = key_len + value_len + 4 416 if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf) 417 call add_to_buffer(" ", xf%buffer) 418 call add_to_buffer(key(:key_len), xf%buffer) 419 call add_to_buffer("=", xf%buffer) 420 call add_to_buffer("""",xf%buffer) 421 call add_to_buffer_escaping_markup(value(:value_len), xf%buffer) 422 call add_to_buffer("""", xf%buffer) 423enddo 424 425end subroutine write_attributes 426 427!--------------------------------------------------------------- 428 subroutine xml_AddArray_integer(xf,a,format) 429 type(xmlf_t), intent(inout) :: xf 430 integer, intent(in), dimension(:) :: a 431 character(len=*), intent(in), optional :: format 432 433 call close_start_tag(xf,">") 434 if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.) 435 if (present(format)) then 436 write(xf%lun,format) a 437 else 438 write(xf%lun,"(6(i12))") a 439 endif 440 end subroutine xml_AddArray_integer 441 442!------------------------------------------------------------------- 443 subroutine xml_AddArray_real_dp(xf,a,format) 444 type(xmlf_t), intent(inout) :: xf 445 real(kind=dp), intent(in), dimension(:) :: a 446 character(len=*), intent(in), optional :: format 447 448 call close_start_tag(xf,">") 449 if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.) 450 if (present(format)) then 451 write(xf%lun,format) a 452 else 453 write(xf%lun,"(4(es20.12))") a 454 endif 455 end subroutine xml_AddArray_real_dp 456 457!------------------------------------------------------------------ 458 subroutine xml_AddArray_real_sp(xf,a,format) 459 type(xmlf_t), intent(inout) :: xf 460 real(kind=sp), intent(in), dimension(:) :: a 461 character(len=*), intent(in), optional :: format 462 463 call close_start_tag(xf,">") 464 if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.) 465 if (present(format)) then 466 write(xf%lun,format) a 467 else 468 write(xf%lun,"(4(es20.7))") a 469 endif 470 end subroutine xml_AddArray_real_sp 471 472!--------------------------------------------------------- 473! Error handling/trapping routines: 474 475 subroutine wxml_warning_xf(xf, msg) 476 ! Emit warning, but carry on. 477 type(xmlf_t), intent(in) :: xf 478 character(len=*), intent(in) :: msg 479 480 write(6,'(a)') 'WARNING(wxml) in writing to file ', xmlf_name(xf) 481 write(6,'(a)') msg 482 483 end subroutine wxml_warning_xf 484 485 subroutine wxml_error_xf(xf, msg) 486 ! Emit error message, clean up file and stop. 487 type(xmlf_t), intent(inout) :: xf 488 character(len=*), intent(in) :: msg 489 490 write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf) 491 write(6,'(a)') msg 492 493 call xml_Close(xf) 494 stop 495 496 end subroutine wxml_error_xf 497 498 subroutine wxml_fatal_xf(xf, msg) 499 !Emit error message and abort with coredump. Does not try to 500 !close file, so should be used from anything xml_Close might 501 !itself call (to avoid infinite recursion!) 502 503 type(xmlf_t), intent(in) :: xf 504 character(len=*), intent(in) :: msg 505 506 write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf) 507 write(6,'(a)') msg 508 509 call pxfabort 510 stop 511 512 end subroutine wxml_fatal_xf 513 514 function xmlf_name(xf) result(fn) 515 Type (xmlf_t), intent(in) :: xf 516 character(len=size(xf%filename)) :: fn 517 call assign_array_to_str(fn,xf%filename) 518 end function xmlf_name 519 520 521end module m_wxml_core 522 523