XML-DTDParser-2.01/ 40777 0 0 0 10142714770 6704 5XML-DTDParser-2.01/Changes100666 0 0 2436 10142714766 10226 Revision history for Perl extension XML::DTDParser. 1.0 Tue Feb 12 23:41:58 2002 - original version 1.1 Wed Feb 13 00:20 2002 - small fix 1.2 Sun Dec 29 - renamed from Jenda::QD::DTDParser to XML::DTDParser - uploaded to CPAN 1.3 Sun Jan 5 - fixed a typo on line 34 (close IN; instead of close $IN;, thanks to hughmyers@micron.com) - handling properly - added childrenSTR option to the elements 1.4 GOK - internal only 1.5 Tue Feb 11 2003 - allows - incorrectly formated chlidren lists are reported as incorrectly formated (instead of some bogus "Element @#*&^*&^$ referenced by Element was not found") - supports enumerated attributes 1.6 GOK - added support for comments 1.7 Web Mar 19, 2003 - fixed a small bug in the regexp parsing the comments 1.8 GOK - internal only 1.9 Fri Nov 05 2004 - ParseDTDFile function - handle correctly (the multiplicity of the "type" should be "+", not "*" in this case - fixes in regexps 2.00 Fri Nov 05 2004 - return the multiplicity as chindrenX => { child => '1..', other => 1, another => '1..3', ...} 2.01 Fri Nov 05 2004 - do not include #PCDATA in childrenX, fix test XML-DTDParser-2.01/DTDParser.pm100666 0 0 27515 10142714766 11106 package XML::DTDParser; require Exporter; use FileHandle; use strict; use File::Spec; use Cwd; our @ISA = qw(Exporter); our @EXPORT = qw(ParseDTD FindDTDRoot ParseDTDFile); our @EXPORT_OK = @EXPORT; our $VERSION = '2.01'; my $namechar = '[#\x41-\x5A\x61-\x7A\xC0-\xD6\xD8-\xF6\xF8-\xFF0-9\xB7._:-]'; my $name = '[\x41-\x5A\x61-\x7A\xC0-\xD6\xD8-\xF6\xF8-\xFF_:]' . $namechar . '*'; my $nameX = $name . '[.?+*]*'; my $nmtoken = $namechar . '+'; my $AttType = '(?:CDATA\b|IDREFS?\b|ID\b|ENTITY\b|ENTITIES\b|NMTOKENS?\b|\([^\)]*\)|NOTATION\s+\([^\)]*\))'; my $DefaultDecl = q{(?:#REQUIRED|#IMPLIED|(:?#FIXED ?)?(?:".*?"|'.*?'))}; my $AttDef = '('.$name.') ('.$AttType.')(?: ('.$DefaultDecl.'))?'; sub ParseDTDFile { my $file = shift; open my $IN, "< $file" or die "Cannot open the $file : $!\n"; my $xml = do {local $/; <$IN>}; close $IN; my ($vol,$dir,$filename) = File::Spec->splitpath( $file); if ($filename eq $file) { return ParseDTD($xml); } else { # in case there are any includes, they should be relative to the DTD file, not to current dir my $cwd = cwd(); chdir(File::Spec->catdir($vol,$dir)); my $DTD = ParseDTD($xml); chdir($cwd); return $DTD; } } sub ParseDTD { my $xml = shift; my (%elements, %definitions); $xml =~ s/\s\s*/ /gs; while ($xml =~ s{}{}io) { my ($percent, $entity, $include) = ($1,$2,$3); $percent = '&' unless $percent; my $definition; { # the $include may be a URL, use LWP::Simple to fetch it if it is. my $IN; open $IN, "<$include" or die "Cannot open include file $include : $!\n"; $definition = do {local $/; <$IN>}; close $IN; } $definition =~ s/\s\s*/ /gs; $xml =~ s{\Q$percent$entity;\E}{$definition}g; } my (%elementinfo, %attribinfo); while ($xml =~ s{}{}s) { my $info = $1;$info =~ s/\s+$//s; my %info; while ($info =~ s{^([\w-]+)\s*=\s*((?:'[^']*')+|(?:"[^"]*")+|[^\s'"]\S*)\s*}{}s) { my ($name, $value) = ($1, $2); if ($value =~ /^'/) { ($value = substr $value, 1, length($value)-2) =~ s/''/'/g; } elsif ($value =~ /^"/) { ($value = substr $value, 1, length($value)-2) =~ s/""/"/g; } $info{$name} = $value; } die "Malformed section!\n\t\n" if ($info ne ''); die "The section doesn't contain the 'element' parameter!\n" unless exists $info{'element'}; my $element = $info{'element'}; delete $info{'element'}; if (exists $info{'attribute'}) { my $attribute = $info{'attribute'}; delete $info{'attribute'}; $attribinfo{$element}->{$attribute} = \%info; } else { $elementinfo{$element} = \%info; } } $xml =~ s{}{}gs; $xml =~ s{<\?.*?\?>}{}gs; while ($xml =~ s{}{}io) { my ($percent, $entity, $definition) = ($1,$2,$3); $percent = '&' unless $percent; $definitions{"$percent$entity"} = $definition; } { my $replacements = 0; 1 while $replacements++ < 1000 and $xml =~ s{([&%]$name);}{(exists $definitions{$1} ? $definitions{$1} : "$1\x01;")}geo; die <<'*END*' if $xml =~ m{([&%]$name);}o; Recursive definitions or too many entities! Only up to 1000 entity replacements allowed. (An entity is something like &foo; or %foo;. They are defined by tag.) *END* } undef %definitions; $xml =~ tr/\x01//d; while ($xml =~ s{}{}io) { my ($element, $children, $option) = ($1,$2,$3); $elements{$element}->{childrenSTR} = $children . $option; $children =~ s/\s//g; if ($children eq '(#PCDATA)') { $children = '#PCDATA'; } elsif ($children =~ s/^\((#PCDATA(?:\|$name)+)\)$/$1/o and $option eq '*') { $children =~ s/\|/*,/g; $children .= '*'; } else { $children = simplify_children( $children, $option); } die " is not valid!\n" unless $children =~ m{^#?$nameX(?:,$nameX)*$}o; $elements{$element}->{childrenARR} = []; foreach my $child (split ',', $children) { $child =~ s/([?*+])$// and $option = $1 or $option = '!'; if (exists $elements{$element}->{children}->{$child}) { $elements{$element}->{children}->{$child} = _merge_options( $elements{$element}->{children}->{$child}, $option); $elements{$element}->{childrenX}->{$child} = _merge_counts( $elements{$element}->{childrenX}->{$child}, _char2count($option)) unless $child eq '#PCDATA'; } else { $elements{$element}->{children}->{$child} = $option; $elements{$element}->{childrenX}->{$child} = _char2count($option) unless $child eq '#PCDATA'; } push @{$elements{$element}->{childrenARR}}, $child unless $child eq '#PCDATA'; } delete $elements{$element}->{childrenARR} if @{$elements{$element}->{childrenARR}} == 0 } while ($xml =~ s{}{}io) { my ($element, $param) = ($1,$2); if (uc $param eq 'ANY') { $elements{$element}->{any} = 1; } else { $elements{$element} = {}; } } #=for comment while ($xml =~ s{}{}io) { my ($element, $attributes) = ($1,$2); die " referenced by an not found!\n" unless exists $elements{$element}; while ($attributes =~ s/^\s*$AttDef//io) { my ($name,$type,$option,$default) = ($1,$2,$3); if ($option =~ /^#FIXED\s+["'](.*)["']$/i){ $option = '#FIXED'; $default = $1; } elsif ($option =~ /^["'](.*)["']$/i){ $option = ''; $default = $1; } $elements{$element}->{attributes}->{$name} = [$type,$option,$default,undef]; if ($type =~ /^(?:NOTATION\s*)?\(\s*(.*?)\)$/) { $elements{$element}->{attributes}->{$name}->[3] = parse_enum($1); } } } #=cut #$xml = ''; $xml =~ s/\s\s*/ /g; die "UNPARSED DATA:\n$xml\n\n" if $xml =~ /\S/; foreach my $element (keys %elements) { foreach my $child (keys %{$elements{$element}->{children}}) { if ($child eq '#PCDATA') { delete $elements{$element}->{children}->{'#PCDATA'}; $elements{$element}->{content} = 1; } else { die "Element $child referenced by $element was not found!\n" unless exists $elements{$child}; if (exists $elements{$child}->{parent}) { push @{$elements{$child}->{parent}}, $element; } else { $elements{$child}->{parent} = [$element]; } $elements{$child}->{option} = $elements{$element}->{children}->{$child}; } } if (scalar(keys %{$elements{$element}->{children}}) == 0) { delete $elements{$element}->{children}; } if (exists $elementinfo{$element}) { foreach my $info (keys %{$elementinfo{$element}}) { $elements{$element}->{$info} = $elementinfo{$element}->{$info}; } } if (exists $attribinfo{$element}) { foreach my $attribute (keys %{$attribinfo{$element}}) { $elements{$element}->{'attributes'}->{$attribute}->[4] = $attribinfo{$element}->{$attribute}; } } } return \%elements; } sub flatten_children { my ( $children, $option ) = @_; if ($children =~ /\|/) { $children =~ s{[|,]}{?,}g; $children .= '?' } if ($option) { $children =~ s/,/$option,/g; $children .= $option; } return $children; } sub simplify_children { my ( $children, $option ) = @_; 1 while $children =~ s{\(($nameX(?:[,|]$nameX)*)\)([?*+]*)}{flatten_children($1, $2)}geo; if ($option) { $children =~ s/,/$option,/g; $children .= $option; } foreach ($children) { s{\?\?}{?}g; s{\?\+}{*}g; s{\?\*}{*}g; s{\+\?}{*}g; s{\+\+}{+}g; s{\+\*}{*}g; s{\*\?}{*}g; s{\*\+}{*}g; s{\*\*}{*}g; } return $children; } sub parse_enum { my $enum = shift; $enum =~ tr/\x20\x09\x0D\x0A//d; # get rid of whitespace return [split /\|/, $enum]; } my %merge_options = ( '!!' => '+', '!*' => '+' , '!+' => '+', '!?' => '+', '**' => '*', '*+' => '+', '*?' => '*', '++' => '+', '+?' => '+', '??' => '?', ); sub _merge_options { my ($o1, $o2) = sort @_; return $merge_options{$o1.$o2}; } my %char2count = ( '!' => '1', '?' => '0..1', '+' => '1..', '*' => '0..', ); sub _char2count{ return $char2count{$_[0]} } sub _merge_counts { my ($c1, $c2) = @_; if ($c1 =~ /^\d+$/) { if ($c2 =~ /^\d+$/) { return $c1+$c2 } elsif ($c2 =~ /^(\d+)..(\d+)$/) { return ($c1+$1) . ".." . ($c1+$2); } elsif ($c2 =~ /^(\d+)..$/) { return ($c1+$1) . ".."; } } elsif ($c1 =~ /^(\d+)..(\d+)$/) { my ($c1l,$c1u) = ($1,$2); if ($c2 =~ /^\d+$/) { return ($c1l+$c2) . ".." . ($c1u+$c2); } elsif ($c2 =~ /^(\d+)..(\d+)$/) { return ($c1l+$1) . ".." . ($c1u+$2); } elsif ($c2 =~ /^(\d+)..$/) { return ($c1l+$1) . ".."; } } elsif ($c1 =~ /^(\d+)..$/) { $c1=$1; if ($c2 =~ /^\d+$/) { return ($c1+$c2) . ".."; } elsif ($c2 =~ /^(\d+)..(\d+)$/) { return ($c1+$1) . ".."; } elsif ($c2 =~ /^(\d+)..$/) { return ($c1+$1) . ".."; } } } sub FindDTDRoot { my $elements = shift; my @roots; foreach my $element (keys %$elements) { if (!exists $elements->{$element}->{parent}) { push @roots, $element; $elements->{$element}->{option} = '!'; } } return @roots; } =head1 NAME XML::DTDParser - quick and dirty DTD parser Version 2.01 =head1 SYNOPSIS use XML::DTDParser qw(ParseDTD ParseDTDFile); $DTD = ParseDTD $DTDtext; #or $DTD = ParseDTDFile( $dtdfile) =head1 DESCRIPTION This module parses a DTD file and creates a data structure containing info about all tags, their allowed parameters, children, parents, optionality etc. etc. etc. Since I'm too lazy to document the structure, parse a DTD you need and print the result to a file using Data::Dumper. The datastructure should be selfevident. Note: The module should be able to parse just about anything, but it intentionaly looses some information. Eg. if the DTD specifies that a tag should contain either CHILD1 or CHILD2 you only get that CHILD1 and CHILD2 are optional. That is is the DTD contains the result will be the same is if it contained You get the original unparsed parameter list as well so if you need this information you may parse it yourself. Since version 1.6 this module supports my "extensions" to DTDs. If the DTD contains a comment in form and there is an element XXX in the DTD, the resulting hash for the XXX will contain 'foo' => 'bar', 'person' => 'd\'Artagnan', 'greeting => 'Hello World!' If the DTD contains the $DTD->{XXX}->{attributes}->{YYY}->[4] will be set to { break => 'no' } I use this parser to import the DTD into the database so that I could map some fields to certain tags for output and I want to be able to specify the mapping inside the file: =head2 EXPORT By default the module exports all (both) it's functions. If you only want one, or none use use XML::DTDParser qw(ParseDTD); or use XML::DTDParser qw(); =over 4 =item ParseDTD $DTD = ParseDTD $DTDtext; Parses the $DTDtext and creates a data structure. If the $DTDtext contains some declarations those are read and parsed as needed. The paths are relative to current directory. The module currently doesn't support URLs here yet. =item ParseDTDFile $DTD = ParseDTDFile $DTDfile; Parses the contents of $DTDfile and creates a data structure. If the $DTDfile contains some declarations those are read and parsed as needed. The paths are relative to the $DTDfile. The module currently doesn't support URLs here yet. =item FindDTDRoot $DTD = ParseDTD $DTDtext; @roots = FindDTDRoot $DTD; Returns all tags that have no parent. There could be several such tags defined by the DTD. Especialy if it used some common includes. =back =head1 AUTHOR Jenda@Krynicky.cz http://Jenda.Krynicky.cz =head1 COPYRIGHT Copyright (c) 2002 Jan Krynicky . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut XML-DTDParser-2.01/Makefile.PL100666 0 0 746 10142714766 10667 use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'XML::DTDParser', 'VERSION_FROM' => 'DTDParser.pm', # finds $VERSION 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'DTDParser.pm', # retrieve abstract from module AUTHOR => 'Jenda@Krynicky.cz') : ()), ); XML-DTDParser-2.01/MANIFEST100666 0 0 71 10142714766 10015 Changes DTDParser.pm Makefile.PL MANIFEST README test.pl XML-DTDParser-2.01/README100666 0 0 705 7603627211 7544 XML/DTDParser version 1.0 =============================== Quick and dirty DTD parser. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES None COPYRIGHT AND LICENCE Copyright (c) 2002 Jan Krynicky . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. XML-DTDParser-2.01/test.pl100666 0 0 21646 10142714766 10273 # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test; BEGIN { plan tests => 3 }; use XML::DTDParser; ok(1); # If we made it this far, we're ok. ######################### # Insert your test code below, the Test module is use()ed here so read # its man page ( perldoc Test ) for help writing this test script. my $DTD = ParseDTD <<'*END*'; *END* ok(1); eval "use Data::Compare;"; if ($@) { skip("You don't have Data::Compare\n"); exit; } my $GOOD_DTD = { 'NAME' => { 'parent' => [ 'BILLING' ], 'childrenSTR' => '(#PCDATA)', 'map_to' => 'BILLING_CONTACT_NAME', 'content' => 1, 'option' => '!' }, 'TEXT' => { 'parent' => [ 'JOB' ], 'childrenSTR' => '(#PCDATA)', 'content' => 1, 'option' => '!' }, 'JOB' => { 'repeat_list' => 'add,modify,delete', 'childrenARR' => [ 'TITLE', 'BILLING', 'FLD', 'TEXT' ], 'parent' => [ 'JOBPOSTINGDOCUMENT' ], 'childrenSTR' => '(TITLE,BILLING,FLD,TEXT)', 'option' => '+', 'children' => { 'TEXT' => '!', 'TITLE' => '!', 'FLD' => '!', 'BILLING' => '!' }, 'childrenX' => { 'TEXT' => '1', 'TITLE' => '1', 'FLD' => '1', 'BILLING' => '1' }, 'repeat_set' => 'action', 'attributes' => { 'action' => [ 'CDATA', '#REQUIRED', undef, undef ], 'id' => [ 'CDATA', '#REQUIRED', undef, undef, { 'map_to' => 'JDTID_UNIQUE_NUMBER' } ] } }, 'TITLE' => { 'parent' => [ 'JOB' ], 'childrenSTR' => '(#PCDATA)', 'map_to' => 'JOB_TITLE', 'content' => 1, 'option' => '!' }, 'OFFICE' => { 'parent' => [ 'BILLING' ], 'childrenSTR' => '(#PCDATA)', 'map_to' => 'BILLING_CONTACT_OFFICE', 'content' => 1, 'option' => '!' }, 'JOBPOSTINGDOCUMENT' => { 'childrenARR' => [ 'JOB' ], 'childrenSTR' => '(JOB+)', 'children' => { 'JOB' => '+' }, 'childrenX' => { 'JOB' => '1..' } }, 'BILLING' => { 'childrenARR' => [ 'NAME', 'PHONE', 'OFFICE', 'FOO', 'FOO' ], 'parent' => [ 'JOB' ], 'childrenSTR' => '(NAME,PHONE,OFFICE,FOO,FOO*)', 'option' => '!', 'children' => { 'NAME' => '!', 'OFFICE' => '!', 'FOO' => '+', 'PHONE' => '!' }, 'childrenX' => { 'NAME' => '1', 'OFFICE' => '1', 'FOO' => '1..', 'PHONE' => '1' }, 'attributes' => { 'empty' => [ 'CDATA', '#REQUIRED', undef, undef ], 'static' => [ 'CDATA', '#REQUIRED', undef, undef, { 'set_to' => 'some value' } ] } }, 'FOO' => { 'parent' => [ 'BILLING' ], 'childrenSTR' => '(#PCDATA)', 'content' => 1, 'option' => '+', 'set_to' => 'Bar' }, 'FLD' => { 'parent' => [ 'JOB' ], 'childrenSTR' => '(#PCDATA)', 'content' => 1, 'option' => '!' }, 'PHONE' => { 'parent' => [ 'BILLING' ], 'childrenSTR' => '(#PCDATA)', 'map_to' => 'BILLING_CONTACT_PHONE', 'content' => 1, 'option' => '!' } }; ok(Compare($DTD, $GOOD_DTD)); #use Data::Dumper; #print Dumper($DTD);