r73766 - in /branches/upstream/libxml-dtdparser-perl: ./ current/ current/Changes current/DTDParser.pm current/MANIFEST current/Makefile.PL current/README current/test.pl
gregoa at users.alioth.debian.org
gregoa at users.alioth.debian.org
Thu Apr 28 23:56:42 UTC 2011
Author: gregoa
Date: Thu Apr 28 23:56:36 2011
New Revision: 73766
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=73766
Log:
[svn-inject] Installing original source of libxml-dtdparser-perl (2.01)
Added:
branches/upstream/libxml-dtdparser-perl/
branches/upstream/libxml-dtdparser-perl/current/
branches/upstream/libxml-dtdparser-perl/current/Changes
branches/upstream/libxml-dtdparser-perl/current/DTDParser.pm
branches/upstream/libxml-dtdparser-perl/current/MANIFEST
branches/upstream/libxml-dtdparser-perl/current/Makefile.PL
branches/upstream/libxml-dtdparser-perl/current/README
branches/upstream/libxml-dtdparser-perl/current/test.pl
Added: branches/upstream/libxml-dtdparser-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libxml-dtdparser-perl/current/Changes?rev=73766&op=file
==============================================================================
--- branches/upstream/libxml-dtdparser-perl/current/Changes (added)
+++ branches/upstream/libxml-dtdparser-perl/current/Changes Thu Apr 28 23:56:36 2011
@@ -1,0 +1,45 @@
+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 at micron.com)
+ - handling <!ELEMENT D (A? | B? | C?)> properly
+ - added childrenSTR option to the elements
+
+1.4 GOK
+ - internal only
+
+1.5 Tue Feb 11 2003
+ - allows <!ELEMENT Foo (#PCDATA|Bar|Baz)*>
+ - incorrectly formated chlidren lists are reported as incorrectly formated
+ (instead of some bogus "Element @#*&^*&^$ referenced by Element was not found")
+ - supports enumerated attributes <!ATTLIST A Name ( 1 | 2 | 3) #REQUIRED>
+
+1.6 GOK
+ - added support for <!--#info --> comments
+
+1.7 Web Mar 19, 2003
+ - fixed a small bug in the regexp parsing the <!--#info --> comments
+
+1.8 GOK
+ - internal only
+
+1.9 Fri Nov 05 2004
+ - ParseDTDFile function
+ - handle <!ELEMENT id (id, type, type*)> 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
Added: branches/upstream/libxml-dtdparser-perl/current/DTDParser.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libxml-dtdparser-perl/current/DTDParser.pm?rev=73766&op=file
==============================================================================
--- branches/upstream/libxml-dtdparser-perl/current/DTDParser.pm (added)
+++ branches/upstream/libxml-dtdparser-perl/current/DTDParser.pm Thu Apr 28 23:56:36 2011
@@ -1,0 +1,452 @@
+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{<!ENTITY\s+(?:(%)\s*)?($name)\s+SYSTEM\s*"(.*?)"\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{<!--#info\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 <!--#info ...--> section!\n\t<!--#info $info -->\n"
+ if ($info ne '');
+ die "The <!--#info $info --> 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{<!ENTITY\s+(?:(%)\s*)?($name)\s*"(.*?)"\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 <!ENTITY ...> definitions or too many entities! Only up to 1000 entity replacements allowed.
+(An entity is something like &foo; or %foo;. They are defined by <!ENTITY ...> tag.)
+*END*
+ }
+ undef %definitions;
+ $xml =~ tr/\x01//d;
+
+ while ($xml =~ s{<!ELEMENT\s+($name)\s*(\(.*?\))([?*+]?)\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 "<!ELEMENT $element (...)> 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{<!ELEMENT\s+($name)\s*(EMPTY|ANY)\s*>}{}io) {
+ my ($element, $param) = ($1,$2);
+ if (uc $param eq 'ANY') {
+ $elements{$element}->{any} = 1;
+ } else {
+ $elements{$element} = {};
+ }
+ }
+#=for comment
+ while ($xml =~ s{<!ATTLIST(?:\s+($name)\s+(.*?))?\s*>}{}io) {
+ my ($element, $attributes) = ($1,$2);
+ die "<!ELEMENT $element ...> referenced by an <!ATTLIST ...> 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
+ <!ELEMENT FOO (BAR|BAZ)>
+the result will be the same is if it contained
+ <!ELEMENT FOO (BAR?,BAZ?)>
+
+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
+
+ <!--#info element=XXX foo=bar greeting="Hello World!" person='d''Artagnan'-->
+
+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
+
+ <!--#info element=XXX attribute=YYY break=no-->
+
+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:
+
+ <!--#info element=TagName map_to="FieldName"-->
+
+=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
+<!ENTITY ... SYSTEM "..."> 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
+<!ENTITY ... SYSTEM "..."> 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 at Krynicky.cz
+http://Jenda.Krynicky.cz
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002 Jan Krynicky <Jenda at Krynicky.cz>. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
Added: branches/upstream/libxml-dtdparser-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libxml-dtdparser-perl/current/MANIFEST?rev=73766&op=file
==============================================================================
--- branches/upstream/libxml-dtdparser-perl/current/MANIFEST (added)
+++ branches/upstream/libxml-dtdparser-perl/current/MANIFEST Thu Apr 28 23:56:36 2011
@@ -1,0 +1,6 @@
+Changes
+DTDParser.pm
+Makefile.PL
+MANIFEST
+README
+test.pl
Added: branches/upstream/libxml-dtdparser-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libxml-dtdparser-perl/current/Makefile.PL?rev=73766&op=file
==============================================================================
--- branches/upstream/libxml-dtdparser-perl/current/Makefile.PL (added)
+++ branches/upstream/libxml-dtdparser-perl/current/Makefile.PL Thu Apr 28 23:56:36 2011
@@ -1,0 +1,11 @@
+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 at Krynicky.cz') : ()),
+);
Added: branches/upstream/libxml-dtdparser-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libxml-dtdparser-perl/current/README?rev=73766&op=file
==============================================================================
--- branches/upstream/libxml-dtdparser-perl/current/README (added)
+++ branches/upstream/libxml-dtdparser-perl/current/README Thu Apr 28 23:56:36 2011
@@ -1,0 +1,25 @@
+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 <Jenda at Krynicky.cz>. All rights reserved.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
Added: branches/upstream/libxml-dtdparser-perl/current/test.pl
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libxml-dtdparser-perl/current/test.pl?rev=73766&op=file
==============================================================================
--- branches/upstream/libxml-dtdparser-perl/current/test.pl (added)
+++ branches/upstream/libxml-dtdparser-perl/current/test.pl Thu Apr 28 23:56:36 2011
@@ -1,0 +1,221 @@
+# 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*';
+<!-- this is an ordinary comment > < -->
+<!ELEMENT JOBPOSTINGDOCUMENT (JOB+)>
+
+<!ELEMENT JOB (TITLE,BILLING,FLD,TEXT)>
+<!ATTLIST JOB id CDATA #REQUIRED action CDATA #REQUIRED>
+<!--#info element='JOB' repeat_set=action repeat_list='add,modify,delete'-->
+<!--#info element='JOB' attribute='id' map_to='JDTID_UNIQUE_NUMBER'-->
+
+<!ELEMENT TITLE (#PCDATA)>
+<!--#info element='TITLE' map_to='JOB_TITLE'-->
+
+<!ELEMENT BILLING (NAME,PHONE,OFFICE,FOO,FOO*)>
+<!ATTLIST BILLING static CDATA #REQUIRED empty CDATA #REQUIRED>
+<!--#info element='BILLING' attribute='static' set_to='some value'-->
+
+<!ELEMENT NAME (#PCDATA)>
+<!--#info element='NAME' map_to='BILLING_CONTACT_NAME'-->
+<!ELEMENT PHONE (#PCDATA)>
+<!--#info element='PHONE' map_to='BILLING_CONTACT_PHONE'-->
+<!ELEMENT OFFICE (#PCDATA)>
+<!--#info element='OFFICE' map_to='BILLING_CONTACT_OFFICE'-->
+<!ELEMENT FOO (#PCDATA)>
+<!--#info element='FOO' set_to='Bar'-->
+
+<!ELEMENT FLD (#PCDATA)>
+<!ELEMENT TEXT (#PCDATA)>
+
+*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);
More information about the Pkg-perl-cvs-commits
mailing list