[6] | 1 | module m_wxml_core |
---|
| 2 | |
---|
| 3 | use m_wxml_buffer |
---|
| 4 | use m_wxml_elstack |
---|
| 5 | use m_wxml_dictionary |
---|
| 6 | |
---|
| 7 | logical, private, save :: pcdata_advance_line_default = .false. |
---|
| 8 | logical, private, save :: pcdata_advance_space_default = .false. |
---|
| 9 | |
---|
| 10 | integer, private, parameter :: sp = selected_real_kind(6,30) |
---|
| 11 | integer, private, parameter :: dp = selected_real_kind(14,100) |
---|
| 12 | |
---|
| 13 | private |
---|
| 14 | |
---|
| 15 | type, public :: xmlf_t |
---|
| 16 | integer :: lun |
---|
| 17 | type(buffer_t) :: buffer |
---|
| 18 | type(elstack_t) :: stack |
---|
| 19 | type(wxml_dictionary_t) :: dict |
---|
| 20 | logical :: start_tag_closed |
---|
| 21 | logical :: root_element_output |
---|
| 22 | logical :: indenting_requested |
---|
| 23 | end type xmlf_t |
---|
| 24 | |
---|
| 25 | public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close |
---|
| 26 | public :: xml_AddPcdata, xml_AddAttribute, xml_AddXMLDeclaration |
---|
| 27 | public :: xml_AddComment, xml_AddCdataSection |
---|
| 28 | |
---|
| 29 | public :: xml_AddArray |
---|
| 30 | interface xml_AddArray |
---|
| 31 | module procedure xml_AddArray_integer, & |
---|
| 32 | xml_AddArray_real_dp, xml_AddArray_real_sp |
---|
| 33 | end interface |
---|
| 34 | private :: xml_AddArray_integer, xml_AddArray_real_dp, xml_AddArray_real_sp |
---|
| 35 | |
---|
| 36 | private :: get_unit |
---|
| 37 | private :: add_eol |
---|
| 38 | private :: write_attributes |
---|
| 39 | |
---|
| 40 | |
---|
| 41 | integer, private, parameter :: COLUMNS = 80 |
---|
| 42 | |
---|
| 43 | CONTAINS |
---|
| 44 | |
---|
| 45 | !------------------------------------------------------------------- |
---|
| 46 | subroutine xml_OpenFile(filename, xf, indent) |
---|
| 47 | character(len=*), intent(in) :: filename |
---|
| 48 | type(xmlf_t), intent(inout) :: xf |
---|
| 49 | logical, intent(in), optional :: indent |
---|
| 50 | |
---|
| 51 | integer :: iostat |
---|
| 52 | |
---|
| 53 | call get_unit(xf%lun,iostat) |
---|
| 54 | if (iostat /= 0) stop "cannot open file" |
---|
| 55 | open(unit=xf%lun, file=filename, form="formatted", status="replace", & |
---|
| 56 | action="write", position="rewind") ! , recl=65536) |
---|
| 57 | |
---|
| 58 | call reset_elstack(xf%stack) |
---|
| 59 | call reset_dict(xf%dict) |
---|
| 60 | call reset_buffer(xf%buffer) |
---|
| 61 | |
---|
| 62 | xf%start_tag_closed = .true. |
---|
| 63 | xf%root_element_output = .false. |
---|
| 64 | |
---|
| 65 | xf%indenting_requested = .false. |
---|
| 66 | if (present(indent)) then |
---|
| 67 | xf%indenting_requested = indent |
---|
| 68 | endif |
---|
| 69 | end subroutine xml_OpenFile |
---|
| 70 | |
---|
| 71 | !------------------------------------------------------------------- |
---|
| 72 | subroutine xml_AddXMLDeclaration(xf,encoding) |
---|
| 73 | type(xmlf_t), intent(inout) :: xf |
---|
| 74 | character(len=*), intent(in), optional :: encoding |
---|
| 75 | |
---|
| 76 | if (present(encoding)) then |
---|
| 77 | call add_to_buffer("<?xml version=""1.0"" encoding=""" & |
---|
| 78 | // trim(encoding) // """ ?>", xf%buffer) |
---|
| 79 | else |
---|
| 80 | call add_to_buffer("<?xml version=""1.0"" ?>", xf%buffer) |
---|
| 81 | endif |
---|
| 82 | end subroutine xml_AddXMLDeclaration |
---|
| 83 | |
---|
| 84 | !------------------------------------------------------------------- |
---|
| 85 | subroutine xml_AddComment(xf,comment) |
---|
| 86 | type(xmlf_t), intent(inout) :: xf |
---|
| 87 | character(len=*), intent(in) :: comment |
---|
| 88 | |
---|
| 89 | call close_start_tag(xf,">") |
---|
| 90 | call add_eol(xf) |
---|
| 91 | call add_to_buffer("<!--", xf%buffer) |
---|
| 92 | call add_to_buffer(comment, xf%buffer) |
---|
| 93 | call add_to_buffer("-->", xf%buffer) |
---|
| 94 | end subroutine xml_AddComment |
---|
| 95 | |
---|
| 96 | !------------------------------------------------------------------- |
---|
| 97 | subroutine xml_AddCdataSection(xf,cdata) |
---|
| 98 | type(xmlf_t), intent(inout) :: xf |
---|
| 99 | character(len=*), intent(in) :: cdata |
---|
| 100 | |
---|
| 101 | call close_start_tag(xf,">") |
---|
| 102 | call add_to_buffer("<![CDATA[", xf%buffer) |
---|
| 103 | call add_to_buffer(cdata, xf%buffer) |
---|
| 104 | call add_to_buffer("]]>", xf%buffer) |
---|
| 105 | end subroutine xml_AddCdataSection |
---|
| 106 | |
---|
| 107 | !------------------------------------------------------------------- |
---|
| 108 | subroutine xml_NewElement(xf,name) |
---|
| 109 | type(xmlf_t), intent(inout) :: xf |
---|
| 110 | character(len=*), intent(in) :: name |
---|
| 111 | |
---|
| 112 | if (is_empty(xf%stack)) then |
---|
| 113 | if (xf%root_element_output) stop "two root elements" |
---|
| 114 | xf%root_element_output = .true. |
---|
| 115 | endif |
---|
| 116 | |
---|
| 117 | call close_start_tag(xf,">") |
---|
| 118 | call push_elstack(name,xf%stack) |
---|
| 119 | call add_eol(xf) |
---|
| 120 | call add_to_buffer("<" // trim(name),xf%buffer) |
---|
| 121 | xf%start_tag_closed = .false. |
---|
| 122 | call reset_dict(xf%dict) |
---|
| 123 | |
---|
| 124 | end subroutine xml_NewElement |
---|
| 125 | !------------------------------------------------------------------- |
---|
| 126 | subroutine xml_AddPcdata(xf,pcdata,space,line_feed) |
---|
| 127 | type(xmlf_t), intent(inout) :: xf |
---|
| 128 | character(len=*), intent(in) :: pcdata |
---|
| 129 | logical, intent(in), optional :: space |
---|
| 130 | logical, intent(in), optional :: line_feed |
---|
| 131 | |
---|
| 132 | logical :: advance_line , advance_space |
---|
| 133 | integer :: n, i, jmax |
---|
| 134 | integer, parameter :: chunk_size = 128 |
---|
| 135 | |
---|
| 136 | advance_line = pcdata_advance_line_default |
---|
| 137 | if (present(line_feed)) then |
---|
| 138 | advance_line = line_feed |
---|
| 139 | endif |
---|
| 140 | |
---|
| 141 | advance_space = pcdata_advance_space_default |
---|
| 142 | if (present(space)) then |
---|
| 143 | advance_space = space |
---|
| 144 | endif |
---|
| 145 | |
---|
| 146 | if (is_empty(xf%stack)) then |
---|
| 147 | stop "pcdata outside element content" |
---|
| 148 | endif |
---|
| 149 | |
---|
| 150 | call close_start_tag(xf,">") |
---|
| 151 | |
---|
| 152 | if (advance_line) then |
---|
| 153 | call add_eol(xf) |
---|
| 154 | advance_space = .false. |
---|
| 155 | else |
---|
| 156 | if (xf%indenting_requested) then |
---|
| 157 | if ((len(xf%buffer) + len_trim(pcdata) + 1) > COLUMNS ) then |
---|
| 158 | call add_eol(xf) |
---|
| 159 | advance_space = .false. |
---|
| 160 | endif |
---|
| 161 | endif |
---|
| 162 | endif |
---|
| 163 | if (advance_space) call add_to_buffer(" ",xf%buffer) |
---|
| 164 | if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.false.) |
---|
| 165 | ! |
---|
| 166 | ! We bypass the buffer for the bulk of the dump |
---|
| 167 | ! |
---|
| 168 | n = len(pcdata) |
---|
| 169 | !print *, "writing pcdata of length: ", n |
---|
| 170 | i = 1 |
---|
| 171 | do |
---|
| 172 | jmax = min(i+chunk_size-1,n) |
---|
| 173 | ! print *, "writing chunk: ", i, jmax |
---|
| 174 | write(unit=xf%lun,fmt="(a)",advance="no") pcdata(i:jmax) |
---|
| 175 | if (jmax == n) exit |
---|
| 176 | i = jmax + 1 |
---|
| 177 | enddo |
---|
| 178 | end subroutine xml_AddPcdata |
---|
| 179 | |
---|
| 180 | !------------------------------------------------------------------- |
---|
| 181 | subroutine xml_AddAttribute(xf,name,value) |
---|
| 182 | type(xmlf_t), intent(inout) :: xf |
---|
| 183 | character(len=*), intent(in) :: name |
---|
| 184 | character(len=*), intent(in) :: value |
---|
| 185 | |
---|
| 186 | if (is_empty(xf%stack)) then |
---|
| 187 | stop "attributes outside element content" |
---|
| 188 | endif |
---|
| 189 | |
---|
| 190 | if (xf%start_tag_closed) then |
---|
| 191 | stop "attributes outside start tag" |
---|
| 192 | endif |
---|
| 193 | if (has_key(xf%dict,name)) then |
---|
| 194 | stop "duplicate att name" |
---|
| 195 | endif |
---|
| 196 | |
---|
| 197 | call add_key_to_dict(trim(name),xf%dict) |
---|
| 198 | call add_value_to_dict(trim(value),xf%dict) |
---|
| 199 | |
---|
| 200 | end subroutine xml_AddAttribute |
---|
| 201 | |
---|
| 202 | !----------------------------------------------------------- |
---|
| 203 | subroutine xml_EndElement(xf,name) |
---|
| 204 | type(xmlf_t), intent(inout) :: xf |
---|
| 205 | character(len=*), intent(in) :: name |
---|
| 206 | |
---|
| 207 | character(len=100) :: current |
---|
| 208 | |
---|
| 209 | if (is_empty(xf%stack)) then |
---|
| 210 | stop "Out of elements to close" |
---|
| 211 | endif |
---|
| 212 | |
---|
| 213 | call get_top_elstack(xf%stack,current) |
---|
| 214 | if (current /= name) then |
---|
| 215 | print *, "current, name: ", trim(current), " ", trim(name) |
---|
| 216 | stop |
---|
| 217 | endif |
---|
| 218 | if (.not. xf%start_tag_closed) then ! Empty element |
---|
| 219 | if (len(xf%dict) > 0) call write_attributes(xf) |
---|
| 220 | call add_to_buffer(" />",xf%buffer) |
---|
| 221 | xf%start_tag_closed = .true. |
---|
| 222 | else |
---|
| 223 | call add_eol(xf) |
---|
| 224 | call add_to_buffer("</" // trim(name) // ">", xf%buffer) |
---|
| 225 | endif |
---|
| 226 | call pop_elstack(xf%stack,current) |
---|
| 227 | |
---|
| 228 | end subroutine xml_EndElement |
---|
| 229 | |
---|
| 230 | !---------------------------------------------------------------- |
---|
| 231 | |
---|
| 232 | subroutine xml_Close(xf) |
---|
| 233 | type(xmlf_t), intent(in) :: xf |
---|
| 234 | |
---|
| 235 | write(unit=xf%lun,fmt="(a)") char(xf%buffer) |
---|
| 236 | close(unit=xf%lun) |
---|
| 237 | |
---|
| 238 | end subroutine xml_Close |
---|
| 239 | |
---|
| 240 | !================================================================== |
---|
| 241 | !------------------------------------------------------------------- |
---|
| 242 | subroutine get_unit(lun,iostat) |
---|
| 243 | |
---|
| 244 | ! Get an available Fortran unit number |
---|
| 245 | |
---|
| 246 | integer, intent(out) :: lun |
---|
| 247 | integer, intent(out) :: iostat |
---|
| 248 | |
---|
| 249 | integer :: i |
---|
| 250 | logical :: unit_used |
---|
| 251 | |
---|
| 252 | do i = 10, 99 |
---|
| 253 | lun = i |
---|
| 254 | inquire(unit=lun,opened=unit_used) |
---|
| 255 | if (.not. unit_used) then |
---|
| 256 | iostat = 0 |
---|
| 257 | return |
---|
| 258 | endif |
---|
| 259 | enddo |
---|
| 260 | iostat = -1 |
---|
| 261 | lun = -1 |
---|
| 262 | end subroutine get_unit |
---|
| 263 | |
---|
| 264 | !---------------------------------------------------------- |
---|
| 265 | subroutine add_eol(xf) |
---|
| 266 | type(xmlf_t), intent(inout) :: xf |
---|
| 267 | |
---|
| 268 | integer :: indent_level |
---|
| 269 | character(len=100), parameter :: blanks = "" |
---|
| 270 | |
---|
| 271 | indent_level = len(xf%stack) - 1 |
---|
| 272 | write(unit=xf%lun,fmt="(a)") char(xf%buffer) |
---|
| 273 | call reset_buffer(xf%buffer) |
---|
| 274 | |
---|
| 275 | if (xf%indenting_requested) & |
---|
| 276 | call add_to_buffer(blanks(1:indent_level),xf%buffer) |
---|
| 277 | |
---|
| 278 | end subroutine add_eol |
---|
| 279 | !------------------------------------------------------------ |
---|
| 280 | subroutine dump_buffer(xf,lf) |
---|
| 281 | type(xmlf_t), intent(inout) :: xf |
---|
| 282 | logical, intent(in), optional :: lf |
---|
| 283 | |
---|
| 284 | if (present(lf)) then |
---|
| 285 | if (lf) then |
---|
| 286 | write(unit=xf%lun,fmt="(a)",advance="yes") char(xf%buffer) |
---|
| 287 | else |
---|
| 288 | write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer) |
---|
| 289 | endif |
---|
| 290 | else |
---|
| 291 | write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer) |
---|
| 292 | endif |
---|
| 293 | call reset_buffer(xf%buffer) |
---|
| 294 | |
---|
| 295 | end subroutine dump_buffer |
---|
| 296 | |
---|
| 297 | !------------------------------------------------------------ |
---|
| 298 | subroutine close_start_tag(xf,s) |
---|
| 299 | type(xmlf_t), intent(inout) :: xf |
---|
| 300 | character(len=*), intent(in) :: s |
---|
| 301 | |
---|
| 302 | if (.not. xf%start_tag_closed) then |
---|
| 303 | if (len(xf%dict) > 0) call write_attributes(xf) |
---|
| 304 | call add_to_buffer(s, xf%buffer) |
---|
| 305 | xf%start_tag_closed = .true. |
---|
| 306 | endif |
---|
| 307 | |
---|
| 308 | end subroutine close_start_tag |
---|
| 309 | |
---|
| 310 | !------------------------------------------------------------- |
---|
| 311 | subroutine write_attributes(xf) |
---|
| 312 | type(xmlf_t), intent(inout) :: xf |
---|
| 313 | |
---|
| 314 | integer :: i, status, size |
---|
| 315 | character(len=100) :: key, value |
---|
| 316 | |
---|
| 317 | do i = 1, len(xf%dict) |
---|
| 318 | call get_key(xf%dict,i,key,status) |
---|
| 319 | call get_value(xf%dict,key,value,status) |
---|
| 320 | key = adjustl(key) |
---|
| 321 | value = adjustl(value) |
---|
| 322 | size = len_trim(key) + len_trim(value) + 4 |
---|
| 323 | if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf) |
---|
| 324 | call add_to_buffer(" ", xf%buffer) |
---|
| 325 | call add_to_buffer(trim(key), xf%buffer) |
---|
| 326 | call add_to_buffer("=", xf%buffer) |
---|
| 327 | call add_to_buffer("""",xf%buffer) |
---|
| 328 | call add_to_buffer(trim(value), xf%buffer) |
---|
| 329 | call add_to_buffer("""", xf%buffer) |
---|
| 330 | enddo |
---|
| 331 | |
---|
| 332 | end subroutine write_attributes |
---|
| 333 | |
---|
| 334 | !--------------------------------------------------------------- |
---|
| 335 | subroutine xml_AddArray_integer(xf,a,format) |
---|
| 336 | type(xmlf_t), intent(inout) :: xf |
---|
| 337 | integer, intent(in), dimension(:) :: a |
---|
| 338 | character(len=*), intent(in), optional :: format |
---|
| 339 | |
---|
| 340 | call close_start_tag(xf,">") |
---|
| 341 | if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.) |
---|
| 342 | if (present(format)) then |
---|
| 343 | write(xf%lun,format) a |
---|
| 344 | else |
---|
| 345 | write(xf%lun,"(6(i12))") a |
---|
| 346 | endif |
---|
| 347 | end subroutine xml_AddArray_integer |
---|
| 348 | |
---|
| 349 | !------------------------------------------------------------------- |
---|
| 350 | subroutine xml_AddArray_real_dp(xf,a,format) |
---|
| 351 | type(xmlf_t), intent(inout) :: xf |
---|
| 352 | real(kind=dp), intent(in), dimension(:) :: a |
---|
| 353 | character(len=*), intent(in), optional :: format |
---|
| 354 | |
---|
| 355 | call close_start_tag(xf,">") |
---|
| 356 | if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.) |
---|
| 357 | if (present(format)) then |
---|
| 358 | write(xf%lun,format) a |
---|
| 359 | else |
---|
| 360 | write(xf%lun,"(4(es20.12))") a |
---|
| 361 | endif |
---|
| 362 | end subroutine xml_AddArray_real_dp |
---|
| 363 | |
---|
| 364 | !------------------------------------------------------------------ |
---|
| 365 | subroutine xml_AddArray_real_sp(xf,a,format) |
---|
| 366 | type(xmlf_t), intent(inout) :: xf |
---|
| 367 | real(kind=sp), intent(in), dimension(:) :: a |
---|
| 368 | character(len=*), intent(in), optional :: format |
---|
| 369 | |
---|
| 370 | call close_start_tag(xf,">") |
---|
| 371 | if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.) |
---|
| 372 | if (present(format)) then |
---|
| 373 | write(xf%lun,format) a |
---|
| 374 | else |
---|
| 375 | write(xf%lun,"(4(es20.12))") a |
---|
| 376 | endif |
---|
| 377 | end subroutine xml_AddArray_real_sp |
---|
| 378 | |
---|
| 379 | end module m_wxml_core |
---|
| 380 | |
---|