XML-AutoWriter-0.4/0000755000076500000240000000000011214247332012550 5ustar dcpstaffXML-AutoWriter-0.4/CHANGES0000644000076500000240000001044011214245237013544 0ustar dcpstaffCHANGES file for XML::ValidWriter and XML::AutoWriter 0.39 Tue Dec 12 09:26:11 EST 2005 - Relicensed to user's choice of GPL, Artistic, or BSD license 0.38 Tue Mar 9 01:55:33 EST 2004 - phashes removed 0.36 Mon Dec 18 07:21:10 EST 2000 - Fixed bug where ']' or ']]' at the end of CDATA would not be emitted before a start or empty tag (ie in mixed content). 0.33-v.035 Fri Dec 15 07:02:36 EST 2000 - XML::ValidWriter and XML::AutoWriter now croak if any control codes other than TAB, CR, or newline (9, 10, 13) are passed. - Fixed a bug that kicked out of PCDATA escape mode in to CDATA too easily. 0.32 Fri Dec 15 07:02:36 EST 2000 - Reduced number of times '>' is escaped in PCDATA. It still gets turned into '>' gratuitously occasionally, but that's a really minor nit, IMHO. 0.3 Wed Aug 9 11:53:59 EDT 2000 - Fixed a bug in escaping of CDATA end tags that are split across multiple parameters to or calls to characters(). This will use a lot of memory if passing big sets of parameters to characters(), which actually is what you're supposed to do to allow the CDATA escape guesser to guess more accurately. If this is a problem, we'll fix it. - Added ability to pass OUTPUT => 'filename.ml' to XML::ValidWriter and subclasses, and have it opened and closed. - Fixed some typos in documentation - Allowed XML::Doctype's import() function to call constructors for subclasses of XML::Doctype - Fixed a bug that prevented PCDATA sections from finding an appropriate path. - Removed assumption that undeclared elements can contain ANY. - Added check to make sure the root node is at least referred-to. 0.2 Fri Aug 4 13:49:19 EDT 2000 - fixes a few bugs - adds more validity checks - renames XML::DTD to be XML::Doctype, - provides setDataMode which will insert newlines around tags, but never in PCDATA content that is not mixed with elements. An example is below. - optimizes '' to be '' on output - autodetects whether or not to use escaping for element PCDATA - alters the exported element-name functions so that, if a tag 'foo' is referenced in the DTD, doing a C, you get: start_foo( [attr => 'val', ...] ) ; end_foo() ; empty_foo( [attr => 'var', ...] ) ; foo( $content[, attr=> 'val', ...] ) ; You can C subclasses of XML::ValidWriter in this way, too. - AUTOLOADs methods corresponding to the above exported functions. This is done on a per-instance basis, so as to handle both intermediate subclasses, where the class namespace should not be corrupted, and final subclasses, where you this functionality is actually used). Here's a real piece of code as an example, given that the tags , , , , etc. are all mentioned in the DTD:, and that $w ISA XML::AutoWriter (which ISA XML::ValidWriter): if ( $self->none_seen ) { $w->setDataMode( 1 ) ; $w->xmlDecl ; $w->date( _ISO8601 ) ; $w->repository_type( $self->header->{rep_type} ) ; $w->repository_description( $self->header->{rep_desc} ) ; } my $saw = $self->seen( $r ) ; my $fn = $r->{filename} ; $w->start_rev ; $w->name( $fn ) ; $w->type( $r->{type} ) ; $w->p4_info() ; The AUTOLOAD idea stolen from XML::Generator. - provides setDataMode which will insert newlines around tags, except for elements that contain only PCDATA. The XML generated by the above code in DATAMODE is: 2000-08-04 17:35:57Z p4 User name: barries Client name: barries Client root: /home/barries/src/ Current directory: /home/barries/src/foo Client address: 127.0.0.1:1687 Server address: localhost:1666 Server root: . Server version: P4D/LINUX52X86/99.2/14042 (2000/01/28) Server license: none revengine/Makefile.PL text XML-AutoWriter-0.4/inc/0000755000076500000240000000000011214247332013321 5ustar dcpstaffXML-AutoWriter-0.4/inc/Module/0000755000076500000240000000000011214247332014546 5ustar dcpstaffXML-AutoWriter-0.4/inc/Module/AutoInstall.pm0000644000076500000240000005260411214247327017356 0ustar dcpstaff#line 1 package Module::AutoInstall; use strict; use Cwd (); use ExtUtils::MakeMaker (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.03'; } # special map on pre-defined feature sets my %FeatureMap = ( '' => 'Core Features', # XXX: deprecated '-core' => 'Core Features', ); # various lexical flags my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps ); my ( $PostambleActions, $PostambleUsed ); # See if it's a testing or non-interactive session _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); _init(); sub _accept_default { $AcceptDefault = shift; } sub missing_modules { return @Missing; } sub do_install { __PACKAGE__->install( [ $Config ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) : () ], @Missing, ); } # initialize various flags, and/or perform install sub _init { foreach my $arg ( @ARGV, split( /[\s\t]+/, $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' ) ) { if ( $arg =~ /^--config=(.*)$/ ) { $Config = [ split( ',', $1 ) ]; } elsif ( $arg =~ /^--installdeps=(.*)$/ ) { __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); exit 0; } elsif ( $arg =~ /^--default(?:deps)?$/ ) { $AcceptDefault = 1; } elsif ( $arg =~ /^--check(?:deps)?$/ ) { $CheckOnly = 1; } elsif ( $arg =~ /^--skip(?:deps)?$/ ) { $SkipInstall = 1; } elsif ( $arg =~ /^--test(?:only)?$/ ) { $TestOnly = 1; } elsif ( $arg =~ /^--all(?:deps)?$/ ) { $AllDeps = 1; } } } # overrides MakeMaker's prompt() to automatically accept the default choice sub _prompt { goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; my ( $prompt, $default ) = @_; my $y = ( $default =~ /^[Yy]/ ); print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; print "$default\n"; return $default; } # the workhorse sub import { my $class = shift; my @args = @_ or return; my $core_all; print "*** $class version " . $class->VERSION . "\n"; print "*** Checking for Perl dependencies...\n"; my $cwd = Cwd::cwd(); $Config = []; my $maxlen = length( ( sort { length($b) <=> length($a) } grep { /^[^\-]/ } map { ref($_) ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) : '' } map { +{@args}->{$_} } grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } )[0] ); # We want to know if we're under CPAN early to avoid prompting, but # if we aren't going to try and install anything anyway then skip the # check entirely since we don't want to have to load (and configure) # an old CPAN just for a cosmetic message $UnderCPAN = _check_lock(1) unless $SkipInstall; while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { my ( @required, @tests, @skiptests ); my $default = 1; my $conflict = 0; if ( $feature =~ m/^-(\w+)$/ ) { my $option = lc($1); # check for a newer version of myself _update_to( $modules, @_ ) and return if $option eq 'version'; # sets CPAN configuration options $Config = $modules if $option eq 'config'; # promote every features to core status $core_all = ( $modules =~ /^all$/i ) and next if $option eq 'core'; next unless $option eq 'core'; } print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); unshift @$modules, -default => &{ shift(@$modules) } if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { if ( $mod =~ m/^-(\w+)$/ ) { my $option = lc($1); $default = $arg if ( $option eq 'default' ); $conflict = $arg if ( $option eq 'conflict' ); @tests = @{$arg} if ( $option eq 'tests' ); @skiptests = @{$arg} if ( $option eq 'skiptests' ); next; } printf( "- %-${maxlen}s ...", $mod ); if ( $arg and $arg =~ /^\D/ ) { unshift @$modules, $arg; $arg = 0; } # XXX: check for conflicts and uninstalls(!) them. if ( defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) ) { print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; push @Existing, $mod => $arg; $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; push @required, $mod => $arg; } } next unless @required; my $mandatory = ( $feature eq '-core' or $core_all ); if ( !$SkipInstall and ( $CheckOnly or ($mandatory and $UnderCPAN) or $AllDeps or _prompt( qq{==> Auto-install the } . ( @required / 2 ) . ( $mandatory ? ' mandatory' : ' optional' ) . qq{ module(s) from CPAN?}, $default ? 'y' : 'n', ) =~ /^[Yy]/ ) ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } elsif ( !$SkipInstall and $default and $mandatory and _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) =~ /^[Nn]/ ) { push( @Missing, @required ); $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; } else { $DisabledTests{$_} = 1 for map { glob($_) } @tests; } } if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) { require Config; print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; # make an educated guess of whether we'll need root permission. print " (You may need to do that as the 'root' user.)\n" if eval '$>'; } print "*** $class configuration finished.\n"; chdir $cwd; # import to main:: no strict 'refs'; *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; } sub _running_under { my $thing = shift; print <<"END_MESSAGE"; *** Since we're running under ${thing}, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; # if we are, then we simply let it taking care of our dependencies sub _check_lock { return unless @Missing or @_; my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); } require CPAN; if ($CPAN::VERSION > '1.89' && $cpan_env) { return _running_under('CPAN'); } # last ditch attempt, this -will- configure CPAN, very sorry _load_cpan(1); # force initialize even though it's already loaded # Find the CPAN lock-file my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); return unless -f $lock; # Check the lock local *LOCK; return unless open(LOCK, $lock); if ( ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' ) { print <<'END_MESSAGE'; *** Since we're running under CPAN, I'll just let it take care of the dependency's installation later. END_MESSAGE return 1; } close LOCK; return; } sub install { my $class = shift; my $i; # used below to strip leading '-' from config keys my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); my ( @modules, @installed ); while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { # grep out those already installed if ( defined( _version_check( _load($pkg), $ver ) ) ) { push @installed, $pkg; } else { push @modules, $pkg, $ver; } } return @installed unless @modules; # nothing to do return @installed if _check_lock(); # defer to the CPAN shell print "*** Installing dependencies...\n"; return unless _connected_to('cpan.org'); my %args = @config; my %failed; local *FAILED; if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { while () { chomp; $failed{$_}++ } close FAILED; my @newmod; while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { push @newmod, ( $k => $v ) unless $failed{$k}; } @modules = @newmod; } if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { _install_cpanplus( \@modules, \@config ); } else { _install_cpan( \@modules, \@config ); } print "*** $class installation finished.\n"; # see if we have successfully installed them while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { if ( defined( _version_check( _load($pkg), $ver ) ) ) { push @installed, $pkg; } elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { print FAILED "$pkg\n"; } } close FAILED if $args{do_once}; return @installed; } sub _install_cpanplus { my @modules = @{ +shift }; my @config = _cpanplus_config( @{ +shift } ); my $installed = 0; require CPANPLUS::Backend; my $cp = CPANPLUS::Backend->new; my $conf = $cp->configure_object; return unless $conf->can('conf') # 0.05x+ with "sudo" support or _can_write($conf->_get_build('base')); # 0.04x # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $conf->get_conf('makeflags') || ''; if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { # 0.03+ uses a hashref here $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; } else { # 0.02 and below uses a scalar $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); } $conf->set_conf( makeflags => $makeflags ); $conf->set_conf( prereqs => 1 ); while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { $conf->set_conf( $key, $val ); } my $modtree = $cp->module_tree; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { print "*** Installing $pkg...\n"; MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; my $success; my $obj = $modtree->{$pkg}; if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $cp->install( modules => [ $obj->{module} ] ); if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation cancelled.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _cpanplus_config { my @config = (); while ( @_ ) { my ($key, $value) = (shift(), shift()); if ( $key eq 'prerequisites_policy' ) { if ( $value eq 'follow' ) { $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); } elsif ( $value eq 'ask' ) { $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); } elsif ( $value eq 'ignore' ) { $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); } else { die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; } } else { die "*** Cannot convert option $key to CPANPLUS version.\n"; } } return @config; } sub _install_cpan { my @modules = @{ +shift }; my @config = @{ +shift }; my $installed = 0; my %args; _load_cpan(); require Config; if (CPAN->VERSION < 1.80) { # no "sudo" support, probe for writableness return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) and _can_write( $Config::Config{sitelib} ); } # if we're root, set UNINST=1 to avoid trouble unless user asked for it. my $makeflags = $CPAN::Config->{make_install_arg} || ''; $CPAN::Config->{make_install_arg} = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); # don't show start-up info $CPAN::Config->{inhibit_startup_message} = 1; # set additional options while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { ( $args{$opt} = $arg, next ) if $opt =~ /^force$/; # pseudo-option $CPAN::Config->{$opt} = $arg; } local $CPAN::Config->{prerequisites_policy} = 'follow'; while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; print "*** Installing $pkg...\n"; my $obj = CPAN::Shell->expand( Module => $pkg ); my $success = 0; if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) { my $pathname = $pkg; $pathname =~ s/::/\\W/; foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { delete $INC{$inc}; } my $rv = $args{force} ? CPAN::Shell->force( install => $pkg ) : CPAN::Shell->install($pkg); $rv ||= eval { $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) ->{install} if $CPAN::META; }; if ( $rv eq 'YES' ) { print "*** $pkg successfully installed.\n"; $success = 1; } else { print "*** $pkg installation failed.\n"; $success = 0; } $installed += $success; } else { print << "."; *** Could not find a version $ver or above for $pkg; skipping. . } MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; } return $installed; } sub _has_cpanplus { return ( $HasCPANPLUS = ( $INC{'CPANPLUS/Config.pm'} or _load('CPANPLUS::Shell::Default') ) ); } # make guesses on whether we're under the CPAN installation directory sub _under_cpan { require Cwd; require File::Spec; my $cwd = File::Spec->canonpath( Cwd::cwd() ); my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); return ( index( $cwd, $cpan ) > -1 ); } sub _update_to { my $class = __PACKAGE__; my $ver = shift; return if defined( _version_check( _load($class), $ver ) ); # no need to upgrade if ( _prompt( "==> A newer version of $class ($ver) is required. Install?", 'y' ) =~ /^[Nn]/ ) { die "*** Please install $class $ver manually.\n"; } print << "."; *** Trying to fetch it from CPAN... . # install ourselves _load($class) and return $class->import(@_) if $class->install( [], $class, $ver ); print << '.'; exit 1; *** Cannot bootstrap myself. :-( Installation terminated. . } # check if we're connected to some host, using inet_aton sub _connected_to { my $site = shift; return ( ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( qq( *** Your host cannot resolve the domain name '$site', which probably means the Internet connections are unavailable. ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/ ); } # check if a directory is writable; may create it on demand sub _can_write { my $path = shift; mkdir( $path, 0755 ) unless -e $path; return 1 if -w $path; print << "."; *** You are not allowed to write to the directory '$path'; the installation may fail due to insufficient permissions. . if ( eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( qq( ==> Should we try to re-execute the autoinstall process with 'sudo'?), ((-t STDIN) ? 'y' : 'n') ) =~ /^[Yy]/ ) { # try to bootstrap ourselves from sudo print << "."; *** Trying to re-execute the autoinstall process with 'sudo'... . my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; return unless system( 'sudo', $^X, $0, "--config=$config", "--installdeps=$missing" ); print << "."; *** The 'sudo' command exited with error! Resuming... . } return _prompt( qq( ==> Should we try to install the required module(s) anyway?), 'n' ) =~ /^[Yy]/; } # load a module and return the version it reports sub _load { my $mod = pop; # class/instance doesn't matter my $file = $mod; $file =~ s|::|/|g; $file .= '.pm'; local $@; return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); } # Load CPAN.pm and it's configuration sub _load_cpan { return if $CPAN::VERSION and not @_; require CPAN; if ( $CPAN::HandleConfig::VERSION ) { # Newer versions of CPAN have a HandleConfig module CPAN::HandleConfig->load; } else { # Older versions had the load method in Config directly CPAN::Config->load; } } # compare two versions, either use Sort::Versions or plain comparison sub _version_check { my ( $cur, $min ) = @_; return unless defined $cur; $cur =~ s/\s+$//; # check for version numbers that are not in decimal format if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { if ( ( $version::VERSION or defined( _load('version') )) and version->can('new') ) { # use version.pm if it is installed. return ( ( version->new($cur) >= version->new($min) ) ? $cur : undef ); } elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) { # use Sort::Versions as the sorting algorithm for a.b.c versions return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 ) ? $cur : undef ); } warn "Cannot reliably compare non-decimal formatted versions.\n" . "Please install version.pm or Sort::Versions.\n"; } # plain comparison local $^W = 0; # shuts off 'not numeric' bugs return ( $cur >= $min ? $cur : undef ); } # nothing; this usage is deprecated. sub main::PREREQ_PM { return {}; } sub _make_args { my %args = @_; $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } if $UnderCPAN or $TestOnly; if ( $args{EXE_FILES} and -e 'MANIFEST' ) { require ExtUtils::Manifest; my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); $args{EXE_FILES} = [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; } $args{test}{TESTS} ||= 't/*.t'; $args{test}{TESTS} = join( ' ', grep { !exists( $DisabledTests{$_} ) } map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); my $missing = join( ',', @Missing ); my $config = join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) if $Config; $PostambleActions = ( ($missing and not $UnderCPAN) ? "\$(PERL) $0 --config=$config --installdeps=$missing" : "\$(NOECHO) \$(NOOP)" ); return %args; } # a wrapper to ExtUtils::MakeMaker::WriteMakefile sub Write { require Carp; Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; if ($CheckOnly) { print << "."; *** Makefile not written in check-only mode. . return; } my %args = _make_args(@_); no strict 'refs'; $PostambleUsed = 0; local *MY::postamble = \&postamble unless defined &MY::postamble; ExtUtils::MakeMaker::WriteMakefile(%args); print << "." unless $PostambleUsed; *** WARNING: Makefile written with customized MY::postamble() without including contents from Module::AutoInstall::postamble() -- auto installation features disabled. Please contact the author. . return 1; } sub postamble { $PostambleUsed = 1; return <<"END_MAKE"; config :: installdeps \t\$(NOECHO) \$(NOOP) checkdeps :: \t\$(PERL) $0 --checkdeps installdeps :: \t$PostambleActions END_MAKE } 1; __END__ #line 1045 XML-AutoWriter-0.4/inc/Module/Install/0000755000076500000240000000000011214247332016154 5ustar dcpstaffXML-AutoWriter-0.4/inc/Module/Install/AutoInstall.pm0000644000076500000240000000227211214247327020760 0ustar dcpstaff#line 1 package Module::Install::AutoInstall; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.87'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub AutoInstall { $_[0] } sub run { my $self = shift; $self->auto_install_now(@_); } sub write { my $self = shift; $self->auto_install(@_); } sub auto_install { my $self = shift; return if $self->{done}++; # Flatten array of arrays into a single array my @core = map @$_, map @$_, grep ref, $self->build_requires, $self->requires; my @config = @_; # We'll need Module::AutoInstall $self->include('Module::AutoInstall'); require Module::AutoInstall; Module::AutoInstall->import( (@config ? (-config => \@config) : ()), (@core ? (-core => \@core) : ()), $self->features, ); $self->makemaker_args( Module::AutoInstall::_make_args() ); my $class = ref($self); $self->postamble( "# --- $class section:\n" . Module::AutoInstall::postamble() ); } sub auto_install_now { my $self = shift; $self->auto_install(@_); Module::AutoInstall::do_install(); } 1; XML-AutoWriter-0.4/inc/Module/Install/AutoManifest.pm0000644000076500000240000000125711214247327021122 0ustar dcpstaff#line 1 use strict; use warnings; package Module::Install::AutoManifest; use Module::Install::Base; BEGIN { our $VERSION = '0.003'; our $ISCORE = 1; our @ISA = qw(Module::Install::Base); } sub auto_manifest { my ($self) = @_; return unless $Module::Install::AUTHOR; die "auto_manifest requested, but no MANIFEST.SKIP exists\n" unless -e "MANIFEST.SKIP"; if (-e "MANIFEST") { unlink('MANIFEST') or die "Can't remove MANIFEST: $!"; } $self->postamble(<<"END"); create_distdir: manifest_clean manifest distclean :: manifest_clean manifest_clean: \t\$(RM_F) MANIFEST END } 1; __END__ #line 48 #line 131 1; # End of Module::Install::AutoManifest XML-AutoWriter-0.4/inc/Module/Install/Base.pm0000644000076500000240000000207011214247327017367 0ustar dcpstaff#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.87'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } ### This is the ONLY module that shouldn't have strict on # use strict; #line 45 sub new { my ($class, %args) = @_; foreach my $method ( qw(call load) ) { next if defined &{"$class\::$method"}; *{"$class\::$method"} = sub { shift()->_top->$method(@_); }; } bless( \%args, $class ); } #line 66 sub AUTOLOAD { my $self = shift; local $@; my $autoload = eval { $self->_top->autoload } or return; goto &$autoload; } #line 83 sub _top { $_[0]->{_top}; } #line 98 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 114 sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 162 XML-AutoWriter-0.4/inc/Module/Install/Can.pm0000644000076500000240000000332411214247327017221 0ustar dcpstaff#line 1 package Module::Install::Can; use strict; use Module::Install::Base; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.87'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 XML-AutoWriter-0.4/inc/Module/Install/Fetch.pm0000644000076500000240000000462611214247327017557 0ustar dcpstaff#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.87'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; XML-AutoWriter-0.4/inc/Module/Install/Include.pm0000644000076500000240000000101411214247327020075 0ustar dcpstaff#line 1 package Module::Install::Include; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.87'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub include { shift()->admin->include(@_); } sub include_deps { shift()->admin->include_deps(@_); } sub auto_include { shift()->admin->auto_include(@_); } sub auto_include_deps { shift()->admin->auto_include_deps(@_); } sub auto_include_dependent_dists { shift()->admin->auto_include_dependent_dists(@_); } 1; XML-AutoWriter-0.4/inc/Module/Install/Makefile.pm0000644000076500000240000001600011214247327020230 0ustar dcpstaff#line 1 package Module::Install::Makefile; use strict 'vars'; use Module::Install::Base; use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.87'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 394 XML-AutoWriter-0.4/inc/Module/Install/Metadata.pm0000644000076500000240000003363711214247327020252 0ustar dcpstaff#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.87'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } my @boolean_keys = qw{ sign mymeta }; my @scalar_keys = qw{ name module_name abstract author version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords }; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless $self->author; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as perl itself' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub _extract_bugtracker { my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than on rt.cpan.org link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { $v = $v + 0; # Numify } return $v; } ###################################################################### # MYMETA.yml Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta { my $self = shift; # If there's no existing META.yml there is nothing we can do return unless -f 'META.yml'; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = YAML::Tiny::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } 1; XML-AutoWriter-0.4/inc/Module/Install/Win32.pm0000644000076500000240000000340211214247327017417 0ustar dcpstaff#line 1 package Module::Install::Win32; use strict; use Module::Install::Base; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.87'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; XML-AutoWriter-0.4/inc/Module/Install/WriteAll.pm0000644000076500000240000000177611214247327020254 0ustar dcpstaff#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.87'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { $self->makemaker_args( PL_FILES => {} ); } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. $self->Meta->write if $args{meta}; $self->Meta->write_mymeta if $self->mymeta; return 1; } 1; XML-AutoWriter-0.4/inc/Module/Install.pm0000644000076500000240000002411611214247327016522 0ustar dcpstaff#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.87'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); use Cwd (); use File::Find (); use File::Path (); use FindBin; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; if ( $] >= 5.006 ) { open( FH, '<', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "< $_[0]" ) or die "open($_[0]): $!"; } my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; if ( $] >= 5.006 ) { open( FH, '>', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "> $_[0]" ) or die "open($_[0]): $!"; } foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2009 Adam Kennedy. XML-AutoWriter-0.4/lib/0000755000076500000240000000000011214247332013316 5ustar dcpstaffXML-AutoWriter-0.4/lib/XML/0000755000076500000240000000000011214247332013756 5ustar dcpstaffXML-AutoWriter-0.4/lib/XML/AutoWriter.pm0000755000076500000240000002317511214247163016436 0ustar dcpstaffpackage XML::AutoWriter ; use strict ; use vars qw( $VERSION ) ; $VERSION = 0.40; use Carp ; use XML::Doctype; use XML::Doctype::ElementDecl; use XML::ValidWriter; use base qw( XML::ValidWriter ) ; =head1 NAME XML::AutoWriter - DOCTYPE based XML output =head1 SYNOPSIS use XML::Doctype NAME => a, SYSTEM_ID => 'a.dtd' ; use XML::AutoWriter qw( :all :dtd_tags ) ; # # a.dtd contains: # # # # # # b1 ; # Emits c2( attr=>"val" ) ; # Emits endAllTags ; # Emits ## If you've got an XML::Doctype object handy: use XML::AutoWriter qw( :dtd_tags ), DOCTYPE => $doctype ; ## If you've saved a preparsed DTD as a perl module use FooML::Doctype::v1_0001 ; use XML::AutoWriter qw( :dtd_tags ) ; ## Or as a normal perl object: $writer = XML::AutoWriter->new( ... ) ; $writer->startTag( 'b1' ) ; $writer->startTag( 'c2' ) ; $writer->end ; =head1 STATUS Alpha. Use and patch, don't depend on things not changing drastically. Many methods supplied by XML::Writer are not yet supplied here. =head1 DESCRIPTION This module subclasses L and provides automatic start and end tag generation, allowing you to emit only the 'important' tags. See XML::ValidWriter for the details on all functions not documented here. =head2 XML::Writer API compatibility Much of the interface is patterned after XML::Writer so that it can possibly be used as a drop-in replacement. It will take awhile before this module emulates enough of XML::Writer to be a drop-in replacement in situations where the more advanced XML::Writer methods are used. =head2 Automatic start tags Automatic start tag creation is done when emitting a start tag that is not allowed to be a child of the currently open tag but is allowed to be contained in the currently open tag's subset. In this case, the minimal number of start tags necessary to allow All start tags between the current tag and the desired tag are automatically emitted with no attributes. =head2 Automatic end tags If start tag autogeneration fails, then end tag autogeneration is attempted. startTag() scans the stack of currently open tags trying to close as few as possible before start tag autogeneration suceeds. Explicit end tags may be emitted to prevent unwanted automatic start tags, and, in the future, warnings or errors will be available in place of automatic start and end tag creation. =head1 METHODS AND FUNCTIONS All of the routines in this module can be called as either functions or methods unless otherwise noted. To call these routines as functions use either the DOCTYPE or :dtd_tags options in the parameters to the use statement: use XML::AutoWriter DOCTYPE => XML::Doctype->new( ... ) ; use XML::AutoWriter qw( :dtd_tags ) ; This associates an XML::AutoWriter and an XML::Doctype with the package. These are used by the routines when called as functions. =over =cut =item new $writer = XML::AutoWriter->new( DTD => $dtd, OUTPUT => \*FH ) ; Creates an XML::AutoWriter. All other parameters are passed to the XML::ValidWriter base class constructor. =cut #sub new is inherited sub _find_path { ## Find a path from $root to $dest by doing a breadth-first ## search. Cache the results as we go to speed us up next time. my XML::Doctype $doctype ; my ( $root, $dest ) ; ( $doctype, $root, $dest ) = @_ ; ## Break encapsulation on XML::Doctype for speed. my $elts = $doctype->{ELTS} ; croak "Unknown tag '$root'" unless exists $elts->{$root} ; croak "Unknown tag '$dest'" unless $dest eq '#PCDATA' || exists $elts->{$dest} ; require XML::Doctype::ElementDecl; my XML::Doctype::ElementDecl $root_elt = $elts->{$root} ; # print STDERR "searching for $root ... $dest\n" ; return [] if $root_elt->is_any || ( $dest eq '#PCDATA' && $root_elt->can_contain_pcdata ) ; my $paths = $root_elt->{PATHS} ; unless ( $paths ) { ## Init the cache $paths = $root_elt->{PATHS} = { map {( $_ => [] )} $root_elt->child_names } ; $root_elt->{TODO} = [ $root_elt->child_names ] ; } ## Check the cache return $root_elt->{PATHS}->{$dest} if exists $root_elt->{PATHS}->{$dest} ; ## Do the search, starting where we left off. @todo is a list of known ## descendant names. We scan each such name looking for more descendants ## until we exhaust the tree or we find the one we're looking for. We ## avoid loops. my $todo = $root_elt->{TODO} ; while ( @$todo ) { # print STDERR "todo: ", join( ' ', @$todo ), "\n" ; my $gkid = shift @$todo ; # print STDERR "doing $gkid\n" ; push @$todo, $elts->{$gkid}->child_names ; my $gkid_path = $paths->{$gkid} ; if ( $elts->{$gkid}->can_contain_pcdata() ) { $paths->{'#PCDATA'} = [ @$gkid_path, $gkid ] unless exists $paths->{'#PCDATA'} ; # print STDERR "checking (pcdata) ", # join( '', map "<$_>", @{$paths->{'#PCDATA'}} ), "\n" ; if ( $dest eq '#PCDATA' ) { # print STDERR "Yahoo!\n" ; return $paths->{'#PCDATA'} ; } } for my $ggkid ( $elts->{$gkid}->child_names ) { next if exists $paths->{$ggkid} ; $paths->{$ggkid} = [ @$gkid_path, $gkid ] ; # print STDERR "checking ", # join( '', map "<$_>", @{$paths->{$ggkid}}, $ggkid ), " ($dest)\n" ; if ( $ggkid eq $dest ) { # print STDERR "Yahoo!\n" ; return $paths->{$ggkid} } } } # print STDERR "rats...\n" ; return ; } =item characters characters( 'yabba dabba dooo' ) ; $writer->characters( 'yabba dabba dooo' ) ; If the currently open tag cannot contain #PCDATA, then start tag autogeneration will be attempted, followed by end tag autogeneration. Start tag autogeneration takes place even if you pass in only '', or even (), the empty list. =cut sub characters { my XML::AutoWriter $self = &XML::ValidWriter::_self ; my $stack = $self->{STACK} ; my $doctype = $self->{DOCTYPE} ; ## Don't re-emit root if it's been emitted, so that the error message ## will be about emitting our $tag, not the root tag. $self->startTag( $doctype->name ) if ! @$stack && ! defined $self->{EMITTED_ROOT} ; for ( my $i = $#$stack ; $i >= 0 ; --$i ) { my XML::VWElement $elt = $stack->[$i]; my $path = _find_path( $doctype, $elt->{NAME}, '#PCDATA' ) ; if ( defined $path ) { while ( $#$stack > $i ) { my XML::VWElement $end_elt = $stack->[-1]; $self->endTag( $end_elt->{NAME} ) } $self->SUPER::startTag( $_ ) for @$path ; last ; } } $self->SUPER::characters( @_ ) ; } =item endTag endTag ; endTag( 'a' ) ; $writer->endTag ; $writer->endTag( 'a' ) ; Prints one or more end tags. The tag name is optional and defaults to the most recently emitted start tag if not present. This will emit as many close tags as necessary to close the supplied tag name, or will emit an error if the tag name specified is not open in the output document. =cut sub endTag { my XML::AutoWriter $self = &XML::ValidWriter::_self ; return $self->SUPER::endTag() unless @_ ; my ( $tag ) = @_ ; my $stack = $self->{STACK} ; ## Close all tags down to & including the one asked for. Don't ## destroy the stack until we have a match, so we can print it ## as an error message if we bottom out. for ( my $i = $#$stack ; $i >= 0 ; --$i ) { my XML::VWElement $elt = $stack->[$i]; if ( $elt->{NAME} eq $tag ) { $self->SUPER::endTag() while $#$stack >= $i ; return ; } } confess "No '$tag' open, only " . join( ', ', map { "'$_->{NAME}'"} @$stack ) ; } =item startTag startTag( 'a', attr => val ) ; # use default XML::AutoWriter for # current package. $writer->startTag( 'a', attr => val ) ; Emits a named start tag with optional attributes. If the named tag cannot be a child of the most recently started tag, then any tags that need to be opened between that one and the named tag are opened. If the named tag cannot be enclosed within the most recently opened tag, no matter how deep, then startTag() tries to end as few started tags as necessary to allow the named tag to be emitted within a tag already on the stack. This warns (once) if no declaration has been emitted. It does not check to see if a has been emitted. It dies if an attempt is made to emit a second root element. =cut sub startTag { my XML::AutoWriter $self = &XML::ValidWriter::_self ; my $tag = shift ; croak "Must supply a tag name" unless defined $tag ; my $stack = $self->{STACK} ; my $doctype = $self->{DOCTYPE} ; ## Don't re-emit root if it's been emitted, so that the error message ## will be about emitting our $tag, not the root tag. $self->startTag( $doctype->name ) if ! @$stack && ! defined $self->{EMITTED_ROOT} && $tag ne $doctype->name ; for ( my $i = $#$stack ; $i >= 0 ; --$i ) { my XML::VWElement $elt = $stack->[$i]; my $path = _find_path( $doctype, $elt->{NAME}, $tag ) ; if ( defined $path ) { while ( $#$stack > $i ) { my XML::VWElement $end_elt = $stack->[-1]; $self->endTag( $end_elt->{NAME} ) } $self->SUPER::startTag( $_ ) for @$path ; last ; } } $self->SUPER::startTag( $tag, @_ ) ; } =head1 AUTHOR Barrie Slaymaker =head1 COPYRIGHT This module is Copyright 2000, 2005, 2009 Barrie Slaymaker. Some rights reserved. This module is licensed under your choice of the Artistic, BSD or General Public License. =cut 1 ; XML-AutoWriter-0.4/lib/XML/Doctype/0000755000076500000240000000000011214247332015365 5ustar dcpstaffXML-AutoWriter-0.4/lib/XML/Doctype/AttDef.pm0000755000076500000240000000762411214245237017110 0ustar dcpstaffpackage XML::Doctype::AttDef ; =head1 NAME XML::Doctype::AttDef - A class representing a definition in an tag =head1 SYNOPSIS $attr = $elt->attribute( $name ) ; $attr->name ; =head1 DESCRIPTION This module is used to represent tags in an XML::Doctype object. It contains tags as well. =head1 STATUS This module is alpha code. It's developed enough to support XML::ValidWriter, but need a lot of work. Some big things that are lacking are: =over =cut use strict ; use vars qw( $VERSION %_default_dtds ) ; use fields ( 'DEFAULT', # The default value if QUANT is '#FIXED' or '', undef otherwise 'NAME', 'OUT_DEFAULT', # Used to set a universal output default value 'QUANT', # '#REQUIRED', '#IMPLIED', '#FIXED', undef 'TYPE', # 'CDATA', 'ID', ... ) ; use Carp ; $VERSION = 0.1 ; =head1 METHODS =item new $dtd = XML::Doctype::AttDef->new( $name, $type, $default ) ; =cut sub new { my XML::Doctype::AttDef $self = fields::new( shift ); ( $self->{NAME}, $self->{TYPE} ) = @_[0,1] ; if ( $_[0] =! /^#/ ) { ( $self->{QUANT}, $self->{DEFAULT} ) = @_[2,3] ; } else { $self->{DEFAULT} = $_[2] ; } return $self ; } =item default ( $spec, $value ) = $attr->default ; $attr->default( '#REQUIRED' ) ; $attr->default( '#IMPLIED' ) ; $attr->default( '', 'foo' ) ; $attr->default( '#FIXED', 'foo' ) ; Sets/gets the default value. This is a =cut sub default { my XML::Doctype::AttDef $self = shift ; if ( @_ ) { my ( $default ) = @_ ; my $quant = $self->quant ; if ( defined $default ) { if ( defined $quant && $quant =~ /^#(REQUIRED|IMPLIED)/ ) { carp "Attribute '", $self->name, "' $quant default set to '$default'" ; } } else { if ( ! defined $quant ) { carp "Attribute '", $self->name, "' default set to undef" ; } elsif ( $quant eq '#FIXED' ) { carp "Attribute '", $self->name, "' #FIXED default set to undef" ; } } $self->{DEFAULT} = $default ; } return $self->{DEFAULT} ; } =item quant $attdef->quant( $q ) ; $q = $attdef->quant ; Sets/gets the attribute quantifier: '#REQUIRED', '#FIXED', '#IMPLIED', or ''. =cut sub quant { my XML::Doctype::AttDef $self = shift ; $self->{QUANT} = shift if @_ ; return $self->{QUANT} ; } =item name $attdef->name( $name ) ; $name = $attdef->name ; Sets/gets this attribute name. Don't change the name while an attribute is in an element's attlist, since it will then be filed under the wrong name. =cut sub name { my XML::Doctype::AttDef $self = shift ; $self->{NAME} = shift if @_ ; return $self->{NAME} ; } =item default_on_write $attdef->default_on_write( $value ) ; $value = $attdef->default_on_write ; $attdef->default_on_write( $attdef->default ) ; Sets/gets the value which is automatically output for this attribute if none is supplied to $writer->startTag. This is typically used to set a document-wide default for #REQUIRED attributes (and perhaps plain attributes) so that the attribute is treated like a #FIXED tag and emitted with a fixed value. The default_on_write does not need to be the same as the default unless the quantifier is #FIXED. =cut sub default_on_write { my XML::Doctype::AttDef $self = shift ; $self->{OUT_DEFAULT} = shift if @_ ; return $self->{OUT_DEFAULT} ; } =head1 SUBCLASSING This object uses the fields pragma, so you should use base and fields for any subclasses. =head1 AUTHOR Barrie Slaymaker =head1 COPYRIGHT This module is Copyright 2000, 2005 Barrie Slaymaker. All rights reserved. This module is licensed under your choice of the Artistic, BSD or General Public License. =cut 1 ; XML-AutoWriter-0.4/lib/XML/Doctype/ElementDecl.pm0000755000076500000240000001707411214245237020122 0ustar dcpstaffpackage XML::Doctype::ElementDecl ; =head1 NAME XML::Doctype::ElementDecl - A class representing an tag =head1 SYNOPSIS $elt = $dtd->element( 'foo' ) ; $elt->name() ; $elt->attr( 'foo' ) ; =head1 DESCRIPTION This module is used to represent tags in an XML::Doctype object. It contains tags as well. =head1 STATUS This module is alpha code. It's developed enough to support XML::ValidWriter, but need a lot of work. Some big things that are lacking are: =over =cut use strict ; use vars qw( $VERSION %_default_dtds ) ; use fields ( 'ATTDEFS', 'CONTENT', # 'EMPTY', 'ANY' or a regexp. undef if ! is_declared(). 'DECLARED', 'NAME', 'NAMES', 'PATHS', # A hash which XML::ValidWriter uses to cache the paths # it finds from this element name to possible child elements. 'TODO', # A list of children that XML::ValidWriter has not yet # explored for possible inclusion in PATHS. ) ; use Carp ; use UNIVERSAL qw( isa ) ; $VERSION = 0.1 ; =head1 METHODS =item new # Undefined element constructors: $dtd = XML::Doctype::ElementDecl->new( $name ) ; $dtd = XML::Doctype::ElementDecl->new( $name, undef, \@attdefs ) ; # Defined element constructors $dtd = XML::Doctype::ElementDecl->new( $name, \@kids, \@attdef ) ; $dtd = XML::Doctype::ElementDecl->new( $name, [], \@attdefs ) ; =cut sub _assemble_re { ## Convert the tree of XML::Parser::ContentModel instances to a ## regular expression and accumulate a HASH of element names in ## NAMES. This hash is later converted to an ARRAY. my XML::Doctype::ElementDecl $self = shift ; my ( $cp ) = @_ ; if ( $cp->isname ) { return '(?:#PCDATA)*' if $cp->name eq '#PCDATA' ; ${$self->{NAMES}->{$cp->name}} = 1 ; return join( '', '<', quotemeta $cp->name, '>' ) unless $cp->quant ; } return join( '', map $self->_assemble_re( $_ ), $cp->children ) if $cp->isseq && ! $cp->quant ; return join( '', '(?:', $cp->isname ? ( '<', quotemeta( $cp->name ), '>' ) : $cp->isseq ? join( '', map $self->_assemble_re( $_ ), $cp->children ) : $cp->ischoice ? join( '|', map $self->_assemble_re( $_ ), $cp->children ) : $cp->ismixed ? join( '|', '(?:#PCDATA)?', map( defined $_ ? $self->_assemble_re( $_ ) : (), $cp->children ) ) : (), ')', $cp->quant || () ) ; } sub new { my XML::Doctype::ElementDecl $self = fields::new( shift ); my $cm ; # The XML::Expat::ContentModel object for this DECL. ( $self->{NAME}, $cm, $self->{ATTDEFS} ) = @_ ; if ( $cm ) { if ( $cm->isany ) { $self->{CONTENT} = 'ANY' ; $self->{NAMES} = [] ; } elsif ( $cm->isempty ) { $self->{CONTENT} = 'EMPTY' ; $self->{NAMES} = [] ; } elsif ( $cm->ismixed || $cm->isseq || $cm->ischoice ) { $self->{NAMES} = {} ; my $re = $self->_assemble_re( $cm ) ; $self->{CONTENT} = "^$re\$" ; # qr/^$re$/ ; $self->{NAMES} = [ $self->{NAMES} ? keys %{$self->{NAMES}} : () ] ; } else { croak "'$cm' passed for a content model" ; } } else { $self->{NAMES} = [] ; } return $self ; } sub _freeze { my $self = shift ; if ( defined $self->{CONTENT} && ref $self->{CONTENT} eq 'Regexp' ) { ## need two assigns to really, really divorce the SV from the ## quircky-half-object RegExp type. $self->{CONTENT} = '' ; $self->{CONTENT} = "$self->{CONTENT}" ; } } =item add_attdef $elt_decl->add_attdef( $att_def ) ; =cut sub add_attdef { my XML::Doctype::ElementDecl $self = shift ; my ( $attdef ) = @_ ; $self->{ATTDEFS}->{$attdef->name} = $attdef ; } =item attdef $attr = $elt->attdef( $name ) ; Returns the XML::Doctype::AttDef named by $name or undef if there is no such attribute. =cut sub attdef { my XML::Doctype::ElementDecl $self = shift ; my ( $name ) = @_ ; return $self->{ATTDEFS}->{$name} if exists $self->{ATTDEFS}->{$name} ; return ; } =item attdefs $attdefs = $elt->attdefs( $name ) ; Returns the list of XML::Doctype::AttDef instances associated with this element. =cut sub attdefs { my XML::Doctype::ElementDecl $self = shift ; my ( $name ) = @_ ; return $self->{ATTDEFS} ? values %{$self->{ATTDEFS}} : () ; } =item attribute_names Returns a list of the attdefs' names. =cut sub attribute_names { my XML::Doctype::ElementDecl $self = shift ; return $self->{ATTDEFS} ? keys %{$self->{ATTDEFS}} : () ; } =item child_names @names = $elt->child_names ; Returns a list of names of elements in this element decl's content model. =cut sub child_names { my XML::Doctype::ElementDecl $self = shift ; return @{$self->{NAMES}} ; } =item is_declared if ( $elt_decl->is_declared ) ... $elt_decl->is_declared( 1 ) ; Returns TRUE if there is any data defined in the element other than name and attributes or if is_declared has been set by calling is_declared( 1 ) or passing DECLARED => 1 to new(). =cut sub is_declared { my XML::Doctype::ElementDecl $self = shift ; $self->{DECLARED} = shift if @_ ; return $self->{DECLARED} || defined $self->{CONTENT} ; } =item is_empty =cut sub is_empty { my XML::Doctype::ElementDecl $self = shift ; return $self->{CONTENT} && $self->{CONTENT} eq 'EMPTY' ; } =item is_any =cut sub is_any { my XML::Doctype::ElementDecl $self = shift ; return $self->{CONTENT} && $self->{CONTENT} eq 'ANY' ; } =item is_mixed =cut sub is_mixed { my XML::Doctype::ElementDecl $self = shift ; return $self->{CONTENT} && $self->{CONTENT} =~ /#PCDATA/ ; } sub can_contain_pcdata { my XML::Doctype::ElementDecl $self = shift ; return $self->{CONTENT} && ( $self->{CONTENT} eq 'ANY' || return $self->{CONTENT} =~ /#PCDATA/ ) ; } =item name $n = $elt_decl->name ; Gets the name of the element. =cut sub name { my XML::Doctype::ElementDecl $self = shift ; return $self->{NAME} ; } =item validate_content $v = $elt_decl->validate_content( \@seq ) ; Takes an ARRAY ref of tag names (or '#PCDATA') and checks to see if it would be valid content for elements of this type. Right now, this must be called only when an element's end tag is emitted. It can be broadened to be incremental if need be. =cut sub validate_content { my XML::Doctype::ElementDecl $self = shift ; my ( $c ) = @_ ; return 1 if ! defined $self->{CONTENT} || $self->{CONTENT} eq 'ANY' ; return ! @$c if $self->{CONTENT} eq 'EMPTY' ; ## Must be mixed. If this elt can have no kids, the test ## is quick. Otherwise we need to validate agains the content ## model tree. my $content_desc = join( '', map $_ eq '#PCDATA' ? $_ : "<$_>", @$c ) ; # print STDERR "$content_desc\n$self->{CONTENT}\n" ; #print $self->{CONTENT}, "\n" ; return $content_desc =~ $self->{CONTENT} ; } =head1 SUBCLASSING This object uses the fields pragma, so you should use base and fields for any subclasses. =head1 AUTHOR Barrie Slaymaker =head1 COPYRIGHT This module is Copyright 2000, 2005 Barrie Slaymaker. All rights reserved. This module is licensed under your choice of the Artistic, BSD or General Public License. =cut 1 ; XML-AutoWriter-0.4/lib/XML/Doctype.pm0000755000076500000240000002612011214245237015731 0ustar dcpstaffpackage XML::Doctype ; =head1 NAME XML::Doctype - A DTD object class =head1 SYNOPSIS # To parse an external DTD at compile time, useful when # using XML::ValidWriter use XML::Doctype NAME => 'FooML', SYSTEM_ID => 'FooML.dtd' ; use XML::Doctype NAME => 'FooML', DTD_TEXT => $dtd ; # Parsing at run-time $doctype = XML::Doctype->new( 'FooML', SYSTEM_ID => 'FooML.dtd' ) ; # or $doctype = XML::Doctype->new() ; $doctype->parse( 'FooML', 'FooML.dtd' ) ; # Saving the parsed object open( PM, ">FooML/DTD/v1_000.pm" ) or die $! ; print PM $doctype->as_pm( 'FooML::DTD::v1_000' ) ; # Using a saved parsed DTD use FooML::DTD::v1_000 ; $doctype = FooML::DTD::v1_000->new() ; =head1 DESCRIPTION This module parses DTDs and allows them to be saved as .pm files and reloaded. The ability to save and reload is intended to aid in packaging parsed DTDs with XML tools so that XML::Parser need not be installed. =head1 STATUS This module is alpha code. It's developed enough to support XML::ValidWriter, but need a lot of work. Some big things that are lacking are: =over =item * methods or objects to build / traverse the DTD =item * XML::Doctype::ELEMENT =item * XML::Doctype::ATTLIST =item * XML::Doctype::ENITITY =back =cut use strict ; use vars qw( $VERSION %_default_dtds ) ; use fields ( 'ELTS', # A hash of declared & undeclared elements, keyed by name 'NAME', # The root node (the name from the DOCTYPE decl). 'SYSID', 'PUBID', ) ; use Carp ; use XML::Doctype::ElementDecl ; use XML::Doctype::AttDef ; $VERSION = 0.11 ; =head1 METHODS =item new $doctype = XML::Doctype->new() ; $doctype = XML::Doctype->new( 'FooML', DTD_TEXT => $doctype_text ) ; $doctype = XML::Doctype->new( 'FooML', SYSTEM_ID => 'FooML.dtd' ) ; =cut sub new { my XML::Doctype $self = fields::new( shift ); return $self unless @_ ; my $name = shift ; if ( @_ == 1 ) { $self->parse_dtd_file( $name, shift ) ; } else { while ( @_ ) { for ( shift ) { if ( /^SYSTEM(?:_ID)?$/ ) { $self->parse_dtd_file( $name, shift ) ; } elsif ( $_ eq 'DTD_TEXT' ) { $self->parse_dtd( $name, shift ) ; } else { croak "Unrecognized parameter '$_'" ; } } } } ## Do this here so subclass author won't be suprised when eventually ## calling save_as_pm. my $class = ref $self; no strict 'refs' ; croak "\$$class\::VERSION not defined" unless defined ${"$class\::VERSION"} ; return $self ; } =item name $name = $doctype->name() ; Sets/gets the name. =cut sub name { my XML::Doctype $self = shift ; $self->{NAME} = shift if @_ ; return $self->{NAME} } ## ## Called to translate the XML::Parser::ContentModel passed by XML::Parser ## in to a tree of XML::Doctype::ChildDecl instances. sub _import_ContentModel { } sub _do_parse { my XML::Doctype $self = shift ; my ( $fake_doc ) = @_ ; my $elts = $self->{ELTS} = {} ; ## Should maybe use libwww to fetch URLs, but will do files for now ## We require this lazily to save load time and allow it to be ## not present if it's not needed. require XML::Parser ; my $p = XML::Parser->new( ParseParamEnt => 1, Handlers => { Doctype => sub { my $expat = shift ; my ( $name, $sysid, $pubid, $internal ) = @_ ; $self->{NAME} = $name ; $self->{SYSID} = $sysid ; $self->{PUBID} = $pubid ; }, Element => sub { my $expat = shift ; my ( $name, $model ) = @_ ; croak "ELEMENT '$name' already defined" if exists $elts->{$name} && $elts->{$name}->is_declared ; my $elt = XML::Doctype::ElementDecl->new( $name, $model ) ; $elt->is_declared( 1 ) ; $elts->{$name} = $elt ; for ( $elt->child_names ) { $elts->{$_} = XML::Doctype::ElementDecl->new( $_ ) unless $elts->{$_} ; } }, Attlist => sub { my $expat = shift ; my ( $elt_name, $att_name, $type, $default, $fixed ) = @_ ; $elts->{$elt_name} = XML::Doctype::ElementDecl->new() unless exists $elts->{$elt_name} ; $default =~ s/^'(.*)'$/$1/ || $default =~ s/^"(.*)"$/$1/ ; $elts->{$elt_name}->add_attdef( XML::Doctype::AttDef->new( $att_name, $type, $fixed ? ( '#FIXED', $default ) : ( $default, undef ), ) ) ; }, }, ) ; $p->parse( $fake_doc ) ; croak "Doctype", defined $self->{SYSID} ? " SYSTEM_ID $self->{SYSID}" : (), " did not declare root node <$self->{NAME}>" unless exists $self->{ELTS}->{$self->{NAME}} ; # require Data::Dumper ; print Data::Dumper::Dumper( $elts ) ; ## TODO: Check that all elements referred-to by name in the element tree ## rooted at $self->{NAME} are actually declared. } =item parse_dtd $doctype->parse_dtd( $name, $doctype_text ) ; $doctype->parse_dtd( $name, $doctype_text, 'internal' ) ; Parses the text of a DTD from a scalar. $name is used to indicate the name of the DOCTYPE, and thus the root node. The DTD is considered to be external unless the third parameter is TRUE. =cut sub parse_dtd { my XML::Doctype $self = shift ; my ( $name, $text, $internal ) = @_ ; $self->_do_parse( < <$name> TOHERE } =item parse_dtd_file $doctype->parse_dtd_file( $name, $system_id [, $public_id] ) ; $doctype->parse_dtd_file( $name, $system_id [, $public_id], 'internal' ) ; Parses a DTD from a file. Eventually will support full URL syntax. $public_id is ignored for now, and $system_id is used to locate the DTD. This routine requires XML::Parser. XML::Parser is not loaded at any other time and is not needed to use the resulting DTD object. The DTD is considered to be external unless the fourth parameter is TRUE. $doctype->parse_dtd_file( $name, $system_id, $p_id, 'internal' ) ; $doctype->parse_dtd_file( $name, $system_id, undef, 'internal' ) ; =cut sub parse_dtd_file { my XML::Doctype $self = shift ; my ( $name, $system_id, undef, $internal ) = @_ ; $self->_do_parse( < <$name> TOHERE } =item system_id $system_id = $doctype->system_id() ; Sets/gets the system ID. =cut sub system_id { my XML::Doctype $self = shift ; $self->{SYSID} = shift if @_ ; return $self->{SYSID} } =item public_id $public_id = $doctype->public_id() ; Sets/gets the public_id. =cut sub public_id { my XML::Doctype $self = shift ; $self->{PUBID} = shift if @_ ; return $self->{PUBID} } =item element_decl $elt_decl = $doctype->element_decl( $name ) ; Returns the XML::Doctype:Element object associated with $name. These can be defined by tags or undefined, which can happen if they were just referred-to by or tags. =cut sub element_decl { my XML::Doctype $self = shift ; my ( $name ) = @_ ; return $self->{ELTS}->{$name} if exists $self->{ELTS}->{$name} ; return ; } =item element_names Returns an unsorted list of element names. This list includes names that are declared and undeclared (but referred to in element declarations or attribute definitions). =cut sub element_names { my XML::Doctype $self = shift ; my $h = {} ; for ( keys %{$self->{ELTS}} ) { $h->{$_} = 1 ; $h->{$_} = 1 for $self->{ELTS}->{$_}->child_names() ; } return keys %$h ; } =item as_pm open( PM, "FooML/DTD/v1_001.pm" ) or die $! ; print PM $doctype->as_pm( 'FooML::DTD::v1_001' ) or die $! ; close PM or die $! ; Then, later: use FooML::DTD::v1_001 ; # Do *not* use () as a parameter list! Returns string containing the DTD as an independant module, allowing the DTD to be parsed in the development environment and shipped as Perl code, so that the target environment need not have XML::Parser installed. This is useful for XML creation-only tools and as an efficiency tuning measure if you will be rereading the same set of DTDs over and over again. =cut ## TODO: Save as pure, unblessed data structure that XML::Doctype can ## convert to internal format, to increase inter-version compatibility. sub as_pm { my XML::Doctype $self = shift ; my ( $package ) = @_ ; my $date = localtime ; my $class = ref $self ; my $version ; if ( $class ne __PACKAGE__ ) { no strict 'refs' ; croak "\$$class\::VERSION not defined" unless defined ${"$class\::VERSION"} ; $version = "$class, v" . ${"$class\::VERSION"} . ", (" ; } $version .= __PACKAGE__ . ", v$VERSION" ; $version .= ')' if $class ne __PACKAGE__ ; require Data::Dumper ; my $d = Data::Dumper->new( [$self], ['$doctype'], ) ; # $d->Freezer( '_freeze' ) unless $d->can( 'Dumpperl' ) ; $d->Purity(1); ## We really do want to dump executable code. $d->Indent(1); ## Used fixed indent depth. I find this more readable. return join( '', <can( 'Dumpperl' ) ? $d->Dumpperl : $d->Dump, "\n 1 ;\n" ); package $package ; ## ## THIS FILE CREATED AUTOMATICALLY: YOU MAY LOSE ANY EDITS IF YOU MOFIFY IT. ## ## When: $date ## By: $version ## require XML::Doctype ; sub import { my \$pkg = shift ; my \$callpkg = caller ; \$XML::Doctype::_default_dtds{\$callpkg} = \$doctype ; } ENDPREAMBLE } sub _freeze { my $self = shift ; $_->_freeze for values %{$self->{ELTS}} ; return $self ; } =item import =item use use XML::Doctype NAME => 'FooML', SYSTEM_ID => 'dtds/FooML.dtd' ; import() constructs a default DTD object for the calling package so that XML::ValidWriter's functional interface can use it. If XML::Doctype is subclassed, the subclasses' constructor is called with all parameters. =cut sub import { my $class = shift ; my $callpkg = caller ; my @others ; my @dtd_args ; while ( @_ ) { for ( shift ) { if ( $_ eq 'NAME' ) { push @dtd_args, shift ; } elsif ( /^[A-Z][A-Z_0-9]*$/ ) { push @dtd_args, $_, shift ; } else { push @others, $_ ; } } } $_default_dtds{$callpkg} = $class->new( @dtd_args ) if @dtd_args ; croak join( ', ', @others ), " not exported by $class" if @others ; } =head1 SUBCLASSING This object uses the fields pragma, so you should use base and fields for any subclasses. =head1 AUTHOR Barrie Slaymaker =head1 COPYRIGHT This module is Copyright 2000, 2005 Barrie Slaymaker. All rights reserved. This module is licensed under your choice of the Artistic, BSD or General Public License. =cut 1 ; XML-AutoWriter-0.4/lib/XML/ValidWriter.pm0000755000076500000240000012257611214246314016567 0ustar dcpstaffpackage XML::ValidWriter ; =head1 NAME XML::ValidWriter - DOCTYPE driven valid XML output =head1 SYNOPSIS ## As a normal perl object: $writer = XML::ValidWriter->new( DOCTYPE => $xml_doc_type, OUTPUT => \*FH ) ; $writer->startTag( 'b1' ) ; $writer->startTag( 'c2' ) ; $writer->end ; ## Writing to a scalar: $writer = XML::ValidWriter->new( DOCTYPE => $xml_doc_type, OUTPUT => \$buf ) ; ## Or, in scripting mode: use XML::Doctype NAME => a, SYSTEM_ID => 'a.dtd' ; use XML::ValidWriter qw( :all :dtd_tags ) ; b1 ; # Emits c2( attr=>"val" ) ; # Emits endAllTags ; # Emits ## If you've got an XML::Doctype object handy: use XML::ValidWriter qw( :dtd_tags ), DOCTYPE => $doctype ; ## If you've saved a preparsed DTD as a perl module use FooML::Doctype::v1_0001 ; use XML::ValidWriter qw( :dtd_tags ) ; # # This all assumes that the DTD contains: # # # # # # =head1 STATUS Alpha. Use and patch, don't depend on things not changing drastically. Many methods supplied by XML::Writer are not yet supplied here. =head1 DESCRIPTION This module uses the DTD contained in an XML::Doctype to enable compile- and run-time checks of XML output validity. It also provides methods and functions named after the elements mentioned in the DTD. If an XML::ValidWriter uses a DTD that mentions the element type TABLE, that instance will provide the methods $writer->TABLE( $content, ...attrs... ) ; $writer->start_TABLE( ...attrs... ) ; $writer->end_TABLE() ; $writer->empty_TABLE( ...attrs... ) ; . These are created for undeclared elements--those elements not explicitly declared with an declaration--as well. If an element type name conflicts with a method, it will not override the internal method. When an XML::Doctype is parsed, the name of the doctype defines the root node of the document. This name can be changed, though, see L for details. In addition to the object-oriented API, a function API is also provided. This allows you to import most of the methods of XML::ValidWriter as functions using standard import specifications: use XML::ValidWriter qw( :all ) ; ## Could list function names instead C<:all> does not import the functions named after elements mentioned in the DTD, you need to import those tags using C<:dtd_tags>: use XML::Doctype NAME => 'foo', SYSTEM_ID => 'fooml.dtd' ; use XML::ValidWriter qw( :all :dtd_tags ) ; or BEGIN { $doctype = XML::Doctype->new( ... ) ; } use XML::ValidWriter DOCTYPE => $doctype, qw( :all :dtd_tags ) ; =head2 XML::Writer API compatibility Much of the interface is patterned after XML::Writer so that it can possibly be used as a drop-in replacement. It will take awhile before this module emulates enough of XML::Writer to be a drop-in replacement in situations where the more advanced XML::Writer methods are used. If you find you need a method not suported here, write it and send it in! This was not derived from XML::Writer because XML::Writer does not expose it's stack. Even if it did, it's might be difficult to store enough state in it's stack. Unlike XML::Writer, this does not call in all of the IO::* family, and method dispatch should be faster. DTD-specific methods are also supported (see L). =head2 Quick and Easy Unix Filter Apps For quick applications that provide Unix filter application functionality, XML::ValidWriter and XML::Doctype cooperate to allow you to =over =item 1 Parse a DTD at compile-time and set that as the default DTD for the current package. This is done using the use XML::Doctype NAME => 'FooML, SYSTEM_ID => 'fooml.dtd' ; syntax. =item 2 Define and export a set of functions corresponding to start and end tags for all declared and undeclared ELEMENTs in the DTD. This is done by using the C<:dtd_tags> export symbol like so: use XML::Doctype NAME => 'FooML, SYSTEM_ID => 'fooml.dtd' ; use XML::ValidWriter qw(:dtd_tags) ; If the elements a, b_c, and d-e are referred to in the DTD, the following functions will be exported: a() end_a() # like startTag( 'a', ... ) and endTag( 'a' ) b_c() end_b_c() d_e() end_d_e() {'d-e'}() {'end_d-e'}() These functions emit only tags, unlike the similar functions found in CGI.pm and XML::Generator, which also allow you to pass content in as parameters. See below for details on conflict resolution in the mapping of entity names containing /\W/ to Perl subroutine names. If the elements declared in the DTD might conflict with functions in your package namespace, simple put them in some safe namespace: package FooML ; use XML::Doctype NAME => 'FooML', SYSTEM_ID => 'fooml.dtd' ; use XML::ValidWriter qw(:dtd_tags) ; package Whatever ; The advantage of importing these subroutine names is that perl can then detect use of unknown tags at compile time. If you don't want to use the default DTD, use the C<-dtd> option: BEGIN { $dtd = XML::Doctype->new( .... ) } use XML::ValidWriter qw(:dtd_tags), -dtd => \$dtd ; =item 3 Use the default DTD to validate emitted XML. startTag() and endTag() will check the tag being emitted against the list of currently open tags and either emit a minimal set of missing end and start tags necessary to achieve document validity or produce errors or warnings. Since the functions created by the C<:dtd_tags> export symbol are wrappers around startTag() and endTag(), they provide this functionality as well. So, if you have a DTD like you can do this: use XML::Doctype NAME => 'a', SYSTEM_ID => 'a.dtd' ; use XML::ValidWriter ':dtd_tags' ; getDoctype->element_decl('a')->attdef('aa1')->default_on_write('foo') ; a ; b1 ; c1 ; end_c1 ; end_b1 ; b3 ; c3( -attr => val ) ; end_c3 ; end_b3 ; end_a ; and emit a document like "val" /> . =back =head1 OUTPUT OPTIMIZATION XML is a very simple langauge and does not offer a lot of room for optimization. As the spec says "Terseness in XML markup is of minimal importance." XML::ValidWriter does optimize the following on output: Ca...EE/aE> becomes 'Ea... />' Spurious emissions of C<]]EE![CDATA[> are supressed. XML::ValidWriter chooses whether or not to use a section or simply escape '<' and '&'. If you are emitting content for an element in multiple calls to L, the first call decides whether or not to use CDATA, so it's to your advantage to emit as much in the first call as possible. You can do characters( @lots_of_segments ) ; if it helps. =cut use strict ; use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ) ; use fields ( 'AT_BOL', # Set if the last thing emitted was a "\n". 'CDATA_END_PART', # ']' or ']]' if we're in CDATA mode and the last parm # to the last call to characters() ended in this. 'CHECKED_XML_DECL', 'FILE_NAME', # set if the constructor received OUTPUT => 'foo.barml' 'CREATED_AT', # File and line number the instance was created at 'DATA_MODE', # Whether or not to be in data mode 'DOCTYPE', # The parsed DOCTYPE & DTD 'EMITTED_DOCTYPE', 'EMITTED_ROOT', 'EMITTED_XML', 'IS_STANDALONE', 'METHODS', # Cache of AUTOLOADed methods 'OUTPUT', # The output filehandle 'STACK', # The array of open elements 'SHOULD_WARN', # Turns on warnings for things that should (but may not be) # the case, like emitting ''. defaults to '1'. 'WAS_END_TAG', # Set if last thing emitted was an empty tag or an end tag 'STRAGGLERS', # '>' if we just emitted a start tag, ']]>' if {NAME} = $elt_decl->name ; $self->{ELT_DECL} = $elt_decl ; $self->{CONTENT} = [] ; return $self ; } sub add_content { my XML::VWElement $self = shift ; for ( @_ ) { if ( ! @{$self->{CONTENT}} || ! ( $_ eq '#PCDATA' && $self->{CONTENT}->[-1] eq '#PCDATA' ) ) { push @{$self->{CONTENT}}, $_ ; } } } package XML::ValidWriter; ## ## This module can maintain a set of XML::ValidWriter instances, ## one for each calling package. ## my %pkg_writers ; sub _self { ## MUST be called as C< &_self ;> ## If it's a reference to anything but a plain old hash, then the ## first param is either an XML::ValidWriter, a reference to a glob ## a reference to a SCALAR, or a reference to an IO::Handle. return shift if ( @_ && ref $_[0] && isa( $_[0], 'XML::ValidWriter' ) ) ; my $callpkg = caller(1) ; croak "No default XML::ValidWriter declared for package '$callpkg'" unless $pkg_writers{$callpkg} ; return $pkg_writers{$callpkg} ; } =head1 METHODS AND FUNCTIONS All of the routines in this module can be called as either functions or methods unless otherwise noted. To call these routines as functions use either the DOCTYPE or :dtd_tags options in the parameters to the use statement: use XML::ValidWriter DOCTYPE => XML::Doctype->new( ... ) ; use XML::ValidWriter qw( :dtd_tags ) ; This associates an XML::ValidWriter and an XML::Doctype with the package. These are used by the routines when called as functions. =over =item new $writer = XML::ValidWriter->new( DTD => $dtd, OUTPUT => \*FH ) ; Creates an XML::ValidWriter. The value passed for OUTPUT may be: =over =item a SCALAR ref if you want to direct output to append to a scalar. This scalar is truncated whenever the XML::ValidWriter object is reset() or DESTROY()ed =item a file handle glob ref or a reference to an IO object XML::ValidWriter does not load IO. This is the only mode compatible with XML::Writer. =item a file name A simple scalar is taken to be a filename to be created or truncated and emitted to. This file will be closed when the XML::ValidWriter object is reset or deatroyed. =back NOTE: if you leave OUTPUT undefined, then the currently select()ed output is used at each emission (ie calling select() can alter the destination mid-stream). This eases writing command line filter applications, the select() interaction is unintentional, and please don't depend on it. I reserve the right to cache the select()ed filehandle at creation time or at time of first emission at some point in the future. =cut sub new { my XML::ValidWriter $self = fields::new( shift ); $self->{SHOULD_WARN} = 1 ; while ( @_ ) { for my $parm ( shift ) { if ( $parm eq 'DOCTYPE' ) { croak "Can't have two DOCTYPE parms" if defined $self->{DOCTYPE} ; $self->{DOCTYPE} = shift ; } elsif ( $parm eq 'OUTPUT' ) { croak "Can't have two OUTPUT parms" if defined $self->{OUTPUT} || defined $self->{FILE_NAME} ; if ( ref $_[0] ) { $self->{OUTPUT} = shift ; } else { $self->{FILE_NAME} = shift ; } } } } ## Find the original caller my $caller_depth = 1 ; ++$caller_depth while caller && isa( scalar( caller $caller_depth ), __PACKAGE__ ) ; $self->{CREATED_AT} = join( ', ', (caller( $caller_depth ))[1,2] ); $self->reset ; return $self ; } =item import Can't think of why you'd call this method directly, it gets called when you use this module: use XML::ValidWriter qw( :all ) ; In addition to the normal functionality of exporting functions like startTag() and endTag(), XML::ValidWriter's import() can create functions corresponding to all elements in a DTD. This is done using the special C<:dtd_tags> export symbol. For example, use XML::Doctype NAME => 'FooML', SYSTEM_ID => 'fooml.dtd' ; use XML::ValidWriter qw( :dtd_tags ) ; where fooml.dtd referse to a tag type of 'blurb' causes these functions to be imported: blurb() # calls defaultWriter->startTag( 'blurb', @_ ) ; blurb_element() # calls defaultWriter->dataElement( 'blurb', @_ ) ; empty_blurb() # calls defaultWriter->emptyTag( 'blurb', @_ ) ; end_blurb() # calls defaultWriter->endTag( 'blurb' ) ; The range of characters for element types is much larger than the range of characters for bareword perl subroutine names, which are limited to [a-zA-Z0-9_]. In this case, XML::ValidWriter will export an oddly named function that you can use a symbolic reference to call (you will need C if you are doing a C): &{"space-1999:moonbase"}( ...attributes ... ) ; . XML::ValidWriter will also try to fold the name in to bareword space by converting /\W/ symbols to '_'. If the resulting function name, space_1999_moonbase( ...attributes... ) ; has not been generated and is not the name of an element type, then it will also be exported. If you are using a DTD that might introduce function names that conflict with existing ones, simple export them in to their own namespace: package ML ; use XML::Doctype NAME => 'foo', SYSTEM_ID => 'fooml.dtd' ; use XML::ValidWriter qw( :dtd_tags ) ; package main ; use XML::ValidWriter qw( :all ) ; ML::foo ; ML::c2 ; ML::c1 ; ML::end_a ; I gave serious thought to converting ':' in element names to '::' in function declarations, which might work well in the functions-in-their-own- namespace case, but not in the default case, since Perl does not (yet) have relative namespaces. Another alternative is to allow a mapping of XML namespaces to Perl namespaces to be done. =cut ## use %pkg_writers, defined above ## This import is odd: it allows subclasses to 'inherit' exports sub import { my $pkg = shift ; my $callpkg = caller ; my $doctype ; my @args ; my @syms ; my $export_dtd_tags ; my $op ; while ( @_ ) { $op = shift ; if ( $op eq 'DOCTYPE' ) { $doctype = shift ; } elsif ( $op eq ':dtd_tags' ) { $export_dtd_tags = 1 ; } elsif ( $op eq ':all' ) { push @syms, @EXPORT_OK ; } elsif ( $op =~ /^[A-Z_0-9]+$/ ) { push @args, $op ; push @args, shift ; } elsif ( $op =~ /^[:$%@*]/ ) { croak "import tag '$op' not supported" ; } else { push @syms, $op ; } } if ( $export_dtd_tags || $doctype ) { $pkg_writers{$callpkg} = $pkg->new( @args ) unless $pkg_writers{$callpkg} ; $doctype = $XML::Doctype::_default_dtds{$callpkg} if ! $doctype && exists $XML::Doctype::_default_dtds{$callpkg} ; $pkg_writers{$callpkg}->setDoctype( $doctype ) if $doctype ; } $pkg_writers{$callpkg}->exportDTDTags( $callpkg ) if $export_dtd_tags ; my %ok = map { ( $_ => 1 ) } @EXPORT_OK ; for my $sym ( @syms ) { no strict 'refs' ; $sym =~ s/^&// ; if ( $ok{$sym} ) { if ( defined &{"$pkg\::$sym"} ) { *{"$callpkg\::$sym"} = \&{"$pkg\::$sym"} ; next ; } elsif ( defined &{$sym} ) { *{"$callpkg\::$sym"} = \&{"$sym"} ; next ; } } croak "Function '$sym' not exported by '$pkg' or " . __PACKAGE__ ; } } my %escapees ; $escapees{'&'} = '&' ; $escapees{'<'} = '<' ; $escapees{'>'} = '>' ; $escapees{']>'} = ']>' ; $escapees{']]>'} = ']]>' ; $escapees{'"'} = '"' ; $escapees{"'"} = ''' ; # Takes a list, returns a list: don't use in scalar context. sub _esc { croak "_esc used in scalar context" unless wantarray ; my $text ; return map { $text = $_ ; if ( $text =~ /([\x00-\x08\x0B\x0C\x0E-\x1F])/ ) { croak sprintf( "Illegal character 0x%02d (^%s) sent", ord $1, chr( ord( "A" ) + ord( $1 ) - 1 ) ) } $text =~ s{([&<]|^>|^\]>|\]\]>)}{$escapees{$1}}eg ; $text ; } @_ ; } sub _esc1 { my $text = shift ; if ( $text =~ /([\x00-\x08\x0B\x0C\x0E-\x1F])/ ) { croak sprintf( "Invalid character 0x%02d (^%s) sent", ord $1, chr( ord( "A" ) + ord( $1 ) - 1 ) ) } $text =~ s{([&<]|^>|^\]>|\]\]>)}{$escapees{$1}}eg ; return $text ; } sub _attr_esc1 { my $text = shift ; if ( $text =~ /([\x00-\x08\x0B\x0C\x0E-\x1F])/ ) { croak sprintf( "Invalid character 0x%02d (^%s) sent", ord $1, chr( ord( "A" ) + ord( $1 ) - 1 ) ) } $text =~ s{([&<"'])}{$escapees{$1}}eg ; return $text ; } sub _esc_cdata_ends { ## This could be very memory hungry, but alas... my $text = join( '', @_ ) ; if ( $text =~ /([\x00-\x08\x0B\x0C\x0E-\x1F])/ ) { croak sprintf( "Invalid character 0x%02d (^%s) sent", ord $1, chr( ord( "A" ) + ord( $1 ) - 1 ) ) } $text =~ s{\]\]>}{]]]]>}g ; return $text ; } =item characters characters( "escaped text", "& more" ) ; $writer->characters( "escaped text", "& more" ) ; Emits character data. Character data will be escaped before output, by either transforming 'E' and '&' to < and &, or by enclosing in a 'C![CDATA[...]]E>' bracket, depending on which will be more human-readable, according to the module. =cut sub characters { my XML::ValidWriter $self = &_self ; my $to = $self->{OUTPUT} || select ; croak "Can't emit characters before the root element" if ! defined $self->{EMITTED_ROOT} ; my $stack = $self->{STACK} ; croak "Can't emit characters outside of the root element" unless @$stack ; my XML::VWElement $end_elt = $stack->[-1]; my $open_elt = $self->getDoctype->element_decl( $end_elt->{NAME} ) ; croak "Element '$open_elt->{NAME}' can't contain #PCDATA" unless ! $open_elt || $open_elt->can_contain_pcdata ; croak "Undefined value passed to characters() in <$open_elt->{NAME}>" if grep ! defined $_, @_ ; my $length ; my $decide_cdata = $self->{STRAGGLERS} eq '>' ; my $in_cdata_mode ; if ( $decide_cdata ) { my $escs = 0 ; my $cdata_ends = 0 ; my $cdata_escs = 0 ; my $pos ; ## I assume that splitting CDATA ends between chunks is very ## rare. If an app does that a lot, then this could guess 'wrong' ## and use CDATA escapes in a situation where they result in more ## bytes out than <& escaping would. for ( @_ ) { $escs += tr/<&// ; $pos = 0 ; ++$cdata_ends while ( $pos = index $_, ']]>', $pos + 3 ) >= 0 ; $cdata_escs += tr/\x00-\x08\x0b\x0c\x0e-\x1f// ; $length += length $_ ; } ## Each < or & is 4 or 5 chars. ## Each ]]]]>&#xN; is 12 chars. $in_cdata_mode = 4.5*$escs > 15*$cdata_ends + 17.75*$cdata_escs + 12 ; } else { $in_cdata_mode = $self->{STRAGGLERS} eq ']]>' ; $length += length $_ for @_ ; } return unless $length ; ## I chose to stay in or out of CDATA mode for an element ## in order to keep document structure relatively simple...to keep human ## readers from getting confused between escaping modes. ## This may lead to degeneracy if it's an (SG|X)ML document being emitted in ## an element, so this may change. if ( $in_cdata_mode ) { if ( $self->{STRAGGLERS} eq ']]>' ) { ## Don't emit ']]>{STRAGGLERS} = '' ; } else { $self->{STRAGGLERS} .= '{STRAGGLERS}, _esc_cdata_ends( $self->{CDATA_END_PART}, @_ ) ) ; $self->{CDATA_END_PART} = $$to =~ s/(\]\]?)(?!\n)\Z// ? $1 : '' ; } else { no strict 'refs' ; my $chunk = _esc_cdata_ends( $self->{CDATA_END_PART}, @_ ) ; $self->{CDATA_END_PART} = $chunk =~ s/(\]\]?)(?!\n)\Z// ? $1 : '' ; print $to $self->{STRAGGLERS}, $chunk or croak "$! writing chars in <$open_elt->{NAME}>" ; } $self->{STRAGGLERS} = ']]>' ; } else { if ( ref $to eq 'SCALAR' ) { $$to .= $self->{STRAGGLERS} ; $$to .= _esc1( join( '', @_ ) ) ; } else { no strict 'refs' ; print $to $self->{STRAGGLERS}, _esc( @_ ) or croak "$! writing chars in <$open_elt->{NAME}>" ; } $self->{STRAGGLERS} = '' ; # $self->{CDATA_END_PART} = '' ; } $stack->[-1]->add_content( '#PCDATA' ) if @{$stack} ; $self->{WAS_END_TAG} = 0 ; return ; } =item dataElement $writer->dataElement( $tag ) ; $writer->dataElement( $tag, $content ) ; $writer->dataElement( $tag, $content, attr1 => $val1, ... ) ; dataElement( $tag ) ; dataElement( $tag, $content ) ; dataElement( $tag, $content, attr1 => $val1, ... ) ; Does the equivalent to ## Split the optional args in to attributes and elements arrays. $writer->startTag( $tag, @attributes ) ; $writer->characters( $content ) ; $writer->endTag( $tag ) ; This function is exportable as dataElement(), and is also exported for each element 'foo' found in the DTD as foo(). =cut sub dataElement { my XML::ValidWriter $self = shift ; my ( $tag ) = shift ; croak "Odd number of parameters passed to dataElement for <$tag>" if @_ && ! @_ & 1 ; ## We avoid copying content (attribute or element) more than we ## have to so as not to do more copies than necessary of ## potenially huge content. We still do have to copy content to ## pass it to characters(), though. $self->startTag( $tag, @_[1..$#_] ) ; my $is_empty = $self->{WAS_END_TAG} ; ## If ! defined we want to pass it in, so we get an error if ( @_ && ( ! defined $_[0] || length $_[0] ) ) { croak "Can't emit character data to EMPTY <$tag>" if $self->{WAS_END_TAG} ; $self->characters( $_[0] ) ; } $self->endTag( $tag ) unless $is_empty ; return ; } =item defaultWriter $writer = defaultWriter ; ## Not a method! $writer = defaultWriter( 'Foo::Bar' ) ; Returns the default XML::ValidWriter for the given package, or the current package if none is specified. This is useful for getting at methods like C that are not also functions. Croaks if no default writer has been defined (see L). =cut sub defaultWriter(;$) { my $pkg = @_ ? shift : caller ; croak "No default XML::ValidWriter created for package '$pkg'" unless exists $pkg_writers{$pkg} && $pkg_writers{$pkg} ; } =item doctype # Using the writer's associated DTD: doctype ; # Ignoring the writer's associated DTD: doctype( $type ) ; doctype( $type, undef, $system ) ; doctype( $type, $public, $system ) ; $writer->doctype ; ...etc See L to emit the entire DTD in the document. This checks to make sure that no doctype or elements have been emitted. A warning is emitted if standalone="yes" was specified in the declaration and a system id is specified. This is extremely likely to be an error. If you need to silence the warning, write me (see below). Passing '' or '0' (zero) as a $public_id or as a $system_id also generates a warning, as these are extremely likely to be errors. =cut sub doctype { my XML::ValidWriter $self = &_self ; my ( $type, $public_id, $system_id ) = @_ ; croak " already emitted" if defined $self->{EMITTED_DOCTYPE} ; croak " can't be emitted after elements" if defined $self->{EMITTED_ROOT} ; croak "A PUBLIC_ID was specified, but no SYSTEM_ID" if $public_id && ! $system_id ; carp "'' passed for a PUBLIC_ID" if defined $public_id && ! $public_id ; carp "'' passed for a SYSTEM_ID" if defined $system_id && ! $system_id ; carp "SYSTEM_ID specified for a standalone document" if defined $system_id && $self->{IS_STANDALONE} ; $self->rawCharacters( "" ) ; $self->{EMITTED_DOCTYPE} = defined $type ? $type : "UNKNOWN" ; } =item emptyTag emptyTag( $tag[, attr1 => $val1... ] ) ; $writer->emptyTag( $tag[, attr1 => $val1... ] ) ; Emits an empty tag like ''. The extra space is for compatibility with XHTML. =cut sub emptyTag { my XML::ValidWriter $self = shift ; ## Sneaky, sneaky... return $self->startTag( @_, '#EMPTY' ) ; } =item endTag endTag ; endTag( 'a' ) ; $writer->endTag ; $writer->endTag( 'a' ) ; Prints one or more end tags. The tag name is optional and defaults to the most recently emitted start tag if not present. This will emit as many close tags as necessary to close the supplied tag name, or will emit an error if the tag name specified is not open in the output document. =cut sub endTag { my XML::ValidWriter $self = &_self ; $self->{CHECKED_XML_DECL} ||= ( carp( "No emitted." ), 1 ) ; my $stack = $self->{STACK} ; unless ( @$stack ) { my $tag = @_ ? shift : '' ; if ( $self->{EMITTED_ROOT} ) { croak "Too many end tags emitted" . ( $tag ? ", can't emit '$tag'" : '' ) ; } croak "Can't endTag(", $tag ? " '$tag' " : '', ") when no tags have been emitted" ; } my XML::VWElement $se = pop @$stack ; my $tag = @_ ? shift : $se->{NAME} ; croak "Unmatched , open tags are: ", join( '', map "<$_->{NAME}>", @$stack, $se ) if $tag ne $se->{NAME} ; unless ( $se->{ELT_DECL}->validate_content( $se->{CONTENT} ) ) { if ( @{$se->{CONTENT}} ) { croak( "Invalid content for <$tag>: " . join( '', map "<$_>", @{$se->{CONTENT}} ) ) } else { croak "Content required for <$tag>" ; } } my $prefix = '' ; if ( $self->{DATA_MODE} && $self->{WAS_END_TAG} ) { $prefix = " " x ( 3 * @$stack ) ; } if ( $self->{STRAGGLERS} eq '>' ) { ## Last thing emitted was a start tag. $self->{STRAGGLERS} = '' ; $self->rawCharacters( ' />', ! @{$stack} || $self->getDataMode ? "\n" : () ) ; } else { $self->rawCharacters( $prefix, '', ! @{$stack} || $self->getDataMode ? "\n" : () ) ; } $self->{WAS_END_TAG} = 1 ; } =item end $writer->end ; # Not a function!! Emits all necessary end tags to close the document. Available as a method only, since 'end' is a little to generic to be exported as a function name, IMHO. See 'endAllTags' for the plain function equivalent function. =cut sub end { # Well, I lied, you could call it as a function. my XML::ValidWriter $self = &_self ; $self->endTag() while @{$self->{STACK}} ; croak "No root element emitted" unless defined $self->{EMITTED_ROOT} ; } =item endAllTags endAllTags ; $writer->endAllTags ; A plain function that emits all necessart end tags to close the document. Corresponds to the method C, but is exportable as a function/ =cut { no strict 'refs' ; *{"endAllTags"} = \&end ; } =item exportDTDTags $writer->exportDTDTags() ; $writer->exportDTDTags( $to_pkg ) ; Exports the tags found in the DTD to the caller's namespace. =cut sub exportDTDTags { my XML::ValidWriter $self = &_self ; my $pkg = ref $self ; my $callpkg = @_ ? shift : caller ; my $doctype = $self->{DOCTYPE} ; croak "No DOCTYPE specified to export tags from" unless $doctype ; ## Export tag() and end_tag(), tag_element(), and empty_tag() ; no strict 'refs' ; for my $tag ( $doctype->element_names ) { *{"$callpkg\::start_$tag"} = sub { $pkg_writers{$callpkg}->startTag( $tag, @_ ) ; }, *{"$callpkg\::end_$tag"} = sub { $pkg_writers{$callpkg}->endTag( $tag, @_ ) ; }, *{"$callpkg\::empty_$tag"} = sub { $pkg_writers{$callpkg}->emptyTag( $tag, @_ ) ; }, *{"$callpkg\::$tag"} = sub { $pkg_writers{$callpkg}->dataElement( $tag, @_ ) ; }, } } =item getDataMode $m = getDataMode ; $m = $writer->getDataMode ; Returns TRUE if the writer is in DATA_MODE. =cut sub getDataMode { my XML::ValidWriter $self = shift ; return $self->{DATA_MODE} ; } =item getDoctype $dtd = getDoctype ; $dtd = $writer->getDoctype ; This is used to get the writer's XML::Doctype object. =cut sub getDoctype { my XML::ValidWriter $self = &_self ; return $self->{DOCTYPE} ; } =item getOutput $fh = getOutput ; $fh = $writer->getOutput ; Gets the filehandle an XML::ValidWriter sends output to. =cut sub getOutput { my XML::ValidWriter $self = &_self ; return $self->{OUTPUT} ; } =item rawCharacters rawCharacters( "", "& more text" ) ; $writer->rawCharacters( "", "& more text" ) ; This allows you to emit raw text without any escape processing. The text is not examined for tags, so you can invalidate your document and even corrupt it's well-formedness. =cut ## This is called everywhere to emit raw characters *except* characters(), ## which must go direct because it uses STRAGGLERS and CDATA_END_PART ## differently. sub rawCharacters { my XML::ValidWriter $self = &_self ; my $to= $self->{OUTPUT} || select ; return unless grep length $_, @_ ; if ( ref $to eq 'SCALAR' ) { $$to .= join( '', _esc_cdata_ends( $self->{CDATA_END_PART} ), $self->{STRAGGLERS}, @_ ) ; $self->{AT_BOL} = substr( $$to, -1, 1 ) eq "\n" ; } else { no strict 'refs' ; for ( my $i = $#_ ; $i >= 0 ; --$i ) { next unless length $_[$i] ; $self->{AT_BOL} = substr( $_[$i], -1, 1 ) eq "\n" ; last ; } print $to _esc_cdata_ends( $self->{CDATA_END_PART} ), $self->{STRAGGLERS}, @_ or croak $!; } $self->{CDATA_END_PART} = '' ; $self->{STRAGGLERS} = '' ; } =item reset $writer->reset ; # Not a function! Resets a writer to be initialized, but not have emitted anything. This is useful if you need to abort output, but want to reuse the XML::ValidWriter. =cut sub reset { my XML::ValidWriter $self = shift ; $self->{STACK} = [] ; # If we should warn, clear the flag that says we checked it & vice versa $self->{CHECKED_XML_DECL} = ! $self->{SHOULD_WARN} ; ## I'd use assignement to a slice here, but older perls... $self->{IS_STANDALONE} = 0 ; $self->{EMITTED_DOCTYPE} = undef ; $self->{EMITTED_ROOT} = undef ; $self->{EMITTED_XML} = undef ; $self->{AT_BOL} = 1 ; $self->{WAS_END_TAG} = 1 ; $self->{STRAGGLERS} = '' ; $self->{CDATA_END_PART} = '' ; if ( defined $self->{FILE_NAME} ) { if ( defined $self->{OUTPUT} ) { close $self->{OUTPUT} or croak "$! closing '$self->{FILE_NAME}'." ; } else { require Symbol ; $self->{OUTPUT} = Symbol::gensym() ; } eval "use Fcntl ; 1" or croak $@ ; open( $self->{OUTPUT}, ">$self->{FILE_NAME}", ) or croak "$!: $self->{FILE_NAME}" ; } return ; } =item setDataMode setDataMode( 1 ) ; $writer->setDataMode( 1 ) ; Enable or disable data mode. =cut sub setDataMode { my XML::ValidWriter $self = &_self ; $self->{DATA_MODE} = shift ; return ; } =item setDoctype setDoctype $doctype ; $writer->setDoctype( $doctype ) ; This is used to set the doctype object. =cut sub setDoctype { my XML::ValidWriter $self = &_self ; $self->{DOCTYPE} = shift if @_ ; return ; } =item select_xml select_xml OUTHANDLE ; # Nnot a method!! Selects a filehandle to send the XML output to when not using the object oriented interface. This is similar to perl's builtin select, but only affects startTag and endTag functions, (not methods). This is only needed if you want to interleave output to the selected output files (usually STDOUT, see L and to an XML file on another filehandle. If you want to redirect all output (yours and XML::Writer's) to the same file, just use Perl's built-in select(), since startTag and endTag emit to the currently selected filehandle by default. Like select, this returns the old value. =cut sub select_xml(;*) { ## I cheat a little and this could be used as a method my XML::ValidWriter $self = &_self ; my $r = $self->getOutput ; $self->setOutput( shift ) if @_ ; return $r ; } =item setOutput setOutput( \*FH ) ; $writer->setOutput( \*FH ) ; Sets the filehandle an XML::ValidWriter sends output to. =cut sub setOutput { my XML::ValidWriter $self = &_self ; $self->{OUTPUT} = shift if @_ ; return ; } =item startTag startTag( 'a', attr => val ) ; # use default XML::ValidWriter for # current package. $writer->startTag( 'a', attr => val ) ; Emits a named start tag with optional attributes. If the named tag cannot be a child of the most recently started tag, then any tags that need to be opened between that one and the named tag are opened. If the named tag cannot be enclosed within the most recently opened tag, no matter how deep, then startTag() tries to end as few started tags as necessary to allow the named tag to be emitted within a tag already on the stack. This warns (once) if no declaration has been emitted. It does not check to see if a has been emitted. It dies if an attempt is made to emit a second root element. =cut sub startTag { my XML::ValidWriter $self = &_self ; my $tag = shift ; croak "Must supply a tag name" unless defined $tag ; $self->{CHECKED_XML_DECL} ||= ( carp( "No emitted." ), 1 ) ; if ( ! @{$self->{STACK}} ) { if ( defined $self->{EMITTED_ROOT} ) { croak "Root element '$self->{EMITTED_ROOT}' ended, can't emit '$tag'" } else { if ( $tag ne $self->{DOCTYPE}->name ) { croak "Root element '$tag' does not match DOCTYPE '", $self->getDTD->name, "'" } } $self->{EMITTED_ROOT} = $tag ; } my $elt_decl = $self->{DOCTYPE}->element_decl( $tag ) ; my @attrs ; my %attrs ; ## emptyTag sneaks an '#EMPTY' on the parms and calls us. my $is_empty = @_ && $_[-1] eq '#EMPTY' ? pop : $elt_decl->is_empty ; croak "Odd number of parameters passed to startTag( '$tag' ): ", scalar( @_ ) if @_ & 1 ; while ( @_ ) { my ( $attr, $val ) = ( shift, shift ) ; croak "Undefined attribute name for <$tag>" unless defined $attr ; croak "Undefined attribute value for <$tag>, attribute '$attr'" unless defined $val ; croak "Attribute '$attr' already emitted" if $attrs{$attr} ; $attrs{$attr} = $val ; push @attrs, ( ' ', $attr, '="', _attr_esc1( $val ), '"' ) ; } if ( $elt_decl ) { for my $attdef ( $elt_decl->attdefs ) { my $name = $attdef->name ; my $quant = $attdef->quant ; push @attrs, ( ' ', $name, '="', $attrs{$name} = _attr_esc1( $attdef->default_on_write ), '"' ) if ! exists $attrs{$name} && defined $attdef->default_on_write ; if ( $quant eq '#FIXED' ) { if ( exists $attrs{$name} ) { croak "Attribute '$name' is #FIXED to '" . $attdef->default . "' and cannot be emitted as '" . $attrs{$name} . "'" if $attdef->default ne $attrs{$name} } else { ## Output #FIXED attributes if they weren't passed push @attrs, ( ' ', $name, '="', _attr_esc1( $attdef->default ), '"' ) ; } } elsif ( $quant eq '#REQUIRED' ) { croak "Tag '$tag', attribute '$name' #REQUIRED, but not provided" unless exists $attrs{$name} && defined $attrs{$name} ; } } } ## TODO: A quick check to see if $tag can be it's parent's child. ## TODO: Incremental data model checking. my $stack = $self->{STACK} ; my $prefix = '' ; if ( $self->{DATA_MODE} ) { $prefix = ( $self->{AT_BOL} ? "" : "\n" ) . " " x ( 3 * @$stack ) ; } if ( $is_empty ) { $self->rawCharacters( $prefix, '<', $tag, @attrs, ' />', ! @$stack || $self->getDataMode ? "\n" : () ) ; } else { $self->rawCharacters( $prefix, '<', $tag, @attrs ) ; $self->{STRAGGLERS} = '>' ; } $stack->[-1]->add_content( $tag ) if @{$stack} ; push @$stack, XML::VWElement->new( $elt_decl ) unless $is_empty ; $self->{WAS_END_TAG} = $is_empty ; return ; } =item xmlDecl([[$encoding][, $standalone]) xmlDecl ; xmlDecl( "UTF-8" ) ; xmlDecl( "UTF-8", "yes" ) ; $writer->xmlDecl( ... ) ; Emits an XML declaration. Must be called before any of the other output routines. If $encoding is not defined, it is not output. This is slightly different than XML::Writer, which outputs 'UTF-8' if you pass in undef, 0, or ''. If $encoding is '' or 0, then it is output as "" or "0" and a warning is generated. If $standalone is defined and is not 'no', 0, or '', it is output as 'yes'. If it is 'no', then it is output as 'no'. If it's 0 or '' it is not output. =cut sub xmlDecl { my XML::ValidWriter $self = &_self ; croak " already emitted" if defined $self->{EMITTED_XML} ; croak " not the first thing in the document" if defined $self->{EMITTED_DOCTYPE} || defined $self->{EMITTED_ROOT} ; my ( $encoding, $standalone ) = @_ ; if ( defined $encoding ) { carp "encoding '$encoding' passed" if ! $encoding ; } $standalone = 'yes' if $standalone && $standalone ne 'no' ; $self->rawCharacters( '\n" ) ; $self->{CHECKED_XML_DECL} = 1 ; $self->{IS_STANDALONE} = $standalone && $standalone eq 'yes' ; # declare open season on tag emission $self->{EMITTED_XML} = 1 ; } =item AUTOLOAD This function is called whenever a function or method is not found in XML::ValidWriter. If it was a method being called, and the desired method name is a start or end tag found in the DTD, then a method is cooked up on the fly. These methods are slower than normal methods, but they are cached so that they don't need to be recompiled. The speed penalty is probably not significant since they do I/O and are thus usually orders of magnitude slower than normal Perl methods. =cut ## TODO: Perhaps change exportDTDTags to use AUTOLOAD ## TODO: Allow caching of methods in package namespace as an option so ## that specializations of XML::ValidWriter can avoid the AUTOLOAD speed ## hit. use vars qw( $AUTOLOAD ) ; sub AUTOLOAD { croak "Function $AUTOLOAD not AUTOLOADable (no functions are)" unless isa( $_[0], __PACKAGE__ ) ; my XML::ValidWriter $self = $_[0] ; unless ( exists $self->{METHODS}->{$AUTOLOAD} ) { my ( $class, $ss, $method ) = $AUTOLOAD =~ /^(.*)::((?:start_|end_|empty_)?)(.*?)$/ ; croak "Can't parse method name '$AUTOLOAD'" unless defined $class ; croak "Method $AUTOLOAD does not refer to an element in the XML::Doctype" unless $self->{DOCTYPE}->element_decl( $method ) ; my $sub = $ss eq '' ? sub { my XML::ValidWriter $self = shift ; $self->dataElement( $method, @_ ) ; } : $ss eq 'start_' ? sub { my XML::ValidWriter $self = shift ; $self->startTag( $method, @_ ) ; } : $ss eq 'end_' ? sub { my XML::ValidWriter $self = shift ; $self->endTag( $method, @_ ) ; } : sub { my XML::ValidWriter $self = shift ; $self->emptyTag( $method, @_ ) ; } ; $self->{METHODS}->{$AUTOLOAD} = $sub ; } goto &{$self->{METHODS}->{$AUTOLOAD}} } =item DESTROY DESTROY is called when an XML::ValidWriter is cleaned up. This is used to automatically close all tags that remain open. This will not work if you have closed the output filehandle that the ValidWriter was using. This method will also warn if anything was emitted bit no root node was emitted. This warning can be silenced by calling $writer->reset() ; when you abandon output. =cut ##TODO: Prevent $self->end for errored objects. ##TODO: Prevent further output to errored objects if they cannot ever ## be valid. Perhaps prevent it to all errored objects? sub DESTROY { my XML::ValidWriter $self = shift ; # if ( @{$self->{STACK}} ) { # $self->end() ; # } if ( defined $self->{FILE_NAME} ) { close $self->{OUTPUT} or croak "$! closing '$self->{FILE_NAME}'." ; } if ( ! defined $self->{EMITTED_ROOT} && ( defined $self->{EMITTED_XML} || defined $self->{EMITTED_DOCTYPE} ) ) { ## TODO: Identify a document name here carp "No content emitted after preamble in ", ref $self, " created at ", $self->{CREATED_AT} ; ; } } =back =head1 AUTHOR Barrie Slaymaker =head1 COPYRIGHT This module is Copyright 2000, 2005 Barrie Slaymaker. All rights reserved. This module is licensed under your choice of the Artistic, BSD or General Public License. =cut 1 ; XML-AutoWriter-0.4/Makefile.PL0000755000076500000240000000037711214246150014531 0ustar dcpstaffuse inc::Module::Install; perl_version '5.006001'; name 'XML-AutoWriter'; all_from 'lib/XML/AutoWriter.pm'; requires => 'XML::Parser'; build_requires => 'Test'; build_requires => 'IO::File'; auto_set_repository; auto_manifest; auto_install; WriteAll; XML-AutoWriter-0.4/MANIFEST0000644000076500000240000000112711214247332013702 0ustar dcpstaffCHANGES inc/Module/AutoInstall.pm inc/Module/Install.pm inc/Module/Install/AutoInstall.pm inc/Module/Install/AutoManifest.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Include.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/XML/AutoWriter.pm lib/XML/Doctype.pm lib/XML/Doctype/AttDef.pm lib/XML/Doctype/ElementDecl.pm lib/XML/ValidWriter.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml t/auto.t t/cm_re.t t/dtd.t t/escape.t t/foo.t t/valid.t XML-AutoWriter-0.4/MANIFEST.SKIP0000644000076500000240000000033511214245634014452 0ustar dcpstaff^\.git ^_build ^Build$ ^blib ~$ \.bak$ CVS \.svn \.DS_Store cover_db \..*\.sw.?$ ^Makefile$ ^pm_to_blib$ ^MakeMaker-\d ^blibdirs$ \.old$ ^#.*#$ ^\.# ^TODO$ ^PLANS$ ^doc/ ^benchmarks ^\._.*$ ^t\/600_todo_tests\/$ \.shipit XML-AutoWriter-0.4/META.yml0000644000076500000240000000101711214247327014024 0ustar dcpstaff--- abstract: 'DOCTYPE based XML output' author: - 'Barrie Slaymaker ' build_requires: ExtUtils::MakeMaker: 6.42 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.87' license: bsd meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: XML-AutoWriter no_index: directory: - inc - t requires: perl: 5.6.1 resources: license: http://opensource.org/licenses/bsd-license.php version: 0.4 XML-AutoWriter-0.4/t/0000755000076500000240000000000011214247332013013 5ustar dcpstaffXML-AutoWriter-0.4/t/auto.t0000755000076500000240000001555711214245237014172 0ustar dcpstaff#!/usr/local/bin/perl -w =head1 NAME writer.t - test suite for XML::Doctype =cut package Foo ; use Test ; package main ; use strict ; use IO::File; use Test ; use XML::Doctype ; use UNIVERSAL qw( isa ) ; my $w ; my $doctype ; my $t = 't' ; my $out_name = "$t/out" ; my $buf ; my $dtd = < TOHERE my %dtd1_elts = ( a => { KIDS => [qw( b1 b2 b3 )], }, b1 => { KIDS => [qw( c1 )], }, b2 => { KIDS => [qw( c2 )], }, b3 => { KIDS => [qw( c3 )], }, ) ; sub slurp { my ( $in_name ) = @_ ; open( F, "<$in_name" ) or die "$!: $in_name" ; local $/ = undef ; my $in = join( '', ) ; close F ; $in =~ s/\n//g ; return $in ; } my $xml_decl = qq{} ; sub test_xml_decl { my $expected = pop ; package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; ## The extra ()'s are necessary because we didn't import at compile time. xmlDecl( @_ ) ; start_a() ; c1() ; endAllTags() ; $buf =~ s/\n//g ; $expected =~ s/\n//g ; ok( $buf, $expected ) ; } my @tests = ( sub { $doctype = XML::Doctype->new( 'a', DTD_TEXT => $dtd ) ; ok( $doctype ) ; }, sub { unlink $out_name ; my $f = IO::File->new( ">$out_name" ) ; my $w = XML::AutoWriter->new( DOCTYPE => $doctype, OUTPUT => $f, ) ; $w->getDoctype->element_decl('a')->attdef('aa1')->default_on_write('foo') ; $w->xmlDecl ; $w->startTag( 'a' ) ; $w->startTag( 'c1' ) ; $w->end ; $f->close ; ok( slurp( $out_name ), qq{$xml_decl} ) ; }, ## ## import tests ## sub { package Foo ; eval 'use XML::AutoWriter qw(:all :dtd_tags), DOCTYPE => $doctype' ; die $@ if $@ ; ok( defined &a ) ; }, sub { package Foo ; ok( defined &end_a ) ; }, sub { unlink $out_name ; eval <<'TOHERE' ; package Foo ; defaultWriter()->reset ; open( F, ">$out_name" ) or die "$!: '$out_name'" ; select F ; xmlDecl ; start_a foo => '&<>"' ; start_b1 ; c1 ; endAllTags ; select STDOUT ; close F ; TOHERE die $@ if $@ ; ok( slurp( $out_name ), qq{$xml_decl} ) ; unlink $out_name ; }, ## ## XML decl tests ## # Commented out so as to not to trigger complaints about warnings #sub { # package Foo ; # $buf = '' ; # defaultWriter()->reset ; # select_xml( \$buf ) ; # ## The extra ()'s are necessary because we didn't import at compile time. # a() ; # ok( $buf, qq{} ) ; #}, sub { test_xml_decl( 'foo', qq{\n} ) ; }, sub { test_xml_decl( 'foo', 'bar', qq{\n} ) ; }, # Commented out so as not to trigger complaints about warnings #sub { # test_xml_decl( '', 'bar', # qq{\n} # ) ; #}, # #sub { # test_xml_decl( 0, 'bar', # qq{\n} # ) ; #}, # sub { test_xml_decl( undef, '', qq{\n} ) ; }, sub { test_xml_decl( undef, 0, qq{\n} ) ; }, sub { test_xml_decl( undef, 'no', qq{\n} ) ; }, ## ## Misc tag emission tests ## sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; ## The extra ()'s are necessary because we didn't import at compile time. xmlDecl() ; start_a() ; start_b1() ; start_c1() ; characters( '<>' ) ; rawCharacters( '<>' ) ; end_a() ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_decl<><>} ) ; }, sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; xmlDecl() ; start_a() ; start_c1() ; end_a() ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_decl} ) ; }, sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; xmlDecl() ; start_a() ; c1() ; characters( 'bar' ) ; end_a() ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_declbar} ) ; }, sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; xmlDecl() ; start_a() ; c1() ; b3( 'bar' ) ; end_a() ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_declbar} ) ; }, sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; xmlDecl() ; start_a() ; start_c1() ; start_c2() ; end_a() ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_decl} ) ; }, sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; xmlDecl() ; $buf =~ s/\n//g ; defaultWriter()->reset() ; ok( $buf, $xml_decl ) ; }, ## From Laurent CAPRANI, modified a bit sub { my $dt = XML::Doctype->new( 'D', DTD_TEXT => < TOHERE $buf = '' ; my $w = XML::AutoWriter->new( DOCTYPE => $dt, OUTPUT => \$buf ) ; $w->xmlDecl ; $w->characters( 'yaba' ) ; $w->start_G ; $w->characters( 'daba' ) ; $w->endAllTags ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_decl

yaba

daba

} ) ; }, # Commented out so as to not to trigger complaints about failing tests #sub { # package Foo ; # $buf = '' ; # defaultWriter()->reset ; # select_xml( \$buf ) ; # a() ; # endAllTags() ; # a() ; # ok( $buf, qq{} ) ; #}, # Commented out so as to not to trigger complaints about failing tests #sub { # package Foo ; # $buf = '' ; # defaultWriter()->reset ; # select_xml( \$buf ) ; # endAllTags() ; # ok( $buf, qq{} ) ; #}, ## ## OO tests ## sub { $w = XML::AutoWriter->new() ; ok( isa( $w, "XML::AutoWriter" ) ) ; }, ) ; plan tests => scalar @tests ; ## Do this after planing so that the test harness can see that we ## started, then failed. use XML::AutoWriter qw( :all ) ; $_->() for @tests ; XML-AutoWriter-0.4/t/cm_re.t0000755000076500000240000000262111214245237014273 0ustar dcpstaff#!/usr/local/bin/perl -w =head1 NAME cd_re.t - Tests content model -> RE compiliation =cut package Foo ; use Test ; package main ; use strict ; use Test ; use XML::Doctype ; use UNIVERSAL qw( isa ) ; my $dt ; my $re ; my @tests = ( sub { $dt = XML::Doctype->new( 'a', DTD_TEXT => < TOHERE ok( isa( $dt, 'XML::Doctype' ) ) ; }, sub { ok( eval { qr/^$dt->{ELTS}->{b}->{CONTENT}$/ } ) }, sub { my $r = '^(?:(?:#PCDATA)?)$' ; ok( $dt->element_decl('b')->{CONTENT}, "$r" ) ; }, sub { ok( eval { qr/$dt->{ELTS}->{c}->{CONTENT}/, 1 } ) }, sub { my $r = '^(?:(?:#PCDATA)?|||)*$' ; ok( $dt->{ELTS}->{c}->{CONTENT}, "$r" ) ; }, sub { ok( $re = eval { qr/$dt->{ELTS}->{a}->{CONTENT}/ } ) }, sub { ok( '' =~ $re ) }, sub { my $r = '^(?:)?(?:)*(?:||)$' ; ok( $dt->{ELTS}->{a}->{CONTENT}, "$r" ) ; }, sub { ok( $dt->element_decl('a')->validate_content( [qw( b1 b2 b3 b3 b6 b7 )] )); }, ) ; plan tests => scalar @tests ; ## Do this after planing so that the test harness can see that we ## started, then failed. package Foo ; use XML::Doctype ; package ::main ; use XML::Doctype ; skip "undo deprecation warning", 1 or $_->() for @tests ; XML-AutoWriter-0.4/t/dtd.t0000755000076500000240000000605611214245237013767 0ustar dcpstaff#!/usr/local/bin/perl -w =head1 NAME dtd.t - test suite for XML::Doctype =cut use strict ; use Test ; use UNIVERSAL qw( isa ) ; use XML::Doctype; my $w ; my $dtd = < TOHERE my $t = 't' ; my $dtd_file = "$t/dtd_t.dtd" ; unlink $dtd_file ; open DTD, ">$dtd_file" or die "$!: $dtd_file" ; print DTD $dtd or die "$!: $dtd_file" ; close DTD or die "$!: $dtd_file" ; my $pm ; my %dtd1_elts = ( a => { KIDS => [qw( b1 b2 b3 )], }, b1 => { KIDS => [qw( c1 )], }, b2 => { KIDS => [qw( c2 )], }, b3 => { KIDS => [qw( c3 )], }, c1 => { KIDS => [] }, c2 => { KIDS => [] }, c3 => { KIDS => [] }, ) ; my XML::Doctype $doctype; my @tests = ( ## ## File parsing ## sub { $doctype= XML::Doctype->new( 'a', $dtd_file ) ; ok( $doctype) ; }, sub { ok( $doctype->name, 'a' ) }, sub { ok( $doctype->system_id, $dtd_file ) }, ( map { my $elt = $_ ; ( sub { ok( exists $doctype->{ELTS}->{$elt} ) ; }, sub { ok( defined $doctype->{ELTS}->{$elt} ) ; }, sub { ok( join( ',', sort $doctype->{ELTS}->{$elt}->child_names ), join( ',', sort @{$dtd1_elts {$elt}->{KIDS}} ) ) ; }, ) ; } keys %dtd1_elts ), ## ## Text parsing ## sub { $doctype= XML::Doctype->new( 'a', DTD_TEXT => $dtd ) ; ok( $doctype) ; }, sub { ok( $doctype->name, 'a' ) }, sub { ok( ! defined $doctype->system_id ) }, ( map { my $elt = $_ ; ( sub { ok( exists $doctype->{ELTS}->{$elt} ) ; }, sub { ok( defined $doctype->{ELTS}->{$elt} ) ; }, sub { ok( join( ',', sort $doctype->{ELTS}->{$elt}->child_names ), join( ',', sort @{$dtd1_elts {$elt}->{KIDS}} ) ) ; }, ) ; } keys %dtd1_elts ), sub { ok( join( ',', sort $doctype->element_names ), join( ',', sort keys %dtd1_elts ) ) ; }, ## ## Saving as a module and reloading ## sub { $pm = $doctype->as_pm( 'Foo' ) ; ok( $pm, qr/package Foo ;(.*'a'|.*'c2'){2}/s ) ; }, sub { unlink 'Foo.pm' ; open PM, ">Foo.pm" or die "$!: 'Foo.pm'" ; print PM $pm or die "$!: 'Foo.pm'" ; close PM or die "$!: 'Foo.pm'" ; local @INC = ( @INC, '.' ) ; ok( !! eval "package Bar ; use Foo ; 1;" ) ; unlink 'Foo.pm' or warn "$!: Foo.pm" ; }, sub { ok( $@ || '', '' ) ; }, sub { ok( !! $XML::Doctype::_default_dtds{Bar} ) ; }, ## ## Default object parsing ## sub { eval < 'a', SYSTEM_ID => '$dtd_file' ; TOHERE die $@ if $@ ; ok( 1 ) ; }, sub { ok( !! $XML::Doctype::_default_dtds{main} ) ; }, ) ; plan tests => scalar @tests ; ## Do this after planing so that the test harness can see that we ## started, then failed. use XML::Doctype ; $_->() for @tests ; unlink $dtd_file or warn "$!: $dtd_file" ; XML-AutoWriter-0.4/t/escape.t0000755000076500000240000001100311214245237014440 0ustar dcpstaff#!/usr/local/bin/perl -w =head1 NAME escape.t - Escaping test suite for XML::ValidWriter =cut package Foo ; use Test ; package main ; use strict ; use Test ; use XML::Doctype ; use UNIVERSAL qw( isa ) ; my $w ; my $doctype ; my $t = 't' ; my $dtd = < TOHERE my $out_name = "$t/out" ; my $buf ; my $xml_decl = qq{} ; sub test_cdata_esc { ## See if contiguously emitted CDATA end sequences are escaped properly package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; ## The extra ()'s are necessary because we didn't import at compile time. xmlDecl() ; start_a() ; ## Kick us in to CDATA mode characters( "<<<<<" ) ; ## play games characters( $_ ) for @_ ; end_a() ; $buf =~ s{.*}{}sg ; $buf =~ s{]]>.*}{}sg ; $buf =~ s{reset ; select_xml( \$buf ) ; ## The extra ()'s are necessary because we didn't import at compile time. xmlDecl() ; start_a() ; ## play games characters( $_ ) for @_ ; end_a() ; $buf =~ s{.*}{}sg ; $buf =~ s{.*}{}sg ; return $buf ; } my @tests = ( sub { $doctype = XML::Doctype->new( 'a', DTD_TEXT => $dtd ) ; ok( $doctype ) ; }, sub { package Foo ; eval 'use XML::ValidWriter qw(:all :dtd_tags), DOCTYPE => $doctype' ; die $@ if $@ ; ok( defined &a ) ; }, ## ## CharData escape tests ## sub { ok( test_char_data_esc( "&" ), "&" ) }, sub { ok( test_char_data_esc( "<" ), "<" ) }, sub { ok( test_char_data_esc( ">" ), ">" ) }, sub { ok( test_char_data_esc( "]>" ), "]>" ) }, sub { ok( test_char_data_esc( "a", ">" ), "a>" ) }, sub { ok( test_char_data_esc( "]", ">" ), "]>" ) }, sub { ok( test_char_data_esc( "]]", ">" ),"]]>" ) }, sub { ok( test_char_data_esc( "]]>" ), "]]>" ) }, sub { ok( test_char_data_esc( "]]>]]>" ), "]]>]]>" ) }, sub { ok( test_char_data_esc( "a>" ), "a>" ) }, sub { ok( test_char_data_esc( "a]>" ), "a]>" ) }, sub { ok( test_char_data_esc( "a]>" ), "a]>" ) }, sub { ok( test_char_data_esc( "\t" ), "\t", "\\t, 0x09, ^I, TAB" ) }, sub { ok( test_char_data_esc( "\n" ), "\n", "\\n, 0x0A, ^J, NL" ) }, sub { ok( test_char_data_esc( "\r" ), "\r", "\\r, 0x0D, ^M, CR" ) }, ## Throw in a bunch of oddball characters and see what happens ( map { my $ord = $_ ; my $char = chr( $ord ) ; ( sub { eval { test_char_data_esc( $char ) } ; ## Older dists of perl don't know about qr// passed to ok(): if ( $@ && $@ =~ /invalid char/i ) { ok( 1 ) ; } else { ok( $@, "invalid char", sprintf( "0x%02x", $ord ) ) } }, sub { eval { test_cdata_esc( $char ) } ; ## Older dists of perl don't know about qr// passed to ok(): if ( $@ && $@ =~ /invalid char/i ) { ok( 1 ) ; } else { ok( $@, "invalid char", sprintf( "0x%02x", $ord ) ) } }, ) } ( 0..0x08, 0x0b, 0x0c, 0x0e..0x1f ) ), ## ## CDATA escape mode tests ## sub { ok( test_cdata_esc( "]]>" ), "]]]]>" ) }, sub { ok( test_cdata_esc( "]]>" ), "]]]]>" ) }, sub { ok( test_cdata_esc( "]]", ">" ), "]]]]>" ) }, sub { ok( test_cdata_esc( "]", "]>" ), "]]]]>" ) }, sub { ok( test_cdata_esc( "\t" ), "\t", "\\t, 0x09, ^I, TAB" ) }, sub { ok( test_cdata_esc( "\n" ), "\n", "\\n, 0x0A, ^J, NL" ) }, sub { ok( test_cdata_esc( "\r" ), "\r", "\\r, 0x0D, ^M, CR" ) }, sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; ## The extra ()'s are necessary because we didn't import at compile time. xmlDecl() ; start_a() ; ## Kick us in to CDATA mode, but with a closing ']' characters( "<<<<<]" ) ; b() ; end_a() ; $buf =~ s{.*.*}{}sg ; $buf =~ s{\]\]>}{}sg ; ok( $buf, "]" ) ; return $buf ; }, ) ; plan tests => scalar @tests ; ## Do this after planing so that the test harness can see that we ## started, then failed. use XML::ValidWriter qw( :all ) ; $_->() for @tests ; XML-AutoWriter-0.4/t/foo.t0000755000076500000240000000255611214245237014000 0ustar dcpstaff#!/usr/local/bin/perl -w =head1 NAME foo.t - Tests some of the examples in XML::Doctype's POD =cut package Foo ; use Test ; package main ; use strict ; use Test ; use XML::Doctype ; use UNIVERSAL qw( isa ) ; my $w ; my $doctype ; my $dtd = < TOHERE my $buf ; my @tests = ( sub { $buf = '' ; eval < 'a', DTD_TEXT => < TOHERE use XML::AutoWriter qw( :all :dtd_tags ) ; select_xml \\\$buf ; getDoctype->element_decl('a')->attdef('aa1')->default_on_write('foo') ; xmlDecl ; start_a( attr => 'val' ); c1; c2; end_a; ENDEXAMPLE1 die $@ if $@ ; $buf =~ s/\n//g ; ok( $buf, qq{} ) ; }, ) ; plan tests => scalar @tests ; ## Do this after planing so that the test harness can see that we ## started, then failed. package Foo ; use XML::Doctype ; package ::main ; use XML::Doctype ; $_->() for @tests ; XML-AutoWriter-0.4/t/valid.t0000755000076500000240000001474411214245237014316 0ustar dcpstaff#!/usr/local/bin/perl -w =head1 NAME valid.t - test suite for XML::ValidWriter =cut package Foo ; use Test ; package main ; use strict ; use Test ; use XML::Doctype ; use UNIVERSAL qw( isa ) ; use IO::File; my $w ; my $doctype ; my $t = 't' ; my $dtd = < TOHERE my $out_name = "$t/out" ; my $buf ; my %dtd1_elts = ( a => { KIDS => [qw( b1 b2 b3 )], }, b1 => { KIDS => [qw( c1 )], }, b2 => { KIDS => [qw( c2 )], }, b3 => { KIDS => [qw( c3 )], }, ) ; sub slurp { my ( $in_name ) = @_ ; open( F, "<$in_name" ) or die "$!: $in_name" ; local $/ = undef ; my $in = join( '', ) ; close F ; $in =~ s/\n//g ; return $in ; } my $xml_decl = qq{} ; sub test_xml_decl { my $expected = pop ; package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; ## The extra ()'s are necessary because we didn't import at compile time. xmlDecl( @_ ) ; start_a() ; start_b1() ; start_c1() ; endAllTags() ; $buf =~ s/\n//g ; $expected =~ s/\n//g ; ok( $buf, $expected ) ; } my @tests = ( sub { $doctype = XML::Doctype->new( 'a', DTD_TEXT => $dtd ) ; ok( $doctype ) ; }, ## ## Writing to an IO::* or to a named file ## sub { unlink $out_name ; my $f = IO::File->new( ">$out_name" ) ; my $w = XML::ValidWriter->new( DOCTYPE => $doctype, OUTPUT => $f, ) ; $w->getDoctype->element_decl('a')->attdef('aa1')->default_on_write('foo') ; $w->xmlDecl ; $w->startTag( 'a' ) ; $w->startTag( 'b1' ) ; $w->startTag( 'c1' ) ; $w->end ; $f->close ; ok( slurp( $out_name ), qq{$xml_decl} ) ; unlink $out_name || warn "$!: $out_name" ; }, sub { unlink $out_name ; { my $w = XML::ValidWriter->new( DOCTYPE => $doctype, OUTPUT => $out_name, ) ; $w->getDoctype->element_decl('a')->attdef('aa1')->default_on_write('foo'); $w->xmlDecl ; $w->startTag( 'a' ) ; $w->startTag( 'b1' ) ; $w->startTag( 'c1' ) ; $w->end ; ## File should be closed on end of scope. } ok( slurp( $out_name ), qq{$xml_decl} ) ; unlink $out_name || warn "$!: $out_name" ; }, ## ## import tests ## sub { package Foo ; eval 'use XML::ValidWriter qw(:all :dtd_tags), DOCTYPE => $doctype' ; die $@ if $@ ; ok( defined &a ) ; }, sub { package Foo ; ok( defined &end_a ) ; }, sub { unlink $out_name ; eval q{ package Foo ; defaultWriter()->reset ; open( F, ">$out_name" ) or die "$!: '$out_name'" ; select F ; xmlDecl ; start_a foo => '&<>"' ; start_b1 ; c1 ; endAllTags ; select STDOUT ; close F ; } ; die $@ if $@ ; ok( slurp( $out_name ), qq{$xml_decl} ) ; unlink $out_name ; }, ## ## XML decl tests ## # Commented out so as to not to trigger complaints about warnings #sub { # package Foo ; # $buf = '' ; # defaultWriter()->reset ; # select_xml( \$buf ) ; # ## The extra ()'s are necessary because we didn't import at compile time. # a() ; # ok( $buf, qq{} ) ; #}, sub { test_xml_decl( 'foo', qq{} ) ; }, sub { test_xml_decl( 'foo', 'bar', qq{} ) ; }, # Commented out so as not to trigger complaints about warnings #sub { # test_xml_decl( '', 'bar', # qq{} # ) ; #}, # #sub { # test_xml_decl( 0, 'bar', # qq{} # ) ; #}, # sub { test_xml_decl( undef, '', qq{$xml_decl} ) }, sub { test_xml_decl( undef, 0, qq{$xml_decl} ) }, sub { test_xml_decl( undef, 'no', qq{} ) ; }, ## ## Misc tag emission tests ## sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; ## The extra ()'s are necessary because we didn't import at compile time. xmlDecl() ; start_a() ; start_b1() ; characters( '<>' ) ; rawCharacters( '<>' ) ; end_b1() ; end_a() ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_decl<><>} ) ; }, sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; xmlDecl() ; start_a() ; start_b1() ; characters( '' ) for (1..100) ; rawCharacters( '' ) for (1..100) ; end_b1() ; end_a() ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_decl} ) ; }, sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; xmlDecl() ; start_a() ; start_b1() ; empty_c1() ; end_b1() ; end_a() ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_decl} ) ; }, sub { package Foo ; $buf = '' ; defaultWriter()->reset ; select_xml( \$buf ) ; xmlDecl() ; start_a() ; b1( 'test' ) ; end_a() ; $buf =~ s/\n//g ; ok( $buf, qq{$xml_decltest} ) ; }, # Commented out so as to not to trigger complaints about failing tests #sub { # package Foo ; # $buf = '' ; # defaultWriter()->reset ; # select_xml( \$buf ) ; # a() ; # endAllTags() ; # a() ; # ok( $buf, qq{} ) ; #}, # Commented out so as to not to trigger complaints about failing tests #sub { # package Foo ; # $buf = '' ; # defaultWriter()->reset ; # select_xml( \$buf ) ; # endAllTags() ; # ok( $buf, qq{} ) ; #}, ## ## OO tests ## sub { $w = XML::ValidWriter->new() ; ok( isa( $w, "XML::ValidWriter" ) ) ; }, ) ; plan tests => scalar @tests ; ## Do this after planing so that the test harness can see that we ## started, then failed. use XML::ValidWriter qw( :all ) ; $_->() for @tests ;