1module m_common_element 2 3#ifndef DUMMYLIB 4 ! Structure and manipulation of element specification 5 6 use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc 7 use fox_m_fsys_string_list, only: string_list, init_string_list, & 8 destroy_string_list, add_string, tokenize_to_string_list, & 9 registered_string 10 use m_common_charset, only: isInitialNameChar, isNameChar, & 11 upperCase, XML_WHITESPACE 12 use m_common_content_model, only: content_particle_t, newCP, destroyCPtree, & 13 OP_MIXED, OP_CHOICE, OP_SEQ, OP_NAME, & 14 REP_QUESTION_MARK, REP_ASTERISK, & 15 transformCPPlus ! , dumpCPtree ! For debugging - see below. 16 use m_common_error, only: error_stack, add_error, in_error 17 use m_common_namecheck, only: checkName, checkNames, checkNCName, & 18 checkNCNames, checkQName, checkNmtoken, checkNmtokens 19 20 implicit none 21 private 22 23 integer, parameter :: ST_START = 0 24 integer, parameter :: ST_EMPTYANY = 1 25 integer, parameter :: ST_FIRSTCHILD = 2 26 integer, parameter :: ST_END = 3 27 integer, parameter :: ST_PCDATA = 4 28 integer, parameter :: ST_NAME = 5 29 integer, parameter :: ST_CHILD = 6 30 integer, parameter :: ST_AFTERBRACKET = 7 31 integer, parameter :: ST_AFTERLASTBRACKET = 8 32 integer, parameter :: ST_SEPARATOR = 9 33 integer, parameter :: ST_AFTERNAME = 10 34 integer, parameter :: ST_ATTTYPE = 11 35 integer, parameter :: ST_AFTER_NOTATION = 12 36 integer, parameter :: ST_NOTATION_LIST = 13 37 integer, parameter :: ST_ENUMERATION = 14 38 integer, parameter :: ST_ENUM_NAME = 15 39 integer, parameter :: ST_AFTER_ATTTYPE_SPACE = 16 40 integer, parameter :: ST_AFTER_ATTTYPE = 17 41 integer, parameter :: ST_DEFAULT_DECL = 18 42 integer, parameter :: ST_AFTERDEFAULTDECL = 19 43 integer, parameter :: ST_DEFAULTVALUE = 20 44 45 integer, parameter :: ATT_NULL = 0 46 47 integer, parameter :: ATT_CDATA = 1 48 integer, parameter :: ATT_ID = 2 49 integer, parameter :: ATT_IDREF = 3 50 integer, parameter :: ATT_IDREFS = 4 51 integer, parameter :: ATT_ENTITY = 5 52 integer, parameter :: ATT_ENTITIES = 6 53 integer, parameter :: ATT_NMTOKEN = 7 54 integer, parameter :: ATT_NMTOKENS = 8 55 integer, parameter :: ATT_NOTATION = 9 56 integer, parameter :: ATT_ENUM = 10 57 integer, parameter :: ATT_CDANO = 11 58 integer, parameter :: ATT_CDAMB = 12 59 60 character(len=8), parameter :: ATT_TYPES(12) = (/ & 61 "CDATA ", & 62 "ID ", & 63 "IDREF ", & 64 "IDREFS ", & 65 "ENTITY ", & 66 "ENTITIES", & 67 "NMTOKEN ", & 68 "NMTOKENS", & 69 "NOTATION", & 70 "ENUM ", & 71 "CDANO ", & 72 "CDAMB "/) 73 74 integer, parameter :: ATT_REQUIRED = 1 75 integer, parameter :: ATT_IMPLIED = 2 76 integer, parameter :: ATT_DEFAULT = 4 77 integer, parameter :: ATT_FIXED = 3 78 79 80 type attribute_t 81 character, pointer :: name(:) => null() 82 integer :: attType = ATT_NULL 83 integer :: attDefault = ATT_NULL 84 type(string_list) :: enumerations 85 character, pointer :: default(:) => null() 86 logical :: internal = .true. 87 end type attribute_t 88 89 type attribute_list 90 type(attribute_t), pointer :: list(:) => null() 91 end type attribute_list 92 93 type element_t 94 character, pointer :: name(:) => null() 95 logical :: empty = .false. 96 logical :: any = .false. 97 logical :: mixed = .false. 98 logical :: id_declared = .false. 99 logical :: internal = .true. 100 type (content_particle_t), pointer :: cp => null() 101 character, pointer :: model(:) => null() 102 type(attribute_list) :: attlist 103 end type element_t 104 105 type element_list 106 type(element_t), pointer :: list(:) => null() 107 end type element_list 108 109 110 public :: element_t 111 public :: element_list 112 113 public :: attribute_t 114 public :: attribute_list 115 116 public :: init_element_list 117 public :: destroy_element_list 118 public :: existing_element 119 public :: declared_element 120 public :: get_element 121 public :: add_element 122 123 public :: parse_dtd_element 124 125 public :: init_attribute_list 126 public :: destroy_attribute_list 127 128 129 public :: parse_dtd_attlist 130 131 public :: report_declarations 132 133 public :: attribute_has_default 134 public :: get_attlist_size 135 public :: get_attribute_declaration 136 public :: express_attribute_declaration 137 138 public :: att_value_normalize 139 140 public :: get_att_type_enum 141 142 public :: ATT_NULL 143 public :: ATT_CDATA 144 public :: ATT_ID 145 public :: ATT_IDREF 146 public :: ATT_IDREFS 147 public :: ATT_ENTITY 148 public :: ATT_ENTITIES 149 public :: ATT_NMTOKEN 150 public :: ATT_NMTOKENS 151 public :: ATT_NOTATION 152 public :: ATT_ENUM 153 154 public :: ATT_CDANO 155 public :: ATT_CDAMB 156 157 public :: ATT_REQUIRED 158 public :: ATT_IMPLIED 159 public :: ATT_DEFAULT 160 public :: ATT_FIXED 161 162 public :: ATT_TYPES 163 164 interface get_attribute_declaration 165 module procedure get_attdecl_by_index 166 module procedure get_attdecl_by_name 167 end interface 168 169contains 170 171 subroutine init_element_list(e_list) 172 type(element_list), intent(inout) :: e_list 173 174 allocate(e_list%list(0)) 175 end subroutine init_element_list 176 177 subroutine destroy_element_list(e_list) 178 type(element_list), intent(inout) :: e_list 179 180 integer :: i 181 182 do i = 1, size(e_list%list) 183 deallocate(e_list%list(i)%name) 184 if (associated(e_list%list(i)%cp)) call destroyCPtree(e_list%list(i)%cp) 185 if (associated(e_list%list(i)%model)) deallocate(e_list%list(i)%model) 186 call destroy_attribute_list(e_list%list(i)%attlist) 187 enddo 188 deallocate(e_list%list) 189 end subroutine destroy_element_list 190 191 function existing_element(e_list, name) result(p) 192 type(element_list), intent(in) :: e_list 193 character(len=*), intent(in) :: name 194 logical :: p 195 196 integer :: i 197 198 p = .false. 199 do i = 1, size(e_list%list) 200 if (str_vs(e_list%list(i)%name)==name) then 201 p = .true. 202 exit 203 endif 204 enddo 205 end function existing_element 206 207 function declared_element(e_list, name) result(p) 208 type(element_list), intent(in) :: e_list 209 character(len=*), intent(in) :: name 210 logical :: p 211 212 integer :: i 213 214 p = .false. 215 do i = 1, size(e_list%list) 216 if (str_vs(e_list%list(i)%name)==name) then 217 p = associated(e_list%list(i)%model) 218 exit 219 endif 220 enddo 221 end function declared_element 222 223 function get_element(e_list, name) result(e) 224 type(element_list), intent(in) :: e_list 225 character(len=*), intent(in) :: name 226 type(element_t), pointer :: e 227 228 integer :: i 229 230 do i = 1, size(e_list%list) 231 if (str_vs(e_list%list(i)%name)==name) then 232 e => e_list%list(i) 233 return 234 endif 235 enddo 236 e => null() 237 end function get_element 238 239 function add_element(e_list, name) result(e) 240 type(element_list), intent(inout) :: e_list 241 character(len=*), intent(in) :: name 242 type(element_t), pointer :: e 243 244 type(element_t), pointer :: temp(:) 245 integer :: i 246 247 temp => e_list%list 248 249 allocate(e_list%list(size(temp)+1)) 250 do i = 1, size(temp) 251 e_list%list(i)%name => temp(i)%name 252 e_list%list(i)%model => temp(i)%model 253 e_list%list(i)%empty = temp(i)%empty 254 e_list%list(i)%any = temp(i)%any 255 e_list%list(i)%mixed = temp(i)%mixed 256 e_list%list(i)%cp => temp(i)%cp 257 e_list%list(i)%id_declared = temp(i)%id_declared 258 e_list%list(i)%internal = temp(i)%internal 259 e_list%list(i)%attlist%list => temp(i)%attlist%list 260 enddo 261 deallocate(temp) 262 e => e_list%list(i) 263 e%name => vs_str_alloc(name) 264 call init_attribute_list(e%attlist) 265 266 end function add_element 267 268 subroutine parse_dtd_element(contents, xv, stack, element, internal) 269 character(len=*), intent(in) :: contents 270 integer, intent(in) :: xv 271 type(error_stack), intent(inout) :: stack 272 type(element_t), pointer :: element 273 logical, intent(in) :: internal 274 275 integer :: state 276 integer :: i, nbrackets 277 logical :: mixed, empty, any 278 character :: c 279 character, pointer :: order(:), name(:), temp(:) 280 type(content_particle_t), pointer :: top, current, tcp 281 logical :: mixed_additional, firstChild 282 283 ! FIXME should we check namespaces here (for element names) 284 ! checking duplicates - valid or wf? - and only for MIXED? 285 286 order => null() 287 name => null() 288 temp => null() 289 290 any = .false. 291 empty = .false. 292 mixed = .false. 293 nbrackets = 0 294 mixed_additional = .false. 295 firstChild = .true. 296 state = ST_START 297 298 top => null() 299 300 do i = 1, len(contents) + 1 301 if (i<=len(contents)) then 302 c = contents(i:i) 303 else 304 c = ' ' 305 endif 306 307 if (state==ST_START) then 308 !write(*,*)'ST_START' 309 if (verify(c, XML_WHITESPACE)==0) then 310 continue 311 elseif (verify(c, 'EMPTYANY')==0) then 312 name => vs_str_alloc(c) 313 state = ST_EMPTYANY 314 elseif (c=='(') then 315 order => vs_str_alloc(" ") 316 nbrackets = 1 317 top => newCP() 318 current => top 319 state = ST_FIRSTCHILD 320 else 321 call add_error(stack, & 322 'Unexpected character "'//c//'" at start of ELEMENT specification') 323 goto 100 324 endif 325 326 elseif (state==ST_EMPTYANY) then 327 !write(*,*)'ST_EMPTYANY' 328 if (verify(c, upperCase)==0) then 329 temp => name 330 name => vs_str_alloc(str_vs(temp)//c) 331 deallocate(temp) 332 elseif (verify(c, XML_WHITESPACE)==0) then 333 if (str_vs(name)=='EMPTY') then 334 empty = .true. 335 top => newCP(empty=.true.) 336 current => top 337 elseif (str_vs(name)=='ANY') then 338 any = .true. 339 top => newCP(any=.true.) 340 current => top 341 else 342 call add_error(stack, & 343 'Unexpected ELEMENT specification; expecting EMPTY or ANY') 344 goto 100 345 endif 346 deallocate(name) 347 state = ST_END 348 else 349 call add_error(stack, & 350 'Unexpected ELEMENT specification; expecting EMPTY or ANY') 351 goto 100 352 endif 353 354 elseif (state==ST_FIRSTCHILD) then 355 !write(*,*)'ST_FIRSTCHILD' 356 if (verify(c, XML_WHITESPACE)==0) cycle 357 if (c=='#') then 358 mixed = .true. 359 state = ST_PCDATA 360 name => vs_str_alloc("") 361 elseif (isInitialNameChar(c, xv)) then 362 allocate(name(1)) 363 name(1) = c 364 state = ST_NAME 365 elseif (c=='(') then 366 nbrackets = nbrackets + 1 367 deallocate(order) 368 tcp => newCP() 369 current%firstChild => tcp 370 tcp%parent => current 371 current => tcp 372 order => vs_str_alloc(" ") 373 state = ST_CHILD 374 else 375 call add_error(stack, & 376 'Unexpected character in ELEMENT specification') 377 goto 100 378 endif 379 380 elseif (state==ST_PCDATA) then 381 !write(*,*)'ST_PCDATA' 382 if (verify(c, 'PCDATA')==0) then 383 temp => name 384 name => vs_str_alloc(str_vs(temp)//c) 385 deallocate(temp) 386 elseif (verify(c, XML_WHITESPACE)==0) then 387 if (str_vs(name)=='PCDATA') then 388 deallocate(name) 389 else 390 call add_error(stack, & 391 'Unexpected token after #') 392 goto 100 393 endif 394 ! Must be first child 395 current%operator = OP_MIXED 396 tcp => newCP(name="#PCDATA") 397 current%firstChild => tcp 398 tcp%parent => current 399 current => tcp 400 firstChild = .false. 401 state = ST_SEPARATOR 402 elseif (c==')') then 403 if (str_vs(name)=='PCDATA') then 404 deallocate(name) 405 nbrackets = 0 406 state = ST_AFTERLASTBRACKET 407 deallocate(order) 408 else 409 call add_error(stack, & 410 'Unexpected token after #') 411 goto 100 412 endif 413 ! Must be first child 414 current%operator = OP_MIXED 415 tcp => newCP(name="#PCDATA") 416 current%firstChild => tcp 417 tcp%parent => current 418 firstChild = .false. 419 elseif (c=='|') then 420 if (str_vs(name)=='PCDATA') then 421 firstChild = .false. 422 deallocate(name) 423 else 424 call add_error(stack, & 425 'Unexpected token after #') 426 goto 100 427 endif 428 ! Must be first child 429 current%operator = OP_MIXED 430 tcp => newCP(name="#PCDATA") 431 current%firstChild => tcp 432 tcp%parent => current 433 current => tcp 434 firstChild = .false. 435 order(1) = '|' 436 state = ST_CHILD 437 elseif (c==',') then 438 call add_error(stack, & 439 'Ordered specification not allowed for Mixed elements') 440 goto 100 441 else 442 call add_error(stack, & 443 'Unexpected character in ELEMENT specification') 444 goto 100 445 endif 446 447 elseif (state==ST_NAME) then 448 !write(*,*)'ST_NAME' 449 if (isNameChar(c, xv)) then 450 temp => name 451 name => vs_str_alloc(str_vs(temp)//c) 452 deallocate(temp) 453 elseif (scan(c, "?+*")>0) then 454 if (mixed) then 455 call add_error(stack, & 456 'Repeat operators forbidden for Mixed elements') 457 goto 100 458 endif 459 tcp => newCP(name=str_vs(name), repeat=c) 460 deallocate(name) 461 if (firstChild) then 462 current%firstChild => tcp 463 tcp%parent => current 464 firstChild = .false. 465 else 466 current%nextSibling => tcp 467 tcp%parent => current%parent 468 endif 469 current => tcp 470 if (c=="+") call transformCPPlus(current) 471 state = ST_SEPARATOR 472 elseif (verify(c, XML_WHITESPACE)==0) then 473 if (mixed) mixed_additional = .true. 474 tcp => newCP(name=str_vs(name)) 475 deallocate(name) 476 if (firstChild) then 477 current%firstChild => tcp 478 tcp%parent => current 479 firstChild = .false. 480 else 481 current%nextSibling => tcp 482 tcp%parent => current%parent 483 endif 484 current => tcp 485 state = ST_SEPARATOR 486 elseif (scan(c,',|')>0) then 487 if (order(nbrackets)=='') then 488 order(nbrackets)=c 489 elseif (order(nbrackets)/=c) then 490 call add_error(stack, & 491 'Cannot mix ordered and unordered elements') 492 goto 100 493 endif 494 if (mixed) mixed_additional = .true. 495 tcp => newCP(name=str_vs(name)) 496 deallocate(name) 497 if (firstChild) then 498 current%firstChild => tcp 499 tcp%parent => current 500 firstChild = .false. 501 else 502 current%nextSibling => tcp 503 tcp%parent => current%parent 504 endif 505 current => tcp 506 if (c=="|".and.current%parent%operator/=OP_MIXED) & 507 current%parent%operator = OP_CHOICE 508 state = ST_CHILD 509 elseif (c==')') then 510 if (mixed) mixed_additional = .true. 511 nbrackets = nbrackets - 1 512 if (nbrackets==0) then 513 state = ST_AFTERLASTBRACKET 514 deallocate(order) 515 else 516 temp => order 517 allocate(order(nbrackets)) 518 order = temp(:size(order)) 519 deallocate(temp) 520 state = ST_AFTERBRACKET 521 endif 522 tcp => newCP(name=str_vs(name)) 523 deallocate(name) 524 if (firstChild) then 525 current%firstChild => tcp 526 tcp%parent => current 527 firstChild = .false. 528 else 529 current%nextSibling => tcp 530 tcp%parent => current%parent 531 current => current%parent 532 if (.not.check_duplicates(current)) & 533 goto 100 534 endif 535 else 536 call add_error(stack, & 537 'Unexpected character found after element name') 538 goto 100 539 endif 540 541 elseif (state==ST_CHILD) then 542 !write(*,*)'ST_CHILD' 543 if (verify(c, XML_WHITESPACE)==0) cycle 544 if (c=='#') then 545 call add_error(stack, & 546 '# forbidden except as first child element') 547 goto 100 548 elseif (isInitialNameChar(c, xv)) then 549 name => vs_str_alloc(c) 550 state = ST_NAME 551 elseif (c=='(') then 552 if (mixed) then 553 call add_error(stack, & 554 'Nested brackets forbidden for Mixed content') 555 goto 100 556 endif 557 tcp => newCP() 558 if (firstChild) then 559 current%firstChild => tcp 560 tcp%parent => current 561 else 562 current%nextSibling => tcp 563 tcp%parent => current%parent 564 firstChild = .true. 565 endif 566 current => tcp 567 nbrackets = nbrackets + 1 568 temp => order 569 order => vs_str_alloc(str_vs(temp)//" ") 570 deallocate(temp) 571 else 572 call add_error(stack, & 573 'Unexpected character "'//c//'" found after (') 574 goto 100 575 endif 576 577 elseif (state==ST_SEPARATOR) then 578 !write(*,*)'ST_SEPARATOR' 579 if (verify(c, XML_WHITESPACE)==0) cycle 580 if (c=='#') then 581 call add_error(stack, & 582 '#PCDATA must be first in list') 583 goto 100 584 elseif (scan(c,'|,')>0) then 585 if (order(nbrackets)=='') then 586 order(nbrackets) = c 587 elseif (order(nbrackets)/=c) then 588 call add_error(stack, & 589 'Cannot mix ordered and unordered elements') 590 goto 100 591 endif 592 if (c=="|".and.current%parent%operator/=OP_MIXED) & 593 current%parent%operator = OP_CHOICE 594 state = ST_CHILD 595 elseif (c==')') then 596 nbrackets = nbrackets - 1 597 if (nbrackets==0) then 598 state = ST_AFTERLASTBRACKET 599 deallocate(order) 600 else 601 temp => order 602 allocate(order(nbrackets)) 603 order = temp(:size(order)) 604 deallocate(temp) 605 state = ST_AFTERBRACKET 606 endif 607 current => current%parent 608 if (.not.check_duplicates(current)) & 609 goto 100 610 else 611 call add_error(stack, & 612 'Unexpected character found in element declaration.') 613 goto 100 614 endif 615 616 elseif (state==ST_AFTERBRACKET) then 617 !write(*,*)'ST_AFTERBRACKET' 618 if (c=='*') then 619 current%repeater = REP_ASTERISK 620 state = ST_SEPARATOR 621 elseif (c=='+') then 622 call transformCPPlus(current) 623 state = ST_SEPARATOR 624 elseif (c=='?') then 625 current%repeater = REP_QUESTION_MARK 626 state = ST_SEPARATOR 627 elseif (verify(c, XML_WHITESPACE)==0) then 628 state = ST_SEPARATOR 629 elseif (scan(c,'|,')>0) then 630 if (order(nbrackets)=='') then 631 order(nbrackets) = c 632 elseif (order(nbrackets)/=c) then 633 call add_error(stack, & 634 'Cannot mix ordered and unordered elements') 635 goto 100 636 endif 637 if (c=="|".and.current%parent%operator/=OP_MIXED) & 638 current%parent%operator = OP_CHOICE 639 state = ST_CHILD 640 elseif (c==')') then 641 nbrackets = nbrackets - 1 642 if (nbrackets==0) then 643 deallocate(order) 644 state = ST_AFTERLASTBRACKET 645 else 646 temp => order 647 allocate(order(nbrackets)) 648 order = temp(:size(order)) 649 deallocate(temp) 650 state = ST_AFTERBRACKET 651 endif 652 current => current%parent 653 if (.not.check_duplicates(current)) & 654 goto 100 655 else 656 call add_error(stack, & 657 'Unexpected character "'//c//'"found after ")"') 658 goto 100 659 endif 660 661 elseif (state==ST_AFTERLASTBRACKET) then 662 !write(*,*)'ST_AFTERLASTBRACKET' 663 if (c=='*') then 664 state = ST_END 665 current%repeater = REP_ASTERISK 666 elseif (c=='+') then 667 if (mixed) then 668 call add_error(stack, & 669 '+ operator disallowed for Mixed elements') 670 goto 100 671 endif 672 call transformCPPlus(current) 673 state = ST_END 674 elseif (c=='?') then 675 if (mixed) then 676 call add_error(stack, & 677 '? operator disallowed for Mixed elements') 678 goto 100 679 endif 680 current%repeater = REP_QUESTION_MARK 681 state = ST_END 682 elseif (verify(c, XML_WHITESPACE)==0) then 683 if (mixed) then 684 if (mixed_additional) then 685 call add_error(stack, & 686 'Missing "*" at end of Mixed element specification') 687 goto 100 688 endif 689 endif 690 state = ST_END 691 else 692 call add_error(stack, & 693 'Unexpected character "'//c//'" found after final ")"') 694 goto 100 695 endif 696 697 elseif (state==ST_END) then 698 !write(*,*)'ST_END' 699 if (verify(c, XML_WHITESPACE)==0) then 700 continue 701 else 702 call add_error(stack, & 703 'Unexpected token found after end of element specification') 704 goto 100 705 endif 706 707 endif 708 709 enddo 710 711 if (state/=ST_END) then 712 call add_error(stack, "Error in parsing contents of element declaration") 713 goto 100 714 endif 715 716 if (associated(element)) then 717 element%any = any 718 element%empty = empty 719 element%mixed = mixed 720 element%model => vs_str_alloc(trim(strip_spaces(contents))) 721 element%cp => top 722 element%internal = internal 723! For debugging it may be useful to dump the result here... 724! Also need to use the subroutine. 725! call dumpCPtree(top) 726 else 727 if (associated(top)) call destroyCPtree(top) 728 endif 729 return 730 731100 if (associated(order)) deallocate(order) 732 if (associated(name)) deallocate(name) 733 if (associated(top)) call destroyCPtree(top) 734 735 contains 736 function strip_spaces(s1) result(s2) 737 character(len=*) :: s1 738 character(len=len(s1)) :: s2 739 integer :: i, i2 740 i2 = 1 741 do i = 1, len(s1) 742 if (verify(s1(i:i), XML_WHITESPACE)==0) cycle 743 s2(i2:i2) = s1(i:i) 744 i2 = i2 + 1 745 end do 746 s2(i2:) = '' 747 end function strip_spaces 748 749 function check_duplicates(cp) result(p) 750 type(content_particle_t), pointer :: cp 751 logical :: p 752 753 type(string_list) :: sl 754 type(content_particle_t), pointer :: tcp 755 756 if (cp%operator==OP_SEQ) then 757 p = .true. 758 return 759 endif 760 761 call init_string_list(sl) 762 tcp => cp%firstChild 763 p = .false. 764 do while (associated(tcp)) 765 if (tcp%operator==OP_NAME) then 766 if (registered_string(sl, str_vs(tcp%name))) then 767 call destroy_string_list(sl) 768 if (cp%operator==OP_MIXED) then 769 call add_error(stack, & 770 "Duplicate element names found in MIXED") 771 elseif (cp%operator==OP_CHOICE) then 772 call add_error(stack, & 773 "Duplicate element names found in CHOICE") 774 endif 775 return 776 else 777 call add_string(sl, str_vs(tcp%name)) 778 endif 779 endif 780 tcp => tcp%nextSibling 781 enddo 782 p = .true. 783 call destroy_string_list(sl) 784 end function check_duplicates 785 end subroutine parse_dtd_element 786 787 788 subroutine init_attribute_list(a_list) 789 type(attribute_list), intent(inout) :: a_list 790 791 allocate(a_list%list(0)) 792 end subroutine init_attribute_list 793 794 subroutine destroy_attribute_t(a) 795 type(attribute_t), pointer :: a 796 797 if (associated(a%name)) deallocate(a%name) 798 if (associated(a%default)) deallocate(a%default) 799 call destroy_string_list(a%enumerations) 800 801 deallocate(a) 802 end subroutine destroy_attribute_t 803 804 subroutine destroy_attribute_list(a_list) 805 type(attribute_list), intent(inout) :: a_list 806 807 integer :: i 808 809 do i = 1, size(a_list%list) 810 deallocate(a_list%list(i)%name) 811 if (associated(a_list%list(i)%default)) deallocate(a_list%list(i)%default) 812 call destroy_string_list(a_list%list(i)%enumerations) 813 enddo 814 deallocate(a_list%list) 815 816 end subroutine destroy_attribute_list 817 818 function existing_attribute(a_list, name) result(p) 819 type(attribute_list), intent(inout) :: a_list 820 character(len=*), intent(in) :: name 821 logical :: p 822 823 integer :: i 824 p = .false. 825 do i = 1, size(a_list%list) 826 p = (str_vs(a_list%list(i)%name)==name) 827 if (p) exit 828 enddo 829 end function existing_attribute 830 831 function add_attribute(a_list, name, internal) result(a) 832 type(attribute_list), intent(inout) :: a_list 833 character(len=*), intent(in) :: name 834 logical, intent(in) :: internal 835 type(attribute_t), pointer :: a 836 837 integer :: i 838 type(attribute_t), pointer :: temp(:) 839 840 temp => a_list%list 841 allocate(a_list%list(size(temp)+1)) 842 do i = 1, size(temp) 843 a_list%list(i)%name => temp(i)%name 844 a_list%list(i)%atttype = temp(i)%atttype 845 a_list%list(i)%attdefault = temp(i)%attdefault 846 a_list%list(i)%default => temp(i)%default 847 a_list%list(i)%enumerations%list => temp(i)%enumerations%list 848 a_list%list(i)%internal = temp(i)%internal 849 enddo 850 deallocate(temp) 851 a => a_list%list(i) 852 853 a%name => vs_str_alloc(name) 854 call init_string_list(a%enumerations) 855 a%internal = internal 856 857 end function add_attribute 858 859 function get_attribute(a_list, name) result(a) 860 type(attribute_list), intent(inout) :: a_list 861 character(len=*), intent(in) :: name 862 type(attribute_t), pointer :: a 863 864 integer :: i 865 do i = 1, size(a_list%list) 866 if (str_vs(a_list%list(i)%name)==name) then 867 a => a_list%list(i) 868 exit 869 endif 870 enddo 871 end function get_attribute 872 873 subroutine parse_dtd_attlist(contents, xv, namespaces, validCheck, stack, elem, internal) 874 character(len=*), intent(in) :: contents 875 integer, intent(in) :: xv 876 logical, intent(in) :: validCheck 877 logical, intent(in) :: namespaces 878 type(error_stack), intent(inout) :: stack 879 type(element_t), pointer :: elem 880 logical, intent(in) :: internal 881 882 integer :: i 883 integer :: state 884 character :: c, q 885 character, pointer :: name(:), attType(:), default(:), value(:), temp(:) 886 887 type(attribute_t), pointer :: ca 888 type(attribute_t), pointer :: ignore_att 889 890 ignore_att => null() 891 ! We need ignore_att to process but not take account of duplicate attributes 892 ! elem is optional so we can not record declarations if necessary. 893 ca => null() 894 name => null() 895 attType => null() 896 default => null() 897 value => null() 898 temp => null() 899 900 state = ST_START 901 902 do i = 1, len(contents) + 1 903 if (in_error(stack)) exit 904 if (i<=len(contents)) then 905 c = contents(i:i) 906 else 907 c = " " 908 endif 909 910 if (state==ST_START) then 911 !write(*,*)'ST_START' 912 if (verify(c, XML_WHITESPACE)==0) cycle 913 if (isInitialNameChar(c, xv)) then 914 name => vs_str_alloc(c) 915 state = ST_NAME 916 else 917 call add_error(stack, & 918 'Unexpected character in Attlist') 919 endif 920 921 elseif (state==ST_NAME) then 922 !write(*,*)'ST_NAME' 923 if (isNameChar(c, xv)) then 924 temp => vs_str_alloc(str_vs(name)//c) 925 deallocate(name) 926 name => temp 927 elseif (verify(c, XML_WHITESPACE)==0) then 928 if (namespaces.and..not.checkQName(str_vs(name), xv)) then 929 call add_error(stack, & 930 "Attribute name in ATTLIST must be QName") 931 elseif (associated(elem)) then 932 if (existing_attribute(elem%attlist, str_vs(name))) then 933 if (associated(ignore_att)) call destroy_attribute_t(ignore_att) 934 allocate(ignore_att) 935 call init_string_list(ignore_att%enumerations) 936 ignore_att%name => vs_vs_alloc(name) 937 ca => ignore_att 938 else 939 ca => add_attribute(elem%attlist, str_vs(name), internal) 940 endif 941 else 942 if (associated(ignore_att)) call destroy_attribute_t(ignore_att) 943 allocate(ignore_att) 944 call init_string_list(ignore_att%enumerations) 945 ignore_att%name => vs_vs_alloc(name) 946 ca => ignore_att 947 endif 948 deallocate(name) 949 state = ST_AFTERNAME 950 else 951 call add_error(stack, & 952 'Unexpected character in Attlist Name') 953 endif 954 955 elseif (state==ST_AFTERNAME) then 956 !write(*,*)'ST_AFTERNAME' 957 if (verify(c, XML_WHITESPACE)==0) cycle 958 if (verify(c, upperCase)==0) then 959 attType => vs_str_alloc(c) 960 state = ST_ATTTYPE 961 elseif (c=='(') then 962 allocate(value(0)) 963 ca%attType = ATT_ENUM 964 state = ST_ENUMERATION 965 else 966 call add_error(stack, & 967 'Unexpected error after Attlist Name') 968 endif 969 970 elseif (state==ST_ATTTYPE) then 971 !write(*,*)'ST_ATTTYPE' 972 if (verify(c, upperCase)==0) then 973 temp => attType 974 attType => vs_str_alloc(str_vs(temp)//c) 975 deallocate(temp) 976 elseif (verify(c, XML_WHITESPACE)==0) then 977 ! xml:id constraint 978 if (str_vs(ca%name)=="xml:id" & 979 .and..not.str_vs(attType)=="ID") then 980 call add_error(stack, & 981 "xml:id attribute must be declared as type ID") 982 elseif (str_vs(attType)=='CDATA') then 983 ca%attType = ATT_CDATA 984 state = ST_AFTER_ATTTYPE 985 elseif (str_vs(attType)=='ID') then 986 if (validCheck) then 987 ! Validity Constraint: One ID per Element Type 988 if (associated(elem)) then 989 if (elem%id_declared) then 990 call add_error(stack, & 991 "Cannot have two declared attributes of type ID on one element type.") 992 else 993 elem%id_declared = .true. 994 endif 995 endif 996 endif 997 ca%attType = ATT_ID 998 state = ST_AFTER_ATTTYPE 999 elseif (str_vs(attType)=='IDREF') then 1000 ca%attType = ATT_IDREF 1001 state = ST_AFTER_ATTTYPE 1002 elseif (str_vs(attType)=='IDREFS') then 1003 ca%attType = ATT_IDREFS 1004 state = ST_AFTER_ATTTYPE 1005 elseif (str_vs(attType)=='ENTITY') then 1006 ca%attType = ATT_ENTITY 1007 state = ST_AFTER_ATTTYPE 1008 elseif (str_vs(attType)=='ENTITIES') then 1009 ca%attType = ATT_ENTITIES 1010 state = ST_AFTER_ATTTYPE 1011 elseif (str_vs(attType)=='NMTOKEN') then 1012 ca%attType = ATT_NMTOKEN 1013 state = ST_AFTER_ATTTYPE 1014 elseif (str_vs(attType)=='NMTOKENS') then 1015 ca%attType = ATT_NMTOKENS 1016 state = ST_AFTER_ATTTYPE 1017 elseif (str_vs(attType)=='NOTATION') then 1018 ca%attType = ATT_NOTATION 1019 state = ST_AFTER_NOTATION 1020 else 1021 call add_error(stack, & 1022 'Unknown AttType') 1023 endif 1024 deallocate(attType) 1025 else 1026 call add_error(stack, & 1027 'Unexpected character in AttType') 1028 endif 1029 1030 elseif (state==ST_AFTER_NOTATION) then 1031 !write(*,*)'ST_AFTER_NOTATION' 1032 if (verify(c, XML_WHITESPACE)==0) cycle 1033 if (c=='(') then 1034 state = ST_NOTATION_LIST 1035 else 1036 call add_error(stack, & 1037 'Unexpected character after Notation') 1038 endif 1039 1040 elseif (state==ST_NOTATION_LIST) then 1041 !write(*,*)'ST_NOTATION_LIST' 1042 if (verify(c, XML_WHITESPACE)==0) cycle 1043 if (isInitialNameChar(c, xv)) then 1044 value => vs_str_alloc(c) 1045 state = ST_ENUM_NAME 1046 else 1047 call add_error(stack, & 1048 'Unexpected character in Notation list') 1049 endif 1050 1051 elseif (state==ST_ENUMERATION) then 1052 !write(*,*)'ST_ENUMERATION' 1053 if (verify(c, XML_WHITESPACE)==0) cycle 1054 if (isNameChar(c, xv)) then 1055 temp => vs_str_alloc(str_vs(value)//c) 1056 deallocate(value) 1057 value => temp 1058 state = ST_ENUM_NAME 1059 elseif (c=='|') then 1060 call add_error(stack, & 1061 "Missing token in Enumeration") 1062 elseif (c==')') then 1063 call add_error(stack, & 1064 "Missing tokens in Enumeration") 1065 else 1066 call add_error(stack, & 1067 'Unexpected character in attlist enumeration') 1068 endif 1069 1070 elseif (state==ST_ENUM_NAME) then 1071 !write(*,*)'ST_ENUM_NAME' 1072 if (isNameChar(c, xv)) then 1073 temp => vs_str_alloc(str_vs(value)//c) 1074 deallocate(value) 1075 value => temp 1076 elseif (verify(c, XML_WHITESPACE)==0) then 1077 if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then 1078 call add_error(stack, & 1079 "Duplicate enumeration value in ATTLIST") 1080 elseif (namespaces.and.ca%attType==ATT_NOTATION & 1081 .and..not.checkNCName(str_vs(value), xv)) then 1082 call add_error(stack, & 1083 "Notation name must be NCName") 1084 else 1085 call add_string(ca%enumerations, str_vs(value)) 1086 endif 1087 deallocate(value) 1088 state = ST_SEPARATOR 1089 elseif (c=='|') then 1090 if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then 1091 call add_error(stack, & 1092 "Duplicate enumeration value in ATTLIST") 1093 elseif (namespaces.and.ca%attType==ATT_NOTATION & 1094 .and..not.checkNCName(str_vs(value), xv)) then 1095 call add_error(stack, & 1096 "Notation name must be NCName") 1097 else 1098 call add_string(ca%enumerations, str_vs(value)) 1099 endif 1100 deallocate(value) 1101 if (ca%attType==ATT_NOTATION) then 1102 state = ST_NOTATION_LIST 1103 else 1104 allocate(value(0)) 1105 state = ST_ENUMERATION 1106 endif 1107 elseif (c==')') then 1108 if (size(value)==0) then 1109 call add_error(stack, & 1110 'Missing token in Enumeration list') 1111 endif 1112 if (validCheck.and.registered_string(ca%enumerations, str_vs(value))) then 1113 call add_error(stack, & 1114 "Duplicate enumeration value in ATTLIST") 1115 elseif (namespaces.and.ca%attType==ATT_NOTATION & 1116 .and..not.checkNCName(str_vs(value), xv)) then 1117 call add_error(stack, & 1118 "Notation name must be NCName") 1119 else 1120 call add_string(ca%enumerations, str_vs(value)) 1121 endif 1122 deallocate(value) 1123 state = ST_AFTER_ATTTYPE_SPACE 1124 else 1125 call add_error(stack, & 1126 'Unexpected character in attlist enumeration') 1127 endif 1128 1129 elseif (state==ST_SEPARATOR) then 1130 !write(*,*)'ST_SEPARATOR' 1131 if (verify(c, XML_WHITESPACE)==0) cycle 1132 if (c=='|') then 1133 if (ca%attType==ATT_NOTATION) then 1134 state = ST_NOTATION_LIST 1135 else 1136 allocate(value(0)) 1137 state = ST_ENUMERATION 1138 endif 1139 elseif (c==')') then 1140 state = ST_AFTER_ATTTYPE_SPACE 1141 else 1142 call add_error(stack, & 1143 'Unexpected character in attlist enumeration') 1144 endif 1145 1146 elseif (state==ST_AFTER_ATTTYPE_SPACE) then 1147 if (verify(c, XML_WHITESPACE)/=0) then 1148 call add_error(stack, & 1149 'Missing whitespace in attlist enumeration') 1150 endif 1151 state = ST_AFTER_ATTTYPE 1152 1153 elseif (state==ST_AFTER_ATTTYPE) then 1154 !write(*,*)'ST_AFTER_ATTTYPE' 1155 if (verify(c, XML_WHITESPACE)==0) cycle 1156 if (c=='#') then 1157 allocate(default(0)) 1158 state = ST_DEFAULT_DECL 1159 elseif (c=='"'.or.c=="'") then 1160 if (validCheck) then 1161 ! Validity Constraint: ID Attribute Default 1162 if (ca%attType==ATT_ID) & 1163 call add_error(stack, & 1164 "Attribute of type ID may not have default value") 1165 endif 1166 ca%attDefault = ATT_DEFAULT 1167 q = c 1168 allocate(value(0)) 1169 state = ST_DEFAULTVALUE 1170 else 1171 call add_error(stack, & 1172 'Unexpected character after AttType') 1173 endif 1174 1175 elseif (state==ST_DEFAULT_DECL) then 1176 !write(*,*)'ST_DEFAULT_DECL' 1177 if (verify(c, upperCase)==0) then 1178 temp => vs_str_alloc(str_vs(default)//c) 1179 deallocate(default) 1180 default => temp 1181 elseif (verify(c, XML_WHITESPACE)==0) then 1182 if (str_vs(default)=='REQUIRED') then 1183 ca%attdefault = ATT_REQUIRED 1184 deallocate(default) 1185 state = ST_START 1186 elseif (str_vs(default)=='IMPLIED') then 1187 ca%attdefault = ATT_IMPLIED 1188 deallocate(default) 1189 state = ST_START 1190 elseif (str_vs(default)=='FIXED') then 1191 if (validCheck) then 1192 ! Validity Constraint: ID Attribute Default 1193 if (ca%attType==ATT_ID) & 1194 call add_error(stack, & 1195 "Attribute of type ID may not have FIXED value") 1196 endif 1197 ca%attdefault = ATT_FIXED 1198 deallocate(default) 1199 state = ST_AFTERDEFAULTDECL 1200 else 1201 call add_error(stack, & 1202 'Unknown Default declaration') 1203 endif 1204 else 1205 call add_error(stack, & 1206 'Unexpected character in Default declaration') 1207 endif 1208 1209 elseif (state==ST_AFTERDEFAULTDECL) then 1210 !write(*,*)'ST_AFTERDEFAULTDECL' 1211 if (verify(c, XML_WHITESPACE)==0) cycle 1212 if (c=='"') then 1213 q = c 1214 allocate(value(0)) 1215 state = ST_DEFAULTVALUE 1216 elseif (c=="'") then 1217 q = c 1218 allocate(value(0)) 1219 state = ST_DEFAULTVALUE 1220 else 1221 call add_error(stack, & 1222 'Unexpected character after Default declaration') 1223 endif 1224 1225 elseif (state==ST_DEFAULTVALUE) then 1226 !write(*,*)'ST_DEFAULTVALUE' 1227 if (c==q) then 1228 if (ca%attType/=ATT_CDATA) then 1229 temp => vs_str_alloc(att_value_normalize(str_vs(value))) 1230 deallocate(value) 1231 value => temp 1232 endif 1233 if (validCheck) then 1234 select case(ca%attType) 1235 ! Can't have ID with defaults 1236 case (ATT_IDREF) 1237 ! VC: IDREF 1238 if (namespaces) then 1239 if (.not.checkNCName(str_vs(value), xv)) & 1240 call add_error(stack, & 1241 "Attributes of type IDREF must have a value which is an XML NCName") 1242 else 1243 if (.not.checkName(str_vs(value), xv)) & 1244 call add_error(stack, & 1245 "Attributes of type IDREF must have a value which is an XML Name") 1246 endif 1247 case (ATT_IDREFS) 1248 ! VC: IDREF 1249 if (namespaces) then 1250 if (.not.checkNCNames(str_vs(value), xv)) & 1251 call add_error(stack, & 1252 "Attributes of type IDREFS must have a value which contains only XML NCNames") 1253 else 1254 if (.not.checkNames(str_vs(value), xv)) & 1255 call add_error(stack, & 1256 "Attributes of type IDREFS must have a value which contains only XML Names") 1257 endif 1258 case (ATT_ENTITY) 1259 ! VC: Entity Name 1260 if (namespaces) then 1261 if (.not.checkNCName(str_vs(value), xv)) & 1262 call add_error(stack, & 1263 "Attributes of type ENTITY must have a value which is an XML NCName") 1264 else 1265 if (.not.checkName(str_vs(value), xv)) & 1266 call add_error(stack, & 1267 "Attributes of type ENTITY must have a value which is an XML Name") 1268 endif 1269 case (ATT_ENTITIES) 1270 ! VC: Entity Name 1271 if (namespaces) then 1272 if (.not.checkNames(str_vs(value), xv)) & 1273 call add_error(stack, & 1274 "Attributes of type ENTITIES must have a value which contains only XML NCNames") 1275 else 1276 if (.not.checkNames(str_vs(value), xv)) & 1277 call add_error(stack, & 1278 "Attributes of type ENTITIES must have a value which contains only XML Names") 1279 endif 1280 case (ATT_NMTOKEN) 1281 ! VC Name Token 1282 if (.not.checkNmtoken(str_vs(value), xv)) & 1283 call add_error(stack, & 1284 "Attributes of type NMTOKEN must have a value which is a NMTOKEN") 1285 case (ATT_NMTOKENS) 1286 ! VC: Name Token 1287 if (.not.checkNmtokens(str_vs(value), xv)) & 1288 call add_error(stack, & 1289 "Attributes of type NMTOKENS must have a value which contain only NMTOKENs") 1290 case (ATT_NOTATION) 1291 ! VC: Notation Attributes 1292 if (namespaces) then 1293 if (.not.checkNCName(str_vs(value), xv)) & 1294 call add_error(stack, & 1295 "Attributes of type NOTATION must have a value which is an XMLNCName") 1296 else 1297 if (.not.checkName(str_vs(value), xv)) & 1298 call add_error(stack, & 1299 "Attributes of type NOTATION must have a value which is an XML Name") 1300 endif 1301 case (ATT_ENUM) 1302 ! VC: Enumeration 1303 if (.not.checkNmtoken(str_vs(value), xv)) & 1304 call add_error(stack, & 1305 "Attributes of type ENUM must have a value which is an NMTOKENs") 1306 if (.not.registered_string(ca%enumerations, str_vs(value))) & 1307 call add_error(stack, & 1308 "Default value of ENUM does not match permitted values") 1309 end select 1310 endif 1311 if (.not.in_error(stack)) then 1312 if (ca%attType==ATT_ENTITIES) then 1313 call destroy_string_list(ca%enumerations) 1314 ca%enumerations = tokenize_to_string_list(str_vs(value)) 1315 endif 1316 ca%default => value 1317 value => null() 1318 state = ST_START 1319 endif 1320 else 1321 temp => vs_str_alloc(str_vs(value)//c) 1322 deallocate(value) 1323 value => temp 1324 endif 1325 1326 endif 1327 1328 enddo 1329 1330 if (associated(ignore_att)) call destroy_attribute_t(ignore_att) 1331 1332 if (.not.in_error(stack)) then 1333 if (state==ST_START) then 1334 return 1335 else 1336 call add_error(stack, & 1337 'Incomplete Attlist declaration') 1338 endif 1339 endif 1340 1341 if (associated(name)) deallocate(name) 1342 if (associated(attType)) deallocate(attType) 1343 if (associated(default)) deallocate(default) 1344 if (associated(value)) deallocate(value) 1345 1346 end subroutine parse_dtd_attlist 1347 1348 subroutine report_declarations(elem, attributeDecl_handler) 1349 type(element_t), intent(in) :: elem 1350 interface 1351 subroutine attributeDecl_handler(eName, aName, type, mode, value) 1352 character(len=*), intent(in) :: eName 1353 character(len=*), intent(in) :: aName 1354 character(len=*), intent(in) :: type 1355 character(len=*), intent(in), optional :: mode 1356 character(len=*), intent(in), optional :: value 1357 end subroutine attributeDecl_handler 1358 end interface 1359 1360 integer :: i 1361 character(len=8) :: type 1362 character(len=8) :: mode 1363 type(attribute_t), pointer :: a 1364 1365 do i = 1, size(elem%attlist%list) 1366 a => elem%attlist%list(i) 1367 type = ATT_TYPES(a%attType) 1368 select case (a%attDefault) 1369 case (ATT_REQUIRED) 1370 mode = "REQUIRED" 1371 case (ATT_IMPLIED) 1372 mode = "IMPLIED" 1373 case (ATT_FIXED) 1374 mode = "FIXED" 1375 end select 1376 1377 if (a%attType==ATT_NOTATION) then 1378 if (a%attDefault==ATT_DEFAULT) then 1379 if (associated(a%default)) then 1380 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1381 'NOTATION '//make_token_group(a%enumerations), value=str_vs(a%default)) 1382 else 1383 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1384 'NOTATION '//make_token_group(a%enumerations)) 1385 endif 1386 else 1387 if (associated(a%default)) then 1388 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1389 'NOTATION '//make_token_group(a%enumerations), mode=trim(mode), & 1390 value=str_vs(a%default)) 1391 else 1392 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1393 'NOTATION '//make_token_group(a%enumerations), mode=trim(mode)) 1394 endif 1395 endif 1396 elseif (a%attType==ATT_ENUM) then 1397 if (a%attDefault==ATT_DEFAULT) then 1398 if (associated(a%default)) then 1399 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1400 make_token_group(a%enumerations), value=str_vs(a%default)) 1401 else 1402 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1403 make_token_group(a%enumerations)) 1404 endif 1405 else 1406 if (associated(a%default)) then 1407 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1408 make_token_group(a%enumerations), mode=trim(mode), & 1409 value=str_vs(a%default)) 1410 else 1411 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1412 make_token_group(a%enumerations), mode=trim(mode)) 1413 endif 1414 endif 1415 else 1416 if (a%attDefault==ATT_DEFAULT) then 1417 if (associated(a%default)) then 1418 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1419 trim(type), value=str_vs(a%default)) 1420 else 1421 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1422 trim(type)) 1423 endif 1424 else 1425 if (associated(a%default)) then 1426 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1427 trim(type), mode=trim(mode), value=str_vs(a%default)) 1428 else 1429 call attributeDecl_handler(str_vs(elem%name), str_vs(a%name), & 1430 trim(type), mode=trim(mode)) 1431 endif 1432 endif 1433 endif 1434 enddo 1435 1436 1437 end subroutine report_declarations 1438 1439 pure function make_token_group_len(s_list) result(n) 1440 type(string_list), intent(in) :: s_list 1441 integer :: n 1442 1443 integer :: i 1444 n = size(s_list%list) + 1 1445 do i = 1, size(s_list%list) 1446 n = n + size(s_list%list(i)%s) 1447 enddo 1448 end function make_token_group_len 1449 1450 function make_token_group(s_list) result(s) 1451 type(string_list), intent(in) :: s_list 1452 character(len=make_token_group_len(s_list)) :: s 1453 1454 integer :: i, m, n 1455 s(1:1) = '(' 1456 n = 2 1457 do i = 1, size(s_list%list)-1 1458 m = size(s_list%list(i)%s) 1459 s(n:n+m) = str_vs(s_list%list(i)%s)//'|' 1460 n = n + m + 1 1461 enddo 1462 s(n:) = str_vs(s_list%list(i)%s)//')' 1463 end function make_token_group 1464 1465 function attribute_has_default(att) result(p) 1466 type(attribute_t), pointer :: att 1467 logical :: p 1468 1469 if (associated(att)) then 1470 p = att%attDefault==ATT_DEFAULT.or.att%attDefault==ATT_FIXED 1471 else 1472 p = .false. 1473 endif 1474 end function attribute_has_default 1475 1476 function get_attlist_size(elem) result(n) 1477 type(element_t), pointer :: elem 1478 integer :: n 1479 1480 if (associated(elem)) then 1481 n = size(elem%attlist%list) 1482 else 1483 n = 0 1484 endif 1485 end function get_attlist_size 1486 1487 function get_attdecl_by_index(elem, n) result(att) 1488 type(element_t), pointer :: elem 1489 integer, intent(in) :: n 1490 type(attribute_t), pointer :: att 1491 1492 att => null() 1493 if (associated(elem)) then 1494 if (n>0.and.n<=size(elem%attlist%list)) then 1495 att => elem%attlist%list(n) 1496 endif 1497 endif 1498 end function get_attdecl_by_index 1499 1500 function get_attdecl_by_name(elem, name) result(att) 1501 type(element_t), pointer :: elem 1502 character(len=*), intent(in) :: name 1503 type(attribute_t), pointer :: att 1504 1505 integer :: i 1506 att => null() 1507 if (associated(elem)) then 1508 do i = 1, size(elem%attlist%list) 1509 if (str_vs(elem%attlist%list(i)%name)==name) then 1510 att => elem%attlist%list(i) 1511 return 1512 endif 1513 enddo 1514 endif 1515 end function get_attdecl_by_name 1516 1517 pure function express_att_decl_len(a) result(n) 1518 type(attribute_t), intent(in) :: a 1519 integer :: n 1520 1521 if (a%attType==ATT_ENUM) then 1522 n = size(a%name) 1523 else 1524 n = size(a%name)+1+len_trim(ATT_TYPES(a%attType)) 1525 endif 1526 1527 if (a%attType==ATT_NOTATION & 1528 .or.a%attType==ATT_ENUM) & 1529 n = n + 1 + make_token_group_len(a%enumerations) 1530 1531 select case(a%attDefault) 1532 case (ATT_REQUIRED) 1533 n = n + len(" #REQUIRED") 1534 case (ATT_IMPLIED) 1535 n = n + len(" #IMPLIED") 1536 case (ATT_DEFAULT) 1537 n = n + len(" ") 1538 case (ATT_FIXED) 1539 n = n + len(" #FIXED") 1540 end select 1541 1542 if (associated(a%default)) & 1543 n = n + 3 + size(a%default) 1544 end function express_att_decl_len 1545 1546 function express_attribute_declaration(a) result(s) 1547 type(attribute_t), intent(in) :: a 1548 character(len=express_att_decl_len(a)) :: s 1549 1550 if (a%attType==ATT_ENUM) then 1551 s = str_vs(a%name) 1552 else 1553 s = str_vs(a%name)//" "//ATT_TYPES(a%attType) 1554 endif 1555 if (a%attType==ATT_NOTATION & 1556 .or.a%attType==ATT_ENUM) & 1557 s = trim(s)//" "//make_token_group(a%enumerations) 1558 1559 select case(a%attDefault) 1560 case (ATT_REQUIRED) 1561 s = trim(s)//" #REQUIRED" 1562 case (ATT_IMPLIED) 1563 s = trim(s)//" #IMPLIED" 1564 case (ATT_DEFAULT) 1565 s = trim(s)//" " 1566 case (ATT_FIXED) 1567 s = trim(s)//" #FIXED" 1568 end select 1569 1570 if (associated(a%default)) & 1571 s = trim(s)//" """//str_vs(a%default)//"""" 1572 end function express_attribute_declaration 1573 1574 function get_att_type_enum(s) result(n) 1575 character(len=*), intent(in) :: s 1576 integer :: n 1577 1578 select case(s) 1579 case ('CDATA') 1580 n = ATT_CDATA 1581 case ('ID') 1582 n = ATT_ID 1583 case ('IDREF') 1584 n = ATT_IDREF 1585 case ('IDREFS') 1586 n = ATT_IDREFS 1587 case ('NMTOKEN') 1588 n = ATT_NMTOKEN 1589 case ('NMTOKENS') 1590 n = ATT_NMTOKENS 1591 case ('ENTITY') 1592 n = ATT_ENTITY 1593 case ('ENTITIES') 1594 n = ATT_ENTITIES 1595 case ('NOTATION') 1596 n = ATT_NOTATION 1597 case ('CDANO') 1598 n= ATT_CDANO 1599 case ('CDAMB') 1600 n = ATT_CDAMB 1601 end select 1602 end function get_att_type_enum 1603 1604 pure function att_value_normalize_len(s1) result(n) 1605 character(len=*), intent(in) :: s1 1606 integer :: n 1607 1608 integer :: i 1609 logical :: w 1610 1611 n = 0 1612 w = .true. 1613 do i = 1, len(s1) 1614 if (w.and.(verify(s1(i:i),XML_WHITESPACE)==0)) cycle 1615 w = .false. 1616 n = n + 1 1617 if (verify(s1(i:i),XML_WHITESPACE)==0) w = .true. 1618 enddo 1619 if (w) n = n - 1 ! Discard final space 1620 1621 end function att_value_normalize_len 1622 1623 function att_value_normalize(s1) result(s2) 1624 character(len=*), intent(in) :: s1 1625 character(len=att_value_normalize_len(s1)) :: s2 1626 1627 integer :: i, i2 1628 logical :: w 1629 1630 i = 0 1631 i2 = 1 1632 w = .true. 1633 do while (i2<=len(s2)) 1634 i = i + 1 1635 if (w.and.(verify(s1(i:i),XML_WHITESPACE)==0)) cycle 1636 w = .false. 1637 s2(i2:i2) = s1(i:i) 1638 i2 = i2 + 1 1639 if (verify(s1(i:i),XML_WHITESPACE)==0) w = .true. 1640 enddo 1641 1642 end function att_value_normalize 1643 1644#endif 1645end module m_common_element 1646