{
    ## A clean lexical environment with no strictures in main::
    sub SteamRoller::_eval{
        my $dest = pop;
        warn ">>>evalling $dest<<<\n" if $ENV{DEBUGSTEAMROLLEDSCRIPT};
        eval shift( @_ ) . "; 1;" or die $@;
        $INC{$dest} = "evalled" if length $dest;
    };
}
{
package SteamRoller;
use strict;
use Cwd;
use File::Spec;
use File::Basename qw( fileparse );

## The BEGINs are so the monster strings below get parsed, used, and
## deallocated one at a time.  Not using __END__/__DATA__ to allow
## adding user code that does so.

my $original_cwd;
my $parent_dir;
my $dont_spew;
my $digest;
my $id_fn;
my @lib_dirs;
my $command_path;

BEGIN {
$digest = "U+3Il95PuUZjOPm4gh/GCA koNyikaCdb48uSB1d9I6JA 9aS1yB6P+BZxFgIl38fRmQ KrSOwNYqG88nUsCoIlw1Nw csKy4dpP4udEys0tfBoaIw NBoj/WZbC6hl1riX2CAHWw 3Zo45NhA/hfHSErz0FVT0g nWyNveGQCju+YVFLl1tp+Q 3LHYgY/QymZHLngPo5mt5g r3XVhIZdl5Yuvqla4WACyQ kVp+nnUYEYeg72WIiQ3XoQ ae11ArUeZjEgw9Cw2qWOvg SVdc7WSV+1Lum3DVD26Kqg AOLmE8S16mWoCaM6ete8HA F7SXgIxhaD6DSGoRc5yqNg eE8V9xWOxhQuOXRpUBWP/g DFV9gR1bTIgXj9p3I/n/oQ bzXtGKZHQrFIcYkpmf2Oeg P4IFprUlnmVlrt4ng3Qzkg tu6kDDp97NSnFE2xsc0pHg 2vImopU09qJOgA05kdMvag /WYEmKX81WQFvCKyOdHcog +OD0Rara1WcGGkrvxi37Lg hMgYmW/qIocLwlbVl1hVMg HoTJQBnEH+acvNCaPUlwAw 6K+hnrMf/oFchCAOKK2kKA gM2rSnIXKuWhKJ/d9LfWCg blurZ+885Zy3lnAH8feuLw RCtKz+bZJ5dF85KsZq2EZw ZH0TFtaZ+tGJGEj3PR32Lw C7fwA5E6Rz1uWHqYBJHyUg WBXpgiX8KtT6LwKfPPABtw +IJiErqM0mIO6F3KByI8Dw L9fxX8JPNV+P6yqAtTXrog IOzQ3YMz2IFWHh/7o8aHaA UsiBKr5dYaoiB3Fg2RiGRA +w8ZTtbUKLvqt0/5xbCTTw jBrXXC6qIEmwRhVBR9G/ow iqOGDi9mrGgXFRY0yntUIA cqeaH3KdK7RW04dKvw/U0g X0Mty+qK7LG++VfJCjkfSw QpZLmtoKzRegmpBzHTzLSg APluJvz0fzgY/YpYKYsK9A Op9N0gyzQbwJwnmY8fIiTQ 01qQNAnqaj60Ewx+SzFSyg /Rw6EN6yWVyuZ35WyE9+Eg APibHxbMXmZriSVVsGdxBw 3RgqwYH96lh+OoQrl6Somg wjJx6IsIGDhBLMYn9rdizw Dk2W0uyR+fEg0EMuHHkfVQ 9hVDLzTlHILDutbV3CQCFQ";
$id_fn = "id_M_eO__d2w5wa27w_2URRPQ";
@lib_dirs = ( 'lib' );
$command_path = "";

$original_cwd = cwd;

sub _spew {
    return if $dont_spew;
    my $dest = pop;
    warn ">>>spewing $dest<<<\n" if $ENV{DEBUGSTEAMROLLEDSCRIPT};
    $dest = File::Spec->catfile( $parent_dir, $dest );
    my $dest_parent = (fileparse( $dest ))[1];
    ## 0775: Trust in the user's umask "a bit", but don't allow writing
    mkpath( [ $dest_parent ], 0, 0775 ) unless -d $dest_parent;
    sysopen F, $dest, O_CREAT()|O_WRONLY(), 0775 or die "$!: $dest\n";
    push @_, pop;  ## make read/writable
    chomp $_[-1];
    print F @_                                   or die "$!: $dest\n";
    close F                                      or die "$!: $dest\n";
}


## Search for an existing copy.
## This is more to prevent overwriting an old (put possibly still
## in service) copy than to speed things up.  spewing a bunch
## of files like we do is pretty quick.
my $payload_number = 0;
while () {
    $parent_dir = File::Spec->catdir(
        File::Spec->tmpdir,
        scalar fileparse( $0 ) . "-tmp-$payload_number"
    );

    last unless -d $parent_dir;

    my $id_file = File::Spec->catdir( $parent_dir, $id_fn );

    if ( -f $id_file ) {
        my $id = do $id_file;
        if ( $id eq $digest ) {
            $dont_spew = 1;
            last;
        }
    }

    ++$payload_number;
}

eval <<LAZY_LOADS unless $dont_spew;
    use Fcntl qw( O_CREAT O_WRONLY );
    use File::Path qw( mkpath );
LAZY_LOADS

_spew qq{"$digest"\n}, $id_fn;

if ( $ENV{STEAMROLLEDSCRIPTIGNORESITELIB} ) {
     use Config;
     @INC = grep index( $_, $Config{sitelib_stem} ), @INC;
}

unshift @INC, 
    map(
        File::Spec->catdir( $parent_dir, $_ ),
        @lib_dirs
    );
}
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAABW, "lib/VCP.pm" }
package VCP ;\n\n=head1 NAME\n\nVCP - Versioned Copy, copying hierarchies of versioned files\n\n=head1 SYNOPSIS\n\n=head1 DESCRIPTION\n\nThis module copies hierarchies of versioned files between repositories, and\nbetween repositories and RevML (.revml) files.\n\nStay tuned for more documentation.\n\n=head1 EXPORTS\n\nThe following functions may be exported: L</debug>, L</enable_debug>,\nL</disable_debug>, along with the tags ':all' and ':debug'.  Use the latter\nto head off future namespace pollution in case :all gets expanded in the\nfuture..\n\n=head1 METHODS\n\n=over\n\n=cut\n\nuse strict ;\nuse File::Spec ;\nuse File::Path ;\nuse VCP::Debug ;\nuse vars qw( \$VERSION ) ;\n\n\$VERSION = 0.1 ;\n\nrequire VCP::Source ;\nrequire VCP::Dest ;\n\nuse fields (\n   'SOURCE',     # The VCP::Source to pull data from\n   'DEST',       # The RevML::Writer instance\n) ;\n\n\n=item new\n\n   \$ex = VCP->new( \$source, \$dest ) ;\n\nwhere\n\n   \$source  is an instance of VCP::Source\n   \$dest    is an instance of VCP::Dest\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my ( \$source, \$dest ) = \@_ ;\n\n   my VCP \$self ;\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   \$self->{SOURCE} = \$source ;\n   \$self->{DEST}   = \$dest ;\n\n   return \$self ;\n}\n\n\n=item dest\n\n   \$dest = \$vcp->dest ;\n\nGets the dest object.  This object is set by passing it to\nnew(), so there's no need to set it.\n\n=cut\n\nsub dest {\n   my VCP \$self = shift ;\n   return \$self->{DEST} ;\n}\n\n\n=item copy_all\n\n   \$vcp->copy_all( \$header, \$footer ) ;\n\nCalls \$source->handle_header, \$source->copy_revs, and \$source->handle_footer.\n\n=cut\n\nsub copy_all {\n   my VCP \$self = shift ;\n\n   my ( \$header, \$footer ) = \@_ ;\n\n   my VCP::Source \$s = \$self->source ;\n   \$s->dest( \$self->dest ) ;\n\n   \$s->handle_header( \$header ) ;\n   \$s->copy_revs() ;\n   \$s->handle_footer( \$footer ) ;\n\n   ## Removing this link allows the dest to be cleaned up earlier by perl,\n   ## which keeps VCP::Rev from complaining about undeleted revs.\n   \$s->dest( undef ) ;\n   return ;\n}\n\n\n=item source\n\n   \$source = \$vcp->source ;\n\nGets the source object.  This object is set by passing it to\nnew(), so there's no need to set it.\n\n=cut\n\nsub source {\n   my VCP \$self = shift ;\n   return \$self->{SOURCE} ;\n}\n\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAABW
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAABX, "lib/VCP/Dest.pm" }
package VCP::Dest ;\n\n=head1 NAME\n\nVCP::Dest - A base class for VCP destinations\n\n=head1 SYNOPSIS\n\n=head1 DESCRIPTION\n\n=head1 EXTERNAL METHODS\n\n=over\n\n=cut\n\nuse strict ;\n\nuse Carp ;\nuse UNIVERSAL qw( isa ) ;\nuse VCP::Revs ;\nuse VCP::Debug qw(:debug) ;\n\nuse vars qw( \$VERSION \$debug ) ;\n\n\$VERSION = 0.1 ;\n\n\$debug = 0 ;\n\nuse base 'VCP::Plugin' ;\n\nuse fields (\n   'DEST_HEADER',      ## Holds header info until first rev is seen.\n   'DEST_SORT_SPEC',   ## ARRAY of field names to sort by\n   'DEST_SORT_KEYS',   ## HASH of sort keys, indexed by name and rev.\n   'DEST_COMMENT_TIMES', ## The average time of all instances of a comment\n   'DEST_DEFAULT_COMMENT', ## The comment to use when a comment is undefined\n                           ## This is used when presorting/merging so\n                           ## that comment will still be used to\n                           ## compare when selecting the next rev to\n                           ## merge, otherwise it would be removed as\n                           ## a sporadic field.\n) ;\n\nuse VCP::Revs ;\n\n\n=item new\n\nCreates an instance, see subclasses for options.  The options passed are\nusually native command-line options for the underlying repository's\nclient.  These are usually parsed and, perhaps, checked for validity\nby calling the underlying command line.\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Dest \$self = \$class->SUPER::new( \@_ ) ;\n\n   ## rev_id is here in case the change id isn't,\n   ## name is here for VSS deletes, which have no other data.\n   \$self->set_sort_spec( "presort,change,time,avgcommenttime,comment,name,rev_id" ) ;\n\n   return \$self ;\n}\n\n\n###############################################################################\n\n=head1 SUBCLASSING\n\nThis class uses the fields pragma, so you'll need to use base and \npossibly fields in any subclasses.\n\n=head2 SUBCLASS API\n\nThese methods are intended to support subclasses.\n\n=over\n\n=item digest\n\n    \$self->digest( "/tmp/readers" ) ;\n\nReturns the Base64 MD5 digest of the named file.  Used to compare a base\nrev (which is the revision *before* the first one we want to transfer) of\na file from the source repo to the existing head rev of a dest repo.\n\nThe Base64 version is returned because that's what RevML uses and we might\nwant to cross-check with a .revml file when debugging.\n\n=cut\n\nsub digest {\n   shift ;  ## selfless little bugger, isn't it?\n   my ( \$path ) = \@_ ;\n\n   require Digest::MD5 ;\n   my \$d= Digest::MD5->new ;\n   open DEST_P4_F, "<\$path" or die "\$!: \$path" ;\n   \$d->addfile( \\*DEST_P4_F ) ;\n\n   my \$digest = \$d->b64digest ;\n   close DEST_P4_F ;\n   return \$digest ;\n}\n\n\n=item compare_base_revs\n\n   \$self->compare_base_revs( \$rev ) ;\n\nChecks out the indicated revision fromt the destination repository and\ncompares it (using digest()) to the file from the source repository\n(as indicated by \$rev->work_path). Dies with an error message if the\nbase revisions do not match.\n\nCalls \$self->checkout_file( \$rev ), which the subclass must implement.\n\n=cut\n\nsub compare_base_revs {\n   my VCP::Dest \$self = shift ;\n   my ( \$rev ) = \@_ ;\n\n   ## This block should only be run when transferring an incremental rev.\n   ## from a "real" repo.  If it's from a .revml file, the backfill will\n   ## already be done for us.\n   ## Grab it and see if it's the same...\n   my \$source_digest = \$self->digest( \$rev->work_path ) ;\n   \n   my \$dest_digest   = \$self->digest( \$self->checkout_file( \$rev ) ) ;\n   die( "vcp: base revision\\n",\n       \$rev->as_string, "\\n",\n       "differs from the last version in the destination p4 repository.\\n",\n       "    source digest: \$source_digest\\n",\n       "    dest. digest:  \$dest_digest\\n"\n   ) unless \$source_digest eq \$dest_digest ;\n}\n\n\n=item header\n\nGets/sets the \$header passed to handle_header().\n\nGenerally not overridden: all error checking is done in new(), and\nno output should be generated until output() is called.\n\n=cut\n\nsub header {\n   my VCP::Dest \$self = shift ;\n   \$self->{DEST_HEADER} = shift if \@_ ;\n   return \$self->{DEST_HEADER} ;\n}\n\n=back\n\n=head2 SUBCLASS OVERLOADS\n\nThese methods are overloaded by subclasses.\n\n=over\n\n=item backfill\n\n   \$dest->backfill( \$rev ) ;\n\nChecks the file indicated by VCP::Rev \$rev out of the target repository if\nthis destination supports backfilling.  Currently, only the revml destination\ndoes not support backfilling.\n\nThe \$rev->{workpath} must be set to the filename the backfill was put\nin.\n\nThis is used when doing an incremental update, where the first revision of\na file in the update is encoded as a delta from the prior version.  A digest\nof the prior version is sent along before the first version delta to\nverify it's presence in the database.\n\nSo, the source calls backfill(), which returns TRUE on success, FALSE if the\ndestination doesn't support backfilling, and dies if there's an error in\nprocuring the right revision.\n\nIf FALSE is returned, then the revisions will be sent through with no\nworking path, but will have a delta record.\n\nMUST BE OVERRIDDEN.\n\n=cut\n\nsub backfill {\n   my VCP::Dest \$self = shift ;\n   die ref( \$self ) . "::backfill() not found, Oops.\\n" ;\n}\n\n\n=item handle_footer\n\n   \$dest->handle_footer( \$footer ) ;\n\nDoes any cleanup necessary.  Not required.  Don't call this from the override.\n\n=cut\n\nsub handle_footer {\n   my VCP::Dest \$self = shift ;\n   return ;\n}\n\n=item handle_header\n\n   \$dest->handle_header( \$header ) ;\n\nStows \$header in \$self->header.  This should only rarely be overridden,\nsince the first call to handle_rev() should output any header info.\n\n=cut\n\nsub handle_header {\n   my VCP::Dest \$self = shift ;\n\n   my ( \$header ) = \@_ ;\n\n   \$self->header( \$header ) ;\n\n   return ;\n}\n\n=item handle_rev\n\n   \$dest->handle_rev( \$rev ) ;\n\nOutputs the item referred to by VCP::Rev \$rev.  If this is the first call,\nthen \$self->none_seen will be TRUE and any preamble should be emitted.\n\nMUST BE OVERRIDDEN.  Don't call this from the override.\n\n=cut\n\nsub handle_rev {\n   my VCP::Dest \$self = shift ;\n   die ref( \$self ) . "::handle_rev() not found, Oops.\\n" ;\n}\n\n\n=head3 Sorting\n\n=over\n\n=item set_sort_spec\n\n   \$dest->set_sort_spec( \@key_names ) ;\n\n\@key_names specifies the list of fields to sort by.  Each element in the array\nmay be a comma separated list.  Such elements are treated as though each name\nwas passed in it's own element; so C<( "a", "b,c" )> is equivalent to C<("a",\n"b", "c")>.  This eases command line parameter parsing.\n\nSets the sort specification, checking to make sure that the field_names\nhave corresponding parse_sort_field_... handlers in this object.\n\nLegal field names include: name, change, change_id, rev, rev_id, comment,\ntime.\n\nIf a field is missing from all revs, it is ignored, however at\nleast one of rev_id, change, or time *must* be used.\n\nDefault ordering is by\n\n  - change_id    (compared numerically using <=>, for now)\n  - time         (commit time: simple numeric, since this is a simple number)\n  - comment      (alphabetically, case sensitive)\n\nThis ordering benefits change number oriented systems while preserving\ncommit order for non-change number oriented systems.\n\nIf change_id is undefined in either rev, it is not used.\n\nIf time is undefined in a rev, the value "-1" is used.  This causes\nbase revisions (ie digest-only) to precede real revisions.\n\nThat's not always good, though: one of commit time or change number should\nbe defined!  \n\nChange ids are compared numerically, times by date order (ie numerically, since\ntime-since-the-epoch is used internally). Comments are compared alphabetically.\n\nEach sort field is split in to one or more segments, see the appropriate\nparse_sort_field_... documentation.\n\nHere's the sorting rules:\n  - Revisions are compared field by field.\n  - The first non-equal field determines sort order.\n  - Fields are compared segment by segment.\n  - The first non-equal segment determines sort order.\n  - A not-present segment compares as less-than any other segment, so\n    fields that are leading substrings of longer fields come first, and\n    not-present fields come before all present fields, including empty\n    fields.\n\n=cut\n\nsub set_sort_spec {\n   my VCP::Dest \$self = shift ;\n\n   my \@spec = split ',', join ',', \@_ ;\n\n   for ( \@spec ) {\n      next if \$_ eq "presort";\n      next if \$self->can( "parse_sort_field_\$_" ) ;\n      croak "Sort specification \$_ is not available in ",\n         ref( \$self ) =~ /.*:(.*)/ ;\n   }\n\n   debug "vcp: sort spec: ", join ",", \@spec\n      if explicitly_debugging "sort" || debugging \$self ;\n   \$self->{DEST_SORT_SPEC} = \\\@spec ;\n   return undef ;\n}\n\n\n=item parse_sort_field_name\n\n    push \@sort_key_segs, \$self->parse_sort_field_name( \$rev ) ;\n\nSplits the C<name> of the revision in to segments suitable for sorting.\n\n=cut\n\nsub parse_sort_field_name {\n   my VCP::Dest \$self = shift ;\n   my VCP::Rev \$rev ;\n   ( \$rev ) = \@_ ;\n\n   for ( \$rev->name ) {\n      return ()   unless defined ;\n      return ("") unless length  ;\n      return split "/" ;\n   }\n}\n\n=item parse_sort_field_rev\n=item parse_sort_field_rev_id\n=item parse_sort_field_revision\n=item parse_sort_field_revision_id\n=item parse_sort_field_change\n=item parse_sort_field_change_id\n\n    push \@sort_key_segs, \$self->parse_sort_field_name( \$rev ) ;\n\nThese split the C<change_id> or C<rev_id> of the revision in to segments\nsuitable for sorting.  Several spellings of each method are provided for user\nconvenience; all spellings for each field work the same way.  This is because\nusers may think of different names for each field depending on how much RevML\nthey know (the _id variants come from RevML), or whether they like to spell\n"revision" or "rev".\n\nThe splits occur at the following points:\n\n   1. Before and after each substring of consecutive digits\n   2. Before and after each substring of consecutive letters\n   3. Before and after each non-alpha-numeric character\n\nThe substrings are greedy: each is as long as possible and non-alphanumeric\ncharacters are discarded.  So "11..22aa33" is split in to 5 segments:\n( 11, "", 22, "aa", 33 ).\n\nIf a segment is numeric, it is left padded with 50 NUL characters.\n\nThis algorithm makes 1.52 be treated like revision 1, minor revision 52, not\nlike a floating point C<1.52>.  So the following sort order is maintained:\n\n   1.0\n   1.0b1\n   1.0b2\n   1.0b10\n   1.0c\n   1.1\n   1.2\n   1.10\n   1.11\n   1.12\n\nThe substring "pre" might be treated specially at some point.\n\n(At least) the following cases are not handled by this algorithm:\n\n   1. floating point rev_ids: 1.0, 1.1, 1.11, 1.12, 1.2\n   2. letters as "prereleases": 1.0a, 1.0b, 1.0, 1.1a, 1.1\n\nNever returns (), since C<rev_id> is a required field.\n\n=cut\n\n## This function's broken out to be shared.\nsub _pad_number {\n   for ( \$_[0] ) {\n      return () unless defined ;\n      return ( "\\x00" x ( 50 - length ) ) . \$_[0] ;\n   }\n}\n\nsub _pad_rev_id {\n   map /^\\d+\\z/ ? _pad_number \$_ : \$_ , \@_ ;\n}\n\n\n## This function's broken out to be shared.\nsub _clean_text_field {\n   for ( \$_[0] ) {\n      return () unless defined ;\n      return (\$_) ;\n   }\n}\n\n## This function (not method) is broken out for testing purposes.  Perhaps\n## later, it can be made in to a method to allow subclassing.\nsub _split_rev_id {\n   for ( \$_[0] ) {\n      return ()     unless defined ;\n      return ( "" ) unless length ;\n\n      return split /(?:\n\x09  (?<=[[:alpha:]])(?=[^[:alpha:]])\n\x09 |(?<=[[:digit:]])(?=[^[:digit:]])\n\x09 |[^[:alnum:]]+\n      )/x ;\n   }\n}\n\nsub _pad_decimal_number {\n   for ( \$_[0] ) {\n      return () unless defined ;\n      return sprintf( "%0100.50f", \$_[0] );\n   }\n}\n\n*parse_sort_field_rev_id = \\&parse_sort_field_rev ;\n*parse_sort_field_revision = \\&parse_sort_field_rev ;\n*parse_sort_field_revision_id = \\&parse_sort_field_rev ;\nsub parse_sort_field_rev {\n   my VCP::Dest \$self = shift ;\n   my ( \$rev ) = \@_ ;\n   return _pad_rev_id _split_rev_id \$rev->rev_id\n}\n\n\n*parse_sort_field_change_id = \\&parse_sort_field_change ;\nsub parse_sort_field_change {\n   my VCP::Dest \$self = shift ;\n   my ( \$rev ) = \@_ ;\n   return _pad_rev_id _split_rev_id \$rev->change_id ;\n}\n\n=item parse_sort_field_time\n\nPads and returns the seconds-since-epoch value that is the time.\n\n=cut\n\nsub parse_sort_field_time {\n   my VCP::Dest \$self = shift ;\n   my ( \$rev ) = \@_ ;\n   ## We default time to 0 if it's a base rev, so it can be used\n   ## as a sort key.\n   return _pad_number \$rev->time || ( \$rev->is_base_rev ? 0 : undef ) ;\n}\n\n=item parse_sort_field_avgcommenttime\n\nPads and returns the seconds-since-epoch value that is the average\ntimestamp for all revs with this rev's comment.  This allows apparent\nchanges that occur across time period boundaries (seconds, minutes,\ndays: whatever the source RCS gives out in terms of time value\nresolution) so that revs with identical comments will be grouped near\nthe time change between two time boundaries.\n\n=cut\n\nsub parse_sort_field_avgcommenttime {\n   my VCP::Dest \$self = shift ;\n   my ( \$rev ) = \@_ ;\n   ## We default time to 0 if it's a base rev, so it can be used\n   ## as a sort key.\n   return _pad_decimal_number\n       defined \$rev->comment\n           ? \$self->{DEST_COMMENT_TIMES}->{\$rev->comment}\n           : \$rev->is_base_rev ? 0 : undef;\n}\n\n=item parse_sort_field_comment\n\nJust returns the comment, undef, or maybe "" (see the source).\n\n=cut\n\nsub parse_sort_field_comment {\n    my VCP::Dest \$self = shift ;\n    my ( \$rev ) = \@_ ;\n    return _clean_text_field\n       defined \$rev->comment\n          ? \$rev->comment\n          : \$rev->is_base_rev\n             ? ""\n             : \$self->{DEST_DEFAULT_COMMENT};\n}\n\n\nsub _calc_sort_rec {\n    my VCP::Dest \$self = shift ;\n    my ( \$rev, \$spec ) = \@_ ;\n    my \@fields = ( \$rev );\n\n    for my \$spec ( \@\$spec ) {\n        my \$sub = \$self->can( "parse_sort_field_\$spec" ) ;\n\x09die "Can't sort by \$spec, no parse_sort_field_\$spec found"\n\x09   unless \$sub ;\n\x09my \@segments = \$sub->( \$self, \$rev ) ;\n\x09confess \$rev->as_string, " contains an <undef> sort key"\n\x09   if grep !defined, \@segments ;\n        push \@fields, \\\@segments ;\n    }\n    return \\\@fields ;\n}\n\n## The sort routine\nsub _rev_cmp {\n   my \@a_fields = \@\$a ;\n   my \@b_fields = \@\$b ;\n\n   # The first "field" is the revision itself.\n   my \$reva = shift \@a_fields;\n   my \$revb = shift \@b_fields;\n   confess "\\\$a[0] is a '\$reva', not a VCP::Rev" unless isa( \$reva, "VCP::Rev" );\n   confess "\\\$b[0] is a '\$revb', not a VCP::Rev" unless isa( \$revb, "VCP::Rev" );\n\n   debug "vcp cmp: ", \$reva->as_string, "\\n       : ", \$revb->as_string\n      if explicitly_debugging "sort" ;\n\n   while ( \@a_fields && \@b_fields ) {\n      my \$result ;\n      my \@a_segments = \@{shift \@a_fields} ;\n      my \@b_segments = \@{shift \@b_fields} ;\n      unless ( \@a_segments && \@b_segments ) {\n         debug "vcp cmp: pass" if \$result && explicitly_debugging "sort" ;\n         next;\n      }\n\n      while ( \@a_segments && \@b_segments ) {\n         my \$a_segment = shift \@a_segments;\n         my \$b_segment = shift \@b_segments;\n\x09 debug "vcp cmp: ",\n            defined \$a_segment ? \$a_segment : "<undef>",\n            " cmp ",\n            defined \$b_segment ? \$b_segment : "<undef>"\n\x09    if explicitly_debugging "sort" ;\n\n         unless ( defined \$a_segment && defined \$b_segment ) {\n            debug "vcp cmp: pass" if \$result && explicitly_debugging "sort" ;\n            next;\n         }\n\n\x09 \$result = \$a_segment cmp \$b_segment;\n\x09 debug "vcp cmp: \$result" if \$result && explicitly_debugging "sort" ;\n\x09 return \$result if \$result ;\n      }\n      debug "vcp cmp: " . \@a_segments . " <=> " . \@b_segments . " ( segment length)"\n\x09 if explicitly_debugging "sort" ;\n      \$result = \@a_segments <=> \@b_segments ;\n      debug "vcp cmp: \$result" if \$result && explicitly_debugging "sort" ;\n      return \$result if \$result ;\n   }\n\n   confess "revs have different numbers of sort key fields:",\n      \$reva->as_string, "\\n",\n      \$revb->as_string \n      if \@a_fields || \@b_fields ;\n\n   debug "vcp cmp equal:", \$reva->as_string, "\\n             :", \$revb->as_string\n      if explicitly_debugging "sort" ;\n   return 0 ;\n}\n\n=item sort_revs\n\n   \$source->dest->sort_revs( \$source->revs ) ;\n\nThis sorts the revisions that the source has identified in to whatever order\nis needed by the destination.  The default ordering is set by L</rev_cmp_sub>.\n\nSorting is normally done in two passes.  Each file's revisions are sorted\nby change, rev_id, or time, then the resulting lists of revisions are\nsorted in to one long list by pulling the "least" revision off the head\nof each list based on change, time, comment, and name.\n\nThis two-phased approach ensures that revisions of a file are always in\nproper order no matter what order they are provided, and furthermore in an\norder that enables change number aggregation (which is useful even if the\ndestination does not provide change numbers if only to do batch submits\nor get commit timestamps in a sensible order).\n\nThe sort specification "presort" is used to engage the presort-and-merge\nalgorithm (it is engaged by default).  There is currently no way to\naffect the sort order in the presort phase.\n\n=cut\n\nsub _calc_sort_recs {\n   my VCP::Dest \$self = shift ;\n   my ( \$sort_recs, \$spec ) = \@_;\n\n   debug "vcp sort key: ", join ", ", \@\$spec\n      if debugging "sort" ;\n\n   if ( grep /avgcommenttime/, \@\$spec ) {\n      \$self->{DEST_COMMENT_TIMES} = {};\n      for ( \@\$sort_recs ) {\n         my \$r = \$_->[0];\n         my \$comment = defined \$r->comment\n             ? \$r->comment\n             : \$r->is_base_rev ? "" : undef;\n         my \$time = defined \$r->time\n             ? \$r->time\n             : \$r->is_base_rev ? 0 : undef;\n         next unless defined \$comment && defined \$time;\n         push \@{\$self->{DEST_COMMENT_TIMES}->{\$comment}}, \$time;\n      }\n\n      for ( values %{\$self->{DEST_COMMENT_TIMES}} ) {\n         next unless \@\$_;\n         my \$sum;\n         \$sum += \$_ for \@\$_;\n         \$_ = \$sum / \@\$_;\n      }\n   }\n\n   for ( \@\$sort_recs) {\n      my \$r = \$_->[0];\n      my \$sort_rec = \$self->_calc_sort_rec( \$r, \$spec );\n      ## Modify the sort rec, don't replace it\n      \@\$_ = \@\$sort_rec;\n   }\n}\n\nsub _remove_sporadics {\n   my VCP::Dest \$self = shift;\n   my ( \$sort_recs, \$spec ) = \@_;\n\n   my \@not_seen = my \@seen = ( 0 ) x \@\$spec;\n   my \@sporadics;\n   my \@keepers = ( 0 );  ## Always keep the rev (\$sort_rec[0])\n   my \$its_ok;\n\n   for ( \@\$sort_recs) {\n      for my \$i ( 1..\$#\$_ ) {\n         if ( \@{\$_->[\$i]} && defined \$_->[\$i]->[0] ) {\n            ++\$seen[\$i];\n         }\n         else {\n            ++\$not_seen[\$i];\n         }\n      }\n   }\n   for my \$i ( 1..(\$#seen > \$#not_seen ? \$#seen : \$#not_seen) ) {\n      if ( \$seen[\$i] && \$not_seen[\$i] ) {\n         push \@sporadics, \$i - 1;\n         next;\n      }\n      push \@keepers, \$i;\n\n      if (\n         \$seen[\$i]\n         && \$spec->[\$i-1] =~ /^(change|rev|time)/\n      ) {\n         ## One of the quantitative ordering fields is present.\n         \$its_ok = 1;\n      }\n   }\n\n   if ( \@sporadics ) {\n      my \@sp_desc = map \n         "\$spec->[\$_] (seen \$seen[\$_] times, missing \$not_seen[\$_])\\n",\n         \@sporadics;\n      unless ( \$its_ok ) {\n         die "missing sort key",\n            \@sp_desc == 1 ? () : "s",\n            " while sorting revisions:",\n            \@sp_desc == 1\n               ? ( " ", \@sp_desc )\n               : ( "\\n", map "    \$_", \@sp_desc ),\n            "sort keys are ",\n            join( ", ", \@\$spec ),\n            "\\n";\n      }\n\n      debug "removing sporadic sort key",\n         \@sp_desc == 1\n            ? ( ": ", \@sp_desc )\n            : ( "s:\\n", map "    \$_", \@sp_desc )\n         if debugging;\n\nconfess "not keeping revs" unless \$keepers[0] == 0;\n\n      \@\$_ = \@{\$_}[\@keepers] for \@\$sort_recs;\n   }\n}\n\n\nsub _presort_revs {\n   my VCP::Dest \$self = shift ;\n   my ( \$revs, \$sort_spec ) = \@_;\n\n   my %p;\n   for my \$r ( \$revs->get ) {\n      push \@{\$p{\$r->name}}, \$self->_calc_sort_rec( \$r, \$sort_spec );\n   }\n\n   return [ map [ sort _rev_cmp \@\$_ ], values %p ];\n}\n\n\nsub _merge_presorted_revs {\n   my VCP::Dest \$self = shift ;\n   my ( \$presorted, \$spec ) = \@_;\n\n   debug "merging presorted revisions by ", join ", ", \@\$spec\n      if debugging ;\n\n   my \@result;\n   my \@p = \@\$presorted;\n\n   my \@sort_recs = map \@\$_, \@p;\n\n   \$self->{DEST_DEFAULT_COMMENT} = "";\n   \$self->_calc_sort_recs( \\\@sort_recs, \$spec );\n   \$self->{DEST_DEFAULT_COMMENT} = undef;\n\n   ## Fill in missing time values as best as we can for things like\n   ## VSS.\n   for ( 0..\$#\$spec ) {\n      next unless \$spec->[\$_] eq "time";\n      my \$time_index = \$_ + 1; # Ignore the rev in \$_->[0]\n      for ( \@p ) {\n         my \$prev_t = [ "9" x 50 ];\n         for ( reverse \@\$_ ) {\n            if ( \@{\$_->[\$time_index]} ) {\n               \$prev_t = \$_->[\$time_index];\n            }\n            else {\n               \$_->[\$time_index] = \$prev_t;\n            }\n         }\n      }\n   }\n\n   \$self->_remove_sporadics( \\\@sort_recs, \$spec );\n\n   while ( \@p ) {\n      local \$a = \$p[0]->[0];\n      my \$which = 0;\n      local \$b;\n      for my \$i ( 1..\$#p ) {\n         \$b = \$p[\$i]->[0];\n         if ( _rev_cmp() > 0 ) {\n            \$which = \$i;\n            \$a = \$b;\n         }\n      }\n\n      push \@result, (shift \@{\$p[\$which]})->[0];\n      splice \@p, \$which, 1 unless \@{\$p[\$which]};\n   }\n\n   \@result;\n}\n\n\nsub sort_revs {\n   my VCP::Dest \$self = shift ;\n   my ( \$revs ) = \@_ ;\n\n   my \@spec = \@{\$self->{DEST_SORT_SPEC}};\n\n   if ( substr( \$spec[0], 0, 7 ) eq "presort" ) {\n      my \@prespec = ( shift \@spec ) =~ m/presort\\((?:\\s*(\\w+)[,)])*\\)/;\n      \@prespec = qw( change rev_id time ) unless \@prespec;\n\n      debug "presorting revisions by ", join ", ", \@prespec\n         if debugging ;\n\n      my \$presorted = \$self->_presort_revs( \$revs, \\\@prespec );\n\n      \$revs->set( \$self->_merge_presorted_revs( \$presorted, \\\@spec ) );\n\n      return;\n   }\n\n   debug "sorting revisions" if debugging ;\n\n   my \$sort_recs = [ map [ \$_ ], \$revs->get ];\n   \$self->_calc_sort_recs( \$sort_recs, \\\@spec );\n\n   \$self->_remove_sporadics( \$sort_recs, \\\@spec );\n\n   \$revs->set( map \$_->[0], sort _rev_cmp \@\$sort_recs ) ;\n}\n\n=back\n\n\n=back\n\n=head1 NOTES\n\nSeveral fields are jury rigged for "base revisions": these are fake\nrevisions used to start off incremental, non-bootstrap transfers with\nthe MD5 digest of the version that must be the last version in the\ntarget repository.  Since these are "faked", they don't contain\ncomments or timestamps, so the comment and timestamp fields are treated as\n"" and 0 by the sort routines.\n\nThere is a special sortkey C<avgcommenttime> that allows revisions within\nthe same time period (second, minute, day) to be sorted according to the\naverage time of the comment for the revision (across all revisions with\nthat comment).  This causes changes that span more than one time period\nto still be grouped properly.\n\n=cut\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAABX
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAABY, "lib/VCP/Patch.pm" }
package VCP::Patch ;\n\n=head1 NAME\n\nVCP::Patch - Apply the (almost) unified diffs used in RevML\n\n=head1 SYNOPSIS\n\n    use VCP::Patch ;\n\n    vcp_patch( \$source_file_name, \$result_file_name, \$patch_file_name ) ;\n\n=head1 DESCRIPTION\n\nCreates the result file by applying the patch to the source file.  Obliterates\nthe result file even if the patch fails.\n\nThe patches are in a "unified diff" format, but without the filename headers\n(these are passed as other data fields in VCP and the actual filenames are just\nworking files and are not important).  Some example patches:\n\n=item *\n\nFor a one line file:\n\n   \@\@ -1 +1 \@\@\n   -a/deeply/buried/file, revision 1, char 0x01="<char code="0x01" />"\n   +a/deeply/buried/file, revision 2, char 0x09="  "\n\n=item *\n\nFor a several line file with multiple changes:\n\nHere are the source and result files side-by-side:\n\n   Source\x09Result\n   ======\x09======\n\n   1            1\n   2\x09\x092\n   3\x09\x093\n   4\x09\x094\n   5d\x09\x095a\n   6\x09\x096\n   7\x09\x097\n   8\x09\x098\n   9\x09\x099\n   10\x09\x099a\n   11\x09\x0910\n   11d\x09\x0911\n   12\x09\x0912\n   13\x09\x0913\n\nThe "patch" to transform the source in to the result can be expressed in\nseveral ways, depending on the amount of context.  VCP requires no context\nsince the result is checked with an MD5 checksum.  Context is, however,\nsometimes used to make the RevML a bit more human readable, though this can\nvary.\n\n=over\n\n=item 0 context (C<diff -U 0>):\n\n   \@\@ -5 +5 \@\@\n   -5d\n   +5a\n   \@\@ -9,0 +10 \@\@\n   +9a\n   \@\@ -12 +12,0 \@\@\n   -11d\n\n=item 1 line of context (C<diff -U 1>):\n\n   --- A   Sat Aug 25 00:05:26 2001\n   +++ B   Sat Aug 25 00:05:26 2001\n   \@\@ -4,3 +4,3 \@\@\n    4\n   -5d\n   +5a\n    6\n   \@\@ -9,5 +9,5 \@\@\n    9\n   +9a\n    10\n    11\n   -11d\n    12\n\n=item 3 lines of context (C<diff -U 3 ...> or C<diff -u ...>)\n\n   --- A   Sat Aug 25 00:05:26 2001\n   +++ B   Sat Aug 25 00:05:26 2001\n   \@\@ -2,13 +2,13 \@\@\n    2\n    3\n    4\n   -5d\n   +5a\n    6\n    7\n    8\n    9\n   +9a\n    10\n    11\n   -11d\n    12\n    13\n\n=back\n\n=back\n\n=head1 Functions\n\n=over\n\n=cut\n\n\@ISA    = qw( Exporter ) ;\n\@EXPORT = qw( vcp_patch ) ;\n\nuse strict ;\nuse Carp ;\nuse VCP::Debug ':debug' ;\nuse Exporter ;\n\n=item vcp_patch\n\nTakes a patch file name, a source file name, and a result file name and\nperforms the patch.  Called from VCP::Source::revml to reconstitute revisions\ngiven by delta records.\n\nWill die on error, always returns true.\n\n=cut\n\nsub vcp_patch {\n   my ( \$source_fn, \$result_fn, \$patch_fn ) = \@_ ;\n\n   debug "patching \$source_fn -> \$result_fn using \$patch_fn" if debugging ;\n\n   open PATCH,  "<\$patch_fn"     or croak "\$!: \$source_fn" ;\n   open SOURCE, "<\$source_fn"    or croak "\$!: \$source_fn" ;\n   open RESULT, ">\$result_fn"    or croak "\$!: \$result_fn" ;\n\n   ## We'll need to make sure the diff's line endings match up with the\n   ## source files' somehow.\n   binmode PATCH;\n   binmode SOURCE;\n   binmode RESULT;\n\n   my \$source_pos = 1;\n\n   while ( <PATCH> =~ /(.)(.*?\\n)/ ) {\n      my ( \$fchar, \$patch_line ) = ( \$1, \$2 );\n      if ( \$fchar eq '\@' ) {\n         \$patch_line =~ /^\\\@ -(\\d+)(?:,\\d+)? [+-]\\d+(,\\d+)? \\\@\\\@/\n             or croak "Can't parse line: '\$fchar\$patch_line'.";\n         my \$first_source_line = \$1;\n         while ( \$source_pos < \$first_source_line ) {\n            my \$source_line = <SOURCE>;\n            croak "Ran off end of source file at line \$source_pos"\n               unless defined \$source_line;\n            print RESULT \$source_line;\n            ++\$source_pos;\n         }\n      }\n      elsif ( \$fchar eq '-' ) {\n         my \$source_line = <SOURCE>;\n         croak "Ran off end of source file at line \$source_pos"\n            unless defined \$source_line;\n         \$source_line =~ s/[\\r\\n]+\\z//;\n         \$patch_line =~ s/[\\r\\n]+\\z//;\n         unless ( \$source_line eq \$patch_line ) {\n            \$source_line =~ s/([\\000-\\037])/sprintf "\\\\x%02x", ord \$1/ge;\n            \$patch_line  =~ s/([\\000-\\037])/sprintf "\\\\x%02x", ord \$1/ge;\n            croak "Patch line disagrees with source line \$source_pos:\\n",\n               "source:\\"", \$source_line, "\\"\\n",\n               "patch :\\"", \$patch_line , "\\"\\n";\n         }\n         ++\$source_pos;\n      }\n      elsif ( \$fchar eq ' ' ) {\n         my \$source_line = <SOURCE>;\n         croak "Ran off end of source file at line \$source_pos"\n            unless defined \$source_line;\n         print RESULT \$source_line;\n         ++\$source_pos;\n      }\n      elsif ( \$fchar eq '+' ) {\n         print RESULT \$patch_line;\n         ++\$source_pos;\n      }\n      else {\n          croak "Unknown line type '\$fchar' in diff line '\$fchar\$patch_line'";\n      }\n   }\n\n   print RESULT <SOURCE> ;\n\n   close SOURCE or croak "\$!: \$source_fn" ;\n   close RESULT or croak "\$!: \$result_fn" ;\n   close PATCH  or croak "\$!: \$patch_fn" ;\n   return 1 ;\n}\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nSean McCune <sean\@sean-mccune.com>\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAABY
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAABZ, "lib/VCP/TestUtils.pm" }
package VCP::TestUtils ;\n\n=head1 NAME\n\nVCP::TestUtils - support routines for VCP testing\n\n=cut\n\nuse Exporter ;\n\n\@EXPORT = qw(\n   assert_eq\n   slurp\n   mk_tmp_dir\n   perl_cmd\n   vcp_cmd\n   get_vcp_output\n\n   p4d_borken \n   launch_p4d\n\n   cvs_borken\n   init_cvs\n\n   vss_borken\n\n   s_content\n   rm_elts\n) ;\n\n\@ISA = qw( Exporter ) ;\n\nuse strict ;\n\nuse Carp ;\nuse Cwd ;\nuse File::Path ;\nuse File::Spec ;\nuse IPC::Run qw( run start kill_kill ) ;\nuse POSIX ':sys_wait_h' ;\nuse Text::Diff ;\n\n=head1 General utility functions\n\n=over\n\n=item mk_tmp_dir\n\nCreates one or more temporary directories, which will be removed upon exit\nin an END block\n\n=cut\n\n{\n   my \@tmp_dirs ;\n   END { rmtree \\\@tmp_dirs unless \$ENV{VCPNODELETE} }\n\n   sub mk_tmp_dir {\n      confess "undef!!!" if grep !defined, \@_ ;\n      rmtree \\\@_ ;\n      mkpath \\\@_, 0, 0770 ;\n      push \@tmp_dirs, \@_ ;\n   }\n}\n\n=item assert_eq\n\n   assert_eq \$test_name, \$in, \$out ;\n\ndies with a useful diff in \$\@ is \$in ne \$out.  Returns nothing.\n\nRequires a diff that knows about the -d and -U options.\n\n=cut\n\n\nsub assert_eq {\n   my ( \$name, \$in, \$out ) = \@_ ;\n\n   ## Doint this because Test::Differences isn't quite "real" yet...\n   die diff \\\$in, \\\$out, { CONTEXT => 10 } if \$in ne \$out ;\n}\n\n=item slurp\n\n   \$guts = slurp \$filename ;\n\n=cut\n\nsub slurp {\n   my ( \$fn ) = \@_ ;\n   open F, "<\$fn" or die "\$!: \$fn" ;\n   binmode F ;\n   local \$/ ;\n   return <F> ;\n}\n\n\n=item perl_cmd\n\n   \@perl = perl_cmd\n\nReturns a list containing the Perl executable and some options to reproduce\nthe current Perl options , like -I.\n\n=cut\n\nsub perl_cmd {\n   my %seen ;\n   return (\n      \$^X,\n      (\n\x09 map {\n\x09    my \$s = \$_ ;\n\x09    \$s = File::Spec->rel2abs( \$_ ) ;\n\x09    "-I\$s" ;\n\x09 } grep ! \$seen{\$_}++, \@INC\n      )\n   ) ;\n}\n\n\n=item vcp_cmd\n\n   \@vcp = vcp_cmd\n\nReturns a list containing the Perl executable and some options to reproduce\nthe current Perl options , like -I.\n\nvcp_cmd assumes it is called from within the main distro directory or one\nsubdir under it, since it looks for "bin/vcp" and "../bin/vcp".  This should be\nadequate for almost all uses.\n\nvcp_cmd caches it's results to allow it to be run from other directories after\nthe first time it's called. (this is not a significant performance improvement;\nrunning the vcp process takes several orders of magnitude longer than the quick\nchecks vcp_cmd does).\n\n=cut\n\nmy \@vcp_cmd ;\n\nsub vcp_cmd {\n   unless ( \@vcp_cmd ) {\n      ## We always run vcp by doing a \@perl, vcp, to make sure that vcp runs under\n      ## the same version of perl that we are running under.\n      my \$vcp = 'vcp' ;\n      \$vcp = "bin/\$vcp"    if -e "bin/\$vcp" ;\n      \$vcp = "../bin/\$vcp" if -e "../bin/\$vcp" ;\n\n      \$vcp = File::Spec->rel2abs( \$vcp ) ;\n\n      \@vcp_cmd = ( perl_cmd, \$vcp ) ;\n   }\n   return \@vcp_cmd ;\n}\n\n\n=item get_vcp_output\n\n   \@vcp = get_vcp_output "foo:", "-bar" ;\n\nDoes a:\n\n   run [ vcp_cmd, \@_, "revml:", ... ], \\undef, \\\$out\n      or croak "`vcp blahdy blah` returned \$?";\n\nand returns \$out.  The "..." refers to whatever output options are needed\nto make the test output agree with C<bin/gentrevml>'s test files\n(t/test-*.revml).\n\n=cut\n\nsub get_vcp_output {\n   my \$out ;\n   my \@args = ( \@_, "revml:", "--sort-by=name,rev_id" ) ;\n   run [ vcp_cmd, \@args ], \\undef, \\\$out\n      or croak "`vcp ", join( " ", \@_ ), " returned \$?\\n" ;\n   return \$out ;\n}\n\n=cut\n\nsub vcp_cmd {\n   ## We always run vcp by doing a \@perl, vcp, to make sure that vcp runs under\n   ## the same version of perl that we are running under.\n   my \$vcp = 'vcp' ;\n   \$vcp = "bin/\$vcp"    if -x "bin/\$vcp" ;\n   \$vcp = "../bin/\$vcp" if -x "../bin/\$vcp" ;\n\n   \$vcp = File::Spec->rel2abs( \$vcp ) ;\n\n   return ( perl_cmd, \$vcp ) ;\n}\n\n\n=back\n\n=head1 XML "cleanup" functions\n\nThese are used to get rid of content or elements that are known to differ\nwhen comparing the revml fed in to a repository with the revml that\ncomes out.\n\n=over\n\n=item s_content\n\n   s_content\n      \$elt_type1, \$elt_type2, ..., \\\$string1, \\\$string2, ..., \$new_content ;\n\nChanges the contents of the elements, since some things, like suer id or\nmod_time can't be the same after going through a repository.\n\nIf \$new_val is not supplied, a constant string is used.\n\n=cut\n\nsub s_content {\n   my \$new_val = pop if \@_ && ! ref \$_[-1] ;\n   \$new_val = "<!-- deleted by test suite -->" unless defined \$new_val ;\n\n   my \$elt_type_re = do {\n      my \@a ;\n      push \@a, quotemeta shift while \@_ && ! ref \$_[0] ;\n      join "|", \@a ;\n   } ;\n\n   \$\$_ =~ s{(<(\$elt_type_re)[^>]*?>).*?(</\\2\\s*>)}\n\x09   {\$1\$new_val\$3}sg\n      for \@_ ;\n\n   \$\$_ =~ s{(<(\$elt_type_re)[^>]*?>).*?(</\\2\\s*>)}{\$1\$new_val\$3}sg\n      for \@_ ;\n}\n\n\n=item rm_elts\n\n   rm_elts \$elt_type1, \$elt_type2, ..., \\\$string1, \\\$string2\n   rm_elts \$elt_type1, \$elt_type2, ..., qr/\$content_re/, \\\$string1, \\\$string2\n\nRemoves the specified elements from the strings, including leading whitespace\nand trailing line separators.  If the optional \$content_re regular expression\nis provided, then only elements containing that pattern will be removed.\n\n=cut\n\nsub rm_elts {\n   my \$elt_type_re = do {\n      my \@a ;\n      push \@a, quotemeta shift while \@_ && ! ref \$_[0] ;\n      join "|", \@a ;\n   } ;\n\n   my \$content_re = \@_ && ref \$_[0] eq "Regexp" ? shift : qr/.*?/s ;\n   my \$re = qr{^\\s*<(\$elt_type_re)\\b[^>]*?>\$content_re</\\1\\s*>\\r?\\n}sm ;\n\n   \$\$_ =~ s{\$re}{}g for \@_ ;\n}\n\n\n=head1 p4 repository mgmt functions\n\n=over\n\n=item p4_borken\n\nReturns true if the p4 is missing or too old (< 99.2).\n\n=cut\n\nsub p4d_borken {\n   my \$p4dV = `p4d -V` || 0 ;\n   return "p4d not found" unless \$p4dV ;\n\n   my ( \$p4d_version ) = \$p4dV =~ m{^Rev[^/]*/[^/]*/([^/]*)}m ;\n\n   my \$min_version = 99.2 ;\n   return "p4d version too old, need at least \$min_version"\n       unless \$p4d_version >= \$min_version ;\n   return "" ;\n}\n\n=item launch_p4d\n\n   launch_p4d "prefix_" ;\n\nCreates an empty repository and launches a p4d for it.  The p4d will be killed\nand it's repository deleted on exit.  Returns the options needed to access\nthe repository.\n\n=cut\n\n#sub launch_p4d {\n#   my \$prefix = shift || "" ;\n#\n#   {\n#      my \$borken = p4d_borken ;\n#      croak \$borken if \$borken ;\n#   }\n#\n#   my \$tmp  = File::Spec->tmpdir ;\n#   my \$repo = File::Spec->catdir( \$tmp, "vcp\${\$}_\${prefix}p4repo" ) ;\n#   mk_tmp_dir \$repo ;\n#\n#   ## Ok, this is wierd: we need to fork & run p4d in foreground mode so that\n#   ## we can capture it's PID and kill it later.  There doesn't seem to be\n#   ## the equivalent of a 'p4d.pid' file. If we let it daemonize, then I\n#   ## don't know how to get it's PID.\n#\n#   my \$port ;\n#   my \$p4d_pid ;\n#   my \$tries ;\n#   while () {\n#      ## 30_000 is because I vaguely recall some TCP stack that had problems\n#      ## with listening on really high ports.  2048 is because I vaguely recall\n#      ## that some OS required root privs up to 2047 instead of 1023.\n#      \$port = ( rand( 65536 ) % 30_000 ) + 2048 ;\n#      my \@p4d = ( 'p4d', '-f', '-r', \$repo, '-p', \$port ) ;\n#      print "# Running ", join( " ", \@p4d ), "\\n" ;\n#      \$p4d_pid = fork ;\n#      unless ( \$p4d_pid ) {\n#\x09 ## Ok, there's a tiny chance that this will fail due to a port\n#\x09 ## collision.  Oh, well.\n#\x09 exec \@p4d ;\n#\x09 die "\$!: p4d" ;\n#      }\n#      sleep 1 ;\n#      ## Wait for p4d to start.  'twould be better to wait for P4PORT to\n#      ## be seen.\n#      select( undef, undef, undef, 0.250 ) ;\n#\n#      last if kill 0, \$p4d_pid ;\n#      die "p4d failed to start after \$tries tries, aborting\\n"\n#         if ++\$tries >= 3 ;\n#      warn "p4d failed to start, retrying\\n" ;\n#   }\n#\n#   END {\n#      return unless defined \$p4d_pid ;\n#      kill 'INT',  \$p4d_pid or die "\$! \$p4d_pid" ;\n#      my \$t0 = time ;\n#      my \$dead_child ;\n#      while ( \$t0 + 15 > time ) {\n#         select undef, undef, undef, 0.250 ;\n#\x09 \$dead_child = waitpid \$p4d_pid, WNOHANG ;\n#\x09 warn "\$!: \$p4d_pid" if \$dead_child == -1 ;\n#\x09 last if \$dead_child ;\n#      }\n#      unless ( defined \$dead_child && \$dead_child > 0 ) {\n#\x09 print "terminating \$p4d_pid\\n" ;\n#\x09 kill 'TERM', \$p4d_pid or die "\$! \$p4d_pid" ;\n#\x09 \$t0 = time ;\n#\x09 while ( \$t0 + 15 > time ) {\n#\x09    select undef, undef, undef, 0.250 ;\n#\x09    \$dead_child = waitpid \$p4d_pid, WNOHANG ;\n#\x09    warn "\$!: \$p4d_pid" if \$dead_child == -1 ;\n#\x09    last if \$dead_child ;\n#\x09 }\n#      }\n#      unless ( defined \$dead_child && \$dead_child > 0 ) {\n#\x09 print "killing \$p4d_pid\\n" ;\n#\x09 kill 'KILL', \$p4d_pid or die "\$! \$p4d_pid" ;\n#      }\n#   }\n#\n#   return {\n#      user =>    "\${prefix}t_user",\n#      port =>    \$port,\n#   } ;\n#}\nsub launch_p4d {\n   my \$prefix = shift || "" ;\n\n   {\n      my \$borken = p4d_borken ;\n      croak \$borken if \$borken ;\n   }\n\n   my \$tmp  = File::Spec->tmpdir ;\n   my \$repo = File::Spec->catdir( \$tmp, "vcp\${\$}_\${prefix}p4repo" ) ;\n   mk_tmp_dir \$repo ;\n\n   ## Ok, this is wierd: we need to fork & run p4d in foreground mode so that\n   ## we can capture it's PID and kill it later.  There doesn't seem to be\n   ## the equivalent of a 'p4d.pid' file. If we let it daemonize, then I\n   ## don't know how to get it's PID.\n\n   my \$port ;\n   my \$tries ;\n   my \$h ;\n   while () {\n      ## 30_000 is because I vaguely recall some TCP stack that had problems\n      ## with listening on really high ports.  2048 is because I vaguely recall\n      ## that some OS required root privs up to 2047 instead of 1023.\n      \$port = ( rand( 65536 ) % 30_000 ) + 2048 ;\n      my \@p4d = ( "p4d", "-f", "-r", \$repo, "-p", \$port ) ;\n      print "# Running ", join( " ", \@p4d ), "\\n" ;\n      \$h = start \\\@p4d ;\n      ## Wait for p4d to start.  'twould be better to wait for P4PORT to\n      ## be seen.\n      sleep 1 ;\n\n      ## The child process will have died if the port is taken or due\n      ## to other errors.\n      last if \$h->pumpable;\n      finish \$h;\n      die "p4d failed to start after \$tries tries, aborting\\n"\n         if ++\$tries >= 3 ;\n      warn "p4d failed to start, retrying\\n" ;\n   }\n\n   END {\n      return unless \$h;\n      \$h->kill_kill;\n      \$? = 0;  ## p4d exits with a "15", which becomes our exit code\n               ## if we don't clear this.\n   }\n\n   return {\n      user =>    "\${prefix}t_user",\n      port =>    \$port,\n   } ;\n}\n\n=back\n\n=head1 CVS mgmt functions\n\n=over\n\n=item cvs_borken\n\nReturns true if cvs -v works and outputs "Concurrent Versions System".\n\n=cut\n\nsub cvs_borken {\n   my \$cvsV = `cvs -v` || 0 ;\n   return "cvs command not found" unless \$cvsV ;\n   return "cvs command does not appear to be for CVS: '\$cvsV'"\n       unless \$cvsV =~ /Concurrent Versions System/;\n\n   return "" ;\n}\n\n=item init_cvs\n\n   my \$cvs_options = init_cvs \$prefix, \$module_name ;\n\nCreates a CVS repository containing an empty module. Also sets\n\$ENV{LOGNAME} if it notices that we're running as root, so CVS won't give\na "cannot commit files as 'root'" error. Tries "nobody", then "guest".\n\nReturns the options needed to access the cvs repository.\n\n=cut\n\nsub init_cvs {\n   my ( \$prefix , \$module ) = \@_ ;\n\n   my \$tmp = File::Spec->tmpdir ;\n   my \$options = {\n      repo    =>    File::Spec->catdir( \$tmp, "vcp\${\$}_\${prefix}cvsroot" ),\n      work    =>    File::Spec->catdir( \$tmp, "vcp\${\$}_\${prefix}cvswork" ),\n   } ;\n\n   my \$cwd = cwd ;\n   ## Give vcp ... cvs:... a repository to work with.  Note that it does not\n   ## use \$cvswork, just this test script does.\n\n   \$ENV{CVSROOT} = \$options->{repo} ;\n\n   ## CVS does not like root to commit files.  So, try to fool it.\n   ## CVS calls geteuid() to determine rootness (so does perl's \$>).\n   ## If root, CVS calls getlogin() first, then checks the LOGNAME and USER\n   ## environment vars.\n   ##\n   ## What this means is: if the user is actually logged in on a physical\n   ## terminal as 'root', getlogin() will return "root" to cvs and we can't\n   ## fool CVS.\n   ##\n   ## However, if they've used "su", a very common occurence, then getlogin()\n   ## will return failure (NULL in C, undef in Perl) and we can spoof CVS\n   ## using \$ENV{LOGNAME}.\n   if ( ! \$>  && \$^O !~ /Win32/ ) {\n      my \$login = getlogin ;\n      if ( ( ! defined \$login || ! getpwnam \$login )\n         && ( ! exists \$ENV{LOGNAME} || ! getpwnam \$ENV{LOGNAME} )\n      ) {\n\x09 for ( qw( nobody guest ) ) {\n\x09    my \$uid = getpwnam \$_ ;\n\x09    next unless defined \$uid ;\n\x09    ( \$ENV{LOGNAME}, \$> ) = ( \$_, \$uid ) ;\n\x09    last ;\n\x09 }\n\x09 ## Must set uid, too, to keep perl (and thus vcp) from bombing\n\x09 ## out when running setuid and given a -I option. This happens\n\x09 ## a lot in the test suite, since the tests often call vcp\n\x09 ## using "perl", "-Iblib/lib", "bin/vcp", ... to recreate the\n\x09 ## appropriate operating environment for Perl.  If this becomes\n\x09 ## a problem, perhaps we can hack in a "run as user" option to\n\x09 ## VCP::Utils::cvs so that only the cvs subcommands are run\n\x09 ## setuid, or perhaps we can avoid passing "-I" to the perls.\n\x09 \$< = \$> ;\n\x09 \n\x09 warn\n\x09    "# Setting real & eff. uids=",\n\x09    \$>,\n\x09    "(",\n\x09    \$ENV{LOGNAME},\n\x09    qq{) to quell "cvs: cannot commit files as 'root'"\\n} ;\n      }\n   }\n\n   mk_tmp_dir \$options->{repo} ;\n\n   run [ qw( cvs init ) ]                    or die "cvs init failed" ;\n\n   mk_tmp_dir \$options->{work} ;\n   chdir \$options->{work}                    or die "\$!: \$options->{work}" ;\n\n   mkdir \$module, 0770                       or die "\$!: \$module" ;\n   chdir \$module                             or die "\$!: \$module" ;\n   run [ qw( cvs import -m ), "\$module import", \$module, "\${module}_vendor", "\${module}_release" ]\n                                             or die "cvs import failed" ;\n   chdir \$cwd                                or die "\$!: \$cwd" ;\n\n   delete \$ENV{CVSROOT} ;\n#   chdir ".."                                or die "\$! .." ;\n#\n#   system qw( cvs checkout CVSROOT/modules ) and die "cvs checkout failed" ;\n#\n#   open MODULES, ">>CVSROOT/modules"         or  die "\$!: CVSROOT/modules" ;\n#   print MODULES "\\n\$module \$module/\\n"      or  die "\$!: CVSROOT/modules" ;\n#   close MODULES                             or  die "\$!: CVSROOT/modules" ;\n#\n#   system qw( cvs commit -m foo CVSROOT/modules )\n#                                             and die "cvs commit failed" ;\n   return \$options ;\n}\n\n=back\n\n=head1 VSS mgmt functions\n\n=over\n\n=item vss_borken\n\nfails unless \$ENV{SSUSER} is defined and the command C<ss whoami> runs and\nreturns what looks like a username.\n\nMay lock up if the ss.exe command prompts for a password.\n\nThis is because I can't figure out a reliable way to detect if the "ss" command\nruns well without risking a lock up, since it has a habit of prompting for\na password that I can't break it of without initalizing a custom Source Safe\nrepository.\n\n=cut\n\nsub vss_borken {\n   return "SSUSER not in the environment" unless defined \$ENV{SSUSER};\n\n   my \$user = `ss Whoami` ;\n   return "ss command not found" unless defined \$user && length \$user;\n   return "ss command did not return just a username"\n       unless \$user =~ /\\A\\S+\$/m;\n\n   return "" ;\n}\n\n=back\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAABZ
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACA, "lib/VCP/DiffFormat.pm" }
package VCP::DiffFormat ;\n\n=head1 NAME\n\n    VCP::DiffFormat - special diff format for VCP\n\n=head1 SYNOPSIS\n\n    diff \$a, \$b { STYLE => "VCP::DiffFormat" };\n\n=head1 DESCRIPTION\n\nThis is a plugin output formatter for Text::Diff that generates "unified" style\ndiffs without headers.  VCP::Dest::revml uses this to output differences for\nseveral reasons:\n\n=over\n\n=item *\n\nThe Unix C<diff> command is not available on all platforms by default,\nspecifically WinNT.\n\n=item *\n\nThe two line "file header" is not needed in RevML, since the meta information\nis captured elsewhere in the <rev> element, and the name and mtime\nof the files being compared is irrellevant; they're just some temporary files\nsomewhere\n\n=item *\n\nBecause RevML offers MD5 hashes of the file to verify that a diff was applied\nproperly, all of the "-" lines present in a normal unified diff are not\nnecesssary.  They are left in now for ease of debugging with RevML files, but\nmay be stripped out to conserve space.\n\n=cut\n\n\@ISA = qw( Text::Diff::Unified );\n\nuse strict;\nuse Text::Diff;\nuse Carp;\n\nsub file_header { "" }\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACA
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACB, "lib/VCP/Debug.pm" }
package VCP::Debug ;\n\n=head1 NAME\n\nVCP::Debug - debugging support for VCP\n\n=head1 SYNOPSIS\n\n=head1 DESCRIPTION\n\n=head1 EXPORTS\n\nThe following functions may be exported: L</debug>, L</enable_debug>,\nL</debugging>\nL</disable_debug>, along with the tags ':all' and ':debug'.  Use the latter\nto head off future namespace pollution in case :all gets expanded in the\nfuture..\n\nA warning will be emitted on program exit for any specs that aren't used,\nto help you make sure that you are using sensible specs.\n\n=over\n\n=cut\n\nuse strict ;\nuse vars qw( \$VERSION \@ISA \@EXPORT_OK %EXPORT_TAGS ) ;\nuse Exporter ;\n\n\@ISA = qw( Exporter ) ;\n\@EXPORT_OK = qw(\n   debug\n   enable_debug\n   disable_debug\n   debugging\n   explicitly_debugging\n) ;\n%EXPORT_TAGS = (\n   'all'   => \\\@EXPORT_OK,\n   'debug' => \\\@EXPORT_OK,\n) ;\n\n\$VERSION = 0.1 ;\n\n# TODO:\n#=item use\n#=item import\n#\n#In addition to all of the routines and tags that C<use> and C<import> normally\n#take (see above), you may also pass in pairwise debugging definitions like\n#so:\n#\n#   use VCP::debug (\n#      ":all",\n#      DEBUGGING_FOO => "foo,bar",\n#   ) ;\n#\n#Any all caps export import requests are created as subroutines that may well be\n#optimized away at compile time if "enable_debugging" has not been called. This\n#requires a conspiracy between the author of a module and the author of the main\n#program to call enable_debugging I<before> C<use>ing any modules that leverage\n#this feature, otherwise compile-time optimizations won't occur.\n#\n\n=item debug\n\n   debug \$foo if debugging \$self ;\n\nEmits a line of debugging (a "\\n" will be appended).  Use debug_some\nto avoid the "\\n".  Any undefined parameters will be displayed as\nC<E<lt>undefE<gt>>.\n\n=cut\n\nmy \$dump_undebugged ;\nmy \$reported_specs ;\nmy \@debug_specs ;\nmy %used_specs ;\nmy %debugging ;\n\nEND {\n   \$used_specs{'##NEVER_MATCH##'} = 1 ;\n   my \@unused = grep ! \$used_specs{\$_}, \@debug_specs ;\n\n   warn "vcp: Unused debug specs: ", join( ', ', map "/\$_/", \@unused ), "\\n"\n      if \@unused ;\n\n   if ( \@unused || \$dump_undebugged ) {\n      my \@undebugged = grep {\n\x09 my \$name = \$_ ;\n\x09 ! grep \$name =~ /\$_/i, keys %used_specs\n      } map lc \$_, sort keys %debugging ;\n\n      if ( \@undebugged ) {\n\x09 warn "vcp: Undebugged things: ", join( ', ', \@undebugged ), "\\n" ;\n      }\n      else {\n\x09 warn "vcp: No undebugged things\\n" ;\n      }\n   }\n}\n\nsub debug {\n   return unless \@debug_specs ;\n   if ( \@_ ) {\n      my \$t = join( '', map defined \$_ ? \$_ : "<undef>", \@_ ) ;\n      if ( length \$t ) {\n\x09 print STDERR \$t, substr( \$t, -1 ) eq "\\n" ? () : "\\n" ;\n      }\n   }\n}\n\n\nsub debug_some {\n   return unless \@debug_specs ;\n   print STDERR map defined \$_ ? \$_ : "<undef>", \@_ if \@_ ;\n}\n\n\n=item debugging\n\n   debug "blah" if debugging ;\n\nReturns TRUE if the caller's module is being debugged\n\n   debug "blah" if debugging \$self ;\n   debug "blah" if debugging \$other, \$self ; ## ORs the arguments together\n\nReturns TRUE if any of the arguments are being debugged.  Plain\nstrings can be passed or blessed references.\n\n=cut\n\nsub _report_specs {\n   my \@report = grep ! /##NEVER_MATCH##/, \@debug_specs ;\n   print STDERR "Debugging ",join( ', ', map "/\$_/", \@report ),"\\n"\n      if \@report ;\n   \$reported_specs = 1 ;\n}\n\n\nsub debugging {\n   return undef unless \@debug_specs ;\n\n   my \$result ;\n   my \@missed ;\n   for my \$where ( \@_ ? map ref \$_ || \$_, \@_ : scalar caller ) {\n      if ( ! exists \$debugging{\$where} ) {\n# print STDERR "missed \$where\\n" ;\n\x09 ## If this is the first miss, then these may not have been reported.\n\x09 _report_specs unless \$reported_specs ;\n\n\x09 ## We go ahead and evaluate all specs instead of returning when the\n\x09 ## first is found so that we can set \$used_specs for all specs that\n\x09 ## match.\n\x09 \$debugging{\$where} = 0 ;\n\x09 for my \$spec ( \@debug_specs ) {\n\x09    next if \$spec eq '##NEVER_MATCH##' ;\n# print STDERR "   /\$spec/:\\n" ;\n\x09    if ( \$where =~ /\$spec/i ) {\n\x09       \$debugging{\$where} = 1 ;\n\x09       \$used_specs{\$spec} = 1 ;\n\x09       \$result = 1 ;\n\x09       ## no last: we want to build up %used_specs.  There\n\x09       ## aren't usually many specs anyway.\n\x09    }\n\x09    else {\n# print STDERR "   ! /\$spec/\\n" ;\n            }\n\x09 }\n      }\n# print STDERR "\$where ", \$debugging{\$where} ? 'yes' : 'no', "\\n" ;\n      return 1 if \$debugging{\$where} ;\n   }\n\n   return \$result ;\n}\n\n=item explicitly_debugging\n\n   debug "blah" if explicitly_debugging ;\n\nReturns TRUE if the caller's module is being debugged by a literal match\ninstead of a pattern match.  This is used when debugging output would normally\nbe congested with too much crap from a particular subsystem when using a\nwildcard debug spec (like ".*"), but you want the ability to turn on debugging\nfor that subsystem:\n\n   debug "blah" if explicitly_debugging "VCP::Dest::sort" ;\n\nrequires an explicit C<VCP::Dest::sort> to be given in the debug specs.\n\n   debug "blah" if explicitly_debugging \$self ;\n   debug "blah" if explicitly_debugging \$other, \$self ; ## ORs the args\n\nReturns TRUE if any of the arguments are being debugged.  Plain\nstrings can be passed or blessed references.\n\n=cut\n\nmy %explicitly_debugging ;\n\nsub explicitly_debugging {\n   return undef unless \@debug_specs ;\n\n   my \$result ;\n   my \@missed ;\n   for my \$where ( \@_ ? map ref \$_ || \$_, \@_ : scalar caller ) {\n      if ( ! exists \$explicitly_debugging{\$where} ) {\n# print STDERR "missed \$where\\n" ;\n\x09 ## If this is the first miss, then these may not have been reported.\n\x09 _report_specs unless \$reported_specs ;\n\n\x09 ## We go ahead and evaluate all specs instead of returning when the\n\x09 ## first is found so that we can set \$used_specs for all specs that\n\x09 ## match.\n\x09 \$explicitly_debugging{\$where} = 0 ;\n\x09 for my \$spec ( \@debug_specs ) {\n\x09    next if \$spec eq '##NEVER_MATCH##' ;\n# print STDERR "   /\$spec/:\\n" ;\n\x09    if ( lc \$where eq lc \$spec ) {\n\x09       \$explicitly_debugging{\$where} = 1 ;\n\x09       \$used_specs{\$spec} = 1 ;\n\x09       \$result = 1 ;\n\x09       ## no last: we want to build up %used_specs.  There\n\x09       ## aren't usually many specs anyway.\n\x09    }\n\x09    else {\n# print STDERR "   ! /\$spec/\\n" ;\n            }\n\x09 }\n      }\n# print STDERR "\$where ", \$debugging{\$where} ? 'yes' : 'no', "\\n" ;\n      return 1 if \$explicitly_debugging{\$where} ;\n   }\n\n   return \$result ;\n}\n\n=item disable_debug\n\nDisable all debugging.\n\n=cut\n\nsub disable_debug() {\n   \@debug_specs = () ;\n   return ;\n}\n\n=item enable_debug\n\n   enable_debug ;\n   enable_debug( ...debug specs... ) ;\n\nA debug spec is a regular expression that matches the name of a module.\n\n=cut\n\nsub enable_debug {\n   my %specs = map { ( \$_ => 1 ) } \@debug_specs, \@_ ;\n   my \@new_debug_specs = %specs \n      ? keys %specs \n      : qr/^/ ;\n   _report_specs\n      if \$reported_specs && \@debug_specs != \@new_debug_specs ;\n   \@debug_specs = map(\n      /^what\$/i && ( \$dump_undebugged = 1 ) ? '##NEVER_MATCH##' : \$_,\n      \@new_debug_specs\n   ) ;\n   return ;\n}\n\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACB
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACC, "lib/VCP/Plugin.pm" }
package VCP::Plugin ;\n\n=head1 NAME\n\nVCP::Plugin - A base class for VCP::Source and VCP::Dest\n\n=head1 SYNOPSIS\n\n=head1 DESCRIPTION\n\nSome functionality is common to sources and destinations, such as\ncache access, Pod::Usage conversion, command-line access shortcut\nmember, etc.\n\n=head1 EXTERNAL METHODS\n\n=over\n\n=cut\n\nuse strict ;\n\nuse Carp ;\nuse Cwd ;\nuse File::Basename ;\nuse File::Path ;\nuse File::Spec ;\nuse IPC::Run ;\nuse UNIVERSAL qw( isa ) ;\nuse VCP::Debug ':debug' ;\nuse VCP::Rev ;\n\nuse vars qw( \$VERSION \$debug ) ;\n\n\$VERSION = 0.1 ;\n\n\$debug = 0 ;\n\nuse fields (\n   'WORK_ROOT',     ## The root of the export work area.\n   'COMMAND_CHDIR', ## Where to chdir to when running COMMAND\n   'COMMAND_STDERR_FILTER', ## How to modify the stderr when running a command\n   'COMMAND_OK_RESULT_CODES', ## HASH keyed on acceptable COMMAND return vals\n   'REV_ROOT',\n   'SEEN',          ## HASH of previosly seen filename/revisions.\n   'REPO_SCHEME',   ## The scheme (this is usually superfluous, since new() has\n                    ## already been called on the correct class).\n   'REPO_USER',     ## The user name to log in to the repository with, if any\n   'REPO_PASSWORD', ## The password to log in to the repository with, if any\n   'REPO_SERVER',   ## The repository to connect to\n   'REPO_FILESPEC', ## The filespec to get/store\n) ;\n\n\n=item new\n\nCreates an instance, see subclasses for options.  The options passed are\nusually native command-line options for the underlying repository's\nclient.  These are usually parsed and, perhaps, checked for validity\nby calling the underlying command line.\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my \$self ;\n\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   \$self->work_root( \$self->tmp_dir ) ;\n   rmtree \$self->work_root if ! \$ENV{VCPNODELETE} && -e \$self->work_root ;\n\n   \$self->{SEEN} = {} ;\n\n   \$self->{COMMAND_OK_RESULT_CODES} = { 0 => undef } ;\n\n   \$self->command_chdir( \$self->work_path ) ;\n\n   return \$self ;\n}\n\n\n###############################################################################\n\n=head1 SUBCLASSING\n\nThis class uses the fields pragma, so you'll need to use base and \npossibly fields in any subclasses.\n\n=head2 SUBCLASS API\n\nThese methods are intended to support subclasses.\n\n=over\n\n=item seen\n\n   \$old_rev = \$self->seen( \$new_rev ) ;\n   \$old_r = \$self->seen( \$name ) ;\n\nCalled to register the fact that \$new_rev has been seen, and\nto return the last request for the same resource, which refers to the\nprevious version of the resource.  If a plain scalar is passed, simply\nreturns the last rev structure that was seen for that filename (but\ndoes not mark that filename as having been seen if it hasn't).\n\nThis is one of the few accessor methods in VCP's implementation that returns\nthe previous value.\n\n=cut\n\nsub seen {\n   my VCP::Plugin \$self = shift ;\n   my ( \$arg ) = \@_ ;\n\n   confess "SEEN not initted: need to call SUPER::new?"\n      unless defined \$self->{SEEN} ;\n\n   if ( ref \$arg ) {\n      my VCP::Rev \$r = \$arg ;\n      my \$old_r = \$self->{SEEN}->{\$r->name} ;\n      \$self->{SEEN}->{\$r->name} = \$arg ;\n      return \$old_r ;\n   }\n   else {\n      return exists \$self->{SEEN}->{\$arg} && \$self->{SEEN}->{\$arg} ;\n   }\n}\n\n\n=item delete_seen\n\nDeletes the last seen revision for a file.  Returns nothing.\n\n=cut\n\nsub delete_seen {\n   my VCP::Plugin \$self = shift ;\n   my ( \$arg ) = \@_ ;\n\n   confess "SEEN not initted: need to call SUPER::new?"\n      unless defined \$self->{SEEN} ;\n\n   delete \$self->{SEEN}->{\$arg->name} ;\n   return ;\n}\n\n=item none_seen\n\nReturns TRUE if \$dest->seen( \$r ) has not yet been called.\n\n=cut\n\nsub none_seen {\n   my VCP::Plugin \$self = shift ;\n\n   ## This can happen if a subclass forgets to init it's base class(es).\n   confess "Oops" unless defined \$self->{SEEN} ;\n\n   return ! %{\$self->{SEEN}} ;\n}\n\n\n=item parse_repo_spec\n\n   my \$spec = \$self->split_repo_spec( \$spec ) ;\n\nThis splits a repository spec in one of the following formats:\n\n   scheme:user:passwd\@server:filespec\n   scheme:user\@server:filespec\n   scheme::passwd\@server:filespec\n   scheme:server:filespec\n   scheme:filespec\n\nin to the indicated fields, which are stored in \$self and may be\naccessed and altered using L</repo_scheme>, L</repo_user>, L</repo_password>,\nL</repo_server>, and L</repo_filespec>. Some sources and destinations may\nadd additional fields. The p4 drivers create an L<VCP::Utils::p4/repo_client>,\nfor instance, and parse the repo_user field to fill it in.  See\nL<VCP::Utils::p4/parse_p4_repo_spec> for details.\n\nThe spec is parsed from the ends towars the middle in this order:\n\n   1. SCHEME (up to first ':')\n   2. FILESPEC  (after last ':')\n   3. USER, PASSWORD (before first '\@')\n   4. SERVER (everything left).\n\nThis approach allows the FILESPEC string to contain '\@', and the SERVER\nstring to contain ':' and '\@'.  USER can contain ':'.  Funky, but this\nworks well, at least for cvs and p4.\n\nIf a section of the repo spec is not present, the corresponding entry\nin \$hash will not exist.\n\nThe attributes repo_user, repo_password and repo_server are set\nautomatically by this method.  It does not store the SCHEME anyware\nsince the SCHEME is usually ignored by the plugin (the plugin is\nselected using the scheme, so it knows the scheme implicitly), and\nthe FILES setting often needs extra manipulation, so there's no point\nin storing it.\n\n=cut\n\nsub parse_repo_spec {\n   my VCP::Plugin \$self = shift ;\n\n   my ( \$spec ) = \@_ ;\n\n   my \$result ;\n\n   for ( \$spec ) {\n      return \$result unless s/^([^:]*)(?::|\$)// ;\n      \$result->{SCHEME} = \$1 ;\n      \$self->repo_scheme( \$1 ) ;\n\n      return \$result unless s/(?:^|:)([^:]*)\$// ;\n      \$result->{FILES} = \$1 ;\n      \$self->repo_filespec( \$1 ) ;\n\n      if ( s/^([^\\\@]*?)(?::([^\\\@:]*))?\@// ) {\n         if ( defined \$1 ) {\n\x09    \$result->{USER}     = \$1 ;\n\x09    \$self->repo_user( \$1 ) ;\n\x09 }\n\n         if ( defined \$2 ) {\n\x09    \$result->{PASSWORD} = \$2 ;\n\x09    \$self->repo_password( \$2 ) ;\n\x09 }\n      }\n\n      return \$result unless length \$spec ;\n      \$result->{SERVER} = \$spec ;\n      \$self->repo_server( \$spec ) ;\n   }\n\n   ## TODO: Return nothing.  Callers need to come to use the\n   ## accessors.\n   return \$result\n}\n\n\n\n=item usage_and_exit\n\n   GetOptions( ... ) or \$self->usage_and_exit ;\n\nUsed by subclasses to die if unknown options are passed in.\n\nRequires Pod::Usage when called.\n\n=cut\n\nsub usage_and_exit {\n   my VCP::Plugin \$self = shift ;\n\n   require Pod::Usage ;\n   my \$f = ref \$self ;\n   \$f =~ s{::}{/}g ;\n   \$f .= '.pm' ;\n\n   for ( \@INC ) {\n      my \$af = File::Spec->catfile( \$_, \$f ) ;\n      if ( -f \$af ) {\n\x09 Pod::Usage::pod2usage(\n\x09    -input   => \$af,\n\x09    -verbose => 0,\n\x09    -exitval => 2,\n\x09 ) ;\n\x09 confess ;\n      }\n   }\n\n   die "can't locate '\$f' to print usage.\\n" ;\n}\n\n\n=item tmp_dir\n\nReturns the temporary directory this plugin should use, usually something\nlike "/tmp/vcp123/dest-p4".\n\n=cut\n\nmy %tmp_dirs ;\n\nEND {\n   return unless keys %tmp_dirs;\n   ## This delay seems to be required to give NT a chance\n   ## to clean up the tmpdir, otherwise we get a\n   ## "permission denied error on Win32.\n   select undef, undef, undef, 0.01 if \$^O =~ /Win32/ ;\n   rmtree [ reverse sort { length \$a <=> length \$b } keys %tmp_dirs ]\n      if ! \$ENV{VCPNODELETE} && %tmp_dirs ;\n}\n\nsub tmp_dir {\n   my VCP::Plugin \$self = shift ;\n   my \$plugin_dir = ref \$self ;\n   \$plugin_dir =~ tr/A-Z/a-z/ ;\n   \$plugin_dir =~ s/^VCP:://i ;\n   \$plugin_dir =~ s/::/-/g ;\n   my \$tmp_dir_root = File::Spec->catdir( File::Spec->tmpdir, "vcp\$\$" ) ;\n\n   ## Make sure no old tmpdir is there to mess us up in case\n   ## a previous run crashed before cleanup or \$ENV{VCPNODELETE} is set.\n   if ( ! \$tmp_dirs{\$tmp_dir_root} && -e \$tmp_dir_root ) {\n      warn "Removing previous working directory \$tmp_dir_root\\n";\n      rmtree [\$tmp_dir_root ], 0;\n   }\n\n   \$tmp_dirs{\$tmp_dir_root} = 1 ;\n   return File::Spec->catdir( \$tmp_dir_root, \$plugin_dir, \@_ ) ;\n}\n\n\n=item work_path\n\n   \$full_path = \$self->work_path( \$filename, \$rev ) ;\n\nReturns the full path to the working copy of the local filename.\n\nEach VCP::Plugin gets thier own hierarchy to use, usually rooted at\na directory named /tmp/vcp\$\$/plugin-source-foo/ for a module\nVCP::Plugin::Source::foo.  \$\$ is vcp's process ID.\n\nThis is typically \$work_root/\$filename/\$rev, but this may change.\n\$rev is put last instead of first in order to minimize the overhead of\ncreating lots of directories.\n\nIt *must* be under \$work_root in order for rm_work_path() to fully\nclean.\n\nAll directories will be created as needed, so you should be able\nto create the file easily after calling this.  This is only\ncalled by subclasses, and is optional: a subclass could create it's\nown caching system.\n\nDirectories are created mode 0775 (rwxrwxr-x), subject to modification\nby umask or your local operating system.  This will be modifiable in\nthe future.\n\n=cut\n\nsub work_path {\n   my VCP::Plugin \$self = shift ;\n\n   my \$path = File::Spec->canonpath(\n      File::Spec->catfile( \$self->work_root, \@_ )\n   ) ;\n\n   return \$path ;\n}\n\n\n=item mkdir\n\n   \$self->mkdir( \$filename ) ;\n   \$self->mkdir( \$filename, \$mode ) ;\n\nMakes a directory and any necessary parent directories.\n\nThe default mode is 770.  Does some debug logging if any directories are\ncreated.\n\nReturns nothing.\n\n=cut\n\nsub mkdir {\n   my VCP::Plugin \$self = shift ;\n\n   my ( \$path, \$mode ) = \@_ ;\n\n   unless ( -d \$path ) {\n      \$mode = 0770 unless defined \$mode ;\n      debug "vcp: mkdir \$path, ", sprintf "%04o", \$mode if debugging \$self ;\n      mkpath [ \$path ], 0, \$mode\n         or die "vcp: failed to create \$path with mode \$mode\\n" ;\n   }\n\n   return ;\n}\n\n\n=item mkpdir\n\n   \$self->mkpdir( \$filename ) ;\n   \$self->mkpdir( \$filename, \$mode ) ;\n\nMakes the parent directory of a filename and all directories down to it.\n\nThe default mode is 770.  Does some debug logging if any directories are\ncreated.\n\nReturns the path of the parent directory.\n\n=cut\n\nsub mkpdir {\n   my VCP::Plugin \$self = shift ;\n\n   my ( \$path, \$mode ) = \@_ ;\n\n   my ( undef, \$dir ) = fileparse( \$path ) ;\n\n   \$self->mkdir( \$dir, \$mode ) ;\n\n   return \$dir ;\n}\n\n\n=item rm_work_path\n\n   \$self->rm_work_path( \$filename, \$rev ) ;\n   \$self->rm_work_path( \$dirname ) ;\n\nRemoves a directory or file from the work.  Also removes any and\nall directories that become empty as a result up to the\nwork root (/tmp on Unix).\n\n=cut\n\nsub rm_work_path {\n   my VCP::Plugin \$self = shift ;\n\n   my \$path = \$self->work_path( \@_ ) ;\n\n   if ( defined \$path && -e \$path ) {\n      debug "vcp: rmtree \$path" if debugging \$self ;\n      if ( ! \$ENV{VCPNODELETE} ) {\n         rmtree \$path or warn "\$!: \$path"\n      }\n      else {\n         warn "Not removing working directory \$path due to VCPNODELETE\\n";\n      }\n   }\n\n   my \$root = \$self->work_root ;\n\n   if ( substr( \$path, 0, length \$root ) eq \$root ) {\n      while ( length \$path > length \$root ) {\n\x09 ( undef, \$path ) = fileparse( \$path ) ;\n\x09 ## TODO: More discriminating error handling.  But the error emitted\n\x09 ## when a directory is not empty may differ from platform\n\x09 ## to platform, not sure.\n\x09 last unless rmdir \$path ;\n      }\n   }\n}\n\n\n=item work_root\n\n   \$root = \$self->work_root ;\n   \$self->work_root( \$new_root ) ;\n   \$self->work_root( \$new_root, \$dir1, \$dir2, .... ) ;\n\nGets/sets the work root.  This defaults to\n\n   File::Spec->tmpdir . "/vcp\$\$/" . \$plugin_name\n\nbut may be altered.  If set to a relative path, the current working\ndirectory is prepended.  The returned value is always absolute, and will\nnot change if you chdir().  Depending on the operating system, however,\nit might not be located on to the current volume.  If not, it's a bug,\nplease patch away.\n\n=cut\n\nsub work_root {\n   my VCP::Plugin \$self = shift ;\n\n   if ( \@_ ) {\n      if ( defined \$_[0] ) {\n\x09 \$self->{WORK_ROOT} = File::Spec->catdir( \@_ ) ;\n\x09 debug "vcp: work_root set to '",\$self->work_root,"'"\n\x09    if debugging \$self ;\n\x09 unless ( File::Spec->file_name_is_absolute( \$self->{WORK_ROOT} ) ) {\n\x09    require Cwd ;\n\x09    \$self->{WORK_ROOT} = File::Spec->catdir( Cwd::cwd, \@_ ) ;\n\x09 }\n      }\n      else {\n         \$self->{WORK_ROOT} = undef ;\n      }\n   }\n\n   return \$self->{WORK_ROOT} ;\n}\n\n\n=item command_chdir\n\nSets/gets the directory to chdir into before running the default command.\n\n=cut\n\nsub command_chdir {\n   my VCP::Plugin \$self = shift ;\n   if ( \@_ ) {\n      \$self->{COMMAND_CHDIR} = shift ;\n      debug "vcp: command_chdir set to '", \$self->command_chdir, "'"\n         if debugging \$self ;\n   }\n   return \$self->{COMMAND_CHDIR} ;\n}\n\n\n=item command_stderr_filter\n\n   \$self->command_stderr_filter( qr/^cvs add: use 'cvs commit'.*\\n/m ) ;\n   \$self->command_stderr_filter( sub { my \$t = shift ; \$\$t =~ ... } ) ;\n\nSome commands--cough*cvs*cough--just don't seem to be able to shut up\non stderr.  Other times we need to watch stderr for some meaningful output.\n\nThis allows you to filter out expected whinging on stderr so that the command\nappears to run cleanly and doesn't cause \$self->cmd(...) to barf when it sees\nexpected output on stderr.\n\nThis can also be used to filter out intermittent expected errors that\naren't errors in all contexts when they aren't actually errors.\n\n=cut\n\nsub command_stderr_filter {\n   my VCP::Plugin \$self = shift ;\n   \$self->{COMMAND_STDERR_FILTER} = \$_[0] if \@_ ;\n   return \$self->{COMMAND_STDERR_FILTER} ;\n}\n\n\n=item command_ok_result_codes\n\n   \$self->command_ok_result_codes( 0, 1 ) ;\n\nOccasionally, a non-zero result is Ok.  this method lets you set a list\nof acceptable result codes.\n\n=cut\n\nsub command_ok_result_codes {\n   my VCP::Plugin \$self = shift ;\n\n   if ( \@_ ) {\n      %{\$self->{COMMAND_OK_RESULT_CODES}} = () ;\n      \@{\$self->{COMMAND_OK_RESULT_CODES}}{\@_} = () ;\n   }\n\n   return unless defined wantarray ;\n   return keys %{\$self->{COMMAND_STDERR_FILTER}} ;\n}\n\n\n=item repo_scheme\n\n   \$self->repo_scheme( \$scheme_name ) ;\n   \$scheme_name = \$self->repo_scheme ;\n\nSets/gets the scheme specified ("cvs", "p4", "revml", etc). This is normally\nsuperfluous, since the scheme name is peeked at in order to load the\ncorrect VCP::{Source,Dest}::* class, which then calls this.\n\nThis is usually set automatically by L</parse_repo_spec>.\n\n=cut\n\nsub repo_scheme {\n   my VCP::Plugin \$self = shift ;\n   \$self->{REPO_SCHEME} = \$_[0] if \@_ ;\n   return \$self->{REPO_SCHEME} ;\n}\n\n\n=item repo_user\n\n   \$self->repo_user( \$user_name ) ;\n   \$user_name = \$self->repo_user ;\n\nSets/gets the user name to log in to the repository with.  Some plugins\nignore this, like revml, while others, like p4, use it.\n\nThis is usually set automatically by L</parse_repo_spec>.\n\n=cut\n\nsub repo_user {\n   my VCP::Plugin \$self = shift ;\n   \$self->{REPO_USER} = \$_[0] if \@_ ;\n   return \$self->{REPO_USER} ;\n}\n\n\n=item repo_password\n\n   \$self->repo_password( \$password ) ;\n   \$password = \$self->repo_password ;\n\nSets/gets the password to log in to the repository with.  Some plugins\nignore this, like revml, while others, like p4, use it.\n\nThis is usually set automatically by L</parse_repo_spec>.\n\n=cut\n\nsub repo_password {\n   my VCP::Plugin \$self = shift ;\n   \$self->{REPO_PASSWORD} = \$_[0] if \@_ ;\n   return \$self->{REPO_PASSWORD} ;\n}\n\n\n=item repo_server\n\n   \$self->repo_server( \$server ) ;\n   \$server = \$self->repo_server ;\n\nSets/gets the repository to log in to.  Some plugins\nignore this, like revml, while others, like p4, use it.\n\nThis is usually set automatically by L</parse_repo_spec>.\n\n=cut\n\nsub repo_server {\n   my VCP::Plugin \$self = shift ;\n   \$self->{REPO_SERVER} = \$_[0] if \@_ ;\n   return \$self->{REPO_SERVER} ;\n}\n\n\n=item repo_filespec\n\n   \$self->repo_filespec( \$filespec ) ;\n   \$filespec = \$self->repo_filespec ;\n\nSets/gets the filespec.\n\nThis is usually set automatically by L</parse_repo_spec>.\n\n=cut\n\nsub repo_filespec {\n   my VCP::Plugin \$self = shift ;\n   \$self->{REPO_FILESPEC} = \$_[0] if \@_ ;\n   return \$self->{REPO_FILESPEC} ;\n}\n\n\n=item rev_root\n\n   \$self->rev_root( 'depot' ) ;\n   \$rr = \$self->rev_root ;\n\nThe rev_root is the root of the tree being sourced. See L</deduce_rev_root>\nfor automated extraction.\n\nRoot values should have neither a leading or trailing directory separator.\n\n'/' and '\\' are recognized as directory separators and runs of these\nare converted to single '/' characters.  Leading and trailing '/'\ncharacters are then removed.\n\n=cut\n\nsub _slash_hack {\n   for ( my \$spec = shift ) {\n      confess "undef arg" unless defined \$spec ;\n      s{[/\\\\]+}{/}g ;\n      s{^/}{}g ;\n      s{/\\Z}{}g ;\n      return \$_ ;\n   }\n}\n\nsub rev_root {\n   my VCP::Plugin \$self = shift ;\n\n   if ( \@_ ) {\n      \$self->{REV_ROOT} = &_slash_hack ;\n      debug "vcp: rev_root set to '\$self->{REV_ROOT}'" if debugging \$self ;\n   }\n   return \$self->{REV_ROOT} ;\n}\n\n\n=item deduce_rev_root\n\n   \$self->deduce_rev_root ;\n   print \$self->rev_root ;\n\nThis is used in most plugins to deduce the rev_root from the filespec portion\nof the source or destination spec if the user did not specify a rev_root as\nan option.\n\nThis function sets the rev_root to be the portion of the filespec up to (but\nnot including) the first file/directory name with a wildcard.\n\n'/' and '\\' are recognized as directory separators, and '*', '?', and '...'\nas wildcard sequences.  Runs of '/' and '\\' characters are reduced to\nsingle '/' characters.\n\n=cut\n\nsub deduce_rev_root {\n   my VCP::Plugin \$self = shift ;\n\n   my ( \$spec ) = &_slash_hack ;\n   my \@dirs ;\n   my \$wildcard_found ;\n   for ( split( /[\\\\\\/]+/, \$spec ) ) {\n      if ( /[*?]|\\.\\.\\./ ) {\n\x09 \$wildcard_found = 1 ;\n         last ;\n      }\n      push \@dirs, \$_ ;\n   }\n\n   my \$dirs = \$wildcard_found || \@dirs < 2 ? \$#dirs : \$#dirs - 1 ;\n   \$self->rev_root( join( '/', \@dirs[0..\$dirs] ) ) ;\n}\n\n\n=item normalize_name\n\n   \$fn = \$self->normalize_name( \$fn ) ;\n\nNormalizes the filename by converting runs of '\\' and '/' to '/', removing\nleading '/' characters, and removing a leading rev_root.  Dies if the name\ndoes not begin with rev_root.\n\n=cut\n\nsub normalize_name {\n   my VCP::Plugin \$self = shift ;\n\n   my ( \$spec ) = &_slash_hack ;\n\n   my \$rr = \$self->rev_root ;\n\n   return \$spec unless length \$rr ;\n   confess "'\$spec' does not begin with rev_root '\$rr'"\n      unless substr( \$spec, 0, length \$rr ) eq \$rr ;\n \n   return substr( \$spec, length( \$rr ) + 1 ) ;\n}\n\n\n=item denormalize_name\n\n   \$fn = \$self->denormalize_name( \$fn ) ;\n\nDenormalizes the filename by prepending the rev_root.  May do more in\nsubclass overloads.  For instance, does not prepend a '//' by default for\ninstance, but p4 overloads do that.\n\n=cut\n\nsub denormalize_name {\n   my VCP::Plugin \$self = shift ;\n\n   return join( '/', \$self->rev_root, shift ) ;\n}\n\n\n=item run\n\nDEPRECATED: use run_safely instead.\n\n   \$self->run( [\@cmd_and_args], \\\$stdout, \\\$stderr ) ;\n\nA wrapper around L<IPC::Run/run>, which integrates debugging support and\ndisables stdin by default.\n\n=cut\n\n## output command lines using " quoting on Win32 so we can cut & paste.\nmy \$q = \$^O =~ /Win32|OS2/ ? '"' : "'";\n\nsub run {\n   my VCP::Plugin \$self = shift ;\n   my \$cmd = shift ;\n\n\n   debug "vcp: running ", join( ' ', map "\$q\$_\$q", \@\$cmd )\n      if debugging \$self ;\n   \n   return IPC::Run::run( \$cmd, \\undef, \@_ ) ;\n}\n\n=item run_safely\n\nRuns a command "safely", first chdiring in to the proper directory and\nthen running it while examining STDERR through an optional filter and\nlooking at the result codes to see if the command exited acceptably.\n\nMost often called from VCP::Utils::foo methods.\n\n=cut\n\nsub run_safely {\n   my VCP::Plugin \$self = shift ;\n   my \$cmd = shift ;\n\n   my \$cmd_path = \$cmd->[0] ;\n   my \$cmd_name = basename( \$cmd_path ) ;\n\n   ## Prefix succinct mode args with '>', etc.\n   my \$childs_stderr = '' ;\n   my \@redirs ;\n   my \$fd = 1 ;\n   while ( \@_ ) {\n      last unless ref \$_[0] ;\n      push \@redirs, "\$fd>", shift ;\n      ++\$fd ;\n   }\n\n   my \$stderr_filter;\n   while ( \@_ ) {\n      if ( \$_[-1] eq "stderr_filter" ) {\n         shift;\n         \$stderr_filter = shift;\n         next;\n      }\n      push \@redirs, shift \@_ ;\n   }\n   \$stderr_filter = \$self->command_stderr_filter\n      unless defined \$stderr_filter;\n\n   ## Put it on the beginning so that later redirects specified by the client\n   ## can override our redirect.  This is necessary in case the client does\n   ## a '2>&1' or some other subtle thing.\n   unshift \@redirs, '2>', \\\$childs_stderr\n      unless grep \$_ eq '2>', \@redirs ;\n\n   unshift \@redirs, '<', \\undef\n      unless grep \$_ eq '<', \@redirs ;\n\n   debug "vcp: running ", join( ' ', map "\$q\$_\$q", \@\$cmd ),\n      " in ", defined \$self->{COMMAND_CHDIR}\n         ?  \$self->{COMMAND_CHDIR}\n\x09 : "undef"\n      if debugging \$self, join( '::', ref \$self, \$cmd->[0] ) ;\n\n   my \$cwd ;\n\n   if ( defined \$self->command_chdir ) {\n      \$self->mkdir( \$self->command_chdir )\n\x09 unless -e \$self->command_chdir ;\n\n      \$cwd = cwd;\n\n      chdir \$self->command_chdir or die "\$!: ", \$self->command_chdir ;\n      cwd;\n#      debug "now in ", cwd if debugging ;\n   }\n   \n   my \$h = IPC::Run::harness( \$cmd, \@redirs ) ;\n   \$h->run ;\n\n   if ( defined \$cwd ) {\n      chdir \$cwd or die "\$!: \$cwd" ;\n#      debug "now in ", cwd if debugging ;\n   }\n\n   my \@errors ;\n\n   if ( length \$childs_stderr ) {\n      if ( debugging \$self ) {\n         my \$t = \$childs_stderr ;\n\x09 \$t =~ s/^/\$cmd_name: /gm ;\n\x09 debug \$t ;\n      }\n      if ( ref \$stderr_filter eq 'Regexp' ) {\n         \$childs_stderr =~ s/\$stderr_filter//mg ;\n      }\n      elsif ( ref \$stderr_filter eq 'CODE' ) {\n         \$stderr_filter->( \\\$childs_stderr ) ;\n      }\n\n      if ( length \$childs_stderr ) {\n\x09 \$childs_stderr =~ s/^/\$cmd_name: /gm ;\n\x09 \$childs_stderr .= "\\n" unless substr( \$childs_stderr, -1 ) eq "\\n" ;\n\x09 push (\n\x09    \@errors,\n\x09    "vcp: unexpected stderr from '\$cmd_name':\\n",\n\x09    \$childs_stderr,\n\x09 ) ;\n      }\n   }\n\n   ## In checking the result code, we assume the first one is the important\n   ## one.  This is done because a few callers pipe the first child's output\n   ## in to a perl sub that then does a kill 9,\$\$ to effectively exit without\n   ## calling DESTROY.\n   ## TODO: Look at all of the result codes if we can get rid of kill 9, \$\$.\n   push(\n      \@errors,\n      "vcp: ",\n      join( ' ', \@\$cmd ),\n      " returned ",\n      \$h->full_result( 0 ),\n      " not ",\n      join( ', ', keys %{\$self->{COMMAND_OK_RESULT_CODES}} ),\n      "\\n"\n   )\n      unless exists \$self->{COMMAND_OK_RESULT_CODES}->{\$h->full_result( 0 )} ;\n\n   die join( '', \@errors ) if \@errors ;\n\n   Carp::cluck "Result of `", join( ' ', \@\$cmd ), "` checked"\n      if defined wantarray ;\n}\n\n\nsub DESTROY {\n   my VCP::Plugin \$self = shift ;\n\n   if ( defined \$self->work_root ) {\n      local \$\@ ;\n      eval { \$self->rm_work_path() ; } ;\n\n      warn "Unable to remove work directory '", \$self->work_root, "'\\n"\n\x09 if ! \$ENV{VCPNODELETE} && -d \$self->work_root ;\n   }\n}\n\n=back\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACC
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACD, "lib/VCP/Revs.pm" }
package VCP::Revs ;\n\n=head1 NAME\n\nVCP::Revs - A collection of VCP::Rev objects.\n\n=head1 SYNOPSIS\n\n=head1 DESCRIPTION\n\nRight now, all revs are kept in memory, but we will enable storing them to\ndisk and recovering them at some point so that we don't gobble huge\ntracts of RAM.\n\n=head1 METHODS\n\n=over\n\n=cut\n\n\$VERSION = 1 ;\n\nuse strict ;\n\nuse Carp ;\nuse VCP::Debug ":debug" ;\nuse VCP::Rev ;\n\nuse fields (\n   'REVS',        ## The revs, sorted or not\n   'SEEN',        ## A HASH of keys of form "filename,rev#"\n) ;\n\n\n=item new\n\n=cut\n\nsub new {\n   my \$class = CORE::shift ;\n   \$class = ref \$class || \$class ;\n\n   my \$self ;\n\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   \$self->{REVS} = [] ;\n   \$self->{SEEN} = {} ;\n\n   return \$self ;\n}\n\n\n=item add\n\n   \$revs->add( \$rev ) ;\n   \$revs->add( \$rev1, \$rev2, ... ) ;\n\nAdds a revision or revisions to the collection.\n\n=cut\n\nsub add {\n   my VCP::Revs \$self = CORE::shift ;\n\n   if ( debugging \$self || debugging scalar caller ) {\n      debug( "vcp: queuing ", \$_->as_string ) for \@_ ;\n   }\n\n   for my \$r ( \@_ ) {\n      my \$key = \$r->name . "#" . \$r->rev_id ;\n      croak "Can't add same revision twice: '" . \$r->as_string\n         if \$self->{SEEN}->{\$key} ;\n      \$self->{SEEN}->{\$key} = 1 ;\n      push \@{\$self->{REVS}}, \$r ;\n   }\n}\n\n\n=item set\n\n   \$revs->set( \$rev ) ;\n   \$revs->set( \$rev1, \$rev2, ... ) ;\n\nSets the list of revs.\n\n=cut\n\nsub set {\n   my VCP::Revs \$self = CORE::shift ;\n\n   Carp::confess "undef passed" if grep !defined, \@_;\n\n   if ( debugging \$self || debugging scalar caller ) {\n      require UNIVERSAL;\n      Carp::confess "unblessed ref passed" if grep !UNIVERSAL::can( \$_, "as_string" ), \@_;\n      debug( "vcp: queuing ", \$_->as_string ) for \@_ ;\n   }\n\n   \@{\$self->{REVS}} = \@_ ;\n}\n\n\n=item get\n\n   \@revs = \$revs->get ;\n\nGets the list of revs.\n\n=cut\n\nsub get {\n   my VCP::Revs \$self = CORE::shift ;\n\n   return \@{\$self->{REVS}} ;\n}\n\n\n=item sort\n\n   # Using a custom sort function:\n   \$revs->sort( sub { ... } ) ;\n\nNote: Don't use \$a and \$b in your sort function.  They're package globals\nand that's not your package.  See L<VCP::Dest/rev_cmp_sub> for more details.\n\n=cut\n\nsub sort {\n   my VCP::Revs \$self = CORE::shift ;\n\n   my ( \$sort_func ) = \@_ ;\n\n   \@{\$self->{REVS}} = sort \$sort_func, \@{\$self->{REVS}} ;\n}\n\n\n=item shift\n\n   while ( \$r = \$revs->shift ) {\n      ...\n   }\n\nCall L</sort> before calling this :-).\n\n=cut\n\nsub shift {\n   my VCP::Revs \$self = CORE::shift ;\n\n   return shift \@{\$self->{REVS}} ;\n}\n\n\n=item as_array_ref\n\nReturns an ARRAY ref of all revs.\n\n=cut\n\nsub as_array_ref {\n   my VCP::Revs \$self = CORE::shift ;\n\n   return \$self->{REVS} ;\n}\n\n\n=head1 SUBCLASSING\n\nThis class uses the fields pragma, so you'll need to use base and \npossibly fields in any subclasses.\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACD
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACE, "lib/VCP/Rev.pm" }
package VCP::Rev ;\n\n=head1 NAME\n\nVCP::Rev - VCP's concept of a revision\n\n=head1 SYNOPSIS\n\n=head1 DESCRIPTION\n\n=head1 METHODS\n\n=over\n\n=cut\n\n\$VERSION = 1 ;\n\nuse strict ;\n\nuse Carp ;\nuse VCP::Debug ':debug' ;\nuse vars qw( %FIELDS ) ;\n\nuse fields (\n## RevML fields:\n   'NAME',       ## The file name, relative to REV_ROOT\n   'TYPE',       ## Type.  Binary/text.  Need to stdize the values here\n   'REV_ID',     ## The source repositories unique ID for this revision\n   'CHANGE_ID',  ## The unique ID for the change set, if any\n   'P4_INFO',    ## p4-specific info.\n   'CVS_INFO',   ## cvs-specific info.\n   'STATE',      ## The state (CVS specific at the moment).\n   'TIME',       ## The commit/submit time, if available, as a simple number\n   'MOD_TIME',   ## The last modification time, if available\n   'USER_ID',    ## The submitter/commiter of the revision\n   'LABELS',     ## A HASH, keys are tags/labels assoc. with this rev.\n   'COMMENT',    ## The comment/message for this rev.\n   'ACTION',     ## What was done ('edit', 'move', 'delete', etc.)\n   'BASE_REV_ID',\n## Internal fields: used by VCP::* modules, but not present in RevML files.\n   'WORK_PATH',  ## Where to find the revision on the local filesys\n   'DEST_WORK_PATH', ## Where to find the rev on local fs if it was backfilled\n   'SOURCE_NAME',  ## The non-normalized name of the file, meaningful only to\n                   ## a specific VCP::Source\n## TODO: delete this, I think it is no longer used.\n   'SORT_KEY',   ## An ARRAY of ARRAYs of the fields and segments to sort by\n) ;\n\nBEGIN {\n   ## Define accessors.\n   for ( keys %FIELDS ) {\n      next if \$_ eq 'WORK_PATH' ;\n      next if \$_ eq 'DEST_WORK_PATH' ;\n      my \$f = lc( \$_ ) ;\n      if ( \$f eq 'labels' ) {\n\x09 eval qq{\n\x09    sub \$f {\n\x09       my VCP::Rev \\\$self = shift ;\n\x09       if ( \\\@_ ) {\n\x09          \\\$self->{\$_} = {} ;\n\x09\x09  \\\@{\\\$self->{\$_}}{\\\@_} = (undef) x \\\@_ ;\n\x09       }\n\x09       return \\\$self->{\$_} ? sort keys \\%{\\\$self->{\$_}} : () ;\n\x09    }\n\x09 } ;\n      }\n      else {\n\x09 eval qq{\n\x09    sub \$f {\n\x09       my VCP::Rev \\\$self = shift ;\n\x09       confess "too many parameters passed" if \\\@_ > 1 ;\n\x09       \\\$self->{\$_} = shift if \\\@_ == 1 ;\n\x09       return \\\$self->{\$_} ;\n\x09    }\n\x09 } ;\n      }\n      die \$\@ if \$\@ ;\n   }\n}\n\n\n## We never, ever want to delete a file that has revs referring to it.\n## So, we put a cleanup object in %files_to_delete and manually manage a\n## reference count on it.  The hash is keyed on filename and contains\n## a count value.  When the count reaches 0, it is cleaned.  We add a warning\n## about undeleted files, which is a great PITA.  The reason there's a\n## warning is that we could be using gobs of disk space for temporary files\n## if there's some bug preventing VCP::Rev objects from being DESTROYed\n## soon enough.  It's a PITA because it means that the source and\n## destination object really must be dereferenced ASAP, so their SEEN\n## arrays get cleaned up, and every once in awhile I screw it up somehow.\nmy %files_to_delete ;\n\nEND {\n   if ( debugging && ! \$ENV{VCPNODELETE} ) {\n      for ( sort keys %files_to_delete ) {\n\x09 if ( -e \$_ ) {\n\x09    warn "\$_ not deleted" ;\n\x09 }\n      }\n   }\n}\n\n\n=item new\n\nCreates an instance, see subclasses for options.\n\n   my VCP::Rev \$rev = VCP::Rev->new(\n      name => 'foo',\n      time => \$commit_time,\n      ...\n   ) ;\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Rev \$self ;\n\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   while ( \@_ ) {\n      my \$key = shift ;\n      \$self->{uc(\$key)} = shift ;\n   }\n\n   if ( \$self->{LABELS} ) {\n      \$self->labels( \@{\$self->{LABELS}} ) if ref \$self->{LABELS} eq "ARRAY" ;\n   }\n   else {\n      \$self->{LABELS} = {} unless \$self->{LABELS} ;\n   }\n\n   return \$self ;\n}\n\n\n=item is_base_rev\n\nReturns TRUE if this is a base revision.  This is the case if no\naction is defined.  A base revision is a revision that is being\ntransferred merely to check it's contents against the destination\nrepository's contents.  It's usually a digest and the actual bosy\nof the revision is 'backfilled' from the destination repository and\nchecked against the digest.  This cuts down on transfer size, since\nthe full body of the file never need be sent with incremental updates.\n\nSee L<VCP::Dest/backfill> as well.\n\n=cut\n\nsub is_base_rev {\n   my VCP::Rev \$self = shift ;\n\n   return ! defined \$self->{ACTION} ;\n}\n\n\n=item base_revify\n\nConverts a "normal" rev in to a base rev.\n\n=cut\n\nsub base_revify {\n   my VCP::Rev \$self = shift ;\n\n   \$self->{\$_} = undef for qw(\n      P4_INFO\n      CVS_INFO\n      STATE\n      TIME\n      MOD_TIME\n      USER_ID\n      LABELS\n      COMMENT\n      ACTION\n   );\n}\n\n\n=item work_path, dest_work_path\n\nThese set/get the name of the working file for sources and destinations,\nrespectively.  These files are automatically cleaned up when all VCP::Rev\ninstances that refer to them are DESTROYED or have their work_path or\ndest_work_path set to other files or undef.\n\n=cut\n\nsub _set_work_path {\n   my VCP::Rev \$self = shift ;\n\n   my ( \$field, \$fn ) = \@_ ;\n   my \$doomed = \$self->{\$field} ;\n   if ( defined \$doomed\n      && \$files_to_delete{\$doomed}\n      && --\$files_to_delete{\$doomed} < 1\n      && -e \$doomed\n   ) {\n      if ( debugging \$self ) {\n         my \@details ;\n\x09 my \$i = 2 ;\n\x09 do { \@details = caller(2) } until \$details[0] ne __PACKAGE__ ;\n\x09 debug "vcp: \$self unlinking '\$doomed' in "\n\x09    . join( '|', \@details[0,1,2,3]) ;\n      }\n      unlink \$doomed or warn "\$! unlinking \$doomed\\n"\n         unless \$ENV{VCPNODELETE};\n   }\n\n   \$self->{\$field} = \$fn ;\n   ++\$files_to_delete{\$self->{\$field}} if defined \$self->{\$field} ;\n}\n\n\nsub work_path {\n   my VCP::Rev \$self = shift ;\n   confess "too many parameters passed" if \@_ > 1 ;\n   \$self->_set_work_path( 'WORK_PATH', \@_ ) if \@_ ;\n   return \$self->{WORK_PATH} ;\n}\n\n\nsub dest_work_path {\n   my VCP::Rev \$self = shift ;\n   confess "too many parameters passed" if \@_ > 1 ;\n   \$self->_set_work_path( 'DEST_WORK_PATH', \@_ ) if \@_ ;\n   return \$self->{DEST_WORK_PATH} ;\n}\n\n\n=item labels\n\n   \$r->labels( \@labels ) ;\n   \@labels = \$r->labels ;\n\nSets/gets labels associated with a revision.  If a label is applied multiple\ntimes, it will only be returned once.  This feature means that the automatic\nlabel generation code for r_... revision and ch_... change labels won't add\nadditional copies of labels that were already applied to this revision in the\nsource repository.\n\nReturns labels in an unpredictible order, which happens to be sorted for\nnow.  This sorting is purely for logging purposes and may disappear at\nany moment.\n\n=item add_label\n\n  \$r->add_label( \$label ) ;\n  \$r->add_label( \@labels ) ;\n\nMarks one or more labels as being associated with this revision of a file.\n\n=cut\n\nsub add_label {\n   my VCP::Rev \$self = shift ;\n   \@{\$self->{LABELS}}{\@_} = (undef) x \@_ ;\n   return ;\n}\n\n\nsub as_string {\n   my VCP::Rev \$self = shift ;\n\n   my \@v = map(\n      defined \$_ ? \$_ : "<undef>",\n      \$self->is_base_rev\n\x09 ? map \$self->\$_(), qw( name rev_id change_id type )\n\x09 : map(\n\x09    \$_ eq 'time' && defined \$self->\$_()\n                ? scalar localtime \$self->\$_()\n\x09    : \$_ eq 'comment' && defined \$self->\$_()\n                ? do {\n                   my \$c = \$self->\$_();\n                   \$c =~ s/\\n/\\\\n/g;\n                   \$c =~ s/\\r/\\\\r/g;\n                   \$c =~ s/\\t/\\\\t/g;\n                   \$c =~ s/\\l/\\\\l/g;\n                   \$c = substr( \$c, 0, 32 )\n                      if length( \$c ) > 32;\n                   \$c;\n                }\n                : \$self->\$_(),\n\x09    qw(name rev_id change_id type action time user_id comment )\n\x09 )\n   ) ;\n\n   return \$self->is_base_rev\n      ? sprintf( qq{%s#%s \@%s (%s) -- base rev --}, \@v )\n      : sprintf( qq{%s#%s \@%s (%s) %s %s %s "%s"}, \@v ) ;\n}\n\nsub DESTROY {\n   return if \$ENV{VCPNODELETE};\n   my VCP::Rev \$self = shift ;\n   \$self->work_path( undef ) ;\n   \$self->dest_work_path( undef ) ;\n   my \$doomed = \$self->work_path ;\n   if ( defined \$doomed && -e \$doomed ) {\n      debug "vcp: \$self unlinking '\$doomed'" if debugging \$self ;\n      unlink \$doomed or warn "\$! unlinking \$doomed\\n";\n   }\n}\n\n\n=back\n\n=head1 SUBCLASSING\n\nThis class uses the fields pragma, so you'll need to use base and \npossibly fields in any subclasses.\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACE
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACF, "lib/VCP/Source.pm" }
package VCP::Source ;\n\n=head1 NAME\n\nVCP::Source - A base class for repository sources\n\n=head1 SYNOPSIS\n\n=head1 DESCRIPTION\n\n=head1 EXTERNAL METHODS\n\n=over\n\n=cut\n\nuse strict ;\n\nuse Carp ;\nuse Regexp::Shellish qw( compile_shellish ) ;\nuse Time::Local qw( timelocal ) ;\nuse UNIVERSAL qw( isa ) ;\nuse VCP::Debug qw( :debug ) ;\n\nuse vars qw( \$VERSION \$debug ) ;\n\n\$VERSION = 0.1 ;\n\n\$debug = 0 ;\n\nuse base 'VCP::Plugin' ;\n\nuse fields (\n   'BOOTSTRAP_REGEXPS', ## Determines what files are in bootstrap mode.\n   'DEST',\n   'REVS',              ## A convenience for the child.\n) ;\n\n\n=item new\n\nCreates an instance, see subclasses for options.  The options passed are\nusually native command-line options for the underlying repository's\nclient.  These are usually parsed and, perhaps, checked for validity\nby calling the underlying command line.\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Source \$self = \$class->SUPER::new( \@_ ) ;\n\n   \$self->{BOOTSTRAP_REGEXPS} = [] ;\n   \$self->{REVS} = VCP::Revs->new ;\n\n   return \$self ;\n}\n\n\n###############################################################################\n\n=head1 SUBCLASSING\n\nThis class uses the fields pragma, so you'll need to use base and \npossibly fields in any subclasses.  See L<VCP::Plugin> for methods\noften needed in subclasses.\n\n=head2 Subclass utility API\n\n=over\n\n=item dest\n\nSets/Gets a reference to the VCP::Dest object.  The source uses this to\ncall handle_header(), handle_rev(), and handle_end() methods.\n\n=cut\n\nsub dest {\n   my VCP::Source \$self = shift ;\n\n   \$self->{DEST} = shift if \@_ ;\n   return \$self->{DEST} ;\n}\n\n=back\n\n=head1 SUBCLASS OVERLOADS\n\nThese methods should be overridded in any subclasses.\n\n=over\n\n=item dest_expected\n\nReturns TRUE if a destination is expected given the parameters passed\nto new().\n\nSome sources can have configuration options that cause side effects.\nThe only one that does this so far is the revml source, which can\noutput the RevML doctype as a .pm file.\n\n=cut\n\nsub dest_expected {\n   return 1 ;\n}\n\n\n=item copy\n\nREQUIRED OVERLOAD.\n\n   \$source->copy_revs() ;\n\nCalled by L<VCP/copy> to do the entire export process.  This is passed a\npartially filled-in header structure.\n\nThe subclass should call\n\n   \$self->dest->handle_rev( \$rev_meta ) ;\n\nThe subclass needs to make sure the \$rev_meta hash contains the metadata for\nthe file and a work_path that points to the work location of the\nfile:\n\n   \$rev_meta = VCP::Rev->new(\n      work_path  => '/tmp/revex/4/depot/perl/perl.c',\n      name       => 'depot/perl/perl.c',\n      rev_id     => '4',\n      change_id  => '22',\n      labels     => [ 'v0_003', 'v0_004' ],\n   ) ;\n\n=cut\n\nsub copy_revs {\n   my VCP::Source \$self = shift ;\n\n   confess "ERROR: copy_revs not overloaded by class '",\n      ref \$self, "'.  Oops.\\n" ;\n}\n\n\n=item handle_header\n\nREQUIRED OVERLOAD.\n\nSubclasses must add all repository-specific info to the \$header, at least\nincluding rep_type and rep_desc.\n\n   \$header->{rep_type} => 'p4',\n   \$self->p4( ['info'], \\\$header->{rep_desc} ) ;\n\nThe subclass must call the superclass method to pass the \$header on to\nthe dest:\n\n   \$self->SUPER::handle_header( \$header ) ;\n\n=cut\n\nsub handle_header {\n   my VCP::Source \$self = shift ;\n\n   my ( \$header ) = \@_ ;\n\n   confess "ERROR: copy not overloaded by class '", ref \$self, "'.  Oops.\\n"\n      if \$self->can( 'handle_header' ) eq \\&handle_header ;\n\n   \$self->dest->handle_header( \$header ) ;\n}\n\n\n=item handle_footer\n\nNot a required overload, as the footer carries no useful information at\nthis time.  Overriding methods must call this method to pass the\n\$footer on:\n\n   \$self->SUPER::handle_footer( \$footer ) ;\n\n=cut\n\nsub handle_footer {\n   my VCP::Source \$self = shift ;\n\n   my ( \$footer ) = \@_ ;\n\n   \$self->dest->handle_footer( \$footer ) ;\n}\n\n\n=item parse_time\n\n   \$time = \$self->parse_time( \$timestr ) ;\n\nParses "[cc]YY/MM/DD[ HH[:MM[:SS]]]".\n\nWill add ability to use format strings in future.\nHH, MM, and SS are assumed to be 0 if not present.\n\nReturns a time suitable for feeding to localtime or gmtime.\n\nAssumes local system time, so no good for parsing times in revml, but that's\nnot a common thing to need to do, so it's in VCP::Source::revml.pm.\n\n=cut\n\nsub parse_time {\n   my VCP::Source \$self = shift ;\n   my ( \$timestr ) = \@_ ;\n\n   ## TODO: Get parser context here & give file, line, and column. filename\n   ## and rev, while we're scheduling more work for the future.\n   confess "Malformed time value \$timestr\\n"\n      unless \$timestr =~ /^(\\d\\d)?\\d?\\d(\\D\\d?\\d){2,5}/ ;\n   my \@f = split( /\\D/, \$timestr ) ;\n   --\$f[1] ; # Month of year needs to be 0..11\n   push \@f, ( 0 ) x ( 6 - \@f ) ;\n   return timelocal( reverse \@f ) ;\n}\n\n\n=item revs\n\n   \$self->revs( VCP::Revs->new ) ;\n   \$self->revs->add( \$r ) ; # Many times\n   \$self->dest->sort_revs( \$self->revs ) ;\n   my VCP::Rev \$r ;\n   while ( \$r = \$self->revs->pop ) {\n      ## ...checkout the source reve & set \$r->work_path() to refer to it's loc.\n      \$self->dest->handle_rev( \$r ) ;\n   }\n\nSets/gets the revisions member.  This is used by most sources to accumulate\nthe set of revisions to be copied.\n\nThis member should be set by the child in copy_revs().  It should then be\npassed to the destination\n\n=cut\n\nsub revs {\n   my VCP::Source \$self = shift ;\n\n   \$self->{REVS} = \$_[0] if \@_ ;\n   return \$self->{REVS} ;\n}\n\n\n=item bootstrap\n\nUsually called from within call to GetOptions in subclass' new():\n\n   GetOptions(\n      'b|bootstrap:s'   => sub {\n\x09 my ( \$name, \$val ) = \@_ ;\n\x09 \$self->bootstrap( \$val ) ;\n      },\n      'r|rev-root'      => \\\$rev_root,\n      ) or \$self->usage_and_exit ;\n\nCan be called plain:\n\n   \$self->bootstrap( \$bootstrap_spec ) ;\n\nSee the command line documentation for the format of \$bootstrap_spec.\n\nReturns nothing useful, but L</bootstrap_regexps> does.\n\n=cut\n\nsub bootstrap {\n   my VCP::Source \$self = shift ;\n   my ( \$val ) = \@_ ;\n   \$self->{BOOTSTRAP_REGEXPS} = \$val eq ''\n      ? [ compile_shellish( '**' ) ]\n      : [ map compile_shellish( \$_ ), split /,+/, \$val ] ;\n\n   return ;\n}\n\n\n#=item bootstrap_regexps\n#\n#   \$self->bootstrap_regexps( \$re1, \$re1, ... ) ;\n#   \$self->bootstrap_regexps( undef ) ; ## clears the list\n#   \@res = \$self->bootstrap_regexps ;\n#\n#Sets/gets the list of regular expressions defining what files are in bootstrap\n#mode.  This is usually set by L</bootstrap>, though.\n#\n#=cut\n#\n#sub bootstrap_regexps {\n#   my VCP::Source \$self = shift ;\n#   \$self->{BOOTSTRAP_REGEXPS} = [ \@_ == 1 && ! defined \$_[0] ? () : \@_ ]\n#      if \@_ ;\n#   return \@{\$self->{BOOTSTRAP_REGEXPS}} ;\n#}\n#\n=item is_bootstrap_mode\n\n   ... if \$self->is_bootstrap_mode( \$file ) ;\n\nCompares the filename passed in against the list of bootstrap regular\nexpressions set by L</bootstrap>.\n\nThe file should be in a format similar to the command line spec for\nwhatever repository is passed in, and not relative to rev_root, so\n"//depot/foo/bar" for p4, or "module/foo/bar" for cvs.\n\nThis is typically called in the subbase class only after looking at the\nrevision number to see if it's a first revision (in which case the\nsubclass should automatically put it in bootstrap mode).\n\n=cut\n\nsub is_bootstrap_mode {\n   my VCP::Source \$self = shift ;\n   my ( \$file ) = \@_ ;\n\n   my \$result = grep \$file =~ \$_, \@{\$self->{BOOTSTRAP_REGEXPS}} ;\n\n   debug (\n      "vcp: \$file ",\n      ( \$result ? "=~ " : "!~ " ),\n      "[ ", join( ', ', map "qr/\$_/", \@{\$self->{BOOTSTRAP_REGEXPS}} ), " ] (",\n      ( \$result ? "not in " : "in " ),\n      "bootstrap mode)"\n   ) if debugging \$self ;\n\n   return \$result ;\n}\n\n=back\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACF
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACG, "lib/VCP/Source/vss.pm" }
package VCP::Source::vss ;\n\n=head1 NAME\n\nVCP::Source::vss - A VSS repository source\n\n=head1 SYNOPSIS\n\n   vcp vss:project/...\n\n=head1 DESCRIPTION\n\nSource driver enabling L<C<vcp>|vcp> to extract versions form a vss\nrepository.\n\nThe source specification for VSS looks like:\n\n    vss:filespec [<options>]\n\nC<filespec> may contain trailing wildcards, like C</a/b/...> to extract\nan entire directory tree (this is the normal case).\n\nNOTE: This does not support incremental exports, see LIMITATIONS.\n\n=head1 OPTIONS\n\n=over\n\n=item -b, --bootstrap\n\n   -b ...\n   --bootstrap=...\n   -b file1[,file2[, etc.]]\n   --bootstrap=file1[,file2[, etc. ]]\n\n(the C<...> there is three periods, a\nL<Regexp::Shellish|Regexp::Shellish> wildcard borrowed from C<p4>\npath syntax).\n\nForces bootstrap mode for an entire export (C<-b ...>) or for certain\nfiles.  Filenames may contain wildcards, see L<Regexp::Shellish> for\ndetails on what wildcards are accepted.\n\nControls how the first revision of a file is exported.  A bootstrap\nexport contains the entire contents of the first revision in the\nrevision range.  This should only be necessary when exporting for the\nfirst time.\n\nAn incremental export contains a digest of the revision preceding the\nfirst revision in the revision range, followed by a delta record between\nthat revision and the first revision in the range.  This allows the\ndestination import function to make sure that the incremental export\nbegins where the last export left off.\n\nThe default is decided on a per-file basis: if the first revision in the\nrange is revision #.1, the full contents are exported.  Otherwise an\nincremental export is done for that file.\n\nThis option is necessary when exporting only more recent revisions from\na repository.\n\n=item --cd\n\nUsed to set the VSS working directory.  VCP::Source::vss will cd to this\ndirectory before calling vss, and won't initialize a VSS workspace of\nit's own (normally, VCP::Source::vss does a "vss checkout" in a\ntemporary directory).\n\nThis is an advanced option that allows you to use a VSS workspace you\nestablish instead of letting vcp create one in a temporary directory\nsomewhere.  This is useful if you want to read from a VSS branch or if\nyou want to delete some files or subdirectories in the workspace.\n\nIf this option is a relative directory, then it is treated as relative\nto the current directory.\n\n=item --rev-root\n\nB<Experimental>.\n\nFalsifies the root of the source tree being extracted; files will\nappear to have been extracted from some place else in the hierarchy.\nThis can be useful when exporting RevML, the RevML file can be made\nto insert the files in to a different place in the eventual destination\nrepository than they existed in the source repository.\n\nThe default C<rev-root> is the file spec up to the first path segment\n(directory name) containing a wildcard, so\n\n   vss:/a/b/c...\n\nwould have a rev-root of C</a/b>.\n\nIn direct repository-to-repository transfers, this option should not be\nnecessary, the destination filespec overrides it.\n\n=cut\n\n#=item -V\n#\n#   -V 5\n#   -V 5~3\n#\n#Passed to C<ss History>.\n\n=back\n\n=head2 Files that aren't tagged\n\nVSS has one peculiarity that this driver works around.\n\nIf a file does not contain the tag(s) used to select the source files,\nC<vss log> outputs the entire life history of that file.  We don't want\nto capture the entire history of such files, so L<VCP::Source::vss> goes\nignores any revisions before and after the oldest and newest tagged file\nin the range.\n\n=head1 LIMITATIONS\n\n   "What we have here is a failure to communicate!"\n       - The warden in Cool Hand Luke\n\nVSS does not try to protect itself from people checking in things that\nlook like snippets of VSS log file: they come out exactly like they\nwent in, confusing the log file parser.\n\nSo, if a repository contains messages in the log file that look like the \noutput from some other "vss log" command, things will likely go awry.\n\nAt least one vss repository out there has multiple revisions of a single file\nwith the same rev number.  The second and later revisions with the same rev\nnumber are ignored with a warning like "Can't add same revision twice:...".\n\n=cut\n\n\$VERSION = 1.2 ;\n\n# Removed docs for -f, since I now think it's overcomplicating things...\n#Without a -f This will normally only replicate files which are tagged.  This\n#means that files that have been added since, or which are missing the tag for\n#some reason, are ignored.\n#\n#Use the L</-f> option to force files that don't contain the tag to be\n#=item -f\n#\n#This option causes vcp to attempt to export files that don't contain a\n#particular tag but which occur in the date range spanned by the revisions\n#specified with -r. The typical use is to get all files from a certain\n#tag to now.\n#\n#It does this by exporting all revisions of files between the oldest and\n#newest files that the -r specified.  Without C<-f>, these would\n#be ignored.\n#\n#It is an error to specify C<-f> without C<-r>.\n#\n#exported.\n\nuse strict ;\n\nuse Carp ;\nuse Getopt::Long ;\nuse File::Basename;\nuse Regexp::Shellish qw( :all ) ;\nuse VCP::Rev ;\nuse VCP::Debug ':debug' ;\nuse VCP::Source ;\nuse VCP::Utils::vss ;\n\nuse base qw( VCP::Source VCP::Utils::vss ) ;\nuse fields (\n   'VSS_CUR',            ## The current change number being processed\n   'VSS_BOOTSTRAP',      ## Forces bootstrap mode\n   'VSS_IS_INCREMENTAL', ## Hash of filenames, 0->bootstrap, 1->incremental\n   'VSS_INFO',           ## Results of the 'vss --version' command and VSSROOT\n   'VSS_LABEL_CACHE',    ## ->{\$name}->{\$rev} is a list of labels for that rev\n   'VSS_LABELS',         ## Array of labels from 'p4 labels'\n   'VSS_MAX',            ## The last change number needed\n   'VSS_MIN',            ## The first change number needed\n   'VSS_VER_SPEC',       ## The revision spec to pass to `ss History`\n\n   'VSS_NAME_REP_NAME',  ## A mapping of names to repository names\n\n   'VSS_K_OPTION',       ## Which of the VSS/RCS "-k" options to use, if any\n\n   'VSS_LOG_CARRYOVER',  ## The unparsed bit of the history file\n   'VSS_LOG_STATE',      ## Parser state machine state\n   'VSS_LOG_REV',        ## The revision being parsed (a hash)\n\n   'VSS_NEEDS_BASE_REV', ## What base revisions are needed.  Base revs are\n                         ## needed for incremental (ie non-bootstrap) updates,\n\x09\x09\x09 ## which is decided on a per-file basis by looking\n\x09\x09\x09 ## at VCP::Source::is_bootstrap_mode( \$file ) and\n\x09\x09\x09 ## the file's rev number (ie does it end in .1).\n   'VSS_HIGHEST_VERSION',  ## A HASH keyed on filename that contains the\n                         ## last rev_id seen for a file.  This allows\n                         ## file deletions (which aren't tracked by\n                         ## VSS in a file's history) to be given a\n                         ## pretend revision number.\n   'VSS_REV_ID_OFFSET',  ## After a busy day processing a deleted file,\n                         ## it's time to relax and process the not-deleted\n                         ## file of the same name.  In order to keep\n                         ## from reusing the same version numbers for\n                         ## the not-deleted file, this variable contains\n                         ## an offset to add to the revisions.  It's the\n                         ## value of VSS_HIGHEST_VERSION reached while\n                         ## reading the deleted file.\n\n   'VSS_FILES',          ## Managed by VSS::Utils::vss\n   'VSS_LOG_LAZY_COMMIT_PENDING',  ## Multiple VSS revisions get compressed\n                               ## in to a single VCP revision.  This\n                               ## flag is set when a revision is parsed\n                               ## that is not immediately converted in\n                               ## to a VCP::Rev; right now this applies\n                               ## to "Labeled" revisions because we\n                               ## accumulate labels in to one\n                               ## VCP::Rev.\n   'VSS_LOG_PRELIM_FIELDS',  ## When reading ahead to see if the current\n                         ## pending lazy commit needs to be committed,\n                         ## accumulated data is held here.\n   'VSS_LOG_OLDEST_VERSION',    ## The oldest rev parsed for this file.\n) ;\n\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Source::vss \$self = \$class->SUPER::new( \@_ ) ;\n\n   ## Parse the options\n   my ( \$spec, \$options ) = \@_ ;\n\n   ## Make it look like a Unix path.\n   \$spec =~ s{^\\\$//}{};\n   \$spec =~ s{\\\$}{}g;\n   \$spec =~ s{\\\\}{/}g;\n\n   \$self->parse_repo_spec( \$spec ) ;\n\n   my \$work_dir ;\n   my \$rev_root ;\n   my \$ver_spec ;\n\n   GetOptions(\n      "b|bootstrap:s"   => sub {\n\x09 my ( \$name, \$val ) = \@_ ;\n\x09 \$self->{VSS_BOOTSTRAP} = \$val eq ""\n\x09    ? [ compile_shellish( "..." ) ]\n\x09    : [ map compile_shellish( \$_ ), split /,+/, \$val ] ;\n      },\n      "cd=s"          => \\\$work_dir,\n      "rev-root=s"    => \\\$rev_root,\n      "V=s"           => sub { \$ver_spec = "-V\$_[1]" },\n      "k=s"           => sub { warn \$self->{VSS_K_OPTION} = \$_[1] } ,\n      "kb"            => sub { warn \$self->{VSS_K_OPTION} = "b" } ,\n   ) or \$self->usage_and_exit ;\n\n   \$self->{VSS_VER_SPEC} = \$ver_spec;\n\n   my \$files = \$self->repo_filespec ;\n   unless ( defined \$rev_root ) {\n      \$self->deduce_rev_root( \$files ) ;\n   }\n#   else {\n#      \$files = "\$rev_root/\$files" ;\n#   }\n#\n### TODO: Figure out whether we should make rev_root merely set the rev_root\n### in the header.  I think we probably should do it that way, as it's more\n### flexible and less confusing.\n\n   ## Don't normalize the filespec.\n   \$self->repo_filespec( \$files ) ;\n\n   unless ( defined \$work_dir ) {\n      \$self->create_vss_workspace ;\n   }\n   else {\n      \$self->work_root( File::Spec->rel2abs( \$work_dir ) ) ; \n      \$self->command_chdir( \$self->work_path ) ;\n   }\n\n   ## May need to run again with -D to list deleted files\n   ## This generates the list of all files we want to scan\n   \$self->get_vss_file_list(\n      \$self->repo_filespec,\n   );\n\n   {\n      my ( \$out, \$err );\n      ## Dirty trick: send a known bad parm *just* to get ss.exe to\n      ## print it's banner without popping open a help screen.\n      \$self->ss( [ "help", "/illegal arg" ], ">", \\\$out, "2>", \\\$err );\n      \$self->{VSS_INFO} = \$out;\n   }\n\n   return \$self ;\n}\n\n\nsub is_incremental {\n   my VCP::Source::vss \$self= shift ;\n   my ( \$file, \$first_rev ) = \@_ ;\n\n   \$first_rev =~ s/\\.\\d+//;  ## Trim down <delete /> rev_ids\n\n   my \$bootstrap_mode = \$first_rev <= "1"\n      || ( \$self->{VSS_BOOTSTRAP}\n         && grep \$file =~ \$_, \@{\$self->{VSS_BOOTSTRAP}}\n      ) ;\n\n   return \$bootstrap_mode ? 0 : "incremental" ;\n}\n\n\nsub denormalize_name {\n   my VCP::Source::vss \$self = shift ;\n   return '/' . \$self->SUPER::denormalize_name( \@_ ) ;\n}\n\n\nsub handle_header {\n   my VCP::Source::vss \$self = shift ;\n   my ( \$header ) = \@_ ;\n\n   \$header->{rep_type} = 'vss' ;\n   \$header->{rep_desc} = \$self->{VSS_INFO} ;\n   \$header->{rev_root} = \$self->rev_root ;\n\n   \$self->dest->handle_header( \$header ) ;\n   return ;\n}\n\n\nsub get_rev {\n   my VCP::Source::vss \$self = shift ;\n\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\n   my \$wp = \$self->work_path( "revs", \$r->name, \$r->rev_id ) ;\n   \$r->work_path( \$wp ) ;\n   \$self->mkpdir( \$wp ) ;\n\n   my ( \$fn, \$dir ) = fileparse( \$wp );\n\n   my \$ignored_stdout;\n\nconfess "Shouldn't be get_rev()ing a rev with no rev_id" unless defined \$r->rev_id;\n\n   if ( \$self->vss_file_is_deleted( \$r->source_name ) ) {\n      my \$rev_id = \$r->rev_id;\n      \$rev_id -= \$self->{VSS_REV_ID_OFFSET}->{\$r->source_name}\n         if \$rev_id > \$self->{VSS_REV_ID_OFFSET}->{\$r->source_name};\n      \$self->_swap_in_deleted_file_and(\n         \$r->source_name,\n         "ss",\n         [ "Get",\n            "\\\$/" . \$r->source_name,\n            "-V"  . \$rev_id,\n            "-GL" . \$dir,\n            "-GN",   ## Newlines only, please\n         ],\n         ">", \\\$ignored_stdout\n      ) ;\n   }\n   else {\n      \$self->ss(\n         [ "Get",\n            "\\\$/" . \$r->source_name,\n            "-V"  . \$r->rev_id,\n            "-GL" . \$dir,\n            "-GN",   ## Newlines only, please\n         ],\n         ">", \\\$ignored_stdout\n      );\n   }\n\n   my \$temp_fn = fileparse( \$r->source_name );\n\n   rename "\$dir/\$temp_fn", "\$dir/\$fn" or die "\$! renaming \$temp_fn to \$fn\\n";\n}\n\n\n## History report Parser states\n## The code below does things like grep for "commit" and "skip to next"\n## in these strings.  Plus, they make debug output easier to read.\nuse constant SKIP_TO_NEXT                    => "skip to next";\nuse constant SKIP_TO_NEXT_COMMIT_AT_END      => "skip to next and commit at end";\nuse constant ENTRY_START                     => "entry start";\nuse constant READ_ACTION                     => "read action";\nuse constant READ_COMMENT_AND_COMMIT         => "read comment and commit";\nuse constant READ_REST_OF_COMMENT_AND_COMMIT => "read rest of comment and commit";\n\nsub _reset_log_parser {\n   my VCP::Source::vss \$self = shift ;\n   \$self->{VSS_LOG_STATE} = SKIP_TO_NEXT;\n   \$self->{VSS_LOG_CARRYOVER} = '' ;\n   \$self->{VSS_LOG_REV} = {} ;\n   \$self->{VSS_LOG_OLDEST_VERSION} = undef ;\n   \$self->{VSS_LOG_LAZY_COMMIT_PENDING} = 0;\n   \$self->{VSS_LOG_PRELIM_FIELDS} = {};\n\n}\n\nsub _get_file_metadata {\n   my VCP::Source::vss \$self = shift ;\n   my ( \$filename ) = \@_;\n\n   my \$ss_fn = "\\\$/\$filename";\n\n   my \$filetype;\n\n   \$self->ss( [ "FileType", \$ss_fn ], ">", \\\$filetype );\n\n   \$filetype =~ s/\\A.*\\s(\\S+)\\r?\\n.*/\$1/ms\n      or die "Can't parse filetype from '\$filetype'";\n   \$filetype = lc \$filetype;\n\n   my \$tmp_f;\n   my \$result = 1;\n   if ( defined \$self->{VSS_VER_SPEC} ) {\n      \$tmp_f = \$self->command_stderr_filter;\n      \$self->command_stderr_filter(\n         sub {\n            my ( \$err_text_ref ) = \@_ ;\n            \$\$err_text_ref =~ s{^Version not found\\r?\\n\\r?}[\n               \$result = 0;\n               '' ;\n            ]mei ;\n         }\n      );\n   }\n\n   \$self->_reset_log_parser;\n   \$self->ss( [\n         "History",\n         "\\\$/\$filename",\n         defined \$self->{VSS_VER_SPEC}\n             ? \$self->{VSS_VER_SPEC}\n             : (),\n      ],\n      '>', sub { \$self->parse_log_file( \$filename, \$filetype, \@_ ) },\n   ) ;\n\n   ## Keep scanning until we get the actual checkin, so we get\n   ## any intervening labels and the correct metadata for the\n   ## checkin. A LAZY_COMMIT_PENDING means that the History\n   ## output did not end on a checkin, it ended on a label or\n   ## something.\n   if ( defined \$self->{VSS_LOG_OLDEST_VERSION} ) {\n      if ( substr( \$self->{VSS_LOG_STATE}, -6 ) eq "commit" ) {\n         \$self->add_rev_from_log_parser;\n         \$self->{VSS_LOG_STATE} = SKIP_TO_NEXT;\n      }\n\n      my \$oldest = \$self->{VSS_LOG_OLDEST_VERSION};\n      if ( \$self->{VSS_LOG_LAZY_COMMIT_PENDING} ) {\n         debug "vcp: scanning back to checkin"\n            if debugging \$self;\n         die "Must be in SKIP_TO_NEXT... not \$self->{VSS_LOG_STATE}"\n            unless 0 == index \$self->{VSS_LOG_STATE}, SKIP_TO_NEXT;\n         \$self->_find_checkin( \$filename, \$filetype, \$oldest );\n\n         if ( substr( \$self->{VSS_LOG_STATE}, -6 ) eq "commit" ) {\n            \$self->add_rev_from_log_parser;\n            \$self->{VSS_LOG_STATE} = SKIP_TO_NEXT;\n         }\n         \$oldest = \$self->{VSS_LOG_OLDEST_VERSION};\n      }\n\n      if ( \$self->is_incremental( \$filename, \$oldest ) ) {\n         debug "vcp: scanning back to base rev"\n            if debugging \$self;\n         ## Skip the banner\n         \$self->{VSS_LOG_STATE} = SKIP_TO_NEXT;\n         \$self->_find_checkin( \$filename, \$filetype, \$oldest );\n         if ( substr( \$self->{VSS_LOG_STATE}, -6 ) eq "commit" ) {\n            \$self->add_rev_from_log_parser;\n            \$self->{VSS_LOG_STATE} = SKIP_TO_NEXT;\n         }\n         \$self->revs->as_array_ref->[-1]->base_revify;\n      }\n   }\n   \$self->parse_log_file( \$filename, \$filetype, undef );\n\n   \$self->command_stderr_filter( \$tmp_f )\n      if defined \$self->{VSS_VER_SPEC};\n\n   return \$result;\n}\n\n\nsub _swap_in_deleted_file_and {\n   my VCP::Source::vss \$self = shift ;\n   my ( \$filename, \$method, \@args ) = \@_;\n\n   my \$ss_fn = "\\\$/\$filename";\n\n   my \$ignored_stdout;\n\n   my \$renamed_active;\n   if ( \$self->vss_file_is_active( \$filename ) ) {\n      my \$i = "";\n      while (1) {\n         \$renamed_active = "\$ss_fn.vcp_bak\$i";\n         last unless \$self->vss_file( \$renamed_active );\n         \$i ||= 0;\n         ++\$i;\n      }\n      \$self->ss( [ "Rename", \$ss_fn, \$renamed_active ] );\n   }\n\n   my \$result;\n\n   my \$ok = eval {\n##TODO: not ignore this output!\n      \$self->ss( [ "Recover", \$ss_fn ], ">", \\\$ignored_stdout ) ;\n\n      my \$ok = eval { \$result = \$self->\$method( \@args ); 1 };\n\n      my \$x = \$\@;\n      \$self->{VSS_REV_ID_OFFSET}->{\$filename} =\n          \$self->{VSS_HIGHEST_VERSION}->{\$filename} || 0;\n      \$ok = eval {\n##TODO: not ignore this output!\n         \$self->ss( [ "Delete", \$ss_fn ], ">", \\\$ignored_stdout ) ;\n         1;\n      } && \$ok;\n      \$x = "" unless defined \$x;\n      die \$x.\$\@ unless \$ok;\n   };\n\n\n   my \$x = \$\@;\n\n   if ( defined \$renamed_active ) {\n      my \$myok = eval {\n         \$self->ss( [ "Rename", \$renamed_active, \$ss_fn ] );\n         1;\n      };\n      if ( ! \$myok ) {\n         \$x .= \$\@;\n         \$ok = 0;\n      };\n   }\n\n   die \$x unless \$ok;\n\n   return \$result;\n}\n\n\nsub copy_revs {\n   my VCP::Source::vss \$self = shift ;\n\n   ## Get a list of all files we need to worry about\n   \$self->get_vss_file_list( \$self->repo_filespec );\n\n   \$self->revs( VCP::Revs->new ) ;\n\n   for my \$filename ( \$self->vss_files ) {\n      \$self->{VSS_REV_ID_OFFSET}->{\$filename} = 0;\n\n      my \$found_deleted;\n      if ( \$self->vss_file_is_deleted( \$filename ) ) {\n         \$found_deleted = \$self->_swap_in_deleted_file_and(\n            \$filename, "_get_file_metadata", \$filename\n         );\n\n         my VCP::Rev \$r = VCP::Rev->new(\n            source_name => \$filename,\n            name        => \$self->normalize_name( \$filename ),\n            action      => "delete",\n            ## Make up a fictional rev number that will allow the\n            ## receiver's sort algorithm to put this delete in the\n            ## right place and that will be documented in the\n            ## receiving repository as a label.\n            rev_id      => "\$self->{VSS_REV_ID_OFFSET}->{\$filename}.1",\n            ## Deletes are not logged, no user data, time, etc.\n         ) ;\n\n         \$self->revs->add( \$r );\n      }\n\n      my \$found_active;\n      if ( \$self->vss_file_is_active( \$filename ) ) {\n         my \$tmp_ver_spec;\n         if ( \$found_deleted ) {\n            ## If we happen to have been looking for a label and it was\n            ## found in the deleted version, then make sure we get all\n            ## the revs from the active file.\n            \$tmp_ver_spec = \$self->{VSS_VER_SPEC};\n            \$self->{VSS_VER_SPEC} = undef;\n         }\n\n         \$found_active = \$self->_get_file_metadata( \$filename );\n\n         \$self->{VSS_VER_SPEC} = \$tmp_ver_spec\n            if \$found_deleted;\n      }\n\n      if ( defined \$self->{VSS_VER_SPEC}\n         && ! ( \$found_deleted || \$found_active )\n      ) {\n         warn "vcp: \$self->{VSS_VER_SPEC} did not match any revisions of \$filename, not transferring\\n";\n      }\n      \n      if ( keys %{\$self->{VSS_LOG_REV}} ) {\n         require Data::Dumper;\n         die "Data left over in VSS_LOG_REV, state \$self->{VSS_LOG_STATE}:\\n",\n         Data::Dumper::Dumper(\n            \$self->{VSS_LOG_REV}\n         );\n      }\n   }\n\n   \$self->dest->sort_revs( \$self->revs ) ;\n\n   my VCP::Rev \$r ;\n   while ( \$r = \$self->revs->shift ) {\n      \$self->get_rev( \$r ) if ! \$r->action || \$r->action ne "delete";\n      \$self->dest->handle_rev( \$r ) ;\n   }\n}\n\n\n# Here's a typical history\n#\n###############################################################################\n##D:\\src\\vcp>ss history\n#History of \$/90vss.t ...\n#\n#*****************  Version 9   *****************\n#User: Admin        Date:  3/05/02   Time:  9:32\n#readd recovered\n#\n#*****  a_big_file  *****\n#Version 3\n#User: Admin        Date:  3/05/02   Time:  9:32\n#Checked in \$/90vss.t\n#Comment: comment 3\n#\n#\n#*****  binary  *****\n#Version 3\n#User: Admin        Date:  3/05/02   Time:  9:32\n#Checked in \$/90vss.t\n#Comment: comment 3\n#\n#\n#*****************  Version 8   *****************\n#User: Admin        Date:  3/05/02   Time:  9:32\n#readd deleted\n#\n#*****  binary  *****\n#Version 2\n#User: Admin        Date:  3/05/02   Time:  9:32\n#Checked in \$/90vss.t\n#Comment: comment 2\n#\n#\n#*****************  Version 7   *****************\n#User: Admin        Date:  3/05/02   Time:  9:32\n#readd added\n#\n#*****  a_big_file  *****\n#Version 2\n#User: Admin        Date:  3/05/02   Time:  9:32\n#Checked in \$/90vss.t\n#Comment: comment 2\n#\n#\n#*****************  Version 6   *****************\n#User: Admin        Date:  3/05/02   Time:  9:32\n#\$del added\n#\n#*****************  Version 5   *****************\n#User: Admin        Date:  3/05/02   Time:  9:32\n#binary added\n#\n#*****************  Version 4   *****************\n#User: Admin        Date:  3/05/02   Time:  9:31\n#\$add added\n#\n#*****************  Version 3   *****************\n#User: Admin        Date:  3/05/02   Time:  9:31\n#a_big_file added\n#\n#*****************  Version 2   *****************\n#User: Admin        Date:  3/05/02   Time:  9:31\n#\$a added\n#\n#*****************  Version 1   *****************\n#User: Admin        Date:  3/05/02   Time:  9:31\n#Created\n#\n#\n#D:\\src\\vcp>ss dir /r\n#\$/90vss.t:\n#\$a\n#\$add\n#\$del\n#a_big_file\n#binary\n#readd\n#\n#\$/90vss.t/a:\n#\$deeply\n#\n#\$/90vss.t/a/deeply:\n#\$buried\n#\n#\$/90vss.t/a/deeply/buried:\n#file\n#\n#\$/90vss.t/add:\n#f1\n#f2\n#f3\n#\n#\$/90vss.t/del:\n#f4\n#\n#13 item(s)\n#\n#D:\\src\\vcp>\n#\n###############################################################################\n\n\nsub _is_rev_a_checkin {\n   my ( \$self, \$fn, \$filetype, \$rev_id ) = \@_;\n\n   \$rev_id -= \$self->{VSS_REV_ID_OFFSET}->{\$fn}\n      if \$rev_id > \$self->{VSS_REV_ID_OFFSET}->{\$fn};\n\n   \$self->ss(\n      [ "History", "\\\$/\$fn", "-V\$rev_id", "-#1" ],\n      ">", \\my \$history\n   );\n\n   \$self->parse_log_file( \$fn, \$filetype, \$history );\n\n   ## Note: similar regexp in parse_log_file\n   return \$history =~ /^(Checked in .*|Created|.* recovered)\$/m ? 1 : 0;\n}\n\n\nsub _find_checkin {\n   my \$self = shift;\n   my ( \$fn, \$filetype, \$rev_id ) = \@_;\n\n   \$rev_id =~ s/\\.\\d+//;  # ignore faked-up revs.\n   return if \$rev_id <= 1;\n\n   while ( --\$rev_id ) {\n      warn \$fn, " ", \$rev_id, " ", \$self->{VSS_REV_ID_OFFSET}->{\$fn};\n      if ( \$rev_id <= \$self->{VSS_REV_ID_OFFSET}->{\$fn} ) {\n         last if \$self->_swap_in_deleted_file_and(\n            \$fn,\n            "_is_rev_a_checkin",\n            \$fn,\n            \$filetype,\n            \$rev_id\n         );\n      }\n      else {\n         last if \$self->_is_rev_a_checkin( \$fn, \$filetype, \$rev_id );\n      }\n   }\n}\n\n\nsub parse_log_file {\n   my ( \$self, \$filename, \$filetype, \$input ) = \@_ ;\n\n   if ( defined \$input ) {\n      \$self->{VSS_LOG_CARRYOVER} .= \$input ;\n   }\n   else {\n      ## Last call...\n      ## There can only be leftovers if they don't end in a "\\n".  I've never\n      ## seen that happen, but given large comments, I could be surprised...\n      \$self->{VSS_LOG_CARRYOVER} .= "\\n" if length \$self->{VSS_LOG_CARRYOVER} ;\n   }\n\n   my \$p = \$self->{VSS_LOG_REV};\n\n   local \$_ ;\n\n   ## DOS, Unix, Mac lineends spoken here.\n   while ( \$self->{VSS_LOG_CARRYOVER} =~ s/^(.*(?:\\r\\n|\\n\\r|\\n))// ) {\n      \$_ = \$1 ;\n      if ( debugging \$self ) {\n         my \$foo = \$1;\n         chomp \$foo;\n         debug "[\$foo]     \$self->{VSS_LOG_STATE}\\n";\n      }\n\n      ## This is crude, but effective: it sets the values every time\n      \$p->{Name} = \$filename;\n      \$p->{Type} = \$filetype;\n\n      if ( /^\\*{17}  Version (\\d+) +\\*{17}/ ) {\n         \$self->add_rev_from_log_parser\n            if substr( \$self->{VSS_LOG_STATE}, -6 ) eq "commit";\n         \$self->{VSS_LOG_STATE} = ENTRY_START;\n\n         ## This will overwrite the newer/higher version number\n         ## with the lower/older one until we reach the check-in\n         ## we want\n         \$self->{VSS_LOG_OLDEST_VERSION} = \$p->{Version} = \$1;\n         next;\n      }\n\n      if ( /^\\*{5}\\s+(.*?)\\s+\\*{5}\$/ ) {\n         \$self->add_rev_from_log_parser\n            if substr( \$self->{VSS_LOG_STATE}, -6 ) eq "commit";\n         \$self->{VSS_LOG_STATE} = ENTRY_START;\n         \$p->{_banner_name} = \$1;\n         next;\n      }\n\n      next if 0 == index \$self->{VSS_LOG_STATE}, SKIP_TO_NEXT;\n\n      if ( \$self->{VSS_LOG_STATE} eq ENTRY_START ) {\n         if ( /^Label:\\s*"([^"]+)"/ ) {\n            ## Unshift because we're reading from newest to oldest yet\n            ## we want oldest first so vss->vss is relatively consistent\n            unshift \@{\$p->{Labels}}, \$1;\n            next;\n         }\n         if ( /^User:\\s+(.*?)\\s+Date:\\s+(.*?)\\s+Time:\\s+(\\S+)/ ) {\n            \$self->{VSS_LOG_PRELIM_FIELDS}->{User} = \$1;\n            \$self->{VSS_LOG_PRELIM_FIELDS}->{Date} = \$2;\n            \$self->{VSS_LOG_PRELIM_FIELDS}->{Time} = \$3;\n            \$self->{VSS_LOG_STATE} = READ_ACTION;\n            next;\n         }\n      }\n\n      if ( \$self->{VSS_LOG_STATE} eq READ_ACTION ) {\n         if ( /Labeled/ ) {\n            ## It's a label-add only, ignore the rest.\n            ## for incremental exports, we'll need to commit at the\n            ## end of the log if the last thing was a "Labeled"\n            ## version.  We don't want to commit after each "Labeled"\n            ## because we want to aggregate labels.\n            \$self->{VSS_LOG_STATE} = SKIP_TO_NEXT_COMMIT_AT_END;\n            \$p->{Action} = "edit";\n            \$p->{\$_} = delete \$self->{VSS_LOG_PRELIM_FIELDS}->{\$_}\n               for keys %{\$self->{VSS_LOG_PRELIM_FIELDS}};\n            \$self->{VSS_LOG_LAZY_COMMIT_PENDING} = 1;\n            next;\n         }\n\n         ## Note: similar regexp in is_rev_a_checkin\n         if ( /^(Checked in .*|Created|.* recovered)\$/ ) {\n            \$self->{VSS_LOG_STATE} = READ_COMMENT_AND_COMMIT;\n            \$p->{\$_} = delete \$self->{VSS_LOG_PRELIM_FIELDS}->{\$_}\n               for keys %{\$self->{VSS_LOG_PRELIM_FIELDS}};\n            \$p->{Action} = "edit";\n            next;\n         }\n      }\n\n      if ( \$self->{VSS_LOG_STATE} eq READ_COMMENT_AND_COMMIT ) {\n         if ( s/Comment: // ) {\n            \$p->{Comment} = \$_;\n            \$self->{VSS_LOG_STATE} = READ_REST_OF_COMMENT_AND_COMMIT;\n            next;\n         }\n      }\n\n      if ( \$self->{VSS_LOG_STATE} eq READ_REST_OF_COMMENT_AND_COMMIT ) {\n          \$p->{Comment} .= \$_;\n          next;\n      }\n\n      require Data::Dumper;\n      local \$Data::Dumper::Indent    = 1;\n      local \$Data::Dumper::Quotekeys = 0;\n      local \$Data::Dumper::Terse     = 1;\n\n      die\n         "unhandled VSS log line '\$_' in state \$self->{VSS_LOG_STATE} for:\\n",\n         Data::Dumper::Dumper( \$self->{VSS_LOG_REV} );\n   }\n\n   if ( ! defined \$input ) {\n      \$self->add_rev_from_log_parser\n         if 0 <= index( \$self->{VSS_LOG_STATE}, "commit" )\n            ||  \$self->{VSS_LOG_LAZY_COMMIT_PENDING};\n\n      \$self->{VSS_LOG_STATE} = SKIP_TO_NEXT;\n   }\n}\n\n\n# Here's a (probably out-of-date by the time you read this) dump of the args\n# for _add_rev:\n#\n###############################################################################\n#\$file = {\n#  'WORKING' => 'src/Eesh/eg/synopsis',\n#  'SELECTED' => '2',\n#  'LOCKS' => 'strict',\n#  'TOTAL' => '2',\n#  'ACCESS' => '',\n#  'RCS' => '/var/vss/vssroot/src/Eesh/eg/synopsis,v',\n#  'KEYWORD' => 'kv',\n#  'RTAGS' => {\n#    '1.1' => [\n#      'Eesh_003_000',\n#      'Eesh_002_000'\n#    ]\n#  },\n#  'HEAD' => '1.2',\n#  'TAGS' => {\n#    'Eesh_002_000' => '1.1',\n#    'Eesh_003_000' => '1.1'\n#  },\n#  'BRANCH' => ''\n#};\n#\$rev = {\n#  'DATE' => '2000/04/21 17:32:16',\n#  'MESSAGE' => 'Moved a bunch of code from eesh, then deleted most of it.\n#',\n#  'STATE' => 'Exp',\n#  'AUTHOR' => 'barries',\n#  'REV' => '1.1'\n#};\n###############################################################################\n\nsub _add_rev {\n   my VCP::Source::vss \$self = shift ;\n   my ( \$rev_data, \$is_base_rev ) = \@_ ;\n\n   if ( debugging \$self ) {\n      require Data::Dumper;\n      debug "ADDING: ", Data::Dumper::Dumper( \$rev_data );\n   }\n\n   my \$action = \$rev_data->{Action};\n\n   \$rev_data->{Type} ||= "text";\n\n#debug map "\$_ => \$rev_data->{\$_}, ", sort keys %{\$rev_data} ;\n\n   my \$filename = \$rev_data->{Name};\n\n   my VCP::Rev \$r = VCP::Rev->new(\n      source_name => \$filename,\n      name        => \$self->normalize_name( \$rev_data->{Name} ),\n      rev_id      =>\n         \$rev_data->{Version} + \$self->{VSS_REV_ID_OFFSET}->{\$filename},\n      type        => \$rev_data->{Type},\n#      ! \$is_base_rev\n#\x09 ? (\n\x09    action      => \$action,\n\x09    time        =>\n               \$self->parse_time( \$rev_data->{Date} . " " . \$rev_data->{Time} ),\n\x09    user_id     => \$rev_data->{User},\n\x09    comment     => \$rev_data->{Comment},\n\x09    state       => \$rev_data->{STATE},\n\x09    labels      => \$rev_data->{Labels},\n#\x09 )\n#\x09 : (),\n   ) ;\n\n   \$self->{VSS_NAME_REP_NAME}->{\$rev_data->{Name}} = \$rev_data->{RCS} ;\n\n   eval {\n      \$self->revs->add( \$r ) ;\n   } ;\n   if ( \$\@ ) {\n      if ( \$\@ =~ /Can't add same revision twice/ ) {\n         warn \$\@ ;\n      }\n      else {\n         die \$\@ ;\n      }\n   }\n}\n\nsub add_rev_from_log_parser {\n   my ( \$self ) = \@_;\n\n   my \$rev_data = \$self->{VSS_LOG_REV};\n\n   \$rev_data->{Comment} = ''\n      unless defined \$rev_data->{Comment};\n\n   \$rev_data->{Comment} =~ s/\\r\\n|\\n\\r/\\n/g ;\n   chomp \$rev_data->{Comment};\n   chomp \$rev_data->{Comment};\n\n   \$self->_add_rev( \$rev_data );\n\n   my \$name = \$rev_data->{Name};\n\n   \$self->{VSS_HIGHEST_VERSION}->{\$name} = \$rev_data->{Version}\n      if ! defined \$self->{VSS_HIGHEST_VERSION}->{\$name}\n         || \$rev_data->{Version} > \$self->{VSS_HIGHEST_VERSION}->{\$name};\n\n   %\$rev_data = () ;\n   \$self->{VSS_LOG_LAZY_COMMIT_PENDING} = 0;\n} ;\n\n=head1 VSS NOTES\n\nWe lose comments attached to labels: labels are added to the last\n"real" (ie non-label-only) revision and the comments are ignored.\nThis can be changed, contact me.\n\nWe assume a file has always been text or binary, don't think this is\nstored per-version in VSS.\n\nLooks for deleted files: recovers them if found just long enough to\ncope with them, then deletes them again.\n\nVSS does not track renames by version, so a previous name for a file is lost.\n\nVSS lets you add a new file after deleting an old one.  This module\nrenames the current file, restores the old one, issues its revisions,\nthen deletes the old on and renames the current file back.  In this\ncase, the C<rev_id>s from the current file start at the highest\nC<rev_id> for the deleted file and continue up.\n\nNOTE: when recovering a deleted file and using it, the current version\ntakes a "least opportunity to screw up the source repository" approach:\nit renames the not-deleted version (if any), restores the deleted one,\ndoes the History or Get, and then deletes it and renames the not-deleted\nversion back.\n\nThis is so that if something (the OS, the hardware, AC mains, or even\nVCP code) crashes, the source repository is left as close to the\noriginal state as is possible.  This does mean that this module can\nissue many more commands than minimally necessary; perhaps there should\nbe a --speed-over-safety option.\n\nNo incremental export is supported.  VSS' -V~Lfoo option, which says\n"all versions since this label" does not actually cause the C<ss.exe\nHistory> command to emit the indicated checkin.  We'll need to make the\nhistory command much smarter to implement that.\n\n=head1 SEE ALSO\n\nL<VCP::Dest::vss>, L<vcp>, L<VCP::Process>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nCopyright (c) 2000, 2001, 2002 Perforce Software, Inc.\nAll rights reserved.\n\nSee L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACG
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACH, "lib/VCP/Source/p4.pm" }
package VCP::Source::p4 ;\n\n=head1 NAME\n\nVCP::Source::p4 - A Perforce p4 repository source\n\n=head1 SYNOPSIS\n\n   vcp p4://depot/...\@10          # all files after change 10 applied\n   vcp p4://depot/...\@1,10        # changes 1..10\n   vcp p4://depot/...\@-2,10       # changes 8..10\n   vcp p4://depot/...\@1,#head     # changes 1..#head\n   vcp p4://depot/...\@-2,#head    # changes 8..10\n   vcp p4:...\@-2,#head            # changes 8..10, if only one depot\n\nTo specify a user name of 'user', P4PASSWD 'pass', and port 'host:1666',\nuse this syntax:\n\n   vcp p4:user(client)password\@host:1666:files\n\nNote: the password will be passed in the environment variable P4PASSWD\nso it shouldn't show up in error messages. This means that a password\nspecified in a P4CONFIG file will override the password you set on the\ncommand line. This is a bug.  User, client and the server string will be\npassed as command line options to make them show up in error output.\n\nYou may use the P4... environment variables instead of any or all of the\nfields in the p4: repository specification.  The repository spec\noverrides the environment variables.\n\n=head1 DESCRIPTION\n\nDriver to allow L<vcp|vcp> to extract files from a\nL<Perforce|http://perforce.com/> repository.\n\nNote that not all metadata is extracted: users, clients and job tracking\ninformation is not exported, and only label names are exported.\n\nAlso, the 'time' and 'mod_time' attributes will lose precision, since\np4 doesn't report them down to the minute.  Hmmm, seems like p4 never\nsets a true mod_time.  It gets set to either the submit time or the\nsync time.  From C<p4 help client>:\n\n    modtime         Causes 'p4 sync' to force modification time \n\x09\x09    to when the file was submitted.\n\n    nomodtime *     Leaves modification time set to when the\n\x09\x09    file was fetched.\n\n=head1 OPTIONS\n\n=over\n\n=item -b, --bootstrap\n\n   -b '...'\n   --bootstrap='...'\n   -b file1[,file2[,...]]\n   --bootstrap=file1[,file2[,...]]\n\n(the C<...> there is three periods, a\nL<Regexp::Shellish|Regexp::Shellish> wildcard borrowed from C<p4>\npath syntax).\n\nForces bootstrap mode for an entire export (-b '...') or for certain\nfiles.  Filenames may contain wildcards, see L<Regexp::Shellish> for\ndetails on what wildcards are accepted.\n\nControls how the first revision of a file is exported.  A bootstrap\nexport contains the entire contents of the first revision in the revision\nrange.  This should only be necessary when exporting for the first time.\n\nAn incremental export contains a digest of the revision preceding the first\nrevision in the revision range, followed by a delta record between that\nrevision and the first revision in the range.  This allows the destination\nimport function to make sure that the incremental export begins where the\nlast export left off.\n\nThe default is decided on a per-file basis: if the first revision in the\nrange is revision #1, the full contents are exported.  Otherwise an\nincremental export is done for that file.\n\nThis option is necessary when exporting only more recent revisions from\na repository.\n\n=item -r, --rev-root\n\nB<Experimental>.\n\nFalsifies the root of the source tree being extracted; files will\nappear to have been extracted from some place else in the hierarchy.\nThis can be useful when exporting RevML, the RevML file can be made\nto insert the files in to a different place in the eventual destination\nrepository than they existed in the source repository.\n\nThe default C<rev-root> is the file spec up to the first path segment\n(directory name) containing a wildcard, so\n\n   p4:/a/b/c...\n\nwould have a rev-root of C</a/b>.\n\nIn direct repository-to-repository transfers, this option should not be\nnecessary, the destination filespec overrides it.\n\n=back\n\n=head1 METHODS\n\n=over\n\n=cut\n\n\$VERSION = 1.0 ;\n\nuse strict ;\n\nuse Carp ;\nuse Getopt::Long ;\nuse Fcntl qw( O_WRONLY O_CREAT ) ;\nuse VCP::Debug ":debug" ;\nuse Regexp::Shellish qw( :all ) ;\nuse VCP::Rev ;\nuse IPC::Run qw( run io timeout new_chunker ) ;\n\nuse base qw( VCP::Source VCP::Utils::p4 ) ;\nuse fields (\n   'P4_REPO_CLIENT',    ## Set by p4_parse_repo_spec in VCP::Utils::p4\n   'P4_INFO',           ## Results of the 'p4 info' command\n   'P4_LABEL_CACHE',    ## ->{\$name}->{\$rev} is a list of labels for that rev\n#   'P4_LABELS',         ## Array of labels from 'p4 labels'\n   'P4_MAX',            ## The last change number needed\n   'P4_MIN',            ## The first change number needed\n) ;\n\n=item new\n\nCreates a new instance of a VCP::Source::p4.  Contacts the p4d using the p4\ncommand and gets some initial information ('p4 info' and 'p4 labels').\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Source::p4 \$self = \$class->SUPER::new( \@_ ) ;\n\n   ## Parse the options\n   my ( \$spec, \$options ) = \@_ ;\n\n   \$self->parse_p4_repo_spec( \$spec ) ;\n\n   my \$rev_root ;\n\n   GetOptions(\n      'b|bootstrap:s'   => sub {\n\x09 my ( \$name, \$val ) = \@_ ;\n\x09 \$self->bootstrap( \$val ) ;\n      },\n      'r|rev-root=s'    => \\\$rev_root,\n      ) or \$self->usage_and_exit ;\n\n\n   my \$name = \$self->repo_filespec ;\n   unless ( defined \$rev_root ) {\n      if ( length \$name >= 2 && substr( \$name, 0, 2 ) ne '//' ) {\n         ## No depot on the command line, default it to the only depot\n\x09 ## or error if more than one.\n\x09 my \$depots ;\n\x09 \$self->p4( ['depots'], \\\$depots ) ;\n\x09 \$depots = 'depot' unless length \$depots ;\n\x09 my \@depots = split( /^/m, \$depots ) ;\n\x09 die "vcp: p4 has more than one depot, can't assume //depot/...\\n"\n\x09    if \@depots > 1 ;\n\x09 debug "vcp: defaulting depot to '\$depots[0]'" if debugging \$self ;\n\x09 \$name = join( '/', '/', \$depots[0], \$name ) ;\n      }\n      \$self->deduce_rev_root( \$name ) ;\n   }\n   else {\n      \$self->rev_root( \$rev_root ) ;\n   }\n\n   die "no depot name specified for p4 source '\$name'\\n"\n      unless \$name =~ m{^//[^/]+/} ;\n   \$self->repo_filespec( \$name ) ;\n\n   \$self->load_p4_info ;\n   \$self->load_p4_labels ;\n\n   return \$self ;\n}\n\n\nsub load_p4_info {\n   my VCP::Source::p4 \$self = shift ;\n\n   my \$errors = '' ;\n   \$self->p4( ['info'], \\\$self->{P4_INFO} ) ;\n}\n\n\nsub is_incremental {\n   my VCP::Source::p4 \$self= shift ;\n\n   my ( \$file, \$first_rev ) = \@_ ;\n\n   my \$bootstrap_mode = \$first_rev == 1 || \$self->is_bootstrap_mode( \$file ) ;\n\n   return ! \$bootstrap_mode ;\n}\n\n# A typical entry in the filelog looks like\n#-------8<-------8<------\n#//revengine/revml.dtd\n#... #6 change 11 edit on 2000/08/28 by barries\@barries (text)\n#\n#        Rev 0.008: Added some modules and tests and fixed lots of bugs.\n#\n#... #5 change 10 edit on 2000/08/09 by barries\@barries (text)\n#\n#        Got Dest/cvs working, lots of small changes elsewhere\n#\n#-------8<-------8<------\n# And, from a more tangled source tree, perl itself:\n#-------8<-------8<------\n#... ... branch into //depot/ansiperl/x2p/a2p.h#1\n#... ... ignored //depot/maint-5.004/perl/x2p/a2p.h#1\n#... ... copy into //depot/oneperl/x2p/a2p.h#3\n#... ... copy into //depot/win32/perl/x2p/a2p.h#2\n#... #2 change 18 integrate on 1997/05/25 by mbeattie\@localhost (text)\n#\n#        First stab at 5.003 -> 5.004 integration.\n#\n#... ... branch into //depot/lexwarn/perl/x2p/a2p.h#1\n#... ... branch into //depot/oneperl/x2p/a2p.h#1\n#... ... copy from //depot/relperl/x2p/a2p.h#2\n#... ... branch into //depot/win32/perl/x2p/a2p.h#1\n#... #1 change 1 add on 1997/03/28 by mbeattie\@localhost (text)\n#\n#        Perl 5.003 check-in\n#\n#... ... branch into //depot/mainline/perl/x2p/a2p.h#1\n#... ... branch into //depot/relperl/x2p/a2p.h#1\n#... ... branch into //depot/thrperl/x2p/a2p.h#1\n#-------8<-------8<------\n#\n# This next regexp is used to parse the lines beginning "... #"\n\nmy \$filelog_rev_info_re = qr{\n   \\G                  # Use with /gc!!\n   ^\\.\\.\\.\\s+\n   \\#(\\d+)\\s+          # Revision\n   change\\s+(\\d+)\\s+   # Change nubmer\n   (\\S+)\\s+            # Action\n   \\S+\\s+              ### 'on '\n   (\\S+)\\s+            # date\n   \\S+\\s+              ### 'by '\n   (\\S(?:.*?\\S))\\s+    # user id.  Undelimited, so hope for best\n   \\((\\S+?)\\)          # type\n   .*\\r?\\n\n}mx ;\n\n# And this one grabs the comment\nmy \$filelog_comment_re = qr{\n   \\G\n   ^\\r?\\n\n   ((?:^[^\\S\\r\\n].*\\r?\\n)*)\n   ^\\r?\\n\n}mx ;\n\n\nsub scan_filelog {\n   my VCP::Source::p4 \$self = shift ;\n\n   my ( \$first_change_id, \$last_change_id ) = \@_ ;\n\n   my \$log = '' ;\n\n   my \$delta = \$last_change_id - \$first_change_id + 1 ;\n\n   my \$spec =  join( '', \$self->repo_filespec . '\@' . \$last_change_id ) ;\n   my \$temp_f = \$self->command_stderr_filter ;\n   \$self->command_stderr_filter(\n       qr{//\\S* - no file\\(s\\) at that changelist number\\.\\s*\\r?\\n}\n   ) ;\n\n   my %oldest_revs ;\n   {\n      my \$log_state = "need_file" ;\n\n      my VCP::Rev \$r ;\n      my \$name ;\n      my \$comment ;\n\n      my \$p4_filelog_parser = sub {\n\x09 local \$_ = shift ;\n\n      REDO_LINE:\n\x09 if ( \$log_state eq "need_file" ) {\n\x09    die "\\\$r defined" if defined \$r ;\n\x09    die "vcp: p4 filelog parser: file name expected, got '\$_'"\n\x09       unless m{^//(.*?)\\r?\\n\\r?} ;\n\n\x09    \$name = \$1 ;\n\x09    \$log_state = "revs" ;\n\x09 }\n\x09 elsif ( \$log_state eq "revs" ) {\n\x09    return if m{^\\.\\.\\.\\s+\\.\\.\\..*\\r?\\n\\r?} ;\n\x09    unless ( m{\$filelog_rev_info_re} ) {\n\x09       \$log_state = "need_file" ;\n\x09       goto REDO_LINE ;\n\x09    }\n\n\x09    my \$change_id = \$2 ;\n\x09    if ( \$change_id < \$self->min ) {\n\x09       undef \$r ;\n\x09       \$log_state = "need_comment" ;\n\x09       return ;\n\x09    }\n\n\x09    my \$type = \$6 ;\n\n\x09    my \$norm_name = \$self->normalize_name( \$name ) ;\n\x09    die "\\\$r defined" if defined \$r ;\n\x09    \$r = VCP::Rev->new(\n\x09       name      => \$norm_name,\n\x09       rev_id    => \$1,\n\x09       change_id => \$change_id,\n\x09       action    => \$3,\n\x09       time      => \$self->parse_time( \$4 ),\n\x09       user_id   => \$5,\n\x09       p4_info   => \$_,\n\x09       comment   => '',\n\x09    ) ;\n\n\x09    my \$is_binary = \$type =~ /^(?:u?x?binary|x?tempobj|resource)/ ;\n\x09    \$r->type( \$is_binary ? "binary" : "text" ) ;\n\n\x09    \$r->labels( \$self->get_p4_file_labels( \$name, \$r->rev_id ) );\n\n\x09    ## Filelogs are in newest...oldest order, so this should catch\n\x09    ## the oldest revision of each file.\n\x09    \$oldest_revs{\$name} = \$r ;\n\n\x09    \$log_state = "need_comment" ;\n\x09 }\n\x09 elsif ( \$log_state eq "need_comment" ) {\n\x09    unless ( /^\$/ ) {\n\x09       die\n   "vcp: p4 filelog parser: expected a blank line before a comment, got '\$_'" ;\n\x09    }\n\x09    \$log_state = "comment_accum" ;\n\x09 }\n\x09 elsif ( \$log_state eq "comment_accum" ) {\n\x09    if ( /^\$/ ) {\n\x09       if ( defined \$r ) {\n\x09\x09  \$r->comment( \$comment ) ;\n\x09\x09  \$self->revs->add( \$r ) ;\n\x09\x09  \$r = undef ;\n\x09       }\n\x09       \$comment = undef ;\n\x09       \$log_state = "revs" ;\n\x09       return ;\n\x09    }\n\x09    unless ( s/^\\s// ) {\n\x09       die "vcp: p4 filelog parser: expected a comment line, got '\$_'" ;\n\x09    }\n\x09    \$comment .= \$_ ;\n\x09 }\n\x09 else {\n\x09    die "unknown log_state '\$log_state'" ;\n\x09 }\n      } ;\n\n      \$self->p4(\n\x09 [qw( filelog -m ), \$delta, "-l", \$spec ],\n\x09 '>', new_chunker, \$p4_filelog_parser\n      ) ;\n      \$self->command_stderr_filter( \$temp_f ) ;\n\n      die "\\\$r defined" if defined \$r ;\n   }\n\n   my \@base_rev_specs ;\n   for my \$name ( sort keys %oldest_revs ) {\n      my \$r = \$oldest_revs{\$name} ;\n      my \$rev_id = \$r->rev_id ;\n      if ( \$self->is_incremental( "//\$name", \$r->rev_id ) ) {\n\x09 \$rev_id -= 1 ;\n\x09 push \@base_rev_specs, "//\$name#\$rev_id" ;\n      }\n      else {\n\x09 debug "vcp: bootstrapping '", \$r->name, "#", \$r->rev_id, "'"\n\x09    if debugging \$self ;\n      }\n      \$oldest_revs{\$name} = undef ;\n   }\n\n   if ( \@base_rev_specs ) {\n      undef \$log ;\n      \$self->command_stderr_filter(\n\x09  qr{//\\S* - no file\\(s\\) at that changelist number\\.\\s*\\r?\\n}\n      ) ;\n      \$self->p4( [qw( filelog -m 1 -l ), \@base_rev_specs ], \\\$log ) ;\n      \$self->command_stderr_filter( \$temp_f ) ;\n\n      while ( \$log =~ m{\\G(.*?)^//(.*?)\\r?\\n\\r?}gmsc ) {\n\x09 warn "vcp: Ignoring '\$1' in p4 filelog output\\n" if length \$1 ;\n\x09 my \$name = \$2 ;\n\n\x09 my \$norm_name = \$self->normalize_name( \$name ) ;\n\x09 while () {\n\x09    next if     \$log =~ m{\\G^\\.\\.\\.\\s+\\.\\.\\..*\\r?\\n\\r?}gmc ;\n\n\x09    last unless \$log =~ m{\$filelog_rev_info_re}gc ;\n\n\x09    my VCP::Rev \$br = VCP::Rev->new(\n\x09       name      => \$norm_name,\n\x09       rev_id    => \$1,\n\x09       change_id => \$2,\n   # Don't send these on a base rev for incremental changes:\n   #\x09     action    => \$3,\n   #\x09     time      => \$self->parse_time( \$4 ),\n   #\x09     user_id   => \$5,\n\x09\x09type      => \$6,\n   #\x09     comment   => '',\n\x09    ) ;\n\n\x09    \$self->revs->add( \$br ) ;\n\n\x09    \$log =~ m{\$filelog_comment_re}gc ;\n\x09 }\n      }\n   }\n}\n\n\nsub min {\n   my VCP::Source::p4 \$self = shift ;\n   \$self->{P4_MIN} = shift if \@_ ;\n   return \$self->{P4_MIN} ;\n}\n\n\nsub max {\n   my VCP::Source::p4 \$self = shift ;\n   \$self->{P4_MAX} = shift if \@_ ;\n   return \$self->{P4_MAX} ;\n}\n\n\nsub load_p4_labels {\n   my VCP::Source::p4 \$self = shift ;\n\n   my \$labels = '' ;\n   my \$errors = '' ;\n   \$self->p4( ['labels'], \\\$labels ) ;\n\n   my \@labels = map(\n      /^Label\\s*(\\S*)/ ? \$1 : (),\n      split( /^/m, \$labels )\n   ) ;\n\n   \$self->command_ok_result_codes( 0, 1 ) ;\n\n   my \$marker = "//.../NtLkly" ;\n   my \$p4_files_args =\n      join(\n         "",\n\x09 ( map {\n\x09    ( "\$marker\\n", "//...\\\@\$_\\n" ) ;\n\x09 } \@labels ),\n      ) ;\n   my \$files ;\n   \$self->p4( [ qw( -x - -s files) ], "<", \\\$p4_files_args, ">", \\\$files ) ;\n\n   my \$label ;\n   for my \$spec ( split /\\n/m, \$files ) {\n      last if \$spec =~ /^exit:/ ;\n      if ( \$spec =~ /^error: \$marker/o ) {\n\x09 \$label = shift \@labels ;\n\x09 next ;\n      }\n      next if \$spec =~ m{^error: //\\.\\.\\.\\\@.+ file(\\(s\\))? not in label.\$} ;\n      \$spec =~ /^.*?: *\\/\\/(.*)#(\\d+)/\n\x09 or die "Couldn't parse name & rev from '\$spec' in '\$files'" ;\n\n      debug "vcp: p4 label '\$label' => '\$1#\$2'" if debugging \$self ;\n      push \@{\$self->{P4_LABEL_CACHE}->{\$1}->{\$2}}, \$label ;\n   }\n\n   \$self->command_ok_result_codes( 0 ) ;\n\n   return ;\n}\n\n\nsub denormalize_name {\n   my VCP::Source::p4 \$self = shift ;\n   return '//' . \$self->SUPER::denormalize_name( \@_ ) ;\n}\n\n\nsub get_p4_file_labels {\n   my VCP::Source::p4 \$self = shift ;\n\n   my \$name ;\n   my VCP::Rev \$rev ;\n   ( \$name, \$rev ) = \@_ ;\n\n   return (\n      (  exists \$self->{P4_LABEL_CACHE}->{\$name}\n      && exists \$self->{P4_LABEL_CACHE}->{\$name}->{\$rev}\n      )\n\x09 ? \@{\$self->{P4_LABEL_CACHE}->{\$name}->{\$rev}}\n\x09 : ()\n   ) ;\n}\n\n\nmy \$filter_prog = <<'EOPERL' ;\n   use strict ;\n   my ( \$name, \$working_path ) = ( shift, shift ) ;\n   }\nEOPERL\n\n\nsub get_rev {\n   my VCP::Source::p4 \$self = shift ;\n\n   my VCP::Rev \$r ;\n\n   ( \$r ) = \@_ ;\n\n   return if defined \$r->action && \$r->action eq "delete" ;\n   my \$fn  = \$r->name ;\n   my \$rev = \$r->rev_id ;\n   \$r->work_path( \$self->work_path( \$fn, \$rev ) ) ;\n   my \$wp  = \$r->work_path ;\n   \$self->mkpdir( \$wp ) ;\n\n   my \$denormalized_name = \$self->denormalize_name( \$fn ) ;\n   my \$rev_spec = "\$denormalized_name#\$rev" ;\n\n   sysopen( WP, \$wp, O_CREAT | O_WRONLY )\n      or die "\$!: \$wp" ;\n\n   binmode WP ;\n\n   my \$re = quotemeta( \$rev_spec ) . " - .* change \\\\d+ \\\\((.+)\\\\)";\n\n   ## TODO: look for "+x" in the (...) and pass an executable bit\n   ## through the rev structure.\n   \$self->p4( \n      [ "print", \$rev_spec ],\n      ">", sub {\n\x09 \$_ = shift ;\n\x09 s/\\A\$re\\r?\\n//m if \$re ;\n\x09 print WP or die "\$! writing to \$wp" ;\n\x09 \$re = undef ;\n      },\n   ) ;\n\n   close WP or die "\$! closing wp" ;\n\n   return ;\n}\n\n\nsub handle_header {\n   my VCP::Source::p4 \$self = shift ;\n   my ( \$header ) = \@_ ;\n\n   \$header->{rep_type} = 'p4' ;\n   \$header->{rep_desc} = \$self->{P4_INFO} ;\n   \$header->{rev_root} = \$self->rev_root ;\n\n   \$self->dest->handle_header( \$header ) ;\n   return ;\n}\n\n\nsub copy_revs {\n   my VCP::Source::p4 \$self = shift ;\n\n   \$self->revs( VCP::Revs->new ) ;\n\n   \$self->scan_filelog( \$self->min, \$self->max ) ;\n   \$self->dest->sort_revs( \$self->revs ) ;\n\n   ## Discard the revs so they'll be DESTROYed and thus\n   ## clean up after themselves.\n   while ( my VCP::Rev \$r = \$self->revs->shift ) {\n      \$self->get_rev( \$r ) ;\n      \$self->dest->handle_rev( \$r ) ;\n   }\n}\n\n=head1 SEE ALSO\n\nL<VCP::Dest::p4>, L<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nCopyright (c) 2000, 2001, 2002 Perforce Software, Inc.\nAll rights reserved.\n\nSee L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACH
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACI, "lib/VCP/Source/revml.pm" }
package VCP::Source::revml ;\n\n=head1 NAME\n\nVCP::Source::revml - Outputs versioned files to a revml file\n\n=head1 SYNOPSIS\n\n   vcp revml[:<source>]\n   vcp revml[:<source>] --dtd <dtd>\n\nWhere <source> is a filename for input; or missing or '-' for STDIN.\n\nTo compile a DTD in to a perl module:\n\n   revml: --dtd <dtd> --save-doctype\n\n=head1 DESCRIPTION\n\nThis source driver allows L<vcp|vcp> to read a RevML file.\n\nFor now, all revisions are fully reconstituted in the working\ndirectory in order to make sure that all of the patches apply cleanly.\nThis can require a huge amount of disk space, but it works (optimizing\nthis is on the TODO).\n\n=cut\n\nuse strict ;\n\nuse Carp ;\nuse Fcntl ;\nuse Getopt::Long ;\nuse Digest::MD5 ;\nuse MIME::Base64 ;\nuse RevML::Doctype ;\nuse Symbol ;\nuse UNIVERSAL qw( isa ) ;\nuse XML::Parser ;\nuse Time::Local qw( timegm ) ;\nuse VCP::Debug ':debug' ;\nuse VCP::Patch ;\nuse VCP::Rev ;\n\nuse vars qw( \$VERSION \$debug ) ;\n\n\$VERSION = 0.1 ;\n\n\$debug = 0 ;\n\nuse base 'VCP::Source' ;\n\nuse fields (\n   'COPY_MODE', ## TRUE to do a copy, FALSE if not (like when writing .pm DTD)\n   'DOCTYPE',\n   'HEADER',    ## The \$header is held here until the first <rev> is read\n   'IN_FH',     ## The handle of the input revml file\n   'IN_NAME',   ## The name of the input revml file, or '-' for stdout\n   'WORK_NAME', ## The name of the working file (diff or content)\n   'WORK_FH',   ## The filehandle of working file\n   'REV',       ## The VCP::Rev containing all of this rev's meta info\n   'STACK',     ## A stack of currently open elements\n   'UNDECODED_CONTENT', ## Base64 content waiting to be decoded.\n) ;\n\n\n#=item new\n#\n#Creates a new instance.  The only parameter is '-dtd', which overrides\n#the default DTD found by searching for modules matching RevML::DTD:v*.pm.\n#\n#Attempts to open the input file if one is specified.\n#\n#If the option '--save-doctype' is passed, then no copying of resources\n#is done (queue_all returns nothing to copy) and the doctype is saved\n#as a .pm file.  See L<RevML::Doctype> for details.\n#\n#=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Source::revml \$self = \$class->SUPER::new( \@_ ) ;\n\n   \$self->{COPY_MODE} = 1 ;\n\n   my ( \$spec, \$args ) = \@_ ;\n\n   my \$parsed_spec = \$self->parse_repo_spec( \$spec ) ;\n\n   my \$save_doctype ;\n   {\n      local *ARGV = \$args ;\n      GetOptions(\n\x09 'dtd|version' => sub {\n\x09    \$self->{DOCTYPE} = RevML::Doctype->new( shift \@\$args ) ;\n\x09 },\n\x09 'save-doctype' => \\\$save_doctype,\n      ) or \$self->usage_and_exit ;\n   }\n\n   \$self->{DOCTYPE} = RevML::Doctype->new\n      unless \$self->{DOCTYPE} ;\n\n   if ( \$save_doctype ) {\n      \$self->{COPY_MODE} = 0 ;\n      \$self->{DOCTYPE}->save_as_pm ;\n   }\n   my \@errors ;\n\n   my \$files = \$parsed_spec->{FILES} ;\n\n   \$self->{IN_NAME} = defined \$files && length \$files\n      ? \$files\n      : '-' ;\n\n   if ( \$self->{IN_NAME} eq '-' ) {\n      \$self->{IN_FH}   = \\*STDIN ;\n      ## TODO: Check IN_FH for writability when it's set to STDIN\n   }\n   else {\n      require Symbol ;\n      \$self->{IN_FH} = Symbol::gensym ;\n      open( \$self->{IN_FH}, "<\$self->{IN_NAME}" )\n         or die "\$!: \$self->{IN_NAME}\\n" ;\n   }\n\n   \$self->{WORK_FH} = Symbol::gensym ;\n\n   die join( '', \@errors ) if \@errors ;\n\n   return \$self ;\n}\n\n\nsub dest_expected {\n   my VCP::Source::revml \$self = shift ;\n\n   return \$self->{COPY_MODE} ;\n}\n\n\nsub handle_header {\n   my VCP::Source::revml \$self = shift ;\n\n   ## Save this off until we get our first rev from the input\n   \$self->{HEADER} = shift ;\n   return ;\n}\n\n\nsub get_rev {\n   my VCP::Source::revml \$self = shift ;\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n}\n\n\nsub copy_revs {\n   my VCP::Source::revml \$self = shift ;\n\n   \$self->revs( VCP::Revs->new ) ;\n   \$self->parse_revml_file ;\n\n   \$self->dest->sort_revs( \$self->revs ) ;\n\n   my VCP::Rev \$r ;\n   while ( \$r = \$self->revs->shift ) {\n      \$self->get_rev( \$r ) ;\n      \$self->dest->handle_rev( \$r ) ;\n   }\n}\n\n\nsub parse_revml_file {\n   my VCP::Source::revml \$self = shift ;\n\n   my \@stack ;\n   \$self->{STACK} = \\\@stack ;\n\n   my \$char_handler = sub {\n      my \$expat = shift ;\n      my \$pelt = \$stack[-1] ; ## parent element\n      my \$tag = \$pelt->{NAME} ;\n      my \$content = \$pelt->{CONTENT} ;\n      if ( defined \$content ) {\n\x09 if ( \@\$content && \$content->[-1]->{TYPE} eq 'PCDATA' ) {\n\x09    \$content->[-1]->{PCDATA} .= \$_[0] ;\n\x09 }\n\x09 else {\n\x09    push \@\$content, { TYPE => 'PCDATA', PCDATA => \$_[0] } ;\n\x09 }\n      }\n      my \$sub = "\${tag}_characters" ;\n      \$self->\$sub( \@_ ) if \$self->can( \$sub ) ;\n   } ;\n\n   my \$p = XML::Parser->new(\n      Handlers => {\n         Start => sub {\n\x09    my \$expat = shift ;\n\x09    my \$tag = shift ;\n\n\x09    if ( \$tag eq "char" ) {\n\x09       while ( \@_ ) {\n\x09          my ( \$attr, \$value ) = ( shift, shift ) ;\n#print STDERR \$value, "=" ;\n\x09\x09  if ( \$attr eq "code" ) {\n\x09\x09     if ( \$value =~ s{^0x}{} ) {\n\x09\x09\x09\$value = chr( hex( \$value ) ) ;\n\x09\x09     }\n\x09\x09     else {\n\x09\x09\x09\$value = chr( \$value ) ;\n\x09\x09     }\n#print STDERR ord \$value, "\\n" ;\n\x09\x09     \$char_handler->( \$expat, \$value ) ;\n\x09\x09  }\n\x09       }\n\x09       return ;\n\x09    }\n\n#print STDERR "<\$tag>\\n" ;\n\x09    push \@stack, {\n\x09       NAME => \$tag,\n\x09       ATTRS => {\@_},\n\x09       CONTENT => ! \$self->can( "\${tag}_characters" ) ? [] : undef,\n\x09    } ;\n\x09    my \$sub = "start_\$tag" ;\n\x09    \$self->\$sub( \@_ ) if \$self->can( \$sub ) ;\n\x09 },\n\n\x09 End => sub {\n\x09    my \$expat = shift ;\n\x09    my \$tag = shift ;\n\x09    return if \$tag eq "char" ;\n\n#print STDERR "</\$tag>\\n" ;\n\x09    die "Unexpected </\$tag>, expected </\$stack[-1]>\\n"\n\x09       unless \$tag eq \$stack[-1]->{NAME} ;\n\x09    my \$sub = "end_\$tag" ;\n\x09    \$self->\$sub( \@_ ) if \$self->can( \$sub ) ;\n\x09    my \$elt = pop \@stack ;\n\n\x09    if ( \@stack\n\x09       && \$stack[-1]->{NAME} =~ /^rev(ml)?\$/\n\x09       && defined \$elt->{CONTENT}\n\x09       ) {\n#print STDERR "</\$tag>\\n" ;\n\x09       ## Save all the meta fields for start_content() or start_diff()\n\x09       if ( \$tag eq 'label' ) {\n\x09          push \@{\$stack[-1]->{labels}}, \$elt ;\n\x09       }\n\x09       else {\n\x09\x09  \$stack[-1]->{\$tag} = \$elt ;\n\x09       }\n\x09    }\n\x09 },\n\n\x09 Char => \$char_handler,\n      },\n   ) ;\n   \$p->parse( \$self->{IN_FH} ) ;\n}\n\n\nsub start_rev {\n   my VCP::Source::revml \$self = shift ;\n\n   ## We now have all of the header info parsed, save it off\n\n   ## TODO: Demystify this hairy wart.  Better yet, simplify all the code\n   ## in this module.  It needs to decode the fields as they come in and\n   ## stick them in the header and the rev_meta \n   for ( map(\n      \$self->{STACK}->[-2]->{\$_},\n      grep /^[a-z_0-9]+\$/, keys %{\$self->{STACK}->[-2]}\n   ) ) {\n      \$self->{HEADER}->{\$_->{NAME}} = \$_->{CONTENT}->[0]->{PCDATA} ;\n   }\n\n   ## Make sure no older rev is lying around to confuse us.\n   \$self->{REV} = undef ;\n}\n\n## RevML is contstrained so that the diff and content tags are after all of\n## the meta info for a revision.  And we really don't want to hold\n## the entire content of a file in memory, in case it's large.  So we\n## intercept start_content and start_diff and initialize the REV\n## member as well as opening a place to catch all of the data that gets\n## extracted from the file.\nsub init_rev_meta {\n   my VCP::Source::revml \$self = shift ;\n\n   my \$rev_elt = \$self->{STACK}->[-2] ;\n   my VCP::Rev \$r = VCP::Rev->new() ;\n   ## All revml tag naes are lc, all internal data member names are uc\n#require Data::Dumper ; print Data::Dumper::Dumper( \$self->{STACK} ) ;\n\n   for ( grep /^[a-z_0-9]+\$/, keys %\$rev_elt ) {\n      if ( \$_ eq 'labels' ) {\n         \$r->labels(\n\x09    map \$_->{CONTENT}->[0]->{PCDATA}, \@{\$rev_elt->{labels}}\n\x09 ) ;\n      }\n      else {\n         ## We know that all kids *in use today* of <rev> are pure PCDATA\n\x09 ## Later, we'll need sub-attributes.\n\x09 ## TODO: Flatten the element tree by preficing attribute names\n\x09 ## with, I dunno, say '_' or by adding '_attr' to them.\n\x09 my \$out_key = \$_ ;\n         \$r->\$out_key( \$rev_elt->{\$_}->{CONTENT}->[0]->{PCDATA} ) ;\n      }\n   }\n#require Data::Dumper ; print Data::Dumper::Dumper( \$r ) ;\n\n   \$r->work_path( \$self->work_path( \$r->name, \$r->rev_id ) ) ;\n\n   \$self->mkpdir( \$r->work_path ) ;\n\n   \$self->{REV} = \$r ;\n   return ;\n}\n\n\nsub start_delete {\n   my VCP::Source::revml \$self = shift ;\n\n   \$self->init_rev_meta ;\n   \$self->{REV}->action( "delete" ) ;\n   ## Clear the work_path so that VCP::Rev doesn't try to delete it.\n   \$self->{REV}->work_path( undef ) ;\n}\n\n\nsub start_move {\n   my VCP::Source::revml \$self = shift ;\n\n   \$self->init_rev_meta ;\n   \$self->{REV}->action( "move" ) ;\n   ## Clear the work_path so that VCP::Rev doesn't try to delete it.\n   \$self->{REV}->work_path( undef ) ;\n   die "<move> unsupported" ;\n}\n\n\nsub start_content {\n   my VCP::Source::revml \$self = shift ;\n\n   \$self->init_rev_meta ;\n#require Data::Dumper ; print Data::Dumper::Dumper( \$self->{REV} ) ;\n   \$self->{REV}->action( "edit" ) ;\n   \$self->{WORK_NAME} = \$self->{REV}->work_path ;\n   \$self->{UNDECODED_CONTENT} = "" ;\n   sysopen \$self->{WORK_FH}, \$self->{WORK_NAME}, O_WRONLY | O_CREAT | O_TRUNC\n      or die "\$!: \$self->{WORK_NAME}" ;\n   ## The binmode here is to make sure we don't convert \\n to \\r\\n and\n   ## to allow ^Z out the door (^Z is EOF on windows, and they take those\n   ## things rather more seriously there than on Unix).\n   binmode \$self->{WORK_FH};\n}\n\n\nsub content_characters {\n   my VCP::Source::revml \$self = shift ;\n   if ( \$self->{STACK}->[-1]->{ATTRS}->{encoding} eq "base64" ) {\n      \$self->{UNDECODED_CONTENT} .= shift ;\n      if ( \$self->{UNDECODED_CONTENT} =~ s{(.*\\n)}{} ) {\n\x09 syswrite( \$self->{WORK_FH}, decode_base64( \$1 ) )\n\x09    or die "\$! writing \$self->{WORK_NAME}" ;\n      }\n   }\n   elsif ( \$self->{STACK}->[-1]->{ATTRS}->{encoding} eq "none" ) {\n# print STDERR map( sprintf( " %02x=\$_", ord ), \$_[0] =~ m/(.)/gs ), "\\n" ;\n      syswrite \$self->{WORK_FH}, \$_[0]\n         or die "\$! writing \$self->{WORK_NAME}" ;\n   }\n   else {\n      die "vcp: unknown encoding '\$self->{STACK}->[-1]->{ATTRS}->{encoding}'\\n";\n   }\n   return ;\n}\n\nsub end_content {\n   my VCP::Source::revml \$self = shift ;\n   \n   if ( length \$self->{UNDECODED_CONTENT} ) {\n      syswrite( \$self->{WORK_FH}, decode_base64( \$self->{UNDECODED_CONTENT} ) )\n\x09 or die "\$! writing \$self->{WORK_NAME}" ;\n   }\n   close \$self->{WORK_FH} or die "\$! closing \$self->{WORK_NAME}" ;\n\n   if ( \$self->none_seen ) {\n#require Data::Dumper ; print Data::Dumper::Dumper( \$self->{HEADER} ) ;\n      \$self->dest->handle_header( \$self->{HEADER} ) ;\n   }\n\n   \$self->seen( \$self->{REV} ) ;\n}\n\nsub start_delta {\n   my VCP::Source::revml \$self = shift ;\n\n   \$self->init_rev_meta ;\n   my \$r = \$self->{REV} ;\n   \$r->action( 'edit' ) ;\n   \$self->{WORK_NAME} = \$self->work_path( \$r->name, 'delta' ) ;\n   sysopen \$self->{WORK_FH}, \$self->{WORK_NAME}, O_WRONLY | O_CREAT | O_TRUNC\n      or die "\$!: \$self->{WORK_NAME}" ;\n   ## See comment in start_content :)\n   binmode \$self->{WORK_FH};\n}\n\n\n## TODO: Could keep deltas in memory if they're small.\n*delta_characters = \\&content_characters ;\n## grumble...name used once warning...grumble\n*delta_characters = \\&content_characters ;\n\nsub end_delta {\n   my VCP::Source::revml \$self = shift ;\n\n   close \$self->{WORK_FH} or die "\$! closing \$self->{WORK_NAME}" ;\n\n#print STDERR `hexdump -cx \$self->{WORK_NAME}` ;\n\n   my VCP::Rev \$r = \$self->{REV} ;\n\n   ## Delay sending handle_header to dest until patch succeeds.\n   my \$is_first = \$self->none_seen ;\n\n   my VCP::Rev \$saw = \$self->seen( \$r ) ;\n\n   die "No original content to patch for ", \$r->name, ",",\n      " revision ", \$r->rev_id\n      unless defined \$saw ;\n\n   if ( -s \$self->{WORK_NAME} ) {\n      ## source fn, result fn, patch fn\n      vcp_patch( \$saw->work_path, \$r->work_path, \$self->{WORK_NAME} );\n      unless ( \$ENV{VCPNODELETE} ) {\n         unlink \$self->{WORK_NAME} or warn "\$! unlinking \$self->{WORK_NAME}\\n" ;\n      }\n   }\n   else {\n      ## TODO: Don't assume working link()\n      debug "vcp: linking ", \$saw->work_path, ", ", \$r->work_path\n         if debugging \$self ;\n\n      link \$saw->work_path, \$r->work_path\n         or die "vcp: \$! linking ", \$saw->work_path, ", ", \$r->work_path\n   }\n\n   if ( \$is_first ) {\n#require Data::Dumper ; print Data::Dumper::Dumper( \$self->{HEADER} ) ;\n      \$self->dest->handle_header( \$self->{HEADER} ) ;\n   }\n\n}\n\n\n## Convert ISO8601 UTC time to local time since the epoch\nsub end_time {\n   my VCP::Source::revml \$self = shift ;\n\n   my \$timestr = \$self->{STACK}->[-1]->{CONTENT}->[0]->{PCDATA} ;\n   ## TODO: Get parser context here & give file, line, and column. filename\n   ## and rev, while we're scheduling more work for the future.\n   confess "Malformed time value \$timestr\\n"\n      unless \$timestr =~ /^\\d\\d\\d\\d(\\D\\d\\d){5}/ ;\n   confess "Non-UTC time value \$timestr\\n" unless substr \$timestr, -1 eq 'Z' ;\n   my \@f = split( /\\D/, \$timestr ) ;\n   --\$f[1] ; # Month of year needs to be 0..11\n   \$self->{STACK}->[-1]->{CONTENT}->[0]->{PCDATA} = timegm( reverse \@f ) ;\n}\n\n# double assign => avoid used once warning\n*end_mod_time = *end_mod_time = \\&end_time ;\n\n\n## TODO: Verify that we should be using a Base64 encoded MD5 digest,\n## according to <delta>'s attributes.  Oh, and same goes for <content>'s\n## encoding.\n\n## TODO: workaround backfilling if the destination is revml, since\n## it can't put the original content in place.  We'll need to flag\n## some kind of special pass-through mode for that.\n\nsub end_digest {\n   my VCP::Source::revml \$self = shift ;\n\n   \$self->init_rev_meta unless defined \$self->{REV} ;\n   my \$r = \$self->{REV} ;\n\n   my \$original_digest = \$self->{STACK}->[-1]->{CONTENT}->[0]->{PCDATA} ;\n   my \$d = Digest::MD5->new() ;\n\n   if ( \$r->is_base_rev ) {\n      \$self->dest->handle_header( \$self->{HEADER} ) if \$self->none_seen ;\n\n      ## Don't bother checking the digest if the destination returns\n      ## FALSE, meaning that a backfill is not possible with that destination.\n      ## VCP::Dest::revml does this.\n      return unless \$self->dest->backfill( \$r ) ;\n      my VCP::Rev \$saw = \$self->seen( \$r ) ;\n      warn "I've seen ", \$r->name, " before" if \$saw ;\n   }\n   my \$work_path = \$r->work_path ;\n\n   sysopen F, \$work_path, O_RDONLY\n      or die "vcp: \$! opening '\$work_path' for digestion\\n" ;\n   ## See comment for binmode in start_content :)\n   binmode F;\n   \$d->addfile( \\*F ) ;\n   close F ;\n   my \$reconstituted_digest = \$d->b64digest ;\n\n   ## TODO: provide an option to turn this in to a warning\n   ## TODO: make this abort writing anything to the dest, but continue\n   ## processing, so as to deliver as many error messages as possible.\n   unless ( \$original_digest eq \$reconstituted_digest ) {\n      my \$reject_file_name = \$r->name ;\n      \$reject_file_name =~ s{[^A-Za-z0-9 -.]+}{-}g ;\n      \$reject_file_name =~ s{^-+}{}g ;\n      my \$reject_file_path = File::Spec->catfile(\n         File::Spec->tmpdir,\n\x09 \$reject_file_name\n      ) ;\n\n      link \$work_path, \$reject_file_path \n         or die "vcp: digest check failed for ", \$r->as_string,\n\x09 "\\nvcp: failed to leave copy in '\$reject_file_path': \$!\\n" ;\n\n      die "vcp: digest check failed for ", \$r->as_string,\n\x09 "\\nvcp: copy left in '\$reject_file_path'\\n",\n         "got      digest: \$reconstituted_digest\\n",\n         "expected digest: \$original_digest\\n";\n   }\n}\n\n\n## Having this and no sub rev_characters causes the parser to accumulate\n## content.\nsub end_rev {\n   my VCP::Source::revml \$self = shift ;\n\n   \$self->revs->add( \$self->{REV} )  unless \$self->{REV}->is_base_rev ;\n\n   ## Release this rev.\n   \$self->{REV} = undef ;\n}\n\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nCopyright (c) 2000, 2001, 2002 Perforce Software, Inc.\nAll rights reserved.\n\nSee L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAACI
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACJ, "lib/VCP/Source/cvs.pm" }
package VCP::Source::cvs ;\n\n=head1 NAME\n\nVCP::Source::cvs - A CVS repository source\n\n=head1 SYNOPSIS\n\n   vcp cvs:module/... -d ">=2000-11-18 5:26:30" <dest>\n                                  # All file revs newer than a date/time\n\n   vcp cvs:module/... -r foo      # all files in module and below labelled foo\n   vcp cvs:module/... -r foo:     # All revs of files labelled foo and newer,\n                                  # including files not tagged with foo.\n   vcp cvs:module/... -r 1.1:1.10 # revs 1.1..1.10\n   vcp cvs:module/... -r 1.1:     # revs 1.1 and up\n\n   ## NOTE: Unlike cvs, vcp requires spaces after option letters.\n\n=head1 DESCRIPTION\n\nSource driver enabling L<C<vcp>|vcp> to extract versions form a cvs\nrepository.\n\nThis doesn't deal with branches yet (at least not intentionally).  That\nwill require a bit of Deep Thought.\n\nThe source specification for CVS looks like:\n\n    cvs:cvsroot/filespec [<options>]\n\nwhere the C<cvsroot> is passed to C<cvs> with the C<-d> option if\nprovided (C<cvsroot> is optional if the environment variable C<CVSROOT>\nis set) and the filespec and E<lt>optionsE<gt> determine what revisions\nto extract.\n\nC<filespec> may contain trailing wildcards, like C</a/b/...> to extract\nan entire directory tree.\n\n=head1 OPTIONS\n\n=over\n\n=item -b, --bootstrap\n\n   -b ...\n   --bootstrap=...\n   -b file1[,file2[, etc.]]\n   --bootstrap=file1[,file2[, etc. ]]\n\n(the C<...> there is three periods, a\nL<Regexp::Shellish|Regexp::Shellish> wildcard borrowed from C<p4>\npath syntax).\n\nForces bootstrap mode for an entire export (C<-b ...>) or for certain\nfiles.  Filenames may contain wildcards, see L<Regexp::Shellish> for\ndetails on what wildcards are accepted.\n\nControls how the first revision of a file is exported.  A bootstrap\nexport contains the entire contents of the first revision in the\nrevision range.  This should only be necessary when exporting for the\nfirst time.\n\nAn incremental export contains a digest of the revision preceding the\nfirst revision in the revision range, followed by a delta record between\nthat revision and the first revision in the range.  This allows the\ndestination import function to make sure that the incremental export\nbegins where the last export left off.\n\nThe default is decided on a per-file basis: if the first revision in the\nrange is revision #.1, the full contents are exported.  Otherwise an\nincremental export is done for that file.\n\nThis option is necessary when exporting only more recent revisions from\na repository.\n\n=item --cd\n\nUsed to set the CVS working directory.  VCP::Source::cvs will cd to this\ndirectory before calling cvs, and won't initialize a CVS workspace of\nit's own (normally, VCP::Source::cvs does a "cvs checkout" in a\ntemporary directory).\n\nThis is an advanced option that allows you to use a CVS workspace you\nestablish instead of letting vcp create one in a temporary directory\nsomewhere.  This is useful if you want to read from a CVS branch or if\nyou want to delete some files or subdirectories in the workspace.\n\nIf this option is a relative directory, then it is treated as relative\nto the current directory.\n\n=item -kb, -k b\n\nPass the -kb option to cvs, forces a binary checkout.  This is\nuseful when you want a text file to be checked out with Unix linends,\nor if you know that some files in the repository are not flagged as\nbinary files and should be.\n\n=item --rev-root\n\nB<Experimental>.\n\nFalsifies the root of the source tree being extracted; files will\nappear to have been extracted from some place else in the hierarchy.\nThis can be useful when exporting RevML, the RevML file can be made\nto insert the files in to a different place in the eventual destination\nrepository than they existed in the source repository.\n\nThe default C<rev-root> is the file spec up to the first path segment\n(directory name) containing a wildcard, so\n\n   cvs:/a/b/c...\n\nwould have a rev-root of C</a/b>.\n\nIn direct repository-to-repository transfers, this option should not be\nnecessary, the destination filespec overrides it.\n\n=item -r\n\n   -r v_0_001:v_0_002\n   -r v_0_002:\n\nPassed to C<cvs log> as a C<-r> revision specification. This corresponds\nto the C<-r> option for the rlog command, not either of the C<-r>\noptions for the cvs command. Yes, it's confusing, but 'cvs log' calls\n'rlog' and passes the options through.\n\nIMPORTANT: When using tags to specify CVS file revisions, it would ordinarily\nbe the case that a number of unwanted revisions would be selected.  This is\nbecause the behavior of the cvs log command dumps the entire log history for\nany files that do not contain the tag. VCP captures the histories of such files\nand ignores all revisions that are older or newer than any files that match the\ntags.\n\nBe cautious using HEAD as the end of a revision range, this seems to cause the\ndelete actions for files deleted in the last revision to not be noticed. Not\nsure why.\n\nOne of C<-r> or L<C<-d>|-d> must be specified.\n\n=item C<-d>\n\n   -d "2000-11-18 5:26:30<="\n\nPassed to 'cvs log' as a C<-d> date specification. \n\nWARNING: if this string doesn't contain a '>' or '<', you're probably doing\nsomething wrong, since you're not specifying a range.  vcp may warn about this\nin the future.\n\nOne of L<C<-r>|-r> or C<-d> must be specified.\n\n=back\n\n=head2 Files that aren't tagged\n\nCVS has one peculiarity that this driver works around.\n\nIf a file does not contain the tag(s) used to select the source files,\nC<cvs log> outputs the entire life history of that file.  We don't want\nto capture the entire history of such files, so L<VCP::Source::cvs> goes\nignores any revisions before and after the oldest and newest tagged file\nin the range.\n\n=head1 LIMITATIONS\n\n   "What we have here is a failure to communicate!"\n       - The warden in Cool Hand Luke\n\nCVS does not try to protect itself from people checking in things that\nlook like snippets of CVS log file: they come out exactly like they\nwent in, confusing the log file parser.\n\nSo, if a repository contains messages in the log file that look like the \noutput from some other "cvs log" command, things will likely go awry.\n\nAt least one cvs repository out there has multiple revisions of a single file\nwith the same rev number.  The second and later revisions with the same rev\nnumber are ignored with a warning like "Can't add same revision twice:...".\n\n=cut\n\n\$VERSION = 1.2 ;\n\n# Removed docs for -f, since I now think it's overcomplicating things...\n#Without a -f This will normally only replicate files which are tagged.  This\n#means that files that have been added since, or which are missing the tag for\n#some reason, are ignored.\n#\n#Use the L</-f> option to force files that don't contain the tag to be\n#=item -f\n#\n#This option causes vcp to attempt to export files that don't contain a\n#particular tag but which occur in the date range spanned by the revisions\n#specified with -r. The typical use is to get all files from a certain\n#tag to now.\n#\n#It does this by exporting all revisions of files between the oldest and\n#newest files that the -r specified.  Without C<-f>, these would\n#be ignored.\n#\n#It is an error to specify C<-f> without C<-r>.\n#\n#exported.\n\nuse strict ;\n\nuse Carp ;\nuse Getopt::Long ;\nuse Regexp::Shellish qw( :all ) ;\nuse VCP::Rev ;\nuse VCP::Debug ':debug' ;\nuse VCP::Source ;\nuse VCP::Utils::cvs ;\n\nuse base qw( VCP::Source VCP::Utils::cvs ) ;\nuse fields (\n   'CVS_CUR',            ## The current change number being processed\n   'CVS_BOOTSTRAP',      ## Forces bootstrap mode\n   'CVS_IS_INCREMENTAL', ## Hash of filenames, 0->bootstrap, 1->incremental\n   'CVS_INFO',           ## Results of the 'cvs --version' command and CVSROOT\n   'CVS_LABEL_CACHE',    ## ->{\$name}->{\$rev} is a list of labels for that rev\n   'CVS_LABELS',         ## Array of labels from 'p4 labels'\n   'CVS_MAX',            ## The last change number needed\n   'CVS_MIN',            ## The first change number needed\n   'CVS_REV_SPEC',       ## The revision spec to pass to `cvs log`\n   'CVS_DATE_SPEC',      ## The date spec to pass to `cvs log`\n   'CVS_FORCE_MISSING',  ## Set if -r was specified.\n\n   'CVS_K_OPTION',       ## Which of the CVS/RCS "-k" options to use, if any\n\n   'CVS_LOG_CARRYOVER',  ## The unparsed bit of the log file\n   'CVS_LOG_FILE_DATA',  ## Data about all revs of a file from the log file\n   'CVS_LOG_STATE',      ## Parser state machine state\n   'CVS_LOG_REV',        ## The revision being parsed (a hash)\n\n   'CVS_NAME_REP_NAME',  ## A mapping of repository names to names, used to\n                         ## figure out what files to ignore when a cvs log\n\x09\x09\x09 ## goes ahead and logs a file which doesn't match\n\x09\x09\x09 ## the revisions we asked for.\n\n   'CVS_NEEDS_BASE_REV', ## What base revisions are needed.  Base revs are\n                         ## needed for incremental (ie non-bootstrap) updates,\n\x09\x09\x09 ## which is decided on a per-file basis by looking\n\x09\x09\x09 ## at VCP::Source::is_bootstrap_mode( \$file ) and\n\x09\x09\x09 ## the file's rev number (ie does it end in .1).\n   'CVS_SAW_EQUALS',     ## Set when we see the ==== lines in log file [1]\n) ;\n\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Source::cvs \$self = \$class->SUPER::new( \@_ ) ;\n\n   ## Parse the options\n   my ( \$spec, \$options ) = \@_ ;\n\n   \$self->parse_repo_spec( \$spec ) ;\n\n   my \$work_dir ;\n   my \$rev_root ;\n   my \$rev_spec ;\n   my \$date_spec ;\n   #   my \$force_missing ;\n\n   GetOptions(\n      "b|bootstrap:s"   => sub {\n\x09 my ( \$name, \$val ) = \@_ ;\n\x09 \$self->{CVS_BOOTSTRAP} = \$val eq ""\n\x09    ? [ compile_shellish( "..." ) ]\n\x09    : [ map compile_shellish( \$_ ), split /,+/, \$val ] ;\n      },\n      "cd=s"          => \\\$work_dir,\n      "rev-root=s"    => \\\$rev_root,\n      "r=s"           => \\\$rev_spec,\n      "d=s"           => \\\$date_spec,\n      "k=s"           => sub { warn \$self->{CVS_K_OPTION} = \$_[1] } ,\n      "kb"            => sub { warn \$self->{CVS_K_OPTION} = "b" } ,\n#      "f+"            => \\\$force_missing,\n   ) or \$self->usage_and_exit ;\n\n   unless ( defined \$rev_spec || defined \$date_spec ) {\n      print STDERR "Revision (-r) or date (-d) specification missing\\n" ;\n      \$self->usage_and_exit ;\n   }\n\n#   if ( \$force_missing && ! defined \$rev_spec ) {\n#      print STDERR\n#         "Force missing (-f) may not be used without a revision spec (-r)\\n" ;\n#      \$self->usage_and_exit ;\n#   }\n#\n   my \$files = \$self->repo_filespec ;\n   unless ( defined \$rev_root ) {\n      \$self->deduce_rev_root( \$files ) ;\n   }\n#   else {\n#      \$files = "\$rev_root/\$files" ;\n#   }\n#\n### TODO: Figure out whether we should make rev_root merely set the rev_root\n### in the header.  I think we probably should do it that way, as it's more\n### flexible and less confusing.\n\n   my \$recurse = \$files =~ s{/\\.\\.\\.\$}{} ;\n\n   ## Don't normalize the filespec.\n   \$self->repo_filespec( \$files ) ;\n\n   \$self->rev_spec( \$rev_spec ) ;\n   \$self->date_spec( \$date_spec ) ;\n   \$self->force_missing( defined \$rev_spec ) ;\n#   \$self->force_missing( \$force_missing ) ;\n\n   ## Make sure the cvs command is available\n   \$self->command_stderr_filter(\n      qr{^\n         (?:cvs\\s\n             (?:\n                (?:server|add|remove):\\suse\\s'cvs\\scommit'\\sto.*\n                |tag.*(?:waiting for.*lock|obtained_lock).*\n             )\n        )\\n\n      }x\n   ) ;\n\n   ## Doing a CVS command or two here also forces cvs to be found in new(),\n   ## or an exception will be thrown.\n   \$self->cvs( ['--version' ], \\\$self->{CVS_INFO} ) ;\n\n   ## This does a checkout, so we'll blow up quickly if there's a problem.\n   unless ( defined \$work_dir ) {\n      \$self->create_cvs_workspace ;\n   }\n   else {\n      \$self->work_root( File::Spec->rel2abs( \$work_dir ) ) ; \n      \$self->command_chdir( \$self->work_path ) ;\n   }\n\n   return \$self ;\n}\n\n\nsub is_incremental {\n   my VCP::Source::cvs \$self= shift ;\n   my ( \$file, \$first_rev ) = \@_ ;\n\n   my \$bootstrap_mode = substr( \$first_rev, -2 ) eq ".1"\n      || ( \$self->{CVS_BOOTSTRAP}\n         && grep \$file =~ \$_, \@{\$self->{CVS_BOOTSTRAP}}\n      ) ;\n\n   return \$bootstrap_mode ? 0 : "incremental" ;\n}\n\n\nsub rev_spec {\n   my VCP::Source::cvs \$self = shift ;\n   \$self->{CVS_REV_SPEC} = shift if \@_ ;\n   return \$self->{CVS_REV_SPEC} ;\n}\n\n\nsub rev_spec_cvs_option {\n   my VCP::Source::cvs \$self = shift ;\n   return defined \$self->rev_spec? "-r" . \$self->rev_spec : (),\n}\n\n\nsub date_spec {\n   my VCP::Source::cvs \$self = shift ;\n   \$self->{CVS_DATE_SPEC} = shift if \@_ ;\n   return \$self->{CVS_DATE_SPEC} ;\n}\n\n\nsub date_spec_cvs_option {\n   my VCP::Source::cvs \$self = shift ;\n   return defined \$self->date_spec ? "-d" . \$self->date_spec : (),\n}\n\n\nsub force_missing {\n   my VCP::Source::cvs \$self = shift ;\n   \$self->{CVS_FORCE_MISSING} = shift if \@_ ;\n   return \$self->{CVS_FORCE_MISSING} ;\n}\n\n\nsub denormalize_name {\n   my VCP::Source::cvs \$self = shift ;\n   return '/' . \$self->SUPER::denormalize_name( \@_ ) ;\n}\n\n\nsub handle_header {\n   my VCP::Source::cvs \$self = shift ;\n   my ( \$header ) = \@_ ;\n\n   \$header->{rep_type} = 'cvs' ;\n   \$header->{rep_desc} = \$self->{CVS_INFO} ;\n   \$header->{rev_root} = \$self->rev_root ;\n\n   \$self->dest->handle_header( \$header ) ;\n   return ;\n}\n\n\nsub get_rev {\n   my VCP::Source::cvs \$self = shift ;\n\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\n   my \$wp = \$self->work_path( "revs", \$r->name, \$r->rev_id ) ;\n   \$r->work_path( \$wp ) ;\n   \$self->mkpdir( \$wp ) ;\n\n   \$self->cvs( [\n\x09 "checkout",\n\x09 "-r" . \$r->rev_id,\n\x09 "-p",\n\x09 \$r->source_name,\n      ],\n      '>', \$wp,\n   ) ;\n}\n\n\nsub copy_revs {\n   my VCP::Source::cvs \$self = shift ;\n\n   \$self->{CVS_LOG_STATE} = '' ;\n   \$self->{CVS_LOG_CARRYOVER} = '' ;\n   \$self->revs( VCP::Revs->new ) ;\n\n   ## We need to watch STDERR for messages like\n   ## cvs log: warning: no revision `ch_3' in `/home/barries/src/revengine/tmp/cvsroot/foo/add/f4,v'\n   ## Files that cause this warning need to have some revisions ignored because\n   ## cvs log will emit the entire log for these files in addition to \n   ## the warning, including revisions checked in before the first tag and\n   ## after the last tag.\n   my \$tmp_f = \$self->command_stderr_filter ;\n   my %ignore_files ;\n   my \$ignore_file = sub {\n      exists \$ignore_files{\$self->{CVS_NAME_REP_NAME}->{\$_[0]}} ;\n   } ;\n\n   ## This regexp needs to gobble newlines.\n   \$self->command_stderr_filter( sub {\n      my ( \$err_text_ref ) = \@_ ;\n      \$\$err_text_ref =~ s\@\n         ^cvs(?:\\.exe)?\\slog:\\swarning:\\sno\\srevision\\s.*?\\sin\\s[`"'](.*)[`"']\\r?\\n\\r?\n      \@\n         \$ignore_files{\$1} = undef ;\n\x09 '' ;\n      \@gxmei ;\n   } ) ; ## `\n\n   \$self->{CVS_LOG_FILE_DATA} = {} ;\n   \$self->{CVS_LOG_REV} = {} ;\n   \$self->{CVS_SAW_EQUALS} = 0 ;\n   # The log command must be run in the directory above the work root,\n   # since we pass in the name of the workroot dir as the first dir in\n   # the filespec.\n   my \$tmp_command_chdir = \$self->command_chdir ;\n   \$self->command_chdir( \$self->tmp_dir( "co" ) ) ;\n   \$self->cvs( [\n         "log",\n\x09 \$self->rev_spec_cvs_option,\n\x09 \$self->date_spec_cvs_option,\n\x09 length \$self->repo_filespec ? \$self->repo_filespec : (),\n      ],\n      '>', sub { \$self->parse_log_file( \@_ ) },\n   ) ;\n\n   \$self->command_chdir( \$tmp_command_chdir ) ;\n   \$self->command_stderr_filter( \$tmp_f ) ;\n\n   my \$revs = \$self->revs ;\n\n   ## Figure out the time stamp range for force_missing calcs.\n   my ( \$min_rev_spec_time, \$max_rev_spec_time ) ;\n   if ( \$self->force_missing ) {\n      ## If the rev_spec is /:\$/ || /^:/, we tweak the range ends.\n      my \$max_time = 0 ;\n      \$max_rev_spec_time = 0 ;\n      \$min_rev_spec_time = 0 if substr( \$self->rev_spec, 0, 1 ) eq ':' ;\n      for my \$r ( \@{\$revs->as_array_ref} ) {\n         next if \$r->is_base_rev ;\n         my \$t = \$r->time ;\n         \$max_time = \$t if \$t >= \$max_rev_spec_time ;\n\x09 next if \$ignore_file->( \$r->source_name ) ;\n         \$min_rev_spec_time = \$t if \$t <= ( \$min_rev_spec_time || \$t ) ;\n         \$max_rev_spec_time = \$t if \$t >= \$max_rev_spec_time ;\n      }\n#      \$max_rev_spec_time = \$max_time if substr( \$self->rev_spec, -1 ) eq ':' ;\n      \$max_rev_spec_time = undef if substr( \$self->rev_spec, -1 ) eq ':' ;\n\n      debug(\n\x09 "vcp: including files in ['",\n\x09 localtime( \$min_rev_spec_time ),\n\x09 "'..'",\n\x09 defined \$max_rev_spec_time\n\x09    ? localtime( \$max_rev_spec_time )\n\x09    : "<end_of_time>",\n\x09 "']"\n      ) if debugging \$self ;\n   }\n\n   ## Remove extra revs from queue by copying from \$revs to \$self->revs().\n   ## TODO: Debug simultaneous use of -r and -d, since we probably are\n   ## blowing away revs that -d included that -r didn't.  I haven't\n   ## checked to see if we do or don't blow said revs away.\n   my %oldest_revs ;\n   \$self->revs( VCP::Revs->new ) ;\n   for my \$r ( \@{\$revs->as_array_ref} ) {\n      if ( \$ignore_file->( \$r->source_name ) ) {\n\x09 if (\n\x09       (!defined \$min_rev_spec_time || \$r->time >= \$min_rev_spec_time)\n\x09    && (!defined \$max_rev_spec_time || \$r->time <= \$max_rev_spec_time)\n\x09 ) {\n\x09    debug(\n\x09       "vcp: including file ", \$r->as_string\n\x09    ) if debugging \$self ;\n\x09 }\n\x09 else {\n\x09    debug(\n\x09       "vcp: ignoring file ", \$r->as_string,\n\x09       ": no revisions match -r"\n\x09    ) if debugging \$self ;\n\x09    next ;\n\x09 }\n      }\n      ## Because of the order of the log file, the last rev set is always\n      ## the first rev in the range.\n      \$oldest_revs{\$r->source_name} = \$r ;\n      \$self->revs->add( \$r ) ;\n   }\n   \$revs = \$self->revs ;\n\n   ## Add in base revs\n   for my \$fn ( keys %oldest_revs ) {\n      my \$r = \$oldest_revs{\$fn} ;\n      my \$rev_id = \$r->rev_id ;\n      if ( \$self->is_incremental( \$fn, \$rev_id ) ) {\n\x09 \$rev_id =~ s{(\\d+)\$}{\$1-1}e ;\n         \$revs->add(\n\x09    VCP::Rev->new(\n\x09       source_name => \$r->source_name,\n\x09       name        => \$r->name,\n\x09       rev_id      => \$rev_id,\n\x09       type        => \$r->type,\n\x09    )\n\x09 )\n      }\n   }\n\n   \$self->dest->sort_revs( \$self->revs ) ;\n\n   my VCP::Rev \$r ;\n   while ( \$r = \$self->revs->shift ) {\n      \$self->get_rev( \$r ) ;\n      \$self->dest->handle_rev( \$r ) ;\n   }\n}\n\n\n# Here's a typical file log entry.\n#\n###############################################################################\n#\n#RCS file: /var/cvs/cvsroot/src/Eesh/Changes,v\n#Working file: src/Eesh/Changes\n#head: 1.3\n#branch:\n#locks: strict\n#access list:\n#symbolic names:\n#        Eesh_003_000: 1.3\n#        Eesh_002_000: 1.2\n#        Eesh_000_002: 1.1\n#keyword substitution: kv\n#total revisions: 3;     selected revisions: 3\n#description:\n#----------------------------\n#revision 1.3\n#date: 2000/04/22 05:35:27;  author: barries;  state: Exp;  lines: +5 -0\n#*** empty log message ***\n#----------------------------\n#revision 1.2\n#date: 2000/04/21 17:32:14;  author: barries;  state: Exp;  lines: +22 -0\n#Moved a bunch of code from eesh, then deleted most of it.\n#----------------------------\n#revision 1.1\n#date: 2000/03/24 14:54:10;  author: barries;  state: Exp;\n#*** empty log message ***\n#=============================================================================\n###############################################################################\n\nsub parse_log_file {\n   my ( \$self, \$input ) = \@_ ;\n\n   if ( defined \$input ) {\n      \$self->{CVS_LOG_CARRYOVER} .= \$input ;\n   }\n   else {\n      ## There can only be leftovers if they don't end in a "\\n".  I've never\n      ## seen that happen, but given large comments, I could be surprised...\n      \$self->{CVS_LOG_CARRYOVER} .= "\\n" if length \$self->{CVS_LOG_CARRYOVER} ;\n   }\n\n   my \$store_rev = sub {\n#      my ( \$is_oldest ) = \@_ ;\n      return unless keys %{\$self->{CVS_LOG_REV}} ;\n\n      \$self->{CVS_LOG_REV}->{MESSAGE} = ''\n         if \$self->{CVS_LOG_REV}->{MESSAGE} eq '*** empty log message ***' ;\n\n      \$self->{CVS_LOG_REV}->{MESSAGE} =~ s/\\r\\n|\\n\\r/\\n/g ;\n\n#debug map "\$_ => \$self->{CVS_LOG_FILE_DATA}->{\$_},", sort keys %{\$self->{CVS_LOG_FILE_DATA}} ;\n      \$self->_add_rev( \$self->{CVS_LOG_FILE_DATA}, \$self->{CVS_LOG_REV} ) ;\n\n#      if ( \$is_oldest ) {\n#         if ( \n#\x09    \$self->is_incremental(\n#\x09       \$self->{CVS_LOG_FILE_DATA}->{WORKING},\n#\x09       \$self->{CVS_LOG_REV}->{REV}\n#\x09    )\n#\x09 ) {\n#\x09    \$self->{CVS_LOG_REV}->{REV} =~ s{(\\d+)\$}{\$1-1}e ;\n#\n#\x09    \$self->_add_rev(\n#\x09       \$self->{CVS_LOG_FILE_DATA},\n#\x09       \$self->{CVS_LOG_REV},\n#\x09       "is base rev"\n#\x09    );\n#\x09 }\n#      }\n      \$self->{CVS_LOG_REV} = {} ;\n   } ;\n\n   local \$_ ;\n\n   ## DOS, Unix, Mac lineends spoken here.\n   while ( \$self->{CVS_LOG_CARRYOVER} =~ s/^(.*(?:\\r\\n|\\n\\r|\\n))// ) {\n      \$_ = \$1 ;\n\n      ## [1] See bottom of file for a footnote explaining this delaying of \n      ## clearing CVS_LOG_FILE_DATA and CVS_LOG_STATE until we see\n      ## a ========= line followed by something other than a -----------\n      ## line.\n      ## TODO: Move to a state machine design, hoping that all versions\n      ## of CVS emit similar enough output to not trip it up.\n\n      ## TODO: BUG: Turns out that some CVS-philes like to put text\n      ## snippets in their revision messages that mimic the equals lines\n      ## and dash lines that CVS uses for delimiters!!\n\n   PLEASE_TRY_AGAIN:\n      if ( /^===========================================================*\$/ ) {\n         \$store_rev->() ;# "is oldest" ) ;\n\x09 \$self->{CVS_SAW_EQUALS} = 1 ;\n\x09 next ;\n      }\n\n      if ( /^----------------------------*\$/ ) {\n         \$store_rev->() unless \$self->{CVS_SAW_EQUALS} ;\n\x09 \$self->{CVS_SAW_EQUALS} = 0 ;\n\x09 \$self->{CVS_LOG_STATE} = 'rev' ;\n\x09 next ;\n      }\n\n      if ( \$self->{CVS_SAW_EQUALS} ) {\n\x09 \$self->{CVS_LOG_FILE_DATA} = {} ;\n\x09 \$self->{CVS_LOG_STATE} = '' ;\n\x09 \$self->{CVS_SAW_EQUALS} = 0 ;\n      }\n\n      unless ( \$self->{CVS_LOG_STATE} ) {\n\x09 if (\n\x09    /^(RCS file|Working file|head|branch|locks|access list|keyword substitution):\\s*(.*)/i\n\x09 ) {\n#warn uc( (split /\\s+/, \$1 )[0] ), "/", \$1, ": ", \$2, "\\n" ;\n\x09    \$self->{CVS_LOG_FILE_DATA}->{uc( (split /\\s+/, \$1 )[0] )} = \$2 ;\n#\$DB::single = 1 if /keyword/ && \$self->{CVS_LOG_FILE_DATA}->{WORKING} =~ /Makefile/ ;\n\x09 }\n\x09 elsif ( /^total revisions:\\s*([^;]*)/i ) {\n\x09    \$self->{CVS_LOG_FILE_DATA}->{TOTAL} = \$1 ;\n\x09    if ( /selected revisions:\\s*(.*)/i ) {\n\x09       \$self->{CVS_LOG_FILE_DATA}->{SELECTED} = \$1 ;\n\x09    }\n\x09 }\n\x09 elsif ( /^symbolic names:/i ) {\n\x09    \$self->{CVS_LOG_STATE} = 'tags' ;\n\x09    next ;\n\x09 }\n\x09 elsif ( /^description:/i ) {\n\x09    \$self->{CVS_LOG_STATE} = 'desc' ;\n\x09    next ;\n\x09 }\n\x09 else {\n\x09    carp "Unhandled CVS log line '\$_'" if /\\S/ ;\n\x09 }\n      }\n      elsif ( \$self->{CVS_LOG_STATE} eq 'tags' ) {\n\x09 if ( /^\\S/ ) {\n\x09    \$self->{CVS_LOG_STATE} = '' ;\n\x09    goto PLEASE_TRY_AGAIN ;\n\x09 }\n\x09 my ( \$tag, \$rev ) = m{(\\S+):\\s+(\\S+)} ;\n\x09 unless ( defined \$tag ) {\n\x09    carp "Can't parse tag from CVS log line '\$_'" ;\n\x09    \$self->{CVS_LOG_STATE} = '' ;\n\x09    next ;\n\x09 }\n\x09 \$self->{CVS_LOG_FILE_DATA}->{TAGS}->{\$tag} = \$rev ; \n\x09 push( \@{\$self->{CVS_LOG_FILE_DATA}->{RTAGS}->{\$rev}}, \$tag ) ; \n      }\n      elsif ( \$self->{CVS_LOG_STATE} eq 'rev' ) {\n\x09 ( \$self->{CVS_LOG_REV}->{REV} ) = m/([\\d.]+)/ ;\n\x09 \$self->{CVS_LOG_STATE} = 'rev_meta' ;\n\x09 next ;\n      }\n      elsif ( \$self->{CVS_LOG_STATE} eq 'rev_meta' ) {\n\x09 for ( split /;\\s*/ ) {\n\x09    my ( \$key, \$value ) = m/(\\S+):\\s+(.*?)\\s*\$/ ;\n\x09    \$self->{CVS_LOG_REV}->{uc(\$key)} = \$value ;\n\x09 }\n\x09 \$self->{CVS_LOG_STATE} = 'rev_message' ;\n\x09 next ;\n      }\n      elsif ( \$self->{CVS_LOG_STATE} eq 'rev_message' ) {\n\x09 \$self->{CVS_LOG_REV}->{MESSAGE} .= \$_ ;\n      }\n   }\n\n   ## Never, ever forget the last rev.  "Wait for me! Wait for me!"\n   ## Most of the time, this should not be a problem: cvs log puts a\n   ## line of "=" at the end.  But just in case I don't know of a\n   ## funcky condition where that might not happen...\n   unless ( defined \$input ) {\n      \$store_rev->() ; # "is oldest" ) ;\n      \$self->{CVS_LOG_REV} = undef ;\n      \$self->{CVS_LOG_FILE_DATA} = undef ;\n   }\n}\n\n\n# Here's a (probably out-of-date by the time you read this) dump of the args\n# for _add_rev:\n#\n###############################################################################\n#\$file = {\n#  'WORKING' => 'src/Eesh/eg/synopsis',\n#  'SELECTED' => '2',\n#  'LOCKS' => 'strict',\n#  'TOTAL' => '2',\n#  'ACCESS' => '',\n#  'RCS' => '/var/cvs/cvsroot/src/Eesh/eg/synopsis,v',\n#  'KEYWORD' => 'kv',\n#  'RTAGS' => {\n#    '1.1' => [\n#      'Eesh_003_000',\n#      'Eesh_002_000'\n#    ]\n#  },\n#  'HEAD' => '1.2',\n#  'TAGS' => {\n#    'Eesh_002_000' => '1.1',\n#    'Eesh_003_000' => '1.1'\n#  },\n#  'BRANCH' => ''\n#};\n#\$rev = {\n#  'DATE' => '2000/04/21 17:32:16',\n#  'MESSAGE' => 'Moved a bunch of code from eesh, then deleted most of it.\n#',\n#  'STATE' => 'Exp',\n#  'AUTHOR' => 'barries',\n#  'REV' => '1.1'\n#};\n###############################################################################\n\nsub _add_rev {\n   my VCP::Source::cvs \$self = shift ;\n   my ( \$file_data, \$rev_data, \$is_base_rev ) = \@_ ;\n\n   my \$norm_name = \$self->normalize_name( \$file_data->{WORKING} ) ;\n\n   my \$action = \$rev_data->{STATE} eq "dead" ? "delete" : "edit" ;\n\n   my \$type = \$file_data->{KEYWORD} =~ /[o|b]/ ? "binary" : "text" ;\n\n#debug map "\$_ => \$rev_data->{\$_}, ", sort keys %{\$rev_data} ;\n\n   my VCP::Rev \$r = VCP::Rev->new(\n      source_name => \$file_data->{WORKING},\n      name        => \$norm_name,\n      rev_id      => \$rev_data->{REV},\n      type        => \$type,\n#      ! \$is_base_rev\n#\x09 ? (\n\x09    action      => \$action,\n\x09    time        => \$self->parse_time( \$rev_data->{DATE} ),\n\x09    user_id     => \$rev_data->{AUTHOR},\n\x09    comment     => \$rev_data->{MESSAGE},\n\x09    state       => \$rev_data->{STATE},\n\x09    labels      => \$file_data->{RTAGS}->{\$rev_data->{REV}},\n#\x09 )\n#\x09 : (),\n   ) ;\n\n   \$self->{CVS_NAME_REP_NAME}->{\$file_data->{WORKING}} = \$file_data->{RCS} ;\n   eval {\n      \$self->revs->add( \$r ) ;\n   } ;\n   if ( \$\@ ) {\n      if ( \$\@ =~ /Can't add same revision twice/ ) {\n         warn \$\@ ;\n      }\n      else {\n         die \$\@ ;\n      }\n   }\n}\n\n## FOOTNOTES:\n# [1] :pserver:guest\@cvs.tigris.org:/cvs hass some goofiness like:\n#----------------------------\n#revision 1.12\n#date: 2000/09/05 22:37:42;  author: thom;  state: Exp;  lines: +8 -4\n#\n#merge revision history for cvspatches/root/log_accum.in\n#----------------------------\n#revision 1.11\n#date: 2000/08/30 01:29:38;  author: kfogel;  state: Exp;  lines: +8 -4\n#(derive_subject_from_changes_file): use \\t to represent tab\n#characters, not the incorrect \\i.\n#=============================================================================\n#----------------------------\n#revision 1.11\n#date: 2000/09/05 22:37:32;  author: thom;  state: Exp;  lines: +3 -3\n#\n#merge revision history for cvspatches/root/log_accum.in\n#----------------------------\n#revision 1.10\n#date: 2000/07/29 01:44:06;  author: kfogel;  state: Exp;  lines: +3 -3\n#Change all "Tigris" ==> "Helm" and "tigris" ==> helm", as per Daniel\n#Rall's email about how the tigris path is probably obsolete.\n#=============================================================================\n#----------------------------\n#revision 1.10\n#date: 2000/09/05 22:37:23;  author: thom;  state: Exp;  lines: +22 -19\n#\n#merge revision history for cvspatches/root/log_accum.in\n#----------------------------\n#revision 1.9\n#date: 2000/07/29 01:12:26;  author: kfogel;  state: Exp;  lines: +22 -19\n#tweak derive_subject_from_changes_file()\n#=============================================================================\n#----------------------------\n#revision 1.9\n#date: 2000/09/05 22:37:13;  author: thom;  state: Exp;  lines: +33 -3\n#\n#merge revision history for cvspatches/root/log_accum.in\n#\n\n=head1 SEE ALSO\n\nL<VCP::Dest::cvs>, L<vcp>, L<VCP::Process>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nCopyright (c) 2000, 2001, 2002 Perforce Software, Inc.\nAll rights reserved.\n\nSee L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACJ
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACK, "lib/VCP/Utils/cvs.pm" }
package VCP::Utils::cvs ;\n\n=head1 NAME\n\nVCP::Utils::cvs - utilities for dealing with the cvs command\n\n=head1 SYNOPSIS\n\n   use VCP::Utils::cvs ;\n\n=head1 DESCRIPTION\n\nA mix-in class providing methods shared by VCP::Source::cvs and VCP::Dest::cvs,\nmostly wrappers for calling the cvs command.\n\n=cut\n\nuse strict ;\n\nuse Carp ;\nuse VCP::Debug qw( debug debugging ) ;\nuse File::Spec ;\nuse File::Temp qw( mktemp ) ;\nuse POSIX ':sys_wait_h' ;\n\n=head1 METHODS\n\n=item cvs\n\nCalls the cvs command with the appropriate cvsroot option.\n\n=cut\n\nsub cvs {\n   my \$self = shift ;\n\n   my \$args = shift ;\n\n   unshift \@\$args, "-d" . \$self->repo_server\n      if defined \$self->repo_server;\n\n   return \$self->run_safely( [ qw( cvs -Q -z9 ), \@\$args ], \@_ ) ;\n}\n\n=item create_cvs_workspace\n\nCreates a temp dir named "co" for C<cvs> to work in, checks out the module\nthere, and sets the work root and cvs working dir to that directory.\n\n=cut\n\nsub create_cvs_workspace {\n   my \$self = shift ;\n\n   confess "Can't create_workspace twice" unless \$self->none_seen ;\n\n   ## establish_workspace in a directory named "co" for "checkout". This is\n   ## so that VCP::Source::cvs can use a different directory to contain\n   ## the revs, since all the revs need to be kept around until the VCP::Dest\n   ## is through with them.\n   \$self->command_chdir( \$self->tmp_dir( "co" ) ) ;\n   my ( \$module ) = \$self->rev_root =~ m{^/*(.*?)(/|\\Z)} ;\n   die "Unable to parse cvs module name from '", \$self->rev_root, "'\\n"\n      unless defined \$module and length \$module ;\n   \$self->cvs( [ 'checkout', \$module ] ) ;\n   \$self->work_root( \$self->tmp_dir( "co", \$self->rev_root ) ) ;\n   \$self->command_chdir( \$self->tmp_dir( "co", \$self->rev_root ) ) ;\n}\n\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAACK
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACL, "lib/VCP/Utils/vss.pm" }
package VCP::Utils::vss ;\r\n\r\n=head1 NAME\r\n\r\nVCP::Utils::vss - utilities for dealing with the vss command\r\n\r\n=head1 SYNOPSIS\r\n\r\n   use VCP::Utils::vss ;\r\n\r\n=head1 DESCRIPTION\r\n\r\nA mix-in class providing methods shared by VCP::Source::vss and VCP::Dest::vss,\r\nmostly wrappers for calling the vss command.\r\n\r\n=cut\r\n\r\nuse strict ;\r\n\r\nuse Carp ;\r\nuse VCP::Debug qw( debug debugging ) ;\r\nuse File::Spec ;\r\nuse File::Temp qw( mktemp ) ;\r\nuse POSIX ':sys_wait_h' ;\r\nuse Regexp::Shellish qw( compile_shellish );\r\n\r\n=head1 METHODS\r\n\r\n=item ss\r\n\r\nCalls the vss command with the appropriate vssroot option.\r\n\r\nTODO: See if we can use two different users to do vss->vss.  Not sure if VSS\r\nsets the cp and workfold per machine or per user.\r\n\r\n=cut\r\n\r\nsub ss {\r\n   my \$self = shift ;\r\n\r\n   my \$args = shift ;\r\n\r\n   my \$user = \$self->repo_user;\r\n   my \@Y_arg;\r\n   push \@Y_arg, "-Y\$user" if defined \$user and length \$user;\r\n\r\n   local \$ENV{SSPWD} = \$self->repo_password if defined \$self->repo_password;\r\n\r\n   my \@I_arg;\r\n\r\n   push \@I_arg, "-I-" unless grep /^-I/, \@\$args;\r\n\r\n   \$self->run_safely(\r\n      [ qw( ss ), \@\$args, \@Y_arg, \@I_arg ], \@_\r\n   ) ;\r\n\r\n   return;\r\n}\r\n\r\n=item create_vss_workspace\r\n\r\nCreates a temporary directory.\r\n\r\n=cut\r\n\r\nsub create_vss_workspace {\r\n   my \$self = shift ;\r\n\r\n   confess "Can't create_workspace twice" unless \$self->none_seen ;\r\n\r\n   ## establish_workspace in a directory named "co" for "checkout". This is\r\n   ## so that VCP::Source::vss can use a different directory to contain\r\n   ## the revs, since all the revs need to be kept around until the VCP::Dest\r\n   ## is through with them.\r\n   my \$workspace = \$self->tmp_dir;\r\n\r\n   \$self->mkdir( \$workspace );\r\n}\r\n\r\n\r\n=item get_vss_file_list\r\n\r\nRetrieves a list of all files and directories under a particular\r\npath.  We need this so we can tell what dirs and files need to be added.\r\n\r\n=cut\r\n\r\nsub _scan_for_files {\r\n   my \$self = shift;\r\n   my ( \$path, \$type, \$filelist ) = \@_;\r\n\r\n   \$path = \$self->repo_filespec\r\n      unless defined \$path;\r\n   \$path =~ s{^\\\$[\\\\/]}{};\r\n\r\n   my \$path_re = compile_shellish( \$path );\r\n\r\n   debug "vcp: file scan re: \$path_re" if debugging \$self ;\r\n   my \$cur_project;\r\n   for ( \@\$filelist ) {\r\n      if ( /^(|No items found.*|\\d+ item.*s.*)\$/i ) {\r\n         undef \$cur_project;\r\n         next;\r\n      }\r\n\r\n      if ( m{^\\\$/(.*):} ) {\r\n         \$cur_project = \$1;\r\n         ## Catch all project entries, because we may be importing\r\n         ## to a non-existant project inside a project that exists.\r\n         if ( length \$cur_project ) {\r\n            ## Add a slash so a preexisting dest project is found.\r\n#            if ( "\$cur_project/" =~ \$path_re ) {\r\n               my \$p = \$cur_project;\r\n#               ## Catch all parent projects.  This prevents us from\r\n#               ## creating more than need be.\r\n#               do {\r\n                  \$self->{VSS_FILES}->{\$p} = "project";\r\n#               } while \$p =~ s{/[^/]*}{} && length \$p;\r\n#            }\r\n            \$cur_project .= "/";\r\n         }\r\n         next;\r\n      }\r\n\r\n      if ( m{^\\\$(.*)} ) {\r\n         confess "undefined \\\$cur_project" unless defined \$cur_project;\r\n         ## A subproject.  note here for the fun of it; it should also\r\n         ## occur later in a \$/foo: section of it's own.\r\n         my \$pjt = "\$cur_project\$1";\r\n         \$self->{VSS_FILES}->{\$pjt} = "project"\r\n             if \$pjt =~ \$path_re;\r\n         next;\r\n      }\r\n\r\n      if ( "\$cur_project\$_" =~ \$path_re ) {\r\n         if ( defined \$self->{VSS_FILES}->{"\$cur_project\$_"} ) {\r\n            \$self->{VSS_FILES}->{"\$cur_project\$_"} .= ", \$type";\r\n         }\r\n         else {\r\n            \$self->{VSS_FILES}->{"\$cur_project\$_"} = \$type;\r\n         }\r\n         next;\r\n      }\r\n   }\r\n\r\n}\r\n\r\nsub get_vss_file_list {\r\n   my \$self = shift;\r\n   my ( \$path ) = \@_;\r\n\r\n   ## Sigh.  I tried passing in \$path to the Dir -D command and\r\n   ## ss.exe whines because \$path is rarely a deleted path RATHER\r\n   ## THAN JUST GIVING ME ALL DELETED FILES UNDER \$path!!!\r\n   ## So, we get all the output and filter it for \$path/... ourselves.\r\n   ## This does have the advantage that we can use full wildcards in\r\n   ## \$path.\r\n\r\n   \$self->{VSS_FILES} = {};\r\n\r\n   my \$ignored_stdout;\r\n   \$self->ss( [ "cp", "\\\$/" ], \\\$ignored_stdout );\r\n\r\n   \$self->_scan_for_files( \$path, "file",\r\n      [ do {\r\n         my \$filelist;\r\n         \$self->ss( [qw( Dir -R )], ">", \\\$filelist );\r\n         map { chomp; \$_ } split /^/m, \$filelist;\r\n      } ]\r\n   );\r\n\r\n   \$self->_scan_for_files( \$path, "deleted file",\r\n      [ do {\r\n         my \$filelist;\r\n         \$self->ss( [qw( Dir -R -D)], ">", \\\$filelist );\r\n         map { chomp; \$_ } split /^/m, \$filelist;\r\n      } ]\r\n   );\r\n   if ( debugging \$self ) {\r\n      require Data::Dumper;\\\r\n      debug Data::Dumper::Dumper( \$self->{VSS_FILES} );\r\n   }\r\n}\r\n\r\n=item vss_files\r\n\r\n    \@files = \$self->vss_files;\r\n\r\nreturns a list of all files (not projects) that get_vss_file_list()\r\nloaded.\r\n\r\n=cut\r\n\r\nsub vss_files {\r\n   my \$self = shift;\r\n\r\n   ## TODO: allow a pattern.  This would let us handle filespecs like\r\n   ## /a*/b*\r\n   grep index( \$self->{VSS_FILES}->{\$_}, "project" ) < 0,\r\n      keys %{\$self->{VSS_FILES}};\r\n}\r\n\r\n=item vss_file\r\n\r\n    \$self->vss_file( \$path );\r\n    \$self->vss_file( \$path, undef );      ## To mark as non-existant\r\n    \$self->vss_file( \$path, 1 );          ## To mark as existant\r\n    \$self->vss_file( \$path, "project" );  ## To mark as being a project\r\n\r\nAccepts an absolute path with or without the leading C<\$/> or C</> and\r\nreturns TRUE if it exists in CVS.\r\n\r\n=cut\r\n\r\nsub vss_file {\r\n   my \$self = shift;\r\n   my ( \$path, \$value ) = \@_;\r\n\r\n   confess unless defined \$path;\r\n\r\n   \$self->get_vss_file_list unless \$self->{VSS_FILES};\r\n\r\n   for ( \$path ) {\r\n      s{\\\\}{/}g;\r\n      s{\\/+\$}{};\r\n      s{\\\$+}{}g;\r\n      s{^/+}{};\r\n   }\r\n\r\n   if ( \@_ > 1 ) {\r\n      \$self->{VSS_FILES}->{\$path} = \$value;\r\n      if ( \$value ) {\r\n         my \$p = \$path;\r\n         while () {\r\n            \$p =~ s{(^|/)+[^/]+\$}{};\r\n            last unless length \$p || \$self->{VSS_FILES}->{\$p};\r\n            \$self->{VSS_FILES}->{\$p} = "project";\r\n         }\r\n      }\r\n   }\r\n\r\n   return exists \$self->{VSS_FILES}->{\$path} && \$self->{VSS_FILES}->{\$path};\r\n}\r\n\r\n=item vss_file_is_deleted\r\n\r\nReturns 1 if the file is a deleted file.\r\n\r\nNOTE: in VSS a file may be deleted and not deleted at the same time!\r\nThanks to Dave Foglesong for pointing this out.\r\n\r\n=cut\r\n\r\nsub vss_file_is_deleted {\r\n    return 0 <= index shift->vss_file( \@_ ), "deleted";\r\n}\r\n\r\n=item vss_file_is_active\r\n\r\nReturns 1 if the file is an active (undeleted) file.\r\n\r\nNOTE: in VSS a file may be deleted and active at the same time!\r\nThanks to Dave Foglesong for pointing this out.\r\n\r\n=cut\r\n\r\nsub vss_file_is_active {\r\n    return shift->vss_file( \@_ ) =~ /(^|, )file/;\r\n}\r\n\r\n=head1 COPYRIGHT\r\n\r\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\r\n\r\nThis module and the VCP package are licensed according to the terms given in\r\nthe file LICENSE accompanying this distribution, a copy of which is included in\r\nL<vcp>.\r\n\r\n=cut\r\n\r\n1 ;\r\n\r\n1;\r\n
END_OF_FILE_AAAAAAAAAACL
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACM, "lib/VCP/Utils/p4.pm" }
package VCP::Utils::p4 ;\n\n=head1 NAME\n\nVCP::Utils::p4 - utilities for dealing with the p4 command\n\n=head1 SYNOPSIS\n\n   use base qw( ... VCP::Utils::p4 ) ;\n\n=head1 DESCRIPTION\n\nA mix-in class providing methods shared by VCP::Source::p4 and VCP::Dest::p4,\nmostly wrappers for calling the p4 command.\n\n=cut\n\nuse strict ;\n\nuse Carp ;\nuse VCP::Debug qw( debug debugging ) ;\nuse File::Spec ;\nuse File::Temp qw( mktemp ) ;\nuse POSIX ':sys_wait_h' ;\n\n=head1 METHODS\n\n=item repo_client\n\nThe p4 client name. This is an accessor for a data member in each class.\nThe data member should be part of VCP::Utils::p4, but the fields pragma\ndoes not support multiple inheritance, so the accessor is here but all\nderived classes supporting this accessor must provide for a key named\n"P4_REPO_CLIENT".\n\n=cut\n\nsub repo_client {\n   my \$self = shift ;\n\n   \$self->{P4_REPO_CLIENT} = shift if \@_ ;\n   return \$self->{P4_REPO_CLIENT} ;\n}\n\n\n=item p4\n\nCalls the p4 command with the appropriate user, client, port, and password.\n\n=cut\n\nsub p4 {\n   my \$self = shift ;\n\n   local \$ENV{P4PASSWD} = \$self->repo_password if defined \$self->repo_password ;\n   unshift \@{\$_[0]}, '-p', \$self->repo_server  if defined \$self->repo_server ;\n   unshift \@{\$_[0]}, '-c', \$self->repo_client  if defined \$self->repo_client ;\n   unshift \@{\$_[0]}, '-u', \$self->repo_user    if defined \$self->repo_user ;\n\n   ## TODO: Specify an empty \n\n   ## localizing this was giving me some grief.  Can't recall what.\n   ## PWD must be cleared because, unlike all other Unix utilities I\n   ## know of, p4 looks at it and bases it's path calculations on it.\n   my \$tmp = \$ENV{PWD} ;\n   delete \$ENV{PWD} ;\n\n   my \$args = shift ;\n#if ( \$ENV{UHOH} && grep( /^client\$/, \@\$args ) && grep( /^-o\$/, \@\$args ) ) {\n#  warn( ">>>>>>>>>>>>>p4.exe \@\$args > bah1" );\n#  system( "p4.exe \@\$args > bah1" );\n#  system( "p4.exe \@\$args > bah2" );\n#}\n\n   \$self->run_safely( [ "p4", \@\$args ], \@_ ) ;\n   \$ENV{PWD} = \$tmp if defined \$tmp ;\n}\n\n\n=item parse_p4_repo_spec\n\nCalls \$self->parse_repo_spec, the post-processes the repo_user in to a user\nname and a client view. If the user specified no client name, then a client\nname of "vcp_tmp_\$\$" is used by default.\n\nThis also initializes the client to have a mapping to a working directory\nunder /tmp, and arranges for the current client definition to be restored\nor deleted on exit.\n\n=cut\n\nsub parse_p4_repo_spec {\n   my \$self = shift ;\n   my ( \$spec ) = \@_ ;\n\n   my \$parsed_spec = \$self->parse_repo_spec( \$spec ) ;\n\n   my ( \$user, \$client ) ;\n   ( \$user, \$client ) = \$self->repo_user =~ m/([^()]*)(?:\\((.*)\\))?/\n      if defined \$self->repo_user ;\n   \$client = "vcp_tmp_\$\$" unless defined \$client && length \$client ;\n\n   \$self->repo_user( \$user ) ;\n   \$self->repo_client( \$client ) ;\n\n   if ( \$self->can( "min" ) ) {\n      my \$filespec = \$self->repo_filespec ;\n\n      ## If a change range was specified, we need to list the files in\n      ## each change.  p4 doesn't allow an \@ range in the filelog command,\n      ## for wataver reason, so we must parse it ourselves and call lots\n      ## of filelog commands.  Even if it did, we need to chunk the list\n      ## so that we don't consume too much memory or need a temporary file\n      ## to contain one line per revision per file for an entire large\n      ## repo.\n      my ( \$name, \$min, \$comma, \$max ) ;\n      ( \$name, \$min, \$comma, \$max ) =\n\x09 \$filespec =~ m/^([^\@]*)(?:\@(-?\\d+)(?:(\\D|\\.\\.)((?:\\d+|#head)))?)?\$/i\n\x09 or die "Unable to parse p4 filespec '\$filespec'\\n";\n\n      die "'\$comma' should be ',' in revision range in '\$filespec'\\n"\n\x09 if defined \$comma && \$comma ne ',' ;\n\n      if ( ! defined \$min ) {\n\x09 \$min = 1 ;\n\x09 \$max = '#head' ;\n      }\n\n      if ( ! defined \$max ) {\n\x09 \$max = \$min ;\n      }\n      elsif ( lc( \$max ) eq '#head' ) {\n\x09 \$self->p4( [qw( counter change )], \\\$max ) ;\n\x09 chomp \$max ;\n      }\n\n      if ( \$max == 0 ) {\n         ## TODO: make this a "normal exit"\n         die "Current change number is 0, no work to do\\n";\n      }\n\n      if ( \$min < 0 ) {\n\x09 \$min = \$max + \$min ;\n      }\n\n      \$self->repo_filespec( \$name ) ;\n      \$self->min( \$min ) ;\n      \$self->max( \$max ) ;\n   }\n\n   return \$parsed_spec ;\n}\n\n\n=item init_p4_view\n\n   \$self->init_p4_view\n\nBorrows or creates a client with the right view.  Only called from\nVCP::Dest::p4, since VCP::Source::p4 uses non-view oriented commands.\n\n=cut\n\nsub init_p4_view {\n   my \$self = shift ;\n\n   my \$client = \$self->repo_client ;\n\n   \$self->repo_client( undef ) ;\n   my \$client_exists = grep \$_ eq \$client, \$self->p4_clients ;\n   debug "p4: client '\$client' exists" if \$client_exists && debugging \$self ;\n   \$self->repo_client( \$client ) ;\n   my \$client_spec = \$self->p4_get_client_spec ;\n## work around a wierd intermittant failure on Win32.  The\n## Options: line *should* end in nomodtime normdir\n## instead it looks like:\n##\n## Options:\x09noallwrite noclobber nocompress unlocked nom\xd4+\n##\n## but only occasionally!\n\$client_spec = \$self->p4_get_client_spec\n    if \$^O =~ /Win32/ && \$client_spec =~ /[\\x80-\\xFF]/;\n\n   \$self->queue_p4_restore_client_spec( \$client_exists ? \$client_spec : undef );\n\n   my \$p4_spec = \$self->repo_filespec ;\n   \$p4_spec =~ s{(/(\\.\\.\\.)?)?\$}{/...} ;\n   my \$work_dir = \$self->work_root ;\n\n   \$client_spec =~ s{^Root.*}{Root:\\t\$work_dir}m ;\n   \$client_spec =~ s{^View.*}{View:\\n\\t\$p4_spec\\t//\$client/...\\n}ms ;\n   debug "p4: using client spec", \$client_spec if debugging \$self ;\n   \$client_spec =~ s{^(Options:.*)}{\$1 nocrlf}m \n      if \$^O =~ /Win32/ ;\n   \$client_spec =~ s{^LineEnd.*}{LineEnd:\\tunix}mi ;\n\n   debug "p4: using client spec", \$client_spec if debugging \$self ;\n\n   \$self->p4_set_client_spec( \$client_spec ) ;\n\n}\n\n=item p4_clients\n\nReturns a list of known clients.\n\n=cut\n\nsub p4_clients {\n   my \$self = shift ;\n\n   my \$clients ;\n   \$self->p4( [ "clients", ], ">", \\\$clients ) ;\n   return map { /^Client (\\S*)/ ; \$1 } split /\\n/m, \$clients ;\n}\n\n=item p4_get_client_spec\n\nReturns the current client spec for the named client. The client may or may not\nexist first, grep the results from L</p4_clients> to see if it already exists.\n\n=cut\n\nsub p4_get_client_spec {\n   my \$self = shift ;\n   my \$client_spec ;\n   \$self->p4( [ "client", "-o" ], ">", \\\$client_spec ) ;\n   return \$client_spec ;\n}\n\n\n=item queue_p4_restore_client_spec\n\n   \$self->queue_p4_restore_client_spec( \$client_spec ) ;\n\nSaves a copy of the named p4 client and arranges for it's restoral on exit\n(assuming END blocks run). Used when altering a user-specified client that\nalready exists.\n\nIf \$client_spec is undefined, then the named client will be deleted on\nexit.\n\nNote that END blocks may be skipped in certain cases, like coredumps,\nkill -9, or a call to POSIX::exit().  None of these should happen except\nin debugging, but...\n\n=cut\n\nmy \@client_backups ;\n\nEND {\n   my \$child_exit;\n   {\n      local \$?;  ## Protect this; we're about to run a child process and\n                 ## we want to exit with the appropriate value.\n      for ( \@client_backups ) {\n         my ( \$object, \$name, \$spec ) = \@\$_ ;\n         my \$tmp_name = \$object->repo_client ;\n         \$object->repo_client( \$name ) ;\n         if ( defined \$spec ) {\n            \$object->p4_set_client_spec( \$spec ) ;\n         }\n         else {\n            my \$out ;\n            \$object->p4( [ "client", "-df", \$object->repo_client ], ">", \\\$out);\n            warn "vcp: unexpected stdout from p4:\\np4: ", \$out\n               unless \$out =~ /^Client\\s.*\\sdeleted./ ;\n            \$child_exit = \$?;\n         }\n         \$object->repo_client( \$tmp_name ) ;\n         \$_ = undef ;\n      }\n      \@client_backups = () ;\n   }\n   \$? = \$child_exit if \$child_exit && ! \$?;\n}\n\n\nsub queue_p4_restore_client_spec {\n   my \$self = shift ;\n   my ( \$client_spec ) = \@_ ;\n   push \@client_backups, [ \$self, \$self->repo_client, \$client_spec ] ;\n}\n\n=item p4_set_client_spec\n\n   \$self->p4_set_client_spec( \$client_spec ) ;\n\nWrites a client spec to the repository.\n\n=cut\n\n\nsub p4_set_client_spec {\n   my \$self = shift ;\n   my ( \$client_spec ) = \@_ ;\n\n   ## Capture stdout so it doesn't leak.\n   my \$out ;\n   \$self->p4( [ "client", "-i" ], "<", \\\$client_spec, ">", \\\$out ) ;\n\n   die "vcp: unexpected stdout from p4:\\np4: ", \$out\n      unless \$out =~ /^Client\\s.*\\ssaved.\$/ ;\n}\n\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAACM
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACN, "lib/VCP/Dest/p4.pm" }
package VCP::Dest::p4 ;\n\n=head1 NAME\n\nVCP::Dest::p4 - p4 destination driver\n\n=head1 SYNOPSIS\n\n   vcp <source> p4:user:password\@p4port:[<dest>]\n   vcp <source> p4:user(client):password\@p4port:[<dest>]\n   vcp <source> p4:[<dest>]\n\nThe <dest> spec is a perforce repository spec and must begin with // and a\ndepot name ("//depot"), not a local filesystem spec or a client spec. There\nshould be a trailing "/..." specified.\n\nIf no user name, password, or port are given, the underlying p4 command will\nlook at that standard environment variables. The password is passed using the\nenvironment variable P4PASSWD so it won't be logged in debugging or error\nmessages, the other options are passed on the command line.\n\nIf no client name is given, a temporary client name like "vcp_tmp_1234" will be\ncreated and used.  The P4CLIENT environment variable will not be used.  If an\nexisting client name is given, the named client spec will be saved off,\naltered, used, and restored.  the client was created for this import, it will\nbe deleted when complete, regardless of whether the client was specified by the\nuser or was randomly generated.  WARNING: If perl coredumps or is killed with a\nsignal that prevents cleanup--like a SIGKILL (9)--the the client deletion or\nrestoral will not occur. The client view is not saved on disk, either, so back\nit up manually if you care.\n\nTHE CLIENT SAVE/RESTORE FEATURE IS EXPERIMENTAL AND MAY CHANGE BASED ON USER\nFEEDBACK.\n\nVCP::Dest::p4 attempts change set aggregation by sorting incoming revisions.\nSee L<VCP::Dest/rev_cmp_sub> for the order in which revisions are sorted. Once\nsorted, a change is submitted whenever the change number (if present) changes,\nthe comment (if present) changes, or a new rev of a file with the same name as\na revision that's pending. THIS IS EXPERIMENTAL, PLEASE DOUBLE CHECK\nEVERYTHING!\n\n=head1 DESCRIPTION\n\n=head1 METHODS\n\n=over\n\n=cut\n\n\$VERSION = 1 ;\n\nuse strict ;\nuse vars qw( \$debug ) ;\n\n\$debug = 0 ;\n\nuse Carp ;\nuse File::Basename ;\nuse File::Path ;\nuse Getopt::Long ;\nuse VCP::Debug ':debug' ;\nuse VCP::Dest ;\nuse VCP::Rev ;\n\nuse base qw( VCP::Dest VCP::Utils::p4 ) ;\nuse fields (\n#   'P4_SPEC',               ## The root of the tree to update\n   'P4_PENDING',            ## Revs pending the next submit\n   'P4_DELETES_PENDING',    ## At least one 'delete' needs to be submitted.\n   'P4_WORK_DIR',           ## Where to do the work.\n   'P4_REPO_CLIENT',        ## See VCP::Utils::p4 for accessors and usage...\n\n   ## members for change number divining:\n   'P4_PREV_CHANGE_ID',    ## The change_id in the r sequence, if any\n   'P4_PREV_COMMENT',      ## Used to detect change boundaries\n\n) ;\n\n=item new\n\nCreates a new instance of a VCP::Dest::p4.  Contacts the p4d using the p4\ncommand and gets some initial information ('p4 info' and 'p4 labels').\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Dest::p4 \$self = \$class->SUPER::new( \@_ ) ;\n\n   ## Parse the options\n   my ( \$spec, \$options ) = \@_ ;\n\n   \$self->parse_p4_repo_spec( \$spec ) ;\n\n   my \$files = \$self->repo_filespec ;\n\n   ## No need to deduce the rev_root, we let p4 do that by setting the\n   ## client view to the destination path the user specified.\n\n   GetOptions( "ArGhOpTioN" => \\"" ) or \$self->usage_and_exit ; # No options!\n\n   \$self->init_p4_view ;\n\n   return \$self ;\n}\n\n\nsub checkout_file {\n   my VCP::Dest::p4 \$self = shift ;\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\nconfess unless defined \$self && defined \$self->header ;\n\n   debug "vcp: retrieving '", \$r->as_string, "' from p4 dest repo"\n      if debugging \$self ;\n\n   ## The rev_root was put in the client view, p4 will "denormalize"\n   ## the name for us.\n   my \$work_path = \$self->work_path( \$r->name ) ;\n   debug "vcp: work_path '\$work_path'" if debugging \$self ;\n\n   my VCP::Rev \$saw = \$self->seen( \$r ) ;\n\n   die "Can't backfill already seen file '", \$r->name, "'" if \$saw ;\n\n   my ( undef, \$work_dir ) = fileparse( \$work_path ) ;\n   \$self->mkpdir( \$work_path ) unless -d \$work_dir ;\n\n   my \$tag = "r_" . \$r->rev_id ;\n   \$tag =~ s/\\W+/_/g ;\n\n   ## The -f forces p4 to sync even if it thinks it doesn't have to.  It's\n   ## not in there for any known reason, just being conservative.\n   \$self->p4( ['sync', '-f', \$r->name . "\\\@\$tag" ] ) ;\n   die "'\$work_path' not created in backfill" unless -e \$work_path ;\n\n   return \$work_path ;\n}\n\n\nsub backfill {\n   my VCP::Dest::p4 \$self = shift ;\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\nconfess unless defined \$self && defined \$self->header ;\n\n   \$r->work_path( \$self->checkout_file( \$r ) ) ;\n\n   return 1 ;\n}\n\n\nsub handle_header {\n   my VCP::Dest::p4 \$self = shift ;\n   \$self->{P4_PENDING}        = [] ;\n   \$self->{P4_PREV_COMMENT}   = undef ;\n   \$self->{P4_PREV_CHANGE_ID} = undef ;\n   \$self->SUPER::handle_header( \@_ ) ;\n}\n\n\nsub handle_rev {\n   my VCP::Dest::p4 \$self = shift ;\n\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\ndebug "vcp: handle_rev got \$r ", \$r->name if debugging \$self ;\n\n   if ( \n      ( \@{\$self->{P4_PENDING}} || \$self->{P4_DELETES_PENDING} )\n      && (\n\x09 (\n\x09    defined \$r->change_id && defined \$self->{P4_PREV_CHANGE_ID}\n\x09    &&      \$r->change_id ne         \$self->{P4_PREV_CHANGE_ID}\n\x09    && ( debugging( \$self ) ? debug "vcp: time to submit: change_id changed" : 1 )\n\x09 )\n\x09 || (\n\x09    defined \$r->comment && defined \$self->{P4_PREV_COMMENT}\n\x09    &&      \$r->comment ne         \$self->{P4_PREV_COMMENT}\n\x09    && ( debugging( \$self ) ? debug "vcp: time to submit: comment changed [", \$r->comment, "] vs [", \$self->{P4_PREV_COMMENT}, "]" : 1 )\n\x09 )\n\x09 || (\n\x09    grep( \$r->name eq \$_->name, \@{\$self->{P4_PENDING}} )\n\x09    && ( debugging( \$self ) ? debug "vcp: time to submit: name repeated" : 1 )\n\x09 )\n      )\n   ) {\n      \$self->submit ;\n   }\n   \n   \$self->compare_base_revs( \$r )\n      if \$r->is_base_rev && defined \$r->work_path ;\n\n   my VCP::Rev \$saw = \$self->seen( \$r ) ;\n\n   return if \$r->is_base_rev ;\n\n   my \$fn = \$r->name ;\n   debug "vcp: importing ", \$r->as_string if debugging \$self ;\n   my \$work_path = \$self->work_path( \$fn ) ;\n   debug "vcp: work_path '\$work_path'" if debugging \$self ;\n\n   if ( \$r->action eq 'delete' ) {\n      my \$already_deleted;\n      if ( ! \$saw ) {\n         \$self->p4( [ 'files', \$fn ], '>', \\my \$log );\n         warn \$log;\n         \$already_deleted = \$log =~ /- delete change \\d+/;\n         \$self->p4( [ 'sync', '-f', \$fn ] )\n            unless \$already_deleted;\n      }\n\n      if ( -e \$work_path ) {\n         unlink \$work_path || die "\$! unlinking \$work_path" ;\n      }\n\n      unless ( \$already_deleted ) {\n         \$self->p4( ['delete', \$fn] ) ;\n         \$self->{P4_DELETES_PENDING} = 1 ;\n      }\n      \$self->delete_seen( \$r ) ;\n   }\n   else {\n   ## TODO: Don't assume same filesystem or working link().\n      {\n         my \$filetype = defined \$r->p4_info && \$r->p4_info =~ /\\((\\S+)\\)\$/\n\x09    ? \$1\n\x09    : \$r->type ;\n\n         my \$add_it ;\n\x09 if ( -e \$work_path ) {\n\x09    \$self->p4( ["edit", "-t", \$filetype, \$fn] ) ;\n\x09    unlink \$work_path          or die "\$! unlinking \$work_path" ;\n\x09 }\n\x09 else {\n\x09    \$self->mkpdir( \$work_path ) ;\n\x09    \$add_it = 1 ;\n\x09 }\n\x09 debug "vcp: linking ", \$r->work_path, " to \$work_path" if debugging \$self ;\n\x09 link \$r->work_path, \$work_path\n\x09    or die "\$! linking ", \$r->work_path, " -> \$work_path" ;\n\n\x09 \$r->dest_work_path( \$work_path ) ;\n\n\x09 if ( defined \$r->mod_time ) {\n\x09    utime \$r->mod_time, \$r->mod_time, \$work_path\n\x09       or die "\$! changing times on \$work_path" ;\n\x09 }\n\x09 if ( \$add_it ) {\n\x09    \$self->p4( ["add", "-t", \$filetype, \$fn] ) ;\n\x09 }\n      }\n\n      unless ( \$saw ) {\n\x09 ## New file.\n      }\n\n      ## TODO: Provide command line options for user-defined tag prefixes\n      my \$tag = "r_" . \$r->rev_id ;\n      \$tag =~ s/\\W+/_/g ;\n      \$r->add_label( \$tag ) ;\n      if ( defined \$r->change_id ) {\n\x09 my \$tag = "ch_" . \$r->change_id ;\n\x09 \$tag =~ s/\\W+/_/g ;\n\x09 \$r->add_label( \$tag ) ;\n      }\n\ndebug "vcp: saving off \$r ", \$r->name, " in PENDING" if debugging \$self ;\n      push \@{\$self->{P4_PENDING}}, \$r ;\n   }\n\n   \$self->{P4_PREV_CHANGE_ID} = \$r->change_id ;\n   \$self->{P4_PREV_COMMENT} = \$r->comment ;\n}\n\n\nsub handle_footer {\n   my VCP::Dest::p4 \$self = shift ;\n\n   \$self->submit\n       if ( \$self->{P4_PENDING} && \@{\$self->{P4_PENDING}} )\n          || \$self->{P4_DELETES_PENDING} ;\n   \$self->SUPER::handle_footer ;\n}\n\n\nsub submit {\n   my VCP::Dest::p4 \$self = shift ;\n\n   my %pending_labels ;\n   my %comments ;\n   my \$max_time ;\n\n   if ( \@{\$self->{P4_PENDING}} ) {\n      for my \$r ( \@{\$self->{P4_PENDING}} ) {\n\x09 \$comments{\$r->comment} = \$r->name if defined \$r->comment ;\n\x09 \$max_time = \$r->time if ! defined \$max_time || \$r->time > \$max_time ;\n\x09 for my \$l ( \$r->labels ) {\n\x09    push \@{\$pending_labels{\$l}}, \$r->dest_work_path ;\n\x09 }\n      }\n\n      if ( defined \$max_time ) {\n\x09 my \@f = reverse( (localtime \$max_time)[0..5] ) ;\n\x09 \$f[0] += 1900 ;\n\x09 ++\$f[1] ; ## Day of month needs to be 1..12\n\x09 \$max_time = sprintf "%04d/%02d/%02d %02d:%02d:%02d", \@f ;\n      }\n      elsif ( debugging \$self ) {\n         debug "No max_time found" ;\n      }\n   }\n\n   my \$description = join( "\\n", keys %comments ) ;\n   if ( length \$description ) {\n      \$description =~ s/^/\\t/gm ;\n      \$description .= "\\n" if substr \$description, -1 eq "\\n" ;\n   }\n\n   my \$change ;\n   \$self->p4( [ 'change', '-o' ], \\\$change ) ;\n\n   if ( defined \$max_time ) {\n      \$change =~ s/^Date:.*\\r?\\n\\r/Date:\\t\$max_time\\n/m\n\x09 or \$change =~ s/(^Client:)/Date:\\t\$max_time\\n\\n\$1/m\n\x09 or die "vcp: Couldn't modify change date\\n\$change" ;\n   }\n\n   \$change =~ s/^Description:.*\\r?\\n\\r?.*/Description:\\n\$description/m\n      or die "vcp: Couldn't modify change description\\n\$change" ;\n   \$self->p4([ 'submit', '-i'], '<', \\\$change ) ;\n\n   ## Create or add a label spec for each of the labels.  The 'sort' is to\n   ## make debugging output more legible.\n   ## TODO: Modify RevML to allow label metadata (owner, desc, options)\n   ## to be passed through.  Same for user, client, jobs metadata etc.\n   ## The assumption is made that most labels will apply to a single change\n   ## number, so we do the labelling once per submit.  I don't think that\n   ## this will break if it doesn't, but TODO: add more labelling tests.\n   for my \$l ( sort keys %pending_labels ) {\n      my \$label_desc ;\n      \$self->p4( [qw( label -o ), \$l], '>', \\\$label_desc ) ;\n      \$self->p4( [qw( label -i ) ],    '<', \\\$label_desc ) ;\n\n      my \$pending_labels = join( "\\n", \@{\$pending_labels{\$l}} ) . "\\n" ;\n      \$self->p4( [qw( -x - labelsync -a -l ), \$l ], "<", \\\$pending_labels ) ;\n   }\n   \@{\$self->{P4_PENDING}} = () ;\n   \$self->{P4_DELETES_PENDING} = undef ;\n}\n\nsub tag {\n   my VCP::Dest::p4 \$self = shift ;\n\n   my \$tag = shift  ;\n   \$tag =~ s/\\W+/_/g ;\n   \$self->p4( ['tag', \$tag, \@_] ) ;\n}\n\n\n## Prevent VCP::Plugin from rmtree-ing the workspace we're borrowing\nsub DESTROY {\n   my VCP::Dest::p4 \$self = shift ;\n\n   \$self->work_root( undef ) ;\n   \$self->SUPER::DESTROY ;\n}\n\n\n=back\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nCopyright (c) 2000, 2001, 2002 Perforce Software, Inc.\nAll rights reserved.\n\nSee L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACN
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACO, "lib/VCP/Dest/revml.pm" }
package VCP::Dest::revml ;\n\n=head1 NAME\n\nVCP::Dest::revml - Outputs versioned files to a revml file\n\n=head1 SYNOPSIS\n\n## revml output class:\n\n   revml:[<output-file>]\n   revml:[<output-file>] --dtd <revml.dtd>\n   revml:[<output-file>] --version <version>\n   revml:[<output-file>] --sort-by=name,rev\n\n=head1 DESCRIPTION\n\nThe --dtd and --version options cause the output to be checked against\na particular version of revml.  This does I<not> cause output to be in \nthat version, but makes sure that output is compliant with that version.\n\n=head1 EXTERNAL METHODS\n\n=over\n\n=cut\n\nuse strict ;\n\nuse Carp ;\nuse Digest::MD5 ;\nuse Fcntl ;\nuse Getopt::Long ;\nuse MIME::Base64 ;\nuse RevML::Doctype ;\nuse RevML::Writer ;\nuse Symbol ;\nuse UNIVERSAL qw( isa ) ;\nuse VCP::Debug ':debug' ;\nuse VCP::Rev ;\nuse Text::Diff ;\n\nuse vars qw( \$VERSION ) ;\n\n\$VERSION = 0.1 ;\n\nuse base 'VCP::Dest' ;\n\nuse fields (\n   'OUT_NAME',  ## The name of the output file, or '-' for stdout\n   'OUT_FH',    ## The handle of the output file\n   'WRITER',    ## The XML::AutoWriter instance write with\n) ;\n\n\n=item new\n\nCreates a new instance.  The only parameter is '-dtd', which overrides\nthe default DTD found by searching for modules matching RevML::DTD:v*.pm.\n\nAttempts to create the output file if one is specified.\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Dest::revml \$self = \$class->SUPER::new( \@_ ) ;\n\n   my \@errors ;\n\n   my ( \$spec, \$options ) = \@_ ;\n\n   my \$parsed_spec = \$self->parse_repo_spec( \$spec ) ;\n\n   my \$file_name = \$parsed_spec->{FILES} ;\n   \$self->{OUT_NAME} = defined \$file_name && length \$file_name\n      ? \$file_name\n      : '-' ;\n   if ( \$self->{OUT_NAME} eq '-' ) {\n      \$self->{OUT_FH}   = \\*STDOUT ;\n      ## TODO: Check OUT_FH for writability when it's set to STDOUT\n   }\n   else {\n      require Symbol ;\n      \$self->{OUT_FH} = Symbol::gensym ;\n      ## TODO: Provide a '-f' force option\n      open( \$self->{OUT_FH}, ">\$self->{OUT_NAME}" )\n         or die "\$!: \$self->{OUT_NAME}" ;\n   }\n   ## BUG: Can't undo this AFAIK, so we're permanently altering STDOUT\n   ## if OUT_NAME eq '-'.\n   binmode \$self->{OUT_FH};\n\n   my \$doctype ;\n   my \@sort_spec ;\n   {\n      local *ARGV = \$options ;\n      GetOptions(\n\x09 'dtd|version' => sub {\n\x09    \$doctype = RevML::Doctype->new( shift \@\$options ) ;\n\x09 },\n\x09 "k|sort-by=s" => \\\@sort_spec,\n       ) or \$self->usage_and_exit ;\n   }\n\n   \$self->set_sort_spec( \@sort_spec ) if \@sort_spec ;\n\n   \$doctype = RevML::Doctype->new\n      unless \$doctype ;\n\n   die join( '', \@errors ) if \@errors ;\n\n   \$self->writer(\n      RevML::Writer->new(\n\x09 DOCTYPE => \$doctype,\n\x09 OUTPUT  => \$self->{OUT_FH},\n      )\n   );\n\n   return \$self ;\n}\n\n\nsub _ISO8601(;\$) {\n   my \@f = reverse( ( \@_ ? gmtime( shift ) : gmtime )[0..5] ) ;\n   \$f[0] += 1900 ;\n   \$f[1] ++ ; ## Month of year needs to be 1..12\n   return sprintf( "%04d-%02d-%02d %02d:%02d:%02dZ", \@f ) ;\n}\n\nsub _emit_characters {\n   my ( \$w, \$buf ) = \@_ ;\n\n   \$w->setDataMode( 0 ) ;\n\n   ## Note that we don't let XML munge \\r to be \\n!!\n   while ( \$\$buf =~ m{\\G(?:\n      (   [\\x00-\\x08\\x0b-\\x1f\\x7f-\\xff])\n      | ([^\\x00-\\x08\\x0b-\\x1f\\x7f-\\xff]*)\n      )}gx\n   ) {\n      if ( defined \$1 ) {\n\x09 \$w->char( "", code => sprintf( "0x%02x", ord \$1 ) ) ;\n      }\n      else {\n\x09 \$w->characters( \$2 ) ;\n      }\n   }\n\n}\n\n\nsub handle_rev {\n   my VCP::Dest::revml \$self = shift ;\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\n   my \$w = \$self->writer ;\n\n   if ( \$self->none_seen ) {\n      \$w->setDataMode( 1 ) ;\n      \$w->xmlDecl ;\n      my \$h = \$self->header ;\n      ## VCP::Source::revml passes through the original date.  Other sources\n      ## don't.\n      \$w->time(\n         defined \$h->{time}\n\x09    ? _ISO8601 \$h->{time}\n\x09    : _ISO8601\n      ) ;\n      \$w->rep_type( \$h->{rep_type} ) ;\n      \$w->rep_desc( \$h->{rep_desc} ) ;\n      \$w->rev_root( \$h->{rev_root} ) ;\n   }\n\n   my VCP::Rev \$saw = \$self->seen( \$r ) ;\n\n   ## If there's no work path for the current file, keep the previous one.\n   ## This is a cheat that allows us to diff against the last known version\n   ## if a file is deleted and then re-added.  Without this line, we would\n   ## have to include the new version of the file.\n   \$self->seen( \$saw ) if \$saw && ! defined \$r->work_path ;\n\n   my \$fn = \$r->name ;\n\n   my \$is_base_rev = \$r->is_base_rev ;\n   die(\n      "Saw '", \$saw->as_string,\n      "', but found a later base rev '" . \$r->as_string, "'"\n   ) if \$saw && \$is_base_rev ;\n\n   ## type and rev_id are not provided for VSS deletes\n   debug "vcp: emitting revml for ", \$r->as_string\n      if debugging \$self;\n\n   \$w->start_rev ;\n   \$w->name(       \$fn           ) ;\n   \$w->type(       \$r->type               ) if defined \$r->type ;\n   \$w->p4_info(    \$r->p4_info            ) if defined \$r->p4_info ;\n   \$w->cvs_info(   \$r->cvs_info           ) if defined \$r->cvs_info ;\n   \$w->rev_id(     \$r->rev_id             ) if defined \$r->rev_id ;\n   \$w->change_id(  \$r->change_id          ) if defined \$r->change_id ;\n   \$w->time(       _ISO8601 \$r->time      ) if defined \$r->time ;\n   \$w->mod_time(   _ISO8601 \$r->mod_time  ) if defined \$r->mod_time ;\n   \$w->user_id(    \$r->user_id            ) if defined \$r->user_id;\n\n   ## Sorted for readability & testability\n   \$w->label( \$_ ) for sort \$r->labels ;\n\n   if ( defined \$r->comment && length \$r->comment ) {\n      \$w->start_comment ;\n      my \$c = \$r->comment ;\n      _emit_characters( \$w, \\\$c ) ;\n      \$w->end_comment ;\n      \$w->setDataMode( 1 ) ;\n   }\n\n   my \$convert_crs = \$^O =~ /Win32/ && ( \$r->type || "" ) eq "text" ;\n\n   my \$digestion ;\n   my \$close_it ;\n   my \$cp = \$r->work_path ;\n   if ( \$is_base_rev ) {\n      sysopen( F, \$cp, O_RDONLY ) or die "\$!: \$cp\\n" ;\n      binmode F ;\n      \$digestion = 1 ;\n      \$close_it = 1 ;\n   }\n   elsif ( \$r->action eq 'delete' ) {\n      \$w->delete() ;\n      \$self->delete_seen( \$r ) ;\n   }\n   else {\n      sysopen( F, \$cp, O_RDONLY ) or die "\$!: \$cp\\n" ;\n      ## need to binmode it so ^Z can pass through, need to do \\r and\n      ## \\r\\n -> \\n conversion ourselves.\n      binmode F ;\n      \$close_it = 1 ;\n\n      my \$buf ;\n      my \$read ;\n      my \$has_nul ;\n      my \$total_char_count = 0 ;\n      my \$bin_char_count   = 0 ;\n      while ( ! \$has_nul ) {\n\x09 \$read = sysread( F, \$buf, 100_000 ) ;\n\x09 die "\$! reading \$cp\\n" unless defined \$read ;\n\x09 last unless \$read ;\n\x09 \$has_nul = \$buf =~ tr/\\x00// ;\n\x09 \$bin_char_count   += \$buf =~ tr/\\x00-\\x08\\x0b-\\x1f\\x7f-\\xff// ;\n\x09 \$total_char_count += length \$buf ;\n      } ;\n\n      sysseek( F, 0, 0 ) or die "\$! seeking on \$cp\\n" ;\n      \n      \$buf = '' unless \$read ;\n      ## base64 generate 77 chars (including the newline) for every 57 chars\n      ## of input. A '<char code="0x01" />' element is 20 chars.\n      my \$encoding = \$bin_char_count * 20 > \$total_char_count * 77/57\n\x09 ? "base64"\n\x09 : "none" ;\n\n      if (  ! \$saw                    ## First rev, can't delta\n         || ! defined \$saw->work_path ## No file, can't delta\n\x09 || \$has_nul                  ## patch would barf, can't delta\n\x09 || \$encoding ne "none"       ## base64, can't delta\n      ) {\n         ## Full content, no delta.\n\x09 \$w->start_content( encoding => \$encoding ) ;\n\x09 my \$delete_nl ;\n\x09 while () {\n\x09    ## Odd chunk size is because base64 is most concise with\n\x09    ## chunk sizes a multiple of 57 bytes long.\n\x09    \$read = sysread( F, \$buf, 57_000 ) ;\n\x09    die "\$! reading \$cp\\n" unless defined \$read ;\n\x09    last unless \$read ;\n\x09    if ( \$convert_crs ) {\n\x09       substr( \$buf, 0, 1 ) = ""\n\x09\x09  if \$delete_nl && substr( \$buf, 0, 1 ) eq "\\n" ;\n               \$delete_nl = substr( \$buf, -1 ) eq "\\n" ;\n\x09       \$buf =~ s/(\\r\\n|\\r)/\\n/g ;  ## ouch, that's gotta hurt.\n\x09    }\n\x09    if ( \$encoding eq "none" ) {\n\x09       _emit_characters( \$w, \\\$buf ) ;\n\x09    }\n\x09    else {\n\x09       \$w->characters( encode_base64( \$buf ) ) ;\n\x09    }\n\x09 }\n\x09 \$w->end_content ;\n\x09 \$w->setDataMode( 1 ) ;\n      }\n      else {\n         ## Delta from previous version\n\x09 \$w->base_name(   \$saw->name )\n\x09    if \$saw->name ne \$r->name ;\n\x09 \$w->base_rev_id( \$saw->rev_id ) ;\n\n\x09 \$w->start_delta( type => 'diff-u', encoding => 'none' ) ;\n\n\x09 my \$old_cp = \$saw->work_path ;\n\n\x09 die "vcp: no old work path for '", \$saw->name, "'\\n"\n\x09    unless defined \$old_cp && length \$old_cp ;\n\n\x09 die "vcp: old work path '\$old_cp' not found for '", \$saw->name, "'\\n"\n\x09    unless -f \$old_cp ;\n\n         ## TODO: Include entire contents if diff is larger than the contents.\n\n\x09 ## Accumulate a bunch of output so that characters can make a\n\x09 ## knowledgable CDATA vs &lt;&amp; escaping decision.\n\x09 my \@output ;\n\x09 my \$outlen = 0 ;\n\x09 my \$delete_nl ;\n\x09 ## TODO: Write a "minimal" diff output handler that doesn't\n\x09 ## emit any lines from \$old_cp, since they are redundant.\n\x09 diff \$old_cp, \$cp,\n\x09    {\n\x09       ## Not passing file names, so no filename header.\n               STYLE  => "VCP::DiffFormat",\n\x09       OUTPUT => sub {\n\x09\x09  push \@output, \$_[0] ;\n\x09\x09  ## Assume no lines split between \\r and \\n because\n\x09\x09  ## diff() splits based on lines, so we can just\n\x09\x09  ## do a simple conversion here.\n\x09\x09  \$output[-1] =~ s/\\r\\n|\\r/\\n/g if \$convert_crs ;\n\x09\x09  \$outlen += length \$_[0] ;\n\x09\x09  return unless \$outlen > 100_000 ;\n\x09\x09  _emit_characters( \$w, \\join "", splice \@output  ) ;\n\x09       },\n\x09    } ;\n\x09 _emit_characters( \$w, \\join "", splice \@output  ) if \$outlen ;\n\x09 \$w->end_delta ;\n\x09 \$w->setDataMode( 1 ) ;\n      } ;\n      \$digestion = 1 ;\n   }\n\n   if ( \$digestion ) {\n      ## TODO: See if this should be seek or sysseek.\n      sysseek F, 0, 0 or die "\$!: \$cp" ;\n      my \$d= Digest::MD5->new ;\n      ## gotta do this by hand, since it's in binmode and we want\n      ## to handle ^Z and lone \\r's.\n      my \$delete_nl ;\n      my \$read ;\n      my \$buf ;\n      while () {\n\x09 \$read = sysread( F, \$buf, 10_000 ) ;\n\x09 die "\$! reading \$cp\\n" unless defined \$read ;\n\x09 last unless \$read ;\n\x09 if ( \$convert_crs ) {\n\x09    substr( \$buf, 0, 1 ) = ""\n\x09       if \$delete_nl && substr( \$buf, 0, 1 ) eq "\\n" ;\n\x09    \$delete_nl = substr( \$buf, -1 ) eq "\\n" ;\n\x09    \$buf =~ s/(\\r\\n|\\r)/\\n/g ;  ## ouch, that's gotta hurt.\n\x09 }\n\x09 \$d->add( \$buf ) ;\n      }\n      \$d->addfile( \\*F ) ;\n      \$w->digest( \$d->b64digest, type => 'MD5', encoding => 'base64' ) ;\n   }\n   if ( \$close_it ) {\n      close F ;\n   }\n\n   \$w->end_rev ;\n\n#   \$self->seen( \$r ) ;\n}\n\n\nsub handle_footer {\n   my VCP::Dest::revml \$self = shift ;\n   my ( \$footer ) = \@_ ;\n\n   \$self->writer->endAllTags() unless \$self->none_seen ;\n\n   return ;\n}\n\n\nsub writer {\n   my VCP::Dest::revml \$self = shift ;\n   \$self->{WRITER} = shift if \@_ ;\n   return \$self->{WRITER} ;\n}\n\n\n=back\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nCopyright (c) 2000, 2001, 2002 Perforce Software, Inc.\nAll rights reserved.\n\nSee L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACO
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACP, "lib/VCP/Dest/cvs.pm" }
package VCP::Dest::cvs ;\n\n=head1 NAME\n\nVCP::Dest::cvs - cvs destination driver\n\n=head1 SYNOPSIS\n\n   vcp <source> cvs:module\n   vcp <source> cvs:CVSROOT:module\n\nwhere module is a module or directory that already exists within CVS.\n\nThis destination driver will check out the indicated destination in\na temporary directory and use it to add, delete, and alter files.\n\n=head1 DESCRIPTION\n\nThis driver allows L<vcp|vcp> to insert revisions in to a CVS\nrepository.  There are no options at this time.\n\nTODO: Skip all directories named "CVS".\n\n=cut\n\n\$VERSION = 1 ;\n\nuse strict ;\nuse vars qw( \$debug ) ;\n\n\$debug = 0 ;\n\nuse Carp ;\nuse File::Basename ;\nuse File::Path ;\nuse Getopt::Long ;\nuse VCP::Debug ':debug' ;\nuse VCP::Rev ;\n\nuse base qw( VCP::Dest VCP::Utils::cvs ) ;\nuse fields (\n   'CVS_CHANGE_ID',  ## The current change_id in the rev_meta sequence, if any\n   'CVS_LAST_MOD_TIME',  ## A HASH keyed on working files of the mod_times of\n                     ## the previous revisions of those files.  This is used\n\x09\x09     ## to make sure that new revision get a different mod_time\n\x09\x09     ## so that CVS never thinks that a new revision hasn't\n\x09\x09     ## changed just because the VCP::Source happened to create\n\x09\x09     ## two files with the same mod_time.\n   'CVS_PENDING_COMMAND', ## "add" or "edit"\n   'CVS_PENDING',    ## Revs to be committed\n## These next fields are used to detect changes between revs that cause a\n## commit. Commits are batched for efficiency's sake.\n   'CVS_PREV_CHANGE_ID', ## Change ID of previous rev\n   'CVS_PREV_COMMENT',   ## Revs to be committed\n) ;\n\n## Optimization note: The slowest thing is the call to "cvs commit" when\n## something's been added or altered.  After all the changed files have\n## been checked in by CVS, there's a huge pause (at least with a CVSROOT\n## on the local filesystem).  So, we issue "cvs add" whenever we need to,\n## but we queue up the files until a non-add is seem.  Same for when\n## a file is edited.  This preserves the order of the files, without causing\n## lots of commits.  Note that we commit before each delete to make sure\n## that the order of adds/edits and deletes is maintained.\n\n#=item new\n#\n#Creates a new instance of a VCP::Dest::cvs.  Contacts the cvsd using the cvs\n#command and gets some initial information ('cvs info' and 'cvs labels').\n#\n#=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Dest::cvs \$self = \$class->SUPER::new( \@_ ) ;\n\n   ## Parse the options\n   my ( \$spec, \$options ) = \@_ ;\n\n   \$self->parse_repo_spec( \$spec ) ;\n   \$self->deduce_rev_root( \$self->repo_filespec ) ;\n\n   {\n      local *ARGV = \$options ;\n      GetOptions(\n         "NoFreakinOptionsAllowed" => \\undef,\n      )\n\x09 or \$self->usage_and_exit ;\n   }\n\n   \$self->command_stderr_filter(\n      qr{^(?:cvs (?:server|add|remove): (re-adding|use 'cvs commit' to).*)\\n}\n   ) ;\n\n   return \$self ;\n}\n\n\nsub handle_header {\n   my VCP::Dest::cvs \$self = shift ;\n\n   debug "vcp: first rev" if debugging \$self ;\n   \$self->rev_root( \$self->header->{rev_root} )\n      unless defined \$self->rev_root ;\n\n   \$self->create_cvs_workspace ;\n\n   \$self->{CVS_PENDING_COMMAND} = "" ;\n   \$self->{CVS_PENDING}         = [] ;\n   \$self->{CVS_PREV_COMMENT}    = undef ;\n   \$self->{CVS_PREV_CHANGE_ID}  = undef ;\n\n   \$self->SUPER::handle_header( \@_ ) ;\n}\n\n\nsub checkout_file {\n   my VCP::Dest::cvs \$self = shift ;\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\n   debug "vcp: \$r checking out ", \$r->as_string, " from cvs dest repo"\n      if debugging \$self ;\n\n   my \$fn = \$r->name ;\n   my \$work_path = \$self->work_path( \$fn ) ;\n   debug "vcp: work_path '\$work_path'" if debugging \$self ;\n\n   my \$saw = \$self->seen( \$r ) ;\n\n   die "Can't backfill already seen file '", \$r->name, "'" if \$saw ;\n\n   my ( undef, \$work_dir ) = fileparse( \$work_path ) ;\n   \$self->mkpdir( \$work_path ) unless -d \$work_dir ;\n\n   my \$tag = "r_" . \$r->rev_id ;\n   \$tag =~ s/\\W+/_/g ;\n\n   ## Ok, the tricky part: we need to use a tag, but we don't want it\n   ## to be sticky, or we get an error the next time we commit this\n   ## file, since the tag is not likely to be a branch revision.\n   ## Apparently the way to do this is to print it to stdout on update\n   ## (or checkout, but we used update so it works with a \$fn relative\n   ## to the cwd, ie a \$fn with no module name first).\n## The -kb is a hack to get the tests to pass on Win32, where \\n\n## becomes \\r\\n on checkout otherwise.  TODO: figure out what is\n## the best thing to do.  We might try it without the -kb, then\n## if the digest check fails, try it again with -kb.  Problem is\n## that said digest check occurs in VCP/Source/revml, not here,\n## so we need to add a "can retry" return result to the API and\n## modify the Sources to use it if a digest check fails.\n   \$self->cvs(\n      [ qw( update -d -kb -p ), -r => \$tag, \$fn ],\n      '>', \$work_path\n   ) ;\n   die "'\$work_path' not created by cvs checkout" unless -e \$work_path ;\n\n   return \$work_path ;\n}\n\n\nsub backfill {\n   my VCP::Dest::cvs \$self = shift ;\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\n   \$r->work_path( \$self->checkout_file( \$r ) ) ;\n\n   return 1 ;\n}\n\nmy \$old_r ;\nsub handle_rev {\n   my VCP::Dest::cvs \$self = shift ;\n\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\n   if ( \n      ( \@{\$self->{CVS_PENDING}} )#|| \$self->{CVS_DELETES_PENDING} )\n      && (\n         \@{\$self->{CVS_PENDING}} > 25  ## Limit command line length\n\x09 || (\n\x09    defined \$r->change_id && defined \$self->{CVS_PREV_CHANGE_ID}\n\x09    &&      \$r->change_id ne         \$self->{CVS_PREV_CHANGE_ID}\n\x09    && ( debugging( \$self ) ? debug "vcp: change_id changed" : 1 )\n\x09 )\n\x09 || (\n\x09    defined \$r->comment && defined \$self->{CVS_PREV_COMMENT}\n\x09    &&      \$r->comment ne         \$self->{CVS_PREV_COMMENT}\n\x09    && ( debugging( \$self ) ? debug "vcp: comment changed" : 1 )\n\x09 )\n\x09 || (\n\x09    grep( \$r->name eq \$_->name, \@{\$self->{CVS_PENDING}} )\n\x09    && ( debugging( \$self ) ? debug "vcp: name repeated" : 1 )\n\x09 )\n      )\n   ) {\n      debug "vcp: committing on general principles" if debugging \$self ;\n      \$self->commit ;\n   }\n\n   \$self->compare_base_revs( \$r )\n      if \$r->is_base_rev && defined \$r->work_path ;\n\n   ## Don't save the reference.  This forces the DESTROY to happen here,\n   ## if possible.  TODO: Keep VCP::Rev from deleting files prematurely.\n   my \$saw = ! ! \$self->seen( \$r ) ;\n\n   return if \$r->is_base_rev ;\n\n   my \$fn = \$r->name ;\n   my \$work_path = \$self->work_path( \$fn ) ;\n\n   if ( \$r->action eq 'delete' ) {\n      \$self->commit ;\n      unlink \$work_path || die "\$! unlinking \$work_path" ;\n      \$self->cvs( ['remove', \$fn] ) ;\n      ## Do this commit by hand since there are no CVS_PENDING revs, which\n      ## means \$self->commit will not work. It's relatively fast, too.\n      \$self->cvs( ['commit', '-m', \$r->comment || '', \$fn] ) ;\n      \$self->delete_seen( \$r ) ;\n   }\n   else {\n      ## TODO: Move this in to commit().\n      {\n\x09 my ( \$vol, \$work_dir, undef ) = File::Spec->splitpath( \$work_path ) ;\n\x09 unless ( -d \$work_dir ) {\n\x09    my \@dirs = File::Spec->splitdir( \$work_dir ) ;\n\x09    my \$this_dir = shift \@dirs  ;\n\x09    my \$base_dir = File::Spec->catpath( \$vol, \$this_dir, "" ) ;\n\x09    do {\n\x09       ## Warn: MacOS danger here: "" is like Unix's "..".  Shouldn't\n\x09       ## ever be a problem, we hope.\n\x09       if ( length \$base_dir && ! -d \$base_dir ) {\n\x09          \$self->mkdir( \$base_dir ) ;\n\x09\x09  ## We dont' queue these to a PENDING because these\n\x09\x09  ## should be pretty rare after the first checkin.  Could\n\x09\x09  ## have a modal CVS_PENDING with modes like "add", "remove",\n\x09\x09  ## etc. and commit whenever the mode's about to change,\n\x09\x09  ## I guess.\n\x09\x09  \$self->cvs( ["add", \$base_dir] ) ;\n\x09       }\n\x09       \$this_dir = shift \@dirs  ;\n\x09       \$base_dir = File::Spec->catdir( \$base_dir, \$this_dir ) ;\n\x09    } while \@dirs ;\n\x09 }\n      }\n      if ( -e \$work_path ) {\n\x09 unlink \$work_path or die "\$! unlinking \$work_path" ;\n      }\n\n      debug "vcp: linking ", \$r->work_path, " to \$work_path"\n         if debugging \$self ;\n\n      ## TODO: Don't assume same filesystem or working link().\n      link \$r->work_path, \$work_path\n\x09 or die "\$! linking '", \$r->work_path, "' -> \$work_path" ;\n\n      if ( defined \$r->mod_time ) {\n\x09 utime \$r->mod_time, \$r->mod_time, \$work_path\n\x09    or die "\$! changing times on \$work_path" ;\n      }\n\n      my ( \$acc_time, \$mod_time ) = (stat( \$work_path ))[8,9] ;\n      if ( ( \$self->{CVS_LAST_MOD_TIME}->{\$work_path} || 0 ) == \$mod_time ) {\n         ++\$mod_time ;\n\x09 debug "vcp: tweaking mod_time on '\$work_path'" if debugging \$self ;\n\x09 utime \$acc_time, \$mod_time, \$work_path\n\x09    or die "\$! changing times on \$work_path" ;\n      }\n      \$self->{CVS_LAST_MOD_TIME}->{\$work_path} = \$mod_time ;\n\n      \$r->dest_work_path( \$fn ) ;\n\n      if ( ! \$saw ) {\n\x09 ## New file.\n\x09 my \@bin_opts = \$r->type ne "text" ? "-kb" : () ;\n\x09 \$self->commit if \$self->{CVS_PENDING_COMMAND} ne "add" ;\n\x09 \$self->cvs( [ "add", \@bin_opts, "-m", \$r->comment || '', \$fn ] ) ;\n\x09 \$self->{CVS_PENDING_COMMAND} = "add" ;\n      }\n      else {\n\x09 \$self->commit if \$self->{CVS_PENDING_COMMAND} ne "edit" ;\n\x09 \$self->{CVS_PENDING_COMMAND} = "edit" ;\n      }\n\n#      ## TODO: batch the commits when the comment changes or we see a\n#      ## new rev for a file with a pending commit..\n#      \$self->cvs( ['commit', '-m', \$r->comment || '', \$fn] ) ;\n#\ndebug "\$r pushing ", \$r->dest_work_path if debugging \$self ;\n      push \@{\$self->{CVS_PENDING}}, \$r ;\n  }\n\n   \$self->{CVS_PREV_CHANGE_ID} = \$r->change_id ;\n   \$self->{CVS_PREV_COMMENT} = \$r->comment ;\n}\n\n\nsub handle_footer {\n   my VCP::Dest::cvs \$self = shift ;\n\n   \$self->commit\n       if \$self->{CVS_PENDING} && \@{\$self->{CVS_PENDING}} ;#|| \$self->{CVS_DELETES_PENDING} ;\n   \$self->SUPER::handle_footer ;\n}\n\n\nsub commit {\n   my VCP::Dest::cvs \$self = shift ;\n\n   return unless \@{\$self->{CVS_PENDING}} ;\n\n   ## All comments should be the same, since we alway commit when the \n   ## comment changes.\n   my \$comment = \$self->{CVS_PENDING}->[0]->comment || '' ;\n\n   ## \@names was originally to try to convince cvs to commit things in the\n   ## preferred order.  No go: cvs chooses some order I can't fathom without\n   ## reading it's source code.  I'm leaving this in for now to keep cvs\n   ## from having to scan the working dirs for changes, which may or may\n   ## not be happening now (need to check at some point).\n   my \@names = map \$_->dest_work_path, \@{\$self->{CVS_PENDING}} ;\n\n   \$self->cvs( ['commit', '-m', \$comment, \@names ] ) ;\n\n   for my \$r ( \@{\$self->{CVS_PENDING}} ) {\n      ## TODO: Don't rtag it with r_ if it gets the same rev number from the\n      ## commit.\n      ## TODO: Batch files in to the rtag command, esp. for change number tags,\n      ## for performance's sake.\n      ## TODO: batch tags, too.\n      my \@tags = map {\n         s/^([^a-zA-Z])/tag_\$1/ ;\n\x09 s/\\W/_/g ;\n\x09 \$_ ;\n      }(\n\x09 defined \$r->rev_id    ? "r_" . \$r->rev_id     : (),\n         defined \$r->change_id ? "ch_" . \$r->change_id : (),\n\x09 \$r->labels,\n      ) ;\n\n      \$self->tag( \$_, \$r->dest_work_path ) for \@tags ;\n      ## TODO: Provide command line options for user-defined tag prefixes\n    }\n\n   \@{\$self->{CVS_PENDING}} = () ;\n   \$self->{CVS_PENDING_COMMAND} = "" ;\n}\n\n\nsub tag {\n   my VCP::Dest::cvs \$self = shift ;\n\n   my \$tag = shift  ;\n   \$tag =~ s/\\W+/_/g ;\n   \$self->cvs( ['tag', \$tag, \@_] ) ;\n}\n\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nCopyright (c) 2000, 2001, 2002 Perforce Software, Inc.\nAll rights reserved.\n\nSee L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACP
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACQ, "lib/VCP/Dest/vss.pm" }
package VCP::Dest::vss ;\n\n=head1 NAME\n\nVCP::Dest::vss - vss destination driver\n\n=head1 SYNOPSIS\n\n   vcp <source> vss:module\n   vcp <source> vss:VSSROOT:module\n\nwhere module is a module or directory that already exists within VSS.\n\nThis destination driver will check out the indicated destination in\na temporary directory and use it to add, delete, and alter files.\n\n=head1 DESCRIPTION\n\nB<Experimental>.  See L<NOTES|/NOTES> for details.\n\nThis driver allows L<vcp|vcp> to insert revisions in to a VSS\nrepository.  There are no options at this time.\n\n=cut\n\n\$VERSION = 1 ;\n\nuse strict ;\nuse vars qw( \$debug ) ;\n\n\$debug = 0 ;\n\nuse Carp ;\nuse File::Basename ;\nuse File::Path ;\nuse Getopt::Long ;\nuse VCP::Debug ':debug' ;\nuse VCP::Rev ;\nuse File::Spec ;\nuse File::Spec::Unix ;\n\nuse base qw( VCP::Dest VCP::Utils::vss ) ;\nuse fields (\n   'VSS_FILES',      ## HASH of all VSS files, managed by VCP::Utils::vss\n   'VSS_CHECKED_OUT', ## HASH of whether or not a file has been checked out.\n) ;\n\n## Optimization note: The slowest thing is the call to "vss commit" when\n## something's been added or altered.  After all the changed files have\n## been checked in by VSS, there's a huge pause (at least with a VSSROOT\n## on the local filesystem).  So, we issue "vss add" whenever we need to,\n## but we queue up the files until a non-add is seem.  Same for when\n## a file is edited.  This preserves the order of the files, without causing\n## lots of commits.  Note that we commit before each delete to make sure\n## that the order of adds/edits and deletes is maintained.\n\n#=item new\n#\n#Creates a new instance of a VCP::Dest::vss.  Contacts the vssd using the vss\n#command and gets some initial information ('vss info' and 'vss labels').\n#\n#=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my VCP::Dest::vss \$self = \$class->SUPER::new( \@_ ) ;\n\n   ## Parse the options\n   my ( \$spec, \$options ) = \@_ ;\n\n   \$self->parse_repo_spec( \$spec ) ;\n   \$self->deduce_rev_root( \$self->repo_filespec ) ;\n\n   {\n      local *ARGV = \$options ;\n      GetOptions(\n         "NoFreakinOptionsAllowed" => \\undef,\n      )\n\x09 or \$self->usage_and_exit ;\n   }\n\n   ## We need to know about the hierarchy under the target path.\n   my \$dest_path = \$self->repo_filespec;\n   \$dest_path =~ s{([\\\\/]|[\\\\/](\\.\\.\\.|\\*\\*))?\\z}{/...};\n   \$self->get_vss_file_list( \$dest_path );\n\n   return \$self ;\n}\n\n\nsub handle_header {\n   my VCP::Dest::vss \$self = shift ;\n\n   debug "vcp: first rev" if debugging \$self ;\n   \$self->rev_root( \$self->header->{rev_root} )\n      unless defined \$self->rev_root ;\n\n   \$self->create_vss_workspace ;\n\n   \$self->{VSS_CHECKED_OUT} = {};\n\n   \$self->SUPER::handle_header( \@_ ) ;\n}\n\n\nsub checkout_file {\n   my VCP::Dest::vss \$self = shift ;\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\n   debug "vcp: checking out ", \$r->as_string, " from vss dest repo"\n      if debugging \$self ;\n\n   my \$fn = \$self->denormalize_name( \$r->name ) ;\n   my \$work_path = \$self->work_path( "co", \$fn ) ;\n   debug "vcp: work_path '\$work_path'" if debugging \$self ;\n\n   my \$saw = \$self->seen( \$r ) ;\n\n   Carp::confess "Can't backfill already seen file '", \$r->name, "'" if \$saw ;\n   die "Can't backfill already seen file '", \$r->name, "'" if \$saw ;\n\n   my ( \$file, \$work_dir ) = fileparse( \$work_path ) ;\n   \$self->mkpdir( \$work_path ) unless -d \$work_dir ;\n   \$work_dir =~ s{[\\\\/]+\$}{}g;\n\n#   my \$tag = "r_" . \$r->rev_id ;\n#   \$tag =~ s/\\W+/_/g ;\n#\n   my ( undef, \$dirs ) = fileparse( \$fn );\n\n   \$self->ss( [ "cp", "\\\$/\$dirs" ] );\n   ## This -GN is a hack; it's here because the test suite uses\n   ## Unix lineends and the checksums require it.\n   \$self->ss( [ "Get", \$file, "-GL\$work_dir", "-GN" ] );\n   die "'\$work_path' not created by vss checkout" unless -e \$work_path ;\n\n   return \$work_path ;\n}\n\n\nsub backfill {\n   my VCP::Dest::vss \$self = shift ;\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\n   \$r->work_path( \$self->checkout_file( \$r ) ) ;\n\n   return 1 ;\n}\n\n\nsub handle_rev {\n   my VCP::Dest::vss \$self = shift ;\n\n   my VCP::Rev \$r ;\n   ( \$r ) = \@_ ;\n\n   \$self->compare_base_revs( \$r )\n      if \$r->is_base_rev && defined \$r->work_path ;\n\n   ## Don't save the reference.  This forces the DESTROY to happen here,\n   ## if possible.  TODO: Keep VCP::Rev from deleting files prematurely.\n   my \$saw = ! ! \$self->seen( \$r );\n\n   return if \$r->is_base_rev ;\n\n   my \$fn = File::Spec->catfile(\n      \$self->rev_root,\n      \$r->name\n   );\n   my \$work_path = \$self->work_path( "co", \$fn ) ;\n\n   my ( \$vol, \$work_dir, undef ) = File::Spec->splitpath( \$work_path ) ;\n   \$work_dir = File::Spec->catpath( \$vol, \$work_dir, "" );\n   \$self->mkdir( \$work_dir );\n   \$work_dir =~ s{[\\\\/]+\$}{}; ## vss is picky about trailing slashes in -GLpath\n\n   if ( -e \$work_path ) {\n      unlink \$work_path or die "\$! unlinking \$work_path" ;\n   }\n\n   ## Add the directories we need to VSS as projects\n   my ( \$file, \$dirs ) = fileparse( \$fn );\n   \$dirs =~ s{\\\\}{/}g;  ## Make debugging output pretty, ss is cool with /\n   {\n      my \@dirs = File::Spec::Unix->splitdir( \$dirs );\n      shift \@dirs while \@dirs && ! length \$dirs[0];\n      pop   \@dirs while \@dirs && ! length \$dirs[-1];\n\n      my \$cur_project = "";\n      for ( \@dirs ) {\n         \$cur_project .= "/" if length \$cur_project;\n         \$cur_project .= \$_;\n\n         unless ( \$self->vss_file( \$cur_project ) ) {\n            \$self->ss( [ "Create", "\\\$/\$cur_project", "-C-" ] );\n            \$self->vss_file( \$cur_project, "project" );\n         }\n      }\n   }\n\n   \$self->ss( [ "cp", "\\\$/\$dirs" ] );\n\n   if ( \$r->action eq "delete" ) {\n      my \$tmp_f = \$self->command_stderr_filter;\n      \$self->command_stderr_filter(\n         qr{^You have.*checked out.*Y[\\r\\n]*\$}s\n      ) ;\n\n      \$self->ss( [ 'Delete', \$file, "-I-y" ] );\n      \$self->vss_file( \$fn, 0 );\n      \$self->{VSS_CHECKED_OUT}->{\$fn} = 0;\n      ## TODO: Restore the file instead of adding it if it comes back?\n      \$self->command_stderr_filter( \$tmp_f );\n   }\n   else {\n      debug "vcp: linking ", \$r->work_path, " to \$work_path"\n         if debugging \$self ;\n\n      link \$r->work_path, \$work_path\n         or die "\$! linking '", \$r->work_path, "' -> \$work_path" ;\n\n      if ( defined \$r->mod_time ) {\n         utime \$r->mod_time, \$r->mod_time, \$work_path\n            or die "\$! changing times on \$work_path" ;\n      }\n\n      my \$comment_flag = "-C-";\n      if ( defined \$r->comment ) {\n         my \$cfn = \$self->work_path( "comment.txt" ) ;\n         open COMMENT, ">\$cfn"       or die "\$!: \$cfn";\n         print COMMENT \$r->comment   or die "\$!: \$cfn";\n         close COMMENT               or die "\$!: \$cfn";\n         \$comment_flag = "-C\\\@\$cfn";\n      }\n\n      my \$check_it_in = 1;\n\n      if ( ! \$self->{VSS_CHECKED_OUT}->{\$fn} ) {\n         my \$bin_flag = \$r->type ne "text" ? "-B" : "-B-";\n#         my \$tmp_f = \$self->command_stderr_filter;\n#         \$self->command_stderr_filter(\n#            qr{^A deleted file of the same name already exists.*|[\\r\\n]*\$}s\n#         ) ;\n\n         my \$stderr = "";\n         if ( ! \$self->vss_file_is_active( \$fn ) ) {\n            ## If the file has been deleted before, -I-y causes ss to recover it\n            ## instead of adding it anew.\n            \$check_it_in = 0;\n            \$self->ss(\n               [ "Add", \$work_path, "-K", \$bin_flag, \$comment_flag, "-I-y" ],\n               '2>', \\\$stderr,\n            );\n         }\n\n         if ( \$stderr =~ /A deleted file of the same name already exists/ ) {\n            \$check_it_in = 1;\n            \$self->ss(\n               [ "Checkout", \$file, "-G-" ]\n            );\n\n         }\n         elsif ( length \$stderr ) {\n            die "unexpected stderr from ss Add:\\n", \$stderr;\n         }\n         \$self->vss_file( \$fn, "file" );\n         \$self->{VSS_CHECKED_OUT}->{\$fn}++;\n#         \$self->command_stderr_filter( \$tmp_f );\n      }\n\n      if ( \$check_it_in ) {\n         ## TODO: Don't assume same filesystem or working link().\n         my \$tmp_f = \$self->command_stderr_filter;\n         \$self->command_stderr_filter(\n            qr{^.*was checked out from.*not from the current folder\\.\\r?\\nContinue.*\\r?\\n}\n         ) ;\n\n         \$self->ss(\n            [ "Checkin", \$file, "-GL\$work_dir", "-K", "-I-y", \$comment_flag ]\n         );\n         \$self->command_stderr_filter( \$tmp_f );\n      }\n\n      my \@labels = map {\n         s/^([^a-zA-Z])/tag_\$1/ ;\n\x09 s/\\W/_/g ;\n\x09 \$_ ;\n      }(\n\x09 \$r->labels,  ## Put the existing label (if any) first\n\x09 defined \$r->rev_id    ? "r_" . \$r->rev_id     : (),\n         defined \$r->change_id ? "ch_" . \$r->change_id : (),\n      ) ;\n\n      my \$version;\n\$self->ss( [ "cp", "\\\$/\$dirs" ] );\n      \$self->ss( [ "History", \$file, "-#1" ], ">", \\\$version );\n      undef \$version unless\n         \$version =~ s/.*^\\*+\\s+Version\\s+(\\d+)\\s+\\*+\$(.*)/\$1/ms;\n      ## Don't replace existing labels; this can happen if the version\n      ## was recovered from a previous delete, for instance.\n      undef \$version if \$2 =~ /^Label:\\s+/m;\n\n      for ( \@labels ) {\n         \$self->ss( [\n            "Label",\n            \$file,\n            "-L\$_",\n            "-C-",\n            "-I-y",   ## Yes, please reuse the label\n            defined \$version ? "-V\$version" : ()\n         ]);\n\n         undef \$version;\n      }\n   }\n}\n\n=head1 TODO\n\nThis module is here purely to support the VCP test suite, which must\nimport a bunch of files in to VSS before it can test the export.  It works,\nbut is not field tested.\n\nWhile I'm sure there exist pressing reasons for importing files in to\nVSS from other repositories, I have never had such a request and do not\nwish to invest a lot of effort in advance of such a request.\n\nTherefore, this module does not batch checkins, cope with branches,\noptimize comment settings, etc.\n\nPatches or contracts welcome.\n\n=head1 NOTES\n\nVSS does not flag individual revisions as binary vs. text; the change is\nmade on a per-file basis.  This module does not alter the filetype on\nC<Checkin>, however it does set binary (-B) vs. text (-B-) on C<Add>.\n\nVSS allows one label per file, and adding a label (by default) causes a\nnew versions of the file.  This module adds the first label it receives\nfor a file (which is first may or may not be predictable depending on\nthe source repository) to the existing version unless the existing\nversion already has a label, then it just adds new versions as needed.\n\nThis leads to the backfilling issue: when backfilling, there are no labels\nto request, so backfilling always assumes that the most recent rev is the\nbase rev for incremental imports.\n\nThe C<ss Delete> command does not allow a comment.\n\nFiles are recalled from deleted status when added again if they were\ndeleted.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nCopyright (c) 2000, 2001, 2002 Perforce Software, Inc.\nAll rights reserved.\n\nSee L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACQ
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACR, "lib/RevML/Writer.pm" }
package RevML::Writer ;\n\n=head1 NAME\n\nRevML::Writer - Write RevML files using the RevML DTD\n\n=head1 SYNOPSIS\n\n   use RevML::Doctype::v1_1 ;\n   use RevML::Writer ;\n\n=head1 DESCRIPTION\n\nThis class provides facilities to write out the tags and content of\nRevML documents.  See XML::AutoWriter for all the details on this\nwriter's API.\n\n=cut\n\n\nuse strict ;\nuse vars qw( \$VERSION ) ;\n\nuse base qw( XML::AutoWriter ) ;\n\n\$VERSION = 0.1 ;\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAACR
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACS, "lib/RevML/Doctype.pm" }
package RevML::Doctype ;\n\n=head1 NAME\n\nRevML::Doctype - A subclass of XML::Doctype\n\n=head1 SYNOPSIS\n\n   use RevML::Doctype ;\n\n   ## To use the highest RevML::Doctype module (e.g. RevML::Doctype::v0_22)\n   \$rmldt = RevML::Doctype->new ;\n\n   ## To parse a .dtd file:\n   \$rmldt = RevML::Doctype->new( 'revml.dtd' );\n   \$rmldt = RevML::Doctype->new( DTD_FILE => 'revml.dtd' );\n\n   ## To load a preparsed .pm file\n   \$rmldt = RevML::Doctype->new( 1.1 ) ;\n   \$rmldt = RevML::Doctype->new( VERSION => 1.1 ) ;\n\n\n=head1 DESCRIPTION\n\n=head1 METHODS\n\n=over\n\n=cut\n\nuse strict ;\n\nuse Carp ;\n\nuse XML::Doctype ;\n\nuse base 'XML::Doctype' ;\n\nuse fields (\n) ;\n\nuse vars qw( \$VERSION ) ;\n\n\$VERSION = 0.1 ;\n\n\n=item new\n\nCreates an instance.\n\n=cut\n\nsub _highest_doctype_pm_version {\n   my \$ver = 0 ;\n   for ( \@INC ) {\n      for ( glob "\$_/RevML/Doctype/*.pm" ) {\n\x09 next unless s{.*/v([\\d_]+)\\.pm\$}{\$1} ;\n\x09 tr/_/./ ;\n\x09 \$ver = \$_ if \$_ > \$ver;\n      } \n   }\n   return \$ver ;\n}\n\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my ( \$dtd_spec ) = \@_ ;\n\n   \$dtd_spec = _highest_doctype_pm_version\n      if ! defined \$dtd_spec || \$dtd_spec eq 'DEFAULT' ;\n\n   die "No RevML::Doctype found, use -dtd option or install a RevML::DocType::vXXX module\\n"\n      unless \$dtd_spec ;\n\n   ## Try to load \$self from a file, or bless one ourself and parse a DTD.\n   my RevML::Doctype \$self ;\n\n   if ( \$dtd_spec =~ /^\\d+(?:\\.\\d+)*\$/ ) {\n      ## TODO: Make the save format provide a new(), or be data-only.\n      my \$doctype_pm = \$dtd_spec ;\n      \$doctype_pm =~ tr/./_/ ;\n      require "RevML/Doctype/v\$doctype_pm.pm" ;\n      no strict 'refs' ;\n      \$self = \${"RevML::Doctype::v\$doctype_pm\\::doctype"} ;\n      die \$\@ if \$\@ ;\n   }\n   else {\n      ## Read in the DTD from a file.\n      {\n\x09 no strict 'refs' ;\n\x09 \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n      }\n\n      ## Read in the file instead of referring to an external entitity to\n      ## get more meaningful error messages.  It's short.\n      ## TODO: This is probably the result of a minor tail-chasing incident\n      ## and we might be able to go back and read the file directly\n      open( DTD, "<\$dtd_spec" ) or die "\$!: \$dtd_spec" ;\n      my \$dtd = join( '', <DTD> ) ;\n      close DTD ;\n      \$self = \$class->SUPER::new( 'revml', DTD_TEXT => \$dtd ) ;\n   }\n\n   die "Unable to load DTD", defined \$dtd_spec ? " '\$dtd_spec'" : '', "\\n"\n      unless \$self ;\n\n   die "No <revml> version attribute found"\n      unless defined \$self->version ;\n\n   return \$self ;\n}\n\n\n=item save_as_pm\n\n   \$doctype->save_as_pm ;\n   \$doctype->save_as_pm( \$out_spec ) ;\n\nOutspec is a module name.  'RevML::Doctype::vNNN' is assumed if\nno outspec is provided.  Use '-' to emit to STDOUT.\n\nSaves the Doctype object in a perl module.  Tries to save in\nlib/RevML/Doctype/ if that directory exists, then in ./ if not.\n\n=cut\n\nsub save_as_pm {\n   my RevML::Doctype \$self = shift ;\n\n   my ( \$out_spec ) = \@_ ;\n   ## TODO: Try to prevent accidental overwrites by looking for\n   ## the destination and diffing, then promping if a diff is\n   ## found.\n   \$out_spec = "RevML::Doctype::v" . \$self->version\n      unless defined \$out_spec ;\n\n   \$out_spec =~ s/\\./_/g ;\n\n   if ( \$out_spec ne '-' ) {\n      my \$out_file = \$out_spec ;\n      \$out_file =~ s{::}{/}g ;\n      \$out_file =~ s{^/+}{}g ;\n      \$out_file .= '.pm' ;\n\n      require File::Basename ;\n      my \$out_dir = File::Basename::dirname( \$out_file ) ;\n\n      if ( -d File::Spec->catdir( 'lib', \$out_dir ) ) {\n\x09 \$out_file = File::Spec->catfile( 'lib', \$out_file ) ;\n      }\n      elsif ( ! -d \$out_dir ) {\n\x09 \$out_file = File::Basename::fileparse( \$out_file ) ;\n      }\n\n      print "writing RevML v" . \$self->version . " to '\$out_file' as '\$out_spec'.\\n" ;\n      open( F, ">\$out_file" ) || die "\$! \$out_file" ;\n      print F \$self->as_pm( \$out_spec ) ;\n      close F ;\n\n      ## Test for compilability if we saved it.\n      exec( 'perl', '-w', \$out_file ) if defined \$out_file ;\n   }\n   else {\n      print \$self->as_pm( \$out_spec ) ;\n   }\n\n   return ;\n}\n\n\nsub version {\n   my RevML::Doctype \$self = shift ;\n   return \$self->element_decl( 'revml' )->attdef( 'version' )->default ;\n}\n\n\n=item import\n\n=item use\n\n   ## To extablish a default RevML::Doctype for the current package:\n   use RevML::Doctype 'DEFAULT' ;\n   use RevML::Doctype DTD_FILE => 'revml.dtd' ;\n\n=cut\n\n## This inherits XML::Doctype::import, which passes through the args\n## to our constructor.\n\n\n=head1 SUBCLASSING\n\nThis class uses the fields pragma, so you'll need to use base and \npossibly fields in any subclasses.\n\n=head1 COPYRIGHT\n\nCopyright 2000, Perforce Software, Inc.  All Rights Reserved.\n\nThis module and the VCP package are licensed according to the terms given in\nthe file LICENSE accompanying this distribution, a copy of which is included in\nL<vcp>.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1\n
END_OF_FILE_AAAAAAAAAACS
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACT, "lib/RevML/Doctype/v0_26.pm" }
package RevML::Doctype::v0_26 ;\n\n##\n## THIS FILE CREATED AUTOMATICALLY: YOU MAY LOSE ANY EDITS IF YOU MOFIFY IT.\n##\n## When: Fri Aug 18 22:39:26 2000\n## By:   RevML::Doctype, v0.1, (XML::Doctype, v0.11)\n##\n\nrequire XML::Doctype ;\n\nsub import {\n   my \$pkg = shift ;\n   my \$callpkg = caller ;\n   \$XML::Doctype::_default_dtds{\$callpkg} = \$doctype ;\n}\n\n\$doctype = bless( [\n  {\n    'NAME' => 2,\n    'PUBID' => 4,\n    'ELTS' => 1,\n    'SYSID' => 3\n  },\n  {\n    'rev' => bless( [\n      {\n        'NAMES' => 5,\n        'ATTDEFS' => 1,\n        'DECLARED' => 3,\n        'NAME' => 4,\n        'CONTENT' => 2,\n        'TODO' => 7,\n        'PATHS' => 6\n      },\n      undef,\n      '^<name><type>(?:<cvs_info>|<p4_info>|<source_safe_info>|<pvcs_info>)?(?:<branch_id>)?<rev_id>(?:<change_id>)?<time>(?:<mod_time>)?<user_id>(?:<p4_action>|<sourcesafe_action>)?(?:<label>)*(?:<lock>)?(?:<comment>)?(?:<delete>|<move>|(?:<content>|(?:<base_name>)?<base_rev_id><delta>)<digest>)\$',\n      1,\n      'rev',\n      [\n        'p4_info',\n        'cvs_info',\n        'sourcesafe_action',\n        'rev_id',\n        'delta',\n        'source_safe_info',\n        'name',\n        'mod_time',\n        'pvcs_info',\n        'label',\n        'base_name',\n        'type',\n        'delete',\n        'user_id',\n        'p4_action',\n        'time',\n        'comment',\n        'content',\n        'branch_id',\n        'lock',\n        'change_id',\n        'digest',\n        'base_rev_id',\n        'move'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'cvs_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'cvs_info',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_map_sn' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_map_sn',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'base_name' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'base_name',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'user_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'user_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rep_desc' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rep_desc',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_action' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_action',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rev_root' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rev_root',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'time' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'time',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'comment' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'comment',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'change_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'change_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'digest' => bless( [\n      {},\n      {\n        'type' => bless( [\n          {\n            'QUANT' => 4,\n            'TYPE' => 5,\n            'NAME' => 2,\n            'OUT_DEFAULT' => 3,\n            'DEFAULT' => 1\n          },\n          undef,\n          'type',\n          undef,\n          '#REQUIRED',\n          '(MD5)'\n        ], 'XML::Doctype::AttDef' ),\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'digest',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'cvs_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'cvs_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_info',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'sourcesafe_action' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'sourcesafe_action',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'file_count' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'file_count',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'delta' => bless( [\n      {},\n      {\n        'type' => bless( [\n          {},\n          undef,\n          'type',\n          undef,\n          '#REQUIRED',\n          '(diff-u)'\n        ], 'XML::Doctype::AttDef' ),\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(none|base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'delta',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'source_safe_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'source_safe_info',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'revml' => bless( [\n      {},\n      {\n        'version' => bless( [\n          {},\n          '0.26',\n          'version',\n          undef,\n          '#FIXED',\n          'CDATA'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^<time><rep_type><rep_desc>(?:<comment>)?(?:<file_count>)?(?:<branch_map_id><branch_map_sn>|(?:<branch>)*)?<rev_root>(?:<rev>)*\$',\n      1,\n      'revml',\n      [\n        'rev',\n        'rep_desc',\n        'rep_type',\n        'comment',\n        'branch_map_sn',\n        'rev_root',\n        'branch_map_id',\n        'branch',\n        'file_count',\n        'time'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'name' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'name',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'mod_time' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'mod_time',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rep_type' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rep_type',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'pvcs_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<trunk_rev_id>|<attrib>)*\$',\n      1,\n      'pvcs_info',\n      [\n        'attrib',\n        'trunk_rev_id'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_map_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_map_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'sourcesafe_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'sourcesafe_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'label' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'label',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'type' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'type',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'trunk_rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'trunk_rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'delete' => bless( [\n      {},\n      undef,\n      'EMPTY',\n      1,\n      'delete',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch' => bless( [\n      {},\n      undef,\n      '^<branch_id>(?:<cvs_branch_id>)?(?:<p4_branch_id>)?(?:<sourcesafe_branch_id>)?\$',\n      1,\n      'branch',\n      [\n        'branch_id',\n        'sourcesafe_branch_id',\n        'p4_branch_id',\n        'cvs_branch_id'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'attrib' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'attrib',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'content' => bless( [\n      {},\n      {\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(none|base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'content',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'lock' => bless( [\n      {},\n      undef,\n      '^(?:<time>)?<user_id>\$',\n      1,\n      'lock',\n      [\n        'user_id',\n        'time'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'move' => bless( [\n      {},\n      undef,\n      '^<name>\$',\n      1,\n      'move',\n      [\n        'name'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'base_rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'base_rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' )\n  },\n  'revml',\n  undef,\n  undef\n], 'RevML::Doctype' );\n\$doctype->[1]{'cvs_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_map_sn'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'base_name'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'user_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rep_desc'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_action'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rev_root'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'time'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'comment'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'change_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'digest'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'digest'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'cvs_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'sourcesafe_action'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'file_count'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delta'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delta'}[1]{'type'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'delta'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'source_safe_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'revml'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'revml'}[1]{'version'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'name'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'mod_time'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rep_type'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'pvcs_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_map_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'sourcesafe_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'label'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'type'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'trunk_rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delete'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'attrib'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'content'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'content'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'lock'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'move'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'base_rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\n 1 ;\n
END_OF_FILE_AAAAAAAAAACT
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACU, "lib/RevML/Doctype/v0_27.pm" }
package RevML::Doctype::v0_27 ;\n\n##\n## THIS FILE CREATED AUTOMATICALLY: YOU MAY LOSE ANY EDITS IF YOU MOFIFY IT.\n##\n## When: Thu Sep  7 11:35:49 2000\n## By:   RevML::Doctype, v0.1, (XML::Doctype, v0.11)\n##\n\nrequire XML::Doctype ;\n\nsub import {\n   my \$pkg = shift ;\n   my \$callpkg = caller ;\n   \$XML::Doctype::_default_dtds{\$callpkg} = \$doctype ;\n}\n\n\$doctype = bless( [\n  {\n    'NAME' => 2,\n    'PUBID' => 4,\n    'ELTS' => 1,\n    'SYSID' => 3\n  },\n  {\n    'rev' => bless( [\n      {\n        'NAMES' => 5,\n        'ATTDEFS' => 1,\n        'DECLARED' => 3,\n        'NAME' => 4,\n        'CONTENT' => 2,\n        'TODO' => 7,\n        'PATHS' => 6\n      },\n      undef,\n      '^<name><type>(?:<rev_id>(?:<change_id>)?<digest>|(?:<cvs_info>|<p4_info>|<source_safe_info>|<pvcs_info>)?(?:<branch_id>)?<rev_id>(?:<change_id>)?<time>(?:<mod_time>)?<user_id>(?:<p4_action>|<sourcesafe_action>)?(?:<label>)*(?:<lock>)?(?:<comment>)?(?:<delete>|<move>|(?:<content>|(?:<base_name>)?<base_rev_id><delta>)<digest>))\$',\n      1,\n      'rev',\n      [\n        'p4_info',\n        'cvs_info',\n        'sourcesafe_action',\n        'rev_id',\n        'delta',\n        'source_safe_info',\n        'name',\n        'mod_time',\n        'pvcs_info',\n        'label',\n        'base_name',\n        'type',\n        'delete',\n        'user_id',\n        'p4_action',\n        'time',\n        'comment',\n        'content',\n        'branch_id',\n        'lock',\n        'change_id',\n        'digest',\n        'base_rev_id',\n        'move'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'cvs_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'cvs_info',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_map_sn' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_map_sn',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'base_name' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'base_name',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'user_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'user_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rep_desc' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rep_desc',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_action' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_action',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rev_root' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rev_root',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'time' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'time',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'comment' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'comment',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'change_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'change_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'digest' => bless( [\n      {},\n      {\n        'type' => bless( [\n          {\n            'QUANT' => 4,\n            'TYPE' => 5,\n            'NAME' => 2,\n            'OUT_DEFAULT' => 3,\n            'DEFAULT' => 1\n          },\n          undef,\n          'type',\n          undef,\n          '#REQUIRED',\n          '(MD5)'\n        ], 'XML::Doctype::AttDef' ),\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'digest',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'cvs_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'cvs_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_info',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'sourcesafe_action' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'sourcesafe_action',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'file_count' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'file_count',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'delta' => bless( [\n      {},\n      {\n        'type' => bless( [\n          {},\n          undef,\n          'type',\n          undef,\n          '#REQUIRED',\n          '(diff-u)'\n        ], 'XML::Doctype::AttDef' ),\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(none|base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'delta',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'source_safe_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'source_safe_info',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'revml' => bless( [\n      {},\n      {\n        'version' => bless( [\n          {},\n          '0.27',\n          'version',\n          undef,\n          '#FIXED',\n          'CDATA'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^<time><rep_type><rep_desc>(?:<comment>)?(?:<file_count>)?(?:<branch_map_id><branch_map_sn>|(?:<branch>)*)?<rev_root>(?:<rev>)*\$',\n      1,\n      'revml',\n      [\n        'rev',\n        'rep_desc',\n        'rep_type',\n        'comment',\n        'branch_map_sn',\n        'rev_root',\n        'branch_map_id',\n        'branch',\n        'file_count',\n        'time'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'name' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'name',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'mod_time' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'mod_time',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rep_type' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rep_type',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'pvcs_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<trunk_rev_id>|<attrib>)*\$',\n      1,\n      'pvcs_info',\n      [\n        'attrib',\n        'trunk_rev_id'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_map_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_map_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'sourcesafe_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'sourcesafe_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'label' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'label',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'type' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'type',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'trunk_rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'trunk_rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'delete' => bless( [\n      {},\n      undef,\n      'EMPTY',\n      1,\n      'delete',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch' => bless( [\n      {},\n      undef,\n      '^<branch_id>(?:<cvs_branch_id>)?(?:<p4_branch_id>)?(?:<sourcesafe_branch_id>)?\$',\n      1,\n      'branch',\n      [\n        'branch_id',\n        'sourcesafe_branch_id',\n        'p4_branch_id',\n        'cvs_branch_id'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'attrib' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'attrib',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'content' => bless( [\n      {},\n      {\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(none|base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'content',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'lock' => bless( [\n      {},\n      undef,\n      '^(?:<time>)?<user_id>\$',\n      1,\n      'lock',\n      [\n        'user_id',\n        'time'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'move' => bless( [\n      {},\n      undef,\n      '^<name>\$',\n      1,\n      'move',\n      [\n        'name'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'base_rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'base_rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' )\n  },\n  'revml',\n  undef,\n  undef\n], 'RevML::Doctype' );\n\$doctype->[1]{'cvs_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_map_sn'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'base_name'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'user_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rep_desc'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_action'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rev_root'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'time'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'comment'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'change_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'digest'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'digest'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'cvs_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'sourcesafe_action'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'file_count'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delta'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delta'}[1]{'type'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'delta'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'source_safe_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'revml'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'revml'}[1]{'version'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'name'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'mod_time'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rep_type'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'pvcs_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_map_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'sourcesafe_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'label'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'type'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'trunk_rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delete'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'attrib'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'content'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'content'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'lock'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'move'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'base_rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\n 1 ;\n
END_OF_FILE_AAAAAAAAAACU
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACV, "lib/RevML/Doctype/v0_28.pm" }
package RevML::Doctype::v0_28 ;\n\n##\n## THIS FILE CREATED AUTOMATICALLY: YOU MAY LOSE ANY EDITS IF YOU MOFIFY IT.\n##\n## When: Fri Dec 15 07:57:43 2000\n## By:   RevML::Doctype, v0.1, (XML::Doctype, v0.11)\n##\n\nrequire XML::Doctype ;\n\nsub import {\n   my \$pkg = shift ;\n   my \$callpkg = caller ;\n   \$XML::Doctype::_default_dtds{\$callpkg} = \$doctype ;\n}\n\n\$doctype = bless( [\n  {\n    'NAME' => 2,\n    'PUBID' => 4,\n    'ELTS' => 1,\n    'SYSID' => 3\n  },\n  {\n    'rev' => bless( [\n      {\n        'NAMES' => 5,\n        'ATTDEFS' => 1,\n        'DECLARED' => 3,\n        'NAME' => 4,\n        'CONTENT' => 2,\n        'TODO' => 7,\n        'PATHS' => 6\n      },\n      undef,\n      '^<name><type>(?:<rev_id>(?:<change_id>)?<digest>|(?:<cvs_info>|<p4_info>|<source_safe_info>|<pvcs_info>)?(?:<branch_id>)?<rev_id>(?:<change_id>)?<time>(?:<mod_time>)?<user_id>(?:<p4_action>|<sourcesafe_action>)?(?:<label>)*(?:<lock>)?(?:<comment>)?(?:<delete>|<move>|(?:<content>|(?:<base_name>)?<base_rev_id><delta>)<digest>))\$',\n      1,\n      'rev',\n      [\n        'p4_info',\n        'cvs_info',\n        'sourcesafe_action',\n        'rev_id',\n        'delta',\n        'source_safe_info',\n        'name',\n        'mod_time',\n        'pvcs_info',\n        'label',\n        'base_name',\n        'type',\n        'delete',\n        'user_id',\n        'p4_action',\n        'time',\n        'comment',\n        'content',\n        'branch_id',\n        'lock',\n        'change_id',\n        'digest',\n        'base_rev_id',\n        'move'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'cvs_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'cvs_info',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_map_sn' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_map_sn',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'base_name' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'base_name',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'user_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'user_id',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'rep_desc' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'rep_desc',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_action' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_action',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rev_root' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'rev_root',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'time' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'time',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'comment' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'comment',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'change_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'change_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'digest' => bless( [\n      {},\n      {\n        'type' => bless( [\n          {\n            'QUANT' => 4,\n            'TYPE' => 5,\n            'NAME' => 2,\n            'OUT_DEFAULT' => 3,\n            'DEFAULT' => 1\n          },\n          undef,\n          'type',\n          undef,\n          '#REQUIRED',\n          '(MD5)'\n        ], 'XML::Doctype::AttDef' ),\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'digest',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'cvs_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'cvs_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'p4_info',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'sourcesafe_action' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'sourcesafe_action',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'char' => bless( [\n      {},\n      {\n        'code' => bless( [\n          {},\n          undef,\n          'code',\n          undef,\n          '#REQUIRED',\n          'CDATA'\n        ], 'XML::Doctype::AttDef' )\n      },\n      'EMPTY',\n      1,\n      'char',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'file_count' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'file_count',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'delta' => bless( [\n      {},\n      {\n        'type' => bless( [\n          {},\n          undef,\n          'type',\n          undef,\n          '#REQUIRED',\n          '(diff-u)'\n        ], 'XML::Doctype::AttDef' ),\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(none|base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'delta',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'source_safe_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'source_safe_info',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'revml' => bless( [\n      {},\n      {\n        'version' => bless( [\n          {},\n          '0.28',\n          'version',\n          undef,\n          '#FIXED',\n          'CDATA'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^<time><rep_type><rep_desc>(?:<comment>)?(?:<file_count>)?(?:<branch_map_id><branch_map_sn>|(?:<branch>)*)?<rev_root>(?:<rev>)*\$',\n      1,\n      'revml',\n      [\n        'rev',\n        'rep_desc',\n        'rep_type',\n        'comment',\n        'branch_map_sn',\n        'rev_root',\n        'branch_map_id',\n        'branch',\n        'file_count',\n        'time'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'name' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'name',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'mod_time' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'mod_time',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rep_type' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rep_type',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'pvcs_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<trunk_rev_id>|<attrib>|<char>)*\$',\n      1,\n      'pvcs_info',\n      [\n        'attrib',\n        'char',\n        'trunk_rev_id'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_map_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_map_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'sourcesafe_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'sourcesafe_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'label' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'label',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'type' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'type',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'trunk_rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'trunk_rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'delete' => bless( [\n      {},\n      undef,\n      'EMPTY',\n      1,\n      'delete',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch' => bless( [\n      {},\n      undef,\n      '^<branch_id>(?:<cvs_branch_id>)?(?:<p4_branch_id>)?(?:<sourcesafe_branch_id>)?\$',\n      1,\n      'branch',\n      [\n        'branch_id',\n        'sourcesafe_branch_id',\n        'p4_branch_id',\n        'cvs_branch_id'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'attrib' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'attrib',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'content' => bless( [\n      {},\n      {\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(none|base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'content',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'lock' => bless( [\n      {},\n      undef,\n      '^(?:<time>)?<user_id>\$',\n      1,\n      'lock',\n      [\n        'user_id',\n        'time'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'move' => bless( [\n      {},\n      undef,\n      '^<name>\$',\n      1,\n      'move',\n      [\n        'name'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'base_rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'base_rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' )\n  },\n  'revml',\n  undef,\n  undef\n], 'RevML::Doctype' );\n\$doctype->[1]{'cvs_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_map_sn'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'base_name'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'user_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rep_desc'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_action'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rev_root'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'time'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'comment'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'change_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'digest'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'digest'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'cvs_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'sourcesafe_action'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'char'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'char'}[1]{'code'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'file_count'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delta'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delta'}[1]{'type'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'delta'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'source_safe_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'revml'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'revml'}[1]{'version'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'name'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'mod_time'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rep_type'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'pvcs_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_map_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'sourcesafe_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'label'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'type'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'trunk_rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delete'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'attrib'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'content'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'content'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'lock'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'move'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'base_rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\n 1 ;\n
END_OF_FILE_AAAAAAAAAACV
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACW, "lib/RevML/Doctype/v0_29.pm" }
package RevML::Doctype::v0_29 ;\n\n##\n## THIS FILE CREATED AUTOMATICALLY: YOU MAY LOSE ANY EDITS IF YOU MOFIFY IT.\n##\n## When: Wed May  8 16:40:27 2002\n## By:   RevML::Doctype, v0.1, (XML::Doctype, v0.11)\n##\n\nrequire XML::Doctype ;\n\nsub import {\n   my \$pkg = shift ;\n   my \$callpkg = caller ;\n   \$XML::Doctype::_default_dtds{\$callpkg} = \$doctype ;\n}\n\n\$doctype = bless( [\n  {\n    'NAME' => 2,\n    'PUBID' => 4,\n    'ELTS' => 1,\n    'SYSID' => 3\n  },\n  {\n    'rev' => bless( [\n      {\n        'NAMES' => 5,\n        'ATTDEFS' => 1,\n        'DECLARED' => 3,\n        'NAME' => 4,\n        'CONTENT' => 2,\n        'TODO' => 7,\n        'PATHS' => 6\n      },\n      undef,\n      '^<name>(?:<type><rev_id>(?:<change_id>)?<digest>|<type>(?:<cvs_info>|<p4_info>|<source_safe_info>|<pvcs_info>)?(?:<branch_id>)?<rev_id>(?:<change_id>)?<time>(?:<mod_time>)?<user_id>(?:<p4_action>|<sourcesafe_action>)?(?:<label>)*(?:<lock>)?(?:<comment>)?(?:<move>|(?:<content>|(?:<base_name>)?<base_rev_id><delta>)<digest>)|(?:<type>)?(?:<cvs_info>|<p4_info>|<source_safe_info>|<pvcs_info>)?(?:<branch_id>)?(?:<rev_id>)?(?:<change_id>)?(?:<time>)?(?:<mod_time>)?(?:<user_id>)?(?:<p4_action>|<sourcesafe_action>)?(?:<label>)*(?:<lock>)?(?:<comment>)?<delete>)\$',\n      1,\n      'rev',\n      [\n        'p4_info',\n        'cvs_info',\n        'sourcesafe_action',\n        'rev_id',\n        'delta',\n        'source_safe_info',\n        'name',\n        'mod_time',\n        'pvcs_info',\n        'label',\n        'base_name',\n        'type',\n        'delete',\n        'user_id',\n        'p4_action',\n        'time',\n        'comment',\n        'content',\n        'branch_id',\n        'lock',\n        'change_id',\n        'digest',\n        'base_rev_id',\n        'move'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'cvs_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'cvs_info',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_map_sn' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_map_sn',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'base_name' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'base_name',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'user_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'user_id',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'rep_desc' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'rep_desc',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_action' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_action',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rev_root' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'rev_root',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'time' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'time',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'comment' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'comment',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'change_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'change_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'digest' => bless( [\n      {},\n      {\n        'type' => bless( [\n          {\n            'QUANT' => 4,\n            'TYPE' => 5,\n            'NAME' => 2,\n            'OUT_DEFAULT' => 3,\n            'DEFAULT' => 1\n          },\n          undef,\n          'type',\n          undef,\n          '#REQUIRED',\n          '(MD5)'\n        ], 'XML::Doctype::AttDef' ),\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'digest',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'cvs_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'cvs_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'p4_info',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'sourcesafe_action' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'sourcesafe_action',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'char' => bless( [\n      {},\n      {\n        'code' => bless( [\n          {},\n          undef,\n          'code',\n          undef,\n          '#REQUIRED',\n          'CDATA'\n        ], 'XML::Doctype::AttDef' )\n      },\n      'EMPTY',\n      1,\n      'char',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'file_count' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'file_count',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'delta' => bless( [\n      {},\n      {\n        'type' => bless( [\n          {},\n          undef,\n          'type',\n          undef,\n          '#REQUIRED',\n          '(diff-u)'\n        ], 'XML::Doctype::AttDef' ),\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(none|base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'delta',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'source_safe_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'source_safe_info',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'revml' => bless( [\n      {},\n      {\n        'version' => bless( [\n          {},\n          '0.29',\n          'version',\n          undef,\n          '#FIXED',\n          'CDATA'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^<time><rep_type><rep_desc>(?:<comment>)?(?:<file_count>)?(?:<branch_map_id><branch_map_sn>|(?:<branch>)*)?<rev_root>(?:<rev>)*\$',\n      1,\n      'revml',\n      [\n        'rev',\n        'rep_desc',\n        'rep_type',\n        'comment',\n        'branch_map_sn',\n        'rev_root',\n        'branch_map_id',\n        'branch',\n        'file_count',\n        'time'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'name' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'name',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'mod_time' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'mod_time',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'rep_type' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'rep_type',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'pvcs_info' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<trunk_rev_id>|<attrib>|<char>)*\$',\n      1,\n      'pvcs_info',\n      [\n        'attrib',\n        'char',\n        'trunk_rev_id'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch_map_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'branch_map_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'sourcesafe_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'sourcesafe_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'label' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'label',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'type' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'type',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'trunk_rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'trunk_rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'delete' => bless( [\n      {},\n      undef,\n      'EMPTY',\n      1,\n      'delete',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'p4_branch_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'p4_branch_id',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'branch' => bless( [\n      {},\n      undef,\n      '^<branch_id>(?:<cvs_branch_id>)?(?:<p4_branch_id>)?(?:<sourcesafe_branch_id>)?\$',\n      1,\n      'branch',\n      [\n        'branch_id',\n        'sourcesafe_branch_id',\n        'p4_branch_id',\n        'cvs_branch_id'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'attrib' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'attrib',\n      []\n    ], 'XML::Doctype::ElementDecl' ),\n    'content' => bless( [\n      {},\n      {\n        'encoding' => bless( [\n          {},\n          undef,\n          'encoding',\n          undef,\n          '#REQUIRED',\n          '(none|base64)'\n        ], 'XML::Doctype::AttDef' )\n      },\n      '^(?:(?:#PCDATA)?|<char>)*\$',\n      1,\n      'content',\n      [\n        'char'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'lock' => bless( [\n      {},\n      undef,\n      '^(?:<time>)?<user_id>\$',\n      1,\n      'lock',\n      [\n        'user_id',\n        'time'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'move' => bless( [\n      {},\n      undef,\n      '^<name>\$',\n      1,\n      'move',\n      [\n        'name'\n      ]\n    ], 'XML::Doctype::ElementDecl' ),\n    'base_rev_id' => bless( [\n      {},\n      undef,\n      '^(?:(?:#PCDATA)?)\$',\n      1,\n      'base_rev_id',\n      []\n    ], 'XML::Doctype::ElementDecl' )\n  },\n  'revml',\n  undef,\n  undef\n], 'RevML::Doctype' );\n\$doctype->[1]{'cvs_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_map_sn'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'base_name'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'user_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rep_desc'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_action'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rev_root'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'time'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'comment'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'change_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'digest'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'digest'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'cvs_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'sourcesafe_action'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'char'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'char'}[1]{'code'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'file_count'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delta'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delta'}[1]{'type'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'delta'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'source_safe_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'revml'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'revml'}[1]{'version'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'name'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'mod_time'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'rep_type'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'pvcs_info'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch_map_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'sourcesafe_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'label'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'type'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'trunk_rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'delete'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'p4_branch_id'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'branch'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'attrib'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'content'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'content'}[1]{'encoding'}[0] = \$doctype->[1]{'digest'}[1]{'type'}[0];\n\$doctype->[1]{'lock'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'move'}[0] = \$doctype->[1]{'rev'}[0];\n\$doctype->[1]{'base_rev_id'}[0] = \$doctype->[1]{'rev'}[0];\n\n 1 ;\n
END_OF_FILE_AAAAAAAAAACW
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACX, "lib/Regexp/Shellish.pm" }
package Regexp::Shellish ;\n\n#\n# Copyright 1999, Barrie Slaymaker <barries\@slaysys.com>\n#\n# You may distribute under the terms of either the GNU General Public\n# License or the Artistic License, as specified in the README file.\n#\n\n=head1 NAME\n\nRegexp::Shellish - Shell-like regular expressions\n\n=head1 SYNOPSIS\n\n   use Regexp::Shellish qw( :all ) ;\n\n   \$re = compile_shellish( 'a/c*d' ) ;\n\n   ## This next one's like 'a*d' except that it'll\n   ## match 'a/d'.\n   \$re = compile_shellish( 'a**d' ) ;\n\n   ## And here '**' won't match 'a/d', but behaves\n   ## like 'a*d', except for the possibility of high\n   ## cpu time consumption.\n   \$re = compile_shellish( 'a**d', { star_star => 0 } ) ;\n\n   ## The next two result in identical \$re1 and \$re2.\n   ## The second is a noop so that Regexp references can\n   ## be easily accomodated.\n   \$re1 = compile_shellish( 'a{b,c}d' ) ;\n   \$re2 = compile_shellish( qr/\\A(?:a(?:b|c)d)\\Z/ ) ;\n\n   \@matches = shellish_glob( \$re, \@possibilities ) ;\n\n\n=head1 DESCRIPTION\n\nProvides shell-like regular expressions.  The wildcards provided\nare C<?>, C<*> and C<**>, where C<**> is like C<*> but matches C</>.  See\nL</compile_shellish> for details.\n\nCase sensitivity and constructs like <**>, C<(a*b)>, and C<{a,b,c}>\ncan be disabled.\n\n=over\n\n=cut\n\nuse strict ;\n\nuse Carp ;\nuse Exporter ;\n\nuse vars qw( \$VERSION \@ISA \@EXPORT_OK %EXPORT_TAGS ) ;\n\n\$VERSION = '0.93' ;\n\n\@ISA = qw( Exporter ) ;\n\n\@EXPORT_OK = qw(\n   compile_shellish\n   shellish_glob\n) ;\n\n%EXPORT_TAGS = ( 'all' => \\\@EXPORT_OK ) ;\n\n=item compile_shellish\n\nCompiles a string containing a 'shellish' regular expression, returning a\nRegexp reference.  Regexp references passed in are passed through\nunmolested.\n\nHere are the transformation rules from shellish expression terms to\nperl regular expression terms:\n\n   Shellish  Perl RE\n   ========  =======\n   *         [^/]*\n   ?         .\n   **        .*               ## unless { star_star   => 0 }\n   ...       .*               ## unless { dot_dot_dot => 0 }\n\n   (         (                ## unless { parens => 0 }\n   )         )                ## unless { parens => 0 }\n\n   {a,b,c}   (?:a|b|c)        ## unless { braces => 0 }\n\n   \\a        a                ## These are de-escaped and\n   \\*        \\*               ## passed to quotemeta()\n\nThe wildcards treat newlines as normal characters.\n\nParens group in to \$1..\$n, since they are passed through unmolested\n(unless option parens => 0 is passed).  This is useless when using\nglob_shellish(), though.\n\nThe final parameter can be a hash reference containing options:\n\n   compile_shellish(\n      '**',\n      {\n         anchors        => 0,   ## Doesn't put ^ and \$ around the\n\x09                        ## resulting regexp\n         case_sensitive => 0,   ## Make case insensitive\n         dot_dot_dot    => 0,   ## '...' is now just three '.' chars\n         star_star      => 0,   ## '**' is now two '*' wildcards\n\x09 parens         => 0,   ## '(', ')' are now regular chars\n\x09 braces         => 0,   ## '{', '}' are now regular chars\n      }\n   ) ;\n\nNo option affects Regexps passed through.\n\n=cut\n\nsub compile_shellish {\n   my \$o = \@_ && ref \$_[-1] eq 'HASH' ? pop : {} ;\n   my \$re = shift ;\n\n   return \$re if ref \$re eq 'Regexp' ;\n\n   my \$star_star = ( ! exists \$o->{star_star} || \$o->{star_star} )\n      ? '.*'\n      : '[^/]*[^/]*' ;\n\n   my \$dot_dot_dot = ( ! exists \$o->{dot_dot_dot} || \$o->{dot_dot_dot} )\n      ? '.*'\n      : '\\.\\.\\.' ;\n\n   my \$case = ( ! exists \$o->{case_sensitive} || \$o->{case_sensitive} )\n      ? ''\n      : 'i' ;\n\n   my \$anchors     = ( ! exists \$o->{anchors} || \$o->{anchors} ) ;\n   my \$pass_parens = ( ! exists \$o->{parens}  || \$o->{parens} ) ;\n   my \$pass_braces = ( ! exists \$o->{braces}  || \$o->{braces} ) ;\n\n   my \$brace_depth = 0 ;\n\n   my \$orig = \$re ;\n\n   \$re =~ s\@\n      (  \\\\.\n      |  \\*\\*\n      |  \\.\\.\\.\n      |  .\n      )\n   \@\n      if ( \$1 eq '?' ) {\n\x09 '[^/]' ;\n      }\n      elsif ( \$1 eq '*' ) {\n\x09 '[^/]*' ;\n      }\n      elsif ( \$1 eq '**' ) {\n\x09 \$star_star ;\n      }\n      elsif ( \$1 eq '...' ) {\n\x09 \$dot_dot_dot;\n      }\n      elsif ( \$pass_braces && \$1 eq '{' ) {\n\x09 ++\$brace_depth ;\n         '(?:' ;\n      }\n      elsif ( \$pass_braces && \$1 eq '}' ) {\n\x09 croak "Unmatched '}' in '\$orig'" unless \$brace_depth-- ;\n         ')' ;\n      }\n      elsif ( \$pass_braces && \$brace_depth && \$1 eq ',' ) {\n         '|' ;\n      }\n      elsif ( \$pass_parens && index( '()', \$1 ) >= 0 ) {\n         \$1 ;\n      }\n      else {\n\x09 quotemeta(substr( \$1, -1 ) );\n      }\n   \@gexs ;\n\n   croak "Unmatched '{' in '\$orig'" if \$brace_depth ;\n\n   return \$anchors ? qr/\\A(?\$case:\$re)\\Z/s : qr/(?\$case:\$re)/s ;\n}\n\n\n=item shellish_glob\n\nPass a regular expression and a list of possible values, get back a list of\nmatching values.\n\n   my \@matches = shellish_glob( '*/*', \@possibilities ) ;\n   my \@matches = shellish_glob( '*/*', \@possibilities, \\%options ) ;\n\n=cut\n\nsub shellish_glob {\n   my \$o = \@_ > 1 && ref \$_[-1] eq 'HASH' ? pop : {} ;\n   my \$re = compile_shellish( shift, \$o ) ;\n   return grep { m/\$re/ } \@_ ;\n}\n\n=back\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n\n1 ;\n
END_OF_FILE_AAAAAAAAAACX
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACY, "lib/XML/AutoWriter.pm" }
package XML::AutoWriter ;\n\n=head1 NAME\n\nXML::AutoWriter - DOCTYPE based XML output\n\n=head1 SYNOPSIS\n\n   use XML::Doctype         NAME => a, SYSTEM_ID => 'a.dtd' ;\n   use XML::AutoWriter qw( :all :dtd_tags ) ;\n   #\n   # a.dtd contains:\n   #\n   #   <!ELEMENT a ( b1, b2?, b3* ) >\n   #\x09  <!ATTLIST   a aa1 CDATA       #REQUIRED >\n   #   <!ELEMENT b1 ( c1 ) >\n   #   <!ELEMENT b2 ( c2 ) >\n   #\n   b1 ;                # Emits <a><b1>\n   c2( attr=>"val" ) ; # Emits </b1><b2><c2 attr="val">\n   endAllTags ;        # Emits </c2></b2></a>\n\n   ## If you've got an XML::Doctype object handy:\n   use XML::AutoWriter qw( :dtd_tags ), DOCTYPE => \$doctype ;\n\n   ## If you've saved a preparsed DTD as a perl module\n   use FooML::Doctype::v1_0001 ;\n   use XML::AutoWriter qw( :dtd_tags ) ;\n\n   ## Or as a normal perl object:\n   \$writer = XML::AutoWriter->new( ... ) ;\n   \$writer->startTag( 'b1' ) ;\n   \$writer->startTag( 'c2' ) ;\n   \$writer->end ;\n\n=head1 STATUS\n\nAlpha.  Use and patch, don't depend on things not changing drastically.\n\nMany methods supplied by XML::Writer are not yet supplied here.\n\n=head1 DESCRIPTION\n\nThis module subclasses L<XML::ValidWriter> and provides automatic\nstart and end tag generation, allowing you to emit only the 'important'\ntags.\n\nSee XML::ValidWriter for the details on all functions not documented\nhere.\n\n=head2 XML::Writer API compatibility\n\nMuch of the interface is patterned\nafter XML::Writer so that it can possibly be used as a drop-in\nreplacement.  It will take awhile before this module emulates enough\nof XML::Writer to be a drop-in replacement in situations where the\nmore advanced XML::Writer methods are used.\n\n=head2 Automatic start tags\n\nAutomatic start tag creation is done when emitting a start tag that is\nnot allowed to be a child of the currently open tag\nbut is allowed to be contained in the currently open tag's subset.  In\nthis case, the minimal number of start tags necessary to allow\nAll start tags between the current tag and the desired tag are automatically\nemitted with no attributes.\n\n=head2 Automatic end tags\n\nIf start tag autogeneration fails, then end tag autogeneration is attempted.\nstartTag() scans the stack of currently open tags trying to close as few as\npossible before start tag autogeneration suceeds.\n\nExplicit end tags may be emitted to prevent unwanted automatic start\ntags, and, in the future, warnings or errors will be available in place\nof automatic start and end tag creation.\n\n=cut\n\nuse strict ;\nuse vars qw( \$VERSION ) ;\n\n\$VERSION = 0.3 ;\n\nuse Carp ;\n\nuse base qw( XML::ValidWriter ) ;\n\n=head1 METHODS AND FUNCTIONS\n\nAll of the routines in this module can be called as either functions\nor methods unless otherwise noted.\n\nTo call these routines as functions use either the DOCTYPE or\n:dtd_tags options in the parameters to the use statement:\n\n   use XML::AutoWriter DOCTYPE => XML::Doctype->new( ... ) ;\n   use XML::AutoWriter qw( :dtd_tags ) ;\n\nThis associates an XML::AutoWriter and an XML::Doctype with the\npackage.  These are used by the routines when called as functions.\n\n=over\n\n=cut\n\n=item new\n\n   \$writer = XML::AutoWriter->new( DTD => \$dtd, OUTPUT => \\*FH ) ;\n\nCreates an XML::AutoWriter.\n\nAll other parameters are passed to\nthe XML::ValidWriter base class constructor.\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my XML::AutoWriter \$self = \$class->SUPER::new( \@_ ) ;\n\n   return \$self ;\n}\n\n\nsub _find_path {\n   ## Find a path from \$root to \$dest by doing a breadth-first\n   ## search.  Cache the results as we go to speed us up next time.\n   my XML::Doctype \$doctype ;\n   my ( \$root, \$dest ) ;\n   ( \$doctype, \$root, \$dest ) = \@_ ;\n\n   ## Break encapsulation on XML::Doctype for speed.\n   my \$elts = \$doctype->{ELTS} ;\n   croak "Unknown tag '\$root'" unless exists \$elts->{\$root} ;\n   croak "Unknown tag '\$dest'"\n      unless \$dest eq '#PCDATA' || exists \$elts->{\$dest} ;\n\n   my \$root_elt = \$elts->{\$root} ;\n\n   # print STDERR "searching for \$root ... \$dest\\n" ;\n\n   return []\n      if \$root_elt->is_any\n         || ( \$dest eq '#PCDATA' && \$root_elt->can_contain_pcdata ) ;\n\n   my \$paths = \$root_elt->{PATHS} ;\n   unless ( \$paths ) {\n      ## Init the cache\n      \$paths = \$root_elt->{PATHS} = {\n         map {( \$_ => [] )} \$root_elt->child_names\n      } ;\n      \$root_elt->{TODO} = [ \$root_elt->child_names ] ;\n   }\n\n   ## Check the cache\n   return \$root_elt->{PATHS}->{\$dest}\n      if exists \$root_elt->{PATHS}->{\$dest} ;\n\n   ## Do the search, starting where we left off.  \@todo is a list of known\n   ## descendant names.  We scan each such name looking for more descendants\n   ## until we exhaust the tree or we find the one we're looking for.  We\n   ## avoid loops.\n   my \$todo = \$root_elt->{TODO} ;\n   while ( \@\$todo ) {\n      # print STDERR "todo: ", join( ' ', \@\$todo ), "\\n" ;\n\n      my \$gkid = shift \@\$todo ;\n      # print STDERR "doing \$gkid\\n" ;\n      push \@\$todo, \$elts->{\$gkid}->child_names ;\n\n      my \$gkid_path = \$paths->{\$gkid} ;\n\n      if ( \$elts->{\$gkid}->can_contain_pcdata() ) {\n\x09 \$paths->{'#PCDATA'} = [ \@\$gkid_path, \$gkid ]\n\x09    unless exists \$paths->{'#PCDATA'} ;\n\x09 # print STDERR "checking (pcdata) ",\n\x09 # join( '', map "<\$_>", \@{\$paths->{'#PCDATA'}} ), "\\n" ;\n\x09 if ( \$dest eq '#PCDATA' ) {\n\x09    # print STDERR "Yahoo!\\n" ;\n\x09    return \$paths->{'#PCDATA'} ;\n\x09 }\n      }\n\n      for my \$ggkid ( \$elts->{\$gkid}->child_names ) {\n\x09 next if exists \$paths->{\$ggkid} ;\n\n\x09 \$paths->{\$ggkid} = [ \@\$gkid_path, \$gkid ] ;\n\x09 # print STDERR "checking ",\n\x09 # join( '', map "<\$_>", \@{\$paths->{\$ggkid}}, \$ggkid ), " (\$dest)\\n" ;\n\x09 if ( \$ggkid eq \$dest ) {\n\x09    # print STDERR "Yahoo!\\n" ;\n\x09    return \$paths->{\$ggkid}\n\x09 }\n      }\n   }\n   # print STDERR "rats...\\n" ;\n   return ;\n}\n\n\n=item characters\n\n   characters( 'yabba dabba dooo' ) ;\n   \$writer->characters( 'yabba dabba dooo' ) ;\n\nIf the currently open tag cannot contain #PCDATA, then start tag autogeneration\nwill be attempted, followed by end tag autogeneration.\n\nStart tag autogeneration takes place even if you pass in only '', or even (),\nthe empty list.\n\n=cut\n\nsub characters {\n   my XML::AutoWriter \$self = &XML::ValidWriter::_self ;\n\n   my \$stack = \$self->{STACK} ;\n   my \$doctype = \$self->{DOCTYPE} ;\n\n   ## Don't re-emit root if it's been emitted, so that the error message\n   ## will be about emitting our \$tag, not the root tag.\n   \$self->startTag( \$doctype->name )\n      if ! \@\$stack && ! defined \$self->{EMITTED_ROOT} ;\n\n   for ( my \$i = \$#\$stack ; \$i >= 0 ; --\$i ) {\n      my \$path = _find_path( \$doctype, \$stack->[\$i]->{NAME}, '#PCDATA' ) ;\n\n      if ( defined \$path ) {\n         \$self->endTag( \$stack->[-1]->{NAME} )\n\x09     while \$#\$stack > \$i ;\n\x09 \$self->SUPER::startTag( \$_ ) for \@\$path ;\n\x09 last ;\n      }\n   }\n\n   \$self->SUPER::characters( \@_ ) ;\n}\n\n\n=item endTag\n\n   endTag ;\n   endTag( 'a' ) ;\n   \$writer->endTag ;\n   \$writer->endTag( 'a' ) ;\n\nPrints one or more end tags.  The tag name is optional and defaults to the\nmost recently emitted start tag if not present.\n\nThis will emit as many close tags as necessary to close the supplied tag\nname, or will emit an error if the tag name specified is not open in the\noutput document.\n\n=cut\n\nsub endTag {\n   my XML::AutoWriter \$self = &XML::ValidWriter::_self ;\n\n   return \$self->SUPER::endTag() unless \@_ ;\n\n   my ( \$tag ) = \@_ ;\n\n   my \$stack = \$self->{STACK} ;\n\n   ## Close all tags down to & including the one asked for.  Don't\n   ## destroy the stack until we have a match, so we can print it\n   ## as an error message if we bottom out.\n   for ( my \$i = \$#\$stack ; \$i >= 0 ; --\$i ) {\n      if ( \$stack->[\$i]->{NAME} eq \$tag ) {\n\x09 \$self->SUPER::endTag() while \$#\$stack >= \$i ;\n\x09 return ;\n      }\n   }\n\n   confess "No '\$tag' open, only " . join( ', ', map { "'\$_->{NAME}'"} \@\$stack ) ;\n}\n\n\n=item startTag\n\n   startTag( 'a', attr => val ) ;  # use default XML::AutoWriter for\n                                   # current package.\n   \$writer->startTag( 'a', attr => val ) ;\n\nEmits a named start tag with optional attributes.  If the named tag\ncannot be a child of the most recently started tag, then any tags\nthat need to be opened between that one and the named tag are opened.\n\nIf the named tag cannot be enclosed within the most recently opened\ntag, no matter how deep, then startTag() tries to end as few started tags\nas necessary to allow the named tag to be emitted within a tag already on the\nstack.\n\nThis warns (once) if no <?xml?> declaration has been emitted.  It does not\ncheck to see if a <!DOCTYPE...> has been emitted.  It dies if an attempt\nis made to emit a second root element.\n\n=cut\n\nsub startTag {\n   my XML::AutoWriter \$self = &XML::ValidWriter::_self ;\n   my \$tag = shift ;\n   croak "Must supply a tag name" unless defined \$tag ;\n\n   my \$stack = \$self->{STACK} ;\n   my \$doctype = \$self->{DOCTYPE} ;\n\n   ## Don't re-emit root if it's been emitted, so that the error message\n   ## will be about emitting our \$tag, not the root tag.\n   \$self->startTag( \$doctype->name )\n      if ! \@\$stack\n\x09 && ! defined \$self->{EMITTED_ROOT}\n\x09 && \$tag ne \$doctype->name ;\n\n   for ( my \$i = \$#\$stack ; \$i >= 0 ; --\$i ) {\n      my \$path = _find_path( \$doctype, \$stack->[\$i]->{NAME}, \$tag ) ;\n      if ( defined \$path ) {\n         \$self->endTag( \$stack->[-1]->{NAME} )\n\x09     while \$#\$stack > \$i ;\n\x09 \$self->SUPER::startTag( \$_ ) for \@\$path ;\n\x09 last ;\n      }\n   }\n\n   \$self->SUPER::startTag( \$tag, \@_ ) ;\n}\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nThis module is Copyright 2000, Barrie Slaymaker.  All rights reserved.\n\nThis module is licensed under the GPL, version 2.  Please contact me if this\ndoes not suit your needs.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAACY
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAACZ, "lib/XML/ValidWriter.pm" }
package XML::ValidWriter ;\n\n=head1 NAME\n\nXML::ValidWriter - DOCTYPE driven valid XML output\n\n=head1 SYNOPSIS\n\n   ## As a normal perl object:\n   \$writer = XML::ValidWriter->new(\n      DOCTYPE => \$xml_doc_type,\n      OUTPUT => \\*FH\n   ) ;\n   \$writer->startTag( 'b1' ) ;\n   \$writer->startTag( 'c2' ) ;\n   \$writer->end ;\n\n   ## Writing to a scalar:\n   \$writer = XML::ValidWriter->new(\n      DOCTYPE => \$xml_doc_type,\n      OUTPUT => \\\$buf\n   ) ;\n\n   ## Or, in scripting mode:\n   use XML::Doctype         NAME => a, SYSTEM_ID => 'a.dtd' ;\n   use XML::ValidWriter qw( :all :dtd_tags ) ;\n   b1 ;                # Emits <a><b1>\n   c2( attr=>"val" ) ; # Emits </b1><b2><c2 attr="val">\n   endAllTags ;        # Emits </c2></b2></a>\n\n   ## If you've got an XML::Doctype object handy:\n   use XML::ValidWriter qw( :dtd_tags ), DOCTYPE => \$doctype ;\n\n   ## If you've saved a preparsed DTD as a perl module\n   use FooML::Doctype::v1_0001 ;\n   use XML::ValidWriter qw( :dtd_tags ) ;\n\n   #\n   # This all assumes that the DTD contains:\n   #\n   #   <!ELEMENT a ( b1, b2?, b3* ) >\n   #\x09  <!ATTLIST   a aa1 CDATA       #REQUIRED >\n   #   <!ELEMENT b1 ( c1 ) >\n   #   <!ELEMENT b2 ( c2 ) >\n   #\n\n=head1 STATUS\n\nAlpha.  Use and patch, don't depend on things not changing drastically.\n\nMany methods supplied by XML::Writer are not yet supplied here.\n\n=head1 DESCRIPTION\n\nThis module uses the DTD contained in an XML::Doctype to enable compile-\nand run-time checks of XML output validity.  It also provides methods and\nfunctions named after the elements mentioned in the DTD.  If an\nXML::ValidWriter uses a DTD that mentions the element type TABLE, that\ninstance will provide the methods\n\n   \$writer->TABLE( \$content, ...attrs... ) ;\n   \$writer->start_TABLE( ...attrs... ) ;\n   \$writer->end_TABLE() ;\n   \$writer->empty_TABLE( ...attrs... ) ;\n\n.  These are created for undeclared elements--those elements not explicitly\ndeclared with an <!ELEMENT ..> declaration--as well.  If an element\ntype name conflicts with a method, it will not override the internal method.\n\nWhen an XML::Doctype is parsed, the name of the doctype defines the root\nnode of the document.  This name can be changed, though, see L<XML::Doctype>\nfor details.\n\nIn addition to the object-oriented API, a function API is also provided.\nThis allows you to import most of the methods of XML::ValidWriter as functions\nusing standard import specifications:\n\n   use XML::ValidWriter qw( :all ) ; ## Could list function names instead\n\nC<:all> does not import the functions named after elements mentioned in\nthe DTD, you need to import those tags using C<:dtd_tags>:\n\n   use XML::Doctype NAME => 'foo', SYSTEM_ID => 'fooml.dtd' ;\n   use XML::ValidWriter qw( :all :dtd_tags ) ;\n\nor\n\n   BEGIN {\n      \$doctype = XML::Doctype->new( ... ) ;\n   }\n\n   use XML::ValidWriter DOCTYPE => \$doctype, qw( :all :dtd_tags ) ;\n\n=head2 XML::Writer API compatibility\n\nMuch of the interface is patterned\nafter XML::Writer so that it can possibly be used as a drop-in\nreplacement.  It will take awhile before this module emulates enough\nof XML::Writer to be a drop-in replacement in situations where the\nmore advanced XML::Writer methods are used.  If you find you need\na method not suported here, write it and send it in!\n\nThis was not derived from XML::Writer because XML::Writer does not\nexpose it's stack.  Even if it did, it's might be difficult to store\nenough state in it's stack.\n\nUnlike XML::Writer, this does not call in all of the IO::* family, and\nmethod dispatch should be faster.  DTD-specific methods are also supported\n(see L</AUTOLOAD>).\n\n=head2 Quick and Easy Unix Filter Apps\n\nFor quick applications that provide Unix filter application\nfunctionality, XML::ValidWriter and XML::Doctype cooperate to allow you\nto\n\n=over\n\n=item 1\n\nParse a DTD at compile-time and set that as the default DTD for\nthe current package.  This is done using the\n\n   use XML::Doctype NAME => 'FooML, SYSTEM_ID => 'fooml.dtd' ;\n\nsyntax.\n\n=item 2\n\nDefine and export a set of functions corresponding to start and end tags for\nall declared and undeclared ELEMENTs in the DTD.  This is done by using\nthe C<:dtd_tags> export symbol like so:\n\n   use XML::Doctype     NAME => 'FooML, SYSTEM_ID => 'fooml.dtd' ;\n   use XML::ValidWriter qw(:dtd_tags) ;\n\nIf the elements a, b_c, and d-e are referred to in the DTD, the following\nfunctions will be exported:\n\n   a()        end_a()       # like startTag( 'a', ... ) and endTag( 'a' )\n   b_c()      end_b_c()\n   d_e()      end_d_e()     {'d-e'}()     {'end_d-e'}()\n\nThese functions emit only tags, unlike the similar functions found\nin CGI.pm and XML::Generator, which also allow you to pass content\nin as parameters.\n\nSee below for details on conflict resolution in the mapping of entity\nnames containing /\\W/ to Perl subroutine names.\n\nIf the elements declared in the DTD might conflict with functions\nin your package namespace, simple put them in some safe namespace:\n\n   package FooML ;\n   use XML::Doctype         NAME => 'FooML', SYSTEM_ID => 'fooml.dtd' ;\n   use XML::ValidWriter qw(:dtd_tags) ;\n\n   package Whatever ;\n\nThe advantage of importing these subroutine names is that perl\ncan then detect use of unknown tags at compile time.\n\nIf you don't want to use the default DTD, use the C<-dtd> option:\n\n   BEGIN { \$dtd = XML::Doctype->new( .... ) }\n   use XML::ValidWriter qw(:dtd_tags), -dtd => \\\$dtd ;\n\n=item 3\n\nUse the default DTD to validate emitted XML.  startTag() and endTag()\nwill check the tag being emitted against the list of currently open\ntags and either emit a minimal set of missing end and start tags\nnecessary to achieve document validity or produce errors or warnings.\n\nSince the functions created by the C<:dtd_tags> export symbol are wrappers\naround startTag() and endTag(), they provide this functionality as well.\n\nSo, if you have a DTD like\n\n   <!ELEMENT a ( b1, b2?, b3* ) >\n\n       <!ATTLIST   a aa1 CDATA       #REQUIRED >\n\n   <!ELEMENT b1 ( c1 ) >\n   <!ELEMENT b2 ( c2 ) >\n   <!ELEMENT b3 ( c3 ) >\n\nyou can do this:\n\n   use XML::Doctype     NAME => 'a', SYSTEM_ID => 'a.dtd' ;\n   use XML::ValidWriter ':dtd_tags' ;\n\n   getDoctype->element_decl('a')->attdef('aa1')->default_on_write('foo') ;\n\n   a ;\n      b1 ;\n\x09 c1 ;\n\x09 end_c1 ;\n      end_b1 ;\n      b3 ;\n\x09 c3( -attr => val ) ;\n\x09 end_c3 ;\n      end_b3 ;\n   end_a ;\n\nand emit a document like\n\n   <a aa1="foo">\n      <b1>\n         <c1 />\n      </b1>\n      <b3>\n         <c3 attr => "val" />\n      </b3>\n   </a>\n\n.\n\n=back\n\n=head1 OUTPUT OPTIMIZATION\n\nXML is a very simple langauge and does not offer a lot of room for\noptimization.  As the spec says "Terseness in XML markup is of\nminimal importance."  XML::ValidWriter does optimize the following\non output:\n\nC<E<lt>a...E<gt>E<lt>/aE<gt>>   becomes 'E<lt>a... />'\n\nSpurious emissions of C<]]E<gt>E<lt>![CDATA[> are supressed.\n\nXML::ValidWriter chooses whether or not to use a <![CDATA[...]]> section\nor simply escape '<' and '&'.  If you are emitting content for\nan element in multiple \ncalls to L</characters>, the first call decides whether or not to use\nCDATA, so it's to your advantage to emit as much in the first call\nas possible.  You can do\n\n   characters( \@lots_of_segments ) ;\n\nif it helps.\n\n=cut\n\nuse strict ;\nuse vars qw( \$VERSION \@ISA \@EXPORT_OK %EXPORT_TAGS ) ;\nuse fields (\n   'AT_BOL',      # Set if the last thing emitted was a "\\n".\n   'CDATA_END_PART', # ']' or ']]' if we're in CDATA mode and the last parm\n                  # to the last call to characters() ended in this.\n   'CHECKED_XML_DECL',\n   'FILE_NAME',   # set if the constructor received OUTPUT => 'foo.barml'\n   'CREATED_AT',  # File and line number the instance was created at\n   'DATA_MODE',   # Whether or not to be in data mode\n   'DOCTYPE',     # The parsed DOCTYPE & DTD\n   'EMITTED_DOCTYPE',\n   'EMITTED_ROOT',\n   'EMITTED_XML',\n   'IS_STANDALONE',\n   'METHODS',     # Cache of AUTOLOADed methods\n   'OUTPUT',      # The output filehandle\n   'STACK',       # The array of open elements\n   'SHOULD_WARN', # Turns on warnings for things that should (but may not be)\n                  # the case, like emitting '<?xml?>'.  defaults to '1'.\n   'WAS_END_TAG', # Set if last thing emitted was an empty tag or an end tag\n   'STRAGGLERS',  # '>' if we just emitted a start tag, ']]>' if <![CDATA[\n) ;\nuse UNIVERSAL qw( isa ) ;\n\nuse Carp ;\n\nmy \@EXPORT_OK = qw(\n   characters\n   dataElement\n   defaultWriter\n   emptyTag\n   endAllTags\n   endTag\n   getDataMode\n   getDoctype\n   getOutput\n   rawCharacters\n   startTag\n   select_xml\n   setDataMode\n   setDoctype\n   setOutput\n   xmlDecl\n) ;\n\n\$VERSION = 0.37 ;\n\n##\n## This module can maintain a set of XML::ValidWriter instances,\n## one for each calling package.\n##\nmy %pkg_writers ;\n\nsub _self {\n   ## MUST be called as C< &_self ;>\n\n   ## If it's a reference to anything but a plain old hash, then the\n   ## first param is either an XML::ValidWriter, a reference to a glob\n   ## a reference to a SCALAR, or a reference to an IO::Handle.\n   return shift if ( \@_ && ref \$_[0] && isa( \$_[0], 'XML::ValidWriter' ) ) ;\n   my \$callpkg = caller(1) ;\n   croak "No default XML::ValidWriter declared for package '\$callpkg'"\n      unless \$pkg_writers{\$callpkg} ;\n   return \$pkg_writers{\$callpkg} ;\n}\n\n=head1 METHODS AND FUNCTIONS\n\nAll of the routines in this module can be called as either functions\nor methods unless otherwise noted.\n\nTo call these routines as functions use either the DOCTYPE or\n:dtd_tags options in the parameters to the use statement:\n\n   use XML::ValidWriter DOCTYPE => XML::Doctype->new( ... ) ;\n   use XML::ValidWriter qw( :dtd_tags ) ;\n\nThis associates an XML::ValidWriter and an XML::Doctype with the\npackage.  These are used by the routines when called as functions.\n\n=over\n\n=item new\n\n   \$writer = XML::ValidWriter->new( DTD => \$dtd, OUTPUT => \\*FH ) ;\n\nCreates an XML::ValidWriter.\n\nThe value passed for OUTPUT may be:\n\n=over\n\n=item a SCALAR ref\n\nif you want to direct output to append to a scalar.  This scalar is\ntruncated whenever the XML::ValidWriter object is reset() or\nDESTROY()ed\n\n=item a file handle glob ref or a reference to an IO object\n\nXML::ValidWriter does not load IO.  This is\nthe only mode compatible with XML::Writer.\n\n=item a file name\n\nA simple scalar is taken to be a filename to be created or truncated\nand emitted to.  This file will be closed when the XML::ValidWriter object\nis reset or deatroyed.\n\n=back\n\nNOTE: if you leave OUTPUT undefined, then the currently select()ed\noutput is used at each emission (ie calling select() can alter the\ndestination mid-stream).  This eases writing command line filter\napplications, the select() interaction is unintentional, and please\ndon't depend on it.  I reserve the right to cache the select()ed\nfilehandle at creation time or at time of first emission at some\npoint in the future.\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my XML::ValidWriter \$self ;\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n   \$self->{SHOULD_WARN} = 1 ;\n\n   while ( \@_ ) {\n      for my \$parm ( shift ) {\n         if ( \$parm eq 'DOCTYPE' ) {\n\x09    croak "Can't have two DOCTYPE parms"\n\x09       if defined \$self->{DOCTYPE} ;\n\x09    \$self->{DOCTYPE} = shift ;\n\x09 }\n\x09 elsif ( \$parm eq 'OUTPUT' ) {\n\x09    croak "Can't have two OUTPUT parms"\n\x09       if defined \$self->{OUTPUT} || defined \$self->{FILE_NAME} ;\n\x09    if ( ref \$_[0] ) {\n\x09       \$self->{OUTPUT} = shift ;\n\x09    }\n\x09    else {\n\x09       \$self->{FILE_NAME} = shift ;\n\x09    }\n\x09 }\n      }\n   }\n\n   ## Find the original caller\n   my \$caller_depth = 1 ;\n   ++\$caller_depth\n      while caller && isa( scalar( caller \$caller_depth ), __PACKAGE__ ) ;\n   \$self->{CREATED_AT} = join( ', ', (caller( \$caller_depth ))[1,2] );\n   \$self->reset ;\n\n   return \$self ;\n}\n\n\n=item import\n\nCan't think of why you'd call this method directly, it gets called\nwhen you use this module:\n\n   use XML::ValidWriter qw( :all ) ;\n\nIn addition to the normal functionality of exporting functions like\nstartTag() and endTag(), XML::ValidWriter's import() can create\nfunctions corresponding to all elements in a DTD.  This is done using\nthe special C<:dtd_tags> export symbol.  For example,\n\n   use XML::Doctype     NAME => 'FooML', SYSTEM_ID => 'fooml.dtd' ;\n   use XML::ValidWriter qw( :dtd_tags ) ;\n\nwhere fooml.dtd referse to a tag type of 'blurb' causes these\nfunctions to be imported:\n\n   blurb()         # calls defaultWriter->startTag( 'blurb', \@_ ) ;\n   blurb_element() # calls defaultWriter->dataElement( 'blurb', \@_ ) ;\n   empty_blurb()   # calls defaultWriter->emptyTag( 'blurb', \@_ ) ;\n   end_blurb()     # calls defaultWriter->endTag( 'blurb' ) ;\n   \nThe range of characters for element types is much larger than\nthe range of characters for bareword perl subroutine names, which\nare limited to [a-zA-Z0-9_].  In this case, XML::ValidWriter will\nexport an oddly named function that you can use a symbolic reference\nto call (you will need C<no strict 'refs' ;> if you are doing\na C<use strict ;>):\n\n   &{"space-1999:moonbase"}( ...attributes ... ) ;\n\n.  XML::ValidWriter will also try to fold the name in to bareword\nspace by converting /\\W/ symbols to '_'.\nIf the resulting function name,\n\n   space_1999_moonbase( ...attributes... ) ;\n   \nhas not been generated and is not the name of an element type, then\nit will also be exported.\n\nIf you are using a DTD that might introduce function names that\nconflict with existing ones, simple export them in to their own\nnamespace:\n\n   package ML ;\n\n   use XML::Doctype     NAME => 'foo', SYSTEM_ID => 'fooml.dtd' ;\n   use XML::ValidWriter qw( :dtd_tags ) ;\n\n   package main ;\n\n   use XML::ValidWriter qw( :all ) ;\n\n   ML::foo ;\n   ML::c2 ;\n   ML::c1 ;\n   ML::end_a ;\n\nI gave serious thought to converting ':' in element names to '::' in\nfunction declarations, which might work well in the functions-in-their-own-\nnamespace case, but not in the default case, since Perl does not\n(yet) have relative namespaces. Another alternative is to allow a\nmapping of XML namespaces to Perl namespaces to be done.\n\n=cut\n\n## use %pkg_writers, defined above\n\n## This import is odd: it allows subclasses to 'inherit' exports\nsub import {\n   my \$pkg     = shift ;\n   my \$callpkg = caller ;\n\n   my \$doctype ;\n   my \@args ;\n   my \@syms ;\n   my \$export_dtd_tags ;\n   my \$op ;\n   while ( \@_ ) {\n      \$op = shift ;\n      if ( \$op eq 'DOCTYPE' ) {\n\x09 \$doctype = shift ;\n      }\n      elsif ( \$op eq ':dtd_tags' ) {\n\x09 \$export_dtd_tags = 1 ;\n      }\n      elsif ( \$op eq ':all' ) {\n\x09 push \@syms, \@EXPORT_OK ;\n      }\n      elsif ( \$op =~ /^[A-Z_0-9]+\$/ ) {\n\x09 push \@args, \$op ;\n\x09 push \@args, shift ;\n      }\n      elsif ( \$op =~ /^[:\$%\@*]/ ) {\n\x09 croak "import tag '\$op' not supported" ;\n      }\n      else {\n\x09 push \@syms, \$op ;\n      }\n   }\n\n   if ( \$export_dtd_tags || \$doctype ) {\n      \$pkg_writers{\$callpkg} = \$pkg->new( \@args )\n         unless \$pkg_writers{\$callpkg} ;\n\n      \$doctype = \$XML::Doctype::_default_dtds{\$callpkg}\n\x09 if ! \$doctype && exists \$XML::Doctype::_default_dtds{\$callpkg} ;\n\n      \$pkg_writers{\$callpkg}->setDoctype( \$doctype ) if \$doctype ;\n   }\n\n   \$pkg_writers{\$callpkg}->exportDTDTags( \$callpkg )\n      if \$export_dtd_tags ;\n\n   my %ok = map { ( \$_ => 1 ) } \@EXPORT_OK ;\n   for my \$sym ( \@syms ) {\n      no strict 'refs' ;\n      \$sym =~ s/^&// ;\n      if ( \$ok{\$sym} ) {\n\x09 if ( defined &{"\$pkg\\::\$sym"} ) {\n\x09    *{"\$callpkg\\::\$sym"} = \\&{"\$pkg\\::\$sym"} ;\n\x09    next ;\n\x09 }\n\x09 elsif ( defined &{\$sym} ) {\n\x09    *{"\$callpkg\\::\$sym"} = \\&{"\$sym"} ;\n\x09    next ;\n\x09 }\n      }\n      croak "Function '\$sym' not exported by '\$pkg' or " . __PACKAGE__ ;\n   }\n}\n\n\nmy %escapees ;\n\$escapees{'&'}   = '&amp;'  ;\n\$escapees{'<'}   = '&lt;'   ;\n\$escapees{'>'}   = '&gt;'   ;\n\$escapees{']>'}  = ']&gt;'  ;\n\$escapees{']]>'} = ']]&gt;' ;\n\$escapees{'"'}   = '&quot;' ;\n\$escapees{"'"}   = '&apos;' ;\n\n# Takes a list, returns a list: don't use in scalar context.\nsub _esc {\n   croak "_esc used in scalar context" unless wantarray ;\n   my \$text ;\n   return map {\n      \$text = \$_ ;\n      if ( \$text =~ /([\\x00-\\x08\\x0B\\x0C\\x0E-\\x1F])/ ) {\n\x09 croak sprintf(\n\x09    "Illegal character 0x%02d (^%s) sent",\n\x09    ord \$1,\n\x09    chr( ord( "A" ) + ord( \$1 ) - 1 )\n\x09 )\n      }\n      \$text =~ s{([&<]|^>|^\\]>|\\]\\]>)}{\$escapees{\$1}}eg ;\n      \$text ;\n   } \@_ ;\n}\n\n\nsub _esc1 {\n   my \$text = shift ;\n   if ( \$text =~ /([\\x00-\\x08\\x0B\\x0C\\x0E-\\x1F])/ ) {\n      croak sprintf(\n         "Invalid character 0x%02d (^%s) sent",\n         ord \$1,\n\x09 chr( ord( "A" ) + ord( \$1 ) - 1 )\n      )\n   }\n   \$text =~ s{([&<]|^>|^\\]>|\\]\\]>)}{\$escapees{\$1}}eg ;\n   return \$text ;\n}\n\nsub _attr_esc1 {\n   my \$text = shift ;\n   if ( \$text =~ /([\\x00-\\x08\\x0B\\x0C\\x0E-\\x1F])/ ) {\n      croak sprintf(\n         "Invalid character 0x%02d (^%s) sent",\n         ord \$1,\n\x09 chr( ord( "A" ) + ord( \$1 ) - 1 )\n      )\n   }\n   \$text =~ s{([&<"'])}{\$escapees{\$1}}eg ;\n   return \$text ;\n}\n\n\nsub _esc_cdata_ends {\n   ## This could be very memory hungry, but alas...\n   my \$text = join( '', \@_ ) ;\n   if ( \$text =~ /([\\x00-\\x08\\x0B\\x0C\\x0E-\\x1F])/ ) {\n      croak sprintf(\n         "Invalid character 0x%02d (^%s) sent",\n         ord \$1,\n\x09 chr( ord( "A" ) + ord( \$1 ) - 1 )\n      )\n   }\n   \$text =~ s{\\]\\]>}{]]]]><![CDATA[>}g ;\n   return \$text ;\n}\n\n\n=item characters\n\n   characters( "escaped text", "& more" ) ;\n   \$writer->characters( "escaped text", "& more" ) ;\n\nEmits character data.  Character data will be escaped before output, by either\ntransforming 'E<lt>' and '&' to &lt; and &amp;, or by enclosing in a\n'C<E<lt>![CDATA[...]]E<gt>>' bracket, depending on which will be more\nhuman-readable, according to the module.\n\n=cut\n\nsub characters {\n   my XML::ValidWriter \$self = &_self ;\n   my \$to = \$self->{OUTPUT} || select ;\n\n   croak "Can't emit characters before the root element"\n      if ! defined \$self->{EMITTED_ROOT} ;\n\n   my \$stack = \$self->{STACK} ;\n   croak "Can't emit characters outside of the root element"\n      unless \@\$stack ;\n\n   my \$open_elt = \$self->getDoctype->element_decl( \$stack->[-1]->{NAME} ) ;\n\n   croak "Element '\$open_elt->{NAME}' can't contain #PCDATA"\n      unless ! \$open_elt || \$open_elt->can_contain_pcdata ;\n\n   croak "Undefined value passed to characters() in <\$open_elt->{NAME}>"\n      if grep ! defined \$_, \@_ ;\n\n   my \$length ;\n   my \$decide_cdata = \$self->{STRAGGLERS} eq '>' ;\n   my \$in_cdata_mode ;\n\n   if ( \$decide_cdata ) {\n      my \$escs = 0 ;\n      my \$cdata_ends = 0 ;\n      my \$cdata_escs = 0 ;\n      my \$pos ;\n\n      ## I assume that splitting CDATA ends between chunks is very\n      ## rare.  If an app does that a lot, then this could guess 'wrong'\n      ## and use CDATA escapes in a situation where they result in more\n      ## bytes out than <& escaping would.\n      for ( \@_ ) {\n\x09 \$escs += tr/<&// ;\n\x09 \$pos = 0 ;\n\x09 ++\$cdata_ends while ( \$pos = index \$_, ']]>', \$pos + 3 ) >= 0 ;\n\x09 \$cdata_escs += tr/\\x00-\\x08\\x0b\\x0c\\x0e-\\x1f// ;\n\x09 \$length += length \$_ ;\n      }\n      ## Each &lt; or &amp; is 4 or 5 chars.\n      ## Each ]]]]><![CDATA[< is 15.\n      ## Each ]]>&#xN;<![CDATA[ is 17 or 18.\n      ## We ## add 12 since <![CDATA[]]> is 12 chars.\n      \$in_cdata_mode = 4.5*\$escs > 15*\$cdata_ends + 17.75*\$cdata_escs + 12 ;\n   }\n   else {\n      \$in_cdata_mode = \$self->{STRAGGLERS} eq ']]>' ;\n      \$length += length \$_ for \@_ ;\n   }\n\n   return unless \$length ;\n\n   ## I chose to stay in or out of CDATA mode for an element\n   ## in order to keep document structure relatively simple...to keep human\n   ## readers from getting confused between escaping modes.\n   ## This may lead to degeneracy if it's an (SG|X)ML document being emitted in\n   ## an element, so this may change.\n   if ( \$in_cdata_mode ) {\n      if ( \$self->{STRAGGLERS} eq ']]>' ) {\n\x09 ## Don't emit ']]><![CDATA[' between consecutive CDATA character\n\x09 ## chunks.\n         \$self->{STRAGGLERS} = '' ;\n      }\n      else {\n\x09 \$self->{STRAGGLERS} .= '<![CDATA['\n      }\n      if ( ref \$to eq 'SCALAR' ) {\n\x09 \$\$to = join( '',\n\x09    \$\$to,\n\x09    \$self->{STRAGGLERS},\n\x09    _esc_cdata_ends( \$self->{CDATA_END_PART}, \@_ )\n\x09 ) ;\n\n\x09 \$self->{CDATA_END_PART} = \n\x09    \$\$to =~ s/(\\]\\]?)(?!\\n)\\Z//\n\x09       ? \$1\n\x09       : '' ;\n\n      }\n      else {\n\x09 no strict 'refs' ;\n\n\x09 my \$chunk = _esc_cdata_ends( \$self->{CDATA_END_PART}, \@_ ) ;\n\x09 \$self->{CDATA_END_PART} = \n\x09    \$chunk =~ s/(\\]\\]?)(?!\\n)\\Z//\n\x09       ? \$1\n\x09       : '' ;\n\n\x09 print \$to \$self->{STRAGGLERS}, \$chunk\n\x09    or croak "\$! writing chars in <\$open_elt->{NAME}>" ;\n\n      }\n\n      \$self->{STRAGGLERS} = ']]>' ;\n   }\n   else {\n      if ( ref \$to eq 'SCALAR' ) {\n\x09 \$\$to .= \$self->{STRAGGLERS} ;\n\x09 \$\$to .= _esc1( join( '', \@_ ) ) ;\n      }\n      else {\n\x09 no strict 'refs' ;\n\x09 print \$to \$self->{STRAGGLERS}, _esc( \@_ )\n\x09    or croak "\$! writing chars in <\$open_elt->{NAME}>" ;\n      }\n      \$self->{STRAGGLERS} = '' ;\n#      \$self->{CDATA_END_PART} = '' ;\n   }\n\n   \$stack->[-1]->add_content( '#PCDATA' )\n      if \@{\$stack} ;\n\n   \$self->{WAS_END_TAG} = 0 ;\n\n   return ;\n}\n\n\n=item dataElement\n\n   \$writer->dataElement( \$tag ) ;\n   \$writer->dataElement( \$tag, \$content ) ;\n   \$writer->dataElement( \$tag, \$content, attr1 => \$val1, ... ) ;\n   dataElement( \$tag ) ;\n   dataElement( \$tag, \$content ) ;\n   dataElement( \$tag, \$content, attr1 => \$val1, ... ) ;\n\nDoes the equivalent to\n\n   ## Split the optional args in to attributes and elements arrays.\n   \$writer->startTag( \$tag, \@attributes ) ;\n   \$writer->characters( \$content ) ;\n   \$writer->endTag( \$tag ) ;\n\nThis function is exportable as dataElement(), and is also exported\nfor each element 'foo' found in the DTD as foo().\n\n=cut\n\nsub dataElement {\n   my XML::ValidWriter \$self = shift ;\n\n   my ( \$tag ) = shift ;\n\n   croak "Odd number of parameters passed to dataElement for <\$tag>"\n      if \@_ && ! \@_ & 1 ;\n\n   ## We avoid copying content (attribute or element) more than we\n   ## have to so as not to do more copies than necessary of\n   ## potenially huge content.  We still do have to copy content to \n   ## pass it to characters(), though.\n   \$self->startTag( \$tag, \@_[1..\$#_] ) ;\n   my \$is_empty = \$self->{WAS_END_TAG} ;\n\n   ## If ! defined we want to pass it in, so we get an error\n   if ( \@_ && ( ! defined \$_[0] || length \$_[0] ) ) {\n      croak "Can't emit character data to EMPTY <\$tag>"\n         if \$self->{WAS_END_TAG} ;\n      \$self->characters( \$_[0] ) ;\n   }\n\n\n   \$self->endTag( \$tag ) unless \$is_empty ;\n   return ;\n}\n\n\n=item defaultWriter\n\n   \$writer = defaultWriter ;       ## Not a method!\n   \$writer = defaultWriter( 'Foo::Bar' ) ;\n\nReturns the default XML::ValidWriter for the given package, or the current\npackage if none is specified.  This is useful for getting at\nmethods like C<reset> that are not also functions.\n\nCroaks if no default writer has been defined (see L</import>).\n\n=cut\n\nsub defaultWriter(;\$) {\n   my \$pkg = \@_ ? shift : caller ;\n   \n   croak "No default XML::ValidWriter created for package '\$pkg'"\n      unless exists \$pkg_writers{\$pkg}\n         &&         \$pkg_writers{\$pkg} ;\n   \n}\n\n\n=item doctype\n\n   # Using the writer's associated DTD:\n   doctype ;\n\n   # Ignoring the writer's associated DTD:\n   doctype( \$type ) ;\n   doctype( \$type, undef, \$system ) ;\n   doctype( \$type, \$public, \$system ) ;\n\n   \$writer->doctype ;\n   ...etc\n\nSee L</internalDoctype> to emit the entire DTD in the document.\n\nThis checks to make sure that no doctype or elements have been emitted.\n\nA warning is emitted if standalone="yes" was specified in the <?xml..?>\ndeclaration and a system id is specified.  This is extremely likely to\nbe an error.  If you need to silence the warning, write me (see below).\n\nPassing '' or '0' (zero) as a \$public_id or as a \$system_id also generates\na warning, as these are extremely likely to be errors.\n\n=cut\n\nsub doctype {\n   my XML::ValidWriter \$self = &_self ;\n   my ( \$type, \$public_id, \$system_id ) = \@_ ;\n\n   croak "<!DOCTYPE ...> already emitted"\n      if defined \$self->{EMITTED_DOCTYPE} ;\n\n   croak "<!DOCTYPE ...> can't be emitted after elements"\n      if defined \$self->{EMITTED_ROOT} ;\n\n   croak "A PUBLIC_ID was specified, but no SYSTEM_ID"\n      if \$public_id && ! \$system_id ;\n\n   carp "'' passed for a PUBLIC_ID"\n      if defined \$public_id && ! \$public_id ;\n\n   carp "'' passed for a SYSTEM_ID"\n      if defined \$system_id && ! \$system_id ;\n\n   carp "SYSTEM_ID specified for a standalone document"\n      if defined \$system_id && \$self->{IS_STANDALONE} ;\n\n   \$self->rawCharacters(\n      "<!DOCTYPE ",\n      \$type,\n      \$public_id\n         ? (\n\x09    " PUBLIC ",\n\x09    \$public_id,\n\x09    " ",\n\x09    \$system_id,\n\x09 )\n\x09 : \$system_id\n\x09    ? (\n\x09       " SYSTEM ",\n\x09       \$system_id,\n\x09    )\n\x09    : () ,\n      ">"\n   ) ;\n\n   \$self->{EMITTED_DOCTYPE} = defined \$type ? \$type : "UNKNOWN" ;\n}\n\n=item emptyTag\n\n   emptyTag( \$tag[, attr1 => \$val1... ] ) ;\n   \$writer->emptyTag( \$tag[, attr1 => \$val1... ] ) ;\n\nEmits an empty tag like '<foo />'.  The extra space is for compatibility\nwith XHTML.\n\n=cut\n\nsub emptyTag {\n   my XML::ValidWriter \$self = shift ;\n\n   ## Sneaky, sneaky...\n   return \$self->startTag( \@_, '#EMPTY' ) ;\n}\n\n=item endTag\n\n   endTag ;\n   endTag( 'a' ) ;\n   \$writer->endTag ;\n   \$writer->endTag( 'a' ) ;\n\nPrints one or more end tags.  The tag name is optional and defaults to the\nmost recently emitted start tag if not present.\n\nThis will emit as many close tags as necessary to close the supplied tag\nname, or will emit an error if the tag name specified is not open in the\noutput document.\n\n=cut\n\nsub endTag {\n   my XML::ValidWriter \$self = &_self ;\n\n   \$self->{CHECKED_XML_DECL} ||=\n      ( carp( "No <?xml?> emitted." ), 1 ) ;\n\n   my \$stack = \$self->{STACK} ;\n   unless ( \@\$stack ) {\n      my \$tag = \@_ ? shift : '' ;\n      if ( \$self->{EMITTED_ROOT} ) {\n\x09 croak "Too many end tags emitted" .\n\x09    ( \$tag ? ", can't emit '\$tag'" : '' ) ;\n      }\n\n      croak "Can't endTag(", \$tag ? " '\$tag' " : '',\n      ") when no tags have been emitted" ;\n   }\n\n   my \$se = pop \@\$stack ;\n   my \$tag = \@_ ? shift : \$se->{NAME} ;\n   croak "Unmatched </\$tag>, open tags are: ",\n      join( '', map "<\$_->{NAME}>", \@\$stack, \$se )\n      if \$tag ne \$se->{NAME} ;\n\n   unless ( \$se->{ELT_DECL}->validate_content( \$se->{CONTENT} ) ) {\n      if ( \@{\$se->{CONTENT}} ) {\n\x09 croak(\n\x09    "Invalid content for <\$tag>: " .\n\x09    join( '', map "<\$_>", \@{\$se->{CONTENT}} ) \n\x09 )\n      }\n      else {\n         croak "Content required for <\$tag>" ;\n      }\n   }\n\n   my \$prefix = '' ;\n   if ( \$self->{DATA_MODE} && \$self->{WAS_END_TAG} ) {\n      \$prefix = " " x ( 3 * \@\$stack ) ;\n   }\n\n   if ( \$self->{STRAGGLERS} eq '>' ) {\n      ## Last thing emitted was a start tag.\n      \$self->{STRAGGLERS} = '' ;\n      \$self->rawCharacters(\n         ' />',\n         ! \@{\$stack} || \$self->getDataMode ? "\\n" : ()\n      ) ;\n   }\n   else {\n      \$self->rawCharacters(\n\x09 \$prefix, '</', \$tag, '>',\n\x09 ! \@{\$stack} || \$self->getDataMode ? "\\n" : ()\n      ) ;\n   }\n\n   \$self->{WAS_END_TAG} = 1 ;\n}\n\n\n=item end\n\n   \$writer->end ;      # Not a function!!\n\nEmits all necessary end tags to close the document.  Available as a method\nonly, since 'end' is a little to generic to be exported as a function\nname, IMHO.  See 'endAllTags' for the plain function equivalent function.\n\n=cut\n\nsub end {\n   # Well, I lied, you could call it as a function.\n   my XML::ValidWriter \$self = &_self ;\n\n   \$self->endTag() while \@{\$self->{STACK}} ;\n\n   croak "No root element emitted"\n      unless defined \$self->{EMITTED_ROOT} ;\n}\n\n\n=item endAllTags\n\n   endAllTags ;\n   \$writer->endAllTags ;\n\nA plain function that emits all necessart end tags to close the document.\nCorresponds to the method C<end>, but is exportable as a function/\n\n=cut\n\n{\n   no strict 'refs' ;\n   *{"endAllTags"} = \\&end ;\n}\n\n=item exportDTDTags\n\n   \$writer->exportDTDTags() ;\n   \$writer->exportDTDTags( \$to_pkg ) ;\n\nExports the tags found in the DTD to the caller's namespace.\n\n=cut\n\nsub exportDTDTags {\n   my XML::ValidWriter \$self = &_self ;\n\n   my \$pkg = ref \$self ;\n   my \$callpkg = \@_ ? shift : caller ;\n\n   my \$doctype = \$self->{DOCTYPE} ;\n\n   croak "No DOCTYPE specified to export tags from"\n      unless \$doctype ;\n\n   ## Export tag() and end_tag(), tag_element(), and empty_tag() ;\n   no strict 'refs' ;\n   for my \$tag ( \$doctype->element_names ) {\n      *{"\$callpkg\\::start_\$tag"} = sub {\n\x09 \$pkg_writers{\$callpkg}->startTag( \$tag, \@_ ) ;\n      },\n\n      *{"\$callpkg\\::end_\$tag"} = sub {\n\x09 \$pkg_writers{\$callpkg}->endTag( \$tag, \@_ ) ;\n      },\n\n      *{"\$callpkg\\::empty_\$tag"} = sub {\n\x09 \$pkg_writers{\$callpkg}->emptyTag( \$tag, \@_ ) ;\n      },\n\n      *{"\$callpkg\\::\$tag"} = sub {\n\x09 \$pkg_writers{\$callpkg}->dataElement( \$tag, \@_ ) ;\n      },\n\n   }\n\n}\n\n\n\n=item getDataMode\n\n   \$m = getDataMode ;\n   \$m = \$writer->getDataMode ;\n\nReturns TRUE if the writer is in DATA_MODE.\n\n=cut\n\nsub getDataMode {\n   my XML::ValidWriter \$self = shift ;\n\n   return \$self->{DATA_MODE} ;\n}\n\n\n=item getDoctype\n\n   \$dtd = getDoctype ;\n   \$dtd = \$writer->getDoctype ;\n\nThis is used to get the writer's XML::Doctype object.\n\n=cut\n\nsub getDoctype {\n   my XML::ValidWriter \$self = &_self ;\n   return \$self->{DOCTYPE} ;\n}\n\n=item getOutput\n\n   \$fh = getOutput ;\n   \$fh = \$writer->getOutput ;\n\nGets the filehandle an XML::ValidWriter sends output to.\n\n=cut\n\nsub getOutput {\n   my XML::ValidWriter \$self = &_self ;\n   return \$self->{OUTPUT} ;\n}\n\n\n=item rawCharacters\n\n   rawCharacters( "<unescaped text>", "& more text" ) ;\n   \$writer->rawCharacters( "<unescaped text>", "& more text" ) ;\n\nThis allows you to emit raw text without any escape processing.  The text\nis not examined for tags, so you can invalidate your document and even\ncorrupt it's well-formedness.\n\n=cut\n\n## This is called everywhere to emit raw characters *except* characters(),\n## which must go direct because it uses STRAGGLERS and CDATA_END_PART\n## differently.\nsub rawCharacters {\n   my XML::ValidWriter \$self = &_self ;\n\n   my \$to= \$self->{OUTPUT} || select ;\n\n   return unless grep length \$_, \@_ ;\n\n   if ( ref \$to eq 'SCALAR' ) {\n      \$\$to .= join(\n         '',\n         _esc_cdata_ends( \$self->{CDATA_END_PART} ),\n\x09 \$self->{STRAGGLERS},\n\x09 \@_\n      ) ;\n      \$self->{AT_BOL} = substr( \$\$to, -1, 1 ) eq "\\n" ;\n   }\n   else {\n      no strict 'refs' ;\n\n      for ( my \$i = \$#_ ; \$i >= 0 ; --\$i ) {\n         next unless length \$_[\$i] ;\n\x09 \$self->{AT_BOL} = substr( \$_[\$i], -1, 1 ) eq "\\n" ;\n\x09 last ;\n      }\n\n      print \$to\n         _esc_cdata_ends( \$self->{CDATA_END_PART} ),\n         \$self->{STRAGGLERS},\n\x09 \@_ or croak \$!;\n   }\n   \$self->{CDATA_END_PART} = '' ;\n   \$self->{STRAGGLERS} = '' ;\n}\n\n\n=item reset\n\n   \$writer->reset ;        # Not a function!\n\nResets a writer to be initialized, but not have emitted anything.\n\nThis is useful if you need to abort output, but want to reuse the\nXML::ValidWriter.\n\n=cut\n\nsub reset {\n   my XML::ValidWriter \$self = shift ;\n   \$self->{STACK} = [] ;\n\n   # If we should warn, clear the flag that says we checked it & vice versa\n   \$self->{CHECKED_XML_DECL} = ! \$self->{SHOULD_WARN} ;\n\n   ## I'd use assignement to a slice here, but older perls...\n   \$self->{IS_STANDALONE}   = 0 ;\n   \$self->{EMITTED_DOCTYPE} = undef ;\n   \$self->{EMITTED_ROOT}    = undef ;\n   \$self->{EMITTED_XML}     = undef ;\n\n   \$self->{AT_BOL}          = 1 ;\n   \$self->{WAS_END_TAG}     = 1 ;\n   \$self->{STRAGGLERS}      = '' ;\n   \$self->{CDATA_END_PART} = '' ;\n\n   if ( defined \$self->{FILE_NAME} ) {\n      if ( defined \$self->{OUTPUT} ) {\n\x09 close \$self->{OUTPUT} or croak "\$! closing '\$self->{FILE_NAME}'." ;\n      }\n      else {\n\x09 require Symbol ;\n\x09 \$self->{OUTPUT} = Symbol::gensym() ;\n      }\n      eval "use Fcntl ; 1" or croak \$\@ ;\n      open(\n\x09 \$self->{OUTPUT},\n\x09 ">\$self->{FILE_NAME}",\n      ) \n\x09  or croak "\$!: \$self->{FILE_NAME}" ;\n   }\n\n   return ;\n}\n\n\n\n=item setDataMode\n\n   setDataMode( 1 ) ;\n   \$writer->setDataMode( 1 ) ;\n\nEnable or disable data mode.\n\n=cut\n\nsub setDataMode {\n   my XML::ValidWriter \$self = &_self ;\n\n   \$self->{DATA_MODE} = shift ;\n   return ;\n}\n\n\n\n=item setDoctype\n\n   setDoctype \$doctype ;\n   \$writer->setDoctype( \$doctype ) ;\n\nThis is used to set the doctype object.\n\n=cut\n\nsub setDoctype {\n   my XML::ValidWriter \$self = &_self ;\n   \$self->{DOCTYPE} = shift if \@_ ;\n   return ;\n}\n\n=item select_xml\n\n   select_xml OUTHANDLE ;  # Nnot a method!!\n\nSelects a filehandle to send the XML output to when not using the object\noriented interface.  This is similar to perl's builtin select,\nbut only affects startTag and endTag functions, (not methods).\n\nThis is only needed if you want to interleave output to the selected \noutput files (usually STDOUT, see L<perlfunc/select> and to an\nXML file on another filehandle.\n\nIf you want to redirect all output (yours and XML::Writer's) to the same\nfile, just use Perl's built-in select(), since startTag and endTag\nemit to the currently selected filehandle by default.\n\nLike select, this returns the old value.\n\n=cut\n\nsub select_xml(;*) {\n   ## I cheat a little and this could be used as a method\n   my XML::ValidWriter \$self = &_self ;\n\n   my \$r = \$self->getOutput ;\n   \$self->setOutput( shift ) if \@_ ;\n   return \$r ;\n}\n\n=item setOutput\n\n   setOutput( \\*FH ) ;\n   \$writer->setOutput( \\*FH ) ;\n\nSets the filehandle an XML::ValidWriter sends output to.\n\n=cut\n\nsub setOutput {\n   my XML::ValidWriter \$self = &_self ;\n   \$self->{OUTPUT} = shift if \@_ ;\n   return ;\n}\n\n\n=item startTag\n\n   startTag( 'a', attr => val ) ;  # use default XML::ValidWriter for\n                                   # current package.\n   \$writer->startTag( 'a', attr => val ) ;\n\nEmits a named start tag with optional attributes.  If the named tag\ncannot be a child of the most recently started tag, then any tags\nthat need to be opened between that one and the named tag are opened.\n\nIf the named tag cannot be enclosed within the most recently opened\ntag, no matter how deep, then startTag() tries to end as few started tags\nas necessary to allow the named tag to be emitted within a tag already on the\nstack.\n\nThis warns (once) if no <?xml?> declaration has been emitted.  It does not\ncheck to see if a <!DOCTYPE...> has been emitted.  It dies if an attempt\nis made to emit a second root element.\n\n=cut\n\nsub startTag {\n   my XML::ValidWriter \$self = &_self ;\n   my \$tag = shift ;\n   croak "Must supply a tag name" unless defined \$tag ;\n\n   \$self->{CHECKED_XML_DECL} ||=\n      ( carp( "No <?xml?> emitted." ), 1 ) ;\n\n   if ( ! \@{\$self->{STACK}} ) {\n      if ( defined \$self->{EMITTED_ROOT} ) {\n\x09 croak\n\x09    "Root element '\$self->{EMITTED_ROOT}' ended, can't emit '\$tag'"\n      }\n      else {\n         if ( \$tag ne \$self->{DOCTYPE}->name ) {\n\x09    croak\n\x09       "Root element '\$tag' does not match DOCTYPE '",\n\x09       \$self->getDTD->name,\n\x09       "'"\n\x09 }\n      }\n      \$self->{EMITTED_ROOT} = \$tag ;\n   }\n\n   my \$elt_decl = \$self->{DOCTYPE}->element_decl( \$tag ) ;\n\n   my \@attrs ;\n   my %attrs ;\n   ## emptyTag sneaks an '#EMPTY' on the parms and calls us.\n   my \$is_empty = \@_ && \$_[-1] eq '#EMPTY'\n      ? pop\n      : \$elt_decl->is_empty ;\n\n   croak "Odd number of parameters passed to startTag( '\$tag' ): ",\n      scalar( \@_ )\n      if \@_ & 1 ;\n\n   while ( \@_ ) {\n      my ( \$attr, \$val ) = ( shift, shift ) ;\n\n      croak "Undefined attribute name for <\$tag>" \n         unless defined \$attr ;\n\n      croak "Undefined attribute value for <\$tag>, attribute '\$attr'" \n         unless defined \$val ;\n\n      croak "Attribute '\$attr' already emitted"\n         if \$attrs{\$attr} ;\n\n      \$attrs{\$attr} = \$val ;\n\n      push \@attrs, ( ' ', \$attr, '="', _attr_esc1( \$val ), '"' )  ;\n   }\n\n   if ( \$elt_decl ) {\n      for my \$attdef ( \$elt_decl->attdefs ) {\n\x09 my \$name  = \$attdef->name ;\n\x09 my \$quant = \$attdef->quant ;\n\n\x09 push \@attrs, (\n\x09    ' ',\n\x09    \$name,\n\x09    '="',\n\x09    \$attrs{\$name} = _attr_esc1( \$attdef->default_on_write ),\n\x09    '"'\n\x09 )\n\x09    if ! exists \$attrs{\$name} && defined \$attdef->default_on_write ;\n\n\x09 if ( \$quant eq '#FIXED' ) {\n\x09    if ( exists \$attrs{\$name} ) {\n\x09\x09croak "Attribute '\$name' is #FIXED to '" .  \$attdef->default\n\x09\x09   . "' and cannot be emitted as '" .  \$attrs{\$name} . "'"\n\x09\x09   if \$attdef->default ne \$attrs{\$name}\n\x09    }\n\x09    else {\n\x09       ## Output #FIXED attributes if they weren't passed\n\x09       push \@attrs, ( ' ', \$name, '="', _attr_esc1( \$attdef->default ), '"' )  ;\n\x09    }\n\x09 }\n\x09 elsif ( \$quant eq '#REQUIRED' ) {\n\x09    croak "Tag '\$tag', attribute '\$name' #REQUIRED, but not provided"\n\x09       unless exists \$attrs{\$name} && defined \$attrs{\$name} ;\n\x09 }\n      }\n   }\n\n   ## TODO: A quick check to see if \$tag can be it's parent's child.\n   ## TODO: Incremental data model checking.\n   my \$stack = \$self->{STACK} ;\n\n   my \$prefix = '' ;\n   if ( \$self->{DATA_MODE} ) {\n      \$prefix = ( \$self->{AT_BOL} ? "" : "\\n" ) . " " x ( 3 * \@\$stack ) ;\n   }\n\n   if ( \$is_empty ) {\n      \$self->rawCharacters(\n         \$prefix, '<', \$tag, \@attrs, ' />',\n         ! \@\$stack || \$self->getDataMode ? "\\n" : ()\n      ) ;\n   }\n   else {\n      \$self->rawCharacters( \$prefix, '<', \$tag, \@attrs ) ;\n      \$self->{STRAGGLERS} = '>' ;\n   }\n\n   \$stack->[-1]->add_content( \$tag )\n      if \@{\$stack} ;\n   push \@\$stack, XML::VWElement->new( \$elt_decl )\n      unless \$is_empty ;\n\n   \$self->{WAS_END_TAG} = \$is_empty ;\n\n   return ;\n}\n\n\n=item xmlDecl([[\$encoding][, \$standalone])\n\n   xmlDecl ;\n   xmlDecl( "UTF-8" ) ;\n   xmlDecl( "UTF-8", "yes" ) ;\n   \$writer->xmlDecl( ... ) ;\n\nEmits an XML declaration.  Must be called before any of the other\noutput routines.\n\nIf \$encoding is not defined, it is not output.  This is slightly\ndifferent than XML::Writer, which outputs 'UTF-8' if you pass in\nundef, 0, or ''.\n\nIf \$encoding is '' or 0, then it is output as "" or "0"\nand a warning is generated.\n\nIf \$standalone is defined and is not 'no', 0, or '', it is output as 'yes'.\nIf it is 'no', then it is output as 'no'.  If it's 0 or '' it is not\noutput.\n\n=cut\n\nsub xmlDecl {\n   my XML::ValidWriter \$self = &_self ;\n\n   croak "<?xml?> already emitted"\n      if defined \$self->{EMITTED_XML} ;\n\n   croak "<?xml?> not the first thing in the document"\n      if defined \$self->{EMITTED_DOCTYPE} || defined \$self->{EMITTED_ROOT} ;\n\n   my ( \$encoding, \$standalone ) = \@_ ;\n\n   if ( defined \$encoding ) {\n      carp "encoding '\$encoding' passed"\n         if ! \$encoding ;\n   }\n\n   \$standalone = 'yes' if \$standalone && \$standalone ne 'no' ;\n\n   \$self->rawCharacters(\n      '<?xml version="1.0"',\n      defined \$encoding\n         ? qq{ encoding="\$encoding"}\n\x09 : (),\n      \$standalone\n         ? qq{ standalone="\$standalone"}\n\x09 : (),\n      "?>\\n"\n   ) ;\n\n   \$self->{CHECKED_XML_DECL} = 1 ;\n   \$self->{IS_STANDALONE} = \$standalone && \$standalone eq 'yes' ;\n   # declare open season on tag emission\n   \$self->{EMITTED_XML} = 1 ;\n}\n\n=item AUTOLOAD\n\nThis function is called whenever a function or method is not found\nin XML::ValidWriter.\n\nIf it was a method being called, and the desired method name is a start\nor end tag found in the DTD, then a method is cooked up on the fly.\n\nThese methods are slower than normal methods, but they are cached so\nthat they don't need to be recompiled.  The speed penalty is probably\nnot significant since they do I/O and are thus usually orders of\nmagnitude slower than normal Perl methods.\n\n=cut\n\n## TODO: Perhaps change exportDTDTags to use AUTOLOAD\n## TODO: Allow caching of methods in package namespace as an option so\n## that specializations of XML::ValidWriter can avoid the AUTOLOAD speed\n## hit.\n\nuse vars qw( \$AUTOLOAD ) ;\n\nsub AUTOLOAD {\n   croak "Function \$AUTOLOAD not AUTOLOADable (no functions are)"\n      unless isa( \$_[0], __PACKAGE__ ) ;\n\n   my XML::ValidWriter \$self = \$_[0] ;\n   unless ( exists \$self->{METHODS}->{\$AUTOLOAD} ) {\n      my ( \$class, \$ss, \$method ) =\n\x09 \$AUTOLOAD =~ /^(.*)::((?:start_|end_|empty_)?)(.*?)\$/ ;\n      croak "Can't parse method name '\$AUTOLOAD'" unless defined \$class ;\n\n      croak "Method \$AUTOLOAD does not refer to an element in the XML::Doctype"\n\x09 unless \$self->{DOCTYPE}->element_decl( \$method ) ;\n\n      my \$sub = \$ss eq ''\n\x09    ? sub {\n\x09       my XML::ValidWriter \$self = shift ;\n\x09       \$self->dataElement( \$method, \@_ ) ;\n\x09    }\n\x09 : \$ss eq 'start_'\n\x09    ? sub {\n\x09       my XML::ValidWriter \$self = shift ;\n\x09       \$self->startTag( \$method, \@_ ) ;\n\x09    }\n\x09 : \$ss eq 'end_'\n\x09    ? sub {\n\x09       my XML::ValidWriter \$self = shift ;\n\x09       \$self->endTag( \$method, \@_ ) ;\n\x09    }\n\x09 : sub {\n\x09       my XML::ValidWriter \$self = shift ;\n\x09       \$self->emptyTag( \$method, \@_ ) ;\n\x09    }\n\x09 ;\n\n      \$self->{METHODS}->{\$AUTOLOAD} = \$sub ;\n   }\n      \n   goto &{\$self->{METHODS}->{\$AUTOLOAD}}\n}\n\n=item DESTROY\n\nDESTROY is called when an XML::ValidWriter is cleaned up.  This is used\nto automatically close all tags that remain open.  This will not work\nif you have closed the output filehandle that the ValidWriter was\nusing.\n\nThis method will also warn if anything was emitted bit no root node was\nemitted.  This warning can be silenced by calling\n\n   \$writer->reset() ;\n\nwhen you abandon output.\n\n=cut\n\n##TODO: Prevent \$self->end for errored objects.\n##TODO: Prevent further output to errored objects if they cannot ever\n## be valid.  Perhaps prevent it to all errored objects?\n\nsub DESTROY {\n   my XML::ValidWriter \$self = shift ;\n\n#   if ( \@{\$self->{STACK}} ) {\n#      \$self->end() ;\n#   }\n\n   if ( defined \$self->{FILE_NAME} ) {\n      close \$self->{OUTPUT} or croak "\$! closing '\$self->{FILE_NAME}'." ;\n   }\n\n   if ( ! defined \$self->{EMITTED_ROOT}\n      && (  defined \$self->{EMITTED_XML}\n\x09 || defined \$self->{EMITTED_DOCTYPE}\n      )\n   ) {\n      ## TODO: Identify a document name here\n      carp "No content emitted after preamble in ",\n         ref \$self,\n\x09 " created at ",\n\x09 \$self->{CREATED_AT} ;\n      ;\n   }\n}\n\n##\n## A tiny helper class of instances ValidWriter places on the stack as\n## it opens new elements\n##\npackage XML::VWElement ;\n\nuse fields qw( NAME ELT_DECL CONTENT ) ;\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my XML::VWElement \$self ;\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   my ( \$elt_decl ) = \@_ ;\n\n   \$self->{NAME} = \$elt_decl->name ;\n   \$self->{ELT_DECL} = \$elt_decl ;\n   \$self->{CONTENT} = [] ;\n\n   return \$self ;\n}\n\nsub add_content {\n   my XML::VWElement \$self = shift ;\n\n   for ( \@_ ) {\n      if ( ! \@{\$self->{CONTENT}}\n         || ! ( \$_                     eq '#PCDATA' \n\x09    &&  \$self->{CONTENT}->[-1] eq '#PCDATA'\n\x09 )\n      ) {\n         push \@{\$self->{CONTENT}}, \$_ ;\n      }\n   }\n}\n\n=back\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nThis module is Copyright 2000, Barrie Slaymaker.  All rights reserved.\n\nThis module is licensed under the GPL, version 2.  Please contact me if this\ndoes not suit your needs.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAACZ
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADA, "lib/XML/Doctype.pm" }
package XML::Doctype ;\n\n=head1 NAME\n\nXML::Doctype - A DTD object class\n\n=head1 SYNOPSIS\n\n   # To parse an external DTD at compile time, useful when\n   # using XML::ValidWriter\n   use XML::Doctype NAME => 'FooML', SYSTEM_ID => 'FooML.dtd' ;\n   use XML::Doctype NAME => 'FooML', DTD_TEXT  => \$dtd ;\n\n   # Parsing at run-time\n   \$doctype = XML::Doctype->new( 'FooML', SYSTEM_ID => 'FooML.dtd' ) ;\n\n   # or\n   \$doctype = XML::Doctype->new() ;\n   \$doctype->parse( 'FooML', 'FooML.dtd' ) ;\n\n   # Saving the parsed object\n   open( PM, ">FooML/DTD/v1_000.pm" ) or die \$! ;\n   print PM \$doctype->as_pm( 'FooML::DTD::v1_000' ) ;\n\n   # Using a saved parsed DTD\n   use FooML::DTD::v1_000 ;\n\n   \$doctype = FooML::DTD::v1_000->new() ;\n\n\n=head1 DESCRIPTION\n\nThis module parses DTDs and allows them to be saved as .pm files and\nreloaded.  The ability to save and reload is intended to aid in packaging\nparsed DTDs with XML tools so that XML::Parser need not be installed.\n\n=head1 STATUS\n\nThis module is alpha code.  It's developed enough to support XML::ValidWriter,\nbut need a lot of work.  Some big things that are lacking are:\n\n=over\n\n=item *\n\nmethods or objects to build / traverse the DTD\n\n=item *\n\nXML::Doctype::ELEMENT\n\n=item *\n\nXML::Doctype::ATTLIST\n\n=item *\n\nXML::Doctype::ENITITY\n\n=back\n\n=cut\n\nuse strict ;\nuse vars qw( \$VERSION %_default_dtds ) ;\nuse fields (\n   'ELTS',       # A hash of declared & undeclared elements, keyed by name\n   'NAME',       # The root node (the name from the DOCTYPE decl).\n   'SYSID',\n   'PUBID',\n) ;\n\nuse Carp ;\nuse XML::Doctype::ElementDecl ;\nuse XML::Doctype::AttDef ;\n\n\$VERSION = 0.11 ;\n\n=head1 METHODS\n\n=item new\n\n   \$doctype = XML::Doctype->new() ;\n   \$doctype = XML::Doctype->new( 'FooML', DTD_TEXT => \$doctype_text ) ;\n   \$doctype = XML::Doctype->new( 'FooML', SYSTEM_ID => 'FooML.dtd' ) ;\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my XML::Doctype \$self ;\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   return \$self unless \@_ ;\n\n   my \$name = shift ;\n\n   if ( \@_ == 1 ) {\n      \$self->parse_dtd_file( \$name, shift ) ;\n   }\n   else {\n      while ( \@_ ) {\n\x09 for ( shift ) {\n\x09    if ( /^SYSTEM(?:_ID)?\$/ ) {\n\x09       \$self->parse_dtd_file( \$name, shift ) ;\n\x09    }\n\x09    elsif ( \$_ eq 'DTD_TEXT' ) {\n\x09       \$self->parse_dtd( \$name, shift ) ;\n\x09    }\n\x09    else {\n\x09       croak "Unrecognized parameter '\$_'" ;\n\x09    }\n\x09 }\n      }\n   }\n\n   ## Do this here so subclass author won't be suprised when eventually\n   ## calling save_as_pm.\n   no strict 'refs' ;\n   croak "\\\$\$class\\::VERSION not defined" \n      unless defined \${"\$class\\::VERSION"} ;\n\n   return \$self ;\n}\n\n\n=item name\n\n   \$name = \$doctype->name() ;\n\n   Sets/gets the name.\n\n=cut\n\nsub name {\n   my XML::Doctype \$self = shift ;\n   \$self->{NAME} = shift if \@_ ;\n   return \$self->{NAME}\n}\n\n\n##\n## Called to translate the XML::Parser::ContentModel passed by XML::Parser\n## in to a tree of XML::Doctype::ChildDecl instances.\nsub _import_ContentModel {\n}\n\n\nsub _do_parse {\n   my XML::Doctype \$self = shift ;\n   my ( \$fake_doc ) = \@_ ;\n\n   my \$elts = \$self->{ELTS} = {} ;\n\n   ## Should maybe use libwww to fetch URLs, but will do files for now\n   ## We require this lazily to save load time and allow it to be\n   ## not present if it's not needed.\n   require XML::Parser ;\n   my \$p = XML::Parser->new(\n      ParseParamEnt => 1,\n      Handlers => {\n         Doctype => sub {\n            my \$expat = shift ;\n\x09    my ( \$name, \$sysid, \$pubid, \$internal ) = \@_ ;\n\x09    \$self->{NAME} = \$name ;\n\x09    \$self->{SYSID} = \$sysid ;\n\x09    \$self->{PUBID} = \$pubid ;\n\x09 },\n\x09 \n\x09 Element => sub {\n\x09    my \$expat = shift ;\n\x09    my ( \$name, \$model ) = \@_ ;\n\n\x09    croak "ELEMENT '\$name' already defined"\n\x09       if exists \$elts->{\$name} && \$elts->{\$name}->is_declared ;\n\n            my \$elt = XML::Doctype::ElementDecl->new( \$name, \$model ) ;\n\x09    \$elt->is_declared( 1 ) ;\n            \$elts->{\$name} = \$elt ;\n\n\x09    for ( \$elt->child_names ) {\n\x09       \$elts->{\$_} = XML::Doctype::ElementDecl->new( \$_ )\n\x09          unless \$elts->{\$_} ;\n\x09    }\n\x09 },\n\n         Attlist => sub {\n\x09    my \$expat = shift ;\n\x09    my ( \$elt_name, \$att_name, \$type, \$default, \$fixed ) = \@_ ;\n\n\x09    \$elts->{\$elt_name} = XML::Doctype::ElementDecl->new()\n\x09       unless exists \$elts->{\$elt_name} ;\n\n\x09    \$default =~ s/^'(.*)'\$/\$1/ || \$default =~ s/^"(.*)"\$/\$1/ ;\n\x09    \n\x09    \$elts->{\$elt_name}->add_attdef(\n\x09       XML::Doctype::AttDef->new( \n\x09\x09  \$att_name,\n\x09\x09  \$type,\n\x09\x09  \$fixed ? ( '#FIXED', \$default ) : ( \$default, undef ),\n\x09       )\n\x09    ) ;\n\x09 },\n      },\n   ) ;\n\n   \$p->parse( \$fake_doc ) ;\n\n   croak "Doctype",\n      defined \$self->{SYSID} ? " SYSTEM_ID \$self->{SYSID}" : (),\n      " did not declare root node <\$self->{NAME}>"\n      unless exists \$self->{ELTS}->{\$self->{NAME}} ;\n\n#   require Data::Dumper ; print Data::Dumper::Dumper( \$elts ) ;\n   ## TODO: Check that all elements referred-to by name in the element tree\n   ## rooted at \$self->{NAME} are actually declared.\n}\n\n\n=item parse_dtd\n\n   \$doctype->parse_dtd( \$name, \$doctype_text ) ;\n   \$doctype->parse_dtd( \$name, \$doctype_text, 'internal' ) ;\n\nParses the text of a DTD from a scalar.  \$name is used to indicate the\nname of the DOCTYPE, and thus the root node.\n\nThe DTD is considered to be external unless the third parameter is\nTRUE.\n\n=cut\n\nsub parse_dtd {\n   my XML::Doctype \$self = shift ;\n   my ( \$name, \$text, \$internal ) = \@_ ;\n\n   \$self->_do_parse( <<TOHERE ) ;\n<?xml version="1.0" encoding="US-ASCII" standalone="yes"?>\n<!DOCTYPE \$name [\n\$text\n]>\n<\$name></\$name>\nTOHERE\n}\n\n\n=item parse_dtd_file\n\n   \$doctype->parse_dtd_file( \$name, \$system_id [, \$public_id] ) ;\n   \$doctype->parse_dtd_file( \$name, \$system_id [, \$public_id], 'internal' ) ;\n\nParses a DTD from a file.  Eventually will support full URL syntax.\n\n\$public_id is ignored for now, and \$system_id is used to locate\nthe DTD.\n\nThis routine requires XML::Parser.  XML::Parser is not loaded at any\nother time and is not needed to use the resulting DTD object.\n\nThe DTD is considered to be external unless the fourth parameter is\nTRUE.\n\n   \$doctype->parse_dtd_file( \$name, \$system_id, \$p_id, 'internal' ) ;\n   \$doctype->parse_dtd_file( \$name, \$system_id, undef, 'internal' ) ;\n\n=cut\n\n\nsub parse_dtd_file {\n   my XML::Doctype \$self = shift ;\n   my ( \$name, \$system_id, undef, \$internal ) = \@_ ;\n\n   \$self->_do_parse( <<TOHERE ) ;\n<?xml version="1.0" encoding="US-ASCII" standalone="no"?>\n<!DOCTYPE \$name SYSTEM "\$system_id" >\n<\$name></\$name>\nTOHERE\n}\n\n\n=item system_id\n\n   \$system_id = \$doctype->system_id() ;\n\n   Sets/gets the system ID.\n\n=cut\n\nsub system_id {\n   my XML::Doctype \$self = shift ;\n   \$self->{SYSID} = shift if \@_ ;\n   return \$self->{SYSID}\n}\n\n=item public_id\n\n   \$public_id = \$doctype->public_id() ;\n\n   Sets/gets the public_id.\n\n=cut\n\nsub public_id {\n   my XML::Doctype \$self = shift ;\n   \$self->{PUBID} = shift if \@_ ;\n   return \$self->{PUBID}\n}\n\n=item element_decl\n\n   \$elt_decl = \$doctype->element_decl( \$name ) ;\n\nReturns the XML::Doctype:Element object associated with \$name.  These can\nbe defined by <!ELEMENT> tags or undefined, which can happen if they\nwere just referred-to by <!ELEMENT> or <!ATTLIST> tags.\n\n=cut\n\nsub element_decl {\n   my XML::Doctype \$self = shift ;\n   my ( \$name ) = \@_ ;\n\n   return \$self->{ELTS}->{\$name} if exists \$self->{ELTS}->{\$name} ;\n   return ;\n}\n\n=item element_names\n\nReturns an unsorted list of element names.  This list includes names that\nare declared and undeclared (but referred to in element declarations or\nattribute definitions).\n\n=cut\n\nsub element_names {\n   my XML::Doctype \$self = shift ;\n   my \$h = {} ;\n   for ( keys %{\$self->{ELTS}} ) {\n      \$h->{\$_} = 1 ;\n      \$h->{\$_} = 1 for \$self->{ELTS}->{\$_}->child_names() ;\n   }\n\n   return keys %\$h ;\n}\n\n\n=item as_pm\n\n   open( PM, "FooML/DTD/v1_001.pm" )            or die \$! ;\n   print PM \$doctype->as_pm( 'FooML::DTD::v1_001' ) or die \$! ;\n   close PM                                     or die \$! ;\n\nThen, later:\n\n   use FooML::DTD::v1_001 ;   # Do *not* use () as a parameter list!\n\nReturns string containing the DTD as an independant module, allowing the\nDTD to be parsed in the development environment and shipped as Perl code,\nso that the target environment need not have XML::Parser installed.\n\nThis is useful for XML creation-only tools and as an\nefficiency tuning measure if you will be rereading the same set of DTDs over\nand over again.\n\n=cut\n\n## TODO: Save as pure, unblessed data structure that XML::Doctype can\n## convert to internal format, to increase inter-version compatibility.\n\nsub as_pm {\n   my XML::Doctype \$self = shift ;\n   my ( \$package ) = \@_ ;\n\n   my \$date = localtime ;\n   my \$class = ref \$self ;\n\n   my \$version ;\n   if ( \$class ne __PACKAGE__ ) {\n      no strict 'refs' ;\n      croak "\\\$\$class\\::VERSION not defined" \n         unless defined \${"\$class\\::VERSION"} ;\n      \$version = "\$class, v" . \${"\$class\\::VERSION"} . ", (" ;\n   }\n\n   \$version .= __PACKAGE__ . ", v\$VERSION" ;\n   \$version .= ')'\n      if \$class ne __PACKAGE__ ;\n\n   require Data::Dumper ;\n   my \$d = Data::Dumper->new( [\$self], ['\$doctype'],  ) ;\n#   \$d->Freezer( '_freeze' ) unless \$d->can( 'Dumpperl' ) ;\n   \$d->Purity(1);     ## We really do want to dump executable code.\n   \$d->Indent(1);     ## Used fixed indent depth.  I find this more readable.\n\n   return\n      join( '', <<ENDPREAMBLE, \$d->can( 'Dumpperl' ) ? \$d->Dumpperl : \$d->Dump, "\\n 1 ;\\n" );\npackage \$package ;\n\n##\n## THIS FILE CREATED AUTOMATICALLY: YOU MAY LOSE ANY EDITS IF YOU MOFIFY IT.\n##\n## When: \$date\n## By:   \$version\n##\n\nrequire XML::Doctype ;\n\nsub import {\n   my \\\$pkg = shift ;\n   my \\\$callpkg = caller ;\n   \\\$XML::Doctype::_default_dtds{\\\$callpkg} = \\\$doctype ;\n}\n\nENDPREAMBLE\n}\n\n\nsub _freeze {\n   my \$self = shift ;\n   \$_->_freeze for values %{\$self->{ELTS}} ;\n   return \$self ;\n}\n\n\n=item import\n\n=item use\n\n   use XML::Doctype NAME => 'FooML', SYSTEM_ID => 'dtds/FooML.dtd' ;\n\nimport() constructs a default DTD object for the calling package\nso that XML::ValidWriter's functional interface can use it.\n\nIf XML::Doctype is subclassed, the subclasses' constructor is called with\nall parameters.\n\n=cut\n\nsub import {\n   my \$class = shift ;\n   my \$callpkg = caller ;\n\n   my \@others ;\n   my \@dtd_args ;\n   while ( \@_ ) {\n      for ( shift ) {\n\x09 if ( \$_ eq 'NAME' ) {\n\x09    push \@dtd_args, shift ;\n\x09 }\n\x09 elsif ( /^[A-Z][A-Z_0-9]*\$/ ) {\n\x09    push \@dtd_args, \$_, shift ;\n\x09 }\n\x09 else {\n\x09    push \@others, \$_ ;\n\x09 }\n      }\n   }\n   \$_default_dtds{\$callpkg} = \$class->new( \@dtd_args ) \n      if \@dtd_args ;\n\n   croak join( ', ', \@others ), " not exported by \$class" if \@others ; \n}\n\n\n=head1 SUBCLASSING\n\nThis object uses the fields pragma, so you should use base and fields for\nany subclasses.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nThis module is Copyright 2000, Barrie Slaymaker.  All rights reserved.\n\nThis module is licensed under the GPL, version 2.  Please contact me if this\ndoes not suit your needs.\n\n=cut\n\n\n\n1 ;\n
END_OF_FILE_AAAAAAAAAADA
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADB, "lib/XML/Doctype/AttDef.pm" }
package XML::Doctype::AttDef ;\n\n=head1 NAME\n\nXML::Doctype::AttDef - A class representing a definition in an <!ATTLIST> tag\n\n=head1 SYNOPSIS\n\n   \$attr = \$elt->attribute( \$name ) ;\n   \$attr->name ;\n\n=head1 DESCRIPTION\n\nThis module is used to represent <!ELEMENT> tags in an XML::Doctype object.\nIt contains <!ATTLIST> tags as well.\n\n=head1 STATUS\n\nThis module is alpha code.  It's developed enough to support XML::ValidWriter,\nbut need a lot of work.  Some big things that are lacking are:\n\n=over\n\n=cut\n\nuse strict ;\nuse vars qw( \$VERSION %_default_dtds ) ;\nuse fields (\n   'DEFAULT', # The default value if QUANT is '#FIXED' or '', undef otherwise\n   'NAME',\n   'OUT_DEFAULT', # Used to set a universal output default value\n   'QUANT',   # '#REQUIRED', '#IMPLIED', '#FIXED', undef\n   'TYPE',    # 'CDATA', 'ID', ...\n) ;\n\nuse Carp ;\n\n\$VERSION = 0.1 ;\n\n=head1 METHODS\n\n=item new\n\n   \$dtd = XML::Doctype::AttDef->new( \$name, \$type, \$default ) ;\n\n=cut\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my XML::Doctype::AttDef \$self ;\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   ( \$self->{NAME}, \$self->{TYPE} ) = \@_[0,1] ;\n   if ( \$_[0] =! /^#/ ) {\n      ( \$self->{QUANT}, \$self->{DEFAULT} ) = \@_[2,3] ;\n   }\n   else {\n      \$self->{DEFAULT} = \$_[2] ;\n   }\n\n   return \$self ;\n}\n\n\n=item default\n\n   ( \$spec, \$value ) = \$attr->default ;\n   \$attr->default( '#REQUIRED' ) ;\n   \$attr->default( '#IMPLIED' ) ;\n   \$attr->default( '', 'foo' ) ;\n   \$attr->default( '#FIXED', 'foo' ) ;\n\nSets/gets the default value.  This is a \n\n=cut\n\nsub default {\n   my XML::Doctype::AttDef \$self = shift ;\n\n   if ( \@_ ) {\n      my ( \$default ) = \@_ ;\n      my \$quant = \$self->quant ;\n      if ( defined \$default ) {\n         if ( defined \$quant && \$quant =~ /^#(REQUIRED|IMPLIED)/ ) {\n\x09    carp\n\x09 "Attribute '", \$self->name, "' \$quant default set to '\$default'" ;\n\x09 }\n      }\n      else {\n         if ( ! defined \$quant ) {\n\x09    carp "Attribute '", \$self->name, "' default set to undef" ;\n         }\n         elsif ( \$quant eq '#FIXED' ) {\n\x09    carp "Attribute '", \$self->name, "' #FIXED default set to undef" ;\n\x09 }\n      }\n      \$self->{DEFAULT} = \$default ;\n   }\n\n   return \$self->{DEFAULT} ;\n}\n\n\n=item quant\n\n   \$attdef->quant( \$q ) ;\n   \$q = \$attdef->quant ;\n\nSets/gets the attribute quantifier: '#REQUIRED', '#FIXED', '#IMPLIED', or ''.\n\n=cut\n\nsub quant {\n   my XML::Doctype::AttDef \$self = shift ;\n\n   \$self->{QUANT} = shift if \@_ ;\n   return \$self->{QUANT} ;\n}\n\n\n=item name\n\n   \$attdef->name( \$name ) ;\n   \$name = \$attdef->name ;\n\nSets/gets this attribute name.  Don't change the name while an attribute\nis in an element's attlist, since it will then be filed under the wrong\nname.\n\n=cut\n\nsub name {\n   my XML::Doctype::AttDef \$self = shift ;\n\n   \$self->{NAME} = shift if \@_ ;\n   return \$self->{NAME} ;\n}\n\n\n=item default_on_write\n\n   \$attdef->default_on_write( \$value ) ;\n   \$value = \$attdef->default_on_write ;\n\n   \$attdef->default_on_write( \$attdef->default ) ;\n\nSets/gets the value which is automatically output for this attribute\nif none is supplied to \$writer->startTag.  This is typically used\nto set a document-wide default for #REQUIRED attributes (and perhaps\nplain attributes) so that the attribute is treated like a #FIXED tag\nand emitted with a fixed value.\n\nThe default_on_write does not need to be the same as the default unless\nthe quantifier is #FIXED.\n\n=cut\n\nsub default_on_write {\n   my XML::Doctype::AttDef \$self = shift ;\n\n   \$self->{OUT_DEFAULT} = shift if \@_ ;\n   return \$self->{OUT_DEFAULT} ;\n}\n\n\n=head1 SUBCLASSING\n\nThis object uses the fields pragma, so you should use base and fields for\nany subclasses.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nThis module is Copyright 2000, Barrie Slaymaker.  All rights reserved.\n\nThis module is licensed under the GPL, version 2.  Please contact me if this\ndoes not suit your needs.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAADB
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADC, "lib/XML/Doctype/ElementDecl.pm" }
package XML::Doctype::ElementDecl ;\n\n=head1 NAME\n\nXML::Doctype::ElementDecl - A class representing an <!ELEMENT> tag\n\n=head1 SYNOPSIS\n\n   \$elt = \$dtd->element( 'foo' ) ;\n   \$elt->name() ;\n   \$elt->attr( 'foo' ) ;\n\n=head1 DESCRIPTION\n\nThis module is used to represent <!ELEMENT> tags in an XML::Doctype object.\nIt contains <!ATTLIST> tags as well.\n\n=head1 STATUS\n\nThis module is alpha code.  It's developed enough to support XML::ValidWriter,\nbut need a lot of work.  Some big things that are lacking are:\n\n=over\n\n=cut\n\nuse strict ;\nuse vars qw( \$VERSION %_default_dtds ) ;\nuse fields (\n   'ATTDEFS',\n   'CONTENT',   # 'EMPTY', 'ANY' or a regexp.  undef if ! is_declared().\n   'DECLARED',\n   'NAME',\n   'NAMES',\n   'PATHS',     # A hash which XML::ValidWriter uses to cache the paths\n                # it finds from this element name to possible child elements.\n   'TODO',      # A list of children that XML::ValidWriter has not yet\n                # explored for possible inclusion in PATHS.\n) ;\n\nuse Carp ;\nuse UNIVERSAL qw( isa ) ;\n\n\$VERSION = 0.1 ;\n\n=head1 METHODS\n\n=item new\n\n   # Undefined element constructors:\n   \$dtd = XML::Doctype::ElementDecl->new( \$name ) ;\n   \$dtd = XML::Doctype::ElementDecl->new( \$name, undef, \\\@attdefs ) ;\n\n   # Defined element constructors\n   \$dtd = XML::Doctype::ElementDecl->new( \$name, \\\@kids, \\\@attdef ) ;\n   \$dtd = XML::Doctype::ElementDecl->new( \$name, [], \\\@attdefs ) ;\n\n=cut\n\nsub _assemble_re {\n   ## Convert the tree of XML::Parser::ContentModel instances to a\n   ## regular expression and accumulate a HASH of element names in\n   ## NAMES.  This hash is later converted to an ARRAY.\n   my XML::Doctype::ElementDecl \$self = shift ;\n   my ( \$cp ) = \@_ ;\n\n   if ( \$cp->isname ) {\n      return '(?:#PCDATA)*' if \$cp->name eq '#PCDATA' ;\n      \${\$self->{NAMES}->{\$cp->name}} = 1 ;\n      return join( '', '<', quotemeta \$cp->name, '>' ) unless \$cp->quant ;\n   }\n   \n   return join( '', map \$self->_assemble_re( \$_ ), \$cp->children )\n      if \$cp->isseq && ! \$cp->quant ;\n\n   return join( '',\n      '(?:',\n      \$cp->isname\n         ? ( '<', quotemeta( \$cp->name ), '>' )\n      : \$cp->isseq\n         ? join( '',  map \$self->_assemble_re( \$_ ), \$cp->children )\n      : \$cp->ischoice\n         ? join( '|', map \$self->_assemble_re( \$_ ), \$cp->children )\n      : \$cp->ismixed\n         ? join(\n\x09    '|',\n\x09    '(?:#PCDATA)?',\n\x09    map(\n\x09       defined \$_ ? \$self->_assemble_re( \$_ ) : (),\n\x09       \$cp->children\n\x09    )\n\x09 )\n      : (),\n      ')',\n      \$cp->quant || ()\n   ) ;\n\n}\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my XML::Doctype::ElementDecl \$self ;\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   my \$cm ; # The XML::Expat::ContentModel object for this DECL.\n   ( \$self->{NAME}, \$cm, \$self->{ATTDEFS} ) = \@_ ;\n\n   if ( \$cm ) {\n      if ( \$cm->isany ) {\n\x09 \$self->{CONTENT} = 'ANY' ;\n\x09 \$self->{NAMES} = [] ;\n      }\n      elsif ( \$cm->isempty ) {\n\x09 \$self->{CONTENT} = 'EMPTY' ;\n\x09 \$self->{NAMES} = [] ;\n      }\n      elsif ( \$cm->ismixed || \$cm->isseq || \$cm->ischoice ) {\n\x09 \$self->{NAMES} = {} ;\n\x09 my \$re = \$self->_assemble_re( \$cm ) ;\n\x09 \$self->{CONTENT} = "^\$re\\\$" ; # qr/^\$re\$/ ;\n\x09 \$self->{NAMES} = [ \$self->{NAMES} ? keys %{\$self->{NAMES}} : () ] ;\n      }\n      else {\n\x09 croak "'\$cm' passed for a content model" ;\n      }\n   }\n   else {\n      \$self->{NAMES} = [] ;\n   }\n\n   return \$self ;\n}\n\n\nsub _freeze {\n   my \$self = shift ;\n   if ( defined \$self->{CONTENT} && ref \$self->{CONTENT} eq 'Regexp' ) {\n      ## need two assigns to really, really divorce the SV from the\n      ## quircky-half-object RegExp type.\n      \$self->{CONTENT} = '' ;\n      \$self->{CONTENT} = "\$self->{CONTENT}" ;\n   }\n}\n\n\n=item add_attdef\n\n   \$elt_decl->add_attdef( \$att_def ) ;\n\n=cut\n\nsub add_attdef {\n   my XML::Doctype::ElementDecl \$self = shift ;\n   my ( \$attdef ) = \@_ ;\n   \$self->{ATTDEFS}->{\$attdef->name} = \$attdef ;\n}\n  \n\n=item attdef\n\n   \$attr = \$elt->attdef( \$name ) ;\n\nReturns the XML::Doctype::AttDef named by \$name or undef if there is no\nsuch attribute.\n\n=cut\n\nsub attdef {\n   my XML::Doctype::ElementDecl \$self = shift ;\n   my ( \$name ) = \@_ ;\n\n   return \$self->{ATTDEFS}->{\$name} if exists \$self->{ATTDEFS}->{\$name} ;\n   return ;\n}\n\n\n=item attdefs\n\n   \$attdefs = \$elt->attdefs( \$name ) ;\n\nReturns the list of XML::Doctype::AttDef instances associated with this\nelement.\n\n=cut\n\nsub attdefs {\n   my XML::Doctype::ElementDecl \$self = shift ;\n   my ( \$name ) = \@_ ;\n\n   return \$self->{ATTDEFS} ? values %{\$self->{ATTDEFS}} : () ;\n}\n\n\n=item attribute_names\n\nReturns a list of the attdefs' names.\n\n=cut\n\nsub attribute_names {\n   my XML::Doctype::ElementDecl \$self = shift ;\n\n   return \$self->{ATTDEFS} ? keys %{\$self->{ATTDEFS}} : () ;\n}\n\n\n=item child_names\n\n   \@names = \$elt->child_names ;\n\nReturns a list of names of elements in this element decl's content model.\n\n=cut\n\nsub child_names {\n   my XML::Doctype::ElementDecl \$self = shift ;\n\n   return \@{\$self->{NAMES}} ;\n}\n\n\n=item is_declared\n\n   if ( \$elt_decl->is_declared ) ...\n   \$elt_decl->is_declared( 1 ) ;\n\nReturns TRUE if there is any data defined in the element other than name and\nattributes or if is_declared has been set by calling is_declared( 1 ) or\npassing DECLARED => 1 to new().\n\n=cut\n\nsub is_declared {\n   my XML::Doctype::ElementDecl \$self = shift ;\n\n   \$self->{DECLARED} = shift if \@_ ;\n\n   return \$self->{DECLARED} || defined \$self->{CONTENT} ;\n}\n\n\n=item is_empty\n\n=cut\n\nsub is_empty {\n   my XML::Doctype::ElementDecl \$self = shift ;\n\n   return \$self->{CONTENT} && \$self->{CONTENT} eq 'EMPTY' ;\n}\n\n\n=item is_any\n\n=cut\n\nsub is_any {\n   my XML::Doctype::ElementDecl \$self = shift ;\n\n   return \$self->{CONTENT} && \$self->{CONTENT} eq 'ANY' ;\n}\n\n\n=item is_mixed\n\n=cut\n\nsub is_mixed {\n   my XML::Doctype::ElementDecl \$self = shift ;\n\n   return \$self->{CONTENT} && \$self->{CONTENT} =~ /#PCDATA/ ;\n}\n\nsub can_contain_pcdata {\n   my XML::Doctype::ElementDecl \$self = shift ;\n\n   return \$self->{CONTENT}\n      && (\n\x09 \$self->{CONTENT} eq 'ANY'\n\x09 || return \$self->{CONTENT} =~ /#PCDATA/\n      ) ;\n}\n\n=item name\n\n   \$n = \$elt_decl->name ;\n\nGets the name of the element.\n\n=cut\n\nsub name {\n   my XML::Doctype::ElementDecl \$self = shift ;\n\n   return \$self->{NAME} ;\n}\n\n\n=item validate_content\n\n   \$v = \$elt_decl->validate_content( \\\@seq ) ;\n\nTakes an ARRAY ref of tag names (or '#PCDATA') and checks to see if\nit would be valid content for elements of this type.\n\nRight now, this must be called only when an element's end tag is\nemitted.  It can be broadened to be incremental if need be.\n\n=cut\n\nsub validate_content {\n   my XML::Doctype::ElementDecl \$self = shift ;\n   my ( \$c ) = \@_ ;\n\n   return 1     if ! defined \$self->{CONTENT} || \$self->{CONTENT} eq 'ANY' ;\n   return ! \@\$c if \$self->{CONTENT} eq 'EMPTY' ;\n\n   ## Must be mixed.  If this elt can have no kids, the test\n   ## is quick.  Otherwise we need to validate agains the content\n   ## model tree.\n   my \$content_desc = join(\n      '',\n      map \$_ eq '#PCDATA' ? \$_ : "<\$_>",\n      \@\$c\n   ) ;\n\n# print STDERR "\$content_desc\\n\$self->{CONTENT}\\n" ;\n\n#print \$self->{CONTENT}, "\\n" ;\n\n   return \$content_desc =~ \$self->{CONTENT} ;\n}\n\n\n=head1 SUBCLASSING\n\nThis object uses the fields pragma, so you should use base and fields for\nany subclasses.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=head1 COPYRIGHT\n\nThis module is Copyright 2000, Barrie Slaymaker.  All rights reserved.\n\nThis module is licensed under the GPL, version 2.  Please contact me if this\ndoes not suit your needs.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAADC
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADD, "lib/Text/Diff.pm" }
package Text::Diff;\n\n\$VERSION = 0.32;\n\n=head1 NAME\n\nText::Diff - Perform diffs on files and record sets\n\n=head1 SYNOPSIS\n\n    use Text::Diff;\n\n    ## Mix and match filenames, strings, file handles, producer subs,\n    ## or arrays of records; returns diff in a string.\n    ## WARNING: can return B<large> diffs for large files.\n    my \$diff = diff "file1.txt", "file2.txt", { STYLE => "Context" };\n    my \$diff = diff \\\$string1,   \\\$string2,   \\%options;\n    my \$diff = diff \\*FH1,       \\*FH2;\n    my \$diff = diff \\&reader1,   \\&reader2;\n    my \$diff = diff \\\@records1,  \\\@records2;\n\n    ## May also mix input types:\n    my \$diff = diff \\\@records1,  "file_B.txt";\n\n=head1 DESCRIPTION\n\nC<diff()> provides a basic set of services akin to the GNU C<diff> utility.  It\nis not anywhere near as feature complete as GNU C<diff>, but it is better\nintegrated with Perl and available on all platforms.  It is often faster than\nshelling out to a system's C<diff> executable for small files, and generally\nslower on larger files.\n\nRelies on L<Algorithm::Diff> for, well, the algorithm.  This may not produce\nthe same exact diff as a system's local C<diff> executable, but it will be a\nvalid diff and comprehensible by C<patch>.  We haven't seen any differences\nbetween Algorithm::Diff's logic and GNU diff's, but we have not examined them\nto make sure they are indeed identical.\n\nB<Note>: If you don't want to import the C<diff> function, do one of the\nfollowing:\n\n   use Text::Diff ();\n\n   require Text::Diff;\n\nThat's a pretty rare occurence, so C<diff()> is exported by default.\n\n=cut\n\nuse Exporter;\n\@ISA = qw( Exporter );\n\@EXPORT = qw( diff );\n\nuse strict;\nuse Carp;\nuse Algorithm::Diff qw( traverse_sequences );\n\n## Hunks are made of ops.  An op is the starting index for each\n## sequence and the opcode:\nuse constant A       => 0;   # Array index before match/discard\nuse constant B       => 1;\nuse constant OPCODE  => 2;   # "-", " ", "+"\nuse constant FLAG    => 3;   # What to display if not OPCODE "!"\n\n\n=head1 OPTIONS\n\ndiff() takes two parameters from which to draw input and a set of\noptions to control it's output.  The options are:\n\n=over\n\n=item FILENAME_A, MTIME_A, FILENAME_B, MTIME_B\n\nThe name of the file and the modification time "files"\n\nThese are filled in automatically for each file when diff() is passed a\nfilename, unless a defined value is passed in.\n\nIf a filename is not passed in and FILENAME_A and FILENAME_B are not provided\nor C<undef>, the header will not be printed.\n\nUnused on C<OldStyle> diffs.\n\n=item OFFSET_A, OFFSET_B\n\nThe index of the first line / element.  These default to 1 for all\nparameter types except ARRAY references, for which the default is 0.  This\nis because ARRAY references are presumed to be data structures, while the\nothers are line oriented text.\n\n=item STYLE\n\n"Unified", "Context", "OldStyle", or an object or class reference for a class\nproviding C<file_header()>, C<hunk_header()>, C<hunk()>, C<hunk_footer()> and\nC<file_footer()> methods.  The two footer() methods are provided for\noverloading only; none of the formats provide them.\n\nDefaults to "Unified" (unlike standard C<diff>, but Unified is what's most\noften used in submitting patches and is the most human readable of the three.\n\nIf the package indicated by the STYLE has no hunk() method, c<diff()> will\nload it automatically (lazy loading).  Since all such packages should inherit\nfrom Text::Diff::Base, this should be marvy.\n\nStyles may be specified as class names (C<STYLE => "Foo"), in which case they\nwill be C<new()>ed with no parameters, or as objects (C<STYLE => Foo->new>).\n\n=item CONTEXT\n\nHow many lines before and after each diff to display.  Ignored on old-style\ndiffs.  Defaults to 3.\n\n=item OUTPUT\n\nExamples and their equivalent subroutines:\n\n    OUTPUT   => \\*FOOHANDLE,   # like: sub { print FOOHANDLE shift() }\n    OUTPUT   => \\\$output,      # like: sub { \$output .= shift }\n    OUTPUT   => \\\@output,      # like: sub { push \@output, shift }\n    OUTPUT   => sub { \$output .= shift },\n\nIf no C<OUTPUT> is supplied, returns the diffs in a string.  If\nC<OUTPUT> is a C<CODE> ref, it will be called once with the (optional)\nfile header, and once for each hunk body with the text to emit.  If\nC<OUTPUT> is an L<IO::Handle>, output will be emitted to that handle.\n\n=item FILENAME_PREFIX_A, FILENAME_PREFIX_B\n\nThe string to print before the filename in the header. Unused on C<OldStyle>\ndiffs.  Defaults are C<"---">, C<"+++"> for Unified and C<"***">, C<"+++"> for\nContext.\n\n=item KEYGEN, KEYGEN_ARGS\n\nThese are passed to L<Algorithm::Diff/traverse_sequences>.\n\n=back\n\nB<Note>: if neither C<FILENAME_> option is defined, the header will not be\nprinted.  If at one is present, the other and both MTIME_ options must be\npresent or "Use of undefined variable" warnings will be generated (except\non C<OldStyle> diffs, which ignores these options).\n\n=cut\n\nmy %internal_styles = (\n    Unified  => undef,\n    Context  => undef,\n    OldStyle => undef,\n    Table    => undef,   ## "internal", but in another module\n);\n\nsub diff {\n    my \@seqs = ( shift, shift );\n    my \$options = shift || {};\n\n    for my \$i ( 0..1 ) {\n        my \$seq = \$seqs[\$i];\n\x09my \$type = ref \$seq;\n\n        while ( \$type eq "CODE" ) {\n\x09    \$seqs[\$i] = \$seq = \$seq->( \$options );\n\x09    \$type = ref \$seq;\n\x09}\n\n\x09my \$AorB = !\$i ? "A" : "B";\n\n        if ( \$type eq "ARRAY" ) {\n            ## This is most efficient :)\n            \$options->{"OFFSET_\$AorB"} = 0\n                unless defined \$options->{"OFFSET_\$AorB"};\n        }\n        elsif ( \$type eq "SCALAR" ) {\n            \$seqs[\$i] = [split( /^/m, \$\$seq )];\n            \$options->{"OFFSET_\$AorB"} = 1\n                unless defined \$options->{"OFFSET_\$AorB"};\n        }\n        elsif ( ! \$type ) {\n            \$options->{"OFFSET_\$AorB"} = 1\n                unless defined \$options->{"OFFSET_\$AorB"};\n\x09    \$options->{"FILENAME_\$AorB"} = \$seq\n\x09        unless defined \$options->{"FILENAME_\$AorB"};\n\x09    \$options->{"MTIME_\$AorB"} = (stat(\$seq))[9]\n\x09        unless defined \$options->{"MTIME_\$AorB"};\n\n            local \$/ = "\\n";\n            open F, "<\$seq" or carp "\$!: \$seq";\n            \$seqs[\$i] = [<F>];\n            close F;\n\n        }\n        elsif ( \$type eq "GLOB" || UNIVERSAL::isa( \$seq, "IO::Handle" ) ) {\n            \$options->{"OFFSET_\$AorB"} = 1\n                unless defined \$options->{"OFFSET_\$AorB"};\n            local \$/ = "\\n";\n            \$seqs[\$i] = [<\$seq>];\n        }\n        else {\n            confess "Can't handle input of type ", ref;\n        }\n    }\n\n    ## Config vars\n    my \$output;\n    my \$output_handler = \$options->{OUTPUT};\n    my \$type = ref \$output_handler ;\n    if ( ! defined \$output_handler ) {\n        \$output_handler = sub { \$output .= shift };\n    }\n    elsif ( \$type eq "CODE" ) {\n        ## No problems, mate.\n    }\n    elsif ( \$type eq "SCALAR" ) {\n        my \$out_ref = \$output_handler;\n        \$output_handler = sub { \$\$out_ref .= shift };\n    }\n    elsif ( \$type eq "ARRAY" ) {\n        my \$out_ref = \$output_handler;\n        \$output_handler = sub { push \@\$out_ref, shift };\n    }\n    elsif ( \$type eq "GLOB" || UNIVERSAL::isa \$output_handler, "IO::Handle" ) {\n        my \$output_handle = \$output_handler;\n        \$output_handler = sub { print \$output_handle shift };\n    }\n    else {\n        croak "Unrecognized output type: \$type";\n    }\n\n    my \$style  = \$options->{STYLE};\n    \$style = "Unified" unless defined \$options->{STYLE};\n    \$style = "Text::Diff::\$style" if exists \$internal_styles{\$style};\n\n    if ( ! \$style->can( "hunk" ) ) {\n\x09eval "require \$style; 1" or die \$\@;\n    }\n\n    \$style = \$style->new\n\x09if ! ref \$style && \$style->can( "new" );\n\n    my \$ctx_lines = \$options->{CONTEXT};\n    \$ctx_lines = 3 unless defined \$ctx_lines;\n    \$ctx_lines = 0 if \$style->isa( "Text::Diff::OldStyle" );\n\n    my \@keygen_args = \$options->{KEYGEN_ARGS}\n        ? \@{\$options->{KEYGEN_ARGS}}\n        : ();\n\n    ## State vars\n    my \$diffs = 0; ## Number of discards this hunk\n    my \$ctx   = 0; ## Number of " " (ctx_lines) ops pushed after last diff.\n    my \@ops;       ## ops (" ", +, -) in this hunk\n    my \$hunks = 0; ## Number of hunks\n\n    my \$emit_ops = sub {\n        \$output_handler->( \$style->file_header( \@seqs,     \$options ) )\n\x09    unless \$hunks++;\n        \$output_handler->( \$style->hunk_header( \@seqs, \@_, \$options ) );\n        \$output_handler->( \$style->hunk       ( \@seqs, \@_, \$options ) );\n        \$output_handler->( \$style->hunk_footer( \@seqs, \@_, \$options ) );\n    };\n\n    ## We keep 2*ctx_lines so that if a diff occurs\n    ## at 2*ctx_lines we continue to grow the hunk instead\n    ## of emitting diffs and context as we go. We\n    ## need to know the total length of both of the two\n    ## subsequences so the line count can be printed in the\n    ## header.\n    my \$dis_a = sub {push \@ops, [\@_[0,1],"-"]; ++\$diffs ; \$ctx = 0 };\n    my \$dis_b = sub {push \@ops, [\@_[0,1],"+"]; ++\$diffs ; \$ctx = 0 };\n\n    traverse_sequences(\n        \@seqs,\n        {\n            MATCH => sub {\n                push \@ops, [\@_[0,1]," "];\n\n                if ( \$diffs && ++\$ctx > \$ctx_lines * 2 ) {\n        \x09   \$emit_ops->( [ splice \@ops, 0, \$#ops - \$ctx_lines ] );\n        \x09   \$ctx = \$diffs = 0;\n                }\n\n                ## throw away context lines that aren't needed any more\n                shift \@ops if ! \$diffs && \@ops > \$ctx_lines;\n            },\n            DISCARD_A => \$dis_a,\n            DISCARD_B => \$dis_b,\n        },\n        \$options->{KEYGEN},  # pass in user arguments for key gen function\n        \@keygen_args,\n    );\n\n    if ( \$diffs ) {\n        \$#ops -= \$ctx - \$ctx_lines if \$ctx > \$ctx_lines;\n        \$emit_ops->( \\\@ops );\n    }\n\n    \$output_handler->( \$style->file_footer( \@seqs, \$options ) ) if \$hunks;\n\n    return defined \$output ? \$output : \$hunks;\n}\n\n\nsub _header {\n    my ( \$h ) = \@_;\n    my ( \$p1, \$fn1, \$t1, \$p2, \$fn2, \$t2 ) = \@{\$h}{\n        "FILENAME_PREFIX_A",\n        "FILENAME_A",\n        "MTIME_A",\n        "FILENAME_PREFIX_B",\n        "FILENAME_B",\n        "MTIME_B"\n    };\n\n    ## remember to change Text::Diff::Table if this logic is tweaked.\n    return "" unless defined \$fn1 && defined \$fn2;\n\n    return join( "",\n        \$p1, " ", \$fn1, defined \$t1 ? "\\t" . localtime \$t1 : (), "\\n",\n        \$p2, " ", \$fn2, defined \$t2 ? "\\t" . localtime \$t2 : (), "\\n",\n    );\n}\n\n## _range encapsulates the building of, well, ranges.  Turns out there are\n## a few nuances.\nsub _range {\n    my ( \$ops, \$a_or_b, \$format ) = \@_;\n\n    my \$start = \$ops->[ 0]->[\$a_or_b];\n    my \$after = \$ops->[-1]->[\$a_or_b];\n\n    ## The sequence indexes in the lines are from *before* the OPCODE is\n    ## executed, so we bump the last index up unless the OP indicates\n    ## it didn't change.\n    ++\$after\n        unless \$ops->[-1]->[OPCODE] eq ( \$a_or_b == A ? "+" : "-" );\n\n    ## convert from 0..n index to 1..(n+1) line number.  The unless modifier\n    ## handles diffs with no context, where only one file is affected.  In this\n    ## case \$start == \$after indicates an empty range, and the \$start must\n    ## not be incremented.\n    my \$empty_range = \$start == \$after;\n    ++\$start unless \$empty_range;\n\n    return\n        \$start == \$after\n            ? \$format eq "unified" && \$empty_range\n                ? "\$start,0"\n                : \$start\n            : \$format eq "unified"\n                ? "\$start,".(\$after-\$start+1)\n                : "\$start,\$after";\n}\n\n\nsub _op_to_line {\n    my ( \$seqs, \$op, \$a_or_b, \$op_prefixes ) = \@_;\n\n    my \$opcode = \$op->[OPCODE];\n    return () unless defined \$op_prefixes->{\$opcode};\n\n    my \$op_sym = defined \$op->[FLAG] ? \$op->[FLAG] : \$opcode;\n    \$op_sym = \$op_prefixes->{\$op_sym};\n    return () unless defined \$op_sym;\n\n    \$a_or_b = \$op->[OPCODE] ne "+" ? 0 : 1 unless defined \$a_or_b;\n    return ( \$op_sym, \$seqs->[\$a_or_b][\$op->[\$a_or_b]] );\n}\n\n\n=head1 Formatting Classes\n\nThese functions implement the output formats.  They are grouped in to classes\nso diff() can use class names to call the correct set of output routines and so\nthat you may inherit from them easily.  There are no constructors or instance\nmethods for these classes, though subclasses may provide them if need be.\n\nEach class has file_header(), hunk_header(), hunk(), and footer() methods\nidentical to those documented in the Text::Diff::Unified section.  header() is\ncalled before the hunk() is first called, footer() afterwards.  The default\nfooter function is an empty method provided for overloading:\n\n    sub footer { return "End of patch\\n" }\n\nSome output formats are provided by external modules (which are loaded\nautomatically), such as L<Text::Diff::Table>.  These are\nare documented here to keep the documentation simple.\n\n=over\n\n=head2 Text::Diff::Base\n\nReturns "" for all methods (other than C<new()>).\n\n=cut\n\n{\n    package Text::Diff::Base;\n    sub new         {\n        my \$proto = shift;\n\x09return bless { \@_ }, ref \$proto || \$proto;\n    }\n\n    sub file_header { return "" }\n    sub hunk_header { return "" }\n    sub hunk        { return "" }\n    sub hunk_footer { return "" }\n    sub file_footer { return "" }\n}\n\n\n=head2 Text::Diff::Unified\n\n    --- A   Mon Nov 12 23:49:30 2001\n    +++ B   Mon Nov 12 23:49:30 2001\n    \@\@ -2,13 +2,13 \@\@\n     2\n     3\n     4\n    -5d\n    +5a\n     6\n     7\n     8\n     9\n    +9a\n     10\n     11\n    -11d\n     12\n     13\n\n=over\n\n=item file_header\n\n    \$s = Text::Diff::Unified->file_header( \$options );\n\nReturns a string containing a unified header.  The sole parameter is the\noptions hash passed in to diff(), containing at least:\n\n    FILENAME_A  => \$fn1,\n    MTIME_A     => \$mtime1,\n    FILENAME_B  => \$fn2,\n    MTIME_B     => \$mtime2\n\nMay also contain\n\n    FILENAME_PREFIX_A    => "---",\n    FILENAME_PREFIX_B    => "+++",\n\nto override the default prefixes (default values shown).\n\n=cut\n\n\@Text::Diff::Unified::ISA = qw( Text::Diff::Base );\n\nsub Text::Diff::Unified::file_header {\n    shift; ## No instance data\n    my \$options = pop ;\n\n    _header(\n        { FILENAME_PREFIX_A => "---", FILENAME_PREFIX_B => "+++", %\$options }\n    );\n}\n\n=item hunk_header\n\n    Text::Diff::Unified->hunk_header( \\\@ops, \$options );\n\nReturns a string containing the output of one hunk of unified diff.\n\n=cut\n\nsub Text::Diff::Unified::hunk_header {\n    shift; ## No instance data\n    pop; ## Ignore options\n    my \$ops = pop;\n\n    return join( "",\n        "\@\@ -",\n        _range( \$ops, A, "unified" ),\n        " +",\n        _range( \$ops, B, "unified" ),\n        " \@\@\\n",\n    );\n}\n\n\n=item Text::Diff::Unified::hunk\n\n    Text::Diff::Unified->hunk( \\\@seq_a, \\\@seq_b, \\\@ops, \$options );\n\nReturns a string containing the output of one hunk of unified diff.\n\n=cut\n\nsub Text::Diff::Unified::hunk {\n    shift; ## No instance data\n    pop; ## Ignore options\n    my \$ops = pop;\n\n    my \$prefixes = { "+" => "+", " " => " ", "-" => "-" };\n\n    return join "", map _op_to_line( \\\@_, \$_, undef, \$prefixes ), \@\$ops\n}\n\n\n=back\n\n=head2 Text::Diff::Table\n\n +--+----------------------------------+--+------------------------------+\n |  |../Test-Differences-0.2/MANIFEST  |  |../Test-Differences/MANIFEST  |\n |  |Thu Dec 13 15:38:49 2001          |  |Sat Dec 15 02:09:44 2001      |\n +--+----------------------------------+--+------------------------------+\n |  |                                  * 1|Changes                       *\n | 1|Differences.pm                    | 2|Differences.pm                |\n | 2|MANIFEST                          | 3|MANIFEST                      |\n |  |                                  * 4|MANIFEST.SKIP                 *\n | 3|Makefile.PL                       | 5|Makefile.PL                   |\n |  |                                  * 6|t/00escape.t                  *\n | 4|t/00flatten.t                     | 7|t/00flatten.t                 |\n | 5|t/01text_vs_data.t                | 8|t/01text_vs_data.t            |\n | 6|t/10test.t                        | 9|t/10test.t                    |\n +--+----------------------------------+--+------------------------------+\n\nThis format also goes to some pains to highlight "invisible" characters on\ndiffering elements by selectively escaping whitespace:\n\n +--+--------------------------+--------------------------+\n |  |demo_ws_A.txt             |demo_ws_B.txt             |\n |  |Fri Dec 21 08:36:32 2001  |Fri Dec 21 08:36:50 2001  |\n +--+--------------------------+--------------------------+\n | 1|identical                 |identical                 |\n * 2|        spaced in         |        also spaced in    *\n * 3|embedded space            |embedded        tab       *\n | 4|identical                 |identical                 |\n * 5|        spaced in         |\\ttabbed in               *\n * 6|trailing spaces\\s\\s\\n     |trailing tabs\\t\\t\\n       *\n | 7|identical                 |identical                 |\n * 8|lf line\\n                 |crlf line\\r\\n             *\n * 9|embedded ws               |embedded\\tws              *\n +--+--------------------------+--------------------------+\n\nSee L</Text::Diff::Table> for more details, including how the whitespace\nescaping works.\n\n=head2 Text::Diff::Context\n\n    *** A   Mon Nov 12 23:49:30 2001\n    --- B   Mon Nov 12 23:49:30 2001\n    ***************\n    *** 2,14 ****\n      2\n      3\n      4\n    ! 5d\n      6\n      7\n      8\n      9\n      10\n      11\n    - 11d\n      12\n      13\n    --- 2,14 ----\n      2\n      3\n      4\n    ! 5a\n      6\n      7\n      8\n      9\n    + 9a\n      10\n      11\n      12\n      13\n\nNote: hunk_header() returns only "***************\\n".\n\n=cut\n\n\n\@Text::Diff::Context::ISA = qw( Text::Diff::Base );\n\nsub Text::Diff::Context::file_header {\n    _header { FILENAME_PREFIX_A=>"***", FILENAME_PREFIX_B=>"---", %{\$_[-1]} };\n}\n\n\nsub Text::Diff::Context::hunk_header {\n    return "***************\\n";\n}\n\nsub Text::Diff::Context::hunk {\n    shift; ## No instance data\n    pop; ## Ignore options\n    my \$ops = pop;\n    ## Leave the sequences in \@_[0,1]\n\n    my \$a_range = _range( \$ops, A, "" );\n    my \$b_range = _range( \$ops, B, "" );\n\n    ## Sigh.  Gotta make sure that differences that aren't adds/deletions\n    ## get prefixed with "!", and that the old opcodes are removed.\n    my \$after;\n    for ( my \$start = 0; \$start <= \$#\$ops ; \$start = \$after ) {\n        ## Scan until next difference\n        \$after = \$start + 1;\n        my \$opcode = \$ops->[\$start]->[OPCODE];\n        next if \$opcode eq " ";\n\n        my \$bang_it;\n        while ( \$after <= \$#\$ops && \$ops->[\$after]->[OPCODE] ne " " ) {\n            \$bang_it ||= \$ops->[\$after]->[OPCODE] ne \$opcode;\n            ++\$after;\n        }\n\n        if ( \$bang_it ) {\n            for my \$i ( \$start..(\$after-1) ) {\n                \$ops->[\$i]->[FLAG] = "!";\n            }\n        }\n    }\n\n    my \$b_prefixes = { "+" => "+ ",  " " => "  ", "-" => undef, "!" => "! " };\n    my \$a_prefixes = { "+" => undef, " " => "  ", "-" => "- ",  "!" => "! " };\n\n    return join( "",\n        "*** ", \$a_range, " ****\\n",\n        map( _op_to_line( \\\@_, \$_, A, \$a_prefixes ), \@\$ops ),\n        "--- ", \$b_range, " ----\\n",\n        map( _op_to_line( \\\@_, \$_, B, \$b_prefixes ), \@\$ops ),\n    );\n}\n=head2 Text::Diff::OldStyle\n\n    5c5\n    < 5d\n    ---\n    > 5a\n    9a10\n    > 9a\n    12d12\n    < 11d\n\nNote: no file_header().\n\n=cut\n\n\@Text::Diff::OldStyle::ISA = qw( Text::Diff::Base );\n\nsub _op {\n    my \$ops = shift;\n    my \$op = \$ops->[0]->[OPCODE];\n    \$op = "c" if grep \$_->[OPCODE] ne \$op, \@\$ops;\n    \$op = "a" if \$op eq "+";\n    \$op = "d" if \$op eq "-";\n    return \$op;\n}\n\nsub Text::Diff::OldStyle::hunk_header {\n    shift; ## No instance data\n    pop; ## ignore options\n    my \$ops = pop;\n\n    my \$op = _op \$ops;\n\n    return join "", _range( \$ops, A, "" ), \$op, _range( \$ops, B, "" ), "\\n";\n}\n\nsub Text::Diff::OldStyle::hunk {\n    shift; ## No instance data\n    pop; ## ignore options\n    my \$ops = pop;\n    ## Leave the sequences in \@_[0,1]\n\n    my \$a_prefixes = { "+" => undef,  " " => undef, "-" => "< "  };\n    my \$b_prefixes = { "+" => "> ",   " " => undef, "-" => undef };\n\n    my \$op = _op \$ops;\n\n    return join( "",\n        map( _op_to_line( \\\@_, \$_, A, \$a_prefixes ), \@\$ops ),\n        \$op eq "c" ? "---\\n" : (),\n        map( _op_to_line( \\\@_, \$_, B, \$b_prefixes ), \@\$ops ),\n    );\n}\n\n=head1 LIMITATIONS\n\nMust suck both input files entirely in to memory and store them with a normal\namount of Perlish overhead (one array location) per record.  This is implied by\nthe implementation of Algorithm::Diff, which takes two arrays.  If\nAlgorithm::Diff ever offers an incremental mode, this can be changed (contact\nthe maintainers of Algorithm::Diff and Text::Diff if you need this; it\nshouldn't be too terribly hard to tie arrays in this fashion).\n\nDoes not provide most of the more refined GNU diff options: recursive directory\ntree scanning, ignoring blank lines / whitespace, etc., etc.  These can all be\nadded as time permits and need arises, many are rather easy; patches quite\nwelcome.\n\nUses closures internally, this may lead to leaks on C<perl> versions 5.6.1 and\nprior if used many times over a process' life time.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>.\n\n=head1 COPYRIGHT & LICENSE\n\nCopyright 2001, Barrie Slaymaker.  All Rights Reserved.\n\nYou may use this under the terms of either the Artistic License or GNU Public\nLicense v 2.0 or greater.\n\n=cut\n\n1;\n
END_OF_FILE_AAAAAAAAAADD
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADE, "lib/Text/Diff/Table.pm" }
package Text::Diff::Table;\n\n=head1 NAME\n\n    Text::Diff::Table - Text::Diff plugin to generate "table" format output\n\n=head1 SYNOPSIS\n\n    use Text::Diff;\n\n    diff \\\@a, \$b { STYLE => "Table" };\n\n=head1 DESCRIPTION\n\nThis is a plugin output formatter for Text::Diff that generates "table" style\ndiffs:\n\n +--+----------------------------------+--+------------------------------+\n |  |../Test-Differences-0.2/MANIFEST  |  |../Test-Differences/MANIFEST  |\n |  |Thu Dec 13 15:38:49 2001          |  |Sat Dec 15 02:09:44 2001      |\n +--+----------------------------------+--+------------------------------+\n |  |                                  * 1|Changes                       *\n | 1|Differences.pm                    | 2|Differences.pm                |\n | 2|MANIFEST                          | 3|MANIFEST                      |\n |  |                                  * 4|MANIFEST.SKIP                 *\n | 3|Makefile.PL                       | 5|Makefile.PL                   |\n |  |                                  * 6|t/00escape.t                  *\n | 4|t/00flatten.t                     | 7|t/00flatten.t                 |\n | 5|t/01text_vs_data.t                | 8|t/01text_vs_data.t            |\n | 6|t/10test.t                        | 9|t/10test.t                    |\n +--+----------------------------------+--+------------------------------+\n\nThis format also goes to some pains to highlight "invisible" characters on\ndiffering elements by selectively escaping whitespace.  Each element is split\nin to three segments (leading whitespace, body, trailing whitespace).  If\nwhitespace differs in a segement, that segment is whitespace escaped.\n\nHere is an example of the selective whitespace.\n\n +--+--------------------------+--------------------------+\n |  |demo_ws_A.txt             |demo_ws_B.txt             |\n |  |Fri Dec 21 08:36:32 2001  |Fri Dec 21 08:36:50 2001  |\n +--+--------------------------+--------------------------+\n | 1|identical                 |identical                 |\n * 2|        spaced in         |        also spaced in    *\n * 3|embedded space            |embedded        tab       *\n | 4|identical                 |identical                 |\n * 5|        spaced in         |\\ttabbed in               *\n * 6|trailing spaces\\s\\s\\n     |trailing tabs\\t\\t\\n       *\n | 7|identical                 |identical                 |\n * 8|lf line\\n                 |crlf line\\r\\n             *\n * 9|embedded ws               |embedded\\tws              *\n +--+--------------------------+--------------------------+\n\nHere's why the lines do or do not have whitespace escaped:\n\n=over\n\n=item lines 1, 4, 7 don't differ, no need.\n\n=item lines 2, 3 differ in non-whitespace, no need.\n\n=item lines 5, 6, 8, 9 all have subtle ws changes.\n\n=back\n\nWhether or not line 3 should have that tab character escaped is a judgement\ncall; so far I'm choosing not to.\n\n=cut\n\n\@ISA = qw( Text::Diff::Base Exporter );\n\@EXPORT_OK = qw( expand_tabs );\n\$VERSION = 1.0;\n\nuse strict;\nuse Carp;\n\n\nmy %escapes = map {\n    my \$c =\n        \$_ eq '"' || \$_ eq '\$' ? qq{'\$_'}\n\x09: \$_ eq "\\\\"           ? qq{"\\\\\\\\"}\n\x09                       : qq{"\$_"} ;\n    ( ord eval \$c => \$_ )\n} (\n    map( chr, 32..126),\n    map( sprintf( "\\\\x%02x", \$_ ), ( 0..31, 127..255 ) ),\n#    map( "\\\\c\$_", "A".."Z"),\n    "\\\\t", "\\\\n", "\\\\r", "\\\\f", "\\\\b", "\\\\a", "\\\\e"\n) ;\n\n\nsub expand_tabs(\$) {\n    my \$s = shift ;\n    my \$count=0;\n    \$s =~ s{(\\t)(\\t*)|([^\\t]+)}{\n         if ( \$1 ) {\n             my \$spaces = " " x ( 8 - \$count % 8  + 8 * length \$2 );\n             \$count = 0;\n             \$spaces;\n\x09 }\n\x09 else {\n\x09     \$count += length \$3;\n\x09     \$3;\n\x09}\n    }ge;\n\n    return \$s;\n}\n\n\nsub escape_ws(\$) {\n    my \$s = shift;\n    \$s =~ s/ /\\\\s/g;\n    \$s =~ s/\\t/\\\\t/g;\n    return \$s;\n}\n\n\nsub trim_trailing_line_ends(\$) {\n    my \$s = shift;\n    \$s =~ s/[\\r\\n]+(?!\\n)\$//;\n    return \$s;\n}\n\nsub escape(\$);\n\n{\n   ## use utf8 if available.  don't if not.\n   my \$escaper = <<'EOCODE' ;\n      sub escape(\$) {\n\x09  use utf8;\n\x09  join "", map {\n\x09      \$_ = ord;\n\x09      exists \$escapes{\$_}\n\x09\x09  ? \$escapes{\$_}\n\x09\x09  : sprintf( "\\\\x{%04x}", \$_ ) ;\n\x09  } split //, shift ;\n      }\n\n      1;\nEOCODE\n   unless ( eval \$escaper ) {\n       \$escaper =~ s/ *use *utf8 *;\\n// or die "Can't drop use utf8;";\n       eval \$escaper or die \$\@;\n   }\n}\n\n\nsub new {\n    my \$proto = shift;\n    return bless { \@_ }, \$proto\n}\n\nmy \$missing_elt = [ "", "" ];\n\nsub hunk {\n    my \$self = shift;\n    my \@seqs = ( shift, shift );\n    my \$ops = shift;  ## Leave sequences in \@_[0,1]\n    my \$options = shift;\n\n    my ( \@A, \@B );\n    for ( \@\$ops ) {\n        my \$opcode = \$_->[Text::Diff::OPCODE()];\n        if ( \$opcode eq " " ) {\n            push \@A, \$missing_elt while \@A < \@B;\n            push \@B, \$missing_elt while \@B < \@A;\n        }\n        push \@A, [ \$_->[0] + ( \$options->{OFFSET_A} || 0), \$seqs[0][\$_->[0]] ]\n            if \$opcode eq " " || \$opcode eq "-";\n        push \@B, [ \$_->[1] + ( \$options->{OFFSET_B} || 0), \$seqs[1][\$_->[1]] ]\n            if \$opcode eq " " || \$opcode eq "+";\n    }\n\n    push \@A, \$missing_elt while \@A < \@B;\n    push \@B, \$missing_elt while \@B < \@A;\n    my \@elts;\n    for ( 0..\$#A ) {\n        my ( \$A, \$B ) = (shift \@A, shift \@B );\n        \n        ## Do minimal cleaning on identical elts so these look "normal":\n        ## tabs are expanded, trailing newelts removed, etc.  For differing\n        ## elts, make invisible characters visible if the invisible characters\n        ## differ.\n        my \$elt_type = \$B == \$missing_elt ? "A" :\n                        \$A == \$missing_elt ? "B" :\n                        \$A->[1] eq \$B->[1]  ? "="\n                                            : "*";\n\n        if ( \$elt_type ne "*" ) {\n            \$A->[1] = escape trim_trailing_line_ends expand_tabs \$A->[1];\n            \$B->[1] = escape trim_trailing_line_ends expand_tabs \$B->[1];\n        }\n        else {\n            ## not using \\z here for backcompat reasons.\n            \$A->[1] =~ /^(\\s*?)([^ \\t].*?)?(\\s*)(?![\\n\\r])\$/s;\n            my ( \$l_ws_A, \$body_A, \$t_ws_A ) = ( \$1, \$2, \$3 );\n\x09    \$body_A = "" unless defined \$body_A;\n            \$B->[1] =~ /^(\\s*?)([^ \\t].*?)?(\\s*)(?![\\n\\r])\$/s;\n            my ( \$l_ws_B, \$body_B, \$t_ws_B ) = ( \$1, \$2, \$3 );\n\x09    \$body_B = "" unless defined \$body_B;\n\n            if ( \$t_ws_A ne \$t_ws_B ) {\n                \$t_ws_A = escape_ws \$t_ws_A;\n                \$t_ws_B = escape_ws \$t_ws_B;\n            }\n            else {\n                \$t_ws_A = \$t_ws_B = "";\n            }\n\n            ## Only space-escape these if otherwise identical\n            ( my \$squeezed_A = \$body_A ) =~ s/\\s+/-/g;\n            ( my \$squeezed_B = \$body_B ) =~ s/\\s+/-/g;\n\n            if ( \$squeezed_A eq \$squeezed_B ) {\n                \$body_A =~ s/\\t/\\\\t/g;\n                \$body_B =~ s/\\t/\\\\t/g;\n            }\n\n            if ( \$l_ws_A ne \$l_ws_B ) {\n                \$l_ws_A =~ s/\\t/\\\\t/g;\n                \$l_ws_B =~ s/\\t/\\\\t/g;\n            }\n\n            \$A->[1] = escape expand_tabs join "", \$l_ws_A, \$body_A, \$t_ws_A;\n            \$B->[1] = escape expand_tabs join "", \$l_ws_B, \$body_B, \$t_ws_B;\n        }\n\n        push \@elts, [ \@\$A, \@\$B, \$elt_type ];\n    }\n\n\n    push \@{\$self->{ELTS}}, \@elts, ["bar"];\n    return "";\n}\n\n\nsub _glean_formats {\n    my \$self = shift ;\n}\n\n\nsub file_footer {\n    my \$self = shift;\n    my \@seqs = (shift,shift);\n    my \$options = pop;\n\n    my \@heading_lines ;\n    \n    if ( defined \$options->{FILENAME_A} || defined \$options->{FILENAME_B} ) {\n        push \@heading_lines, [ \n            map(\n                {\n                    ( "", escape( defined \$_ ? \$_ : "<undef>" ) );\n                }\n                ( \@{\$options}{qw( FILENAME_A FILENAME_B)} )\n            ),\n            "=",\n        ];\n    }\n\n    if ( defined \$options->{MTIME_A} || defined \$options->{MTIME_B} ) {\n        push \@heading_lines, [\n            map( {\n                    ( "",\n                        escape(\n                            ( defined \$_ && length \$_ )\n                                ? localtime \$_\n                                : ""\n                        )\n                    );\n                }\n                \@{\$options}{qw( MTIME_A MTIME_B )}\n            ),\n            "=",\n        ];\n    }\n\n    if ( defined \$options->{INDEX_LABEL} ) {\n        push \@heading_lines, [ "", "", "", "", "=" ] unless \@heading_lines;\n        \$heading_lines[-1]->[0] = \$heading_lines[-1]->[2] =\n            \$options->{INDEX_LABEL};\n    }\n\n    ## Not ushifting on to \@{\$self->{ELTS}} in case it's really big.  Want\n    ## to avoid the overhead.\n\n    my \$four_column_mode = 0;\n    for my \$cols ( \@heading_lines, \@{\$self->{ELTS}} ) {\n        next if \$cols->[-1] eq "bar";\n        if ( \$cols->[0] ne \$cols->[2] ) {\n            \$four_column_mode = 1;\n            last;\n        }\n    }\n\n    unless ( \$four_column_mode ) {\n        for my \$cols ( \@heading_lines, \@{\$self->{ELTS}} ) {\n            next if \$cols->[-1] eq "bar";\n            splice \@\$cols, 2, 1;\n        }\n    }\n\n    my \@w = (0,0,0,0);\n    for my \$cols ( \@heading_lines, \@{\$self->{ELTS}} ) {\n        next if \$cols->[-1] eq "bar";\n        for my \$i (0..(\$#\$cols-1)) {\n            \$w[\$i] = length \$cols->[\$i]\n                if defined \$cols->[\$i] && length \$cols->[\$i] > \$w[\$i];\n        }\n    }\n\n    my %fmts = \$four_column_mode\n        ? (\n            "=" => "| %\$w[0]s|%-\$w[1]s  | %\$w[2]s|%-\$w[3]s  |\\n",\n            "A" => "* %\$w[0]s|%-\$w[1]s  * %\$w[2]s|%-\$w[3]s  |\\n",\n            "B" => "| %\$w[0]s|%-\$w[1]s  * %\$w[2]s|%-\$w[3]s  *\\n",\n            "*" => "* %\$w[0]s|%-\$w[1]s  * %\$w[2]s|%-\$w[3]s  *\\n",\n        )\n        : (\n            "=" => "| %\$w[0]s|%-\$w[1]s  |%-\$w[2]s  |\\n",\n            "A" => "* %\$w[0]s|%-\$w[1]s  |%-\$w[2]s  |\\n",\n            "B" => "| %\$w[0]s|%-\$w[1]s  |%-\$w[2]s  *\\n",\n            "*" => "* %\$w[0]s|%-\$w[1]s  |%-\$w[2]s  *\\n",\n        );\n\n    \$fmts{bar} = sprintf \$fmts{"="}, "", "", "", "" ;\n    \$fmts{bar} =~ s/\\S/+/g;\n    \$fmts{bar} =~ s/ /-/g;\n    return join( "",\n        map {\n            sprintf( \$fmts{\$_->[-1]}, \@\$_ )\n        } (\n        ["bar"],\n        \@heading_lines,\n        \@heading_lines ? ["bar"] : (),\n        \@{\$self->{ELTS}},\n        ),\n    );\n\n    \@{\$self->{ELTS}} = [];\n}\n\n\n=head1 LIMITATIONS\n\nTable formatting requires buffering the entire diff in memory in order to\ncalculate column widths.  This format should only be used for smaller\ndiffs.\n\nAssumes tab stops every 8 characters, as \$DIETY intended.\n\nAssumes all character codes >= 127 need to be escaped as hex codes, ie that the\nuser's terminal is ASCII, and not even "high bit ASCII", capable.  This can be\nmade an option when the need arises.\n\nAssumes that control codes (character codes 0..31) that don't have slash-letter\nescapes ("\\n", "\\r", etc) in Perl are best presented as hex escapes ("\\x01")\ninstead of octal ("\\001") or control-code ("\\cA") escapes.\n\n=head1 AUTHOR\n\n    Barrie Slaymaker <barries\@slaysys.com>\n\n=head1 LICENSE\n\nCopyright 2001 Barrie Slaymaker, All Rights Reserved.\n\nYou may use this software under the terms of the GNU public license, any\nversion, or the Artistic license.\n\n=cut\n\n1;\n
END_OF_FILE_AAAAAAAAAADE
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADF, "lib/Algorithm/DiffOld.pm" }
# This is a version of Algorithm::Diff that uses only a comparison function,\n# like versions <= 0.59 used to.\n# \$Revision: 1.3 \$\n\npackage Algorithm::DiffOld;\nuse strict;\nuse vars qw(\$VERSION \@EXPORT_OK \@ISA \@EXPORT);\nuse integer;\x09\x09# see below in _replaceNextLargerWith() for mod to make\n\x09\x09\x09\x09\x09# if you don't use this\nrequire Exporter;\n\@ISA = qw(Exporter);\n\@EXPORT = qw();\n\@EXPORT_OK = qw(LCS diff traverse_sequences);\n\$VERSION = 1.10;\x09# manually tracking Algorithm::Diff\n\n# McIlroy-Hunt diff algorithm\n# Adapted from the Smalltalk code of Mario I. Wolczko, <mario\@wolczko.com>\n# by Ned Konz, perl\@bike-nomad.com\n\n=head1 NAME\n\nAlgorithm::DiffOld - Compute `intelligent' differences between two files / lists\nbut use the old (<=0.59) interface.\n\n=head1 NOTE\n\nThis has been provided as part of the Algorithm::Diff package by Ned Konz.\nThis particular module is B<ONLY> for people who B<HAVE> to have the old\ninterface, which uses a comparison function rather than a key generating\nfunction.\n\nBecause each of the lines in one array have to be compared with each \nof the lines in the other array, this does M*N comparisions. This can\nbe very slow. I clocked it at taking 18 times as long as the stock\nversion of Algorithm::Diff for a 4000-line file. It will get worse\nquadratically as array sizes increase.\n\n=head1 SYNOPSIS\n\n  use Algorithm::DiffOld qw(diff LCS traverse_sequences);\n\n  \@lcs    = LCS( \\\@seq1, \\\@seq2, \$comparison_function );\n\n  \$lcsref = LCS( \\\@seq1, \\\@seq2, \$comparison_function );\n\n  \@diffs = diff( \\\@seq1, \\\@seq2, \$comparison_function );\n  \n  traverse_sequences( \\\@seq1, \\\@seq2,\n                     { MATCH => \$callback,\n                       DISCARD_A => \$callback,\n                       DISCARD_B => \$callback,\n                     },\n                     \$comparison_function );\n\n=head1 COMPARISON FUNCTIONS\n\nEach of the main routines should be passed a comparison function. If you\naren't passing one in, B<use Algorithm::Diff instead>.\n\nThese functions should return a true value when two items should compare\nas equal.\n\nFor instance,\n\n  \@lcs    = LCS( \\\@seq1, \\\@seq2, sub { my (\$a, \$b) = \@_; \$a eq \$b } );\n\nbut if that is all you're doing with your comparison function, just use\nAlgorithm::Diff and let it do this (this is its default).\n\nOr:\n\n  sub someFunkyComparisonFunction\n  {\n  \x09my (\$a, \$b) = \@_;\n\x09\$a =~ m{\$b};\n  }\n\n  \@diffs = diff( \\\@lines, \\\@patterns, \\&someFunkyComparisonFunction );\n\nwhich would allow you to diff an array \@lines which consists of text\nlines with an array \@patterns which consists of regular expressions.\n\nThis is actually the reason I wrote this version -- there is no way\nto do this with a key generation function as in the stock Algorithm::Diff.\n\n=cut\n\n# Find the place at which aValue would normally be inserted into the array. If\n# that place is already occupied by aValue, do nothing, and return undef. If\n# the place does not exist (i.e., it is off the end of the array), add it to\n# the end, otherwise replace the element at that point with aValue.\n# It is assumed that the array's values are numeric.\n# This is where the bulk (75%) of the time is spent in this module, so try to\n# make it fast!\n\nsub _replaceNextLargerWith\n{\n\x09my ( \$array, \$aValue, \$high ) = \@_;\n\x09\$high ||= \$#\$array;\n\n\x09# off the end?\n\x09if ( \$high == -1  || \$aValue > \$array->[ -1 ] )\n\x09{\n\x09\x09push( \@\$array, \$aValue );\n\x09\x09return \$high + 1;\n\x09}\n\n\x09# binary search for insertion point...\n\x09my \$low = 0;\n\x09my \$index;\n\x09my \$found;\n\x09while ( \$low <= \$high )\n\x09{\n\x09\x09\$index = ( \$high + \$low ) / 2;\n#\x09\x09\$index = int(( \$high + \$low ) / 2);\x09\x09# without 'use integer'\n\x09\x09\$found = \$array->[ \$index ];\n\n\x09\x09if ( \$aValue == \$found )\n\x09\x09{\n\x09\x09\x09return undef;\n\x09\x09}\n\x09\x09elsif ( \$aValue > \$found )\n\x09\x09{\n\x09\x09\x09\$low = \$index + 1;\n\x09\x09}\n\x09\x09else\n\x09\x09{\n\x09\x09\x09\$high = \$index - 1;\n\x09\x09}\n\x09}\n\n\x09# now insertion point is in \$low.\n\x09\$array->[ \$low ] = \$aValue;\x09\x09# overwrite next larger\n\x09return \$low;\n}\n\n# This method computes the longest common subsequence in \$a and \$b.\n\n# Result is array or ref, whose contents is such that\n# \x09\$a->[ \$i ] == \$b->[ \$result[ \$i ] ]\n# foreach \$i in ( 0 .. \$#result ) if \$result[ \$i ] is defined.\n\n# An additional argument may be passed; this is a CODE ref to a comparison\n# routine. By default, comparisons will use "eq" .\n# Note that this routine will be called as many as M*N times, so make it fast!\n\n# Additional parameters, if any, will be passed to the key generation routine.\n\nsub _longestCommonSubsequence\n{\n\x09my \$a = shift;\x09# array ref\n\x09my \$b = shift;\x09# array ref\n\x09my \$compare = shift || sub { my \$a = shift; my \$b = shift; \$a eq \$b };\n\n\x09my \$aStart = 0;\n\x09my \$aFinish = \$#\$a;\n\x09my \$bStart = 0;\n\x09my \$bFinish = \$#\$b;\n\x09my \$matchVector = [];\n\n\x09# First we prune off any common elements at the beginning\n\x09while ( \$aStart <= \$aFinish\n\x09\x09and \$bStart <= \$bFinish\n\x09\x09and &\$compare( \$a->[ \$aStart ], \$b->[ \$bStart ], \@_ ) )\n\x09{\n\x09\x09\$matchVector->[ \$aStart++ ] = \$bStart++;\n\x09}\n\n\x09# now the end\n\x09while ( \$aStart <= \$aFinish\n\x09\x09and \$bStart <= \$bFinish\n\x09\x09and &\$compare( \$a->[ \$aFinish ], \$b->[ \$bFinish ], \@_ ) )\n\x09{\n\x09\x09\$matchVector->[ \$aFinish-- ] = \$bFinish--;\n\x09}\n\n\x09my \$thresh = [];\n\x09my \$links = [];\n\n\x09my ( \$i, \$ai, \$j, \$k );\n\x09for ( \$i = \$aStart; \$i <= \$aFinish; \$i++ )\n\x09{\n\x09\x09\$k = 0;\n\x09\x09# look for each element of \@b between \$bStart and \$bFinish\n\x09\x09# that matches \$a->[ \$i ], in reverse order\n\x09\x09for (\$j = \$bFinish; \$j >= \$bStart; \$j--)\n\x09\x09{\n\x09\x09\x09next if ! &\$compare( \$a->[\$i], \$b->[\$j] );\n\x09\x09\x09# optimization: most of the time this will be true\n\x09\x09\x09if ( \$k\n\x09\x09\x09\x09and \$thresh->[ \$k ] > \$j\n\x09\x09\x09\x09and \$thresh->[ \$k - 1 ] < \$j )\n\x09\x09\x09{\n\x09\x09\x09\x09\$thresh->[ \$k ] = \$j;\n\x09\x09\x09}\n\x09\x09\x09else\n\x09\x09\x09{\n\x09\x09\x09\x09\$k = _replaceNextLargerWith( \$thresh, \$j, \$k );\n\x09\x09\x09}\n\n\x09\x09\x09# oddly, it's faster to always test this (CPU cache?).\n\x09\x09\x09if ( defined( \$k ) )\n\x09\x09\x09{\n\x09\x09\x09\x09\$links->[ \$k ] = \n\x09\x09\x09\x09\x09[ ( \$k ? \$links->[ \$k - 1 ] : undef ), \$i, \$j ];\n\x09\x09\x09}\n\x09\x09}\n\x09}\n\n\x09if ( \@\$thresh )\n\x09{\n\x09\x09for ( my \$link = \$links->[ \$#\$thresh ]; \$link; \$link = \$link->[ 0 ] )\n\x09\x09{\n\x09\x09\x09\$matchVector->[ \$link->[ 1 ] ] = \$link->[ 2 ];\n\x09\x09}\n\x09}\n\n\x09return wantarray ? \@\$matchVector : \$matchVector;\n}\n\nsub traverse_sequences\n{\n\x09my \$a = shift;\x09# array ref\n\x09my \$b = shift;\x09# array ref\n\x09my \$callbacks = shift || { };\n\x09my \$compare = shift;\n\x09my \$matchCallback = \$callbacks->{'MATCH'} || sub { };\n\x09my \$discardACallback = \$callbacks->{'DISCARD_A'} || sub { };\n\x09my \$finishedACallback = \$callbacks->{'A_FINISHED'};\n\x09my \$discardBCallback = \$callbacks->{'DISCARD_B'} || sub { };\n\x09my \$finishedBCallback = \$callbacks->{'B_FINISHED'};\n\x09my \$matchVector = _longestCommonSubsequence( \$a, \$b, \$compare, \@_ );\n\x09# Process all the lines in match vector\n\x09my \$lastA = \$#\$a;\n\x09my \$lastB = \$#\$b;\n\x09my \$bi = 0;\n\x09my \$ai;\n\x09for ( \$ai = 0; \$ai <= \$#\$matchVector; \$ai++ )\n\x09{\n\x09\x09my \$bLine = \$matchVector->[ \$ai ];\n\x09\x09if ( defined( \$bLine ) )\x09# matched\n\x09\x09{\n\x09\x09\x09&\$discardBCallback( \$ai, \$bi++, \@_ ) while \$bi < \$bLine;\n\x09\x09\x09&\$matchCallback( \$ai, \$bi++, \@_ );\n\x09\x09}\n\x09\x09else\n\x09\x09{\n\x09\x09\x09&\$discardACallback( \$ai, \$bi, \@_ );\n\x09\x09}\n\x09}\n\x09# the last entry (if any) processed was a match.\n\n\x09if ( defined( \$finishedBCallback ) && \$ai <= \$lastA )\n\x09{\n\x09\x09&\$finishedBCallback( \$bi, \@_ );\n\x09}\n\x09else\n\x09{\n\x09\x09&\$discardACallback( \$ai++, \$bi, \@_ ) while ( \$ai <= \$lastA );\n\x09}\n\n\x09if ( defined( \$finishedACallback ) && \$bi <= \$lastB )\n\x09{\n\x09\x09&\$finishedACallback( \$ai, \@_ );\n\x09}\n\x09else\n\x09{\n\x09\x09&\$discardBCallback( \$ai, \$bi++, \@_ ) while ( \$bi <= \$lastB );\n\x09}\n\x09return 1;\n}\n\nsub LCS\n{\n\x09my \$a = shift;\x09# array ref\n\x09my \$matchVector = _longestCommonSubsequence( \$a, \@_ );\n\x09my \@retval;\n\x09my \$i;\n\x09for ( \$i = 0; \$i <= \$#\$matchVector; \$i++ )\n\x09{\n\x09\x09if ( defined( \$matchVector->[ \$i ] ) )\n\x09\x09{\n\x09\x09\x09push( \@retval, \$a->[ \$i ] );\n\x09\x09}\n\x09}\n\x09return wantarray ? \@retval : \\\@retval;\n}\n\nsub diff\n{\n\x09my \$a = shift;\x09# array ref\n\x09my \$b = shift;\x09# array ref\n\x09my \$retval = [];\n\x09my \$hunk = [];\n\x09my \$discard = sub { push( \@\$hunk, [ '-', \$_[ 0 ], \$a->[ \$_[ 0 ] ] ] ) };\n\x09my \$add = sub { push( \@\$hunk, [ '+', \$_[ 1 ], \$b->[ \$_[ 1 ] ] ] ) };\n\x09my \$match = sub { push( \@\$retval, \$hunk ) if scalar(\@\$hunk); \$hunk = [] };\n\x09traverse_sequences( \$a, \$b,\n\x09\x09{ MATCH => \$match, DISCARD_A => \$discard, DISCARD_B => \$add },\n\x09\x09\@_ );\n\x09&\$match();\n\x09return wantarray ? \@\$retval : \$retval;\n}\n\n1;\n
END_OF_FILE_AAAAAAAAAADF
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADG, "lib/Algorithm/Diff.pm" }
package Algorithm::Diff;\nuse strict;\nuse vars qw(\$VERSION \@EXPORT_OK \@ISA \@EXPORT);\nuse integer;    # see below in _replaceNextLargerWith() for mod to make\n                # if you don't use this\nrequire Exporter;\n\@ISA       = qw(Exporter);\n\@EXPORT    = qw();\n\@EXPORT_OK = qw(LCS diff traverse_sequences traverse_balanced sdiff);\n\$VERSION = sprintf('%d.%02d', (q\$Revision: 1.15 \$ =~ /\\d+/g));\n\n# McIlroy-Hunt diff algorithm\n# Adapted from the Smalltalk code of Mario I. Wolczko, <mario\@wolczko.com>\n# by Ned Konz, perl\@bike-nomad.com\n\n=head1 NAME\n\nAlgorithm::Diff - Compute `intelligent' differences between two files / lists\n\n=head1 SYNOPSIS\n\n  use Algorithm::Diff qw(diff sdiff LCS traverse_sequences\n                         traverse_balanced);\n\n  \@lcs    = LCS( \\\@seq1, \\\@seq2 );\n\n  \@lcs    = LCS( \\\@seq1, \\\@seq2, \$key_generation_function );\n\n  \$lcsref = LCS( \\\@seq1, \\\@seq2 );\n\n  \$lcsref = LCS( \\\@seq1, \\\@seq2, \$key_generation_function );\n\n  \@diffs = diff( \\\@seq1, \\\@seq2 );\n\n  \@diffs = diff( \\\@seq1, \\\@seq2, \$key_generation_function );\n\n  \@sdiffs = sdiff( \\\@seq1, \\\@seq2 );\n\n  \@sdiffs = sdiff( \\\@seq1, \\\@seq2, \$key_generation_function );\n  \n  traverse_sequences( \\\@seq1, \\\@seq2,\n                     { MATCH => \$callback,\n                       DISCARD_A => \$callback,\n                       DISCARD_B => \$callback,\n                     } );\n\n  traverse_sequences( \\\@seq1, \\\@seq2,\n                     { MATCH => \$callback,\n                       DISCARD_A => \$callback,\n                       DISCARD_B => \$callback,\n                     },\n                     \$key_generation_function );\n\n  traverse_balanced( \\\@seq1, \\\@seq2,\n                     { MATCH => \$callback,\n                       DISCARD_A => \$callback,\n                       DISCARD_B => \$callback,\n                       CHANGE    => \$callback,\n                     } );\n\n=head1 INTRODUCTION\n\n(by Mark-Jason Dominus)\n\nI once read an article written by the authors of C<diff>; they said\nthat they hard worked very hard on the algorithm until they found the\nright one.\n\nI think what they ended up using (and I hope someone will correct me,\nbecause I am not very confident about this) was the `longest common\nsubsequence' method.  in the LCS problem, you have two sequences of\nitems:\n\n        a b c d f g h j q z\n\n        a b c d e f g i j k r x y z\n\nand you want to find the longest sequence of items that is present in\nboth original sequences in the same order.  That is, you want to find\na new sequence I<S> which can be obtained from the first sequence by\ndeleting some items, and from the secend sequence by deleting other\nitems.  You also want I<S> to be as long as possible.  In this case\nI<S> is\n\n        a b c d f g j z\n\nFrom there it's only a small step to get diff-like output:\n\n        e   h i   k   q r x y \n        +   - +   +   - + + +\n\nThis module solves the LCS problem.  It also includes a canned\nfunction to generate C<diff>-like output.\n\nIt might seem from the example above that the LCS of two sequences is\nalways pretty obvious, but that's not always the case, especially when\nthe two sequences have many repeated elements.  For example, consider\n\n\x09a x b y c z p d q\n\x09a b c a x b y c z\n\nA naive approach might start by matching up the C<a> and C<b> that\nappear at the beginning of each sequence, like this:\n\n\x09a x b y c         z p d q\n\x09a   b   c a b y c z\n\nThis finds the common subsequence C<a b c z>.  But actually, the LCS\nis C<a x b y c z>:\n\n\x09      a x b y c z p d q\n\x09a b c a x b y c z\n\n=head1 USAGE\n\nThis module provides three exportable functions, which we'll deal with in\nascending order of difficulty: C<LCS>, \nC<diff>, C<sdiff>, C<traverse_sequences>, and C<traverse_balanced>.\n\n=head2 C<LCS>\n\nGiven references to two lists of items, LCS returns an array containing their\nlongest common subsequence.  In scalar context, it returns a reference to\nsuch a list.\n\n  \@lcs    = LCS( \\\@seq1, \\\@seq2 );\n  \$lcsref = LCS( \\\@seq1, \\\@seq2 );\n\nC<LCS> may be passed an optional third parameter; this is a CODE\nreference to a key generation function.  See L</KEY GENERATION\nFUNCTIONS>.\n\n  \@lcs    = LCS( \\\@seq1, \\\@seq2, \$keyGen );\n  \$lcsref = LCS( \\\@seq1, \\\@seq2, \$keyGen );\n\nAdditional parameters, if any, will be passed to the key generation\nroutine.\n\n=head2 C<diff>\n\n  \@diffs     = diff( \\\@seq1, \\\@seq2 );\n  \$diffs_ref = diff( \\\@seq1, \\\@seq2 );\n\nC<diff> computes the smallest set of additions and deletions necessary\nto turn the first sequence into the second, and returns a description\nof these changes.  The description is a list of I<hunks>; each hunk\nrepresents a contiguous section of items which should be added,\ndeleted, or replaced.  The return value of C<diff> is a list of\nhunks, or, in scalar context, a reference to such a list.\n\nHere is an example:  The diff of the following two sequences:\n\n  a b c e h j l m n p\n  b c d e f j k l m r s t\n\nResult:\n\n [ \n   [ [ '-', 0, 'a' ] ],       \n\n   [ [ '+', 2, 'd' ] ],\n\n   [ [ '-', 4, 'h' ] , \n     [ '+', 4, 'f' ] ],\n\n   [ [ '+', 6, 'k' ] ],\n\n   [ [ '-', 8, 'n' ], \n     [ '-', 9, 'p' ], \n     [ '+', 9, 'r' ], \n     [ '+', 10, 's' ], \n     [ '+', 11, 't' ],\n   ]\n ]\n\nThere are five hunks here.  The first hunk says that the C<a> at\nposition 0 of the first sequence should be deleted (C<->).  The second\nhunk says that the C<d> at position 2 of the second sequence should\nbe inserted (C<+>).  The third hunk says that the C<h> at position 4\nof the first sequence should be removed and replaced with the C<f>\nfrom position 4 of the second sequence.  The other two hunks similarly. \n\nC<diff> may be passed an optional third parameter; this is a CODE\nreference to a key generation function.  See L</KEY GENERATION\nFUNCTIONS>.\n\nAdditional parameters, if any, will be passed to the key generation\nroutine.\n\n=head2 C<sdiff>\n\n  \@sdiffs     = sdiff( \\\@seq1, \\\@seq2 );\n  \$sdiffs_ref = sdiff( \\\@seq1, \\\@seq2 );\n\nC<sdiff> computes all necessary components to show two sequences\nand their minimized differences side by side, just like the \nUnix-utility I<sdiff> does:\n\n    same             same\n    before     |     after\n    old        <     -\n    -          >     new\n\nIt returns a list of array refs, each pointing to an array of \ndisplay instructions. In scalar context it returns a reference\nto such a list.\n\nDisplay instructions consist of three elements: A modifier indicator\n(C<+>: Element added, C<->: Element removed, C<u>: Element unmodified, \nC<c>: Element changed) and the value of the old and new elements, to\nbe displayed side by side.\n\nAn C<sdiff> of the following two sequences:\n\n  a b c e h j l m n p\n  b c d e f j k l m r s t\n\nresults in\n\n[ [ '-', 'a', ''  ],\n  [ 'u', 'b', 'b' ],\n  [ 'u', 'c', 'c' ],\n  [ '+', '',  'd' ],\n  [ 'u', 'e', 'e' ],\n  [ 'c', 'h', 'f' ],\n  [ 'u', 'j', 'j' ],\n  [ '+', '',  'k' ],\n  [ 'u', 'l', 'l' ],\n  [ 'u', 'm', 'm' ],\n  [ 'c', 'n', 'r' ],\n  [ 'c', 'p', 's' ],\n  [ '+', '', 't' ] ]\n\nC<sdiff> may be passed an optional third parameter; this is a CODE\nreference to a key generation function.  See L</KEY GENERATION\nFUNCTIONS>.\n\nAdditional parameters, if any, will be passed to the key generation\nroutine.\n\n=head2 C<traverse_sequences>\n\nC<traverse_sequences> is the most general facility provided by this\nmodule; C<diff> and C<LCS> are implemented as calls to it.\n\nImagine that there are two arrows.  Arrow A points to an element of sequence A,\nand arrow B points to an element of the sequence B.  Initially, the arrows\npoint to the first elements of the respective sequences.  C<traverse_sequences>\nwill advance the arrows through the sequences one element at a time, calling an\nappropriate user-specified callback function before each advance.  It\nwilladvance the arrows in such a way that if there are equal elements C<\$A[\$i]>\nand C<\$B[\$j]> which are equal and which are part of the LCS, there will be\nsome moment during the execution of C<traverse_sequences> when arrow A is\npointing to C<\$A[\$i]> and arrow B is pointing to C<\$B[\$j]>.  When this happens,\nC<traverse_sequences> will call the C<MATCH> callback function and then it will\nadvance both arrows. \n\nOtherwise, one of the arrows is pointing to an element of its sequence that is\nnot part of the LCS.  C<traverse_sequences> will advance that arrow and will\ncall the C<DISCARD_A> or the C<DISCARD_B> callback, depending on which arrow it\nadvanced.  If both arrows point to elements that are not part of the LCS, then\nC<traverse_sequences> will advance one of them and call the appropriate\ncallback, but it is not specified which it will call.\n\nThe arguments to C<traverse_sequences> are the two sequences to traverse, and a\nhash which specifies the callback functions, like this:\n\n  traverse_sequences( \\\@seq1, \\\@seq2,\n                     { MATCH => \$callback_1,\n                       DISCARD_A => \$callback_2,\n                       DISCARD_B => \$callback_3,\n                     } );\n\nCallbacks for MATCH, DISCARD_A, and DISCARD_B are invoked with at least the\nindices of the two arrows as their arguments.  They are not expected to return\nany values.  If a callback is omitted from the table, it is not called.\n\nCallbacks for A_FINISHED and B_FINISHED are invoked with at least the\ncorresponding index in A or B.\n\nIf arrow A reaches the end of its sequence, before arrow B does,\nC<traverse_sequences> will call the C<A_FINISHED> callback when it advances\narrow B, if there is such a function; if not it will call C<DISCARD_B> instead.\nSimilarly if arrow B finishes first.  C<traverse_sequences> returns when both\narrows are at the ends of their respective sequences.  It returns true on\nsuccess and false on failure.  At present there is no way to fail.\n\nC<traverse_sequences> may be passed an optional fourth parameter; this is a\nCODE reference to a key generation function.  See L</KEY GENERATION FUNCTIONS>.\n\nAdditional parameters, if any, will be passed to the key generation function.\n\n=head2 C<traverse_balanced>\n\nC<traverse_balanced> is an alternative to C<traverse_sequences>. It\nuses a different algorithm to iterate through the entries in the\ncomputed LCS. Instead of sticking to one side and showing element changes\nas insertions and deletions only, it will jump back and forth between\nthe two sequences and report I<changes> occurring as deletions on one\nside followed immediatly by an insertion on the other side.\n\nIn addition to the \nC<DISCARD_A>,\nC<DISCARD_B>, and\nC<MATCH>\ncallbacks supported by C<traverse_sequences>, C<traverse_balanced> supports\na C<CHANGE> callback indicating that one element got C<replaced> by another:\n\n  traverse_sequences( \\\@seq1, \\\@seq2,\n                     { MATCH => \$callback_1,\n                       DISCARD_A => \$callback_2,\n                       DISCARD_B => \$callback_3,\n                       CHANGE    => \$callback_4,\n                     } );\n\nIf no C<CHANGE> callback is specified, C<traverse_balanced>\nwill map C<CHANGE> events to C<DISCARD_A> and C<DISCARD_B> actions,\ntherefore resulting in a similar behaviour as C<traverse_sequences>\nwith different order of events.\n\nC<traverse_balanced> might be a bit slower than C<traverse_sequences>,\nnoticable only while processing huge amounts of data.\n\nThe C<sdiff> function of this module \nis implemented as call to C<traverse_balanced>.\n\n=head1 KEY GENERATION FUNCTIONS\n\nC<diff>, C<LCS>, and C<traverse_sequences> accept an optional last parameter.\nThis is a CODE reference to a key generating (hashing) function that should\nreturn a string that uniquely identifies a given element.  It should be the\ncase that if two elements are to be considered equal, their keys should be the\nsame (and the other way around).  If no key generation function is provided,\nthe key will be the element as a string.\n\nBy default, comparisons will use "eq" and elements will be turned into keys\nusing the default stringizing operator '""'.\n\nWhere this is important is when you're comparing something other than strings.\nIf it is the case that you have multiple different objects that should be\nconsidered to be equal, you should supply a key generation function. Otherwise,\nyou have to make sure that your arrays contain unique references.\n\nFor instance, consider this example:\n\n  package Person;\n\n  sub new\n  {\n    my \$package = shift;\n    return bless { name => '', ssn => '', \@_ }, \$package;\n  }\n\n  sub clone\n  {\n    my \$old = shift;\n    my \$new = bless { %\$old }, ref(\$old);\n  }\n\n  sub hash\n  {\n    return shift()->{'ssn'};\n  }\n\n  my \$person1 = Person->new( name => 'Joe', ssn => '123-45-6789' );\n  my \$person2 = Person->new( name => 'Mary', ssn => '123-47-0000' );\n  my \$person3 = Person->new( name => 'Pete', ssn => '999-45-2222' );\n  my \$person4 = Person->new( name => 'Peggy', ssn => '123-45-9999' );\n  my \$person5 = Person->new( name => 'Frank', ssn => '000-45-9999' );\n\nIf you did this:\n\n  my \$array1 = [ \$person1, \$person2, \$person4 ];\n  my \$array2 = [ \$person1, \$person3, \$person4, \$person5 ];\n  Algorithm::Diff::diff( \$array1, \$array2 );\n\neverything would work out OK (each of the objects would be converted\ninto a string like "Person=HASH(0x82425b0)" for comparison).\n\nBut if you did this:\n\n  my \$array1 = [ \$person1, \$person2, \$person4 ];\n  my \$array2 = [ \$person1, \$person3, \$person4->clone(), \$person5 ];\n  Algorithm::Diff::diff( \$array1, \$array2 );\n\n\$person4 and \$person4->clone() (which have the same name and SSN)\nwould be seen as different objects. If you wanted them to be considered\nequivalent, you would have to pass in a key generation function:\n\n  my \$array1 = [ \$person1, \$person2, \$person4 ];\n  my \$array2 = [ \$person1, \$person3, \$person4->clone(), \$person5 ];\n  Algorithm::Diff::diff( \$array1, \$array2, \\&Person::hash );\n\nThis would use the 'ssn' field in each Person as a comparison key, and\nso would consider \$person4 and \$person4->clone() as equal.\n\nYou may also pass additional parameters to the key generation function\nif you wish.\n\n=head1 AUTHOR\n\nThis version by Ned Konz, perl\@bike-nomad.com\n\n=head1 LICENSE\n\nCopyright (c) 2000-2002 Ned Konz.  All rights reserved.\nThis program is free software;\nyou can redistribute it and/or modify it under the same terms\nas Perl itself.\n\n=head1 CREDITS\n\nVersions through 0.59 (and much of this documentation) were written by:\n\nMark-Jason Dominus, mjd-perl-diff\@plover.com\n\nThis version borrows the documentation and names of the routines\nfrom Mark-Jason's, but has all new code in Diff.pm.\n\nThis code was adapted from the Smalltalk code of\nMario Wolczko <mario\@wolczko.com>, which is available at\nftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st\n\nC<sdiff> and C<traverse_balanced> were written by Mike Schilli\n<m\@perlmeister.com>.\n\nThe algorithm is that described in \nI<A Fast Algorithm for Computing Longest Common Subsequences>,\nCACM, vol.20, no.5, pp.350-353, May 1977, with a few\nminor improvements to improve the speed.\n\n=cut\n\n# Create a hash that maps each element of \$aCollection to the set of positions\n# it occupies in \$aCollection, restricted to the elements within the range of\n# indexes specified by \$start and \$end.\n# The fourth parameter is a subroutine reference that will be called to\n# generate a string to use as a key.\n# Additional parameters, if any, will be passed to this subroutine.\n#\n# my \$hashRef = _withPositionsOfInInterval( \\\@array, \$start, \$end, \$keyGen );\n\nsub _withPositionsOfInInterval\n{\n\x09my \$aCollection = shift;    # array ref\n\x09my \$start       = shift;\n\x09my \$end         = shift;\n\x09my \$keyGen      = shift;\n\x09my %d;\n\x09my \$index;\n\x09for ( \$index = \$start ; \$index <= \$end ; \$index++ )\n\x09{\n\x09\x09my \$element = \$aCollection->[\$index];\n\x09\x09my \$key = &\$keyGen( \$element, \@_ );\n\x09\x09if ( exists( \$d{\$key} ) )\n\x09\x09{\n\x09\x09\x09unshift ( \@{ \$d{\$key} }, \$index );\n\x09\x09}\n\x09\x09else\n\x09\x09{\n\x09\x09\x09\$d{\$key} = [\$index];\n\x09\x09}\n\x09}\n\x09return wantarray ? %d : \\%d;\n}\n\n# Find the place at which aValue would normally be inserted into the array. If\n# that place is already occupied by aValue, do nothing, and return undef. If\n# the place does not exist (i.e., it is off the end of the array), add it to\n# the end, otherwise replace the element at that point with aValue.\n# It is assumed that the array's values are numeric.\n# This is where the bulk (75%) of the time is spent in this module, so try to\n# make it fast!\n\nsub _replaceNextLargerWith\n{\n\x09my ( \$array, \$aValue, \$high ) = \@_;\n\x09\$high ||= \$#\$array;\n\n\x09# off the end?\n\x09if ( \$high == -1 || \$aValue > \$array->[-1] )\n\x09{\n\x09\x09push ( \@\$array, \$aValue );\n\x09\x09return \$high + 1;\n\x09}\n\n\x09# binary search for insertion point...\n\x09my \$low = 0;\n\x09my \$index;\n\x09my \$found;\n\x09while ( \$low <= \$high )\n\x09{\n\x09\x09\$index = ( \$high + \$low ) / 2;\n\n\x09\x09#\x09\x09\$index = int(( \$high + \$low ) / 2);\x09\x09# without 'use integer'\n\x09\x09\$found = \$array->[\$index];\n\n\x09\x09if ( \$aValue == \$found )\n\x09\x09{\n\x09\x09\x09return undef;\n\x09\x09}\n\x09\x09elsif ( \$aValue > \$found )\n\x09\x09{\n\x09\x09\x09\$low = \$index + 1;\n\x09\x09}\n\x09\x09else\n\x09\x09{\n\x09\x09\x09\$high = \$index - 1;\n\x09\x09}\n\x09}\n\n\x09# now insertion point is in \$low.\n\x09\$array->[\$low] = \$aValue;    # overwrite next larger\n\x09return \$low;\n}\n\n# This method computes the longest common subsequence in \$a and \$b.\n\n# Result is array or ref, whose contents is such that\n# \x09\$a->[ \$i ] == \$b->[ \$result[ \$i ] ]\n# foreach \$i in ( 0 .. \$#result ) if \$result[ \$i ] is defined.\n\n# An additional argument may be passed; this is a hash or key generating\n# function that should return a string that uniquely identifies the given\n# element.  It should be the case that if the key is the same, the elements\n# will compare the same. If this parameter is undef or missing, the key\n# will be the element as a string.\n\n# By default, comparisons will use "eq" and elements will be turned into keys\n# using the default stringizing operator '""'.\n\n# Additional parameters, if any, will be passed to the key generation routine.\n\nsub _longestCommonSubsequence\n{\n\x09my \$a      = shift;    # array ref\n\x09my \$b      = shift;    # array ref\n\x09my \$keyGen = shift;    # code ref\n\x09my \$compare;           # code ref\n\n\x09# set up code refs\n\x09# Note that these are optimized.\n\x09if ( !defined(\$keyGen) )    # optimize for strings\n\x09{\n\x09\x09\$keyGen = sub { \$_[0] };\n\x09\x09\$compare = sub { my ( \$a, \$b ) = \@_; \$a eq \$b };\n\x09}\n\x09else\n\x09{\n\x09\x09\$compare = sub {\n\x09\x09\x09my \$a = shift;\n\x09\x09\x09my \$b = shift;\n\x09\x09\x09&\$keyGen( \$a, \@_ ) eq &\$keyGen( \$b, \@_ );\n\x09\x09};\n\x09}\n\n\x09my ( \$aStart, \$aFinish, \$bStart, \$bFinish, \$matchVector ) =\n\x09  ( 0, \$#\$a, 0, \$#\$b, [] );\n\n\x09# First we prune off any common elements at the beginning\n\x09while ( \$aStart <= \$aFinish\n\x09\x09and \$bStart <= \$bFinish\n\x09\x09and &\$compare( \$a->[\$aStart], \$b->[\$bStart], \@_ ) )\n\x09{\n\x09\x09\$matchVector->[ \$aStart++ ] = \$bStart++;\n\x09}\n\n\x09# now the end\n\x09while ( \$aStart <= \$aFinish\n\x09\x09and \$bStart <= \$bFinish\n\x09\x09and &\$compare( \$a->[\$aFinish], \$b->[\$bFinish], \@_ ) )\n\x09{\n\x09\x09\$matchVector->[ \$aFinish-- ] = \$bFinish--;\n\x09}\n\n\x09# Now compute the equivalence classes of positions of elements\n\x09my \$bMatches =\n\x09  _withPositionsOfInInterval( \$b, \$bStart, \$bFinish, \$keyGen, \@_ );\n\x09my \$thresh = [];\n\x09my \$links  = [];\n\n\x09my ( \$i, \$ai, \$j, \$k );\n\x09for ( \$i = \$aStart ; \$i <= \$aFinish ; \$i++ )\n\x09{\n\x09\x09\$ai = &\$keyGen( \$a->[\$i], \@_ );\n\x09\x09if ( exists( \$bMatches->{\$ai} ) )\n\x09\x09{\n\x09\x09\x09\$k = 0;\n\x09\x09\x09for \$j ( \@{ \$bMatches->{\$ai} } )\n\x09\x09\x09{\n\n\x09\x09\x09\x09# optimization: most of the time this will be true\n\x09\x09\x09\x09if ( \$k and \$thresh->[\$k] > \$j and \$thresh->[ \$k - 1 ] < \$j )\n\x09\x09\x09\x09{\n\x09\x09\x09\x09\x09\$thresh->[\$k] = \$j;\n\x09\x09\x09\x09}\n\x09\x09\x09\x09else\n\x09\x09\x09\x09{\n\x09\x09\x09\x09\x09\$k = _replaceNextLargerWith( \$thresh, \$j, \$k );\n\x09\x09\x09\x09}\n\n\x09\x09\x09\x09# oddly, it's faster to always test this (CPU cache?).\n\x09\x09\x09\x09if ( defined(\$k) )\n\x09\x09\x09\x09{\n\x09\x09\x09\x09\x09\$links->[\$k] =\n\x09\x09\x09\x09\x09  [ ( \$k ? \$links->[ \$k - 1 ] : undef ), \$i, \$j ];\n\x09\x09\x09\x09}\n\x09\x09\x09}\n\x09\x09}\n\x09}\n\n\x09if (\@\$thresh)\n\x09{\n\x09\x09for ( my \$link = \$links->[\$#\$thresh] ; \$link ; \$link = \$link->[0] )\n\x09\x09{\n\x09\x09\x09\$matchVector->[ \$link->[1] ] = \$link->[2];\n\x09\x09}\n\x09}\n\n\x09return wantarray ? \@\$matchVector : \$matchVector;\n}\n\nsub traverse_sequences\n{\n\x09my \$a                 = shift;                                  # array ref\n\x09my \$b                 = shift;                                  # array ref\n\x09my \$callbacks         = shift || {};\n\x09my \$keyGen            = shift;\n\x09my \$matchCallback     = \$callbacks->{'MATCH'} || sub { };\n\x09my \$discardACallback  = \$callbacks->{'DISCARD_A'} || sub { };\n\x09my \$finishedACallback = \$callbacks->{'A_FINISHED'};\n\x09my \$discardBCallback  = \$callbacks->{'DISCARD_B'} || sub { };\n\x09my \$finishedBCallback = \$callbacks->{'B_FINISHED'};\n\x09my \$matchVector = _longestCommonSubsequence( \$a, \$b, \$keyGen, \@_ );\n\n\x09# Process all the lines in \@\$matchVector\n\x09my \$lastA = \$#\$a;\n\x09my \$lastB = \$#\$b;\n\x09my \$bi    = 0;\n\x09my \$ai;\n\n\x09for ( \$ai = 0 ; \$ai <= \$#\$matchVector ; \$ai++ )\n\x09{\n\x09\x09my \$bLine = \$matchVector->[\$ai];\n\x09\x09if ( defined(\$bLine) )    # matched\n\x09\x09{\n\x09\x09\x09&\$discardBCallback( \$ai, \$bi++, \@_ ) while \$bi < \$bLine;\n\x09\x09\x09&\$matchCallback( \$ai,    \$bi++, \@_ );\n\x09\x09}\n\x09\x09else\n\x09\x09{\n\x09\x09\x09&\$discardACallback( \$ai, \$bi, \@_ );\n\x09\x09}\n\x09}\n\n\x09# The last entry (if any) processed was a match.\n\x09# \$ai and \$bi point just past the last matching lines in their sequences.\n\n\x09while ( \$ai <= \$lastA or \$bi <= \$lastB )\n\x09{\n\n\x09\x09# last A?\n\x09\x09if ( \$ai == \$lastA + 1 and \$bi <= \$lastB )\n\x09\x09{\n\x09\x09\x09if ( defined(\$finishedACallback) )\n\x09\x09\x09{\n\x09\x09\x09\x09&\$finishedACallback( \$lastA, \@_ );\n\x09\x09\x09\x09\$finishedACallback = undef;\n\x09\x09\x09}\n\x09\x09\x09else\n\x09\x09\x09{\n\x09\x09\x09\x09&\$discardBCallback( \$ai, \$bi++, \@_ ) while \$bi <= \$lastB;\n\x09\x09\x09}\n\x09\x09}\n\n\x09\x09# last B?\n\x09\x09if ( \$bi == \$lastB + 1 and \$ai <= \$lastA )\n\x09\x09{\n\x09\x09\x09if ( defined(\$finishedBCallback) )\n\x09\x09\x09{\n\x09\x09\x09\x09&\$finishedBCallback( \$lastB, \@_ );\n\x09\x09\x09\x09\$finishedBCallback = undef;\n\x09\x09\x09}\n\x09\x09\x09else\n\x09\x09\x09{\n\x09\x09\x09\x09&\$discardACallback( \$ai++, \$bi, \@_ ) while \$ai <= \$lastA;\n\x09\x09\x09}\n\x09\x09}\n\n\x09\x09&\$discardACallback( \$ai++, \$bi, \@_ ) if \$ai <= \$lastA;\n\x09\x09&\$discardBCallback( \$ai, \$bi++, \@_ ) if \$bi <= \$lastB;\n\x09}\n\n\x09return 1;\n}\n\nsub traverse_balanced\n{\n\x09my \$a                 = shift;                                  # array ref\n\x09my \$b                 = shift;                                  # array ref\n\x09my \$callbacks         = shift || {};\n\x09my \$keyGen            = shift;\n\x09my \$matchCallback     = \$callbacks->{'MATCH'} || sub { };\n\x09my \$discardACallback  = \$callbacks->{'DISCARD_A'} || sub { };\n\x09my \$discardBCallback  = \$callbacks->{'DISCARD_B'} || sub { };\n\x09my \$changeCallback    = \$callbacks->{'CHANGE'};\n\x09my \$matchVector = _longestCommonSubsequence( \$a, \$b, \$keyGen, \@_ );\n\n\x09# Process all the lines in match vector\n\x09my \$lastA = \$#\$a;\n\x09my \$lastB = \$#\$b;\n\x09my \$bi    = 0;\n\x09my \$ai    = 0;\n\x09my \$ma    = -1;\n\x09my \$mb;\n\n\x09while (1)\n\x09{\n\n\x09\x09# Find next match indices \$ma and \$mb\n\x09\x09do { \$ma++ } while ( \$ma <= \$#\$matchVector && !defined \$matchVector->[\$ma] );\n\n\x09\x09last if \$ma > \$#\$matchVector;    # end of matchVector?\n\x09\x09\$mb = \$matchVector->[\$ma];\n\n\x09\x09# Proceed with discard a/b or change events until\n\x09\x09# next match\n\x09\x09while ( \$ai < \$ma || \$bi < \$mb )\n\x09\x09{\n\n\x09\x09\x09if ( \$ai < \$ma && \$bi < \$mb )\n\x09\x09\x09{\n\n\x09\x09\x09\x09# Change\n\x09\x09\x09\x09if ( defined \$changeCallback )\n\x09\x09\x09\x09{\n\x09\x09\x09\x09\x09&\$changeCallback( \$ai++, \$bi++, \@_ );\n\x09\x09\x09\x09}\n\x09\x09\x09\x09else\n\x09\x09\x09\x09{\n\x09\x09\x09\x09\x09&\$discardACallback( \$ai++, \$bi, \@_ );\n\x09\x09\x09\x09\x09&\$discardBCallback( \$ai, \$bi++, \@_ );\n\x09\x09\x09\x09}\n\x09\x09\x09}\n\x09\x09\x09elsif ( \$ai < \$ma )\n\x09\x09\x09{\n\x09\x09\x09\x09&\$discardACallback( \$ai++, \$bi, \@_ );\n\x09\x09\x09}\n\x09\x09\x09else\n\x09\x09\x09{\n\n\x09\x09\x09\x09# \$bi < \$mb\n\x09\x09\x09\x09&\$discardBCallback( \$ai, \$bi++, \@_ );\n\x09\x09\x09}\n\x09\x09}\n\n\x09\x09# Match\n\x09\x09&\$matchCallback( \$ai++, \$bi++, \@_ );\n\x09}\n\n\x09while ( \$ai <= \$lastA || \$bi <= \$lastB )\n\x09{\n\x09\x09if ( \$ai <= \$lastA && \$bi <= \$lastB )\n\x09\x09{\n\n\x09\x09\x09# Change\n\x09\x09\x09if ( defined \$changeCallback )\n\x09\x09\x09{\n\x09\x09\x09\x09&\$changeCallback( \$ai++, \$bi++, \@_ );\n\x09\x09\x09}\n\x09\x09\x09else\n\x09\x09\x09{\n\x09\x09\x09\x09&\$discardACallback( \$ai++, \$bi, \@_ );\n\x09\x09\x09\x09&\$discardBCallback( \$ai, \$bi++, \@_ );\n\x09\x09\x09}\n\x09\x09}\n\x09\x09elsif ( \$ai <= \$lastA )\n\x09\x09{\n\x09\x09\x09&\$discardACallback( \$ai++, \$bi, \@_ );\n\x09\x09}\n\x09\x09else\n\x09\x09{\n\n\x09\x09\x09# \$bi <= \$lastB\n\x09\x09\x09&\$discardBCallback( \$ai, \$bi++, \@_ );\n\x09\x09}\n\x09}\n\n\x09return 1;\n}\n\nsub LCS\n{\n\x09my \$a = shift;                                           # array ref\n\x09my \$matchVector = _longestCommonSubsequence( \$a, \@_ );\n\x09my \@retval;\n\x09my \$i;\n\x09for ( \$i = 0 ; \$i <= \$#\$matchVector ; \$i++ )\n\x09{\n\x09\x09if ( defined( \$matchVector->[\$i] ) )\n\x09\x09{\n\x09\x09\x09push ( \@retval, \$a->[\$i] );\n\x09\x09}\n\x09}\n\x09return wantarray ? \@retval : \\\@retval;\n}\n\nsub diff\n{\n\x09my \$a      = shift;    # array ref\n\x09my \$b      = shift;    # array ref\n\x09my \$retval = [];\n\x09my \$hunk   = [];\n\x09my \$discard = sub { push ( \@\$hunk, [ '-', \$_[0], \$a->[ \$_[0] ] ] ) };\n\x09my \$add = sub { push ( \@\$hunk, [ '+', \$_[1], \$b->[ \$_[1] ] ] ) };\n\x09my \$match = sub { push ( \@\$retval, \$hunk ) if scalar(\@\$hunk); \$hunk = [] };\n\x09traverse_sequences( \$a, \$b,\n\x09\x09{ MATCH => \$match, DISCARD_A => \$discard, DISCARD_B => \$add }, \@_ );\n\x09&\$match();\n\x09return wantarray ? \@\$retval : \$retval;\n}\n\nsub sdiff\n{\n\x09my \$a      = shift;    # array ref\n\x09my \$b      = shift;    # array ref\n\x09my \$retval = [];\n\x09my \$discard = sub { push ( \@\$retval, [ '-', \$a->[ \$_[0] ], "" ] ) };\n\x09my \$add = sub { push ( \@\$retval, [ '+', "", \$b->[ \$_[1] ] ] ) };\n\x09my \$change = sub {\n\x09\x09push ( \@\$retval, [ 'c', \$a->[ \$_[0] ], \$b->[ \$_[1] ] ] );\n\x09};\n\x09my \$match = sub {\n\x09\x09push ( \@\$retval, [ 'u', \$a->[ \$_[0] ], \$b->[ \$_[1] ] ] );\n\x09};\n\x09traverse_balanced(\n\x09\x09\$a,\n\x09\x09\$b,\n\x09\x09{\n\x09\x09\x09MATCH     => \$match,\n\x09\x09\x09DISCARD_A => \$discard,\n\x09\x09\x09DISCARD_B => \$add,\n\x09\x09\x09CHANGE    => \$change,\n\x09\x09},\n\x09\x09\@_\n\x09);\n\x09return wantarray ? \@\$retval : \$retval;\n}\n\n1;\n
END_OF_FILE_AAAAAAAAAADG
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADH, "lib/Pod/HTML_Elements.pm" }
require IO::File;\npackage Pod::HTML_Elements;\nuse strict;\nuse Pod::Parser 1.061;       \nuse Pod::Links qw(link_parse);\nuse HTML::Element;\nuse HTML::Entities;\nuse HTML::AsSubs qw(h1 a li title);\nuse vars qw(\@ISA \$VERSION);\n\$VERSION = '0.04';\nuse base qw(Pod::Parser);  \nuse Data::Dumper;     \n\nmy \$nbsp;              \n\nsub begin_pod\n{                 \n my \$obj = shift;\n delete \$obj->{'title'};\n my \$html = HTML::Element->new('html');\n my \$head = HTML::Element->new('head');\n my \$body = HTML::Element->new('body');\n \$html->push_content(\$head);\n \$html->push_content(\$body);\n \$obj->{'html'} = \$html;\n \$obj->{'body'} = \$body;\n \$obj->{'current'} = \$body;\n \$obj->{'head'} = \$head;              \n if (defined \$obj->{'Index'} and not defined \$obj->{'index'})\n  {\n   \$obj->{'index'} = HTML::Element->new('ul');\n  }\n}       \n\nsub current \n{ \n my \$obj = shift;\n \$obj->{'current'} = shift if (\@_);\n return \$obj->{'current'}; \n}          \n\nsub body    { return shift->{'body'} }\nsub head    { return shift->{'head'} }\nsub html    { return shift->{'html'} }\n \nsub make_elem\n{\n my \$tag = shift;\n my \$attributes;\n if (\@_ and defined \$_[0] and ref(\$_[0]) eq "HASH") \n  {\n   \$attributes = shift;\n  }            \n else \n  {\n   \$attributes = {};\n  }\n my \$elem = new HTML::Element \$tag, %\$attributes;\n \$elem->push_content(\@_);\n return \$elem;\n}\n\nsub add_elem\n{\n my \$body = shift->current;\n my \$elem = make_elem(\@_);\n \$body->push_content(\$elem);\n return \$elem;\n}\n\nsub do_name\n{\n my (\$parser,\$t) = \@_;\n \$t =~ s/(^\\s+|\\s+\$)//g;\n \$parser->{'title'} = \$t;\n \$parser->{'in_name'} = 0;\n \$parser->head->push_content(title(\$t));\n my \$i = \$parser->{'index'};\n if (defined \$i)\n  {        \n   my \$links = \$parser->{'Links'};              \n   my \$l = \$links->relative_url(\$parser->{'Index'},\$parser->output_file) if (defined \$links);\n   \$i->push_content("\\n",li(a({href => \$l},\$t)));\n  }\n}\n\nsub verbatim \n{\n my (\$parser, \$paragraph, \$line_num) = \@_;    \n \$parser->do_name(\$paragraph) if (\$parser->{'in_name'});\n \$parser->add_elem(pre => \$paragraph);\n}          \n\nsub raw_text\n{\n my \$text = '';\n foreach (\@{\$_[0]})\n  {\n   \$text .= (ref \$_) ? raw_text(\$_->content) : \$_;\n  }\n return \$text;\n}                                 \n\nsub textblock \n{\n my (\$parser, \$paragraph, \$line_num) = \@_;\n my \@expansion = \$parser->parse_to_elem(\$paragraph, \$line_num);\n if (\$parser->{'in_name'})\n  {\n   my \$t = raw_text(\\\@expansion);\n   \$parser->do_name(\$t);\n  }\n my \$c = \$parser->current;\n if (\$c->tag eq 'dt')\n  {                           \n   \$parser->current(\$c = \$c->parent);           \n   \$parser->current(\$parser->add_elem('dd' => \@expansion));   \n  }\n else\n  {\n   \$parser->add_elem(p => \@expansion);\n  }\n}         \n\nsub linktext\n{                  \n my \$parser = shift;\n my \$links = \$parser->{'Links'};\n return \$links->relative_url(\$parser->output_file,\$links->url(\@_)) if (defined \$links);\n return undef;\n}\n\nsub non_break\n{             \n my \$tree = shift;\n foreach (\$tree->children)\n  {\n   if (ref \$_)\n    {\n     non_break(\$_->parse_tree);\n    }\n   else\n    {\n     s/ /\$nbsp/g;\n    }\n  }\n}\n\nmy %seq = (B => 'b', I => 'i', C => 'code', 'F' => 'i', 'L' => 'a');\nsub seq_to_element\n{\n my (\$parser, \$cmd, \$tree) = \@_;\n my \$t = \$seq{\$cmd};\n if (\$t)\n  {     \n   my \@args = walk_tree(\$parser,\$tree);\n   if (\$cmd eq 'L')\n    {\n     my \$txt = raw_text(\\\@args);\n     my (\$text,\@where) = link_parse(\$txt);\n     \@args = (\$text) if (\$text ne \$txt);\n     my \$link = \@where == 1 ? \$where[0] : \$parser->linktext(\@where); \n     unshift(\@args, { href => \$link } ) if defined \$link;\n    }\n   return make_elem(\$t,\@args);\n  }\n if (\$cmd eq 'E')\n  {        \n   # Assume only one simple string in the argument ...\n   my \@args = walk_tree(\$parser,\$tree);\n   my \$s = raw_text(\\\@args);\n   return chr(\$s) if \$s =~ /^\\d+\$/;\n   return decode_entities("&\$s;"); \n  }\n return '' if (\$cmd eq 'Z');\n if (\$cmd eq 'S')\n  {                    \n   \$nbsp = decode_entities('&nbsp;') unless defined \$nbsp;\n   non_break(\$tree);\n   return walk_tree(\$parser,\$tree);\n  }\n return ("\$cmd<",walk_tree(\$parser,\$tree),'>');\n}\n\nsub walk_tree\n{\n my (\$parser,\$tree) = \@_;\n my \@list = ();\n foreach my \$seq (\$tree->children)\n  {\n   if (ref(\$seq))\n    {\n     my \$cmd  = \$seq->cmd_name;\n     my \$tree = \$seq->parse_tree;\n     push(\@list,seq_to_element(\$parser,\$cmd,\$tree));\n    }\n   else\n    {\n     push(\@list,\$seq);\n    }\n  }\n return \@list;\n}\n\nsub parse_to_elem \n{\n my (\$self,\$text,\$line_num) = \@_;\n my \$tree = \$self->parse_text(\$text, \$line_num);\n return walk_tree(\$self,\$tree);\n}\n\n\nsub command \n{      \n my (\$parser, \$command, \$paragraph, \$line_num) = \@_;\n my \@expansion = \$parser->parse_to_elem(\$paragraph, \$line_num);\n if (\$command =~ /^head(\\d+)?\$/)\n  {                   \n   my \$rank = \$1 || 3;\n   \$parser->current(\$parser->body);\n   my \$t = raw_text(\\\@expansion);\n   \$t =~ s/\\s+\$//;\n   if (\$t eq 'NAME' && !\$parser->{'title'})\n    {\n     \$parser->{in_name} = 1;\n    }\n   my \$name = \$parser->linktext(\$t);\n   if (\$name)\n    {\n     \@expansion = make_elem('a',{ name => substr(\$name,1) } , \@expansion ) if (defined \$name);\n    }\n   if (\$rank == 1)\n    {\n     if (\$parser->{'last_head1'} && \$parser->{'last_head1'} eq \$parser->input_file)\n      {\n       \$parser->add_elem("p");\n       \$parser->add_elem("hr");\n      }\n     \$parser->{'last_head1'} = \$parser->input_file;\n    }\n   \$parser->add_elem("h\$rank" => \@expansion);\n  }\n elsif (\$command eq 'over')\n  {\n   \$parser->current(\$parser->add_elem('ul'));\n  }\n elsif (\$command eq 'item')\n  {                              \n   my \$expansion = shift(\@expansion);\n   my \$c = \$parser->current;\n   unless (\$c->tag =~ /^(ul|dl|ol|dd|dt)/)\n    {       \n     my \$file = \$parser->input_file;\n     \$parser->add_elem("h3" => \$expansion, \@expansion);\n     return;\n    }\n   if (\$expansion =~ /^\\*\\s+(.*)\$/)\n    {\n     \$parser->add_elem(li => "\$1",\@expansion);\n    }\n   elsif (\$expansion =~ /^\\d+(?:\\.|\\s+|\\))(.*)\$/ || \n          \$expansion =~ /^\\[\\d+\\](?:\\.|\\s+|\\))(.*)\$/\n         )\n    {                                    \n     my \$s = \$1;\n     \$c->tag('ol') unless \$c->tag eq 'ol';\n     \$parser->add_elem(li => \$s,\@expansion);\n    }\n   else\n    {                           \n     if (\$c->tag eq 'dt')\n      {\n       my \$e = make_elem('strong', \$expansion, \@expansion);\n       \$parser->add_elem('br' => \$e);\n      }\n     else\n      {\n       if (\$c->tag eq 'dd')                          \n        {                                            \n         \$parser->current(\$c = \$c->parent)           \n        }                                            \n       \$c->tag('dl') unless \$c->tag eq 'dl';         \n       my \$e = make_elem('strong', make_elem('p'), \$expansion, \@expansion);\n       my \$t = raw_text([\$expansion]);               \n       if (length \$t)\n        {\n         my \$name = \$parser->linktext(\$t);                                        \n         \$e = make_elem('a',{ name => substr(\$name,1) } , \$e ) if (defined \$name);\n        }\n       \$parser->current(\$parser->add_elem(dt => \$e));\n      }\n    }\n  }\n elsif (\$command eq 'back')\n  {\n   my \$c = \$parser->current;\n   \$parser->current(\$c = \$c->parent) if (\$c->tag eq 'dd');\n   if (\$c->tag =~ /^(ul|ol|dl)/)\n    {\n     \$parser->current(\$c->parent);\n    }\n  }\n elsif (\$command eq 'pod')\n  {\n\n  }\n elsif (\$command eq 'for')\n  {\n   my \$f = \$parser->input_file;\n   my \$t = raw_text(\\\@expansion);\n   # warn "\$f:for \$t\\n";\n   my \$c = \$parser->current;\n  }\n elsif (\$command eq 'begin')\n  {\n   my \$f = \$parser->input_file;\n   my \$t = raw_text(\\\@expansion);\n   warn "\$f:begin \$t\\n";\n   my \$c = \$parser->current;\n  }\n elsif (\$command eq 'end')\n  {\n   my \$t = raw_text(\\\@expansion);\n   my \$c = \$parser->current;\n  }\n else\n  {\n   warn "\$command not implemented\\n";\n   \$parser->add_elem(p => "=\$command ",\@expansion);\n  }\n}         \n\nsub end_pod\n{\n my \$parser = shift;\n\n \$parser->add_elem("p");\n \$parser->add_elem("hr");                                      \n unless (\$parser->{'NoDate'})\n  {\n   \$parser->add_elem("i", make_elem( font => { size => "-1" } , \n                                     "Last updated: ",scalar localtime));\n  }\n my \$html = \$parser->html;\n if (\$html)\n  {\n   my \$fh = \$parser->output_handle;\n   if (\$fh)\n    { \n     if (\$parser->{'PostScript'})\n      {\n       require HTML::FormatPS;\n       my \$formatter = new HTML::FormatPS\n                    FontFamily => 'Times', \n                    HorizontalMargin => HTML::FormatPS::mm(15),\n                    VerticalMargin => HTML::FormatPS::mm(20),\n                    PaperSize  => 'A4';\n       print \$fh \$formatter->format(\$html);\n      }\n     elsif (\$parser->{'Dump'})\n      {\n       \$Data::Dumper::Indent = 1;\n       print \$fh Dumper(\$html);\n      }\n     else\n      {\n       print \$fh \$html->as_HTML;\n      }\n    } \n   \$html->delete;\n  }\n}      \n\nsub write_index\n{\n my \$parser = shift;      \n my \$ifile = \$parser->{'Index'};\n if (defined \$ifile)\n  {my \$fh = IO::File->new(">\$ifile");\n   if (\$fh)\n    { \n     my \$html = HTML::Element->new('html');\n     my \$head = HTML::Element->new('head');\n     my \$body = HTML::Element->new('body');\n     \$html->push_content(\$head);\n     \$html->push_content(\$body);\n     \$body->push_content("\\n",h1('Table of Contents'),\$parser->{'index'},"\\n");\n     print \$fh \$html->as_HTML;\n     \$html->delete;\n     \$fh->close;\n    }\n  }\n}\n\nsub interior_sequence \n{\n die "Should not be called now";\n}\n\n1;\n__END__\n\n=head1 NAME\n\nPod::HTML_Elements - Convert POD to tree of LWP's HTML::Element and hence HTML or PostScript\n\n=head1 SYNOPSIS\n\n  use Pod::HTML_Elements;  \n\n  my \$parser = new Pod::HTML_Elements;\n  \$parser->parse_from_file(\$pod,'foo.html');\n\n  my \$parser = new Pod::HTML_Elements PostScript => 1;\n  \$parser->parse_from_file(\$pod,'foo.ps');\n\n=head1 DESCRIPTION\n\nB<Pod::HTML_Elements> is subclass of L<B<Pod::Parser>>. As the pod is parsed a tree of\nB<L<HTML::Element>> objects is built to represent HTML for the pod.\n\nAt the end of each pod HTML or PostScript representation is written to \nthe output file.   \n\n=head1 BUGS\n\nParameter pass-through to L<HTML::FormatPS> needs to be implemented.\n\n=head1 SEE ALSO \n\nL<perlpod>, L<Pod::Parser>, L<HTML::Element>, L<HTML::FormatPS>\n\n=head1 AUTHOR\n\nNick Ing-Simmons E<lt>nick\@ni-s.u-net.comE<gt>\n\n=cut \n\n
END_OF_FILE_AAAAAAAAAADH
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADI, "lib/Pod/Links.pm" }
package Pod::Links;      \nuse strict;            \nuse File::Basename;\nuse Carp;            \nuse Pod::Parser;\nuse vars qw(\@ISA \$VERSION \@EXPORT_OK);\n\$VERSION = '1.00';\nuse base qw(Exporter Pod::Parser);\n\@EXPORT_OK = qw(link_parse);\n\nsub link_parse\n{                          \n my (\$link,\$sec) = \@_;\n my (\$section,\$remote,\$category);\n my \$text = \$link;\n \$text = \$1 if \$link =~ s/^([^|]+)\\|(?=.)//;\n return (\$text,\$link) if \$link =~ m#[a-zA-Z]+://#;\n \$link =~ s/\\s+/ /g;\n \$sec = {} unless defined \$sec;\n if ((exists(\$sec->{\$link}) && \$link =~ /^(.*)\$/) ||\n     \$link =~ /^"(.*)"\$/ || \$link =~ m#^/"?(.*?)"?\$# ||\n     (\$link !~ m#/# && \$link =~ /^(.*\\s.*)\$/))\n  {\n   \$section = \$1 || \$link; \n  }                  \n elsif (\$link =~ m#^([^/]+)(?:/"?(.*?)"?)?\$#)\n  {\n   (\$remote,\$section) = (\$1,\$2);\n   \$category = \$2 if (\$remote =~ s/(\\w+)\\s*\\((.*)\\)\$/\$1/);\n   # \$section =~ s/\\W+\$// if defined \$section;\n  } \n return (\$text,\$section,\$remote,\$category);\n}\n\nsub begin_pod\n{\n my \$parser = shift;\n \$parser->{'links'} = {};\n \$parser->{'sections'} = {}; \n delete \$parser->{'NAME'};\n}\n\n\nsub new\n{\n my \$parser = shift->SUPER::new(\@_);\n \$parser->{'documents'} = {};\n return \$parser;\n}                            \n\nsub verbatim  \n{ \n my (\$parser, \$paragraph) = \@_;\n if (\$parser->{'inNAME'})\n  {\n   warn \$parser->input_file.": verbatim NAME section!\\n";\n   \$parser->{'NAME'} = \$paragraph;\n   \$parser->{'inNAME'} = 0;\n  }\n}\n\nsub textblock \n{ \n my (\$parser, \$paragraph) = \@_;\n if (\$parser->{'inNAME'})\n  {\n   my \$expansion = \$parser->interpolate(\$paragraph);\n   \$parser->{'NAME'} = \$expansion;\n   \$parser->{'inNAME'} = 0;\n  }\n}\n\nsub command \n{                   \n my (\$parser, \$command, \$paragraph) = \@_;\n my \$expansion = \$parser->interpolate(\$paragraph);\n \$expansion =~ s/(^\\s+|\\s+\$)//g;\n \$expansion =~ s/[\\s\\n]+/ /g;\n if (\$command =~ /^(head\\d)/ || (\$command eq 'item' && \$expansion !~ /^(\\*|\\d+\\.)/))\n  {   \n   \$parser->{'inNAME'} = (\$command eq 'head1' && \$expansion eq 'NAME');\n   if (\$command eq 'item' && \$expansion =~ /\\s/)\n    {                                        \n     \$parser->{'sections'}{\$expansion} |= 1;\n     (\$expansion) = split(/\\s/,\$expansion,2);\n    }\n   \$parser->{'sections'}{\$expansion} |= 1;\n  }\n}\n\nsub interior_sequence \n{\n my (\$parser, \$seq_command, \$seq_argument) = \@_;\n if (\$seq_command eq 'L')\n  {\n   my \$expansion = \$seq_argument;\n   \$expansion =~ s/(^\\s+|\\s+\$)//g;\n   \$expansion =~ s/^[^|]+\\|\\s*//;\n   \$expansion =~ s/[\\s\\n]+/ /g;\n   \$parser->{'links'}{\$expansion} = 0;\n  }                \n elsif (\$seq_command eq 'E')\n  {\n   return '>' if \$seq_argument eq 'gt';\n   return '<' if \$seq_argument eq 'lt';\n  }\n return \$seq_argument; \n} \n\nsub documents\n{\n my (\$parser) = \@_;\n return \$parser->{'documents'};\n}\n\nsub names\n{\n my (\$parser) = \@_;\n return sort keys %{\$parser->{'documents'}};\n}\n\nsub url\n{\n my (\$parser,\$sec,\$name,\$cat) = \@_;\n my \$url = '';\n return \$url unless \$sec || \$name;\n if (defined(\$name) && length(\$name))\n  {\n   my \$hash = \$parser->{'documents'}{\$name};\n   return undef unless defined \$hash->{'link'};\n   \$url .= \$hash->{'link'};\n  }\n if (defined \$sec)\n  {           \n   \$sec =~ s/[^A-Z0-9_]+/_/ig;\n   \$url .= "#\$sec";\n  }\n return \$url;\n}\n\nsub relative_url\n{        \n require URI::URL;\n my \$parser = shift;\n my \$source = URI::URL->newlocal(shift)->abs;\n my \$url = shift;\n if (\$url)\n  {\n   my \$uo = URI::URL->new(\$url,\$source)->abs;\n   my \$rel = \$uo->rel->as_string;\n   \$url = \$rel;\n  }\n return \$url;\n}      \n\n\nsub _attr\n{\n my (\$parser,\$key,\$name,\$val) = \@_;\n my \$hash = \$parser->{'documents'}{\$name};\n \$hash->{\$key} = \$val if (\@_ > 3);\n return \$hash->{\$key};\n}\n\nforeach my \$field (qw[pod name title sections link])\n {\n  no strict 'refs';\n  *{\$field} = sub { shift->_attr(\$field,\@_) }; \n }\n\nsub end_pod\n{\n my (\$parser) = \@_;\n my \$file = \$parser->input_file();\n warn "\$file\\n" if \$parser->{'Verbose'};\n my \$name = \$parser->{'NAME'};\n my \$links = delete \$parser->{'links'};\n my \$sec   = delete \$parser->{'sections'};\n my \$documents = \$parser->{'documents'};\n if (defined \$name)\n  {\n   my (\$doc,\$title) = \$name =~ /^\\s*(.+?)\\s+-+\\s+([\\s\\S]*?)\\s*\$/;\n   if (defined(\$doc))\n    {     \n     (\$doc) = split(/\\s*,\\s*/,\$doc,2) if (\$doc =~ /,/);\n     \$title =~ s/\\.\\s[\\s\\S]*\$//;\n     if (exists \$documents->{\$doc})\n      {        \n       my \$hash = \$documents->{\$doc};\n       if (exists \$hash->{'pod'})\n        {                \n         my \$old = \$hash->{'pod'};\n         warn "`\$doc' in \$old and \$file\\n";\n        }\n       foreach my \$section (keys %{\$hash->{'sections'}})\n        {               \n         if (exists \$sec->{\$section})\n          {\n           \$sec->{\$section} |= \$hash->{'sections'}{\$section};\n          }\n         else\n          {\n           warn "No section '\$section' in `\$doc' \$file\\n";\n          } \n        }\n      }\n\n     \$documents->{\$doc} = { name => \$doc, title => \$title, pod => \$file, sections => \$sec };\n\n     foreach my \$link (sort keys %\$links)\n      {\n       my (\$text,\$section,\$remote,\$category) = link_parse(\$link,\$sec);\n       if (defined \$remote)\n        {\n         unless (exists \$documents->{\$remote})\n          {                         \n           \$documents->{\$remote} = {'sections' => {}, 'refsfrom' => {}}; \n          }\n         \$documents->{\$remote}->{'sections'}{\$section} |= 4 if defined \$section;\n         \$documents->{\$remote}->{'refsfrom'}{\$file}++;\n        }\n       elsif (defined \$section)\n        {\n         \$sec->{\$section} |= 2;  # local ref \n        }\n       else\n        {\n         warn "Strange link L<\$link> in \$file\\n";\n        }\n      }\n    }\n   else\n    {\n     warn "Weird NAME '\$name' in \$file\\n";\n    }\n  }\n else\n  {\n   warn "No NAME in \$file\\n";\n  }\n}      \n\nsub check_links\n{\n my \$parser = shift;\n my \$documents = \$parser->{'documents'};\n foreach my \$doc (sort keys %\$documents)\n  {\n   my \$sec = \$documents->{\$doc}->{'sections'};\n   if (exists \$sec->{'NAME'})\n    {\n     foreach my \$section (sort keys %{\$sec})\n      {\n       my \$f = \$sec->{\$section};\n       if ((\$f & 4) && !(\$f & 1))\n        {\n         warn "Links to \$doc/\$section but never seen\\n";\n        }\n      }\n    }\n   else\n    {\n     my \$who = \$documents->{\$doc}->{'refsfrom'};\n     warn "Links to `\$doc' but never seen\\n";\n     foreach my \$file (sort keys %\$who)\n      {\n       printf STDERR "%3d \$file\\n",\$who->{\$file};\n      }\n    }\n  }\n}      \n\n\n\n1; \n__END__\n
END_OF_FILE_AAAAAAAAAADI
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADJ, "lib/Pod/Find.pm" }
package Pod::Find;     \nuse Exporter;\nuse File::Find;\n\n\@ISA = qw(Exporter);\n\@EXPORT = qw(find_pods contains_pod);\n\nuse strict;\nuse vars qw(%seen_file \@pod_files);\n\nsub find_pods\n{\n local %seen_file;\n local \@pod_files;\n find( \\&pod_finder, \@_);\n return \@pod_files;\n}\n\nsub pod_finder\n{\n unless (\$seen_file{\$File::Find::name})\n  {\n   my \$is_pod = 0;                        \n   if (/\\.(?:pm|pod|pl)\$/i || (-f \$_ && -x _ && -T _))\n    {                                     \n     \$is_pod = contains_pod(\$_)           \n    }                                     \n\n   push(\@pod_files,\$File::Find::name) if (\$seen_file{\$File::Find::name} = \$is_pod); \n   \n   if (-d \$_)\n    {\n     if (/^(\\d+\\.[\\d_]+)\$/)\n      {\n       unless (eval "\$1" == \$])\n        {\n         \$File::Find::prune = 1;\n         warn "perl\$] skipping \$File::Find::name/...\\n";\n         return;\n        }\n      }\n    }\n  }         \n}    \n\nsub contains_pod\n{  \n my \$file = shift;\n local \$/ = '';        \n my \$pod = 0;\n if (open(POD,"<\$file"))\n  {\n   local \$_;  \n   while (<POD>)\n    {         \n     if (\$pod = /^=head\\d\\s/)\n      {\n       last; \n      }      \n    }         \n   close(POD);\n  }\n else\n  {\n   warn "Cannot open \$file:\$!\\n";\n  }\n return \$pod;\n}\n\n\n1;\n__END__\n
END_OF_FILE_AAAAAAAAAADJ
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADK, "lib/IPC/Run.pm" }
package IPC::Run ;\n#\n# Copyright (c) 1999 by Barrie Slaymaker, barries\@slaysys.com\n#\n# You may distribute under the terms of either the GNU General Public\n# License or the Artistic License, as specified in the README file.\n#\n\n=head1 NAME\n\nIPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32)\n\n=head1 SYNOPSIS\n\n   ## First,a command to run:\n      my \@cat = qw( cat ) ;\n\n   ## Using run() instead of system():\n      use IPC::Run qw( run timeout ) ;\n\n      run \\\@cmd, \\\$in, \\\$out, \\\$err, timeout( 10 ) or die "cat: \$?"\n\n      # Can do I/O to sub refs and filenames, too:\n      run \\\@cmd, "in.txt", \\&out, \\&err or die "cat: \$?"\n      run \\\@cat, "in.txt", '>>', "out.txt", '2>>', "err.txt" ;\n\n\n      # Redirecting using psuedo-terminals instad of pipes.\n      run \\\@cat, '<pty<', \\\$in,  '>pty>', \\\$out_and_err ;\n\n   ## Scripting subprocesses (like Expect):\n\n      use IPC::Run qw( start pump finish timeout ) ;\n\n      # Incrementally read from / write to scalars. \n      # \$in is drained as it is fed to cat's stdin,\n      # \$out accumulates cat's stdout\n      # \$err accumulates cat's stderr\n      # \$h is for "harness".\n      my \$h = start \\\@cat, \\\$in, \\\$out, \\\$err, timeout( 10 ) ;\n\n      \$in_q .= "some input\\n" ;\n      pump \$h until \$out_q =~ /input\\n/g ;\n\n      \$in_q .= "some more input\\n" ;\n      pump \$h until \$out_q =~ /\\G.*more input\\n/ ;\n\n      \$in_q .= "some final input\\n" ;\n      finish \$h or die "cat returned \$?" ;\n\n      warn \$err_q if \$err_q ; \n      print \$out_q ;         ## All of cat's output\n\n   # Piping between children\n      run \\\@cat, '|', \\\@gzip ;\n\n   # Multiple children simultaneously (run() blocks until all\n   # children exit, use start() for background execution):\n      run \\\@foo1, '&', \\\@foo2 ;\n\n   # Calling \\&set_up_child in the child before it executes the\n   # command (only works on systems with true fork() & exec())\n   # exceptions thrown in set_up_child() will be propagated back\n   # to the parent and thrown from run().\n      run \\\@cat, \\\$in, \\\$out,\n         init => \\&set_up_child ;\n\n   # Read from / write to file handles you open and close\n      open IN,  '<in.txt'  or die \$! ;\n      open OUT, '>out.txt' or die \$! ;\n      print OUT "preamble\\n" ;\n      run \\\@cat, \\*IN, \\*OUT or die "cat returned \$?" ;\n      print OUT "postamble\\n" ;\n      close IN ;\n      close OUT ;\n\n   # Create pipes for you to read / write (like IPC::Open2 & 3).\n      \$h = start\n         \\\@cat,\n            '<pipe', \\*IN,\n            '>pipe', \\*OUT,\n            '2>pipe', \\*ERR \n         or die "cat returned \$?" ;\n      print IN "some input\\n" ;\n      close IN ;\n      print <OUT>, <ERR> ;\n      finish \$h ;\n\n   # Mixing input and output modes\n      run \\\@cat, 'in.txt', \\&catch_some_out, \\*ERR_LOG ) ;\n\n   # Other redirection constructs\n      run \\\@cat, '>&', \\\$out_and_err ;\n      run \\\@cat, '2>&1' ;\n      run \\\@cat, '0<&3' ;\n      run \\\@cat, '<&-' ;\n      run \\\@cat, '3<', \\\$in3 ;\n      run \\\@cat, '4>', \\\$out4 ;\n      # etc.\n\n   # Passing options:\n      run \\\@cat, 'in.txt', debug => 1 ;\n\n   # Call this system's shell, returns TRUE on 0 exit code\n   # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE\n      run "cat a b c" or die "cat returned \$?" ;\n\n   # Launch a sub process directly, no shell.  Can't do redirection\n   # with this form, it's here to behave like system() with an\n   # inverted result.\n      \$r = run "cat a b c" ;\n\n   # Read from a file in to a scalar\n      run io( "filename", 'r', \\\$recv ) ;\n      run io( \\*HANDLE,   'r', \\\$recv ) ;\n\n=head1 DESCRIPTION\n\nIPC::Run allows you run and interact with child processes using files, pipes,\nand pseudo-ttys.  Both system()-style and scripted usages are supported and\nmay be mixed.  Likewise, functional and OO API styles are both supported and\nmay be mixed.\n\nVarious redirection operators reminiscent of those seen on common Unix and DOS\ncommand lines are provided.\n\nBefore digging in to the details a few LIMITATIONS are important enough\nto be mentioned right up front:\n\n=over\n\n=item Win32 Support\n\nWin32 support is working but B<EXPERIMENTAL>, but does pass all relevant tests\non NT 4.0.  See L</Win32 LIMITATIONS>.\n\n=item pty Support\n\nIf you need pty support, IPC::Run should work well enough most of the\ntime, but IO::Pty is being improved, and IPC::Run will be improved to\nuse IO::Pty's new features when it is release.\n\nThe basic problem is that the pty needs to initialize itself before the\nparent writes to the master pty, or the data written gets lost.  So\nIPC::Run does a sleep(1) in the parent after forking to (hopefully) give\nthe child a chance to run.  This is a kludge that works well on non\nheavily loaded systems :(.\n\nptys are not supported yet under Win32, but will be emulated...\n\n=item Debugging Tip\n\nYou may use the environment variable C<IPCRUNDEBUG> to see what's going on\nunder the hood:\n\n   \$ IPCRUNDEBUG=basic   myscript     # prints minimal debugging\n   \$ IPCRUNDEBUG=data    myscript     # prints all data reads/writes\n   \$ IPCRUNDEBUG=details myscript     # prints lots of low-level details\n   \$ IPCRUNDEBUG=gory    myscript     # (Win32 only) prints data moving through\n                                      # the helper processes.\n\n=back\n\nWe now return you to your regularly scheduled documentation.\n\n=head2 Harnesses\n\nChild processes and I/O handles are gathered in to a harness, then\nstarted and run until the processing is finished or aborted.\n\n=head2 run() vs. start(); pump(); finish();\n\nThere are two modes you can run harnesses in: run() functions as an\nenhanced system(), and start()/pump()/finish() allow for background\nprocesses and scripted interactions with them.\n\nWhen using run(), all data to be sent to the harness is set up in\nadvance (though one can feed subprocesses input from subroutine refs to\nget around this limitation). The harness is run and all output is\ncollected from it, then any child processes are waited for:\n\n   run \\\@cmd, \\<<IN, \\\$out ;\n   blah\n   IN\n\n   ## To precompile harnesses and run them later:\n   my \$h = harness \\\@cmd, \\<<IN, \\\$out ;\n   blah\n   IN\n\n   run \$h ;\n\nThe background and scripting API is provided by start(), pump(), and\nfinish(): start() creates a harness if need be (by calling harness())\nand launches any subprocesses, pump() allows you to poll them for\nactivity, and finish() then monitors the harnessed activities until they\ncomplete.\n\n   ## Build the harness, open all pipes, and launch the subprocesses\n   my \$h = start \\\@cat, \\\$in, \\\$out ;\n   \$in = "first input\\n" ;\n\n   ## Now do I/O.  start() does no I/O.\n   pump \$h while length \$in ;  ## Wait for all input to go\n\n   ## Now do some more I/O.\n   \$in = "second input\\n" ;\n   pump \$h until \$out =~ /second input/ ;\n\n   ## Clean up\n   finish \$h or die "cat returned \$?" ;\n\nYou can optionally compile the harness with harness() prior to\nstart()ing or run()ing, and you may omit start() between harness() and\npump().  You might want to do these things if you compile your harnesses\nahead of time.\n\n=head2 Using regexps to match output\n\nAs shown in most of the scripting examples, the read-to-scalar facility\nfor gathering subcommand's output is often used with regular expressions\nto detect stopping points.  This is because subcommand output often\narrives in dribbles and drabs, often only a character or line at a time.\nThis output is input for the main program and piles up in variables like\nthe C<\$out> and C<\$err> in our examples.\n\nRegular expressions can be used to wait for appropriate output in\nseveral ways.  The C<cat> example in the previous section demonstrates\nhow to pump() until some string appears in the output.  Here's an\nexample that uses C<smb> to fetch files from a remote server:\n\n   \$h = harness \\\@smbclient, \\\$in, \\\$out ;\n\n   \$in = "cd /src\\n" ;\n   \$h->pump until \$out =~ /^smb.*> \\Z/m ;\n   die "error cding to /src:\\n\$out" if \$out =~ "ERR" ;\n   \$out = '' ;\n\n   \$in = "mget *\\n" ;\n   \$h->pump until \$out =~ /^smb.*> \\Z/m ;\n   die "error retrieving files:\\n\$out" if \$out =~ "ERR" ;\n\n   \$in = "quit\\n" ;\n   \$h->finish ;\n\nNotice that we carefully clear \$out after the first command/response\ncycle? That's because IPC::Run does not delete \$out when we continue,\nand we don't want to trip over the old output in the second\ncommand/response cycle.\n\nSay you want to accumulate all the output in \$out and analyze it\nafterwards.  Perl offers incremental regular expression matching using\nthe C<m//gc> and pattern matching idiom and the C<\\G> assertion.\nIPC::Run is careful not to disturb the current C<pos()> value for\nscalars it appends data to, so we could modify the above so as not to\ndestroy \$out by adding a couple of C</gc> modifiers.  The C</g> keeps us\nfrom tripping over the previous prompt and the C</c> keeps us from\nresetting the prior match position if the expected prompt doesn't\nmaterialize immediately:\n\n   \$h = harness \\\@smbclient, \\\$in, \\\$out ;\n\n   \$in = "cd /src\\n" ;\n   \$h->pump until \$out =~ /^smb.*> \\Z/mgc ;\n   die "error cding to /src:\\n\$out" if \$out =~ "ERR" ;\n\n   \$in = "mget *\\n" ;\n   \$h->pump until \$out =~ /^smb.*> \\Z/mgc ;\n   die "error retrieving files:\\n\$out" if \$out =~ "ERR" ;\n\n   \$in = "quit\\n" ;\n   \$h->finish ;\n\n   analyze( \$out ) ;\n\nWhen using this technique, you may want to preallocate \$out to have\nplenty of memory or you may find that the act of growing \$out each time\nnew input arrives causes an C<O(length(\$out)^2)> slowdown as \$out grows.\nSay we expect no more than 10,000 characters of input at the most.  To\npreallocate memory to \$out, do something like:\n\n   my \$out = "x" x 10_000 ;\n   \$out = "" ;\n\nC<perl> will allocate at least 10,000 characters' worth of space, then\nmark the \$out as having 0 length without freeing all that yummy RAM.\n\n=head2 Timeouts and Timers\n\nMore than likely, you don't want your subprocesses to run forever, and\nsometimes it's nice to know that they're going a little slowly.\nTimeouts throw exceptions after a some time has elapsed, timers merely\ncause pump() to return after some time has elapsed.  Neither is\nreset/restarted automatically.\n\nTimeout objects are created by calling timeout( \$interval ) and passing\nthe result to run(), start() or harness().  The timeout period starts\nticking just after all the child processes have been fork()ed or\nspawn()ed, and are polled for expiration in run(), pump() and finish().\nIf/when they expire, an exception is thrown.  This is typically useful\nto keep a subprocess from taking too long.\n\nIf a timeout occurs in run(), all child processes will be terminated and\nall file/pipe/ptty descriptors opened by run() will be closed.  File\ndescriptors opened by the parent process and passed in to run() are not\nclosed in this event.\n\nIf a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to\ndecide whether to kill_kill() all the children or to implement some more\ngraceful fallback.  No I/O will be closed in pump(), pump_nb() or\nfinish() by such an exception (though I/O is often closed down in those\nroutines during the natural course of events).\n\nOften an exception is too harsh.  timer( \$interval ) creates timer\nobjects that merely prevent pump() from blocking forever.  This can be\nuseful for detecting stalled I/O or printing a soothing message or "."\nto pacify an anxious user.\n\nTimeouts and timers can both be restarted at any time using the timer's\nstart() method (this is not the start() that launches subprocesses).  To\nrestart a timer, you need to keep a reference to the timer:\n\n   ## Start with a nice long timeout to let smbclient connect.  If\n   ## pump or finish take too long, an exception will be thrown.\n\n my \$h ;\n eval {\n   \$h = harness \\\@smbclient, \\\$in, \\\$out, \\\$err, ( my \$t = timeout 30 ) ;\n   sleep 11 ;  # No effect: timer not running yet\n\n   start \$h ;\n   \$in = "cd /src\\n" ;\n   pump \$h until ! length \$in ;\n\n   \$in = "ls\\n" ;\n   ## Now use a short timeout, since this should be faster\n   \$t->start( 5 ) ;\n   pump \$h until ! length \$in ;\n\n   \$t->start( 10 ) ;  ## Give smbclient a little while to shut down.\n   \$h->finish ;\n } ;\n if ( \$\@ ) {\n   my \$x = \$\@ ;    ## Preserve \$\@ in case another exception occurs\n   \$h->kill_kill ; ## kill it gently, then brutally if need be, or just\n                   ## brutally on Win32.\n   die \$x ;\n }\n\nTimeouts and timers are I<not> checked once the subprocesses are shut\ndown; they will not expire in the interval between the last valid\nprocess and when IPC::Run scoops up the processes' result codes, for\ninstance.\n\n=head2 Spawning synchronization, child exception propagation\n\nstart() pauses the parent until the child executes the command or CODE\nreference and propagates any exceptions thrown (including exec()\nfailure) back to the parent.  This has several pleasant effects: any\nexceptions thrown in the child, including exec() failure, come flying\nout of start() or run() as though they had ocurred in the parent.\n\nThis includes exceptions your code thrown from init subs.  In this\nexample:\n\n   eval {\n      run \\\@cmd, init => sub { die "blast it! foiled again!" } ;\n   } ;\n   print \$\@ ;\n\nthe exception "blast it! foiled again" will be thrown from the child\nprocess (preventing the exec()) and printed by the parent.\n\nIn situations like\n\n   run \\\@cmd1, "|", \\\@cmd2, "|", \\\@cmd3 ;\n\n\@cmd1 will be initted and exec()ed before \@cmd2, and \@cmd2 before \@cmd3.\nThis can save time and prevent oddball errors emitted by later commands\nwhen earlier commands fail to execute.  Note that IPC::Run doesn't start\nany commands unless it can find the executables referenced by all\ncommands.  These executables must pass both the C<-f> and C<-x> tests\ndescribed in L<perlfunc>.\n\nAnother nice effect is that init() subs can take their time doing things\nand there will be no problems caused by a parent continuing to execute\nbefore a child's init() routine is complete.  Say the init() routine\nneeds to open a socket or a temp file that the parent wants to connect\nto; without this synchronization, the parent will need to implement a\nretry loop to wait for the child to run, since often, the parent gets a\nlot of things done before the child's first timeslice is allocated.\n\nThis is also quite necessary for pseudo-tty initialization, which needs\nto take place before the parent writes to the child via pty.  Writes\nthat occur before the pty is set up can get lost.\n\nA final, minor, nicety is that debugging output from the child will be\nemitted before the parent continues on, making for much clearer debugging\noutput in complex situations.\n\nThe only drawback I can conceive of is that the parent can't continue to\noperate while the child is being initted.  If this ever becomes a\nproblem in the field, we can implement an option to avoid this behavior,\nbut I don't expect it to.\n\nB<Win32>: executing CODE references isn't supported on Win32, see\nL</Win32 LIMITATIONS> for details.\n\n=head2 Syntax\n\nrun(), start(), and harness() can all take a harness specification\nas input.  A harness specification is either a single string to be passed\nto the systems' shell:\n\n   run "echo 'hi there'" ;\n\nor a list of commands, io operations, and/or timers/timeouts to execute.\nConsecutive commands must be separated by a pipe operator '|' or an '&'.\nExternal commands are passed in as array references, and, on systems\nsupporting fork(), Perl code may be passed in as subs:\n\n   run \\\@cmd ;\n   run \\\@cmd1, '|', \\\@cmd2 ;\n   run \\\@cmd1, '&', \\\@cmd2 ;\n   run \\&sub1 ;\n   run \\&sub1, '|', \\&sub2 ;\n   run \\&sub1, '&', \\&sub2 ;\n\n'|' pipes the stdout of \\\@cmd1 the stdin of \\\@cmd2, just like a\nshell pipe.  '&' does not.  Child processes to the right of a '&'\nwill have their stdin closed unless it's redirected-to.\n\nL<IPC::Run::IO> objects may be passed in as well, whether or not\nchild processes are also specified:\n\n   run io( "infile", ">", \\\$in ), io( "outfile", "<", \\\$in ) ;\n      \nas can L<IPC::Run::Timer> objects:\n\n   run \\\@cmd, io( "outfile", "<", \\\$in ), timeout( 10 ) ;\n\nCommands may be followed by scalar, sub, or i/o handle references for\nredirecting\nchild process input & output:\n\n   run \\\@cmd,  \\undef,            \\\$out ;\n   run \\\@cmd,  \\\$in,              \\\$out ;\n   run \\\@cmd1, \\&in, '|', \\\@cmd2, \\*OUT ;\n   run \\\@cmd1, \\*IN, '|', \\\@cmd2, \\&out ;\n\nThis is known as succinct redirection syntax, since run(), start()\nand harness(), figure out which file descriptor to redirect and how.\nFile descriptor 0 is presumed to be an input for\nthe child process, all others are outputs.  The assumed file\ndescriptor always starts at 0, unless the command is being piped to,\nin which case it starts at 1.\n\nTo be explicit about your redirects, or if you need to do more complex\nthings, there's also a redirection operator syntax:\n\n   run \\\@cmd, '<', \\undef, '>',  \\\$out ;\n   run \\\@cmd, '<', \\undef, '>&', \\\$out_and_err ;\n   run(\n      \\\@cmd1,\n         '<', \\\$in,\n      '|', \\\@cmd2,\n         \\\$out\n   ) ;\n\nOperator syntax is required if you need to do something other than simple\nredirection to/from scalars or subs, like duping or closing file descriptors\nor redirecting to/from a named file.  The operators are covered in detail\nbelow.\n\nAfter each \\\@cmd (or \\&foo), parsing begins in succinct mode and toggles to\noperator syntax mode when an operator (ie plain scalar, not a ref) is seen.\nOnce in\noperator syntax mode, parsing only reverts to succinct mode when a '|' or\n'&' is seen.\n\nIn succinct mode, each parameter after the \\\@cmd specifies what to\ndo with the next highest file descriptor. These File descriptor start\nwith 0 (stdin) unless stdin is being piped to (C<'|', \\\@cmd>), in which\ncase they start with 1 (stdout).  Currently, being on the left of\na pipe (C<\\\@cmd, \\\$out, \\\$err, '|'>) does I<not> cause stdout to be\nskipped, though this may change since it's not as DWIMerly as it\ncould be.  Only stdin is assumed to be an\ninput in succinct mode, all others are assumed to be outputs.\n\nIf no piping or redirection is specified for a child, it will inherit\nthe parent's open file handles as dictated by your system's\nclose-on-exec behavior and the \$^F flag, except that processes after a\n'&' will not inherit the parent's stdin. Also note that \$^F does not\naffect file desciptors obtained via POSIX, since it only applies to\nfull-fledged Perl file handles.  Such processes will have their stdin\nclosed unless it has been redirected-to.\n\nIf you want to close a child processes stdin, you may do any of:\n\n   run \\\@cmd, \\undef ;\n   run \\\@cmd, \\"" ;\n   run \\\@cmd, '<&-' ;\n   run \\\@cmd, '0<&-' ;\n\nRedirection is done by placing redirection specifications immediately \nafter a command or child subroutine:\n\n   run \\\@cmd1,      \\\$in, '|', \\\@cmd2,      \\\$out ;\n   run \\\@cmd1, '<', \\\$in, '|', \\\@cmd2, '>', \\\$out ;\n\nIf you omit the redirection operators, descriptors are counted\nstarting at 0.  Descriptor 0 is assumed to be input, all others\nare outputs.  A leading '|' consumes descriptor 0, so this\nworks as expected.\n\n   run \\\@cmd1, \\\$in, '|', \\\@cmd2, \\\$out ;\n   \nThe parameter following a redirection operator can be a scalar ref,\na subroutine ref, a file name, an open filehandle, or a closed\nfilehandle.\n\nIf it's a scalar ref, the child reads input from or sends output to\nthat variable:\n\n   \$in = "Hello World.\\n" ;\n   run \\\@cat, \\\$in, \\\$out ;\n   print \$out ;\n\nScalars used in incremental (start()/pump()/finish()) applications are treated\nas queues: input is removed from input scalers, resulting in them dwindling\nto '', and output is appended to output scalars.  This is not true of \nharnesses run() in batch mode.\n\nIt's usually wise to append new input to be sent to the child to the input\nqueue, and you'll often want to zap output queues to '' before pumping.\n\n   \$h = start \\\@cat, \\\$in_q ;\n   \$in_q = "line 1\\n" ;\n   pump \$h ;\n   \$in_q .= "line 2\\n" ;\n   pump \$h ;\n   \$in_q .= "line 3\\n" ;\n   finish \$h ;\n\nThe final call to finish() must be there: it allows the child process(es)\nto run to completion and waits for their exit values.\n\n=head1 OBSTINATE CHILDREN\n\nInteractive applications are usually optimized for human use.  This\ncan help or hinder trying to interact with them through modules like\nIPC::Run.  Frequently, programs alter their behavior when they detect\nthat stdin, stdout, or stderr are not connected to a tty, assuming that\nthey are being run in batch mode.  Whether this helps or hurts depends\non which optimizations change.  And there's often no way of telling\nwhat a program does in these areas other than trial and error and,\noccasionally, reading the source.  This includes different versions\nand implementations of the same program.\n\nAll hope is not lost, however.  Most programs behave in reasonably\ntractable manners, once you figure out what it's trying to do.\n\nHere are some of the issues you might need to be aware of.\n\n=over\n\n=item *\n\nfflush()ing stdout and stderr\n\nThis lets the user see stdout and stderr immediately.  Many programs\nundo this optimization if stdout is not a tty, making them harder to\nmanage by things like IPC::Run.\n\nMany programs decline to fflush stdout or stderr if they do not\ndetect a tty there.  Some ftp commands do this, for instance.\n\nIf this happens to you, look for a way to force interactive behavior,\nlike a command line switch or command.  If you can't, you will\nneed to use a pseudo terminal ('<pty<' and '>pty>').\n\n=item *\n\nfalse prompts\n\nInteractive programs generally do not guarantee that output from user\ncommands won't contain a prompt string.  For example, your shell prompt\nmight be a '\$', and a file named '\$' might be the only file in a directory\nlisting.\n\nThis can make it hard to guarantee that your output parser won't be fooled\ninto early termination of results.\n\nTo help work around this, you can see if the program can alter it's \nprompt, and use something you feel is never going to occur in actual\npractice.\n\nYou should also look for your prompt to be the only thing on a line:\n\n   pump \$h until \$out =~ /^<SILLYPROMPT>\\s?\\z/m ;\n\n(use C<(?!\\n)\\Z> in place of C<\\z> on older perls).\n\nYou can also take the approach that IPC::ChildSafe takes and emit a\ncommand with known output after each 'real' command you issue, then\nlook for this known output.  See new_appender() and new_chunker() for\nfilters that can help with this task.\n\nIf it's not convenient or possibly to alter a prompt or use a known\ncommand/response pair, you might need to autodetect the prompt in case\nthe local version of the child program is different then the one\nyou tested with, or if the user has control over the look & feel of\nthe prompt.\n\n=item *\n\nRefusing to accept input unless stdin is a tty.\n\nSome programs, for security reasons, will only accept certain types\nof input from a tty.  su, notable, will not prompt for a password unless\nit's connected to a tty.\n\nIf this is your situation, use a pseudo terminal ('<pty<' and '>pty>').\n\n=item *\n\nNot prompting unless connected to a tty.\n\nSome programs don't prompt unless stdin or stdout is a tty.  See if you can\nturn prompting back on.  If not, see if you can come up with a command that\nyou can issue after every real command and look for it's output, as\nIPC::ChildSafe does.   There are two filters included with IPC::Run that\ncan help with doing this: appender and chunker (see new_appender() and\nnew_chunker()).\n\n=item *\n\nDifferent output format when not connected to a tty.\n\nSome commands alter their formats to ease machine parsability when they\naren't connected to a pipe.  This is actually good, but can be surprising.\n\n=back\n\n=head1 PSEUDO TERMINALS\n\nOn systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty\n(available on CPAN) to provide a terminal environment to subprocesses.\nThis is necessary when the subprocess really wants to think it's connected\nto a real terminal.\n\n=head2 CAVEATS\n\nPsuedo-terminals are not pipes, though they are similar.  Here are some\ndifferences to watch out for.\n\n=over\n\n=item Echoing\n\nSending to stdin will cause an echo on stdout, which occurs before each\nline is passed to the child program.  There is currently no way to\ndisable this, although the child process can and should disable it for\nthings like passwords.\n\n=item Shutdown\n\nIPC::Run cannot close a pty until all output has been collected.  This\nmeans that it is not possible to send an EOF to stdin by half-closing\nthe pty, as we can when using a pipe to stdin.\n\nThis means that you need to send the child process an exit command or\nsignal, or run() / finish() will time out.  Be careful not to expect a\nprompt after sending the exit command.\n\n=item Command line editing\n\nSome subprocesses, notable shells that depend on the user's prompt\nsettings, will reissue the prompt plus the command line input so far\nonce for each character.\n\n=item '>pty>' means '&>pty>', not '1>pty>'\n\nThe pseudo terminal redirects both stdout and stderr unless you specify\na file descriptor.  If you want to grab stderr separately, do this:\n\n   start \\\@cmd, '<pty<', \\\$in, '>pty>', \\\$out, '2>', \\\$err ;\n\n=item stdin, stdout, and stderr not inherited\n\nChild processes harnessed to a pseudo terminal have their stdin, stdout,\nand stderr completely closed before any redirection operators take\neffect.  This casts of the bonds of the controlling terminal.  This is\nnot done when using pipes.\n\nRight now, this affects all children in a harness that has a pty in use,\neven if that pty would not affect a particular child.  That's a bug and\nwill be fixed.  Until it is, it's best not to mix-and-match children.\n\n=back\n\n=head2 Redirection Operators\n\n   Operator       SHNP   Description\n   ========       ====   ===========\n   <, N<          SHN    Redirects input to a child's fd N (0 assumed)\n\n   >, N>          SHN    Redirects output from a child's fd N (1 assumed)\n   >>, N>>        SHN    Like '>', but appends to scalars or named files\n   >&, &>         SHN    Redirects stdout & stderr from a child process\n\n   <pty, N<pty    S      Like '<', but uses a pseudo-tty instead of a pipe\n   >pty, N>pty    S      Like '>', but uses a pseudo-tty instead of a pipe\n\n   N<&M                  Dups input fd N to input fd M\n   M>&N                  Dups output fd N to input fd M\n   N<&-                  Closes fd N\n\n   <pipe, N<pipe     P   Pipe opens H for caller to read, write, close.\n   >pipe, N>pipe     P   Pipe opens H for caller to read, write, close.\n                      \n'N' and 'M' are placeholders for integer file descriptor numbers.  The\nterms 'input' and 'output' are from the child process's perspective.\n\nThe SHNP field indicates what parameters an operator can take:\n\n   S: \\\$scalar or \\&function references.  Filters may be used with\n      these operators (and only these).\n   H: \\*HANDLE or IO::Handle for caller to open, and close\n   N: "file name".\n   P: \\*HANDLE opened by IPC::Run as the parent end of a pipe, but read\n      and written to and closed by the caller (like IPC::Open3).\n\n=over\n\n=item Redirecting input: [n]<, [n]<pipe\n\nYou can input the child reads on file descriptor number n to come from a\nscalar variable, subroutine, file handle, or a named file.  If stdin\nis not redirected, the parent's stdin is inherited.\n\n   run \\\@cat, \\undef          ## Closes child's stdin immediately\n      or die "cat returned \$?" ; \n\n   run \\\@cat, \\\$in ;\n\n   run \\\@cat, \\<<TOHERE ;\n   blah\n   TOHERE\n\n   run \\\@cat, \\&input ;       ## Calls &input, feeding data returned\n                              ## to child's.  Closes child's stdin\n                              ## when undef is returned.\n\nRedirecting from named files requires you to use the input\nredirection operator:\n\n   run \\\@cat, '<.profile' ;\n   run \\\@cat, '<', '.profile' ;\n\n   open IN, "<foo" ;\n   run \\\@cat, \\*IN ;\n   run \\\@cat, *IN{IO} ;\n\nThe form used second example here is the safest,\nsince filenames like "0" and "&more\\n" won't confuse &run:\n\nYou can't do either of\n\n   run \\\@a, *IN ;      ## INVALID\n   run \\\@a, '<', *IN ; ## BUGGY: Reads file named like "*main::A"\n   \nbecause perl passes a scalar containing a string that\nlooks like "*main::A" to &run, and &run can't tell the difference\nbetween that and a redirection operator or a file name.  &run guarantees\nthat any scalar you pass after a redirection operator is a file name.\n\nIf your child process will take input from file descriptors other\nthan 0 (stdin), you can use a redirection operator with any of the\nvalid input forms (scalar ref, sub ref, etc.):\n\n   run \\\@cat, '3<', \\\$in3_q ;\n\nWhen redirecting input from a scalar ref, the scalar ref is\nused as a queue.  This allows you to use &harness and pump() to\nfeed incremental bits of input to a coprocess.  See L</Coprocesses>\nbelow for more information.\n\nThe <pipe operator opens the write half of a pipe on the filehandle\nglob reference it takes as an argument:\n\n   \$h = start \\\@cat, '<pipe', \\*IN ;\n   print IN "hello world\\n" ;\n   pump \$h ;\n   close IN ;\n   finish \$h ;\n\nUnlike the other '<' operators, IPC::Run does nothing further with\nit: you are responsible for it.  The previous example is functionally\nequivalent to:\n\n   pipe( \\*R, \\*IN ) or die \$! ;\n   \$h = start \\\@cat, '<', \\*IN ;\n   print IN "hello world\\n" ;\n   pump \$h ;\n   close IN ;\n   finish \$h ;\n\nThis is like the behavior of IPC::Open2 and IPC::Open3.\n\nB<Win32>: The handle returned is actually a socket handle, so you can\nuse select() on it.\n\n=item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe\n\nYou can redirect any output the child emits\nto a scalar variable, subroutine, file handle, or file name.  You\ncan have &run truncate or append to named files or scalars.  If\nyou are redirecting stdin as well, or if the command is on the\nreceiving end of a pipeline ('|'), you can omit the redirection\noperator:\n\n   \@ls = ( 'ls' ) ;\n   run \\\@ls, \\undef, \\\$out\n      or die "ls returned \$?" ; \n\n   run \\\@ls, \\undef, \\&out ;  ## Calls &out each time some output\n                              ## is received from the child's \n                              ## when undef is returned.\n\n   run \\\@ls, \\undef, '2>ls.err' ;\n   run \\\@ls, '2>', 'ls.err' ;\n\nThe two parameter form guarantees that the filename\nwill not be interpreted as a redirection operator:\n\n   run \\\@ls, '>', "&more" ;\n   run \\\@ls, '2>', ">foo\\n" ;\n\nYou can pass file handles you've opened for writing:\n\n   open( *OUT, ">out.txt" ) ;\n   open( *ERR, ">err.txt" ) ;\n   run \\\@cat, \\*OUT, \\*ERR ;\n\nPassing a scalar reference and a code reference requires a little\nmore work, but allows you to capture all of the output in a scalar\nor each piece of output by a callback:\n\nThese two do the same things:\n\n   run( [ 'ls' ], '2>', sub { \$err_out .= \$_[0] } ) ;\n\ndoes the same basic thing as:\n\n   run( [ 'ls' ], '2>', \\\$err_out ) ;\n\nThe subroutine will be called each time some data is read from the child.\n\nThe >pipe operator is different in concept than the other '>' operators,\nalthough it's syntax is similar:\n\n   \$h = start \\\@cat, \$in, '>pipe', \\*OUT, '2>pipe', \\*ERR ;\n   \$in = "hello world\\n" ;\n   finish \$h ;\n   print <OUT> ;\n   print <ERR> ;\n   close OUT ;\n   close ERR ;\n\ncauses two pipe to be created, with one end attached to cat's stdout\nand stderr, respectively, and the other left open on OUT and ERR, so\nthat the script can manually\nread(), select(), etc. on them.  This is like\nthe behavior of IPC::Open2 and IPC::Open3.\n\nB<Win32>: The handle returned is actually a socket handle, so you can\nuse select() on it.\n\n=item Duplicating output descriptors: >&m, n>&m\n\nThis duplicates output descriptor number n (default is 1 if n is omitted)\nfrom descriptor number m.\n\n=item Duplicating input descriptors: <&m, n<&m\n\nThis duplicates input descriptor number n (default is 0 if n is omitted)\nfrom descriptor number m\n\n=item Closing descriptors: <&-, 3<&-\n\nThis closes descriptor number n (default is 0 if n is omitted).  The\nfollowing commands are equivalent:\n\n   run \\\@cmd, \\undef ;\n   run \\\@cmd, '<&-' ;\n   run \\\@cmd, '<in.txt', '<&-' ;\n\nDoing\n\n   run \\\@cmd, \\\$in, '<&-' ;    ## SIGPIPE recipe.\n\nis dangerous: the parent will get a SIGPIPE if \$in is not empty.\n\n=item Redirecting both stdout and stderr: &>, >&, &>pipe, >pipe&\n\nThe following pairs of commands are equivalent:\n\n   run \\\@cmd, '>&', \\\$out ;       run \\\@cmd, '>', \\\$out,     '2>&1' ;\n   run \\\@cmd, '>&', 'out.txt' ;   run \\\@cmd, '>', 'out.txt', '2>&1' ;\n\netc.\n\nFile descriptor numbers are not permitted to the left or the right of\nthese operators, and the '&' may occur on either end of the operator.\n\nThe '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except\nthat both stdout and stderr write to the created pipe.\n\n=item Redirection Filters\n\nBoth input redirections and output redirections that use scalars or\nsubs as endpoints may have an arbitrary number of filter subs placed\nbetween them and the child process.  This is useful if you want to\nreceive output in chunks, or if you want to massage each chunk of\ndata sent to the child.  To use this feature, you must use operator\nsyntax:\n\n   run(\n      \\\@cmd\n         '<', \\&in_filter_2, \\&in_filter_1, \$in,\n         '>', \\&out_filter_1, \\&in_filter_2, \$out,\n   ) ;\n\nThis capability is not provided for IO handles or named files.\n\nTwo filters are provided by IPC::Run: appender and chunker.  Because\nthese may take an argument, you need to use the constructor functions\nnew_appender() and new_chunker() rather than using \\& syntax:\n\n   run(\n      \\\@cmd\n         '<', new_appender( "\\n" ), \$in,\n         '>', new_chunker, \$out,\n   ) ;\n\n=back\n\n=head2 Just doing I/O\n\nIf you just want to do I/O to a handle or file you open yourself, you\nmay specify a filehandle or filename instead of a command in the harness\nspecification:\n\n   run io( "filename", '>', \\\$recv ) ;\n\n   \$h = start io( \$io, '>', \\\$recv ) ;\n\n   \$h = harness \\\@cmd, '&', io( "file", '<', \\\$send ) ;\n\n=head2 Options\n\nOptions are passed in as name/value pairs:\n\n   run \\\@cat, \\\$in, debug => 1 ;\n\nIf you pass the debug option, you may want to pass it in first, so you\ncan see what parsing is going on:\n\n   run debug => 1, \\\@cat, \\\$in ;\n\n=over\n\n=item debug\n\nEnables debugging output in parent and child.  Debugging info is emitted\nto the STDERR that was present when IPC::Run was first C<use()>ed (it's\nC<dup()>ed out of the way so that it can be redirected in children without\nhaving debugging output emitted on it).\n\n=back\n\n=head1 RETURN VALUES\n\nharness() and start() return a reference to an IPC::Run harness.  This is\nblessed in to the IPC::Run package, so you may make later calls to\nfunctions as members if you like:\n\n   \$h = harness( ... ) ;\n   \$h->start ;\n   \$h->pump ;\n   \$h->finish ;\n\n   \$h = start( .... ) ;\n   \$h->pump ;\n   ...\n\nOf course, using method call syntax lets you deal with any IPC::Run\nsubclasses that might crop up, but don't hold your breath waiting for\nany.\n\nrun() and finish() return TRUE when all subcommands exit with a 0 result\ncode.  B<This is the opposite of perl's system() command>.\n\nAll routines raise exceptions (via die()) when error conditions are\nrecognized.  A non-zero command result is not treated as an error\ncondition, since some commands are tests whose results are reported \nin their exit codes.\n\n=head1 ROUTINES\n\n=over\n\n=cut\n\n\$VERSION = 0.74 ;\n\n\@ISA = qw( Exporter ) ;\n\n## We use \@EXPORT for the end user's convenience: there's only one function\n## exported, it's homonymous with the module, it's an unusual name, and\n## it can be suppressed by "use IPC::Run () ;".\n\nmy \@FILTER_IMP = qw( input_avail get_more_input ) ;\nmy \@FILTERS    = qw(\n   new_appender\n   new_chunker\n   new_string_source\n   new_string_sink\n) ;\nmy \@API        = qw(\n   run\n   harness start pump finish\n   signal kill_kill reap_nb\n   io timer timeout\n   close_terminal\n   binary\n) ;\n\n\@EXPORT_OK = ( \@API, \@FILTER_IMP, \@FILTERS, qw( filter_tests Win32_MODE ) ) ;\n%EXPORT_TAGS = (\n   'filter_imp' => \\\@FILTER_IMP,\n   'all'        => \\\@EXPORT_OK,\n   'filters'    => \\\@FILTERS,\n   'api'        => \\\@API,\n) ;\n\nuse strict ;\n\nuse IPC::Run::Debug;\nuse Exporter ;\nuse Fcntl ;\nuse POSIX () ;\nuse Symbol ;\nuse Carp ;\nuse File::Spec ;\nuse IO::Handle ;\nrequire IPC::Run::IO ;\nrequire IPC::Run::Timer ;\nuse UNIVERSAL qw( isa ) ;\n\nuse constant Win32_MODE => \$^O =~ /os2|Win32/i ;\n\nBEGIN {\n   if ( Win32_MODE ) {\n      eval "use IPC::Run::Win32Helper; 1;"\n         or ( \$\@ && die ) or die "\$!" ;\n   }\n   else {\n      eval "use File::Basename; 1;" or die \$! ;\n   }\n}\n\n\nuse fields (\n   'ID',           # An identifier of this harness\n   'IOS',          # ARRAY of filehandles passed in by caller for us to watch\n                   # like PIPES except that we perform no management of these,\n                   # just I/O.  These are encapsulated in IPC::Run::IO\n                   # instances.\n\n   'KIDS',         # ARRAY of child processes\n\n   'PIPES',        # ARRAY of Pipes & Pty handles to/from child procs\n                   # These are references to entries in \@{\$_->{OPS}} for \@KIDS\n\n   'PTYS',         # A HASH of pty nicknames => ( undef or IO::Pty instances ).\n                   # Elts are undef until _open_pipes() and after _cleanup().\n\n   'TIMERS',       # ARRAY of all timer / timeout objects\n\n   'STATE',        # "state" of a harness. See constant subs immediately below.\n\n   'TEMP_FILTERS', # ARRAY of filters installed by _open_pipes() and removed\n                   # by _cleanup() to handle I/O to/from handles.\n\n   'DEBUG_FD',     # Debugging FD dup()ed from STDOUT.\n   'SYNC_WRITER_FD', # write end of pipe used to sync w/ child and report\n                   # exec errors from child.\n\n   'RIN',  'WIN',  'EIN',  # Bit vectors for select()\n   'ROUT', 'WOUT', 'EOUT',\n\n   'PIN',          # A bit vector holding paused PIPES that would otherwise\n                   # be set in WIN.  This is a bit vector to make the\n                   # debugging display of filehandles easier to build, since\n                   # it can treat this just like EIN, WIN, and RIN.\n\n   # Some options.  These get set by API entry subs and used by _internal\n   # subs. \n   'auto_close_ins',\n   'break_on_io',\n   'clear_ins',\n   'non_blocking',\n\n   # Option flags, passed in by caller\n   'debug',\n   'noinherit',\n#   'timeout',\n\n   # Testing flags, passed in from t/*.t\n   '_simulate_open_failure',\n   '_simulate_fork_failure',\n   '_simulate_exec_failure',\n) ;\n\nsub input_avail() ;\nsub get_more_input() ;\n\n###############################################################################\n\n##\n## State machine states, set in \$self->{STATE}\n##\n## These must be in ascending order numerically\n##\nsub _newed()    {0}\nsub _harnessed(){1}\nsub _finished() {2}   ## _finished behave almost exactly like _harnessed\nsub _started()  {3}\n\n##\n## Which fds have been opened in the parent.  This may have extra fds, since\n## we aren't all that rigorous about closing these off, but that's ok.  This\n## is used on Unixish OSs to close all fds in the child that aren't needed\n## by that particular child.\nmy %fds ;\n\n## There's a bit of hackery going on here.\n##\n## We want to have any code anywhere be able to emit\n## debugging statements without knowing what harness the code is\n## being called in/from, since we'd need to pass a harness around to\n## everything.\n##\n## Thus, \$cur_self was born.\n\nuse vars qw( \$cur_self ) ;\n\nsub _debug_fd {\n   return fileno STDERR unless defined \$cur_self ;\n\n   if ( _debugging && ! defined \$cur_self->{DEBUG_FD} ) {\n      my \$fd = select STDERR ; \$| = 1 ; select \$fd ;\n      \$cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR ;\n      _debug( "debugging fd is \$cur_self->{DEBUG_FD}\\n" )\n         if _debugging_details ;\n   }\n\n   return fileno STDERR unless defined \$cur_self->{DEBUG_FD} ;\n\n   return \$cur_self->{DEBUG_FD}\n}\n\nsub DESTROY {\n   ## We absolutely do not want to do anything else here.  We are likely\n   ## to be in a child process and we don't want to do things like kill_kill\n   ## ourself or cause other destruction.\n   my IPC::Run \$self = shift ;\n   POSIX::close \$self->{DEBUG_FD} if defined \$self->{DEBUG_FD} ;\n   \$self->{DEBUG_FD} = undef ;\n}\n\n##\n## Support routines (NOT METHODS)\n##\nmy %cmd_cache ;\n\nsub _search_path {\n   my ( \$cmd_name ) = \@_ ;\n   if ( File::Spec->file_name_is_absolute( \$cmd_name ) && -x \$cmd_name) {\n      _debug "'", \$cmd_name, "' is absolute"\n         if _debugging_details ;\n      return \$cmd_name ;\n   }\n\n   my \$dirsep =\n      ( Win32_MODE\n         ? '[/\\\\\\\\]'\n      : \$^O =~ /MacOS/\n         ? ':'\n      : \$^O =~ /VMS/\n         ? '[\\[\\]]'\n      : '/'\n      ) ;\n\n   if ( Win32_MODE\n      && ( \$cmd_name =~ /\$dirsep/ )\n      && ( \$cmd_name !~ /\\..+\$/ )  ## Only run if cmd_name has no extension?\n    ) {\n      for ( split /;/, \$ENV{PATHEXT} || ".COM;.BAT;.EXE" ) {\n         my \$name = "\$cmd_name\$_";\n         \$cmd_name = \$name, last if -f \$name && -x _;\n      }\n   }\n\n   if ( \$cmd_name =~ /(\$dirsep)/ ) {\n      _debug "'\$cmd_name' contains '\$1'"  if _debugging;\n      croak "file not found: \$cmd_name"    unless -e \$cmd_name ;\n      croak "not a file: \$cmd_name"        unless -f \$cmd_name ;\n      croak "permission denied: \$cmd_name" unless -x \$cmd_name ;\n      return \$cmd_name ;\n   }\n\n   if ( exists \$cmd_cache{\$cmd_name} ) {\n      _debug "'\$cmd_name' found in cache: '\$cmd_cache{\$cmd_name}'"\n         if _debugging;\n      return \$cmd_cache{\$cmd_name} if -x \$cmd_cache{\$cmd_name} ;\n      _debug "'\$cmd_cache{\$cmd_name}' no longer executable, searching..."\n         if _debugging;\n      delete \$cmd_cache{\$cmd_name} ;\n   }\n\n   my \@searched_in ;\n\n   ## This next bit is Unix/Win32 specific, unfortunately.\n   ## There's been some conversation about extending File::Spec to provide\n   ## a universal interface to PATH, but I haven't seen it yet.\n      my \$re = Win32_MODE ? qr/;/ : qr/:/ ;\n\nLOOP:\n   for ( split( \$re, \$ENV{PATH}, -1 ) ) {\n      \$_ = "." unless length \$_ ;\n      push \@searched_in, \$_ ;\n\n      my \$prospect = File::Spec->catfile( \$_, \$cmd_name ) ;\n      my \@prospects ;\n\n      \@prospects =\n         ( Win32_MODE && ! ( -f \$prospect && -x _ ) )\n            ? map "\$prospect\$_", split /;/, \$ENV{PATHEXT} || ".COM;.BAT;.EXE"\n            : ( \$prospect ) ;\n\n      for my \$found ( \@prospects ) {\n         if ( -f \$found && -x _ ) {\n            \$cmd_cache{\$cmd_name} = \$found ;\n            last LOOP ;\n         }\n      }\n   }\n\n   if ( exists \$cmd_cache{\$cmd_name} ) {\n      _debug "'", \$cmd_name, "' added to cache: '", \$cmd_cache{\$cmd_name}, "'"\n         if _debugging_details ;\n      return \$cmd_cache{\$cmd_name} ;\n   }\n\n   croak "Command '\$cmd_name' not found in " . join( ", ", \@searched_in ) ;\n}\n\n\nsub _empty(\$) { ! ( defined \$_[0] && length \$_[0] ) }\n\n## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper.\nsub _close {\n   confess 'undef' unless defined \$_[0] ;\n   no strict 'refs' ;\n   my \$fd = \$_[0] =~ /^\\d+\$/ ? \$_[0] : fileno \$_[0] ;\n   my \$r = POSIX::close \$fd ;\n   \$r = \$r ? '' : " ERROR \$!" ;\n   delete \$fds{\$fd} ;\n   _debug "close( \$fd ) = " . ( \$r || 0 ) if _debugging_details ;\n}\n\nsub _dup {\n   confess 'undef' unless defined \$_[0] ;\n   my \$r = POSIX::dup( \$_[0] ) ;\n   croak "\$!: dup( \$_[0] )" unless defined \$r ;\n   \$r = 0 if \$r eq '0 but true' ;\n   _debug "dup( \$_[0] ) = \$r" if _debugging_details ;\n   \$fds{\$r} = 1 ;\n   return \$r ;\n}\n\n\nsub _dup2_rudely {\n   confess 'undef' unless defined \$_[0] && defined \$_[1] ;\n   my \$r = POSIX::dup2( \$_[0], \$_[1] ) ;\n   croak "\$!: dup2( \$_[0], \$_[1] )" unless defined \$r ;\n   \$r = 0 if \$r eq '0 but true' ;\n   _debug "dup2( \$_[0], \$_[1] ) = \$r" if _debugging_details ;\n   \$fds{\$r} = 1 ;\n   return \$r ;\n}\n\nsub _exec {\n   confess 'undef passed' if grep !defined, \@_ ;\n#   exec \@_ or croak "\$!: exec( " . join( ', ', \@_ ) . " )" ;\n   _debug 'exec()ing ', join " ", map "'\$_'", \@_ if _debugging_details ;\n\n#   {\n## Commented out since we don't call this on Win32.\n#      # This works around the bug where 5.6.1 complains\n#      # "Can't exec ...: No error" after an exec on NT, where\n#      # exec() is simulated and actually returns in Perl's C\n#      # code, though Perl's &exec does not...\n#      no warnings "exec" ;\n#\n#      # Just in case the no warnings workaround\n#      # stops beign a workaround, we don't want\n#      # old values of \$! causing spurious strerr()\n#      # messages to appear in the "Can't exec" message\n#      undef \$! ;\n      exec \@_ ;\n#   }\n#   croak "\$!: exec( " . join( ', ', map "'\$_'", \@_ ) . " )" ;\n    ## Fall through so \$! can be reported to parent.\n}\n\n\nsub _sysopen {\n   confess 'undef' unless defined \$_[0] && defined \$_[1] ;\n_debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ),\nsprintf( "O_WRONLY=0x%02x ", O_WRONLY ),\nsprintf( "O_RDWR=0x%02x ", O_RDWR ),\nsprintf( "O_TRUNC=0x%02x ", O_TRUNC),\nsprintf( "O_CREAT=0x%02x ", O_CREAT),\nsprintf( "O_APPEND=0x%02x ", O_APPEND),\nif _debugging_details ;\n   my \$r = POSIX::open( \$_[0], \$_[1], 0644 ) ;\n   croak "\$!: open( \$_[0], ", sprintf( "0x%03x", \$_[1] ), " )" unless defined \$r ;\n   _debug "open( \$_[0], ", sprintf( "0x%03x", \$_[1] ), " ) = \$r"\n      if _debugging_data ;\n   \$fds{\$r} = 1 ;\n   return \$r ;\n}\n\nsub _pipe {\n   ## Normal, blocking write for pipes that we read and the child writes,\n   ## since most children expect writes to stdout to block rather than\n   ## do a partial write.\n   my ( \$r, \$w ) = POSIX::pipe ;\n   croak "\$!: pipe()" unless \$r ;\n   _debug "pipe() = ( \$r, \$w ) " if _debugging_details ;\n   \$fds{\$r} = \$fds{\$w} = 1 ;\n   return ( \$r, \$w ) ;\n}\n\nsub _pipe_nb {\n   ## For pipes that we write, unblock the write side, so we can fill a buffer\n   ## and continue to select().\n   ## Contributed by Borislav Deianov <borislav\@ensim.com>, with minor\n   ## bugfix on fcntl result by me.\n   local ( *R, *W ) ;\n   my \$f = pipe( R, W ) ;\n   croak "\$!: pipe()" unless defined \$f ;\n   my ( \$r, \$w ) = ( fileno R, fileno W ) ;\n   _debug "pipe_nb pipe() = ( \$r, \$w )" if _debugging_details ;\n   unless ( Win32_MODE ) {\n      ## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and\n      ## then _dup the originals (which get closed on leaving this block)\n      my \$fres = fcntl( W, &F_SETFL, O_WRONLY | O_NONBLOCK );\n      croak "\$!: fcntl( \$w, F_SETFL, O_NONBLOCK )" unless \$fres ;\n      _debug "fcntl( \$w, F_SETFL, O_NONBLOCK )" if _debugging_details ;\n   }\n   ( \$r, \$w ) = ( _dup( \$r ), _dup( \$w ) ) ;\n   _debug "pipe_nb() = ( \$r, \$w )" if _debugging_details ;\n   return ( \$r, \$w ) ;\n}\n\nsub _pty {\n   require IO::Pty ;\n   my \$pty = IO::Pty->new() ;\n   croak "\$!: pty ()" unless \$pty ;\n   \$pty->autoflush() ;\n   \$pty->blocking( 0 ) or croak "\$!: pty->blocking ( 0 )" ;\n   _debug "pty() = ( ", \$pty->fileno, ", ", \$pty->slave->fileno, " )"\n      if _debugging_details ;\n   \$fds{\$pty->fileno} = \$fds{\$pty->slave->fileno} = 1 ;\n   return \$pty ;\n}\n\n\nsub _read {\n   confess 'undef' unless defined \$_[0] ;\n   my \$s  = '' ;\n   my \$r = POSIX::read( \$_[0], \$s, 10_000 ) ;\n   croak "\$!: read( \$_[0] )" unless \$r ;\n   _debug "read( \$_[0] ) = \$r chars '\$s'" if _debugging_data ;\n   return \$s ;\n}\n\n\n## A METHOD, not a function.\nsub _spawn {\n   my IPC::Run \$self = shift ;\n   my ( \$kid ) = \@_ ;\n\n   _debug "opening sync pipe ", \$kid->{PID} if _debugging_details ;\n   my \$sync_reader_fd ;\n   ( \$sync_reader_fd, \$self->{SYNC_WRITER_FD} ) = _pipe ;\n   \$kid->{PID} = fork() ;\n   croak "\$! during fork" unless defined \$kid->{PID} ;\n\n   unless ( \$kid->{PID} ) {\n      ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and\n      ## unloved fds.\n      \$self->_do_kid_and_exit( \$kid ) ;\n   }\n   _debug "fork() = ", \$kid->{PID} if _debugging_details ;\n\n   ## Wait for kid to get to it's exec() and see if it fails.\n   _close \$self->{SYNC_WRITER_FD} ;\n   my \$sync_pulse = _read \$sync_reader_fd ;\n   _close \$sync_reader_fd ;\n\n   if ( ! defined \$sync_pulse || length \$sync_pulse ) {\n      if ( waitpid( \$kid->{PID}, 0 ) >= 0 ) {\n\x09 \$kid->{RESULT} = \$? ;\n      }\n      else {\n\x09 \$kid->{RESULT} = -1 ;\n      }\n      \$sync_pulse =\n         "error reading synchronization pipe for \$kid->{NUM}, pid \$kid->{PID}"\n\x09 unless length \$sync_pulse ;\n      croak \$sync_pulse ;\n   }\n   return \$kid->{PID} ;\n\n## Wait for pty to get set up.  This is a hack until we get synchronous\n## selects.\nif ( keys %{\$self->{PTYS}} && \$IO::Pty::VERSION < 0.9 ) {\n_debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives." ;\nsleep 1 ;\n}\n}\n\n\nsub _write {\n   confess 'undef' unless defined \$_[0] && defined \$_[1] ;\n   my \$r = POSIX::write( \$_[0], \$_[1], length \$_[1] ) ;\n   croak "\$!: write( \$_[0], '\$_[1]' )" unless \$r ;\n   _debug "write( \$_[0], '\$_[1]' ) = \$r" if _debugging_data ;\n   return \$r ;\n}\n\n\n=item run\n\nRun takes a harness or harness specification and runs it, pumping\nall input to the child(ren), closing the input pipes when no more\ninput is available, collecting all output that arrives, until the\npipes delivering output are closed, then waiting for the children to\nexit and reaping their result codes.\n\nYou may think of C<run( ... )> as being like \n\n   start( ... )->finish() ;\n\n, though there is one subtle difference: run() does not\nset \\\$input_scalars to '' like finish() does.  If an exception is thrown\nfrom run(), all children will be killed off "gently", and then "annihilated"\nif they do not go gently (in to that dark night. sorry).\n\nIf any exceptions are thrown, this does a L</kill_kill> before propogating\nthem.\n\n=cut\n\nuse vars qw( \$in_run );  ## No, not Enron ;)\n\nsub run {\n   local \$in_run = 1;  ## Allow run()-only optimizations.\n   my IPC::Run \$self = start( \@_ );\n   my \$r = eval {\n      \$self->{clear_ins} = 0 ;\n      \$self->finish ;\n   } ;\n   if ( \$\@ ) {\n      my \$x = \$\@ ;\n      \$self->kill_kill ;\n      die \$x ;\n   }\n   return \$r ;\n}\n\n\n=item signal\n\n   ## To send it a specific signal by name ("USR1"):\n   signal \$h, "USR1" ;\n   \$h->signal ( "USR1" ) ;\n\nIf \$signal is provided and defined, sends a signal to all child processes.  Try\nnot to send numeric signals, use C<"KILL"> instead of C<9>, for instance.\nNumeric signals aren't portable.\n\nThrows an exception if \$signal is undef.\n\nThis will I<not> clean up the harness, C<finish> it if you kill it.\n\nNormally TERM kills a process gracefully (this is what the command line utility\nC<kill> does by default), INT is sent by one of the keys C<^C>, C<Backspace> or\nC<E<lt>DelE<gt>>, and C<QUIT> is used to kill a process and make it coredump.\n\nThe C<HUP> signal is often used to get a process to "restart", rereading \nconfig files, and C<USR1> and C<USR2> for really application-specific things.\n\nOften, running C<kill -l> (that's a lower case "L") on the command line will\nlist the signals present on your operating system.\n\nB<WARNING>: The signal subsystem is not at all portable.  We *may* offer\nto simulate C<TERM> and C<KILL> on some operating systems, submit code\nto me if you want this.\n\nB<WARNING 2>: Up to and including perl v5.6.1, doing almost anything in a\nsignal handler could be dangerous.  The most safe code avoids all\nmallocs and system calls, usually by preallocating a flag before\nentering the signal handler, altering the flag's value in the\nhandler, and responding to the changed value in the main system:\n\n   my \$got_usr1 = 0 ;\n   sub usr1_handler { ++\$got_signal }\n\n   \$SIG{USR1} = \\&usr1_handler ;\n   while () { sleep 1 ; print "GOT IT" while \$got_usr1-- ; }\n\nEven this approach is perilous if ++ and -- aren't atomic on your system\n(I've never heard of this on any modern CPU large enough to run perl).\n\n=cut\n\nsub signal {\n   my IPC::Run \$self = shift ;\n\n   local \$cur_self = \$self ;\n\n   \$self->_kill_kill_kill_pussycat_kill unless \@_ ;\n\n   Carp::cluck "Ignoring extra parameters passed to kill()" if \@_ > 1 ;\n\n   my ( \$signal ) = \@_ ;\n   croak "Undefined signal passed to signal" unless defined \$signal ;\n   for ( grep \$_->{PID} && ! defined \$_->{RESULT}, \@{\$self->{KIDS}} ) {\n      _debug "sending \$signal to \$_->{PID}"\n         if _debugging;\n      kill \$signal, \$_->{PID}\n         or _debugging && _debug "\$! sending \$signal to \$_->{PID}" ;\n   }\n   \n   return ;\n}\n\n\n=item kill_kill\n\n   ## To kill off a process:\n   \$h->kill_kill ;\n   kill_kill \$h ;\n\n   ## To specify the grace period other than 30 seconds:\n   kill_kill \$h, grace => 5 ;\n\n   ## To send QUIT instead of KILL if a process refuses to die:\n   kill_kill \$h, coup_d_grace => "QUIT" ;\n\nSends a C<TERM>, waits for all children to exit for up to 30 seconds, then\nsends a C<KILL> to any that survived the C<TERM>.\n\nWill wait for up to 30 more seconds for the OS to sucessfully C<KILL> the\nprocesses.\n\nThe 30 seconds may be overriden by setting the C<grace> option, this\noverrides both timers.\n\nThe harness is then cleaned up.\n\nThe doubled name indicates that this function may kill again and avoids\ncolliding with the core Perl C<kill> function.\n\nReturns a 1 if the C<TERM> was sufficient, or a 0 if C<KILL> was \nrequired.  Throws an exception if C<KILL> did not permit the children\nto be reaped.\n\nB<NOTE>: The grace period is actually up to 1 second longer than that\ngiven.  This is because the granularity of C<time> is 1 second.  Let me\nknow if you need finer granularity, we can leverage Time::HiRes here.\n\nB<Win32>: Win32 does not know how to send real signals, so C<TERM> is\na full-force kill on Win32.  Thus all talk of grace periods, etc. do\nnot apply to Win32.\n\n=cut\n\nsub kill_kill {\n   my IPC::Run \$self = shift ;\n\n   my %options = \@_ ;\n   my \$grace = \$options{grace} ;\n   \$grace = 30 unless defined \$grace ;\n   ++\$grace ; ## Make grace time a _minimum_\n\n   my \$coup_d_grace = \$options{coup_d_grace} ;\n   \$coup_d_grace = "KILL" unless defined \$coup_d_grace ;\n\n   delete \$options{\$_} for qw( grace coup_d_grace ) ;\n   Carp::cluck "Ignoring unknown options for kill_kill: ",\n       join " ",keys %options\n       if keys %options ;\n\n   \$self->signal( "TERM" ) ;\n\n   my \$quitting_time = time + \$grace ;\n   my \$delay = 0.01 ;\n   my \$accum_delay ;\n\n   my \$have_killed_before ;\n\n   while () {\n      ## delay first to yeild to other processes\n      select undef, undef, undef, \$delay ;\n      \$accum_delay += \$delay ;\n\n      \$self->reap_nb ;\n      last unless \$self->_running_kids ;\n\n      if ( \$accum_delay >= \$grace*0.8 ) {\n         ## No point in checking until delay has grown some.\n         if ( time >= \$quitting_time ) {\n            if ( ! \$have_killed_before ) {\n               \$self->signal( \$coup_d_grace ) ;\n               \$have_killed_before = 1 ;\n               \$quitting_time += \$grace ;\n               \$delay = 0.01 ;\n               \$accum_delay = 0 ;\n               next ;\n            }\n            croak "Unable to reap all children, even after KILLing them"\n         }\n      }\n\n      \$delay *= 2 ;\n      \$delay = 0.5 if \$delay >= 0.5 ;\n   }\n\n   \$self->_cleanup ;\n   return \$have_killed_before ;\n}\n\n\n=item harness\n\nTakes a harness specification and returns a harness.  This harness is\nblessed in to IPC::Run, allowing you to use method call syntax for\nrun(), start(), et al if you like.\n\nharness() is provided so that you can pre-build harnesses if you\nwould like to, but it's not required..\n\nYou may proceed to run(), start() or pump() after calling harness() (pump()\ncalls start() if need be).  Alternatively, you may pass your\nharness specification to run() or start() and let them harness() for\nyou.  You can't pass harness specifications to pump(), though.\n\n=cut\n\n##\n## Notes: I've avoided handling a scalar that doesn't look like an\n## opcode as a here document or as a filename, though I could DWIM\n## those.  I'm not sure that the advantages outweight the danger when\n## the DWIMer guesses wrong.\n##\n## TODO: allow user to spec default shell. Hmm, globally, in the\n## lexical scope hash, or per instance?  'Course they can do that\n## now by using a [...] to hold the command.\n##\nmy \$harness_id = 0 ;\nsub harness {\n   my \$options ;\n   if ( \@_ && ref \$_[-1] eq 'HASH' ) {\n      \$options = pop ;\n      require Data::Dumper ;\n      carp "Passing in options as a hash is deprecated:\\n", Data::Dumper::Dumper( \$options ) ;\n   }\n\n#   local \$IPC::Run::debug = \$options->{debug}\n#      if \$options && defined \$options->{debug} ;\n\n   my \@args ;\n\n   if ( \@_ == 1 && ! ref \$_[0] ) {\n      if ( Win32_MODE ) {\n         \@args = ( [ qw( command /c ), win32_parse_cmd_line \$_[0] ] ) ;\n      }\n      else {\n         \@args = ( [ qw( sh -c ), \@_ ] ) ;\n      }\n   }\n   elsif ( \@_ > 1 && ! grep ref \$_, \@_ ) {\n      \@args = ( [ \@_ ] ) ;\n   }\n   else {\n      \@args = \@_ ;\n   }\n\n   my \@errs ;               # Accum errors, emit them when done.\n\n   my \$succinct ;           # set if no redir ops are required yet.  Cleared\n                            # if an op is seen.\n\n   my \$cur_kid ;            # references kid or handle being parsed\n\n   my \$assumed_fd    = 0 ;  # fd to assume in succinct mode (no redir ops)\n   my \$handle_num    = 0 ;  # 1... is which handle we're parsing\n\n   my IPC::Run \$self ;\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"FIELDS"} ], __PACKAGE__ ;\n   }\n\n   local \$cur_self = \$self ;\n\n   \$self->{ID}    = ++\$harness_id ;\n   \$self->{IOS}   = [] ;\n   \$self->{KIDS}  = [] ;\n   \$self->{PIPES} = [] ;\n   \$self->{PTYS}  = {} ;\n   \$self->{STATE} = _newed ;\n\n   if ( \$options ) {\n      \$self->{\$_} = \$options->{\$_}\n         for keys %\$options ;\n   }\n\n   _debug "****** harnessing *****" if _debugging;\n\n   my \$first_parse ;\n   local \$_ ;\n   my \$arg_count = \@args ;\n   while ( \@args ) { for ( shift \@args ) {\n      eval {\n         \$first_parse = 1 ;\n         _debug(\n            "parsing ",\n            defined \$_\n               ? ref \$_ eq 'ARRAY'\n                  ? ( '[ ', join( ', ', map "'\$_'", \@\$_ ), ' ]' )\n                  : ( ref \$_\n                     || ( length \$_ < 50\n                           ? "'\$_'"\n                           : join( '', "'", substr( \$_, 0, 10 ), "...'" )\n                        )\n                  )\n               : '<undef>'\n         ) if _debugging;\n\n      REPARSE:\n         if ( ref eq 'ARRAY' || ( ! \$cur_kid && ref eq 'CODE' ) ) {\n            croak "Process control symbol ('|', '&') missing" if \$cur_kid ;\n            croak "Can't spawn a subroutine on Win32"\n\x09       if Win32_MODE && ref eq "CODE" ;\n            \$cur_kid = {\n               TYPE   => 'cmd',\n               VAL    => \$_,\n               NUM    => \@{\$self->{KIDS}} + 1,\n               OPS    => [],\n               PID    => '',\n               RESULT => undef,\n            } ;\n            push \@{\$self->{KIDS}}, \$cur_kid ;\n            \$succinct = 1 ;\n         }\n\n         elsif ( isa( \$_, 'IPC::Run::IO' ) ) {\n            push \@{\$self->{IOS}}, \$_ ;\n            \$cur_kid = undef ;\n            \$succinct = 1 ;\n         }\n         \n         elsif ( isa( \$_, 'IPC::Run::Timer' ) ) {\n            push \@{\$self->{TIMERS}}, \$_ ;\n            \$cur_kid = undef ;\n            \$succinct = 1 ;\n         }\n         \n         elsif ( /^(\\d*)>&(\\d+)\$/ ) {\n            croak "No command before '\$_'" unless \$cur_kid ;\n            push \@{\$cur_kid->{OPS}}, {\n               TYPE => 'dup',\n               KFD1 => \$2,\n               KFD2 => length \$1 ? \$1 : 1,\n            } ;\n            _debug "redirect operators now required" if _debugging_details ;\n            \$succinct = ! \$first_parse ;\n         }\n\n         elsif ( /^(\\d*)<&(\\d+)\$/ ) {\n            croak "No command before '\$_'" unless \$cur_kid ;\n            push \@{\$cur_kid->{OPS}}, {\n               TYPE => 'dup',\n               KFD1 => \$2,\n               KFD2 => length \$1 ? \$1 : 0,\n            } ;\n            \$succinct = ! \$first_parse ;\n         }\n\n         elsif ( /^(\\d*)<&-\$/ ) {\n            croak "No command before '\$_'" unless \$cur_kid ;\n            push \@{\$cur_kid->{OPS}}, {\n               TYPE => 'close',\n               KFD  => length \$1 ? \$1 : 0,\n            } ;\n            \$succinct = ! \$first_parse ;\n         }\n\n         elsif (\n               /^(\\d*) (<pipe)()            ()  ()  \$/x\n            || /^(\\d*) (<pty) ((?:\\s+\\S+)?) (<) ()  \$/x\n            || /^(\\d*) (<)    ()            ()  (.*)\$/x\n         ) {\n            croak "No command before '\$_'" unless \$cur_kid ;\n\n            \$succinct = ! \$first_parse ;\n\n            my \$type = \$2 . \$4 ;\n\n            my \$kfd = length \$1 ? \$1 : 0 ;\n\n            my \$pty_id ;\n            if ( \$type eq '<pty<' ) {\n               \$pty_id = length \$3 ? \$3 : '0' ;\n               ## do the require here to cause early error reporting\n               require IO::Pty ;\n               ## Just flag the pyt's existence for now.  It'll be\n               ## converted to a real IO::Pty by _open_pipes.\n               \$self->{PTYS}->{\$pty_id} = undef ;\n            }\n\n            my \$source = \$5 ;\n\n            my \@filters ;\n            my \$binmode ;\n\n            unless ( length \$source ) {\n               if ( ! \$succinct ) {\n                  while ( \@args > 1\n                      && (\n                         ( ref \$args[1] && ! isa \$args[1], "IPC::Run::Timer" )\n                         || isa \$args[0], "IPC::Run::binmode_pseudo_filter"\n                      )\n                  ) {\n                     if ( isa \$args[0], "IPC::Run::binmode_pseudo_filter" ) {\n                        \$binmode = shift( \@args )->() ;\n                     }\n                     else {\n                        push \@filters, shift \@args\n                     }\n                  }\n               }\n               \$source = shift \@args ;\n               croak "'\$_' missing a source" if _empty \$source ;\n\n               _debug(\n                  'Kid ', \$cur_kid->{NUM}, "'s input fd ", \$kfd,\n                  ' has ', scalar( \@filters ), ' filters.'\n               ) if _debugging_details && \@filters ;\n            } ;\n\n            my IPC::Run::IO \$pipe = IPC::Run::IO->_new_internal(\n               \$type, \$kfd, \$pty_id, \$source, \$binmode, \@filters\n            ) ;\n\n            if ( ( ref \$source eq 'GLOB' || isa \$source, 'IO::Handle' )\n               && \$type !~ /^<p(ty<|ipe)\$/\n            ) {\n\x09       _debug "setting DONT_CLOSE" if _debugging_details ;\n               \$pipe->{DONT_CLOSE} = 1 ; ## this FD is not closed by us.\n\x09       _dont_inherit( \$source ) if Win32_MODE ;\n            }\n\n            push \@{\$cur_kid->{OPS}}, \$pipe ;\n      }\n\n         elsif ( /^()   (>>?)  (&)     ()      (.*)\$/x\n            ||   /^()   (&)    (>pipe) ()      ()  \$/x \n            ||   /^()   (>pipe)(&)     ()      ()  \$/x \n            ||   /^(\\d*)()     (>pipe) ()      ()  \$/x\n            ||   /^()   (&)    (>pty)  ( \\w*)> ()  \$/x \n## TODO:    ||   /^()   (>pty) (\\d*)> (&) ()  \$/x \n            ||   /^(\\d*)()     (>pty)  ( \\w*)> ()  \$/x\n            ||   /^()   (&)    (>>?)   ()      (.*)\$/x \n            ||   /^(\\d*)()     (>>?)   ()      (.*)\$/x\n         ) {\n            croak "No command before '\$_'" unless \$cur_kid ;\n\n            \$succinct = ! \$first_parse ;\n\n            my \$type = (\n               \$2 eq '>pipe' || \$3 eq '>pipe'\n                  ? '>pipe'\n                  : \$2 eq '>pty' || \$3 eq '>pty'\n                     ? '>pty>'\n                     : '>'\n            ) ;\n            my \$kfd = length \$1 ? \$1 : 1 ;\n            my \$trunc = ! ( \$2 eq '>>' || \$3 eq '>>' ) ;\n            my \$pty_id = (\n               \$2 eq '>pty' || \$3 eq '>pty'\n                  ? length \$4 ? \$4 : 0\n                  : undef\n            ) ;\n\n            my \$stderr_too =\n                  \$2 eq '&'\n               || \$3 eq '&'\n               || ( ! length \$1 && substr( \$type, 0, 4 ) eq '>pty' ) ;\n\n            my \$dest = \$5 ;\n            my \@filters ;\n            my \$binmode = 0 ;\n            unless ( length \$dest ) {\n               if ( ! \$succinct ) {\n                  ## unshift...shift: '>' filters source...sink left...right\n                  while ( \@args > 1\n                     && ( \n                        ( ref \$args[1] && !  isa \$args[1], "IPC::Run::Timer" )\n                        || isa \$args[0], "IPC::Run::binmode_pseudo_filter"\n                     )\n                  ) {\n                     if ( isa \$args[0], "IPC::Run::binmode_pseudo_filter" ) {\n                        \$binmode = shift( \@args )->() ;\n                     }\n                     else {\n                        unshift \@filters, shift \@args ;\n                     }\n                  }\n               }\n\n               \$dest = shift \@args ;\n\n               _debug(\n                  'Kid ', \$cur_kid->{NUM}, "'s output fd ", \$kfd,\n                  ' has ', scalar( \@filters ), ' filters.'\n               ) if _debugging_details && \@filters ;\n\n               if ( \$type eq '>pty>' ) {\n                  ## do the require here to cause early error reporting\n                  require IO::Pty ;\n                  ## Just flag the pyt's existence for now.  _open_pipes()\n                  ## will new an IO::Pty for each key.\n                  \$self->{PTYS}->{\$pty_id} = undef ;\n               }\n            }\n\n            croak "'\$_' missing a destination" if _empty \$dest ;\n            my \$pipe = IPC::Run::IO->_new_internal(\n               \$type, \$kfd, \$pty_id, \$dest, \$binmode, \@filters\n            ) ;\n            \$pipe->{TRUNC} = \$trunc ;\n\n            if (  ( isa( \$dest, 'GLOB' ) || isa( \$dest, 'IO::Handle' ) )\n               && \$type !~ /^>(pty>|pipe)\$/\n            ) {\n\x09       _debug "setting DONT_CLOSE" if _debugging_details ;\n               \$pipe->{DONT_CLOSE} = 1 ; ## this FD is not closed by us.\n            }\n            push \@{\$cur_kid->{OPS}}, \$pipe ;\n            push \@{\$cur_kid->{OPS}}, {\n               TYPE => 'dup',\n               KFD1 => 1,\n               KFD2 => 2,\n            } if \$stderr_too ;\n         }\n\n         elsif ( \$_ eq "|" ) {\n            croak "No command before '\$_'" unless \$cur_kid ;\n            unshift \@{\$cur_kid->{OPS}}, {\n               TYPE => '|',\n               KFD  => 1,\n            } ;\n            \$succinct   = 1 ;\n            \$assumed_fd = 1 ;\n            \$cur_kid    = undef ;\n         }\n\n         elsif ( \$_ eq "&" ) {\n            croak "No command before '\$_'" unless \$cur_kid ;\n            unshift \@{\$cur_kid->{OPS}}, {\n               TYPE => 'close',\n               KFD  => 0,\n            } ;\n            \$succinct   = 1 ;\n            \$assumed_fd = 0 ;\n            \$cur_kid    = undef ;\n         }\n\n         elsif ( \$_ eq 'init' ) {\n            croak "No command before '\$_'" unless \$cur_kid ;\n            push \@{\$cur_kid->{OPS}}, {\n               TYPE => 'init',\n               SUB  => shift \@args,\n            } ;\n         }\n\n         elsif ( ! ref \$_ ) {\n            my \$opt = \$_ ;\n            croak "Illegal option '\$_'"\n               unless grep \$_ eq \$opt, keys %\$self ; \n            \$self->{\$_} = shift \@args ;\n         }\n\n         elsif ( \$_ eq 'init' ) {\n            croak "No command before '\$_'" unless \$cur_kid ;\n            push \@{\$cur_kid->{OPS}}, {\n               TYPE => 'init',\n               SUB  => shift \@args,\n            } ;\n         }\n\n         elsif ( \$succinct && \$first_parse ) {\n            ## It's not an opcode, and no explicit opcodes have been\n            ## seen yet, so assume it's a file name.\n            unshift \@args, \$_ ;\n            if ( ! \$assumed_fd ) {\n               \$_ = "\$assumed_fd<",\n            }\n            else {\n               \$_ = "\$assumed_fd>",\n            }\n            _debug "assuming '", \$_, "'" if _debugging_details ;\n            ++\$assumed_fd ;\n            \$first_parse = 0 ;\n            goto REPARSE ;\n         }\n\n         else {\n            croak join( \n               '',\n               'Unexpected ',\n               ( ref() ? \$_ : 'scalar' ),\n               ' in harness() parameter ',\n               \$arg_count - \@args\n            ) ;\n         }\n      } ;\n      if ( \$\@ ) {\n         push \@errs, \$\@ ;\n         _debug 'caught ', \$\@ if _debugging;\n      }\n   } }\n\n   die join( '', \@errs ) if \@errs ;\n\n\n   \$self->{STATE} = _harnessed ;\n#   \$self->timeout( \$options->{timeout} ) if exists \$options->{timeout} ;\n   return \$self ;\n}\n\n\nsub _open_pipes {\n   my IPC::Run \$self = shift ;\n\n   my \@errs ;\n\n   my \@close_on_fail ;\n\n   ## When a pipe character is seen, a pipe is created.  \$pipe_read_fd holds\n   ## the dangling read end of the pipe until we get to the next process.\n   my \$pipe_read_fd ;\n\n   ## Output descriptors for the last command are shared by all children.\n   ## \@output_fds_accum accumulates the current set of output fds.\n   my \@output_fds_accum ;\n\n   for ( sort keys %{\$self->{PTYS}} ) {\n      _debug "opening pty '", \$_, "'" if _debugging_details ;\n      my \$pty = _pty ;\n      \$self->{PTYS}->{\$_} = \$pty ;\n   }\n\n   for ( \@{\$self->{IOS}} ) {\n      eval { \$_->init ; } ;\n      if ( \$\@ ) {\n         push \@errs, \$\@ ;\n         _debug 'caught ', \$\@ if _debugging;\n      }\n      else {\n         push \@close_on_fail, \$_ ;\n      }\n   }\n\n   ## Loop through the kids and their OPS, interpreting any that require\n   ## parent-side actions.\n   for my \$kid ( \@{\$self->{KIDS}} ) {\n      unless ( ref \$kid->{VAL} eq 'CODE' ) {\n         \$kid->{PATH} = _search_path \$kid->{VAL}->[0] ;\n      }\n      if ( defined \$pipe_read_fd ) {\n\x09 _debug "placing write end of pipe on kid \$kid->{NUM}'s stdin"\n\x09    if _debugging_details ;\n         unshift \@{\$kid->{OPS}}, {\n            TYPE => 'PIPE',  ## Prevent next loop from triggering on this\n            KFD  => 0,\n            TFD  => \$pipe_read_fd,\n         } ;\n         \$pipe_read_fd = undef ;\n      }\n      \@output_fds_accum = () ;\n      for my \$op ( \@{\$kid->{OPS}} ) {\n#         next if \$op->{IS_DEBUG} ;\n         my \$ok = eval {\n            if ( \$op->{TYPE} eq '<' ) {\n               my \$source = \$op->{SOURCE};\n\x09       if ( ! ref \$source ) {\n\x09\x09  _debug(\n\x09\x09     "kid ", \$kid->{NUM}, " to read ", \$op->{KFD},\n\x09\x09     " from '" .  \$source, "' (read only)"\n\x09\x09  ) if _debugging_details ;\n\x09\x09  croak "simulated open failure"\n\x09\x09     if \$self->{_simulate_open_failure} ;\n\x09\x09  \$op->{TFD} = _sysopen( \$source, O_RDONLY ) ;\n\x09\x09  push \@close_on_fail, \$op->{TFD} ;\n\x09       }\n\x09       elsif ( isa( \$source, 'GLOB' )\n\x09\x09  ||   isa( \$source, 'IO::Handle' )\n\x09       ) {\n\x09\x09  croak\n\x09\x09     "Unopened filehandle in input redirect for \$op->{KFD}"\n\x09\x09     unless defined fileno \$source ;\n\x09\x09  \$op->{TFD} = fileno \$source ;\n\x09\x09  _debug(\n\x09\x09     "kid ", \$kid->{NUM}, " to read ", \$op->{KFD},\n\x09\x09     " from fd ", \$op->{TFD}\n\x09\x09  ) if _debugging_details ;\n\x09       }\n\x09       elsif ( isa( \$source, 'SCALAR' ) ) {\n\x09\x09  _debug(\n\x09\x09     "kid ", \$kid->{NUM}, " to read ", \$op->{KFD},\n\x09\x09     " from SCALAR"\n\x09\x09  ) if _debugging_details ;\n\n\x09\x09  \$op->open_pipe( \$self->_debug_fd ) ;\n\x09\x09  push \@close_on_fail, \$op->{KFD}, \$op->{FD} ;\n\n\x09\x09  my \$s = '' ;\n\x09\x09  \$op->{KIN_REF} = \\\$s ;\n\x09       }\n\x09       elsif ( isa( \$source, 'CODE' ) ) {\n\x09\x09  _debug(\n\x09\x09     'kid ', \$kid->{NUM}, ' to read ', \$op->{KFD}, ' from CODE'\n\x09\x09  ) if _debugging_details ;\n\x09\x09  \n\x09\x09  \$op->open_pipe( \$self->_debug_fd ) ;\n\x09\x09  push \@close_on_fail, \$op->{KFD}, \$op->{FD} ;\n\x09\x09  \n\x09\x09  my \$s = '' ;\n\x09\x09  \$op->{KIN_REF} = \\\$s ;\n\x09       }\n\x09       else {\n\x09\x09  croak(\n\x09\x09     "'"\n\x09\x09     . ref( \$source )\n\x09\x09     . "' not allowed as a source for input redirection"\n\x09\x09  ) ;\n\x09       }\n               \$op->_init_filters ;\n            }\n            elsif ( \$op->{TYPE} eq '<pipe' ) {\n               _debug(\n                  'kid to read ', \$op->{KFD},\n                  ' from a pipe IPC::Run opens and returns',\n               ) if _debugging_details ;\n\n               my ( \$r, \$w ) = \$op->open_pipe( \$self->_debug_fd, \$op->{SOURCE} ) ;\n\x09       _debug "caller will write to ", fileno \$op->{SOURCE}\n\x09          if _debugging_details;\n\n               \$op->{TFD}    = \$r ;\n\x09       \$op->{FD}     = undef ; # we don't manage this fd\n               \$op->_init_filters ;\n            }\n            elsif ( \$op->{TYPE} eq '<pty<' ) {\n               _debug(\n                  'kid to read ', \$op->{KFD}, " from pty '", \$op->{PTY_ID}, "'",\n               ) if _debugging_details ;\n               \n               for my \$source ( \$op->{SOURCE} ) {\n                  if ( isa( \$source, 'SCALAR' ) ) {\n                     _debug(\n                        "kid ", \$kid->{NUM}, " to read ", \$op->{KFD},\n                        " from SCALAR via pty '", \$op->{PTY_ID}, "'"\n                     ) if _debugging_details ;\n\n                     my \$s = '' ;\n                     \$op->{KIN_REF} = \\\$s ;\n                  }\n                  elsif ( isa( \$source, 'CODE' ) ) {\n                     _debug(\n                        "kid ", \$kid->{NUM}, " to read ", \$op->{KFD},\n                        " from CODE via pty '", \$op->{PTY_ID}, "'"\n                     ) if _debugging_details ;\n                     my \$s = '' ;\n                     \$op->{KIN_REF} = \\\$s ;\n                  }\n                  else {\n                     croak(\n                        "'"\n                        . ref( \$source )\n                        . "' not allowed as a source for '<pty<' redirection"\n                     ) ;\n                  }\n               }\n               \$op->{FD} = \$self->{PTYS}->{\$op->{PTY_ID}}->fileno ;\n               \$op->{TFD} = undef ; # The fd isn't known until after fork().\n               \$op->_init_filters ;\n            }\n            elsif ( \$op->{TYPE} eq '>' ) {\n               ## N> output redirection.\n               my \$dest = \$op->{DEST} ;\n               if ( ! ref \$dest ) {\n                  _debug(\n                     "kid ", \$kid->{NUM}, " to write ", \$op->{KFD},\n                     " to '", \$dest, "' (write only, create, ",\n                     ( \$op->{TRUNC} ? 'truncate' : 'append' ),\n                     ")"\n                  ) if _debugging_details ;\n                  croak "simulated open failure"\n                     if \$self->{_simulate_open_failure} ;\n                  \$op->{TFD} = _sysopen(\n                     \$dest,\n                     ( O_WRONLY\n                     | O_CREAT \n                     | ( \$op->{TRUNC} ? O_TRUNC : O_APPEND )\n                     )\n                  ) ;\n\x09\x09  if ( Win32_MODE ) {\n\x09\x09     ## I have no idea why this is needed to make the current\n\x09\x09     ## file position survive the gyrations TFD must go \n\x09\x09     ## through...\n\x09\x09     POSIX::lseek( \$op->{TFD}, 0, POSIX::SEEK_END() ) ;\n\x09\x09  }\n                  push \@close_on_fail, \$op->{TFD} ;\n               }\n               elsif ( isa( \$dest, 'GLOB' ) ) {\n                  croak(\n                   "Unopened filehandle in output redirect, command \$kid->{NUM}"\n                  ) unless defined fileno \$dest ;\n                  ## Turn on autoflush, mostly just to flush out\n                  ## existing output.\n                  my \$old_fh = select( \$dest ) ; \$| = 1 ; select( \$old_fh ) ;\n                  \$op->{TFD} = fileno \$dest ;\n                  _debug(\n                     'kid to write ', \$op->{KFD}, ' to handle ', \$op->{TFD}\n                  ) if _debugging_details ;\n               }\n               elsif ( isa( \$dest, 'SCALAR' ) ) {\n                  _debug(\n                     "kid ", \$kid->{NUM}, " to write \$op->{KFD} to SCALAR"\n                  ) if _debugging_details ;\n\n\x09\x09  \$op->open_pipe( \$self->_debug_fd ) ;\n                  push \@close_on_fail, \$op->{FD}, \$op->{TFD} ;\n                  \$\$dest = '' if \$op->{TRUNC} ;\n               }\n               elsif ( isa( \$dest, 'CODE' ) ) {\n                  _debug(\n                     "kid \$kid->{NUM} to write \$op->{KFD} to CODE"\n                  ) if _debugging_details ;\n\n\x09\x09  \$op->open_pipe( \$self->_debug_fd ) ;\n                  push \@close_on_fail, \$op->{FD}, \$op->{TFD} ;\n               }\n               else {\n                  croak(\n                     "'"\n                     . ref( \$dest )\n                     . "' not allowed as a sink for output redirection"\n                  ) ;\n               }\n               \$output_fds_accum[\$op->{KFD}] = \$op ;\n               \$op->_init_filters ;\n            }\n\n            elsif ( \$op->{TYPE} eq '>pipe' ) {\n               ## N> output redirection to a pipe we open, but don't select()\n               ## on.\n               _debug(\n                  "kid ", \$kid->{NUM}, " to write ", \$op->{KFD},\n\x09\x09  ' to a pipe IPC::Run opens and returns'\n               ) if _debugging_details ;\n\n               my ( \$r, \$w ) = \$op->open_pipe( \$self->_debug_fd, \$op->{DEST} ) ;\n\x09       _debug "caller will read from ", fileno \$op->{DEST}\n\x09          if _debugging_details ;\n\n               \$op->{TFD} = \$w ;\n\x09       \$op->{FD}  = undef ; # we don't manage this fd\n               \$op->_init_filters ;\n\n               \$output_fds_accum[\$op->{KFD}] = \$op ;\n            }\n            elsif ( \$op->{TYPE} eq '>pty>' ) {\n               my \$dest = \$op->{DEST} ;\n               if ( isa( \$dest, 'SCALAR' ) ) {\n                  _debug(\n                     "kid ", \$kid->{NUM}, " to write ", \$op->{KFD},\n                     " to SCALAR via pty '", \$op->{PTY_ID}, "'"\n               ) if _debugging_details ;\n\n                  \$\$dest = '' if \$op->{TRUNC} ;\n               }\n               elsif ( isa( \$dest, 'CODE' ) ) {\n                  _debug(\n                     "kid ", \$kid->{NUM}, " to write ", \$op->{KFD},\n                     " to CODE via pty '", \$op->{PTY_ID}, "'"\n                  ) if _debugging_details ;\n               }\n               else {\n                  croak(\n                     "'"\n                     . ref( \$dest )\n                     . "' not allowed as a sink for output redirection"\n                  ) ;\n               }\n\n               \$op->{FD} = \$self->{PTYS}->{\$op->{PTY_ID}}->fileno ;\n               \$op->{TFD} = undef ; # The fd isn't known until after fork().\n               \$output_fds_accum[\$op->{KFD}] = \$op ;\n               \$op->_init_filters ;\n            }\n            elsif ( \$op->{TYPE} eq '|' ) {\n               _debug(\n                  "pipelining \$kid->{NUM} and "\n                  . ( \$kid->{NUM} + 1 )\n               ) if _debugging_details ;\n               ( \$pipe_read_fd, \$op->{TFD} ) = _pipe ;\n\x09       if ( Win32_MODE ) {\n\x09\x09  _dont_inherit( \$pipe_read_fd ) ;\n\x09\x09  _dont_inherit( \$op->{TFD} ) ;\n\x09       }\n               \@output_fds_accum = () ;\n            }\n            elsif ( \$op->{TYPE} eq '&' ) {\n               \@output_fds_accum = () ;\n            } # end if \$op->{TYPE} tree\n\x09    1;\n\x09 } ; # end eval\n\x09 unless ( \$ok ) {\n\x09    push \@errs, \$\@ ;\n\x09    _debug 'caught ', \$\@ if _debugging;\n\x09 }\n      } # end for ( OPS }\n   }\n\n   if ( \@errs ) {\n      for ( \@close_on_fail ) {\n         _close( \$_ ) ;\n         \$_ = undef ;\n      }\n      for ( keys %{\$self->{PTYS}} ) {\n         next unless \$self->{PTYS}->{\$_} ;\n         close \$self->{PTYS}->{\$_} ;\n         \$self->{PTYS}->{\$_} = undef ;\n      }\n      die join( '', \@errs )\n   }\n\n   ## give all but the last child all of the output file descriptors\n   ## These will be reopened (and thus rendered useless) if the child\n   ## dup2s on to these descriptors, since we unshift these.  This way\n   ## each process emits output to the same file descriptors that the\n   ## last child will write to.  This is probably not quite correct,\n   ## since each child should write to the file descriptors inherited\n   ## from the parent.\n   ## TODO: fix the inheritance of output file descriptors.\n   ## NOTE: This sharing of OPS among kids means that we can't easily put\n   ## a kid number in each OPS structure to ping the kid when all ops\n   ## have closed (when \$self->{PIPES} has emptied).  This means that we\n   ## need to scan the KIDS whenever \@{\$self->{PIPES}} is empty to see\n   ## if there any of them are still alive.\n   for ( my \$num = 0 ; \$num < \$#{\$self->{KIDS}} ; ++\$num ) {\n      for ( reverse \@output_fds_accum ) {\n         next unless defined \$_ ;\n         _debug(\n            'kid ', \$self->{KIDS}->[\$num]->{NUM}, ' also to write ', \$_->{KFD},\n            ' to ', ref \$_->{DEST}\n         ) if _debugging_details ;\n         unshift \@{\$self->{KIDS}->[\$num]->{OPS}}, \$_ ;\n      }\n   }\n\n   ## Open the debug pipe if we need it\n   ## Create the list of PIPES we need to scan and the bit vectors needed by\n   ## select().  Do this first so that _cleanup can _clobber() them if an\n   ## exception occurs.\n   \@{\$self->{PIPES}} = () ;\n   \$self->{RIN} = '' ;\n   \$self->{WIN} = '' ;\n   \$self->{EIN} = '' ;\n   ## PIN is a vec()tor that indicates who's paused.\n   \$self->{PIN} = '' ;\n   for my \$kid ( \@{\$self->{KIDS}} ) {\n      for ( \@{\$kid->{OPS}} ) {\n         if ( defined \$_->{FD} ) {\n            _debug(\n               'kid ', \$kid->{NUM}, '[', \$kid->{PID}, "]'s ", \$_->{KFD},\n               ' is my ', \$_->{FD}\n            ) if _debugging_details ;\n            vec( \$self->{ \$_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, \$_->{FD}, 1 ) = 1 ;\n#\x09    vec( \$self->{EIN}, \$_->{FD}, 1 ) = 1 ;\n            push \@{\$self->{PIPES}}, \$_ ;\n         }\n      }\n   }\n\n   for my \$io ( \@{\$self->{IOS}} ) {\n      my \$fd = \$io->fileno ;\n      vec( \$self->{RIN}, \$fd, 1 ) = 1 if \$io->mode =~ /r/ ;\n      vec( \$self->{WIN}, \$fd, 1 ) = 1 if \$io->mode =~ /w/ ;\n#      vec( \$self->{EIN}, \$fd, 1 ) = 1 ;\n      push \@{\$self->{PIPES}}, \$io ;\n   }\n\n   ## Put filters on the end of the filter chains to read & write the pipes.\n   ## Clear pipe states\n   for my \$pipe ( \@{\$self->{PIPES}} ) {\n      \$pipe->{SOURCE_EMPTY} = 0 ;\n      \$pipe->{PAUSED} = 0 ;\n      if ( \$pipe->{TYPE} =~ /^>/ ) {\n         my \$pipe_reader = sub {\n            my ( undef, \$out_ref ) = \@_ ;\n\n            return undef unless defined \$pipe->{FD} ;\n            return 0 unless vec( \$self->{ROUT}, \$pipe->{FD}, 1 ) ;\n\n            vec( \$self->{ROUT}, \$pipe->{FD}, 1 ) = 0 ;\n\n            _debug_desc_fd( 'reading from', \$pipe ) if _debugging_details ;\n            my \$in = eval { _read( \$pipe->{FD} ) } ;\n            if ( \$\@ ) {\n               \$in = '' ;\n               ## IO::Pty throws the Input/output error if the kid dies.\n\x09       ## read() throws the bad file descriptor message if the\n\x09       ## kid dies on Win32.\n               die \$\@ unless\n\x09          \$\@ =~ /^Input\\/output error: read/\n\x09\x09  || ( Win32_MODE && \$\@ =~ /Bad file descriptor/ ) ;\n            }\n\n            unless ( length \$in ) {\n               \$self->_clobber( \$pipe ) ;\n               return undef ;\n            }\n\n            ## Protect the position so /.../g matches may be used.\n            my \$pos = pos \$\$out_ref ;\n            \$\$out_ref .= \$in ;\n            pos( \$\$out_ref ) = \$pos ;\n            return 1 ;\n         } ;\n         ## Input filters are the last filters\n         push \@{\$pipe->{FILTERS}}, \$pipe_reader ;\n         push \@{\$self->{TEMP_FILTERS}}, \$pipe_reader ;\n      }\n      else {\n         my \$pipe_writer = sub {\n            my ( \$in_ref, \$out_ref ) = \@_ ;\n            return undef unless defined \$pipe->{FD} ;\n            return 0\n               unless vec( \$self->{WOUT}, \$pipe->{FD}, 1 )\n                  || \$pipe->{PAUSED} ;\n\n            vec( \$self->{WOUT}, \$pipe->{FD}, 1 ) = 0 ;\n\n            if ( ! length \$\$in_ref ) {\n               if ( ! defined get_more_input ) {\n                  \$self->_clobber( \$pipe ) ;\n                  return undef ;\n               }\n            }\n\n            unless ( length \$\$in_ref ) {\n               unless ( \$pipe->{PAUSED} ) {\n                  _debug_desc_fd( 'pausing', \$pipe ) if _debugging_details ;\n                  vec( \$self->{WIN}, \$pipe->{FD}, 1 ) = 0 ;\n#\x09\x09  vec( \$self->{EIN}, \$pipe->{FD}, 1 ) = 0 ;\n                  vec( \$self->{PIN}, \$pipe->{FD}, 1 ) = 1 ;\n                  \$pipe->{PAUSED} = 1 ;\n               }\n               return 0 ;\n            }\n            _debug_desc_fd( 'writing to', \$pipe ) if _debugging_details ;\n\n            my \$c = _write( \$pipe->{FD}, \$\$in_ref ) ;\n            substr( \$\$in_ref, 0, \$c, '' ) ;\n            return 1 ;\n         } ;\n         ## Output filters are the first filters\n         unshift \@{\$pipe->{FILTERS}}, \$pipe_writer ;\n         push    \@{\$self->{TEMP_FILTERS}}, \$pipe_writer ;\n      }\n   }\n}\n\n\nsub _dup2_gently {\n   ## A METHOD, NOT A FUNCTION, NEEDS \$self!\n   my IPC::Run \$self = shift ;\n   my ( \$files, \$fd1, \$fd2 ) = \@_ ;\n   ## Moves TFDs that are using the destination fd out of the\n   ## way before calling _dup2\n   for ( \@\$files ) {\n      next unless defined \$_->{TFD} ;\n      \$_->{TFD} = _dup( \$_->{TFD} ) if \$_->{TFD} == \$fd2 ;\n   }\n   \$self->{DEBUG_FD} = _dup \$self->{DEBUG_FD}\n      if defined \$self->{DEBUG_FD} && \$self->{DEBUG_FD} == \$fd2 ;\n\n   _dup2_rudely( \$fd1, \$fd2 ) ;\n}\n\n=item close_terminal\n\nThis is used as (or in) an init sub to cast off the bonds of a controlling\nterminal.  It must precede all other redirection ops that affect\nSTDIN, STDOUT, or STDERR to be guaranteed effective.\n\n=cut\n\n\nsub close_terminal {\n   ## Cast of the bonds of a controlling terminal\n\n   POSIX::setsid() || croak "POSIX::setsid() failed" ;\n   _debug "closing stdin, out, err"\n      if _debugging_details ;\n   close STDIN ;\n   close STDERR ;\n   close STDOUT ;\n}\n\n\nsub _do_kid_and_exit {\n   my IPC::Run \$self = shift ;\n   my ( \$kid ) = \@_ ;\n\n   ## For unknown reasons, placing these two statements in the eval{}\n   ## causes the eval {} to not catch errors after they are executed in\n   ## perl 5.6.0, godforsaken version that it is...not sure about 5.6.1.\n   ## Part of this could be that these symbols get destructed when\n   ## exiting the eval, and that destruction might be what's (wrongly)\n   ## confusing the eval{}, allowing the exception to probpogate.\n   my \$s1 = gensym ;\n   my \$s2 = gensym ;\n\n   eval {\n      local \$cur_self = \$self ;\n\n      _set_child_debug_name( ref \$kid->{VAL} eq "CODE"\n\x09 ? "CODE"\n\x09 : basename( \$kid->{VAL}->[0] )\n      );\n\n      ## close parent FD's first so they're out of the way.\n      ## Don't close STDIN, STDOUT, STDERR: they should be inherited or\n      ## overwritten below.\n      my \@needed = \$self->{noinherit} ? () : ( 1, 1, 1 ) ;\n      \$needed[ \$self->{SYNC_WRITER_FD} ] = 1 ;\n      \$needed[ \$self->{DEBUG_FD} ] = 1 if defined \$self->{DEBUG_FD} ;\n\n      for ( \@{\$kid->{OPS}} ) {\n\x09 \$needed[ \$_->{TFD} ] = 1 if defined \$_->{TFD} ;\n      }\n\n      ## TODO: use the forthcoming IO::Pty to close the terminal and\n      ## make the first pty for this child the controlling terminal.\n      ## This will also make it so that pty-laden kids don't cause\n      ## other kids to lose stdin/stdout/stderr.\n      my \@closed ;\n      if ( %{\$self->{PTYS}} ) {\n\x09 ## Clean up the parent's fds.\n\x09 for ( keys %{\$self->{PTYS}} ) {\n\x09    _debug "Cleaning up parent's ptty '\$_'" if _debugging_details ;\n\x09    my \$slave = \$self->{PTYS}->{\$_}->slave ;\n\x09    \$closed[ \$self->{PTYS}->{\$_}->fileno ] = 1 ;\n\x09    close \$self->{PTYS}->{\$_} ;\n\x09    \$self->{PTYS}->{\$_} = \$slave ;\n\x09 }\n\n\x09 close_terminal ;\n\x09 \$closed[ \$_ ] = 1 for ( 0..2 ) ;\n      }\n\n      for my \$sibling ( \@{\$self->{KIDS}} ) {\n\x09 for ( \@{\$sibling->{OPS}} ) {\n\x09    if ( \$_->{TYPE} =~ /^.pty.\$/ ) {\n\x09       \$_->{TFD} = \$self->{PTYS}->{\$_->{PTY_ID}}->fileno ;\n\x09       \$needed[\$_->{TFD}] = 1 ;\n\x09    }\n\n#\x09    for ( \$_->{FD}, ( \$sibling != \$kid ? \$_->{TFD} : () ) ) {\n#\x09       if ( defined \$_ && ! \$closed[\$_] && ! \$needed[\$_] ) {\n#\x09\x09  _close( \$_ ) ;\n#\x09\x09  \$closed[\$_] = 1 ;\n#\x09\x09  \$_ = undef ;\n#\x09       }\n#\x09    }\n\x09 }\n      }\n\n      ## This is crude: we have no way of keeping track of browsing all open\n      ## fds, so we scan to a fairly high fd.\n      _debug "open fds: ", join " ", keys %fds if _debugging_details ;\n      for (keys %fds) {\n         if ( ! \$closed[\$_] && ! \$needed[\$_] ) {\n            _close( \$_ ) ;\n            \$closed[\$_] = 1 ;\n         }\n      }\n\n      ## Lazy closing is so the same fd (ie the same TFD value) can be dup2'ed on\n      ## several times.\n      my \@lazy_close ;\n      for ( \@{\$kid->{OPS}} ) {\n\x09 if ( defined \$_->{TFD} ) {\n\x09    unless ( \$_->{TFD} == \$_->{KFD} ) {\n\x09       \$self->_dup2_gently( \$kid->{OPS}, \$_->{TFD}, \$_->{KFD} ) ;\n\x09       push \@lazy_close, \$_->{TFD} ;\n\x09    }\n\x09 }\n\x09 elsif ( \$_->{TYPE} eq 'dup' ) {\n\x09    \$self->_dup2_gently( \$kid->{OPS}, \$_->{KFD1}, \$_->{KFD2} )\n\x09       unless \$_->{KFD1} == \$_->{KFD2} ;\n\x09 }\n\x09 elsif ( \$_->{TYPE} eq 'close' ) {\n\x09    for ( \$_->{KFD} ) {\n\x09       if ( ! \$closed[\$_] ) {\n\x09\x09  _close( \$_ ) ;\n\x09\x09  \$closed[\$_] = 1 ;\n\x09\x09  \$_ = undef ;\n\x09       }\n\x09    }\n\x09 }\n\x09 elsif ( \$_->{TYPE} eq 'init' ) {\n\x09    \$_->{SUB}->() ;\n\x09 }\n      }\n\n      for ( \@lazy_close ) {\n\x09 unless ( \$closed[\$_] ) {\n\x09    _close( \$_ ) ;\n\x09    \$closed[\$_] = 1 ;\n\x09 }\n      }\n\n      if ( ref \$kid->{VAL} ne 'CODE' ) {\n\x09 open \$s1, ">&=\$self->{SYNC_WRITER_FD}"\n\x09    or croak "\$! setting filehandle to fd SYNC_WRITER_FD" ;\n\x09 fcntl \$s1, F_SETFD, 1 ;\n\n\x09 if ( defined \$self->{DEBUG_FD} ) {\n\x09    open \$s2, ">&=\$self->{DEBUG_FD}"\n\x09       or croak "\$! setting filehandle to fd DEBUG_FD" ;\n\x09    fcntl \$s2, F_SETFD, 1 ;\n\x09 }\n\n\x09 my \@cmd = ( \$kid->{PATH}, \@{\$kid->{VAL}}[1..\$#{\$kid->{VAL}}] ) ;\n\x09 _debug 'execing ', join " ", map { /[\\s"]/ ? "'\$_'" : \$_ } \@cmd\n\x09    if _debugging ;\n\n\x09 die "exec failed: simulating exec() failure"\n\x09    if \$self->{_simulate_exec_failure} ;\n\n\x09 _exec \$kid->{PATH}, \@{\$kid->{VAL}}[1..\$#{\$kid->{VAL}}] ;\n\n\x09 croak "exec failed: \$!" ;\n      }\n   } ;\n   if ( \$\@ ) {\n      _write \$self->{SYNC_WRITER_FD}, \$\@ ;\n      ## Avoid DESTROY.\n      POSIX::exit 1  ;\n   }\n\n   ## We must be executing code in the child, otherwise exec() would have\n   ## prevented us from being here.\n   _close \$self->{SYNC_WRITER_FD} ;\n   _debug 'calling fork()ed CODE ref' if _debugging;\n   POSIX::close \$self->{DEBUG_FD}      if defined \$self->{DEBUG_FD} ;\n   ## TODO: Overload CORE::GLOBAL::exit...\n   \$kid->{VAL}->() ;\n\n   ## There are bugs in perl closures up to and including 5.6.1\n   ## that may keep this next line from having any effect, and it\n   ## won't have any effect if our caller has kept a copy of it, but\n   ## this may cause the closure to be cleaned up.  Maybe.\n   \$kid->{VAL} = undef ;\n\n   ## Use POSIX::exit to avoid global destruction, since this might\n   ## cause DESTROY() to be called on objects created in the parent\n   ## and thus cause double cleanup.  For instance, if DESTROY() unlinks\n   ## a file in the child, we don't want the parent to suddenly miss\n   ## it.\n   POSIX::exit 0 ;\n}\n\n\n=item start\n\n   \$h = start(\n      \\\@cmd, \\\$in, \\\$out, ...,\n      timeout( 30, name => "process timeout" ),\n      \$stall_timeout = timeout( 10, name => "stall timeout"   ),\n   ) ;\n\n   \$h = start \\\@cmd, '<', \\\$in, '|', \\\@cmd2, ... ;\n\nstart() accepts a harness or harness specification and returns a harness\nafter building all of the pipes and launching (via fork()/exec(), or, maybe\nsomeday, spawn()) all the child processes.  It does not send or receive any\ndata on the pipes, see pump() and finish() for that.\n\nYou may call harness() and then pass it's result to start() if you like,\nbut you only need to if it helps you structure or tune your application.\nIf you do call harness(), you may skip start() and proceed directly to\npump.\n\nstart() also starts all timers in the harness.  See L<IPC::Run::Timer>\nfor more information.\n\nstart() flushes STDOUT and STDERR to help you avoid duplicate output.\nIt has no way of asking Perl to flush all your open filehandles, so\nyou are going to need to flush any others you have open.  Sorry.\n\nHere's how if you don't want to alter the state of \$| for your\nfilehandle:\n\n   \$ofh = select HANDLE ; \$of = \$| ; \$| = 1 ; \$| = \$of ; select \$ofh;\n\nIf you don't mind leaving output unbuffered on HANDLE, you can do\nthe slightly shorter\n\n   \$ofh = select HANDLE ; \$| = 1 ; select \$ofh;\n\nOr, you can use IO::Handle's flush() method:\n\n   use IO::Handle ;\n   flush HANDLE ;\n\nPerl needs the equivalent of C's fflush( (FILE *)NULL ).\n\n=cut\n\nsub start {\n# \$SIG{__DIE__} = sub { my \$s = shift ; Carp::cluck \$s ; die \$s } ;\n   my \$options ;\n   if ( \@_ && ref \$_[-1] eq 'HASH' ) {\n      \$options = pop ;\n      require Data::Dumper ;\n      carp "Passing in options as a hash is deprecated:\\n", Data::Dumper::Dumper( \$options ) ;\n   }\n\n   my IPC::Run \$self ;\n   if ( \@_ == 1 && isa( \$_[0], __PACKAGE__ ) ) {\n      \$self = shift ;\n      \$self->{\$_} = \$options->{\$_} for keys %\$options ;\n   }\n   else {\n      \$self = harness( \@_, \$options ? \$options : () ) ;\n   }\n\n   local \$cur_self = \$self ;\n\n   \$self->kill_kill if \$self->{STATE} == _started ;\n\n   _debug "** starting" if _debugging;\n\n   \$_->{RESULT} = undef for \@{\$self->{KIDS}} ;\n\n   ## Assume we're not being called from &run.  It will correct our\n   ## assumption if need be.  This affects whether &_select_loop clears\n   ## input queues to '' when they're empty.\n   \$self->{clear_ins} = 1 ;\n\n   IPC::Run::Win32Helper::optimize \$self\n       if Win32_MODE && \$in_run;\n\n   my \@errs ;\n\n   for ( \@{\$self->{TIMERS}} ) {\n      eval { \$_->start } ;\n      if ( \$\@ ) {\n         push \@errs, \$\@ ;\n         _debug 'caught ', \$\@ if _debugging;\n      }\n   }\n\n   eval { \$self->_open_pipes } ;\n   if ( \$\@ ) {\n      push \@errs, \$\@ ;\n      _debug 'caught ', \$\@ if _debugging;\n   }\n\n   if ( ! \@errs ) {\n      ## This is a bit of a hack, we should do it for all open filehandles.\n      ## Since there's no way I know of to enumerate open filehandles, we\n      ## autoflush STDOUT and STDERR.  This is done so that the children don't\n      ## inherit output buffers chock full o' redundant data.  It's really\n      ## confusing to track that down.\n      { my \$ofh = select STDOUT ; local \$| = 1 ; select \$ofh; }\n      { my \$ofh = select STDERR ; local \$| = 1 ; select \$ofh; }\n      for my \$kid ( \@{\$self->{KIDS}} ) {\n         \$kid->{RESULT} = undef ;\n         _debug "child: ",\n            ref( \$kid->{VAL} ) eq "CODE"\n            ? "CODE ref"\n            : (\n               "`",\n               join( " ", map /[^\\w.-]/ ? "'\$_'" : \$_, \@{\$kid->{VAL}} ),\n               "`"\n            ) if _debugging_details ;\n         eval {\n            croak "simulated failure of fork"\n               if \$self->{_simulate_fork_failure} ;\n            unless ( Win32_MODE ) {\n\x09       \$self->_spawn( \$kid ) ;\n            }\n            else {\n## TODO: Test and debug spawing code.  Someday.\n               _debug( \n                  'spawning ',\n                  join(\n                     ' ',\n                     map(\n                        "'\$_'",\n                        ( \$kid->{PATH}, \@{\$kid->{VAL}}[1..\$#{\$kid->{VAL}}] )\n                     )\n                  )\n               ) if _debugging;\n\x09       ## The external kid wouldn't know what to do with it anyway.\n\x09       ## This is only used by the "helper" pump processes on Win32.\n\x09       _dont_inherit( \$self->{DEBUG_FD} ) ;\n               ( \$kid->{PID}, \$kid->{PROCESS} ) =\n\x09\x09  IPC::Run::Win32Helper::win32_spawn( \n\x09\x09     [ \$kid->{PATH}, \@{\$kid->{VAL}}[1..\$#{\$kid->{VAL}}] ],\n\x09\x09     \$kid->{OPS},\n\x09\x09  ) ;\n               _debug "spawn() = ", \$kid->{PID} if _debugging;\n            }\n         } ;\n         if ( \$\@ ) {\n            push \@errs, \$\@ ;\n            _debug 'caught ', \$\@ if _debugging;\n         }\n      }\n   }\n\n   ## Close all those temporary filehandles that the kids needed.\n   for my \$pty ( values %{\$self->{PTYS}} ) {\n      close \$pty->slave ;\n   }\n\n   my \@closed ;\n   for my \$kid ( \@{\$self->{KIDS}} ) {\n      for ( \@{\$kid->{OPS}} ) {\n         my \$close_it = eval {\n            defined \$_->{TFD}\n               && ! \$_->{DONT_CLOSE}\n               && ! \$closed[\$_->{TFD}]\n               && ( ! Win32_MODE || ! \$_->{RECV_THROUGH_TEMP_FILE} ) ## Win32 hack\n         } ;\n         if ( \$\@ ) {\n            push \@errs, \$\@ ;\n            _debug 'caught ', \$\@ if _debugging;\n         }\n         if ( \$close_it || \$\@ ) {\n            eval {\n               _close( \$_->{TFD} ) ;\n               \$closed[\$_->{TFD}] = 1 ;\n               \$_->{TFD} = undef ;\n            } ;\n            if ( \$\@ ) {\n               push \@errs, \$\@ ;\n               _debug 'caught ', \$\@ if _debugging;\n            }\n         }\n      }\n   }\nconfess "gak!" unless defined \$self->{PIPES} ;\n\n   if ( \@errs ) {\n      eval { \$self->_cleanup } ;\n      warn \$\@ if \$\@ ;\n      die join( '', \@errs ) ;\n   }\n\n   \$self->{STATE} = _started ;\n   return \$self ;\n}\n\n\nsub adopt {\n   ## NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN.  SEE\n   ## t/adopt.t for a test suite.\n   my IPC::Run \$self = shift ;\n\n   for my \$adoptee ( \@_ ) {\n      push \@{\$self->{IOS}},    \@{\$adoptee->{IOS}} ;\n      ## NEED TO RENUMBER THE KIDS!!\n      push \@{\$self->{KIDS}},   \@{\$adoptee->{KIDS}} ;\n      push \@{\$self->{PIPES}},  \@{\$adoptee->{PIPES}} ;\n      \$self->{PTYS}->{\$_} = \$adoptee->{PTYS}->{\$_}\n         for keys %{\$adoptee->{PYTS}} ;\n      push \@{\$self->{TIMERS}}, \@{\$adoptee->{TIMERS}} ;\n      \$adoptee->{STATE} = _finished ;\n   }\n}\n\n\nsub _clobber {\n   my IPC::Run \$self = shift ;\n   my ( \$file ) = \@_ ;\n   _debug_desc_fd( "closing", \$file ) if _debugging_details ;\n   my \$doomed = \$file->{FD} ;\n   my \$dir = \$file->{TYPE} =~ /^</ ? 'WIN' : 'RIN' ;\n   vec( \$self->{\$dir}, \$doomed, 1 ) = 0 ;\n#   vec( \$self->{EIN},  \$doomed, 1 ) = 0 ;\n   vec( \$self->{PIN},  \$doomed, 1 ) = 0 ;\n   if ( \$file->{TYPE} =~ /^(.)pty.\$/ ) {\n      if ( \$1 eq '>' ) {\n         ## Only close output ptys.  This is so that ptys as inputs are\n         ## never autoclosed, which would risk losing data that was\n         ## in the slave->parent queue.\n         _debug_desc_fd "closing pty", \$file if _debugging_details ;\n         close \$self->{PTYS}->{\$file->{PTY_ID}}\n            if defined \$self->{PTYS}->{\$file->{PTY_ID}} ;\n         \$self->{PTYS}->{\$file->{PTY_ID}} = undef ;\n      }\n   }\n   elsif ( isa( \$file, 'IPC::Run::IO' ) ) {\n      \$file->close unless \$file->{DONT_CLOSE} ;\n   }\n   else {\n      _close( \$doomed ) ;\n   }\n\n   \@{\$self->{PIPES}} = grep\n      defined \$_->{FD} && ( \$_->{TYPE} ne \$file->{TYPE} || \$_->{FD} ne \$doomed),\n      \@{\$self->{PIPES}} ;\n\n   \$file->{FD} = undef ;\n}\n\nsub _select_loop {\n   my IPC::Run \$self = shift ;\n\n   my \$io_occurred ;\n\n   my \$not_forever = 0.01 ;\n\nSELECT:\n   while ( \$self->pumpable ) {\n      if ( \$io_occurred && \$self->{break_on_io} ) {\n         _debug "exiting _select(): io occured and break_on_io set"\n\x09    if _debugging_details ;\n         last ;\n      }\n\n      my \$timeout = \$self->{non_blocking} ? 0 : undef ;\n\n      if ( \@{\$self->{TIMERS}} ) {\n         my \$now = time ;\n         my \$time_left ;\n         for ( \@{\$self->{TIMERS}} ) {\n            next unless \$_->is_running ;\n            \$time_left = \$_->check( \$now ) ;\n            ## Return when a timer expires\n            return if defined \$time_left && ! \$time_left ;\n            \$timeout = \$time_left\n               if ! defined \$timeout || \$time_left < \$timeout ;\n         }\n      }\n\n      ##\n      ## See if we can unpause any input channels\n      ##\n      my \$paused = 0 ;\n\n      for my \$file ( \@{\$self->{PIPES}} ) {\n         next unless \$file->{PAUSED} && \$file->{TYPE} =~ /^</ ;\n\n         _debug_desc_fd( "checking for more input", \$file ) if _debugging_details ;\n         my \$did ;\n         1 while \$did = \$file->_do_filters( \$self ) ;\n         if ( defined \$file->{FD} && ! defined( \$did ) || \$did ) {\n            _debug_desc_fd( "unpausing", \$file ) if _debugging_details ;\n            \$file->{PAUSED} = 0 ;\n            vec( \$self->{WIN}, \$file->{FD}, 1 ) = 1 ;\n#\x09    vec( \$self->{EIN}, \$file->{FD}, 1 ) = 1 ;\n            vec( \$self->{PIN}, \$file->{FD}, 1 ) = 0 ;\n         }\n         else {\n            ## This gets incremented occasionally when the IO channel\n            ## was actually closed.  That's a bug, but it seems mostly\n            ## harmless: it causes us to exit if break_on_io, or to set\n            ## the timeout to not be forever.  I need to fix it, though.\n            ++\$paused ;\n         }\n      }\n\n      if ( _debugging_details ) {\n         my \$map = join(\n            '',\n            map {\n               my \$out ;\n               \$out = 'r'                     if vec( \$self->{RIN}, \$_, 1 ) ;\n               \$out = \$out ? 'b' : 'w'        if vec( \$self->{WIN}, \$_, 1 ) ;\n               \$out = 'p'           if ! \$out && vec( \$self->{PIN}, \$_, 1 ) ;\n               \$out = \$out ? uc( \$out ) : 'x' if vec( \$self->{EIN}, \$_, 1 ) ;\n               \$out = '-' unless \$out ;\n               \$out ;\n            } (0..1024)\n         ) ;\n         \$map =~ s/((?:[a-zA-Z-]|\\([^\\)]*\\)){12,}?)-*\$/\$1/ ;\n         _debug 'fds for select: ', \$map if _debugging_details ;\n      }\n\n      ## _do_filters may have closed our last fd, and we need to see if\n      ## we have I/O, or are just waiting for children to exit.\n      my \$p = \$self->pumpable;\n      last unless \$p;\n      if ( \$p > 0  && ( ! defined \$timeout || \$timeout > 0.1 ) ) {\n         ## No I/O will wake the select loop up, but we have children\n         ## lingering, so we need to poll them with a short timeout.\n\x09 ## Otherwise, assume more input will be coming.\n\x09 \$timeout = \$not_forever ;\n         \$not_forever *= 2 ;\n         \$not_forever = 0.5 if \$not_forever >= 0.5 ;\n      }\n\n      ## Make sure we don't block forever in select() because inputs are\n      ## paused.\n      if ( ! defined \$timeout && ! ( \@{\$self->{PIPES}} - \$paused ) ) {\n         ## Need to return if we're in pump and all input is paused, or\n\x09 ## we'll loop until all inputs are unpaused, which is darn near\n\x09 ## forever.  And a day.\n         if ( \$self->{break_on_io} ) {\n\x09    _debug "exiting _select(): no I/O to do and timeout=forever"\n               if _debugging;\n\x09    last ;\n\x09 }\n\n\x09 ## Otherwise, assume more input will be coming.\n\x09 \$timeout = \$not_forever ;\n         \$not_forever *= 2 ;\n         \$not_forever = 0.5 if \$not_forever >= 0.5 ;\n      }\n\n      _debug 'timeout=', defined \$timeout ? \$timeout : 'forever'\n         if _debugging_details ;\n\n      my \$nfound ;\n      unless ( Win32_MODE ) {\n         \$nfound = select(\n            \$self->{ROUT} = \$self->{RIN},\n            \$self->{WOUT} = \$self->{WIN},\n            \$self->{EOUT} = \$self->{EIN},\n            \$timeout \n\x09 ) ;\n      }\n      else {\n\x09 my \@in = map \$self->{\$_}, qw( RIN WIN EIN ) ;\n\x09 ## Win32's select() on Win32 seems to die if passed vectors of\n\x09 ## all 0's.  Need to report this when I get back online.\n\x09 for ( \@in ) {\n\x09    \$_ = undef unless index( ( unpack "b*", \$_ ), 1 ) >= 0 ;\n\x09 }\n\n\x09 \$nfound = select(\n            \$self->{ROUT} = \$in[0],\n            \$self->{WOUT} = \$in[1],\n            \$self->{EOUT} = \$in[2],\n            \$timeout \n         ) ;\n\n\x09 for ( \$self->{ROUT}, \$self->{WOUT}, \$self->{EOUT} ) {\n\x09    \$_ = "" unless defined \$_ ;\n\x09 }\n      }\n      last if ! \$nfound && \$self->{non_blocking} ;\n\n      croak "\$! in select" if \$nfound < 0 ;\n      if ( _debugging_details ) {\n         my \$map = join(\n            '',\n            map {\n               my \$out ;\n               \$out = 'r'                     if vec( \$self->{ROUT}, \$_, 1 ) ;\n               \$out = \$out ? 'b' : 'w'        if vec( \$self->{WOUT}, \$_, 1 ) ;\n               \$out = \$out ? uc( \$out ) : 'x' if vec( \$self->{EOUT}, \$_, 1 ) ;\n               \$out = '-' unless \$out ;\n               \$out ;\n            } (0..128)\n         ) ;\n         \$map =~ s/((?:[a-zA-Z-]|\\([^\\)]*\\)){12,}?)-*\$/\$1/ ;\n         _debug "selected  ", \$map ;\n      }\n\n      ## Need to copy since _clobber alters \@{\$self->{PIPES}}.\n      ## TODO: Rethink _clobber().  Rethink \$file->{PAUSED}, too.\n      my \@pipes = \@{\$self->{PIPES}} ;\n      \$io_occurred = \$_->poll( \$self ) ? 1 : \$io_occurred for \@pipes;\n#   FILE:\n#      for my \$pipe ( \@pipes ) {\n#         ## Pipes can be shared among kids.  If another kid closes the\n#         ## pipe, then it's {FD} will be undef.  Also, on Win32, pipes can\n#\x09 ## be optimized to be files, in which case the FD is left undef\n#\x09 ## so we don't try to select() on it.\n#         if ( \$pipe->{TYPE} =~ /^>/\n#            && defined \$pipe->{FD}\n#            && vec( \$self->{ROUT}, \$pipe->{FD}, 1 )\n#         ) {\n#            _debug_desc_fd( "filtering data from", \$pipe ) if _debugging_details ;\n#confess "phooey" unless isa( \$pipe, "IPC::Run::IO" ) ;\n#            \$io_occurred = 1 if \$pipe->_do_filters( \$self ) ;\n#\n#            next FILE unless defined \$pipe->{FD} ;\n#         }\n#\n#\x09 ## On Win32, pipes to the child can be optimized to be files\n#\x09 ## and FD left undefined so we won't select on it.\n#         if ( \$pipe->{TYPE} =~ /^</\n#            && defined \$pipe->{FD}\n#            && vec( \$self->{WOUT}, \$pipe->{FD}, 1 )\n#         ) {\n#            _debug_desc_fd( "filtering data to", \$pipe ) if _debugging_details ;\n#            \$io_occurred = 1 if \$pipe->_do_filters( \$self ) ;\n#\n#            next FILE unless defined \$pipe->{FD} ;\n#         }\n#\n#         if ( defined \$pipe->{FD} && vec( \$self->{EOUT}, \$pipe->{FD}, 1 ) ) {\n#            ## BSD seems to sometimes raise the exceptional condition flag\n#            ## when a pipe is closed before we read it's last data.  This\n#            ## causes spurious warnings and generally renders the exception\n#            ## mechanism useless for our purposes.  The exception\n#            ## flag semantics are too variable (they're device driver\n#            ## specific) for me to easily map to any automatic action like\n#            ## warning or croaking (try running v0.42 if you don't beleive me\n#            ## :-).\n#            warn "Exception on descriptor \$pipe->{FD}" ;\n#         }\n#      }\n   }\n\n   return ;\n}\n\n\nsub _cleanup {\n   my IPC::Run \$self = shift ;\n   _debug "cleaning up" if _debugging_details ;\n\n   for ( values %{\$self->{PTYS}} ) {\n      next unless ref \$_ ;\n      eval {\n         _debug "closing slave fd ", fileno \$_->slave if _debugging_data;\n         close \$_->slave ;\n      } ;\n      carp \$\@ . " while closing ptys" if \$\@ ;\n      eval {\n         _debug "closing master fd ", fileno \$_ if _debugging_data;\n         close \$_ ;\n      } ;\n      carp \$\@ . " closing ptys" if \$\@ ;\n   }\n   \n   _debug "cleaning up pipes" if _debugging_details ;\n   ## _clobber modifies PIPES\n   \$self->_clobber( \$self->{PIPES}->[0] ) while \@{\$self->{PIPES}} ;\n\n   for my \$kid ( \@{\$self->{KIDS}} ) {\n      _debug "cleaning up kid ", \$kid->{NUM} if _debugging_details ;\n      if ( ! length \$kid->{PID} ) {\n         _debug 'never ran child ', \$kid->{NUM}, ", can't reap"\n            if _debugging;\n         for my \$op ( \@{\$kid->{OPS}} ) {\n            _close( \$op->{TFD} )\n               if defined \$op->{TFD} && ! defined \$op->{TEMP_FILE_HANDLE};\n         }\n      }\n      elsif ( ! defined \$kid->{RESULT} ) {\n         _debug 'reaping child ', \$kid->{NUM}, ' (pid ', \$kid->{PID}, ')'\n            if _debugging;\n         my \$pid = waitpid \$kid->{PID}, 0 ;\n         \$kid->{RESULT} = \$? ;\n         _debug 'reaped ', \$pid, ', \$?=', \$kid->{RESULT}\n            if _debugging;\n      }\n\n#      if ( defined \$kid->{DEBUG_FD} ) {\n#\x09 die;\n#         \@{\$kid->{OPS}} = grep\n#            ! defined \$_->{KFD} || \$_->{KFD} != \$kid->{DEBUG_FD},\n#            \@{\$kid->{OPS}} ;\n#         \$kid->{DEBUG_FD} = undef ;\n#      }\n\n      _debug "cleaning up filters" if _debugging_details ;\n      for my \$op ( \@{\$kid->{OPS}} ) {\n         \@{\$op->{FILTERS}} = grep {\n            my \$filter = \$_ ;\n            ! grep \$filter == \$_, \@{\$self->{TEMP_FILTERS}} ;\n         } \@{\$op->{FILTERS}} ;\n      }\n\n      for my \$op ( \@{\$kid->{OPS}} ) {\n         \$op->_cleanup( \$self ) if UNIVERSAL::isa( \$op, "IPC::Run::IO" );\n      }\n   }\n   \$self->{STATE} = _finished ;\n   \@{\$self->{TEMP_FILTERS}} = () ;\n   _debug "done cleaning up" if _debugging_details ;\n\n   POSIX::close \$self->{DEBUG_FD} if defined \$self->{DEBUG_FD} ;\n   \$self->{DEBUG_FD} = undef ;\n}\n\n\n=item pump\n\n   pump \$h ;\n   \$h->pump ;\n\nPump accepts a single parameter harness.  It blocks until it delivers some\ninput or recieves some output.  It returns TRUE if there is still input or\noutput to be done, FALSE otherwise.\n\npump() will automatically call start() if need be, so you may call harness()\nthen proceed to pump() if that helps you structure your application.\n\nIf pump() is called after all harnessed activities have completed, a "process\nended prematurely" exception to be thrown.  This allows for simple scripting\nof external applications without having to add lots of error handling code at\neach step of the script:\n\n   \$h = harness \\\@smbclient, \\\$in_q, \\\$out_q, \$err_q ;\n\n   \$in_q = "cd /foo\\n" ;\n   \$h->pump until \$out_q =~ /^smb.*> \\Z/m ;\n   die "error cding to /foo:\\n\$out_q" if \$out_q =~ "ERR" ;\n   \$out_q = '' ;\n\n   \$in_q = "mget *\\n" ;\n   \$h->pump until \$out_q =~ /^smb.*> \\Z/m ;\n   die "error retrieving files:\\n\$out_q" if \$out_q =~ "ERR" ;\n\n   \$h->finish ;\n\n   warn \$err_q if \$err_q ;\n\n=cut\n\n\nsub pump {\n   die "pump() takes only a a single harness as a parameter"\n      unless \@_ == 1 && isa( \$_[0], __PACKAGE__ ) ;\n\n   my IPC::Run \$self = shift ;\n\n   local \$cur_self = \$self ;\n\n   _debug "** pumping" \n      if _debugging;\n\n#   my \$r = eval {\n      \$self->start if \$self->{STATE} < _started ;\n      croak "process ended prematurely" unless \$self->pumpable ;\n\n      \$self->{auto_close_ins} = 0 ;\n      \$self->{break_on_io}    = 1 ;\n      \$self->_select_loop ;\n      return \$self->pumpable ;\n#   } ;\n#   if ( \$\@ ) {\n#      my \$x = \$\@ ;\n#      _debug \$x if _debugging && \$x ;\n#      eval { \$self->_cleanup } ;\n#      warn \$\@ if \$\@ ;\n#      die \$x ;\n#   }\n#   return \$r ;\n}\n\n\n=item pump_nb\n\n   pump_nb \$h ;\n   \$h->pump_nb ;\n\n"pump() non-blocking", pumps if anything's ready to be pumped, returns\nimmediately otherwise.  This is useful if you're doing some long-running\ntask in the foreground, but don't want to starve any child processes.\n\n=cut\n\nsub pump_nb {\n   my IPC::Run \$self = shift ;\n\n   \$self->{non_blocking} = 1 ;\n   my \$r = eval { \$self->pump } ;\n   \$self->{non_blocking} = 0 ;\n   die \$\@ if \$\@ ;\n   return \$r ;\n}\n\n=item pumpable\n\nReturns TRUE if calling pump() won't throw an immediate "process ended\nprematurely" exception.  This means that there are open I/O channels or\nactive processes.\n\n=cut\n\n## Undocumented feature (don't depend on it outside this module):\n## returns -1 if we have I/O channels open, or >0 if no I/O channels\n## open, but we have kids running.  This allows the select loop\n## to poll for child exit.\nsub pumpable {\n   my IPC::Run \$self = shift ;\n   return -1 if \@{\$self->{PIPES}} ;\n   \$self->reap_nb ;\n   return \$self->_running_kids ;\n}\n\n\nsub _running_kids {\n   my IPC::Run \$self = shift ;\n   return grep\n      defined \$_->{PID} && ! defined \$_->{RESULT},\n      \@{\$self->{KIDS}} ;\n}\n\n\n=item reap_nb\n\nAttempts to reap child processes, but does not block.\n\nDoes not currently take any parameters, one day it will allow specific\nchildren to be reaped.\n\nOnly call this from a signal handler if your C<perl> is recent enough\nto have safe signal handling (5.6.1 did not, IIRC, but it was beign discussed\non perl5-porters).  Calling this (or doing any significant work) in a signal\nhandler on older C<perl>s is asking for seg faults.\n\n=cut\n\nmy \$still_runnings ;\n\nsub reap_nb {\n   my IPC::Run \$self = shift ;\n\n   local \$cur_self = \$self ;\n\n   ## No more pipes, look to see if all the kids yet live, reaping those\n   ## that haven't.  I'd use \$SIG{CHLD}/\$SIG{CLD}, but that's broken\n   ## on older (SYSV) platforms and perhaps less portable than waitpid().\n   ## This could be slow with a lot of kids, but that's rare and, well,\n   ## a lot of kids is slow in the first place.\n   ## Oh, and this keeps us from reaping other children the process\n   ## may have spawned.\n   for my \$kid ( \@{\$self->{KIDS}} ) {\n      if ( Win32_MODE ) {\n\x09 next if ! defined \$kid->{PROCESS} || defined \$kid->{RESULT} ;\n\x09 unless ( \$kid->{PROCESS}->Wait( 0 ) ) {\n\x09    _debug "kid \$kid->{NUM} (\$kid->{PID}) still running"\n               if _debugging_details;\n\x09    next ;\n\x09 }\n\n         _debug "kid \$kid->{NUM} (\$kid->{PID}) exited"\n            if _debugging;\n\n\x09 \$kid->{PROCESS}->GetExitCode( \$kid->{RESULT} )\n\x09    or croak "\$! while GetExitCode()ing for Win32 process" ;\n\n\x09 unless ( defined \$kid->{RESULT} ) {\n\x09    \$kid->{RESULT} = "0 but true" ;\n\x09    \$? = \$kid->{RESULT} = 0x0F ;\n\x09 }\n\x09 else {\n\x09    \$? = \$kid->{RESULT} << 8 ;\n\x09 }\n      }\n      else {\n\x09 next if ! defined \$kid->{PID} || defined \$kid->{RESULT} ;\n\x09 my \$pid = waitpid \$kid->{PID}, POSIX::WNOHANG() ;\n\x09 unless ( \$pid ) {\n\x09    _debug "\$kid->{NUM} (\$kid->{PID}) still running"\n               if _debugging_details;\n\x09    next ;\n\x09 }\n\n\x09 if ( \$pid < 0 ) {\n\x09    _debug "No such process: \$kid->{PID}\\n" if _debugging ;\n\x09    \$kid->{RESULT} = "unknown result, unknown PID" ;\n\x09 }\n\x09 else {\n            _debug "kid \$kid->{NUM} (\$kid->{PID}) exited"\n               if _debugging;\n\n\x09    confess "waitpid returned the wrong PID: \$pid instead of \$kid->{PID}"\n\x09       unless \$pid = \$kid->{PID} ;\n\x09    _debug "\$kid->{PID} returned \$?\\n" if _debugging ;\n\x09    \$kid->{RESULT} = \$? ;\n\x09 }\n      }\n   }\n}\n\n\n=item finish\n\nThis must be called after the last start() or pump() call for a harness,\nor your system will accumulate defunct processes and you may "leak"\nfile descriptors.\n\nfinish() returns TRUE if all children returned 0 (and were not signaled and did\nnot coredump, ie ! \$?), and FALSE otherwise (this is like run(), and the\nopposite of system()).\n\nOnce a harness has been finished, it may be run() or start()ed again,\nincluding by pump()s auto-start.\n\nIf this throws an exception rather than a normal exit, the harness may\nbe left in an unstable state, it's best to kill the harness to get rid\nof all the child processes, etc.\n\nSpecifically, if a timeout expires in finish(), finish() will not\nkill all the children.  Call C<<\$h->kill_kill>> in this case if you care.\nThis differs from the behavior of L</run>.\n\n=cut\n\n\nsub finish {\n   my IPC::Run \$self = shift ;\n   my \$options = \@_ && ref \$_[-1] eq 'HASH' ? pop : {} ;\n\n   local \$cur_self = \$self ;\n\n   _debug "** finishing" if _debugging;\n\n   \$self->{non_blocking}   = 0 ;\n   \$self->{auto_close_ins} = 1 ;\n   \$self->{break_on_io}    = 0 ;\n   # We don't alter \$self->{clear_ins}, start() and run() control it.\n\n   while ( \$self->pumpable ) {\n      \$self->_select_loop( \$options ) ;\n   }\n   \$self->_cleanup ;\n\n   return ! \$self->full_result ;\n}\n\n\n=item result\n\n   \$h->result ;\n\nReturns the first non-zero result code (ie \$? >> 8).  See L</full_result> to \nget the \$? value for a child process.\n\nTo get the result of a particular child, do:\n\n   \$h->result( 0 ) ;  # first child's \$? >> 8\n   \$h->result( 1 ) ;  # second child\n\nor\n\n   (\$h->results)[0]\n   (\$h->results)[1]\n\nReturns undef if no child processes were spawned and no child number was\nspecified.  Throws an exception if an out-of-range child number is passed.\n\n=cut\n\nsub _assert_finished {\n   my IPC::Run \$self = \$_[0] ;\n\n   croak "Harness not run" unless \$self->{STATE} >= _finished ;\n   croak "Harness not finished running" unless \$self->{STATE} == _finished ;\n}\n\n\nsub result {\n   &_assert_finished ;\n   my IPC::Run \$self = shift ;\n   \n   if ( \@_ ) {\n      my ( \$which ) = \@_ ;\n      croak(\n         "Only ",\n         scalar( \@{\$self->{KIDS}} ),\n         " child processes, no process \$which"\n      )\n         unless \$which >= 0 && \$which <= \$#{\$self->{KIDS}} ;\n      return \$self->{KIDS}->[\$which]->{RESULT} >> 8 ;\n   }\n   else {\n      return undef unless \@{\$self->{KIDS}} ;\n      for ( \@{\$self->{KIDS}} ) {\n         return \$_->{RESULT} >> 8 if \$_->{RESULT} >> 8 ;\n      }\n   }\n}\n\n\n=item results\n\nReturns a list of child exit values.  See L</full_results> if you want to\nknow if a signal killed the child.\n\nThrows an exception if the harness is not in a finished state.\n \n=cut\n\nsub results {\n   &_assert_finished ;\n   my IPC::Run \$self = shift ;\n\n   return map \$_->{RESULT} >> 8, \@{\$self->{KIDS}} ;\n}\n\n\n=item full_result\n\n   \$h->full_result ;\n\nReturns the first non-zero \$?.  See L</result> to get the first \$? >> 8 \nvalue for a child process.\n\nTo get the result of a particular child, do:\n\n   \$h->full_result( 0 ) ;  # first child's \$? >> 8\n   \$h->full_result( 1 ) ;  # second child\n\nor\n\n   (\$h->full_results)[0]\n   (\$h->full_results)[1]\n\nReturns undef if no child processes were spawned and no child number was\nspecified.  Throws an exception if an out-of-range child number is passed.\n\n=cut\n\nsub full_result {\n   goto &result if \@_ > 1 ;\n   &_assert_finished ;\n\n   my IPC::Run \$self = shift ;\n\n   return undef unless \@{\$self->{KIDS}} ;\n   for ( \@{\$self->{KIDS}} ) {\n      return \$_->{RESULT} if \$_->{RESULT} ;\n   }\n}\n\n\n=item full_results\n\nReturns a list of child exit values as returned by C<wait>.  See L</results>\nif you don't care about coredumps or signals.\n\nThrows an exception if the harness is not in a finished state.\n \n=cut\n\nsub full_results {\n   &_assert_finished ;\n   my IPC::Run \$self = shift ;\n\n   croak "Harness not run" unless \$self->{STATE} >= _finished ;\n   croak "Harness not finished running" unless \$self->{STATE} == _finished ;\n\n   return map \$_->{RESULT}, \@{\$self->{KIDS}} ;\n}\n\n\n##\n## Filter Scaffolding\n##\nuse vars (\n   '\$filter_op',        ## The op running a filter chain right now\n   '\$filter_num',       ## Which filter is being run right now.\n) ;\n\n##\n## A few filters and filter constructors\n##\n\n=back\n\n=head1 FILTERS\n\nThese filters are used to modify input our output between a child\nprocess and a scalar or subroutine endpoint.\n\n=over\n\n=item binary\n\n   run \\\@cmd, ">", binary, \\\$out ;\n   run \\\@cmd, ">", binary, \\\$out ;  ## Any TRUE value to enable\n   run \\\@cmd, ">", binary 0, \\\$out ;  ## Any FALSE value to disable\n\nThis is a constructor for a "binmode" "filter" that tells IPC::Run to keep\nthe carriage returns that would ordinarily be edited out for you (binmode\nis usually off).  This is not a real filter, but an option masquerading as\na filter.\n\nIt's not named "binmode" because you're likely to want to call Perl's binmode\nin programs that are piping binary data around.\n\n=cut\n\nsub binary(;\$) {\n   my \$enable = \@_ ? shift : 1 ;\n   return bless sub { \$enable }, "IPC::Run::binmode_pseudo_filter" ;\n}\n\n=item new_chunker\n\nThis breaks a stream of data in to chunks, based on an optional\nscalar or regular expression parameter.  The default is the Perl\ninput record separator in \$/, which is a newline be default.\n\n   run \\\@cmd, '>', new_chunker, \\&lines_handler ;\n   run \\\@cmd, '>', new_chunker( "\\r\\n" ), \\&lines_handler ;\n\nBecause this uses \$/ by default, you should always pass in a parameter\nif you are worried about other code (modules, etc) modifying \$/.\n\nIf this filter is last in a filter chain that dumps in to a scalar,\nthe scalar must be set to '' before a new chunk will be written to it.\n\nAs an example of how a filter like this can be written, here's a\nchunker that splits on newlines:\n\n   sub line_splitter {\n      my ( \$in_ref, \$out_ref ) = \@_ ;\n\n      return 0 if length \$\$out_ref ;\n\n      return input_avail && do {\n         while (1) {\n            if ( \$\$in_ref =~ s/\\A(.*?\\n)// ) {\n               \$\$out_ref .= \$1 ;\n               return 1 ;\n            }\n            my \$hmm = get_more_input ;\n            unless ( defined \$hmm ) {\n               \$\$out_ref = \$\$in_ref ;\n               \$\$in_ref = '' ;\n               return length \$\$out_ref ? 1 : 0 ;\n            }\n            return 0 if \$hmm eq 0 ;\n         }\n      }\n   } ;\n\n=cut\n\nsub new_chunker(;\$) {\n   my ( \$re ) = \@_ ;\n   \$re = \$/ if _empty \$re ;\n   \$re = quotemeta( \$re ) unless ref \$re eq 'Regexp' ;\n   \$re = qr/\\A(.*?\$re)/s ;\n\n   return sub {\n      my ( \$in_ref, \$out_ref ) = \@_ ;\n\n      return 0 if length \$\$out_ref ;\n\n      return input_avail && do {\n         while (1) {\n            if ( \$\$in_ref =~ s/\$re// ) {\n               \$\$out_ref .= \$1 ;\n               return 1 ;\n            }\n            my \$hmm = get_more_input ;\n            unless ( defined \$hmm ) {\n               \$\$out_ref = \$\$in_ref ;\n               \$\$in_ref = '' ;\n               return length \$\$out_ref ? 1 : 0 ;\n            }\n            return 0 if \$hmm eq 0 ;\n         }\n      }\n   } ;\n}\n\n\n=item new_appender\n\nThis appends a fixed string to each chunk of data read from the source\nscalar or sub.  This might be useful if you're writing commands to a\nchild process that always must end in a fixed string, like "\\n":\n\n   run( \\\@cmd,\n      '<', new_appender( "\\n" ), \\&commands,\n   ) ;\n\nHere's a typical filter sub that might be created by new_appender():\n\n   sub newline_appender {\n      my ( \$in_ref, \$out_ref ) = \@_ ;\n\n      return input_avail && do {\n         \$\$out_ref = join( '', \$\$out_ref, \$\$in_ref, "\\n" ) ;\n         \$\$in_ref = '' ;\n         1 ;\n      }\n   } ;\n\n=cut\n\nsub new_appender(\$) {\n   my ( \$suffix ) = \@_ ;\n   croak "\\\$suffix undefined" unless defined \$suffix ;\n\n   return sub {\n      my ( \$in_ref, \$out_ref ) = \@_ ;\n\n      return input_avail && do {\n         \$\$out_ref = join( '', \$\$out_ref, \$\$in_ref, \$suffix ) ;\n         \$\$in_ref = '' ;\n         1 ;\n      }\n   } ;\n}\n\n\nsub new_string_source {\n   my \$ref ;\n   if ( \@_ > 1 ) {\n      \$ref = [ \@_ ],\n   }\n   else {\n      \$ref = shift ;\n   }\n\n   return ref \$ref eq 'SCALAR'\n      ? sub {\n         my ( \$in_ref, \$out_ref ) = \@_ ;\n\n         return defined \$\$ref\n            ? do {\n               \$\$out_ref .= \$\$ref ;\n               my \$r = length \$\$ref ? 1 : 0 ;\n               \$\$ref = undef ;\n               \$r ;\n            }\n            : undef\n      }\n      : sub {\n         my ( \$in_ref, \$out_ref ) = \@_ ;\n\n         return \@\$ref\n            ? do {\n               my \$s = shift \@\$ref ;\n               \$\$out_ref .= \$s ;\n               length \$s ? 1 : 0 ;\n            }\n            : undef ;\n      }\n}\n\n\nsub new_string_sink {\n   my ( \$string_ref ) = \@_ ;\n\n   return sub {\n      my ( \$in_ref, \$out_ref ) = \@_ ;\n\n      return input_avail && do {\n         \$\$string_ref .= \$\$in_ref ;\n         \$\$in_ref = '' ;\n         1 ;\n      }\n   } ;\n}\n\n\n#=item timeout\n#\n#This function defines a time interval, starting from when start() is\n#called, or when timeout() is called.  If all processes have not finished\n#by the end of the timeout period, then a "process timed out" exception\n#is thrown.\n#\n#The time interval may be passed in seconds, or as an end time in\n#"HH:MM:SS" format (any non-digit other than '.' may be used as\n#spacing and puctuation).  This is probably best shown by example:\n#\n#   \$h->timeout( \$val ) ;\n#\n#   \$val                     Effect\n#   ======================== =====================================\n#   undef                    Timeout timer disabled\n#   ''                       Almost immediate timeout\n#   0                        Almost immediate timeout\n#   0.000001                 timeout > 0.0000001 seconds\n#   30                       timeout > 30 seconds\n#   30.0000001               timeout > 30 seconds\n#   10:30                    timeout > 10 minutes, 30 seconds\n#\n#Timeouts are currently evaluated with a 1 second resolution, though\n#this may change in the future.  This means that setting\n#timeout(\$h,1) will cause a pokey child to be aborted sometime after\n#one second has elapsed and typically before two seconds have elapsed.\n#\n#This sub does not check whether or not the timeout has expired already.\n#\n#Returns the number of seconds set as the timeout (this does not change\n#as time passes, unless you call timeout( val ) again).\n#\n#The timeout does not include the time needed to fork() or spawn()\n#the child processes, though some setup time for the child processes can\n#included.  It also does not include the length of time it takes for\n#the children to exit after they've closed all their pipes to the\n#parent process.\n#\n#=cut\n#\n#sub timeout {\n#   my IPC::Run \$self = shift ;\n#\n#   if ( \@_ ) {\n#      ( \$self->{TIMEOUT} ) = \@_ ;\n#      \$self->{TIMEOUT_END} = undef ;\n#      if ( defined \$self->{TIMEOUT} ) {\n#\x09 if ( \$self->{TIMEOUT} =~ /[^\\d.]/ ) {\n#\x09    my \@f = split( /[^\\d\\.]+/i, \$self->{TIMEOUT} ) ;\n#\x09    unshift \@f, 0 while \@f < 3 ;\n#\x09    \$self->{TIMEOUT} = ((\$f[0]*60)+\$f[1])*60+\$f[2] ;\n#\x09 }\n#\x09 elsif ( \$self->{TIMEOUT} =~ /^(\\d*)(?:\\.(\\d*))/ ) {\n#\x09    \$self->{TIMEOUT} = \$1 + 1 ;\n#\x09 }\n#\x09 \$self->_calc_timeout_end if \$self->{STATE} >= _started ;\n#      }\n#   }\n#   return \$self->{TIMEOUT} ;\n#}\n#\n#\n#sub _calc_timeout_end {\n#   my IPC::Run \$self = shift ;\n#\n#   \$self->{TIMEOUT_END} = defined \$self->{TIMEOUT} \n#      ? time + \$self->{TIMEOUT}\n#      : undef ;\n#\n#   ## We add a second because we might be at the very end of the current\n#   ## second, and we want to guarantee that we don't have a timeout even\n#   ## one second less then the timeout period.\n#   ++\$self->{TIMEOUT_END} if \$self->{TIMEOUT} ;\n#}\n\n=item io\n\nTakes a filename or filehandle, a redirection operator, optional filters,\nand a source or destination (depends on the redirection operator).  Returns\nan IPC::Run::IO object suitable for harness()ing (including via start()\nor run()).\n\nThis is shorthand for \n\n\n   require IPC::Run::IO ;\n\n      ... IPC::Run::IO->new(...) ...\n\n=cut\n\nsub io {\n   require IPC::Run::IO ;\n   IPC::Run::IO->new( \@_ ) ;\n}\n\n=item timer\n\n   \$h = start( \\\@cmd, \\\$in, \\\$out, \$t = timer( 5 ) ) ;\n\n   pump \$h until \$out =~ /expected stuff/ || \$t->is_expired ;\n\nInstantiates a non-fatal timer.  pump() returns once each time a timer\nexpires.  Has no direct effect on run(), but you can pass a subroutine\nto fire when the timer expires. \n\nSee L</timeout> for building timers that throw exceptions on\nexpiration.\n\nSee L<IPC::Run::Timer/timer> for details.\n\n=cut\n\n# Doing the prototype suppresses 'only used once' on older perls.\nsub timer ;\n*timer = \\&IPC::Run::Timer::timer ;\n\n\n=item timeout\n\n   \$h = start( \\\@cmd, \\\$in, \\\$out, \$t = timeout( 5 ) ) ;\n\n   pump \$h until \$out =~ /expected stuff/ ;\n\nInstantiates a timer that throws an exception when it expires.\nIf you don't provide an exception, a default exception that matches\n/^IPC::Run: .*timed out/ is thrown by default.  You can pass in your own\nexception scalar or reference:\n\n   \$h = start(\n      \\\@cmd, \\\$in, \\\$out,\n      \$t = timeout( 5, exception => 'slowpoke' ),\n   ) ;\n\nor set the name used in debugging message and in the default exception\nstring:\n\n   \$h = start(\n      \\\@cmd, \\\$in, \\\$out,\n      timeout( 50, name => 'process timer' ),\n      \$stall_timer = timeout( 5, name => 'stall timer' ),\n   ) ;\n\n   pump \$h until \$out =~ /started/ ;\n\n   \$in = 'command 1' ;\n   \$stall_timer->start ;\n   pump \$h until \$out =~ /command 1 finished/ ;\n\n   \$in = 'command 2' ;\n   \$stall_timer->start ;\n   pump \$h until \$out =~ /command 2 finished/ ;\n\n   \$in = 'very slow command 3' ;\n   \$stall_timer->start( 10 ) ;\n   pump \$h until \$out =~ /command 3 finished/ ;\n\n   \$stall_timer->start( 5 ) ;\n   \$in = 'command 4' ;\n   pump \$h until \$out =~ /command 4 finished/ ;\n\n   \$stall_timer->reset; # Prevent restarting or expirng\n   finish \$h ;\n\nSee L</timer> for building non-fatal timers.\n\nSee L<IPC::Run::Timer/timer> for details.\n\n=cut\n\n# Doing the prototype suppresses 'only used once' on older perls.\nsub timeout ;\n*timeout = \\&IPC::Run::Timer::timeout ;\n\n\n=back\n\n=head1 FILTER IMPLEMENTATION FUNCTIONS\n\nThese functions are for use from within filters.\n\n=over\n\n=item input_avail\n\nReturns TRUE if input is available.  If none is available, then \n&get_more_input is called and its result is returned.\n\nThis is usually used in preference to &get_more_input so that the\ncalling filter removes all data from the \$in_ref before more data\ngets read in to \$in_ref.\n\nC<input_avail> is usually used as part of a return expression:\n\n   return input_avail && do {\n      ## process the input just gotten\n      1 ;\n   } ;\n\nThis technique allows input_avail to return the undef or 0 that a\nfilter normally returns when there's no input to process.  If a filter\nstores intermediate values, however, it will need to react to an\nundef:\n\n   my \$got = input_avail ;\n   if ( ! defined \$got ) {\n      ## No more input ever, flush internal buffers to \$out_ref\n   }\n   return \$got unless \$got ;\n   ## Got some input, move as much as need be\n   return 1 if \$added_to_out_ref ;\n\n=cut\n\nsub input_avail() {\n   confess "Undefined FBUF ref for \$filter_num+1"\n      unless defined \$filter_op->{FBUFS}->[\$filter_num+1] ;\n   length \${\$filter_op->{FBUFS}->[\$filter_num+1]} || get_more_input ;\n}\n\n\n=item get_more_input\n\nThis is used to fetch more input in to the input variable.  It returns\nundef if there will never be any more input, 0 if there is none now,\nbut there might be in the future, and TRUE if more input was gotten.\n\nC<get_more_input> is usually used as part of a return expression,\nsee L</input_avail> for more information.\n\n=cut\n\n##\n## Filter implementation interface\n##\nsub get_more_input() {\n   ++\$filter_num ;\n   my \$r = eval {\n      confess "get_more_input() called and no more filters in chain"\n         unless defined \$filter_op->{FILTERS}->[\$filter_num] ;\n      \$filter_op->{FILTERS}->[\$filter_num]->(\n         \$filter_op->{FBUFS}->[\$filter_num+1],\n         \$filter_op->{FBUFS}->[\$filter_num],\n      ) ; # if defined \${\$filter_op->{FBUFS}->[\$filter_num+1]} ;\n   } ;\n   --\$filter_num ;\n   die \$\@ if \$\@ ;\n   return \$r ;\n}\n\n\n## This is not needed by most users.  Should really move to IPC::Run::TestUtils\n#=item filter_tests\n#\n#   my \@tests = filter_tests( "foo", "in", "out", \\&filter ) ;\n#   \$_->() for ( \@tests ) ;\n#\n#This creates a list of test subs that can be used to test most filters\n#for basic functionality.  The first parameter is the name of the\n#filter to be tested, the second is sample input, the third is the\n#test(s) to apply to the output(s), and the rest of the parameters are\n#the filters to be linked and tested.\n#\n#If the filter chain is to be fed multiple inputs in sequence, the second\n#parameter should be a reference to an array of thos inputs:\n#\n#   my \@tests = filter_tests( "foo", [qw(1 2 3)], "123", \\&filter ) ;\n#\n#If the filter chain should produce a sequence of outputs, then the\n#thrid parameter should be a reference to an array of those outputs:\n#\n#   my \@tests = filter_tests(\n#      "foo",\n#      "1\\n\\2\\n",\n#      [ qr/^1\$/, qr/^2\$/ ],\n#      new_chunker\n#   ) ;\n#\n#See t/run.t and t/filter.t for an example of this in practice.\n#\n#=cut\n\n##\n## Filter testing routines\n##\nsub filter_tests(\$;\@) {\n   my ( \$name, \$in, \$exp, \@filters ) = \@_ ;\n\n   my \@in  = ref \$in  eq 'ARRAY' ? \@\$in  : ( \$in  ) ;\n   my \@exp = ref \$exp eq 'ARRAY' ? \@\$exp : ( \$exp ) ;\n\n   require Test ;\n   *ok = \\&Test::ok ;\n\n   my IPC::Run::IO \$op ;\n   my \$output ;\n   my \@input ;\n   my \$in_count = 0 ;\n\n   my \@out ;\n\n   my \$h ;\n\n   return (\n      sub {\n         \$h = harness() ;\n         \$op = IPC::Run::IO->_new_internal( '<', 0, 0, 0, undef,\n               new_string_sink( \\\$output ),\n               \@filters,\n               new_string_source( \\\@input ),\n         ) ;\n         \$op->_init_filters ;\n         \@input = () ;\n         \$output = '' ;\n         ok(\n            ! defined \$op->_do_filters( \$h ),\n            1,\n            "\$name didn't pass undef (EOF) through"\n         ) ;\n      },\n\n      ## See if correctly does nothing on 0, (please try again)\n      sub {\n         \$op->_init_filters ;\n         \$output = '' ;\n         \@input = ( '' ) ;\n         ok(\n            \$op->_do_filters( \$h ),\n            0,\n            "\$name didn't return 0 (please try again) when given a 0"\n         ) ;\n      },\n\n      sub {\n         \@input = ( '' ) ;\n         ok(\n            \$op->_do_filters( \$h ),\n            0,\n            "\$name didn't return 0 (please try again) when given a second 0"\n         ) ;\n      },\n\n      sub {\n         for (1..100) {\n            last unless defined \$op->_do_filters( \$h ) ;\n         }\n         ok(\n            ! defined \$op->_do_filters( \$h ),\n            1,\n            "\$name didn't return undef (EOF) after two 0s and an undef"\n         ) ;\n      },\n\n      ## See if it can take \@in and make \@out\n      sub {\n         \$op->_init_filters ;\n         \$output = '' ;\n         \@input = \@in ;\n         while ( defined \$op->_do_filters( \$h ) && \@input ) {\n            if ( length \$output ) {\n               push \@out, \$output ;\n               \$output = '' ;\n            }\n         }\n         if ( length \$output ) {\n            push \@out, \$output ;\n            \$output = '' ;\n         }\n         ok(\n            scalar \@input,\n            0,\n            "\$name didn't consume it's input"\n         ) ;\n      },\n\n      sub {\n         for (1..100) {\n            last unless defined \$op->_do_filters( \$h ) ;\n            if ( length \$output ) {\n               push \@out, \$output ;\n               \$output = '' ;\n            }\n         }\n         ok(\n            ! defined \$op->_do_filters( \$h ),\n            1,\n            "\$name didn't return undef (EOF), tried  100 times"\n         ) ;\n      },\n\n      sub {\n         ok(\n            join( ', ', map "'\$_'", \@out ),\n            join( ', ', map "'\$_'", \@exp ),\n            \$name\n         )\n      },\n\n      sub {\n         ## Force the harness to be cleaned up.\n         \$h = undef ;\n         ok( 1 ) ;\n      }\n   ) ;\n}\n\n\n=back\n\n=head1 TODO\n\nThese will be addressed as needed and as time allows.\n\nStall timeout.\n\nExpose a list of child process objects.  When I do this,\neach child process is likely to be blessed into IPC::Run::Proc.\n\n\$kid->abort(), \$kid->kill(), \$kid->signal( \$num_or_name ).\n\nWrite tests for /(full_)?results?/ subs.\n\nCurrently, pump() and run() only work on systems where select() works on the\nfilehandles returned by pipe().  This does *not* include ActiveState on Win32,\nalthough it does work on cygwin under Win32 (thought the tests whine a bit).\nI'd like to rectify that, suggestions and patches welcome.\n\nLikewise start() only fully works on fork()/exec() machines (well, just\nfork() if you only ever pass perl subs as subprocesses).  There's\nsome scaffolding for calling Open3::spawn_with_handles(), but that's\nuntested, and not that useful with limited select().\n\nSupport for C<\\\@sub_cmd> as an argument to a command which\ngets replaced with /dev/fd or the name of a temporary file containing foo's\noutput.  This is like <(sub_cmd ...) found in bash and csh (IIRC).\n\nAllow multiple harnesses to be combined as independant sets of processes\nin to one 'meta-harness'.\n\nAllow a harness to be passed in place of an \\\@cmd.  This would allow\nmultiple harnesses to be aggregated.\n\nAbility to add external file descriptors w/ filter chains and endpoints.\n\nAbility to add timeouts and timing generators (i.e. repeating timeouts).\n\nHigh resolution timeouts.\n\n=head1 Win32 LIMITATIONS\n\n=over\n\n=item Tested only on NT4.0\n\n=item Known to fail on Win95.\n\nIf you want Win95 support, help debug it.\n\n=item no support yet for <pty< and >pty>\n\nThese are likely to be implemented as "<" and ">" with binmode on, not\nsure.\n\n=item no support for file descriptors higher than 2 (stderr)\n\nWin32 only allows passing explicit fds 0, 1, and 2.  If you really, really need to pass file handles, us Win32API:: GetOsFHandle() or ::FdGetOsFHandle() to\nget the integer handle and pass it to the child process using the command\nline, environment, stdin, intermediary file, or other IPC mechnism.  Then\nuse that handle in the child (Win32API.pm provides ways to reconstitute\nPerl file handles from Win32 file handles).\n\n=item no support for subroutine subprocesses (CODE refs)\n\nCan't fork(), so the subroutines would have no context, and closures certainly\nhave no meaning\n\nPerhaps with Win32 fork() emulation, this can be supported in a limited\nfashion, but there are other very serious problems with that: all parent\nfds get dup()ed in to the thread emulating the forked process, and that\nkeeps the parent from being able to close all of the appropriate fds.\n\n=item no support for init => sub {} routines.\n\nWin32 processes are created from scratch, there is no way to do an init\nroutine that will affect the running child.  Some limited support might\nbe implemented one day, do chdir() and %ENV changes can be made.\n\n=item signals\n\nWin32 does not fully support signals.  signal() is likely to cause errors\nunless sending a signal that Perl emulates, and C<kill_kill()> is immediately\nfatal (there is no grace period).\n\n=item helper processes\n\nIPC::Run uses helper processes, one per redirected file, to adapt between the\nanonymous pipe connected to the child and the TCP socket connected to the\nparent.  This is a waste of resources and will change in the future to either\nuse threads (instead of helper processes) or a WaitForMultipleObjects call\n(instead of select).  Please contact me if you can help with the\nWaitForMultipleObjects() approach; I haven't figured out how to get at it\nwithout C code.\n\n=item shutdown pause\n\nThere seems to be a pause of up to 1 second between when a child program exits\nand the corresponding sockets indicate that they are closed in the parent.\nNot sure why.\n\n=item binmode\n\nbinmode is not supported yet.  The underpinnings are implemented, just ask\nif you need it.\n\n=item IPC::Run::IO\n\nIPC::Run::IO objects can be used on Unix to read or write arbitrary files.  On\nWin32, they will need to use the same helper processes to adapt from\nnon-select()able filehandles to select()able ones (or perhaps\nWaitForMultipleObjects() will work with them, not sure).\n\n=item startup race conditions\n\nThere seems to be an occasional race condition between child process startup\nand pipe closings.  It seems like if the child is not fully created by the time\nCreateProcess returns and we close the TCP socket being handed to it, the\nparent socket can also get closed.  This is seen with the Win32 pumper\napplications, not the "real" child process being spawned.\n\nI assume this is because the kernel hasn't gotten around to incrementing the\nreference count on the child's end (since the child was slow in starting), so\nthe parent's closing of the child end causes the socket to be closed, thus\nclosing the parent socket.\n\nBeing a race condition, it's hard to reproduce, but I encountered it while\ntesting this code on a drive share to a samba box.  In this case, it takes\nt/run.t a long time to spawn it's chile processes (the parent hangs in the\nfirst select for several seconds until the child emits any debugging output).\n\nI have not seen it on local drives, and can't reproduce it at will,\nunfortunately.  The symptom is a "bad file descriptor in select()" error, and,\nby turning on debugging, it's possible to see that select() is being called on\na no longer open file descriptor that was returned from the _socket() routine\nin Win32Helper.  There's a new confess() that checks for this ("PARENT_HANDLE\nno longer open"), but I haven't been able to reproduce it (typically).\n\n=back\n\n=head1 LIMITATIONS\n\nOn Unix, requires a system that supports C<waitpid( \$pid, WNOHANG )> so\nit can tell if a child process is still running.\n\nPTYs don't seem to be non-blocking on some versions of Solaris. Here's a\ntest script contributed by Borislav Deianov <borislav\@ensim.com> to see\nif you have the problem.  If it dies, you have the problem.\n\n   #!/usr/bin/perl\n\n   use IPC::Run qw(run);\n   use Fcntl;\n   use IO::Pty;\n\n   sub makecmd {\n       return ['perl', '-e', \n               '<STDIN>, print "\\n" x '.\$_[0].'; while(<STDIN>){last if /end/}'];\n   }\n\n   #pipe R, W;\n   #fcntl(W, F_SETFL, O_NONBLOCK);\n   #while (syswrite(W, "\\n", 1)) { \$pipebuf++ };\n   #print "pipe buffer size is \$pipebuf\\n";\n   my \$pipebuf=4096;\n   my \$in = "\\n" x (\$pipebuf * 2) . "end\\n";\n   my \$out;\n\n   \$SIG{ALRM} = sub { die "Never completed!\\n" } ;\n\n   print "reading from scalar via pipe...";\n   alarm( 2 ) ;\n   run(makecmd(\$pipebuf * 2), '<', \\\$in, '>', \\\$out);\n   alarm( 0 );\n   print "done\\n";\n\n   print "reading from code via pipe... ";\n   alarm( 2 ) ;\n   run(makecmd(\$pipebuf * 3), '<', sub { \$t = \$in; undef \$in; \$t}, '>', \\\$out);\n   alarm( 0 ) ;\n   print "done\\n";\n\n   \$pty = IO::Pty->new();\n   \$pty->blocking(0);\n   \$slave = \$pty->slave();\n   while (\$pty->syswrite("\\n", 1)) { \$ptybuf++ };\n   print "pty buffer size is \$ptybuf\\n";\n   \$in = "\\n" x (\$ptybuf * 3) . "end\\n";\n\n   print "reading via pty... ";\n   alarm( 2 ) ;\n   run(makecmd(\$ptybuf * 3), '<pty<', \\\$in, '>', \\\$out);\n   alarm(0);\n   print "done\\n";\n\nNo support for ';', '&&', '||', '{ ... }', etc: use perl's, since run()\nreturns TRUE when the command exits with a 0 result code.\n\nDoes not provide shell-like string interpolation.\n\nNo support for C<cd>, C<setenv>, or C<export>: do these in an init() sub\n\n   run(\n      \\cmd,\n         ...\n         init => sub {\n            chdir \$dir or die \$! ;\n            \$ENV{FOO}='BAR'\n         }\n   ) ;\n\nTimeout calculation does not allow absolute times, or specification of\ndays, months, etc.\n\nB<WARNING:> Function coprocesses (C<run \\&foo, ...>) suffer from two\nlimitations.  The first is that it is difficult to close all filehandles the\nchild inherits from the parent, since there is no way to scan all open\nFILEHANDLEs in Perl and it both painful and a bit dangerous to close all open\nfile descriptors with C<POSIX::close()>. Painful because we can't tell which\nfds are open at the POSIX level, either, so we'd have to scan all possible fds\nand close any that we don't want open (normally C<exec()> closes any\nnon-inheritable but we don't C<exec()> for &sub processes.\n\nThe second problem is that Perl's DESTROY subs and other on-exit cleanup gets\nrun in the child process.  If objects are instantiated in the parent before the\nchild is forked, the the DESTROY will get run once in the parent and once in\nthe child.  When coprocess subs exit, POSIX::exit is called to work around this,\nbut it means that objects that are still referred to at that time are not\ncleaned up.  So setting package vars or closure vars to point to objects that\nrely on DESTROY to affect things outside the process (files, etc), will\nlead to bugs.\n\nI goofed on the syntax: "<pipe" vs. "<pty<" and ">filename" are both\noddities.\n\n=head1 TODO\n\n=over\n\n=item Allow one harness to "adopt" another:\n\n   \$new_h = harness \\\@cmd2 ;\n   \$h->adopt( \$new_h ) ;\n\n=item Close all filehandles not explicitly marked to stay open.\n\nThe problem with this one is that there's no good way to scan all open\nFILEHANDLEs in Perl, yet you don't want child processes inheriting handles\nwilly-nilly.\n\n=back\n\n=head1 INSPIRATION\n\nWell, select() and waitpid() badly needed wrapping, and open3() isn't\nopen-minded enough for me.\n\nThe shell-like API inspired by a message Russ Allbery sent to perl5-porters,\nwhich included:\n\n   I've thought for some time that it would be\n   nice to have a module that could handle full Bourne shell pipe syntax\n   internally, with fork and exec, without ever invoking a shell.  Something\n   that you could give things like:\n\n   pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', \@args ], '>&3');\n\nMessage ylln51p2b6.fsf\@windlord.stanford.edu, on 2000/02/04.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>, with numerous suggestions by p5p.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAADK
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADL, "lib/IPC/Run/Timer.pm" }
package IPC::Run::Timer ;\n\n=head1 NAME\n\n   IPC::Run::Timer -- Timer channels for IPC::Run.\n\n=head1 SYNOPSIS\n\n   use IPC::Run qw( run  timer timeout ) ;\n   ## or IPC::Run::Timer ( timer timeout ) ;\n   ## or IPC::Run::Timer ( :all ) ;\n\n   ## A non-fatal timer:\n   \$t = timer( 5 ) ; # or...\n   \$t = IO::Run::Timer->new( 5 ) ;\n   run \$t, ... ;\n\n   ## A timeout (which is a timer that dies on expiry):\n   \$t = timeout( 5 ) ; # or...\n   \$t = IO::Run::Timer->new( 5, exception => "harness timed out" ) ;\n\n=head1 DESCRIPTION\n\nThis class and module allows timers and timeouts to be created for use\nby IPC::Run.  A timer simply expires when it's time is up.  A timeout\nis a timer that throws an exception when it expires.\n\nTimeouts are usually a bit simpler to use  than timers: they throw an\nexception on expiration so you don't need to check them:\n\n   ## Give \@cmd 10 seconds to get started, then 5 seconds to respond\n   my \$t = timeout( 10 ) ;\n   \$h = start(\n      \\\@cmd, \\\$in, \\\$out,\n      \$t,\n   ) ;\n   pump \$h until \$out =~ /prompt/ ;\n\n   \$in = "some stimulus" ;\n   \$out = '' ;\n   \$t->time( 5 )\n   pump \$h until \$out =~ /expected response/ ;\n\nYou do need to check timers:\n\n   ## Give \@cmd 10 seconds to get started, then 5 seconds to respond\n   my \$t = timer( 10 ) ;\n   \$h = start(\n      \\\@cmd, \\\$in, \\\$out,\n      \$t,\n   ) ;\n   pump \$h until \$t->is_expired || \$out =~ /prompt/ ;\n\n   \$in = "some stimulus" ;\n   \$out = '' ;\n   \$t->time( 5 )\n   pump \$h until \$out =~ /expected response/ || \$t->is_expired ;\n\nTimers and timeouts that are reset get started by start() and\npump().  Timers change state only in pump().  Since run() and\nfinish() both call pump(), they act like pump() with repect to\ntimers.\n\nTimers and timeouts have three states: reset, running, and expired.\nSetting the timeout value resets the timer, as does calling\nthe reset() method.  The start() method starts (or restarts) a\ntimer with the most recently set time value, no matter what state\nit's in.\n\n=head2 Time values\n\nAll time values are in seconds.  Times may be specified as integer or\nfloating point seconds, optionally preceded by puncuation-separated\ndays, hours, and minutes.\\\n\nExamples:\n\n   1           1 second\n   1.1         1.1 seconds\n   60          60 seconds\n   1:0         1 minute\n   1:1         1 minute, 1 second\n   1:90        2 minutes, 30 seconds\n   1:2:3:4.5   1 day, 2 hours, 3 minutes, 4.5 seconds\n\nAbsolute date/time strings are *not* accepted: year, month and\nday-of-month parsing is not available (patches welcome :-).\n\n=head2 Interval fudging\n\nWhen calculating an end time from a start time and an interval, IPC::Run::Timer\ninstances add a little fudge factor.  This is to ensure that no time will\nexpire before the interval is up.\n\nFirst a little background.  Time is sampled in discrete increments.  We'll\ncall the\nexact moment that the reported time increments from one interval to the\nnext a tick, and the interval between ticks as the time period.  Here's\na diagram of three ticks and the periods between them:\n\n\n    -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...\n    ^                   ^                   ^\n    |<--- period 0 ---->|<--- period 1 ---->|\n    |                   |                   |\n  tick 0              tick 1              tick 2\n\nTo see why the fudge factor is necessary, consider what would happen\nwhen a timer with an interval of 1 second is started right at the end of\nperiod 0:\n\n\n    -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...\n    ^                ^  ^                   ^\n    |                |  |                   |\n    |                |  |                   |\n  tick 0             |tick 1              tick 2\n                     |\n                 start \$t\n\nAssuming that check() is called many times per period, then the timer\nis likely to expire just after tick 1, since the time reported will have\nlept from the value '0' to the value '1':\n\n    -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...\n    ^                ^  ^   ^               ^\n    |                |  |   |               |\n    |                |  |   |               |\n  tick 0             |tick 1|             tick 2\n                     |      |\n                 start \$t   |\n\x09\x09            |\n\x09\x09\x09check \$t\n\nAdding a fudge of '1' in this example means that the timer is guaranteed\nnot to expire before tick 2.\n\nThe fudge is not added to an interval of '0'.\n\nThis means that intervals guarantee a minimum interval.  Given that\nthe process running perl may be suspended for some period of time, or that\nit gets busy doing something time-consuming, there are no other guarantees on\nhow long it will take a timer to expire.\n\n=head1 SUBCLASSING\n\nThis class uses the fields pragma, so you need to be aware of the contraints\nand strengths that this confers upon subclasses.\nSee the L<base> and L<fields> pragmas for more information.\n\n=head1 FUNCTIONS & METHODS\n\n=over\n\n=cut ;\n\nuse strict ;\nuse Carp ;\nuse Fcntl ;\nuse Symbol ;\nuse UNIVERSAL qw( isa ) ;\nuse Exporter ;\nuse vars qw( \@EXPORT_OK %EXPORT_TAGS \@ISA ) ;\n\n\@EXPORT_OK = qw(\n   check\n   end_time\n   exception\n   expire\n   interval\n   is_expired\n   is_reset\n   is_running\n   name\n   reset\n   start\n\n   timeout\n   timer\n) ;\n\n%EXPORT_TAGS = ( 'all' => \\\@EXPORT_OK ) ;\n\n\@ISA = qw( Exporter ) ;\n\nrequire IPC::Run ;\nuse IPC::Run::Debug ;\n\nuse fields (\n   'INTERVAL',       # An array of the intervals\n   'STATE',          # The current state: 0 = reset, 1 = running, undef=expired\n                     # indicated expiration.\n   'EXCEPTION',      # Set for timouts, will die with each state.\n   'NAME',           # Name of this instance, undef if not set.\n   'START_TIME',     # Time the timer started.\n   'END_TIME',       # Time the timer will/did expire\n   'DEBUG',          # Whether or not to send debug messages.\n) ;\n\n##\n## Some helpers\n##\nmy \$resolution = 1 ;\n\nsub _parse_time {\n   for ( \$_[0] ) {\n      return \$_ unless defined \$_ ;\n      return \$_ if /^\\d*(?:\\.\\d*)?\$/ ;\n\n      my \@f = reverse split( /[^\\d\\.]+/i ) ;\n      croak "IPC::Run: invalid time string '\$_'" unless \@f <= 4 ;\n      my ( \$s, \$m, \$h, \$d ) = \@f ;\n      return\n      ( (\n\x09         ( \$d || 0 )   * 24\n\x09       + ( \$h || 0 ) ) * 60\n\x09       + ( \$m || 0 ) ) * 60\n               + ( \$s || 0 ) ;\n   }\n}\n\n\nsub _calc_end_time {\n   my IPC::Run::Timer \$self = shift ;\n\n   my \$interval = \$self->interval ;\n   \$interval += \$resolution if \$interval ;\n\n   \$self->end_time( \$self->start_time + \$interval ) ;\n}\n\n\n=item timer\n\nA constructor function (not method) of IPC::Run::Timer instances:\n\n   \$t = timer( 5 ) ;\n   \$t = timer( 5, name => 'stall timer', debug => 1 ) ;\n\n   \$t = timer ;\n   \$t->interval( 5 ) ;\n\n   run ..., \$t ;\n   run ..., \$t = timer( 5 ) ;\n\nThis convenience function is a shortened spelling of\n\n   IPC::Run::Timer->new( ... ) ;\n   \n.  It returns a timer in the reset state with a given interval.\n\nIf an exception is provided, it will be thrown when the timer notices that\nit has expired (in check()).  The name is for debugging usage, if you plan on\nhaving multiple timers around.  If no name is provided, an name like "timer #1"\nwill be provided.\n\n=cut\n\nsub timer {\n   return IPC::Run::Timer->new( \@_ ) ;\n}\n\n\n=item timeout\n\nA constructor function (not method) of IPC::Run::Timer instances:\n\n   \$t = timeout( 5 ) ;\n   \$t = timeout( 5, exception => "kablooey" ) ;\n   \$t = timeout( 5, name => "stall", exception => "kablooey" ) ;\n\n   \$t = timeout ;\n   \$t->interval( 5 ) ;\n\n   run ..., \$t ;\n   run ..., \$t = timeout( 5 ) ;\n\nA This convenience function is a shortened spelling of \n\n   IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... ) ;\n   \n.  It returns a timer in the reset state that will throw an\nexception when it expires.\n\nTakes the same parameters as L</timer>, any exception passed in overrides\nthe default exception.\n\n=cut\n\nsub timeout {\n   my \$t = IPC::Run::Timer->new( \@_ ) ;\n   \$t->exception( "IPC::Run: timeout on " . \$t->name )\n      unless defined \$t->exception ;\n   return \$t ;\n}\n\n\n=item new\n\n   IPC::Run::Timer->new()   ;\n   IPC::Run::Timer->new( 5 )   ;\n   IPC::Run::Timer->new( 5, exception => 'kablooey' )   ;\n\nConstructor.  See L</timer> for details.\n\n=cut\n\nmy \$timer_counter ;\n\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my IPC::Run::Timer \$self ;\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   \$self->{STATE} = 0 ;\n   \$self->{DEBUG} = 0 ;\n   \$self->{NAME}  = "timer #" . ++\$timer_counter ;\n\n   while ( \@_ ) {\n      my \$arg = shift ;\n      if ( \$arg =~ /^(?:\\d+[^\\a\\d]){0,3}\\d*(?:\\.\\d*)?\$/ ) {\n         \$self->interval( \$arg ) ;\n      }\n      elsif ( \$arg eq 'exception' ) {\n         \$self->exception( shift ) ;\n      }\n      elsif ( \$arg eq 'name' ) {\n         \$self->name( shift ) ;\n      }\n      elsif ( \$arg eq 'debug' ) {\n         \$self->debug( shift ) ;\n      }\n      else {\n         croak "IPC::Run: unexpected parameter '\$arg'" ;\n      }\n   }\n\n   _debug \$self->name . ' constructed'\n      if \$self->{DEBUG} || _debugging_details ;\n\n   return \$self ;\n}\n\n=item check\n\n   check \$t ;\n   check \$t, \$now ;\n   \$t->check ;\n\nChecks to see if a timer has expired since the last check.  Has no effect\non non-running timers.  This will throw an exception if one is defined.\n\nIPC::Run::pump() calls this routine for any timers in the harness.\n\nYou may pass in a version of now, which is useful in case you have\nit lying around or you want to check several timers with a consistent\nconcept of the current time.\n\nReturns the time left before end_time or 0 if end_time is no longer\nin the future or the timer is not running\n(unless, of course, check() expire()s the timer and this\nresults in an exception being thrown).\n\nReturns undef if the timer is not running on entry, 0 if check() expires it,\nand the time left if it's left running.\n\n=cut\n\nsub check {\n   my IPC::Run::Timer \$self = shift ;\n   return undef if ! \$self->is_running ;\n   return 0     if  \$self->is_expired ;\n\n   my ( \$now ) = \@_ ;\n   \$now = _parse_time( \$now ) ;\n   \$now = time unless defined \$now ;\n\n   _debug(\n      "checking ", \$self->name, " (end time ", \$self->end_time, ") at ", \$now \n   ) if \$self->{DEBUG} || _debugging_details ;\n\n   my \$left = \$self->end_time - \$now ;\n   return \$left if \$left > 0 ;\n\n   \$self->expire ;\n   return 0 ;\n}\n\n\n=item debug\n\nSets/gets the current setting of the debugging flag for this timer.  This\nhas no effect if debugging is not enabled for the current harness.\n\n=cut\n\n\nsub debug {\n   my IPC::Run::Timer \$self = shift ;\n   \$self->{DEBUG} = shift if \@_ ;\n   return \$self->{DEBUG} ;\n}\n\n\n=item end_time\n\n   \$et = \$t->end_time ;\n   \$et = end_time \$t ;\n\n   \$t->end_time( time + 10 ) ;\n\nReturns the time when this timer will or did expire.  Even if this time is\nin the past, the timer may not be expired, since check() may not have been\ncalled yet.\n\nNote that this end_time is not start_time(\$t) + interval(\$t), since some\nsmall extra amount of time is added to make sure that the timer does not\nexpire before interval() elapses.  If this were not so, then \n\nChanging end_time() while a timer is running will set the expiration time.\nChanging it while it is expired has no affect, since reset()ing a timer always\nclears the end_time().\n\n=cut\n\n\nsub end_time {\n   my IPC::Run::Timer \$self = shift ;\n   if ( \@_ ) {\n      \$self->{END_TIME} = shift ;\n      _debug \$self->name, ' end_time set to ', \$self->{END_TIME}\n\x09 if \$self->{DEBUG} > 2 || _debugging_details ;\n   }\n   return \$self->{END_TIME} ;\n}\n\n\n=item exception\n\n   \$x = \$t->exception ;\n   \$t->exception( \$x ) ;\n   \$t->exception( undef ) ;\n\nSets/gets the exception to throw, if any.  'undef' means that no\nexception will be thrown.  Exception does not need to be a scalar: you \nmay ask that references be thrown.\n\n=cut\n\n\nsub exception {\n   my IPC::Run::Timer \$self = shift ;\n   if ( \@_ ) {\n      \$self->{EXCEPTION} = shift ;\n      _debug \$self->name, ' exception set to ', \$self->{EXCEPTION}\n\x09 if \$self->{DEBUG} || _debugging_details ;\n   }\n   return \$self->{EXCEPTION} ;\n}\n\n\n=item interval\n\n   \$i = interval \$t ;\n   \$i = \$t->interval ;\n   \$t->interval( \$i ) ;\n\nSets the interval.  Sets the end time based on the start_time() and the\ninterval (and a little fudge) if the timer is running.\n\n=cut\n\nsub interval {\n   my IPC::Run::Timer \$self = shift ;\n   if ( \@_ ) {\n      \$self->{INTERVAL} = _parse_time( shift ) ;\n      _debug \$self->name, ' interval set to ', \$self->{INTERVAL}\n\x09 if \$self->{DEBUG} > 2 || _debugging_details ;\n\n      \$self->_calc_end_time if \$self->state ;\n   }\n   return \$self->{INTERVAL} ;\n}\n\n\n=item expire\n\n   expire \$t ;\n   \$t->expire ;\n\nSets the state to expired (undef).\nWill throw an exception if one\nis defined and the timer was not already expired.  You can expire a\nreset timer without starting it.\n\n=cut\n\n\nsub expire {\n   my IPC::Run::Timer \$self = shift ;\n   if ( defined \$self->state ) {\n      _debug \$self->name . ' expired'\n\x09 if \$self->{DEBUG} || _debugging ;\n\n      \$self->state( undef ) ;\n      croak \$self->exception if \$self->exception ;\n   }\n   return undef ;\n}\n\n\n=item is_running\n\n=cut\n\n\nsub is_running {\n   my IPC::Run::Timer \$self = shift ;\n   return \$self->state ? 1 : 0 ;\n}\n\n\n=item is_reset\n\n=cut\n   \nsub is_reset {\n   my IPC::Run::Timer \$self = shift ;\n   return defined \$self->state && \$self->state == 0 ;\n}\n\n\n=item is_expired\n\n=cut\n\nsub is_expired {\n   my IPC::Run::Timer \$self = shift ;\n   return ! defined \$self->state ;\n}\n\n=item name\n\nSets/gets this timer's name.  The name is only used for debugging\npurposes so you can tell which freakin' timer is doing what.\n\n=cut\n\nsub name {\n   my IPC::Run::Timer \$self = shift ;\n \n   \$self->{NAME} = shift if \@_ ;\n   return defined \$self->{NAME}\n      ? \$self->{NAME}\n      : defined \$self->{EXCEPTION}\n         ? 'timeout'\n\x09 : 'timer' ;\n}\n\n\n=item reset\n\n   reset \$t ;\n   \$t->reset ;\n\nResets the timer to the non-running, non-expired state and clears\nthe end_time().\n\n=cut\n\nsub reset {\n   my IPC::Run::Timer \$self = shift ;\n   \$self->state( 0 ) ;\n   \$self->end_time( undef ) ;\n   _debug \$self->name . ' reset'\n      if \$self->{DEBUG} || _debugging ;\n\n   return undef ;\n}\n\n\n=item start\n\n   start \$t ;\n   \$t->start ;\n   start \$t, \$interval ;\n   start \$t, \$interval, \$now ;\n\nStarts or restarts a timer.  This always sets the start_time.  It sets the\nend_time based on the interval if the timer is running or if no end time\nhas been set.\n\nYou may pass an optional interval or current time value.\n\nNot passing a defined interval causes the previous interval setting to be\nre-used unless the timer is reset and an end_time has been set\n(an exception is thrown if no interval has been set).  \n\nNot passing a defined current time value causes the current time to be used.\n\nPassing a current time value is useful if you happen to have a time value\nlying around or if you want to make sure that several timers are started\nwith the same concept of start time.  You might even need to lie to an\nIPC::Run::Timer, occasionally.\n\n=cut\n\nsub start {\n   my IPC::Run::Timer \$self = shift ;\n\n   my ( \$interval, \$now ) = map { _parse_time( \$_ ) } \@_ ;\n   \$now = _parse_time( \$now ) ;\n   \$now = time unless defined \$now ;\n\n   \$self->interval( \$interval ) if defined \$interval ;\n\n   ## start()ing a running or expired timer clears the end_time, so that the\n   ## interval is used.  So does specifying an interval.\n   \$self->end_time( undef ) if ! \$self->is_reset || \$interval ;\n\n   croak "IPC::Run: no timer interval or end_time defined for " . \$self->name\n      unless defined \$self->interval || defined \$self->end_time ;\n\n   \$self->state( 1 ) ;\n   \$self->start_time( \$now ) ;\n   ## The "+ 1" is in case the START_TIME was sampled at the end of a\n   ## tick (which are one second long in this module).\n   \$self->_calc_end_time\n      unless defined \$self->end_time ;\n\n   _debug(\n      \$self->name, " started at ", \$self->start_time,\n      ", with interval ", \$self->interval, ", end_time ", \$self->end_time\n   ) if \$self->{DEBUG} || _debugging ;\n   return undef ;\n}\n\n\n=item start_time\n\nSets/gets the start time, in seconds since the epoch.  Setting this manually\nis a bad idea, it's better to call L</start>() at the correct time.\n\n=cut\n\n\nsub start_time {\n   my IPC::Run::Timer \$self = shift ;\n   if ( \@_ ) {\n      \$self->{START_TIME} = _parse_time( shift ) ;\n      _debug \$self->name, ' start_time set to ', \$self->{START_TIME}\n\x09 if \$self->{DEBUG} > 2 || _debugging ;\n   }\n\n   return \$self->{START_TIME} ;\n}\n\n\n=item state\n\n   \$s = state \$t ;\n   \$t->state( \$s ) ;\n\nGet/Set the current state.  Only use this if you really need to transfer the\nstate to/from some variable.\nUse L</expire>, L</start>, L</reset>, L</is_expired>, L</is_running>,\nL</is_reset>.\n\nNote:  Setting the state to 'undef' to expire a timer will not throw an\nexception.\n\n=cut\n\nsub state {\n   my IPC::Run::Timer \$self = shift ;\n   if ( \@_ ) {\n      \$self->{STATE} = shift ;\n      _debug \$self->name, ' state set to ', \$self->{STATE}\n\x09 if \$self->{DEBUG} > 2 || _debugging ;\n   }\n   return \$self->{STATE} ;\n}\n\n\n=head1 TODO\n\nuse Time::HiRes ; if it's present.\n\nAdd detection and parsing of [[[HH:]MM:]SS formatted times and intervals.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAADL
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADM, "lib/IPC/Run/Win32Pump.pm" }
package IPC::Run::Win32Pump;\n\n=head1 NAME\n\nIPC::Run::Win32Pumper - helper processes to shovel data to/from parent, child\n\n=head1 SYNOPSIS\n\nInternal use only; see IPC::Run::Win32IO and best of luck to you.\n\n=head1 DESCRIPTION\n\nSee L<IPC::Run::Win32Helper|IPC::Run::Win32Helper> for details.  This\nmodule is used in subprocesses that are spawned to shovel data to/from\nparent processes from/to their child processes.  Where possible, pumps\nare optimized away.\n\nNOTE: This is not a real module: it's a script in module form, designed\nto be run like\n\n   \$^X -MIPC::Run::Win32Pumper -e 1 ...\n\nIt parses a bunch of command line parameters from IPC::Run::Win32IO.\n\n=cut\n\nuse strict ;\n\nuse Win32API::File qw(\n   OsFHandleOpen\n) ;\n\n\nmy ( \$stdin_fh, \$stdout_fh, \$debug_fh, \$parent_pid, \$parent_start_time, \$debug, \$child_label );\nBEGIN {\n   ( \$stdin_fh, \$stdout_fh, \$debug_fh, \$parent_pid, \$parent_start_time, \$debug, \$child_label ) = \@ARGV ;\n\n   ## Rather than letting IPC::Run::Debug export all-0 constants\n   ## when not debugging, we do it manually in order to not even\n   ## load IPC::Run::Debug.\n   if ( \$debug ) {\n      eval "use IPC::Run::Debug qw( :default _debug_init ); 1;"\n\x09 or die \$\@;\n   }\n   else {\n      eval <<STUBS_END or die \$\@;\n\x09 sub _debug {}\n\x09 sub _debug_init {}\n\x09 sub _debugging() { 0 }\n\x09 sub _debugging_data() { 0 }\n\x09 sub _debugging_details() { 0 }\n\x09 sub _debugging_gory_details() { 0 }\n\x09 1;\nSTUBS_END\n   }\n}\n\n## For some reason these get created with binmode on.  AAargh, gotta       #### REMOVE\n## do it by hand below.       #### REMOVE\nif ( \$debug ) {       #### REMOVE\nclose STDERR;       #### REMOVE\nOsFHandleOpen( \\*STDERR, \$debug_fh, "w" )       #### REMOVE\n or print "\$! opening STDERR as Win32 handle \$debug_fh in pumper \$\$" ;       #### REMOVE\n}       #### REMOVE\nclose STDIN;       #### REMOVE\nOsFHandleOpen( \\*STDIN, \$stdin_fh, "r" )       #### REMOVE\nor die "\$! opening STDIN as Win32 handle \$stdin_fh in pumper \$\$" ;       #### REMOVE\nclose STDOUT;       #### REMOVE\nOsFHandleOpen( \\*STDOUT, \$stdout_fh, "w" )       #### REMOVE\nor die "\$! opening STDOUT as Win32 handle \$stdout_fh in pumper \$\$" ;       #### REMOVE\n\nbinmode STDIN;\nbinmode STDOUT;\n\$| = 1 ;\nselect STDERR ; \$| = 1 ; select STDOUT ;\n\n\$child_label ||= "pump" ;\n_debug_init(\n\$parent_pid,\n\$parent_start_time,\n\$debug,\nfileno STDERR,\n\$child_label,\n) ;\n\n_debug "Entered" if _debugging_details ;\n\n# No need to close all fds; win32 doesn't seem to pass any on to us.\n\$| = 1 ;\nmy \$buf ;\nmy \$total_count = 0 ;\nwhile (1) {\nmy \$count = sysread STDIN, \$buf, 10_000 ;\nlast unless \$count ;\nif ( _debugging_gory_details ) {\n my \$msg = "'\$buf'" ;\n substr( \$msg, 100, -1 ) = '...' if length \$msg > 100 ;\n \$msg =~ s/\\n/\\\\n/g ;\n \$msg =~ s/\\r/\\\\r/g ;\n \$msg =~ s/\\t/\\\\t/g ;\n \$msg =~ s/([\\000-\\037\\177-\\277])/sprintf "\\0x%02x", ord \$1/eg ;\n _debug sprintf( "%5d chars revc: ", \$count ), \$msg ;\n}\n\$total_count += \$count ;\nif ( _debugging_gory_details ) {\n my \$msg = "'\$buf'" ;\n substr( \$msg, 100, -1 ) = '...' if length \$msg > 100 ;\n \$msg =~ s/\\n/\\\\n/g ;\n \$msg =~ s/\\r/\\\\r/g ;\n \$msg =~ s/\\t/\\\\t/g ;\n \$msg =~ s/([\\000-\\037\\177-\\277])/sprintf "\\0x%02x", ord \$1/eg ;\n _debug sprintf( "%5d chars sent: ", \$count ), \$msg ;\n}\nprint \$buf ;\n}\n\n_debug "Exiting, transferred \$total_count chars" if _debugging_details ;\n\n## Perform a graceful socket shutdown.  Windows defaults to SO_DONTLINGER,\n## which should cause a "graceful shutdown in the background" on sockets.\n## but that's only true if the process closes the socket manually, it\n## seems; if the process exits and lets the OS clean up, the OS is not\n## so kind.  STDOUT is not always a socket, of course, but it won't hurt\n## to close a pipe and may even help.  With a closed source OS, who\n## can tell?\n##\n## In any case, this close() is one of the main reasons we have helper\n## processes; if the OS closed socket fds gracefully when an app exits,\n## we'd just redirect the client directly to what is now the pump end \n## of the socket.  As it is, however, we need to let the client play with\n## pipes, which don't have the abort-on-app-exit behavior, and then\n## adapt to the sockets in the helper processes to allow the parent to\n## select.\n##\n## Possible alternatives / improvements:\n## \n## 1) use helper threads instead of processes.  I don't trust perl's threads\n## as of 5.005 or 5.6 enough (which may be myopic of me).\n##\n## 2) figure out if/how to get at WaitForMultipleObjects() with pipe\n## handles.  May be able to take the Win32 handle and pass it to \n## Win32::Event::wait_any, dunno.\n## \n## 3) Use Inline::C or a hand-tooled XS module to do helper threads.\n## This would be faster than #1, but would require a ppm distro.\n##\nclose STDOUT ;\nclose STDERR ;\n\n=head1 AUTHOR\n\nBarries Slaymaker <barries\@slaysys.com>.  Funded by Perforce Software, Inc.\n\n=head1 COPYRIGHT\n\nCopyright 2001, Barrie Slaymaker, All Rights Reserved.\n\nYou may use this under the terms of either the GPL 2.0 ir the Artistic License.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAADM
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADN, "lib/IPC/Run/Win32Helper.pm" }
package IPC::Run::Win32Helper ;\n\n=head1 NAME\n\nIPC::Run::Win32Helper - helper routines for IPC::Run on Win32 platforms.\n\n=head1 SYNOPSIS\n\nuse IPC::Run::Win32Helper ;   # Exports all by default\n\n=head1 DESCRIPTION\n\nIPC::Run needs to use sockets to redirect subprocess I/O so that the select() loop\nwill work on Win32. This seems to only work on WinNT and Win2K at this time, not\nsure if it will ever work on Win95 or Win98. If you have experience in this area, please\ncontact me at barries\@slaysys.com, thanks!.\n\n=cut\n\n\@ISA = qw( Exporter ) ;\n\n\@EXPORT = qw(\n   win32_spawn\n   win32_parse_cmd_line\n   _dont_inherit\n   _inherit\n) ;\n\nuse strict ;\nuse Carp ;\nuse IO::Handle ;\n#use IPC::Open3 ();\nrequire POSIX ;\n\n## Work around missing prototypes in old Socket.pm versions\nsub Socket::IPPROTO_TCP() ;\nsub Socket::TCP_NODELAY() ;\n\nuse Text::ParseWords ;\nuse Win32::Process ;\nuse IPC::Run::Debug;\n## REMOVE OSFHandleOpen\nuse Win32API::File qw(\n   FdGetOsFHandle\n   SetHandleInformation\n   HANDLE_FLAG_INHERIT\n   INVALID_HANDLE_VALUE\n) ;\n\n## Takes an fd or a GLOB ref, never never never a Win32 handle.\nsub _dont_inherit {\n   for ( \@_ ) {\n      next unless defined \$_ ;\n      my \$fd = \$_ ;\n      \$fd = fileno \$fd if ref \$fd ;\n      _debug "disabling inheritance of ", \$fd if _debugging_details ;\n      my \$osfh = FdGetOsFHandle \$fd ;\n      croak \$^E if ! defined \$osfh || \$osfh == INVALID_HANDLE_VALUE ;\n\n      SetHandleInformation( \$osfh, HANDLE_FLAG_INHERIT, 0 ) ;\n   }\n}\n\nsub _inherit {       #### REMOVE\n   for ( \@_ ) {       #### REMOVE\n      next unless defined \$_ ;       #### REMOVE\n      my \$fd = \$_ ;       #### REMOVE\n      \$fd = fileno \$fd if ref \$fd ;       #### REMOVE\n      _debug "enabling inheritance of ", \$fd if _debugging_details ;       #### REMOVE\n      my \$osfh = FdGetOsFHandle \$fd ;       #### REMOVE\n      croak \$^E if ! defined \$osfh || \$osfh == INVALID_HANDLE_VALUE ;       #### REMOVE\n       #### REMOVE\n      SetHandleInformation( \$osfh, HANDLE_FLAG_INHERIT, 1 ) ;       #### REMOVE\n   }       #### REMOVE\n}       #### REMOVE\n       #### REMOVE\n#sub _inherit {\n#   for ( \@_ ) {\n#      next unless defined \$_ ;\n#      my \$osfh = GetOsFHandle \$_ ;\n#      croak \$^E if ! defined \$osfh || \$osfh == INVALID_HANDLE_VALUE ;\n#      SetHandleInformation( \$osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT ) ;\n#   }\n#}\n\n=head1 FUNCTIONS\n\n=over\n\n=cut\n\n=item optimize()\n\nMost common incantations of C<run()> (I<not> C<harness()>, C<start()>,\nor C<finish()>) now use temporary files to redirect input and output\ninstead of pumper processes.\n\nTemporary files are used when sending to child processes if input is\ntaken from a scalar with no filter subroutines.  This is the only time\nwe can assume that the parent is not interacting with the child's\nredirected input as it runs.\n\nTemporary files are used when receiving from children when output is\nto a scalar or subroutine with or without filters, but only if\nthe child in question closes its inputs or takes input from \nunfiltered SCALARs or named files.  Normally, a child inherits its STDIN\nfrom its parent; to close it, use "0<&-" or the C<noinherit => 1> option.\nIf data is sent to the child from CODE refs, filehandles or from\nscalars through filters than the child's outputs will not be optimized\nbecause C<optimize()> assumes the parent is interacting with the child.\nIt is ok if the output is filtered or handled by a subroutine, however.\n\nThis assumes that all named files are real files (as opposed to named\npipes) and won't change; and that a process is not communicating with\nthe child indirectly (through means not visible to IPC::Run).\nThese can be an invalid assumptions, but are the 99% case.\nWrite me if you need an option to enable or disable optimizations; I\nsuspect it will work like the C<binary()> modifier.\n\nTo detect cases that you might want to optimize by closing inputs, try\nsetting the C<IPCRUNDEBUG> environment variable to the special C<notopt>\nvalue:\n\n   C:> set IPCRUNDEBUG=notopt\n   C:> my_app_that_uses_IPC_Run.pl\n\n=item optimizer() rationalizations\n\nOnly for that limited case can we be sure that it's ok to batch all the\ninput in to a temporary file.  If STDIN is from a SCALAR or from a named\nfile or filehandle (again, only in C<run()>), then outputs to CODE refs\nare also assumed to be safe enough to batch through a temp file,\notherwise only outputs to SCALAR refs are batched.  This can cause a bit\nof grief if the parent process benefits from or relies on a bit of\n"early returns" coming in before the child program exits.  As long as\nthe output is redirected to a SCALAR ref, this will not be visible.\nWhen output is redirected to a subroutine or (deprecated) filters, the\nsubroutine will not get any data until after the child process exits,\nand it is likely to get bigger chunks of data at once.\n\nThe reason for the optimization is that, without it, "pumper" processes\nare used to overcome the inconsistancies of the Win32 API.  We need to\nuse anonymous pipes to connect to the child processes' stdin, stdout,\nand stderr, yet select() does not work on these.  select() only works on\nsockets on Win32.  So for each redirected child handle, there is\nnormally a "pumper" process that connects to the parent using a\nsocket--so the parent can select() on that fd--and to the child on an\nanonymous pipe--so the child can read/write a pipe.\n\nUsing a socket to connect directly to the child (as at least one MSDN\narticle suggests) seems to cause the trailing output from most children\nto be lost.  I think this is because child processes rarely close their\nstdout and stderr explicitly, and the winsock dll does not seem to flush\noutput when a process that uses it exits without explicitly closing\nthem.\n\nBecause of these pumpers and the inherent slowness of Win32\nCreateProcess(), child processes with redirects are quite slow to\nlaunch; so this routine looks for the very common case of\nreading/writing to/from scalar references in a run() routine and\nconverts such reads and writes in to temporary file reads and writes.\n\nSuch files are marked as FILE_ATTRIBUTE_TEMPORARY to increase speed and\nas FILE_FLAG_DELETE_ON_CLOSE so it will be cleaned up when the child\nprocess exits (for input files).  The user's default permissions are\nused for both the temporary files and the directory that contains them,\nhope your Win32 permissions are secure enough for you.  Files are\ncreated with the Win32API::File defaults of\nFILE_SHARE_READ|FILE_SHARE_WRITE.\n\nSetting the debug level to "details" or "gory" will give detailed\ninformation about the optimization process; setting it to "basic" or\nhigher will tell whether or not a given call is optimized.  Setting\nit to "notopt" will highligh those calls that aren't optimized.\n\n=cut\n\nsub optimize {\n   my ( \$h ) = \@_;\n\n   my \@kids = \@{\$h->{KIDS}};\n\n   my \$saw_pipe;\n\n   my ( \$ok_to_optimize_outputs, \$veto_output_optimization );\n\n   for my \$kid ( \@kids ) {\n      ( \$ok_to_optimize_outputs, \$veto_output_optimization ) = ()\n         unless \$saw_pipe;\n\n      _debug\n         "Win32 optimizer: (kid \$kid->{NUM}) STDIN piped, carrying over ok of non-SCALAR output optimization"\n         if _debugging_details && \$ok_to_optimize_outputs;\n      _debug\n         "Win32 optimizer: (kid \$kid->{NUM}) STDIN piped, carrying over veto of non-SCALAR output optimization"\n         if _debugging_details && \$veto_output_optimization;\n\n      if ( \$h->{noinherit} && ! \$ok_to_optimize_outputs ) {\n\x09 _debug\n\x09    "Win32 optimizer: (kid \$kid->{NUM}) STDIN not inherited from parent oking non-SCALAR output optimization"\n\x09    if _debugging_details && \$ok_to_optimize_outputs;\n\x09 \$ok_to_optimize_outputs = 1;\n      }\n\n      for ( \@{\$kid->{OPS}} ) {\n         if ( substr( \$_->{TYPE}, 0, 1 ) eq "<" ) {\n            if ( \$_->{TYPE} eq "<" ) {\n\x09       if ( \@{\$_->{FILTERS}} > 1 ) {\n\x09\x09  ## Can't assume that the filters are idempotent.\n\x09       }\n               elsif ( ref \$_->{SOURCE} eq "SCALAR"\n\x09          || ref \$_->{SOURCE} eq "GLOB"\n\x09\x09  || UNIVERSAL::isa( \$_, "IO::Handle" )\n\x09       ) {\n                  if ( \$_->{KFD} == 0 ) {\n                     _debug\n                        "Win32 optimizer: (kid \$kid->{NUM}) 0\$_->{TYPE}",\n                        ref \$_->{SOURCE},\n                        ", ok to optimize outputs"\n                        if _debugging_details;\n                     \$ok_to_optimize_outputs = 1;\n                  }\n                  \$_->{SEND_THROUGH_TEMP_FILE} = 1;\n                  next;\n               }\n               elsif ( ! ref \$_->{SOURCE} && defined \$_->{SOURCE} ) {\n                  if ( \$_->{KFD} == 0 ) {\n                     _debug\n                        "Win32 optimizer: (kid \$kid->{NUM}) 0<\$_->{SOURCE}, ok to optimize outputs",\n                        if _debugging_details;\n                     \$ok_to_optimize_outputs = 1;\n                  }\n                  next;\n               }\n            }\n            _debug\n               "Win32 optimizer: (kid \$kid->{NUM}) ",\n               \$_->{KFD},\n               \$_->{TYPE},\n               defined \$_->{SOURCE}\n                  ? ref \$_->{SOURCE}      ? ref \$_->{SOURCE}\n                                          : \$_->{SOURCE}\n                  : defined \$_->{FILENAME}\n                                          ? \$_->{FILENAME}\n                                          : "",\n\x09       \@{\$_->{FILTERS}} > 1 ? " with filters" : (),\n               ", VETOING output opt."\n               if _debugging_details || _debugging_not_optimized;\n            \$veto_output_optimization = 1;\n         }\n         elsif ( \$_->{TYPE} eq "close" && \$_->{KFD} == 0 ) {\n            \$ok_to_optimize_outputs = 1;\n            _debug "Win32 optimizer: (kid \$kid->{NUM}) saw 0<&-, ok to optimize outputs"\n               if _debugging_details;\n         }\n         elsif ( \$_->{TYPE} eq "dup" && \$_->{KFD2} == 0 ) {\n            \$veto_output_optimization = 1;\n            _debug "Win32 optimizer: (kid \$kid->{NUM}) saw 0<&\$_->{KFD2}, VETOING output opt."\n               if _debugging_details || _debugging_not_optimized;\n         }\n         elsif ( \$_->{TYPE} eq "|" ) {\n            \$saw_pipe = 1;\n         }\n      }\n\n      if ( ! \$ok_to_optimize_outputs && ! \$veto_output_optimization ) {\n         _debug\n            "Win32 optimizer: (kid \$kid->{NUM}) child STDIN not redirected, VETOING non-SCALAR output opt."\n            if _debugging_details || _debugging_not_optimized;\n         \$veto_output_optimization = 1;\n      }\n\n      if ( \$ok_to_optimize_outputs && \$veto_output_optimization ) {\n         \$ok_to_optimize_outputs = 0;\n         _debug "Win32 optimizer: (kid \$kid->{NUM}) non-SCALAR output optimizations VETOed"\n            if _debugging_details || _debugging_not_optimized;\n      }\n\n      ## SOURCE/DEST ARRAY means it's a filter.\n      ## TODO: think about checking to see if the final input/output of\n      ## a filter chain (an ARRAY SOURCE or DEST) is a scalar...but\n      ## we may be deprecating filters.\n\n      for ( \@{\$kid->{OPS}} ) {\n         if ( \$_->{TYPE} eq ">" ) {\n            if ( ref \$_->{DEST} eq "SCALAR"\n               || (\n                  ( \@{\$_->{FILTERS}} > 1\n\x09\x09     || ref \$_->{DEST} eq "CODE"\n\x09\x09     || ref \$_->{DEST} eq "ARRAY"  ## Filters?\n\x09          )\n                  && ( \$ok_to_optimize_outputs && ! \$veto_output_optimization ) \n               )\n            ) {\n\x09       \$_->{RECV_THROUGH_TEMP_FILE} = 1;\n\x09       next;\n            }\n\x09    _debug\n\x09       "Win32 optimizer: NOT optimizing (kid \$kid->{NUM}) ",\n\x09       \$_->{KFD},\n\x09       \$_->{TYPE},\n\x09       defined \$_->{DEST}\n\x09\x09  ? ref \$_->{DEST}      ? ref \$_->{DEST}\n\x09\x09\x09\x09\x09  : \$_->{SOURCE}\n\x09\x09  : defined \$_->{FILENAME}\n\x09\x09\x09\x09\x09  ? \$_->{FILENAME}\n\x09\x09\x09\x09\x09  : "",\n\x09\x09  \@{\$_->{FILTERS}} ? " with filters" : (),\n\x09       if _debugging_details;\n         }\n      }\n   }\n\n}\n\n=item win32_parse_cmd_line\n\n   \@words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} ) ;\n\nreturns 4 words. This parses like the bourne shell (see\nthe bit about shellwords() in L<Text::ParseWords>), assuming we're\ntrying to be a little cross-platform here.  The only difference is\nthat "\\" is *not* treated as an escape except when it precedes \npunctuation, since it's used all over the place in DOS path specs.\n\nTODO: globbing? probably not (it's unDOSish).\n\nTODO: shebang emulation? Probably, but perhaps that should be part\nof Run.pm so all spawned processes get the benefit.\n\nLIMITATIONS: shellwords dies silently on malformed input like \n\n   a\\"\n\n=cut\n\nsub win32_parse_cmd_line {\n   my \$line = shift ;\n   \$line =~ s{(\\\\[\\w\\s])}{\\\\\$1}g ;\n   return shellwords \$line ;\n}\n\n\n=item win32_spawn\n\nSpawns a child process, possibly with STDIN, STDOUT, and STDERR (file descriptors 0, 1, and 2, respectively) redirected.\n\nB<LIMITATIONS>.\n\nCannot redirect higher file descriptors due to lack of support for this in the\nWin32 environment.\n\nThis can be worked around by marking a handle as inheritable in the\nparent (or leaving it marked; this is the default in perl), obtaining it's\nWin32 handle with C<Win32API::GetOSFHandle(FH)> or\nC<Win32API::FdGetOsFHandle(\$fd)> and passing it to the child using the command\nline, the environment, or any other IPC mechanism (it's a plain old integer).\nThe child can then use C<OsFHandleOpen()> or C<OsFHandleOpenFd()> and possibly\nC<<open FOO ">&BAR">> or C<<open FOO ">&\$fd>> as need be.  Ach, the pain!\n\nRemember to check the Win32 handle against INVALID_HANDLE_VALUE.\n\n=cut\n\nsub _save {\n   my ( \$saved, \$saved_as, \$fd ) = \@_ ;\n\n   ## We can only save aside the original fds once.\n   return if exists \$saved->{\$fd} ;\n\n   my \$saved_fd = IPC::Run::_dup( \$fd ) ;\n   _dont_inherit \$saved_fd ;\n\n   \$saved->{\$fd} = \$saved_fd ;\n   \$saved_as->{\$saved_fd} = \$fd ;\n\n   _dont_inherit \$saved->{\$fd} ;\n}\n\nsub _dup2_gently {\n   my ( \$saved, \$saved_as, \$fd1, \$fd2 ) = \@_ ;\n   _save \$saved, \$saved_as, \$fd2 ;\n\n   if ( exists \$saved_as->{\$fd2} ) {\n      ## The target fd is colliding with a saved-as fd, gotta bump\n      ## the saved-as fd to another fd.\n      my \$orig_fd = delete \$saved_as->{\$fd2} ;\n      my \$saved_fd = IPC::Run::_dup( \$fd2 ) ;\n      _dont_inherit \$saved_fd ;\n\n      \$saved->{\$orig_fd} = \$saved_fd ;\n      \$saved_as->{\$saved_fd} = \$orig_fd ;\n   }\n   _debug "moving \$fd1 to kid's \$fd2" if _debugging_details ;\n   IPC::Run::_dup2_rudely( \$fd1, \$fd2 ) ;\n}\n\nsub win32_spawn {\n   my ( \$cmd, \$ops) = \@_ ;\n\n   ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT.\n   ## and is not to the "real" child process, since they would not know\n   ## what to do with it...unlike Unix, we have no code executing in the\n   ## child before the "real" child is exec()ed.\n   \n   my %saved ;      ## Map of parent's orig fd -> saved fd\n   my %saved_as ;   ## Map of parent's saved fd -> orig fd, used to\n                    ## detect collisions between a KFD and the fd a\n\x09\x09    ## parent's fd happened to be saved to.\n   \n   for my \$op ( \@\$ops ) {\n      _dont_inherit \$op->{FD}  if defined \$op->{FD} ;\n\n      if ( defined \$op->{KFD} && \$op->{KFD} > 2 ) {\n\x09 ## TODO: Detect this in harness()\n\x09 ## TODO: enable temporary redirections if ever necessary, not\n\x09 ## sure why they would be...\n\x09 ## 4>&1 1>/dev/null 1>&4 4>&-\n         croak "Can't redirect fd #", \$op->{KFD}, " on Win32" ;\n      }\n\n      ## This is very similar logic to IPC::Run::_do_kid_and_exit().\n      if ( defined \$op->{TFD} ) {\n\x09 unless ( \$op->{TFD} == \$op->{KFD} ) {\n\x09    _dup2_gently \\%saved, \\%saved_as, \$op->{TFD}, \$op->{KFD} ;\n\x09    _dont_inherit \$op->{TFD} ;\n\x09 }\n      }\n      elsif ( \$op->{TYPE} eq "dup" ) {\n         _dup2_gently \\%saved, \\%saved_as, \$op->{KFD1}, \$op->{KFD2}\n            unless \$op->{KFD1} == \$op->{KFD2} ;\n      }\n      elsif ( \$op->{TYPE} eq "close" ) {\n\x09 _save \\%saved, \\%saved_as, \$op->{KFD} ;\n\x09 IPC::Run::_close( \$op->{KFD} ) ;\n      }\n      elsif ( \$op->{TYPE} eq "init" ) {\n\x09 ## TODO: detect this in harness()\n         croak "init subs not allowed on Win32" ;\n      }\n   }\n\n   my \$process ;\n   my \$cmd_line = join " ", map {\n      if ( /["\\s]/ ) {\n\x09 s/"/\\\\"/g ;\n\x09 qq{"\$_"} ;\n      }\n      else {\n         \$_ ;\n      }\n   } \@\$cmd ;\n\n   _debug "cmd line: ", \$cmd_line\n      if _debugging;\n\n   Win32::Process::Create( \n      \$process,\n      \$cmd->[0],\n      \$cmd_line,\n      1,  ## Inherit handles\n      NORMAL_PRIORITY_CLASS,\n      ".",\n   ) or croak "\$!: Win32::Process::Create()" ;\n\n   for my \$orig_fd ( keys %saved ) {\n      IPC::Run::_dup2_rudely( \$saved{\$orig_fd}, \$orig_fd ) ;\n      IPC::Run::_close( \$saved{\$orig_fd} ) ;\n   }\n\n   return ( \$process->GetProcessID(), \$process ) ;\n}\n\n\n=back\n\n=head1 AUTHOR\n\nBarries Slaymaker <barries\@slaysys.com>.  Funded by Perforce Software, Inc.\n\n=head1 COPYRIGHT\n\nCopyright 2001, Barrie Slaymaker, All Rights Reserved.\n\nYou may use this under the terms of either the GPL 2.0 ir the Artistic License.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAADN
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADO, "lib/IPC/Run/IO.pm" }
package IPC::Run::IO ;\n\n=head1 NAME\n\n   IPC::Run::IO -- I/O channels for IPC::Run.\n\n=head1 SYNOPSIS\n\nB<NOT IMPLEMENTED YET ON Win32! Win32 does not allow select() on\nnormal file descriptors; IPC::RUN::IO needs to use IPC::Run::Win32Helper\nto do this.>\n\n   use IPC::Run qw( io ) ;\n\n   ## The sense of '>' and '<' is opposite of perl's open(),\n   ## but agrees with IPC::Run.\n   \$io = io( "filename", '>',  \\\$recv ) ;\n   \$io = io( "filename", 'r',  \\\$recv ) ;\n\n   ## Append to \$recv:\n   \$io = io( "filename", '>>', \\\$recv ) ;\n   \$io = io( "filename", 'ra', \\\$recv ) ;\n\n   \$io = io( "filename", '<',  \\\$send ) ;\n   \$io = io( "filename", 'w',  \\\$send ) ;\n\n   \$io = io( "filename", '<<', \\\$send ) ;\n   \$io = io( "filename", 'wa', \\\$send ) ;\n\n   ## Handles / IO objects that the caller opens:\n   \$io = io( \\*HANDLE,   '<',  \\\$send ) ;\n\n   \$f = IO::Handle->new( ... ) ; # Any subclass of IO::Handle\n   \$io = io( \$f, '<', \\\$send ) ;\n\n   require IPC::Run::IO ;\n   \$io = IPC::Run::IO->new( ... ) ;\n\n   ## Then run(), harness(), or start():\n   run \$io, ... ;\n\n   ## You can, of course, use io() or IPC::Run::IO->new() as an\n   ## argument to run(), harness, or start():\n   run io( ... ) ;\n\n\n=head1 DESCRIPTION\n\nThis class and module allows filehandles and filenames to be harnessed for\nI/O when used IPC::Run, independant of anything else IPC::Run is doing\n(except that errors & exceptions can affect all things that IPC::Run is\ndoing).\n\n=head1 SUBCLASSING\n\nThis class uses the fields pragma, so you need to be aware of the contraints\nand strengths that this confers upon subclasses.\nSee the L<base> and L<fields> pragmas for more information.\n\n=head1 TODO\n\nImplement bidirectionality.\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>\n\n=cut ;\n\n## This class is also used internally by IPC::Run in a very initimate way,\n## since this is a partial factoring of code from IPC::Run plus some code\n## needed to do standalone channels.  This factoring process will continue\n## at some point.  Don't know how far how fast.\n\nuse strict ;\nuse Carp ;\nuse Fcntl ;\nuse Symbol ;\nuse UNIVERSAL qw( isa ) ;\n\nuse IPC::Run::Debug;\nuse IPC::Run qw( Win32_MODE );\n\nuse fields (\n    'TYPE',             # Directionality\n    'DEST',             # Where to send data to when reading from HANDLE\n    'SOURCE',           # Where to get data from when writing to HANDLE\n    'FILENAME',         # The filename to open & close, if any\n    'HANDLE',           # This object's handle\n    'FD',               # File descriptor of 'HANDLE'\n    'TFD',              # fd# file is opened on in parent, will be moved to KFD\n                        # in kid\n    'KFD',              # fd# kid needs to see it on\n    'FILTERS',          # Any filtration?\n    'FBUFS',            # SCALAR refs to filter buffers, including I/O scalars\n    'PAUSED',           # If the input side is paused.\n    'SOURCE_EMPTY',     # No more data to send to file.\n    'PTY_ID',           # The nickname of the pty it HANDLE is a pty\n    'DONT_CLOSE',       # Set if this is an externally opened handle, so\n                        # we know better than to close it.\n\n    'KIN_REF',          # Refers to the input value, whether it's an externally\n                        # supplied SCALAR, or the output buffer for an\n        \x09\x09# externally supplied CODE ref.\n    'TRUNC',            # Whether or not to truncate the output file if a\n                        # named file is passed.\n    'HARNESS',          # Temporarily set to the IPC::Run instance that\n                        # called us while we're doing filters.  Unset to\n        \x09\x09# prevent circrefs.\n    'FAKE_PIPE',        # Used to hold the "fake pipe" objects on Win32,\n                        # since Win32 requires a lot of extra monkey business.\n    'BINMODE',          # If you want all the data on Win32...\n) ;\n\nBEGIN {\n   if ( Win32_MODE ) {\n      eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1"\n         or ( \$\@ && die ) or die "\$!" ;\n   }\n}\n\nsub _empty(\$) ;\n\n*_empty          = \\&IPC::Run::_empty ;\n\n\nsub new {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   my ( \$external, \$type, \$internal ) = ( shift, shift, pop ) ;\n\n   croak "\$class: '\$_' is not a valid I/O operator"\n      unless \$type =~ /^(?:<<?|>>?)\$/ ;\n\n   my IPC::Run::IO \$self = \$class->_new_internal(\n      \$type, undef, undef, \$internal, undef, \@_\n   ) ;\n\n   if ( ! ref \$external ) {\n      \$self->{FILENAME} = \$external ;\n   }\n   elsif ( ref eq 'GLOB' || isa( \$external, 'IO::Handle' ) ) {\n      \$self->{HANDLE} = \$external ;\n      \$self->{DONT_CLOSE} = 1 ;\n   }\n   else {\n      croak "\$class: cannot accept " . ref( \$external ) . " to do I/O with" ;\n   }\n\n   return \$self ;\n}\n\n\n## IPC::Run uses this ctor, since it preparses things and needs more\n## smarts.\nsub _new_internal {\n   my \$class = shift ;\n   \$class = ref \$class || \$class ;\n\n   \$class = "IPC::Run::Win32IO"\n      if Win32_MODE && \$class eq "IPC::Run::IO";\n\n   my IPC::Run::IO \$self ;\n   {\n      no strict 'refs' ;\n      \$self = bless [ \\%{"\$class\\::FIELDS"} ], \$class ;\n   }\n\n   my ( \$type, \$kfd, \$pty_id, \$internal, \$binmode, \@filters ) = \@_ ;\n\n   # Older perls (<=5.00503, at least) don't do list assign to\n   # psuedo-hashes well.\n   \$self->{TYPE}    = \$type ;\n   \$self->{KFD}     = \$kfd ;\n   \$self->{PTY_ID}  = \$pty_id ;\n   \$self->binmode( \$binmode ) ;\n   \$self->{FILTERS} = [ \@filters ] ;\n\n   ## Add an adapter to the end of the filter chain (which is usually just the\n   ## read/writer sub pushed by IPC::Run) to the DEST or SOURCE, if need be.\n   if ( \$self->op =~ />/ ) {\n      croak "'\$_' missing a destination" if _empty \$internal ;\n      \$self->{DEST} = \$internal ;\n      if ( isa( \$self->{DEST}, 'CODE' ) ) {\n         ## Put a filter on the end of the filter chain to pass the\n         ## output on to the CODE ref.  For SCALAR refs, the last\n         ## filter in the chain writes directly to the scalar itself.  See\n         ## _init_filters().  For CODE refs, however, we need to adapt from\n         ## the SCALAR to calling the CODE.\n         unshift( \n            \@{\$self->{FILTERS}},\n            sub {\n               my ( \$in_ref ) = \@_ ;\n\n               return IPC::Run::input_avail() && do {\n        \x09  \$self->{DEST}->( \$\$in_ref ) ;\n        \x09  \$\$in_ref = '' ;\n        \x09  1 ;\n               }\n            }\n         ) ;\n      }\n   }\n   else {\n      croak "'\$_' missing a source" if _empty \$internal ;\n      \$self->{SOURCE} = \$internal ;\n      if ( isa( \$internal, 'CODE' ) ) {\n         push(\n            \@{\$self->{FILTERS}},\n            sub {\n               my ( \$in_ref, \$out_ref ) = \@_ ;\n               return 0 if length \$\$out_ref ;\n\n               return undef\n        \x09  if \$self->{SOURCE_EMPTY} ;\n\n               my \$in = \$internal->() ;\n               unless ( defined \$in ) {\n        \x09  \$self->{SOURCE_EMPTY} = 1 ;\n        \x09  return undef \n               }\n               return 0 unless length \$in ;\n               \$\$out_ref = \$in ;\n\n               return 1 ;\n            }\n         ) ;\n      }\n      elsif ( isa( \$internal, 'SCALAR' ) ) {\n         push(\n            \@{\$self->{FILTERS}},\n            sub {\n               my ( \$in_ref, \$out_ref ) = \@_ ;\n               return 0 if length \$\$out_ref ;\n\n               ## pump() clears auto_close_ins, finish() sets it.\n               return \$self->{HARNESS}->{auto_close_ins} ? undef : 0\n        \x09  if IPC::Run::_empty \${\$self->{SOURCE}}\n        \x09     || \$self->{SOURCE_EMPTY} ;\n\n               \$\$out_ref = \$\$internal ;\n               eval { \$\$internal = '' }\n        \x09  if \$self->{HARNESS}->{clear_ins} ;\n\n               \$self->{SOURCE_EMPTY} = \$self->{HARNESS}->{auto_close_ins} ;\n\n               return 1 ;\n            }\n         ) ;\n      }\n   }\n\n   return \$self ;\n}\n\n\n=item filename\n\nGets/sets the filename.  Returns the value after the name change, if\nany.\n\n=cut\n\nsub filename {\n   my IPC::Run::IO \$self = shift ;\n   \$self->{FILENAME} = shift if \@_ ;\n   return \$self->{FILENAME} ;\n}\n\n\n=item init\n\nDoes initialization required before this can be run.  This includes open()ing\nthe file, if necessary, and clearing the destination scalar if necessary.\n\n=cut\n\nsub init {\n   my IPC::Run::IO \$self = shift ;\n\n   \$self->{SOURCE_EMPTY} = 0 ;\n   \${\$self->{DEST}} = ''\n      if \$self->mode =~ /r/ && ref \$self->{DEST} eq 'SCALAR' ;\n\n   \$self->open if defined \$self->filename ;\n   \$self->{FD} = \$self->fileno ;\n\n   if ( ! \$self->{FILTERS} ) {\n      \$self->{FBUFS} = undef ;\n   }\n   else {\n      \@{\$self->{FBUFS}} = map {\n         my \$s = "" ;\n         \\\$s ;\n      } ( \@{\$self->{FILTERS}}, '' ) ;\n\n      \$self->{FBUFS}->[0] = \$self->{DEST}\n         if \$self->{DEST} && ref \$self->{DEST} eq 'SCALAR' ;\n      push \@{\$self->{FBUFS}}, \$self->{SOURCE} ;\n   }\n\n   return undef ;\n}\n\n\n=item open\n\nIf a filename was passed in, opens it.  Determines if the handle is open\nvia fileno().  Throws an exception on error.\n\n=cut\n\nmy %open_flags = (\n   '>'  => O_RDONLY,\n   '>>' => O_RDONLY,\n   '<'  => O_WRONLY | O_CREAT | O_TRUNC,\n   '<<' => O_WRONLY | O_CREAT | O_APPEND,\n) ;\n\nsub open {\n   my IPC::Run::IO \$self = shift ;\n\n   croak "IPC::Run::IO: Can't open() a file with no name"\n      unless defined \$self->{FILENAME} ;\n   \$self->{HANDLE} = gensym unless \$self->{HANDLE} ;\n\n   _debug\n      "opening '", \$self->filename, "' mode '", \$self->mode, "'"\n   if _debugging_data ;\n   sysopen(\n      \$self->{HANDLE},\n      \$self->filename,\n      \$open_flags{\$self->op},\n   ) or croak\n         "IPC::Run::IO: \$! opening '\$self->{FILENAME}', mode '" . \$self->mode . "'" ;\n\n   return undef ;\n}\n\n\n=item open_pipe\n\nIf this is a redirection IO object, this opens the pipe in a platform\nindependant manner.\n\n=cut\n\nsub _do_open {\n   my \$self = shift;\n   my ( \$child_debug_fd, \$parent_handle ) = \@_ ;\n\n\n   if ( \$self->dir eq "<" ) {\n      ( \$self->{TFD}, \$self->{FD} ) = IPC::Run::_pipe_nb ;\n      if ( \$parent_handle ) {\n         CORE::open \$parent_handle, ">&=\$self->{FD}"\n            or croak "\$! duping write end of pipe for caller" ;\n      }\n   }\n   else {\n      ( \$self->{FD}, \$self->{TFD} ) = IPC::Run::_pipe ;\n      if ( \$parent_handle ) {\n         CORE::open \$parent_handle, "<&=\$self->{FD}"\n            or croak "\$! duping read end of pipe for caller" ;\n      }\n   }\n}\n\nsub open_pipe {\n   my IPC::Run::IO \$self = shift ;\n\n   ## Hmmm, Maybe allow named pipes one day.  But until then...\n   croak "IPC::Run::IO: Can't pipe() when a file name has been set"\n      if defined \$self->{FILENAME} ;\n\n   \$self->_do_open( \@_ );\n\n   ## return ( child_fd, parent_fd )\n   return \$self->dir eq "<"\n      ? ( \$self->{TFD}, \$self->{FD} )\n      : ( \$self->{FD}, \$self->{TFD} ) ;\n}\n\n\nsub _cleanup { ## Called from Run.pm's _cleanup\n   my \$self = shift;\n   undef \$self->{FAKE_PIPE};\n}\n\n\n=item close\n\nCloses the handle.  Throws an exception on failure.\n\n\n=cut\n\nsub close {\n   my IPC::Run::IO \$self = shift ;\n\n   if ( defined \$self->{HANDLE} ) {\n      close \$self->{HANDLE}\n         or croak(  "IPC::Run::IO: \$! closing "\n            . ( defined \$self->{FILENAME}\n               ? "'\$self->{FILENAME}'"\n               : "handle"\n            )\n         ) ;\n   }\n   else {\n      IPC::Run::_close( \$self->{FD} ) ;\n   }\n\n   \$self->{FD} = undef ;\n\n   return undef ;\n}\n\n=item fileno\n\nReturns the fileno of the handle.  Throws an exception on failure.\n\n\n=cut\n\nsub fileno {\n   my IPC::Run::IO \$self = shift ;\n\n   my \$fd = fileno \$self->{HANDLE} ;\n   croak(  "IPC::Run::IO: \$! "\n         . ( defined \$self->{FILENAME}\n            ? "'\$self->{FILENAME}'"\n            : "handle"\n         )\n      ) unless defined \$fd ;\n\n   return \$fd ;\n}\n\n=item mode\n\nReturns the operator in terms of 'r', 'w', and 'a'.  There is a state\n'ra', unlike Perl's open(), which indicates that data read from the\nhandle or file will be appended to the output if the output is a scalar.\nThis is only meaningful if the output is a scalar, it has no effect if\nthe output is a subroutine.\n\nThe redirection operators can be a little confusing, so here's a reference\ntable:\n\n   >      r      Read from handle in to process\n   <      w      Write from process out to handle\n   >>     ra     Read from handle in to process, appending it to existing\n                 data if the destination is a scalar.\n   <<     wa     Write from process out to handle, appending to existing\n                 data if IPC::Run::IO opened a named file.\n\n=cut\n\nsub mode {\n   my IPC::Run::IO \$self = shift ;\n\n   croak "IPC::Run::IO: unexpected arguments for mode(): \@_" if \@_ ;\n\n   ## TODO: Optimize this\n   return ( \$self->{TYPE} =~ /</     ? 'w' : 'r' ) . \n          ( \$self->{TYPE} =~ /<<|>>/ ? 'a' : ''  ) ;\n}\n\n\n=item op\n\nReturns the operation: '<', '>', '<<', '>>'.  See L</mode> if you want\nto spell these 'r', 'w', etc.\n\n=cut\n\nsub op {\n   my IPC::Run::IO \$self = shift ;\n\n   croak "IPC::Run::IO: unexpected arguments for op(): \@_" if \@_ ;\n\n   return \$self->{TYPE} ;\n}\n\n=item binmode\n\nSets/gets whether this pipe is in binmode or not.  No effect off of Win32\nOSs, of course, and on Win32, no effect after the harness is start()ed.\n\n=cut\n\nsub binmode {\n   my IPC::Run::IO \$self = shift ;\n\n   \$self->{BINMODE} = shift if \@_ ;\n\n   return \$self->{BINMODE} ;\n}\n\n\n=item dir\n\nReturns the first character of \$self->op.  This is either "<" or ">".\n\n=cut\n\nsub dir {\n   my IPC::Run::IO \$self = shift ;\n\n   croak "IPC::Run::IO: unexpected arguments for dir(): \@_" if \@_ ;\n\n   return substr \$self->{TYPE}, 0, 1 ;\n}\n\n\n##\n## Filter Scaffolding\n##\n#my \$filter_op  ;        ## The op running a filter chain right now\n#my \$filter_num ;        ## Which filter is being run right now.\n\nuse vars (\n'\$filter_op',        ## The op running a filter chain right now\n'\$filter_num'        ## Which filter is being run right now.\n) ;\n\nsub _init_filters {\n   my IPC::Run::IO \$self = shift ;\n\nconfess "\\\$self not an IPC::Run::IO" unless isa( \$self, "IPC::Run::IO" ) ;\n   \$self->{FBUFS} = [] ;\n\n   \$self->{FBUFS}->[0] = \$self->{DEST}\n      if \$self->{DEST} && ref \$self->{DEST} eq 'SCALAR' ;\n\n   return unless \$self->{FILTERS} && \@{\$self->{FILTERS}} ;\n\n   push \@{\$self->{FBUFS}}, map {\n      my \$s = "" ;\n      \\\$s ;\n   } ( \@{\$self->{FILTERS}}, '' ) ;\n\n   push \@{\$self->{FBUFS}}, \$self->{SOURCE} ;\n}\n\n\nsub poll {\n   my IPC::Run::IO \$self = shift;\n   my ( \$harness ) = \@_;\n\n   if ( defined \$self->{FD} ) {\n      my \$d = \$self->dir;\n      if ( \$d eq "<" ) {\n         if ( vec \$harness->{WOUT}, \$self->{FD}, 1 ) {\n            _debug_desc_fd( "filtering data to", \$self )\n               if _debugging_details ;\n            return \$self->_do_filters( \$harness );\n         }\n      }\n      elsif ( \$d eq ">" ) {\n         if ( vec \$harness->{ROUT}, \$self->{FD}, 1 ) {\n            _debug_desc_fd( "filtering data from", \$self )\n               if _debugging_details ;\n            return \$self->_do_filters( \$harness );\n         }\n      }\n   }\n   return 0;\n}\n\n\nsub _do_filters {\n   my IPC::Run::IO \$self = shift ;\n\n   ( \$self->{HARNESS} ) = \@_ ;\n\n   my ( \$saved_op, \$saved_num ) =(\$IPC::Run::filter_op,\$IPC::Run::filter_num) ;\n   \$IPC::Run::filter_op = \$self ;\n   \$IPC::Run::filter_num = -1 ;\n   my \$r = eval { IPC::Run::get_more_input() ; } ;\n   ( \$IPC::Run::filter_op, \$IPC::Run::filter_num ) = ( \$saved_op, \$saved_num ) ;\n   \$self->{HARNESS} = undef ;\n   die \$\@ if \$\@ ;\n   return \$r ;\n}\n\n1 ;\n
END_OF_FILE_AAAAAAAAAADO
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADP, "lib/IPC/Run/Win32IO.pm" }
package IPC::Run::Win32IO;\n\n=head1 NAME\n\nIPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms.\n\n=head1 SYNOPSIS\n\nuse IPC::Run::Win32IO;   # Exports all by default\n\n=head1 DESCRIPTION\n\nIPC::Run needs to use sockets to redirect subprocess I/O so that the select()\nloop will work on Win32. This seems to only work on WinNT and Win2K at this\ntime, not sure if it will ever work on Win95 or Win98. If you have experience\nin this area, please contact me at barries\@slaysys.com, thanks!.\n\n=cut\n\n=head1 DESCRIPTION\n\nA specialized IO class used on Win32.\n\n=cut\n\nuse strict ;\nuse Carp ;\nuse IO::Handle ;\nuse Socket ;\nrequire POSIX ;\n\n## Work around missing prototypes in old Socket.pm versions\nsub Socket::IPPROTO_TCP() ;\nsub Socket::TCP_NODELAY() ;\n\nuse Socket qw( IPPROTO_TCP TCP_NODELAY ) ;\nuse Symbol ;\nuse Text::ParseWords ;\nuse Win32::Process ;\nuse IPC::Run::Debug qw( :default _debugging_level );\nuse IPC::Run::Win32Helper qw( _inherit _dont_inherit );\nuse Fcntl qw( O_TEXT O_RDONLY );\n\nuse base qw( IPC::Run::IO );\nmy \@cleanup_fields;\nBEGIN {\n   ## These fields will be set to undef in _cleanup to close\n   ## the handles.\n   \@cleanup_fields = (\n      'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()\n      'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()\n      'TEMP_FILE_NAME',         ## The name of the temp file, needed for\n                                ## error reporting / debugging only.\n\n      'PARENT_HANDLE',       ## The handle of the socket for the parent\n      'PUMP_SOCKET_HANDLE',  ## The socket handle for the pump\n      'PUMP_PIPE_HANDLE',    ## The anon pipe handle for the pump\n      'CHILD_HANDLE',        ## The anon pipe handle for the child\n\n      'TEMP_FILE_HANDLE',    ## The Win32 filehandle for the temp file\n   );\n}\n\nuse fields (\n   \@cleanup_fields\n);\n\n\n## REMOVE OSFHandleOpen\nuse Win32API::File qw(\n   GetOsFHandle\n   OsFHandleOpenFd\n   OsFHandleOpen\n   FdGetOsFHandle\n   SetHandleInformation\n   SetFilePointer\n   HANDLE_FLAG_INHERIT\n   INVALID_HANDLE_VALUE\n\n   createFile\n   WriteFile\n   ReadFile\n   CloseHandle\n\n   FILE_ATTRIBUTE_TEMPORARY\n   FILE_FLAG_DELETE_ON_CLOSE\n   FILE_FLAG_WRITE_THROUGH\n\n   FILE_BEGIN\n) ;\n\n#   FILE_ATTRIBUTE_HIDDEN\n#   FILE_ATTRIBUTE_SYSTEM\n\n\nBEGIN {\n   ## Force AUTOLOADED constants to be, well, constant by getting them\n   ## to AUTOLOAD before compilation continues.  Sigh.\n   () = (\n      SOL_SOCKET,\n      SO_REUSEADDR,\n      IPPROTO_TCP,\n      TCP_NODELAY,\n      HANDLE_FLAG_INHERIT,\n      INVALID_HANDLE_VALUE,\n   );\n}\n\n\nuse constant temp_file_flags => (\n   FILE_ATTRIBUTE_TEMPORARY()   |\n   FILE_FLAG_DELETE_ON_CLOSE()  |\n   FILE_FLAG_WRITE_THROUGH()\n);\n\n#   FILE_ATTRIBUTE_HIDDEN()    |\n#   FILE_ATTRIBUTE_SYSTEM()    |\nmy \$tmp_file_counter;\nmy \$tmp_dir;\n\nsub _cleanup {\n    my IPC::Run::Win32IO \$self = shift;\n    my ( \$harness ) = \@_;\n\n    \$self->_recv_through_temp_file( \$harness )\n       if \$self->{RECV_THROUGH_TEMP_FILE};\n\n    CloseHandle( \$self->{TEMP_FILE_HANDLE} )\n       if defined \$self->{TEMP_FILE_HANDLE};\n\n    \$self->{\$_} = undef for \@cleanup_fields;\n}\n\n\nsub _create_temp_file {\n   my IPC::Run::Win32IO \$self = shift;\n\n   ## Create a hidden temp file that Win32 will delete when we close\n   ## it.\n   unless ( defined \$tmp_dir ) {\n      \$tmp_dir = File::Spec->catdir(\n         File::Spec->tmpdir, "IPC-Run.tmp"\n      );\n\n      ## Trust in the user's umask.\n      ## This could possibly be a security hole, perhaps\n      ## we should offer an option.  Hmmmm, really, people coding\n      ## security conscious apps should audit this code and\n      ## tell me how to make it better.  Nice cop-out :).\n      unless ( -d \$tmp_dir ) {\n         mkdir \$tmp_dir or croak "\$!: \$tmp_dir";\n      }\n   }\n\n   \$self->{TEMP_FILE_NAME} = File::Spec->catfile(\n      ## File name is designed for easy sorting and not conflicting\n      ## with other processes.  This should allow us to use "t"runcate\n      ## access in CreateFile in case something left some droppings\n      ## around (which should never happen because we specify\n      ## FLAG_DELETE_ON_CLOSE.\n      ## heh, belt and suspenders are better than bug reports; God forbid\n      ## that NT should ever crash before a temp file gets deleted!\n      \$tmp_dir, sprintf "Win32io-%06d-%08d", \$\$, \$tmp_file_counter++\n   );\n\n   \$self->{TEMP_FILE_HANDLE} = createFile(\n      \$self->{TEMP_FILE_NAME},\n      "trw",         ## new, truncate, read, write\n      {\n         Flags      => temp_file_flags,\n      },\n   ) or croak "Can't create temporary file, \$self->{TEMP_FILE_NAME}: \$^E";\n\n   \$self->{TFD} = OsFHandleOpenFd \$self->{TEMP_FILE_HANDLE}, 0;\n   \$self->{FD} = undef;\n\n   _debug\n      "Win32 Optimizer: temp file (",\n      \$self->{KFD},\n      \$self->{TYPE},\n      \$self->{TFD},\n      ", fh ",\n      \$self->{TEMP_FILE_HANDLE},\n      "): ",\n      \$self->{TEMP_FILE_NAME}\n      if _debugging_details;\n}\n\n\nsub _reset_temp_file_pointer {\n   my \$self = shift;\n   SetFilePointer( \$self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN )\n      or confess "\$^E seeking on (fd \$self->{TFD}) \$self->{TEMP_FILE_NAME} for kid's fd \$self->{KFD}";\n}\n\n\nsub _send_through_temp_file {\n   my IPC::Run::Win32IO \$self = shift;\n\n   _debug\n      "Win32 optimizer: optimizing "\n      . " \$self->{KFD} \$self->{TYPE} temp file instead of ",\n         ref \$self->{SOURCE} || \$self->{SOURCE}\n      if _debugging_details;\n\n   \$self->_create_temp_file;\n\n   if ( defined \${\$self->{SOURCE}} ) {\n      my \$bytes_written = 0;\n      my \$data_ref;\n      if ( \$self->binmode ) {\n\x09 \$data_ref = \$self->{SOURCE};\n      }\n      else {\n         my \$data = \${\$self->{SOURCE}};  # Ugh, a copy.\n\x09 \$data =~ s/(?<!\\r)\\n/\\r\\n/g;\n\x09 \$data_ref = \\\$data;\n      }\n\n      WriteFile(\n         \$self->{TEMP_FILE_HANDLE},\n         \$\$data_ref,\n         0,              ## Write entire buffer\n         \$bytes_written,\n         [],             ## Not overlapped.\n      ) or croak\n         "\$^E writing \$self->{TEMP_FILE_NAME} for kid to read on fd \$self->{KFD}";\n      _debug\n         "Win32 optimizer: wrote \$bytes_written to temp file \$self->{TEMP_FILE_NAME}"\n         if _debugging_data;\n\n      \$self->_reset_temp_file_pointer;\n\n   }\n\n\n   _debug "Win32 optimizer: kid to read \$self->{KFD} from temp file on \$self->{TFD}"\n      if _debugging_details;\n}\n\n\nsub _init_recv_through_temp_file {\n   my IPC::Run::Win32IO \$self = shift;\n\n   \$self->_create_temp_file;\n}\n\n\n## TODO: USe the Win32 API in the select loop to see if the file has grown\n## and read it incrementally if it has.\nsub _recv_through_temp_file {\n   my IPC::Run::Win32IO \$self = shift;\n\n   ## This next line kicks in if the run() never got to initting things\n   ## and needs to clean up.\n   return undef unless defined \$self->{TEMP_FILE_HANDLE};\n\n   push \@{\$self->{FILTERS}}, sub {\n      my ( undef, \$out_ref ) = \@_;\n\n      return undef unless defined \$self->{TEMP_FILE_HANDLE};\n\n      my \$r;\n      my \$s;\n      ReadFile(\n\x09 \$self->{TEMP_FILE_HANDLE},\n\x09 \$s,\n\x09 999_999,  ## Hmmm, should read the size.\n\x09 \$r,\n\x09 []\n      ) or croak "\$^E reading from \$self->{TEMP_FILE_NAME}";\n\n      _debug "ReadFile( \$self->{TFD} ) = \$r chars '\$s'" if _debugging_data ;\n\n      return undef unless \$r;\n\n      \$s =~ s/\\r\\n/\\n/g unless \$self->binmode;\n\n      my \$pos = pos \$\$out_ref;\n      \$\$out_ref .= \$s;\n      pos( \$out_ref ) = \$pos;\n      return 1;\n   };\n\n   my ( \$harness ) = \@_;\n\n   \$self->_reset_temp_file_pointer;\n\n   1 while \$self->_do_filters( \$harness );\n\n   pop \@{\$self->{FILTERS}};\n\n   IPC::Run::_close( \$self->{TFD} );\n}\n\n\nsub poll {\n   my IPC::Run::Win32IO \$self = shift;\n\n   return if \$self->{SEND_THROUGH_TEMP_FILE} || \$self->{RECV_THROUGH_TEMP_FILE};\n\n   return \$self->SUPER::poll( \@_ );\n}\n\n\n## When threaded Perls get good enough, we should use threads here.\n## The problem with threaded perls is that they dup() all sorts of\n## filehandles and fds and don't allow sufficient control over\n## closing off the ones we don't want.\n\nsub _spawn_pumper {\n   my ( \$stdin, \$stdout, \$debug_fd, \$child_label, \@opts ) = \@_ ;\n   my ( \$stdin_fd, \$stdout_fd ) = ( fileno \$stdin, fileno \$stdout ) ;\n\n   _debug "pumper stdin = ", \$stdin_fd if _debugging_details;\n   _debug "pumper stdout = ", \$stdout_fd if _debugging_details;\n   _inherit \$stdin_fd, \$stdout_fd, \$debug_fd ;\n   my \@I_options = map qq{"-I\$_"}, \@INC;\n\n   my \$cmd_line = join( " ",\n      qq{"\$^X"},\n      \@I_options,\n      qw(-MIPC::Run::Win32Pump -e 1 ),\n## I'm using this clunky way of passing filehandles to the child process\n## in order to avoid some kind of premature closure of filehandles\n## problem I was having with VCP's test suite when passing them\n## via CreateProcess.  All of the ## REMOVE code is stuff I'd like\n## to be rid of and the ## ADD code is what I'd like to use.\n      FdGetOsFHandle( \$stdin_fd ), ## REMOVE\n      FdGetOsFHandle( \$stdout_fd ), ## REMOVE\n      FdGetOsFHandle( \$debug_fd ), ## REMOVE\n      \$\$, \$^T, _debugging_level, qq{"\$child_label"},\n      \@opts\n   ) ;\n\n#   open SAVEIN,  "<&STDIN"  or croak "\$! saving STDIN" ;       #### ADD\n#   open SAVEOUT, ">&STDOUT" or croak "\$! saving STDOUT" ;       #### ADD\n#   open SAVEERR, ">&STDERR" or croak "\$! saving STDERR" ;       #### ADD\n#   _dont_inherit \\*SAVEIN ;       #### ADD\n#   _dont_inherit \\*SAVEOUT ;       #### ADD\n#   _dont_inherit \\*SAVEERR ;       #### ADD\n#   open STDIN,  "<&\$stdin_fd"  or croak "\$! dup2()ing \$stdin_fd (pumper's STDIN)" ;       #### ADD\n#   open STDOUT, ">&\$stdout_fd" or croak "\$! dup2()ing \$stdout_fd (pumper's STDOUT)" ;       #### ADD\n#   open STDERR, ">&\$debug_fd" or croak "\$! dup2()ing \$debug_fd (pumper's STDERR/debug_fd)" ;       #### ADD\n\n   _debug "pump cmd line: ", \$cmd_line if _debugging_details;\n\n   my \$process ;\n   Win32::Process::Create( \n      \$process,\n      \$^X,\n      \$cmd_line,\n      1,  ## Inherit handles\n      NORMAL_PRIORITY_CLASS,\n      ".",\n   ) or croak "\$!: Win32::Process::Create()" ;\n\n#   open STDIN,  "<&SAVEIN"  or croak "\$! restoring STDIN" ;       #### ADD\n#   open STDOUT, ">&SAVEOUT" or croak "\$! restoring STDOUT" ;       #### ADD\n#   open STDERR, ">&SAVEERR" or croak "\$! restoring STDERR" ;       #### ADD\n#   close SAVEIN             or croak "\$! closing SAVEIN" ;       #### ADD\n#   close SAVEOUT            or croak "\$! closing SAVEOUT" ;       #### ADD\n#   close SAVEERR            or croak "\$! closing SAVEERR" ;       #### ADD\n\n   close \$stdin  or croak "\$! closing pumper's stdin in parent" ;\n   close \$stdout or croak "\$! closing pumper's stdout in parent" ;\n   # Don't close \$debug_fd, we need it, as do other pumpers.\n\n   # Pause a moment to allow the child to get up and running and emit\n   # debug messages.  This does not always work.\n   #   select undef, undef, undef, 1 if _debugging_details ;\n\n   _debug "_spawn_pumper pid = ", \$process->GetProcessID \n      if _debugging_data;\n}\n\n\nmy \$next_port = 2048 ;\nmy \$loopback  = inet_aton "127.0.0.1" ;\nmy \$tcp_proto = getprotobyname('tcp');\ncroak "\$!: getprotobyname('tcp')" unless defined \$tcp_proto ;\n\nsub _socket {\n   my ( \$server ) = \@_ ;\n   \$server ||= gensym ;\n   my \$client = gensym ;\n\n   my \$listener = gensym ;\n   socket \$listener, PF_INET, SOCK_STREAM, \$tcp_proto\n      or croak "\$!: socket()";\n   setsockopt \$listener, SOL_SOCKET, SO_REUSEADDR, pack("l", 0)\n      or croak "\$!: setsockopt()";\n\n   my \$port ;\n   my \@errors ;\nPORT_FINDER_LOOP:\n   {\n      \$port = \$next_port ;\n      \$next_port = 2048 if ++\$next_port > 65_535 ; \n      unless ( bind \$listener, sockaddr_in( \$port, INADDR_ANY ) ) {\n\x09 push \@errors, "\$! on port \$port" ;\n\x09 croak join "\\n", \@errors if \@errors > 10 ;\n         goto PORT_FINDER_LOOP;\n      }\n   }\n\n   _debug "win32 port = \$port" if _debugging_details;\n\n   listen \$listener, my \$queue_size = 1\n      or croak "\$!: listen()" ;\n\n   {\n      socket \$client, PF_INET, SOCK_STREAM, \$tcp_proto\n         or croak "\$!: socket()";\n\n      my \$paddr = sockaddr_in(\$port, \$loopback );\n\n      connect \$client, \$paddr\n         or croak "\$!: connect()" ;\n    \n      croak "\$!: accept" unless defined \$paddr ;\n\n      ## The windows "default" is SO_DONTLINGER, which should make\n      ## sure all socket data goes through.  I have my doubts based\n      ## on experimentation, but nothing prompts me to set SO_LINGER\n      ## at this time...\n      setsockopt \$client, IPPROTO_TCP, TCP_NODELAY, pack("l", 0)\n\x09 or croak "\$!: setsockopt()";\n   }\n\n   {\n      _debug "accept()ing on port \$port" if _debugging_details;\n      my \$paddr = accept( \$server, \$listener ) ;\n      croak "\$!: accept()" unless defined \$paddr ;\n   }\n\n   _debug\n      "win32 _socket = ( ", fileno \$server, ", ", fileno \$client, " ) on port \$port" \n      if _debugging_details;\n   return ( \$server, \$client ) ;\n}\n\n\nsub _open_socket_pipe {\n   my IPC::Run::Win32IO \$self = shift;\n   my ( \$debug_fd, \$parent_handle ) = \@_ ;\n\n   my \$is_send_to_child = \$self->dir eq "<";\n\n   \$self->{CHILD_HANDLE}     = gensym;\n   \$self->{PUMP_PIPE_HANDLE} = gensym;\n\n   ( \n      \$self->{PARENT_HANDLE},\n      \$self->{PUMP_SOCKET_HANDLE}\n   ) = _socket \$parent_handle ;\n\n   binmode \$self->{PARENT_HANDLE}, \$self->binmode ? ":raw" : ":crlf" or die \$!;\n   binmode \$self->{PUMP_SOCKET_HANDLE} or die \$!;\n\n_debug "PUMP_SOCKET_HANDLE = ", fileno \$self->{PUMP_SOCKET_HANDLE}\n   if _debugging_details;\n##my \$buf ;\n##\$buf = "write on child end of " . fileno( \$self->{WRITE_HANDLE} ) . "\\n\\n\\n\\n\\n" ;\n##POSIX::write(fileno \$self->{WRITE_HANDLE}, \$buf, length \$buf) or warn "\$! in syswrite" ;\n##\$buf = "write on parent end of " . fileno( \$self->{CHILD_HANDLE} ) . "\\r\\n" ;\n##POSIX::write(fileno \$self->{CHILD_HANDLE},\$buf, length \$buf) or warn "\$! in syswrite" ;\n##   \$self->{CHILD_HANDLE}->autoflush( 1 ) ;\n##   \$self->{WRITE_HANDLE}->autoflush( 1 ) ;\n\n   ## Now fork off a data pump and arrange to return the correct fds.\n   if ( \$is_send_to_child ) {\n      pipe \$self->{CHILD_HANDLE}, \$self->{PUMP_PIPE_HANDLE}\n         or croak "\$! opening child pipe" ;\n_debug "CHILD_HANDLE = ", fileno \$self->{CHILD_HANDLE}\n   if _debugging_details;\n_debug "PUMP_PIPE_HANDLE = ", fileno \$self->{PUMP_PIPE_HANDLE}\n   if _debugging_details;\n   }\n   else {\n      pipe \$self->{PUMP_PIPE_HANDLE}, \$self->{CHILD_HANDLE}\n         or croak "\$! opening child pipe" ;\n_debug "CHILD_HANDLE = ", fileno \$self->{CHILD_HANDLE}\n   if _debugging_details;\n_debug "PUMP_PIPE_HANDLE = ", fileno \$self->{PUMP_PIPE_HANDLE}\n   if _debugging_details;\n   }\n\n   ## No child should ever see this.\n   _dont_inherit \$self->{PARENT_HANDLE} ;\n\n   ## We clear the inherit flag so these file descriptors are not inherited.\n   ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is\n   ## called and *that* fd will be inheritable.\n   _dont_inherit \$self->{PUMP_SOCKET_HANDLE} ;\n   _dont_inherit \$self->{PUMP_PIPE_HANDLE} ;\n   _dont_inherit \$self->{CHILD_HANDLE} ;\n\n   ## Need to return \$self so the HANDLEs don't get freed.\n   ## Return \$self, \$parent_fd, \$child_fd\n   my ( \$parent_fd, \$child_fd ) = (\n      fileno \$self->{PARENT_HANDLE},\n      fileno \$self->{CHILD_HANDLE}\n   ) ;\n\n   ## Both PUMP_..._HANDLEs will be closed, no need to worry about\n   ## inheritance.\n   _debug "binmode on" if _debugging_data && \$self->binmode;\n   _spawn_pumper(\n      \$is_send_to_child\n\x09 ? ( \$self->{PUMP_SOCKET_HANDLE}, \$self->{PUMP_PIPE_HANDLE} )\n\x09 : ( \$self->{PUMP_PIPE_HANDLE}, \$self->{PUMP_SOCKET_HANDLE} ),\n      \$debug_fd,\n      \$child_fd . \$self->dir . "pump" . \$self->dir . \$parent_fd,\n   ) ;\n\n{\nmy \$foo ;\nconfess "PARENT_HANDLE no longer open"\n   unless POSIX::read( \$parent_fd, \$foo, 0 ) ;\n}\n\n   _debug "win32_fake_pipe = ( \$parent_fd, \$child_fd )"\n      if _debugging_details;\n\n   \$self->{FD}  = \$parent_fd;\n   \$self->{TFD} = \$child_fd;\n}\n\nsub _do_open {\n   my IPC::Run::Win32IO \$self = shift;\n\n   if ( \$self->{SEND_THROUGH_TEMP_FILE} ) {\n      return \$self->_send_through_temp_file( \@_ );\n   }\n   elsif ( \$self->{RECV_THROUGH_TEMP_FILE} ) {\n      return \$self->_init_recv_through_temp_file( \@_ );\n   }\n   else {\n      return \$self->_open_socket_pipe( \@_ );\n   }\n}\n\n=head1 AUTHOR\n\nBarries Slaymaker <barries\@slaysys.com>.  Funded by Perforce Software, Inc.\n\n=head1 COPYRIGHT\n\nCopyright 2001, Barrie Slaymaker, All Rights Reserved.\n\nYou may use this under the terms of either the GPL 2.0 ir the Artistic License.\n\n=cut\n\n1;\n
END_OF_FILE_AAAAAAAAAADP
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADQ, "lib/IPC/Run/Debug.pm" }
package IPC::Run::Debug;\n\n=head1 NAME\n\nIPC::Run::Debug - debugging routines for IPC::Run\n\n=head1 SYNOPSIS\n\n   ##\n   ## Environment variable usage\n   ##\n   ## To force debugging off and shave a bit of CPU and memory\n   ## by compile-time optimizing away all debugging code in IPC::Run\n   ## (debug => ...) options to IPC::Run will be ignored.\n   export IPCRUNDEBUG=none\n\n   ## To force debugging on (levels are from 0..10)\n   export IPCRUNDEBUG=basic\n\n   ## Leave unset or set to "" to compile in debugging support and\n   ## allow runtime control of it using the debug option.\n\n=head1 DESCRIPTION\n\nControls IPC::Run debugging.  Debugging levels are now set by using words,\nbut the numbers shown are still supported for backwards compatability:\n\n   0  none         disabled (special, see below)\n   1  basic        what's running\n   2  data         what's being sent/recieved\n   3  details      what's going on in more detail\n   4  gory         way too much detail for most uses\n   10 all          use this when submitting bug reports\n      noopts       optimizations forbidden due to inherited STDIN\n\nThe C<none> level is special when the environment variable IPCRUNDEBUG\nis set to this the first time IPC::Run::Debug is loaded: it prevents\nthe debugging code from being compiled in to the remaining IPC::Run modules,\nsaving a bit of cpu.\n\nTo do this in a script, here's a way that allows it to be overridden:\n\n   BEGIN {\n      unless ( defined \$ENV{IPCRUNDEBUG} ) {\n\x09 eval 'local \$ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'\n\x09    or die \$\@;\n      }\n   }\n\nThis should force IPC::Run to not be debuggable unless somebody sets\nthe IPCRUNDEBUG flag; modify this formula to grep \@ARGV if need be:\n\n   BEGIN {\n      unless ( grep /^--debug/, \@ARGV ) {\n\x09 eval 'local \$ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"'\n\x09 or die \$\@;\n   }\n\nBoth of those are untested.\n\n=cut\n\n\@ISA = qw( Exporter ) ;\n\n## We use \@EXPORT for the end user's convenience: there's only one function\n## exported, it's homonymous with the module, it's an unusual name, and\n## it can be suppressed by "use IPC::Run () ;".\n\n\@EXPORT = qw(\n   _debug\n   _debug_desc_fd\n   _debugging\n   _debugging_data\n   _debugging_details\n   _debugging_gory_details\n   _debugging_not_optimized\n   _set_child_debug_name\n);\n\n\n\@EXPORT_OK = qw(\n   _debug_init\n   _debugging_level\n   _map_fds\n);\n\n%EXPORT_TAGS = (\n   default => \\\@EXPORT,\n   all     => [ \@EXPORT, \@EXPORT_OK ],\n);\n\nuse strict ;\nuse Exporter ;\n\nmy \$disable_debugging =\n   defined \$ENV{IPCRUNDEBUG}\n   && (\n      ! \$ENV{IPCRUNDEBUG}\n      || lc \$ENV{IPCRUNDEBUG} eq "none"\n   );\n\neval( \$disable_debugging ? <<'STUBS' : <<'SUBS' ) or die \$\@;\nsub _map_fds()                 { "" }\nsub _debug                     {}\nsub _debug_desc_fd             {}\nsub _debug_init                {}\nsub _set_child_debug_name      {}\nsub _debugging()               { 0 }\nsub _debugging_level()         { 0 }\nsub _debugging_data()          { 0 }\nsub _debugging_details()       { 0 }\nsub _debugging_gory_details()  { 0 }\nsub _debugging_not_optimized() { 0 }\n\n1;\nSTUBS\n\nuse POSIX;\nuse UNIVERSAL qw( isa );\n\nsub _map_fds {\n   my \$map = '' ;\n   my \$digit = 0 ;\n   my \$in_use ;\n   my \$dummy ;\n   for my \$fd (0..63) {\n      ## I'd like a quicker way (less user, cpu & expecially sys and kernal\n      ## calls) to detect open file descriptors.  Let me know...\n      ## Hmmm, could do a 0 length read and check for bad file descriptor...\n      ## but that segfaults on Win32\n      my \$test_fd = POSIX::dup( \$fd ) ;\n      \$in_use = defined \$test_fd ;\n      POSIX::close \$test_fd if \$in_use ;\n      \$map .= \$in_use ? \$digit : '-';\n      \$digit = 0 if ++\$digit > 9 ;\n   }\n   warn "No fds open???" unless \$map =~ /\\d/ ;\n   \$map =~ s/(.{1,12})-*\$/\$1/ ;\n   return \$map ;\n}\n\nuse vars qw( \$parent_pid ) ;\n\n\$parent_pid = \$\$ ;\n\n## TODO: move debugging to it's own module and make it compile-time\n## optimizable.\n\n## Give kid process debugging nice names\nmy \$debug_name ;\n\nsub _set_child_debug_name {\n   \$debug_name = shift;\n}\n\n## There's a bit of hackery going on here.\n##\n## We want to have any code anywhere be able to emit\n## debugging statements without knowing what harness the code is\n## being called in/from, since we'd need to pass a harness around to\n## everything.\n##\n## Thus, \$cur_self was born.\n#\nmy %debug_levels = (\n   none    => 0,\n   basic   => 1,\n   data    => 2,\n   details => 3,\n   gore           => 4,\n   gory_details   => 4,\n   "gory details" => 4,\n   gory           => 4,\n   gorydetails    => 4,\n   all     => 10,\n   notopt  => 0,\n);\n\nmy \$warned;\n\nsub _debugging_level() {\n   my \$level = 0 ;\n\n   \$level = \$IPC::Run::cur_self->{debug} || 0\n      if \$IPC::Run::cur_self\n         && ( \$IPC::Run::cur_self->{debug} || 0 ) >= \$level ;\n\n   if ( defined \$ENV{IPCRUNDEBUG} ) {\n      my \$v = \$ENV{IPCRUNDEBUG};\n      \$v = \$debug_levels{lc \$v} if \$v =~ /[a-zA-Z]/;\n      unless ( defined \$v ) {\n\x09 \$warned ||= warn "Unknown debug level \$ENV{IPCRUNDEBUG}, assuming 'basic' (1)\\n";\n\x09 \$v = 1;\n      }\n      \$level = \$v if \$v > \$level ;\n   }\n   return \$level ;\n}\n\nsub _debugging_atleast(\$) {\n   my \$min_level = shift || 1 ;\n\n   my \$level = _debugging_level ;\n   \n   return \$level >= \$min_level ? \$level : 0 ;\n}\n\nsub _debugging()               { _debugging_atleast 1 }\nsub _debugging_data()          { _debugging_atleast 2 }\nsub _debugging_details()       { _debugging_atleast 3 }\nsub _debugging_gory_details()  { _debugging_atleast 4 }\nsub _debugging_not_optimized() { ( \$ENV{IPCRUNDEBUG} || "" ) eq "notopt" }\n\nsub _debug_init {\n   ## This routine is called only in spawned children to fake out the\n   ## debug routines so they'll emit debugging info.\n   \$IPC::Run::cur_self = {} ;\n   (  \$parent_pid,\n      \$^T, \n      \$IPC::Run::cur_self->{debug}, \n      \$IPC::Run::cur_self->{DEBUG_FD}, \n      \$debug_name \n   ) = \@_ ;\n}\n\n\nsub _debug {\n#   return unless _debugging || _debugging_not_optimized ;\n\n   my \$fd = defined &IPC::Run::_debug_fd\n      ? IPC::Run::_debug_fd()\n      : fileno STDERR;\n\n   my \$s ;\n   my \$debug_id ;\n   \$debug_id = join( \n      " ",\n      join(\n         "",\n         defined \$IPC::Run::cur_self ? "#\$IPC::Run::cur_self->{ID}" : (),\n         "(\$\$)",\n      ),\n      defined \$debug_name && length \$debug_name ? \$debug_name        : (),\n   ) ;\n   my \$prefix = join(\n      "",\n      "IPC::Run",\n      sprintf( " %04d", time - \$^T ),\n      ( _debugging_details ? ( " ", _map_fds ) : () ),\n      length \$debug_id ? ( " [", \$debug_id, "]" ) : (),\n      ": ",\n   ) ;\n\n   my \$msg = join( '', map defined \$_ ? \$_ : "<undef>", \@_ ) ;\n   chomp \$msg ;\n   \$msg =~ s{^}{\$prefix}gm ;\n   \$msg .= "\\n" ;\n   POSIX::write( \$fd, \$msg, length \$msg ) ;\n}\n\n\nmy \@fd_descs = ( 'stdin', 'stdout', 'stderr' ) ;\n\nsub _debug_desc_fd {\n   return unless _debugging ;\n   my \$text = shift ;\n   my \$op = pop ;\n   my \$kid = \$_[0] ;\n\nCarp::carp join " ", caller(0), \$text, \$op  if defined \$op  && isa( \$op, "IO::Pty" ) ;\n\n   _debug(\n      \$text,\n      ' ',\n      ( defined \$op->{FD}\n         ? \$op->{FD} < 3\n            ? ( \$fd_descs[\$op->{FD}] )\n            : ( 'fd ', \$op->{FD} )\n         : \$op->{FD}\n      ),\n      ( defined \$op->{KFD}\n         ? (\n            ' (kid',\n            ( defined \$kid ? ( ' ', \$kid->{NUM}, ) : () ),\n            "'s ",\n            ( \$op->{KFD} < 3\n               ? \$fd_descs[\$op->{KFD}]\n               : defined \$kid\n                  && defined \$kid->{DEBUG_FD}\n                  && \$op->{KFD} == \$kid->{DEBUG_FD}\n                  ? ( 'debug (', \$op->{KFD}, ')' )\n                  : ( 'fd ', \$op->{KFD} )\n            ),\n            ')',\n         )\n         : ()\n      ),\n   ) ;\n}\n\n1;\n\nSUBS\n\n=head1 AUTHOR\n\nBarrie Slaymaker <barries\@slaysys.com>, with numerous suggestions by p5p.\n\n=cut\n\n1 ;\n
END_OF_FILE_AAAAAAAAAADQ
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
BEGIN { _spew <<END_OF_FILE_AAAAAAAAAADR, "lib/File/Temp.pm" }
package File::Temp;\n\n=head1 NAME\n\nFile::Temp - return name and handle of a temporary file safely\n\n=begin __INTERNALS\n\n=head1 PORTABILITY\n\nThis module is designed to be portable across operating systems\nand it currently supports Unix, VMS, DOS, OS/2 and Windows. When\nporting to a new OS there are generally three main issues\nthat have to be solved:\n\n=over 4\n\n=item *\n\nCan the OS unlink an open file? If it can not then the\nC<_can_unlink_opened_file> method should be modified.\n\n=item *\n\nAre the return values from C<stat> reliable? By default all the\nreturn values from C<stat> are compared when unlinking a temporary\nfile using the filename and the handle. Operating systems other than\nunix do not always have valid entries in all fields. If C<unlink0> fails\nthen the C<stat> comparison should be modified accordingly.\n\n=item *\n\nSecurity. Systems that can not support a test for the sticky bit\non a directory can not use the MEDIUM and HIGH security tests.\nThe C<_can_do_level> method should be modified accordingly.\n\n=back\n\n=end __INTERNALS\n\n=head1 SYNOPSIS\n\n  use File::Temp qw/ tempfile tempdir /; \n\n  \$dir = tempdir( CLEANUP => 1 );\n  (\$fh, \$filename) = tempfile( DIR => \$dir );\n\n  (\$fh, \$filename) = tempfile( \$template, DIR => \$dir);\n  (\$fh, \$filename) = tempfile( \$template, SUFFIX => '.dat');\n\n  \$fh = tempfile();\n\nMkTemp family:\n\n  use File::Temp qw/ :mktemp  /;\n\n  (\$fh, \$file) = mkstemp( "tmpfileXXXXX" );\n  (\$fh, \$file) = mkstemps( "tmpfileXXXXXX", \$suffix);\n\n  \$tmpdir = mkdtemp( \$template );\n\n  \$unopened_file = mktemp( \$template );\n\nPOSIX functions:\n\n  use File::Temp qw/ :POSIX /;\n\n  \$file = tmpnam();\n  \$fh = tmpfile();\n\n  (\$fh, \$file) = tmpnam();\n  (\$fh, \$file) = tmpfile();\n\n\nCompatibility functions:\n\n  \$unopened_file = File::Temp::tempnam( \$dir, \$pfx );\n\n=begin later\n\nObjects (NOT YET IMPLEMENTED):\n\n  require File::Temp;\n\n  \$fh = new File::Temp(\$template);\n  \$fname = \$fh->filename;\n\n=end later\n\n=head1 DESCRIPTION\n\nC<File::Temp> can be used to create and open temporary files in a safe way.\nThe tempfile() function can be used to return the name and the open\nfilehandle of a temporary file.  The tempdir() function can \nbe used to create a temporary directory.\n\nThe security aspect of temporary file creation is emphasized such that\na filehandle and filename are returned together.  This helps guarantee\nthat a race condition can not occur where the temporary file is\ncreated by another process between checking for the existence of the\nfile and its opening.  Additional security levels are provided to\ncheck, for example, that the sticky bit is set on world writable\ndirectories.  See L<"safe_level"> for more information.\n\nFor compatibility with popular C library functions, Perl implementations of\nthe mkstemp() family of functions are provided. These are, mkstemp(),\nmkstemps(), mkdtemp() and mktemp().\n\nAdditionally, implementations of the standard L<POSIX|POSIX>\ntmpnam() and tmpfile() functions are provided if required.\n\nImplementations of mktemp(), tmpnam(), and tempnam() are provided,\nbut should be used with caution since they return only a filename\nthat was valid when function was called, so cannot guarantee\nthat the file will not exist by the time the caller opens the filename.\n\n=cut\n\n# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls\n# People would like a version on 5.005 so give them what they want :-)\nuse 5.005;\nuse strict;\nuse Carp;\nuse File::Spec 0.8;\nuse File::Path qw/ rmtree /;\nuse Fcntl 1.03;\nuse Errno;\nrequire VMS::Stdio if \$^O eq 'VMS';\n\n# Need the Symbol package if we are running older perl\nrequire Symbol if \$] < 5.006;\n\n\n# use 'our' on v5.6.0\nuse vars qw(\$VERSION \@EXPORT_OK %EXPORT_TAGS \$DEBUG);\n\n\$DEBUG = 0;\n\n# We are exporting functions\n\nuse base qw/Exporter/;\n\n# Export list - to allow fine tuning of export table\n\n\@EXPORT_OK = qw{\n\x09      tempfile\n\x09      tempdir\n\x09      tmpnam\n\x09      tmpfile\n\x09      mktemp\n\x09      mkstemp\n\x09      mkstemps\n\x09      mkdtemp\n\x09      unlink0\n\x09\x09};\n\n# Groups of functions for export\n\n%EXPORT_TAGS = (\n\x09\x09'POSIX' => [qw/ tmpnam tmpfile /],\n\x09\x09'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],\n\x09       );\n\n# add contents of these tags to \@EXPORT\nExporter::export_tags('POSIX','mktemp');\n\n# Version number \n\n\$VERSION = '0.12';\n\n# This is a list of characters that can be used in random filenames\n\nmy \@CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z\n\x09         a b c d e f g h i j k l m n o p q r s t u v w x y z\n\x09         0 1 2 3 4 5 6 7 8 9 _\n\x09     /);\n\n# Maximum number of tries to make a temp file before failing\n\nuse constant MAX_TRIES => 10;\n\n# Minimum number of X characters that should be in a template\nuse constant MINX => 4;\n\n# Default template when no template supplied\n\nuse constant TEMPXXX => 'X' x 10;\n\n# Constants for the security level\n\nuse constant STANDARD => 0;\nuse constant MEDIUM   => 1;\nuse constant HIGH     => 2;\n\n# OPENFLAGS. If we defined the flag to use with Sysopen here this gives\n# us an optimisation when many temporary files are requested\n\nmy \$OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;\n\nfor my \$oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) {\n  my (\$bit, \$func) = (0, "Fcntl::O_" . \$oflag);\n  no strict 'refs';\n  \$OPENFLAGS |= \$bit if eval {\n    # Make sure that redefined die handlers do not cause problems\n    # eg CGI::Carp\n    local \$SIG{__DIE__} = sub {};\n    local \$SIG{__WARN__} = sub {};\n    \$bit = &\$func();\n    1;\n  };\n}\n\n# On some systems the O_TEMPORARY flag can be used to tell the OS\n# to automatically remove the file when it is closed. This is fine\n# in most cases but not if tempfile is called with UNLINK=>0 and\n# the filename is requested -- in the case where the filename is to\n# be passed to another routine. This happens on windows. We overcome\n# this by using a second open flags variable\n\nmy \$OPENTEMPFLAGS = \$OPENFLAGS;\nfor my \$oflag (qw/ TEMPORARY /) {\n  my (\$bit, \$func) = (0, "Fcntl::O_" . \$oflag);\n  no strict 'refs';\n  \$OPENTEMPFLAGS |= \$bit if eval {\n    # Make sure that redefined die handlers do not cause problems\n    # eg CGI::Carp\n    local \$SIG{__DIE__} = sub {};\n    local \$SIG{__WARN__} = sub {};\n    \$bit = &\$func();\n    1;\n  };\n}\n\n# INTERNAL ROUTINES - not to be used outside of package\n\n# Generic routine for getting a temporary filename\n# modelled on OpenBSD _gettemp() in mktemp.c\n\n# The template must contain X's that are to be replaced\n# with the random values\n\n#  Arguments:\n\n#  TEMPLATE   - string containing the XXXXX's that is converted\n#           to a random filename and opened if required\n\n# Optionally, a hash can also be supplied containing specific options\n#   "open" => if true open the temp file, else just return the name\n#             default is 0\n#   "mkdir"=> if true, we are creating a temp directory rather than tempfile\n#             default is 0\n#   "suffixlen" => number of characters at end of PATH to be ignored.\n#                  default is 0.\n#   "unlink_on_close" => indicates that, if possible,  the OS should remove\n#                        the file as soon as it is closed. Usually indicates\n#                        use of the O_TEMPORARY flag to sysopen. \n#                        Usually irrelevant on unix\n\n# Optionally a reference to a scalar can be passed into the function\n# On error this will be used to store the reason for the error\n#   "ErrStr"  => \\\$errstr\n\n# "open" and "mkdir" can not both be true\n# "unlink_on_close" is not used when "mkdir" is true.\n\n# The default options are equivalent to mktemp().\n\n# Returns:\n#   filehandle - open file handle (if called with doopen=1, else undef)\n#   temp name  - name of the temp file or directory\n\n# For example:\n#   (\$fh, \$name) = _gettemp(\$template, "open" => 1);\n\n# for the current version, failures are associated with\n# stored in an error string and returned to give the reason whilst debugging\n# This routine is not called by any external function\nsub _gettemp {\n\n  croak 'Usage: (\$fh, \$name) = _gettemp(\$template, OPTIONS);'\n    unless scalar(\@_) >= 1;\n\n  # the internal error string - expect it to be overridden\n  # Need this in case the caller decides not to supply us a value\n  # need an anonymous scalar\n  my \$tempErrStr;\n\n  # Default options\n  my %options = (\n\x09\x09 "open" => 0,\n\x09\x09 "mkdir" => 0,\n\x09\x09 "suffixlen" => 0,\n\x09\x09 "unlink_on_close" => 0,\n\x09\x09 "ErrStr" => \\\$tempErrStr,\n\x09\x09);\n\n  # Read the template\n  my \$template = shift;\n  if (ref(\$template)) {\n    # Use a warning here since we have not yet merged ErrStr\n    carp "File::Temp::_gettemp: template must not be a reference";\n    return ();\n  }\n\n  # Check that the number of entries on stack are even\n  if (scalar(\@_) % 2 != 0) {\n    # Use a warning here since we have not yet merged ErrStr\n    carp "File::Temp::_gettemp: Must have even number of options";\n    return ();\n  }\n\n  # Read the options and merge with defaults\n  %options = (%options, \@_)  if \@_;\n\n  # Make sure the error string is set to undef\n  \${\$options{ErrStr}} = undef;\n\n  # Can not open the file and make a directory in a single call\n  if (\$options{"open"} && \$options{"mkdir"}) {\n    \${\$options{ErrStr}} = "doopen and domkdir can not both be true\\n";\n    return ();\n  }\n\n  # Find the start of the end of the  Xs (position of last X)\n  # Substr starts from 0\n  my \$start = length(\$template) - 1 - \$options{"suffixlen"};\n\n  # Check that we have at least MINX x X (eg 'XXXX") at the end of the string\n  # (taking suffixlen into account). Any fewer is insecure.\n\n  # Do it using substr - no reason to use a pattern match since\n  # we know where we are looking and what we are looking for\n\n  if (substr(\$template, \$start - MINX + 1, MINX) ne 'X' x MINX) {\n    \${\$options{ErrStr}} = "The template must contain at least ".\n      MINX . " 'X' characters\\n";\n    return ();\n  }\n\n  # Replace all the X at the end of the substring with a\n  # random character or just all the XX at the end of a full string.\n  # Do it as an if, since the suffix adjusts which section to replace\n  # and suffixlen=0 returns nothing if used in the substr directly\n  # and generate a full path from the template\n\n  my \$path = _replace_XX(\$template, \$options{"suffixlen"});\n\n\n  # Split the path into constituent parts - eventually we need to check\n  # whether the directory exists\n  # We need to know whether we are making a temp directory\n  # or a tempfile\n\n  my (\$volume, \$directories, \$file);\n  my \$parent; # parent directory\n  if (\$options{"mkdir"}) {\n    # There is no filename at the end\n    (\$volume, \$directories, \$file) = File::Spec->splitpath( \$path, 1);\n\n    # The parent is then \$directories without the last directory\n    # Split the directory and put it back together again\n    my \@dirs = File::Spec->splitdir(\$directories);\n\n    # If \@dirs only has one entry that means we are in the current\n    # directory\n    if (\$#dirs == 0) {\n      \$parent = File::Spec->curdir;\n    } else {\n\n      if (\$^O eq 'VMS') {  # need volume to avoid relative dir spec\n        \$parent = File::Spec->catdir(\$volume, \@dirs[0..\$#dirs-1]);\n        \$parent = 'sys\$disk:[]' if \$parent eq '';\n      } else {\n\n\x09# Put it back together without the last one\n\x09\$parent = File::Spec->catdir(\@dirs[0..\$#dirs-1]);\n\n\x09# ...and attach the volume (no filename)\n\x09\$parent = File::Spec->catpath(\$volume, \$parent, '');\n      }\n\n    }\n\n  } else {\n\n    # Get rid of the last filename (use File::Basename for this?)\n    (\$volume, \$directories, \$file) = File::Spec->splitpath( \$path );\n\n    # Join up without the file part\n    \$parent = File::Spec->catpath(\$volume,\$directories,'');\n\n    # If \$parent is empty replace with curdir\n    \$parent = File::Spec->curdir\n      unless \$directories ne '';\n\n  }\n\n  # Check that the parent directories exist \n  # Do this even for the case where we are simply returning a name\n  # not a file -- no point returning a name that includes a directory\n  # that does not exist or is not writable\n\n  unless (-d \$parent) {\n    \${\$options{ErrStr}} = "Parent directory (\$parent) is not a directory";\n    return ();\n  }\n  unless (-w _) {\n    \${\$options{ErrStr}} = "Parent directory (\$parent) is not writable\\n";\n      return ();\n  }\n\n\n  # Check the stickiness of the directory and chown giveaway if required\n  # If the directory is world writable the sticky bit\n  # must be set\n\n  if (File::Temp->safe_level == MEDIUM) {\n    my \$safeerr;\n    unless (_is_safe(\$parent,\\\$safeerr)) {\n      \${\$options{ErrStr}} = "Parent directory (\$parent) is not safe (\$safeerr)";\n      return ();\n    }\n  } elsif (File::Temp->safe_level == HIGH) {\n    my \$safeerr;\n    unless (_is_verysafe(\$parent, \\\$safeerr)) {\n      \${\$options{ErrStr}} = "Parent directory (\$parent) is not safe (\$safeerr)";\n      return ();\n    }\n  }\n\n\n  # Now try MAX_TRIES time to open the file\n  for (my \$i = 0; \$i < MAX_TRIES; \$i++) {\n\n    # Try to open the file if requested\n    if (\$options{"open"}) {\n      my \$fh;\n\n      # If we are running before perl5.6.0 we can not auto-vivify\n      if (\$] < 5.006) {\n\x09\$fh = &Symbol::gensym;\n      }\n\n      # Try to make sure this will be marked close-on-exec\n      # XXX: Win32 doesn't respect this, nor the proper fcntl,\n      #      but may have O_NOINHERIT. This may or may not be in Fcntl.\n      local \$^F = 2;\n\n      # Store callers umask\n      my \$umask = umask();\n\n      # Set a known umask\n      umask(066);\n\n      # Attempt to open the file\n      my \$open_success = undef;\n      if ( \$^O eq 'VMS' and \$options{"unlink_on_close"} ) {\n        # make it auto delete on close by setting FAB\$V_DLT bit\n\x09\$fh = VMS::Stdio::vmssysopen(\$path, \$OPENFLAGS, 0600, 'fop=dlt');\n\x09\$open_success = \$fh;\n      } else {\n\x09my \$flags = ( \$options{"unlink_on_close"} ?\n\x09\x09      \$OPENTEMPFLAGS :\n\x09\x09      \$OPENFLAGS );\n\x09\$open_success = sysopen(\$fh, \$path, \$flags, 0600);\n      }\n      if ( \$open_success ) {\n\n\x09# Reset umask\n\x09umask(\$umask);\n\x09\n\x09# Opened successfully - return file handle and name\n\x09return (\$fh, \$path);\n\n      } else {\n\x09# Reset umask\n\x09umask(\$umask);\n\n\x09# Error opening file - abort with error\n\x09# if the reason was anything but EEXIST\n\x09unless (\$!{EEXIST}) {\n\x09  \${\$options{ErrStr}} = "Could not create temp file \$path: \$!";\n\x09  return ();\n\x09}\n\n\x09# Loop round for another try\n\x09\n      }\n    } elsif (\$options{"mkdir"}) {\n\n      # Store callers umask\n      my \$umask = umask();\n\n      # Set a known umask\n      umask(066);\n\n      # Open the temp directory\n      if (mkdir( \$path, 0700)) {\n\x09# created okay\n\x09# Reset umask\n\x09umask(\$umask);\n\n\x09return undef, \$path;\n      } else {\n\n\x09# Reset umask\n\x09umask(\$umask);\n\n\x09# Abort with error if the reason for failure was anything\n\x09# except EEXIST\n\x09unless (\$!{EEXIST}) {\n\x09  \${\$options{ErrStr}} = "Could not create directory \$path: \$!";\n\x09  return ();\n\x09}\n\n\x09# Loop round for another try\n\n      }\n\n    } else {\n\n      # Return true if the file can not be found\n      # Directory has been checked previously\n\n      return (undef, \$path) unless -e \$path;\n\n      # Try again until MAX_TRIES\n\n    }\n\n    # Did not successfully open the tempfile/dir\n    # so try again with a different set of random letters\n    # No point in trying to increment unless we have only\n    # 1 X say and the randomness could come up with the same\n    # file MAX_TRIES in a row.\n\n    # Store current attempt - in principal this implies that the\n    # 3rd time around the open attempt that the first temp file\n    # name could be generated again. Probably should store each\n    # attempt and make sure that none are repeated\n\n    my \$original = \$path;\n    my \$counter = 0;  # Stop infinite loop\n    my \$MAX_GUESS = 50;\n\n    do {\n\n      # Generate new name from original template\n      \$path = _replace_XX(\$template, \$options{"suffixlen"});\n\n      \$counter++;\n\n    } until (\$path ne \$original || \$counter > \$MAX_GUESS);\n\n    # Check for out of control looping\n    if (\$counter > \$MAX_GUESS) {\n      \${\$options{ErrStr}} = "Tried to get a new temp name different to the previous value \$MAX_GUESS times.\\nSomething wrong with template?? (\$template)";\n      return ();\n    }\n\n  }\n\n  # If we get here, we have run out of tries\n  \${ \$options{ErrStr} } = "Have exceeded the maximum number of attempts ("\n    . MAX_TRIES . ") to open temp file/dir";\n\n  return ();\n\n}\n\n# Internal routine to return a random character from the\n# character list. Does not do an srand() since rand()\n# will do one automatically\n\n# No arguments. Return value is the random character\n\n# No longer called since _replace_XX runs a few percent faster if\n# I inline the code. This is important if we are creating thousands of\n# temporary files.\n\nsub _randchar {\n\n  \$CHARS[ int( rand( \$#CHARS ) ) ];\n\n}\n\n# Internal routine to replace the XXXX... with random characters\n# This has to be done by _gettemp() every time it fails to \n# open a temp file/dir\n\n# Arguments:  \$template (the template with XXX), \n#             \$ignore   (number of characters at end to ignore)\n\n# Returns:    modified template\n\nsub _replace_XX {\n\n  croak 'Usage: _replace_XX(\$template, \$ignore)'\n    unless scalar(\@_) == 2;\n\n  my (\$path, \$ignore) = \@_;\n\n  # Do it as an if, since the suffix adjusts which section to replace\n  # and suffixlen=0 returns nothing if used in the substr directly\n  # Alternatively, could simply set \$ignore to length(\$path)-1\n  # Don't want to always use substr when not required though.\n\n  if (\$ignore) {\n    substr(\$path, 0, - \$ignore) =~ s/X(?=X*\\z)/\$CHARS[ int( rand( \$#CHARS ) ) ]/ge;\n  } else {\n    \$path =~ s/X(?=X*\\z)/\$CHARS[ int( rand( \$#CHARS ) ) ]/ge;\n  }\n\n  return \$path;\n}\n\n# internal routine to check to see if the directory is safe\n# First checks to see if the directory is not owned by the\n# current user or root. Then checks to see if anyone else\n# can write to the directory and if so, checks to see if\n# it has the sticky bit set\n\n# Will not work on systems that do not support sticky bit\n\n#Args:  directory path to check\n#       Optionally: reference to scalar to contain error message\n# Returns true if the path is safe and false otherwise.\n# Returns undef if can not even run stat() on the path\n\n# This routine based on version written by Tom Christiansen\n\n# Presumably, by the time we actually attempt to create the\n# file or directory in this directory, it may not be safe\n# anymore... Have to run _is_safe directly after the open.\n\nsub _is_safe {\n\n  my \$path = shift;\n  my \$err_ref = shift;\n\n  # Stat path\n  my \@info = stat(\$path);\n  unless (scalar(\@info)) {\n    \$\$err_ref = "stat(path) returned no values";\n    return 0;\n  };\n  return 1 if \$^O eq 'VMS';  # owner delete control at file level\n\n  # Check to see whether owner is neither superuser (or a system uid) nor me\n  # Use the real uid from the \$< variable\n  # UID is in [4]\n  if (\$info[4] > File::Temp->top_system_uid() && \$info[4] != \$<) {\n\n    Carp::cluck(sprintf "uid=\$info[4] topuid=%s \\\$<=\$< path='\$path'",\n\x09\x09File::Temp->top_system_uid());\n\n    \$\$err_ref = "Directory owned neither by root nor the current user"\n      if ref(\$err_ref);\n    return 0;\n  }\n\n  # check whether group or other can write file\n  # use 066 to detect either reading or writing\n  # use 022 to check writability\n  # Do it with S_IWOTH and S_IWGRP for portability (maybe)\n  # mode is in info[2]\n  if ((\$info[2] & &Fcntl::S_IWGRP) ||   # Is group writable?\n      (\$info[2] & &Fcntl::S_IWOTH) ) {  # Is world writable?\n    # Must be a directory\n    unless (-d _) {\n      \$\$err_ref = "Path (\$path) is not a directory"\n      if ref(\$err_ref);\n      return 0;\n    }\n    # Must have sticky bit set\n    unless (-k _) {\n      \$\$err_ref = "Sticky bit not set on \$path when dir is group|world writable"\n\x09if ref(\$err_ref);\n      return 0;\n    }\n  }\n\n  return 1;\n}\n\n# Internal routine to check whether a directory is safe\n# for temp files. Safer than _is_safe since it checks for \n# the possibility of chown giveaway and if that is a possibility\n# checks each directory in the path to see if it is safe (with _is_safe)\n\n# If _PC_CHOWN_RESTRICTED is not set, does the full test of each\n# directory anyway.\n\n# Takes optional second arg as scalar ref to error reason\n\nsub _is_verysafe {\n\n  # Need POSIX - but only want to bother if really necessary due to overhead\n  require POSIX;\n\n  my \$path = shift;\n  print "_is_verysafe testing \$path\\n" if \$DEBUG;\n  return 1 if \$^O eq 'VMS';  # owner delete control at file level\n\n  my \$err_ref = shift;\n\n  # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined\n  # and If it is not there do the extensive test\n  my \$chown_restricted;\n  \$chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()\n    if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};\n\n  # If chown_resticted is set to some value we should test it\n  if (defined \$chown_restricted) {\n\n    # Return if the current directory is safe\n    return _is_safe(\$path,\$err_ref) if POSIX::sysconf( \$chown_restricted );\n\n  }\n\n  # To reach this point either, the _PC_CHOWN_RESTRICTED symbol\n  # was not avialable or the symbol was there but chown giveaway\n  # is allowed. Either way, we now have to test the entire tree for\n  # safety.\n\n  # Convert path to an absolute directory if required\n  unless (File::Spec->file_name_is_absolute(\$path)) {\n    \$path = File::Spec->rel2abs(\$path);\n  }\n\n  # Split directory into components - assume no file\n  my (\$volume, \$directories, undef) = File::Spec->splitpath( \$path, 1);\n\n  # Slightly less efficient than having a a function in File::Spec\n  # to chop off the end of a directory or even a function that\n  # can handle ../ in a directory tree\n  # Sometimes splitdir() returns a blank at the end\n  # so we will probably check the bottom directory twice in some cases\n  my \@dirs = File::Spec->splitdir(\$directories);\n\n  # Concatenate one less directory each time around\n  foreach my \$pos (0.. \$#dirs) {\n    # Get a directory name\n    my \$dir = File::Spec->catpath(\$volume,\n\x09\x09\x09\x09  File::Spec->catdir(\@dirs[0.. \$#dirs - \$pos]),\n\x09\x09\x09\x09  ''\n\x09\x09\x09\x09  );\n\n    print "TESTING DIR \$dir\\n" if \$DEBUG;\n\n    # Check the directory\n    return 0 unless _is_safe(\$dir,\$err_ref);\n\n  }\n\n  return 1;\n}\n\n\n\n# internal routine to determine whether unlink works on this\n# platform for files that are currently open.\n# Returns true if we can, false otherwise.\n\n# Currently WinNT, OS/2 and VMS can not unlink an opened file\n# On VMS this is because the O_EXCL flag is used to open the\n# temporary file. Currently I do not know enough about the issues\n# on VMS to decide whether O_EXCL is a requirement.\n\nsub _can_unlink_opened_file {\n\n  if (\$^O eq 'MSWin32' || \$^O eq 'os2' || \$^O eq 'VMS' || \$^O eq 'dos') {\n    return 0;\n  } else {\n    return 1;\n  }\n\n}\n\n# internal routine to decide which security levels are allowed\n# see safe_level() for more information on this\n\n# Controls whether the supplied security level is allowed\n\n#   \$cando = _can_do_level( \$level )\n\nsub _can_do_level {\n\n  # Get security level\n  my \$level = shift;\n\n  # Always have to be able to do STANDARD\n  return 1 if \$level == STANDARD;\n\n  # Currently, the systems that can do HIGH or MEDIUM are identical\n  if ( \$^O eq 'MSWin32' || \$^O eq 'os2' || \$^O eq 'cygwin' || \$^O eq 'dos') {\n    return 0;\n  } else {\n    return 1;\n  }\n\n}\n\n# This routine sets up a deferred unlinking of a specified\n# filename and filehandle. It is used in the following cases:\n#  - Called by unlink0 if an opened file can not be unlinked\n#  - Called by tempfile() if files are to be removed on shutdown\n#  - Called by tempdir() if directories are to be removed on shutdown\n\n# Arguments:\n#   _deferred_unlink( \$fh, \$fname, \$isdir );\n#\n#   - filehandle (so that it can be expclicitly closed if open\n#   - filename   (the thing we want to remove)\n#   - isdir      (flag to indicate that we are being given a directory)\n#                 [and hence no filehandle]\n\n# Status is not referred to since all the magic is done with an END block\n\n{\n  # Will set up two lexical variables to contain all the files to be\n  # removed. One array for files, another for directories\n  # They will only exist in this block\n  # This means we only have to set up a single END block to remove all files\n  # \@files_to_unlink contains an array ref with the filehandle and filename\n  my (\@files_to_unlink, \@dirs_to_unlink);\n\n  # Set up an end block to use these arrays\n  END {\n    # Files\n    foreach my \$file (\@files_to_unlink) {\n      # close the filehandle without checking its state\n      # in order to make real sure that this is closed\n      # if its already closed then I dont care about the answer\n      # probably a better way to do this\n      close(\$file->[0]);  # file handle is [0]\n\n      if (-f \$file->[1]) {  # file name is [1]\n\x09unlink \$file->[1] or warn "Error removing ".\$file->[1];\n      }\n    }\n    # Dirs\n    foreach my \$dir (\@dirs_to_unlink) {\n      if (-d \$dir) {\n\x09rmtree(\$dir, \$DEBUG, 1);\n      }\n    }\n\n  }\n\n  # This is the sub called to register a file for deferred unlinking\n  # This could simply store the input parameters and defer everything\n  # until the END block. For now we do a bit of checking at this\n  # point in order to make sure that (1) we have a file/dir to delete\n  # and (2) we have been called with the correct arguments.\n  sub _deferred_unlink {\n\n    croak 'Usage:  _deferred_unlink(\$fh, \$fname, \$isdir)'\n      unless scalar(\@_) == 3;\n\n    my (\$fh, \$fname, \$isdir) = \@_;\n\n    warn "Setting up deferred removal of \$fname\\n"\n      if \$DEBUG;\n\n    # If we have a directory, check that it is a directory\n    if (\$isdir) {\n\n      if (-d \$fname) {\n\n\x09# Directory exists so store it\n\x09# first on VMS turn []foo into [.foo] for rmtree\n\x09\$fname = VMS::Filespec::vmspath(\$fname) if \$^O eq 'VMS';\n\x09push (\@dirs_to_unlink, \$fname);\n\n      } else {\n\x09carp "Request to remove directory \$fname could not be completed since it does not exist!\\n" if \$^W;\n      }\n\n    } else {\n\n      if (-f \$fname) {\n\n\x09# file exists so store handle and name for later removal\n\x09push(\@files_to_unlink, [\$fh, \$fname]);\n\n      } else {\n\x09carp "Request to remove file \$fname could not be completed since it is not there!\\n" if \$^W;\n      }\n\n    }\n\n  }\n\n\n}\n\n=head1 FUNCTIONS\n\nThis section describes the recommended interface for generating\ntemporary files and directories.\n\n=over 4\n\n=item B<tempfile>\n\nThis is the basic function to generate temporary files.\nThe behaviour of the file can be changed using various options:\n\n  (\$fh, \$filename) = tempfile();\n\nCreate a temporary file in  the directory specified for temporary\nfiles, as specified by the tmpdir() function in L<File::Spec>.\n\n  (\$fh, \$filename) = tempfile(\$template);\n\nCreate a temporary file in the current directory using the supplied\ntemplate.  Trailing `X' characters are replaced with random letters to\ngenerate the filename.  At least four `X' characters must be present\nin the template.\n\n  (\$fh, \$filename) = tempfile(\$template, SUFFIX => \$suffix)\n\nSame as previously, except that a suffix is added to the template\nafter the `X' translation.  Useful for ensuring that a temporary\nfilename has a particular extension when needed by other applications.\nBut see the WARNING at the end.\n\n  (\$fh, \$filename) = tempfile(\$template, DIR => \$dir);\n\nTranslates the template as before except that a directory name\nis specified.\n\n  (\$fh, \$filename) = tempfile(\$template, UNLINK => 1);\n\nReturn the filename and filehandle as before except that the file is\nautomatically removed when the program exits. Default is for the file\nto be removed if a file handle is requested and to be kept if the\nfilename is requested. In a scalar context (where no filename is \nreturned) the file is always deleted either on exit or when it is closed.\n\nIf the template is not specified, a template is always\nautomatically generated. This temporary file is placed in tmpdir()\n(L<File::Spec>) unless a directory is specified explicitly with the \nDIR option.\n\n  \$fh = tempfile( \$template, DIR => \$dir );\n\nIf called in scalar context, only the filehandle is returned\nand the file will automatically be deleted when closed (see \nthe description of tmpfile() elsewhere in this document).\nThis is the preferred mode of operation, as if you only \nhave a filehandle, you can never create a race condition\nby fumbling with the filename. On systems that can not unlink\nan open file or can not mark a file as temporary when it is opened\n(for example, Windows NT uses the C<O_TEMPORARY> flag))\nthe file is marked for deletion when the program ends (equivalent\nto setting UNLINK to 1). The C<UNLINK> flag is ignored if present.\n\n  (undef, \$filename) = tempfile(\$template, OPEN => 0);\n\nThis will return the filename based on the template but\nwill not open this file.  Cannot be used in conjunction with\nUNLINK set to true. Default is to always open the file \nto protect from possible race conditions. A warning is issued\nif warnings are turned on. Consider using the tmpnam()\nand mktemp() functions described elsewhere in this document\nif opening the file is not required.\n\nOptions can be combined as required.\n\n=cut\n\nsub tempfile {\n\n  # Can not check for argument count since we can have any\n  # number of args\n\n  # Default options\n  my %options = (\n\x09\x09 "DIR"    => undef,  # Directory prefix\n                "SUFFIX" => '',     # Template suffix\n                "UNLINK" => 0,      # Do not unlink file on exit\n                "OPEN"   => 1,      # Open file\n\x09\x09);\n\n  # Check to see whether we have an odd or even number of arguments\n  my \$template = (scalar(\@_) % 2 == 1 ? shift(\@_) : undef);\n\n  # Read the options and merge with defaults\n  %options = (%options, \@_)  if \@_;\n\n  # First decision is whether or not to open the file\n  if (! \$options{"OPEN"}) {\n\n    warn "tempfile(): temporary filename requested but not opened.\\nPossibly unsafe, consider using tempfile() with OPEN set to true\\n"\n      if \$^W;\n\n  }\n\n  if (\$options{"DIR"} and \$^O eq 'VMS') {\n\n      # on VMS turn []foo into [.foo] for concatenation\n      \$options{"DIR"} = VMS::Filespec::vmspath(\$options{"DIR"});\n  }\n\n  # Construct the template\n\n  # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc\n  # functions or simply constructing a template and using _gettemp()\n  # explicitly. Go for the latter\n\n  # First generate a template if not defined and prefix the directory\n  # If no template must prefix the temp directory\n  if (defined \$template) {\n    if (\$options{"DIR"}) {\n\n      \$template = File::Spec->catfile(\$options{"DIR"}, \$template);\n\n    }\n\n  } else {\n\n    if (\$options{"DIR"}) {\n\n      \$template = File::Spec->catfile(\$options{"DIR"}, TEMPXXX);\n\n    } else {\n\n      \$template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);\n\n    }\n\n  }\n\n  # Now add a suffix\n  \$template .= \$options{"SUFFIX"};\n\n  # Determine whether we should tell _gettemp to unlink the file\n  # On unix this is irrelevant and can be worked out after the file is\n  # opened (simply by unlinking the open filehandle). On Windows or VMS\n  # we have to indicate temporary-ness when we open the file. In general\n  # we only want a true temporary file if we are returning just the \n  # filehandle - if the user wants the filename they probably do not\n  # want the file to disappear as soon as they close it.\n  # For this reason, tie unlink_on_close to the return context regardless\n  # of OS.\n  my \$unlink_on_close = ( wantarray ? 0 : 1);\n\n  # Create the file\n  my (\$fh, \$path, \$errstr);\n  croak "Error in tempfile() using \$template: \$errstr"\n    unless ((\$fh, \$path) = _gettemp(\$template,\n\x09\x09\x09\x09    "open" => \$options{'OPEN'},\n\x09\x09\x09\x09    "mkdir"=> 0 ,\n                                    "unlink_on_close" => \$unlink_on_close,\n\x09\x09\x09\x09    "suffixlen" => length(\$options{'SUFFIX'}),\n\x09\x09\x09\x09    "ErrStr" => \\\$errstr,\n\x09\x09\x09\x09   ) );\n\n  # Set up an exit handler that can do whatever is right for the\n  # system. This removes files at exit when requested explicitly or when\n  # system is asked to unlink_on_close but is unable to do so because\n  # of OS limitations.\n  # The latter should be achieved by using a tied filehandle.\n  # Do not check return status since this is all done with END blocks.\n  _deferred_unlink(\$fh, \$path, 0) if \$options{"UNLINK"};\n\n  # Return\n  if (wantarray()) {\n\n    if (\$options{'OPEN'}) {\n      return (\$fh, \$path);\n    } else {\n      return (undef, \$path);\n    }\n\n  } else {\n\n    # Unlink the file. It is up to unlink0 to decide what to do with\n    # this (whether to unlink now or to defer until later)\n    unlink0(\$fh, \$path) or croak "Error unlinking file \$path using unlink0";\n\n    # Return just the filehandle.\n    return \$fh;\n  }\n\n\n}\n\n=item B<tempdir>\n\nThis is the recommended interface for creation of temporary directories.\nThe behaviour of the function depends on the arguments:\n\n  \$tempdir = tempdir();\n\nCreate a directory in tmpdir() (see L<File::Spec|File::Spec>).\n\n  \$tempdir = tempdir( \$template );\n\nCreate a directory from the supplied template. This template is\nsimilar to that described for tempfile(). `X' characters at the end\nof the template are replaced with random letters to construct the\ndirectory name. At least four `X' characters must be in the template.\n\n  \$tempdir = tempdir ( DIR => \$dir );\n\nSpecifies the directory to use for the temporary directory.\nThe temporary directory name is derived from an internal template.\n\n  \$tempdir = tempdir ( \$template, DIR => \$dir );\n\nPrepend the supplied directory name to the template. The template\nshould not include parent directory specifications itself. Any parent\ndirectory specifications are removed from the template before\nprepending the supplied directory.\n\n  \$tempdir = tempdir ( \$template, TMPDIR => 1 );\n\nUsing the supplied template, creat the temporary directory in \na standard location for temporary files. Equivalent to doing\n\n  \$tempdir = tempdir ( \$template, DIR => File::Spec->tmpdir);\n\nbut shorter. Parent directory specifications are stripped from the\ntemplate itself. The C<TMPDIR> option is ignored if C<DIR> is set\nexplicitly.  Additionally, C<TMPDIR> is implied if neither a template\nnor a directory are supplied.\n\n  \$tempdir = tempdir( \$template, CLEANUP => 1);\n\nCreate a temporary directory using the supplied template, but \nattempt to remove it (and all files inside it) when the program\nexits. Note that an attempt will be made to remove all files from\nthe directory even if they were not created by this module (otherwise\nwhy ask to clean it up?). The directory removal is made with\nthe rmtree() function from the L<File::Path|File::Path> module.\nOf course, if the template is not specified, the temporary directory\nwill be created in tmpdir() and will also be removed at program exit.\n\n=cut\n\n# '\n\nsub tempdir  {\n\n  # Can not check for argument count since we can have any\n  # number of args\n\n  # Default options\n  my %options = (\n\x09\x09 "CLEANUP"    => 0,  # Remove directory on exit\n\x09\x09 "DIR"        => '', # Root directory\n\x09\x09 "TMPDIR"     => 0,  # Use tempdir with template\n\x09\x09);\n\n  # Check to see whether we have an odd or even number of arguments\n  my \$template = (scalar(\@_) % 2 == 1 ? shift(\@_) : undef );\n\n  # Read the options and merge with defaults\n  %options = (%options, \@_)  if \@_;\n\n  # Modify or generate the template\n\n  # Deal with the DIR and TMPDIR options\n  if (defined \$template) {\n\n    # Need to strip directory path if using DIR or TMPDIR\n    if (\$options{'TMPDIR'} || \$options{'DIR'}) {\n\n      # Strip parent directory from the filename\n      #\n      # There is no filename at the end\n      \$template = VMS::Filespec::vmspath(\$template) if \$^O eq 'VMS';\n      my (\$volume, \$directories, undef) = File::Spec->splitpath( \$template, 1);\n\n      # Last directory is then our template\n      \$template = (File::Spec->splitdir(\$directories))[-1];\n\n      # Prepend the supplied directory or temp dir\n      if (\$options{"DIR"}) {\n\n        \$template = File::Spec->catdir(\$options{"DIR"}, \$template);\n\n      } elsif (\$options{TMPDIR}) {\n\n\x09# Prepend tmpdir\n\x09\$template = File::Spec->catdir(File::Spec->tmpdir, \$template);\n\n      }\n\n    }\n\n  } else {\n\n    if (\$options{"DIR"}) {\n\n      \$template = File::Spec->catdir(\$options{"DIR"}, TEMPXXX);\n\n    } else {\n\n      \$template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);\n\n    }\n\n  }\n\n  # Create the directory\n  my \$tempdir;\n  my \$suffixlen = 0;\n  if (\$^O eq 'VMS') {  # dir names can end in delimiters\n    \$template =~ m/([\\.\\]:>]+)\$/;\n    \$suffixlen = length(\$1);\n  }\n\n  my \$errstr;\n  croak "Error in tempdir() using \$template: \$errstr"\n    unless ((undef, \$tempdir) = _gettemp(\$template,\n\x09\x09\x09\x09    "open" => 0,\n\x09\x09\x09\x09    "mkdir"=> 1 ,\n\x09\x09\x09\x09    "suffixlen" => \$suffixlen,\n\x09\x09\x09\x09    "ErrStr" => \\\$errstr,\n\x09\x09\x09\x09   ) );\n\n  # Install exit handler; must be dynamic to get lexical\n  if ( \$options{'CLEANUP'} && -d \$tempdir) {\n    _deferred_unlink(undef, \$tempdir, 1);\n  }\n\n  # Return the dir name\n  return \$tempdir;\n\n}\n\n=back\n\n=head1 MKTEMP FUNCTIONS\n\nThe following functions are Perl implementations of the \nmktemp() family of temp file generation system calls.\n\n=over 4\n\n=item B<mkstemp>\n\nGiven a template, returns a filehandle to the temporary file and the name\nof the file.\n\n  (\$fh, \$name) = mkstemp( \$template );\n\nIn scalar context, just the filehandle is returned.\n\nThe template may be any filename with some number of X's appended\nto it, for example F</tmp/temp.XXXX>. The trailing X's are replaced\nwith unique alphanumeric combinations.\n\n=cut\n\n\n\nsub mkstemp {\n\n  croak "Usage: mkstemp(template)"\n    if scalar(\@_) != 1;\n\n  my \$template = shift;\n\n  my (\$fh, \$path, \$errstr);\n  croak "Error in mkstemp using \$template: \$errstr"\n    unless ((\$fh, \$path) = _gettemp(\$template,\n\x09\x09\x09\x09    "open" => 1,\n\x09\x09\x09\x09    "mkdir"=> 0 ,\n\x09\x09\x09\x09    "suffixlen" => 0,\n\x09\x09\x09\x09    "ErrStr" => \\\$errstr,\n\x09\x09\x09\x09   ) );\n\n  if (wantarray()) {\n    return (\$fh, \$path);\n  } else {\n    return \$fh;\n  }\n\n}\n\n\n=item B<mkstemps>\n\nSimilar to mkstemp(), except that an extra argument can be supplied\nwith a suffix to be appended to the template.\n\n  (\$fh, \$name) = mkstemps( \$template, \$suffix );\n\nFor example a template of C<testXXXXXX> and suffix of C<.dat>\nwould generate a file similar to F<testhGji_w.dat>.\n\nReturns just the filehandle alone when called in scalar context.\n\n=cut\n\nsub mkstemps {\n\n  croak "Usage: mkstemps(template, suffix)"\n    if scalar(\@_) != 2;\n\n\n  my \$template = shift;\n  my \$suffix   = shift;\n\n  \$template .= \$suffix;\n\n  my (\$fh, \$path, \$errstr);\n  croak "Error in mkstemps using \$template: \$errstr"\n    unless ((\$fh, \$path) = _gettemp(\$template,\n\x09\x09\x09\x09    "open" => 1,\n\x09\x09\x09\x09    "mkdir"=> 0 ,\n\x09\x09\x09\x09    "suffixlen" => length(\$suffix),\n\x09\x09\x09\x09    "ErrStr" => \\\$errstr,\n\x09\x09\x09\x09   ) );\n\n  if (wantarray()) {\n    return (\$fh, \$path);\n  } else {\n    return \$fh;\n  }\n\n}\n\n=item B<mkdtemp>\n\nCreate a directory from a template. The template must end in\nX's that are replaced by the routine.\n\n  \$tmpdir_name = mkdtemp(\$template);\n\nReturns the name of the temporary directory created.\nReturns undef on failure.\n\nDirectory must be removed by the caller.\n\n=cut\n\n#' # for emacs\n\nsub mkdtemp {\n\n  croak "Usage: mkdtemp(template)"\n    if scalar(\@_) != 1;\n\n  my \$template = shift;\n  my \$suffixlen = 0;\n  if (\$^O eq 'VMS') {  # dir names can end in delimiters\n    \$template =~ m/([\\.\\]:>]+)\$/;\n    \$suffixlen = length(\$1);\n  }\n  my (\$junk, \$tmpdir, \$errstr);\n  croak "Error creating temp directory from template \$template\\: \$errstr"\n    unless ((\$junk, \$tmpdir) = _gettemp(\$template,\n\x09\x09\x09\x09\x09"open" => 0,\n\x09\x09\x09\x09\x09"mkdir"=> 1 ,\n\x09\x09\x09\x09\x09"suffixlen" => \$suffixlen,\n\x09\x09\x09\x09\x09"ErrStr" => \\\$errstr,\n\x09\x09\x09\x09       ) );\n\n  return \$tmpdir;\n\n}\n\n=item B<mktemp>\n\nReturns a valid temporary filename but does not guarantee\nthat the file will not be opened by someone else.\n\n  \$unopened_file = mktemp(\$template);\n\nTemplate is the same as that required by mkstemp().\n\n=cut\n\nsub mktemp {\n\n  croak "Usage: mktemp(template)"\n    if scalar(\@_) != 1;\n\n  my \$template = shift;\n\n  my (\$tmpname, \$junk, \$errstr);\n  croak "Error getting name to temp file from template \$template: \$errstr"\n    unless ((\$junk, \$tmpname) = _gettemp(\$template,\n\x09\x09\x09\x09\x09 "open" => 0,\n\x09\x09\x09\x09\x09 "mkdir"=> 0 ,\n\x09\x09\x09\x09\x09 "suffixlen" => 0,\n\x09\x09\x09\x09\x09 "ErrStr" => \\\$errstr,\n\x09\x09\x09\x09\x09 ) );\n\n  return \$tmpname;\n}\n\n=back\n\n=head1 POSIX FUNCTIONS\n\nThis section describes the re-implementation of the tmpnam()\nand tmpfile() functions described in L<POSIX> \nusing the mkstemp() from this module.\n\nUnlike the L<POSIX|POSIX> implementations, the directory used\nfor the temporary file is not specified in a system include\nfile (C<P_tmpdir>) but simply depends on the choice of tmpdir()\nreturned by L<File::Spec|File::Spec>. On some implementations this\nlocation can be set using the C<TMPDIR> environment variable, which\nmay not be secure.\nIf this is a problem, simply use mkstemp() and specify a template.\n\n=over 4\n\n=item B<tmpnam>\n\nWhen called in scalar context, returns the full name (including path)\nof a temporary file (uses mktemp()). The only check is that the file does\nnot already exist, but there is no guarantee that that condition will\ncontinue to apply.\n\n  \$file = tmpnam();\n\nWhen called in list context, a filehandle to the open file and\na filename are returned. This is achieved by calling mkstemp()\nafter constructing a suitable template.\n\n  (\$fh, \$file) = tmpnam();\n\nIf possible, this form should be used to prevent possible\nrace conditions.\n\nSee L<File::Spec/tmpdir> for information on the choice of temporary\ndirectory for a particular operating system.\n\n=cut\n\nsub tmpnam {\n\n   # Retrieve the temporary directory name\n   my \$tmpdir = File::Spec->tmpdir;\n\n   croak "Error temporary directory is not writable"\n     if \$tmpdir eq '';\n\n   # Use a ten character template and append to tmpdir\n   my \$template = File::Spec->catfile(\$tmpdir, TEMPXXX);\n\n   if (wantarray() ) {\n       return mkstemp(\$template);\n   } else {\n       return mktemp(\$template);\n   }\n\n}\n\n=item B<tmpfile>\n\nIn scalar context, returns the filehandle of a temporary file.\n\n  \$fh = tmpfile();\n\nThe file is removed when the filehandle is closed or when the program\nexits. No access to the filename is provided.\n\nIf the temporary file can not be created undef is returned.\nCurrently this command will probably not work when the temporary\ndirectory is on an NFS file system.\n\n=cut\n\nsub tmpfile {\n\n  # Simply call tmpnam() in a list context\n  my (\$fh, \$file) = tmpnam();\n\n  # Make sure file is removed when filehandle is closed\n  # This will fail on NFS\n  unlink0(\$fh, \$file)\n    or return undef;\n\n  return \$fh;\n\n}\n\n=back\n\n=head1 ADDITIONAL FUNCTIONS\n\nThese functions are provided for backwards compatibility\nwith common tempfile generation C library functions.\n\nThey are not exported and must be addressed using the full package\nname. \n\n=over 4\n\n=item B<tempnam>\n\nReturn the name of a temporary file in the specified directory\nusing a prefix. The file is guaranteed not to exist at the time\nthe function was called, but such guarantees are good for one \nclock tick only.  Always use the proper form of C<sysopen>\nwith C<O_CREAT | O_EXCL> if you must open such a filename.\n\n  \$filename = File::Temp::tempnam( \$dir, \$prefix );\n\nEquivalent to running mktemp() with \$dir/\$prefixXXXXXXXX\n(using unix file convention as an example) \n\nBecause this function uses mktemp(), it can suffer from race conditions.\n\n=cut\n\nsub tempnam {\n\n  croak 'Usage tempnam(\$dir, \$prefix)' unless scalar(\@_) == 2;\n\n  my (\$dir, \$prefix) = \@_;\n\n  # Add a string to the prefix\n  \$prefix .= 'XXXXXXXX';\n\n  # Concatenate the directory to the file\n  my \$template = File::Spec->catfile(\$dir, \$prefix);\n\n  return mktemp(\$template);\n\n}\n\n=back\n\n=head1 UTILITY FUNCTIONS\n\nUseful functions for dealing with the filehandle and filename.\n\n=over 4\n\n=item B<unlink0>\n\nGiven an open filehandle and the associated filename, make a safe\nunlink. This is achieved by first checking that the filename and\nfilehandle initially point to the same file and that the number of\nlinks to the file is 1 (all fields returned by stat() are compared).\nThen the filename is unlinked and the filehandle checked once again to\nverify that the number of links on that file is now 0.  This is the\nclosest you can come to making sure that the filename unlinked was the\nsame as the file whose descriptor you hold.\n\n  unlink0(\$fh, \$path) or die "Error unlinking file \$path safely";\n\nReturns false on error. The filehandle is not closed since on some\noccasions this is not required.\n\nOn some platforms, for example Windows NT, it is not possible to\nunlink an open file (the file must be closed first). On those\nplatforms, the actual unlinking is deferred until the program ends and\ngood status is returned. A check is still performed to make sure that\nthe filehandle and filename are pointing to the same thing (but not at\nthe time the end block is executed since the deferred removal may not\nhave access to the filehandle).\n\nAdditionally, on Windows NT not all the fields returned by stat() can\nbe compared. For example, the C<dev> and C<rdev> fields seem to be\ndifferent.  Also, it seems that the size of the file returned by stat()\ndoes not always agree, with C<stat(FH)> being more accurate than\nC<stat(filename)>, presumably because of caching issues even when\nusing autoflush (this is usually overcome by waiting a while after\nwriting to the tempfile before attempting to C<unlink0> it).\n\nFinally, on NFS file systems the link count of the file handle does\nnot always go to zero immediately after unlinking. Currently, this\ncommand is expected to fail on NFS disks.\n\n=cut\n\nsub unlink0 {\n\n  croak 'Usage: unlink0(filehandle, filename)'\n    unless scalar(\@_) == 2;\n\n  # Read args\n  my (\$fh, \$path) = \@_;\n\n  warn "Unlinking \$path using unlink0\\n"\n    if \$DEBUG;\n\n  # Stat the filehandle\n  my \@fh = stat \$fh;\n\n  if (\$fh[3] > 1 && \$^W) {\n    carp "unlink0: fstat found too many links; SB=\@fh" if \$^W;\n  }\n\n  # Stat the path\n  my \@path = stat \$path;\n\n  unless (\@path) {\n    carp "unlink0: \$path is gone already" if \$^W;\n    return;\n  }\n\n  # this is no longer a file, but may be a directory, or worse\n  unless (-f _) {\n    confess "panic: \$path is no longer a file: SB=\@fh";\n  }\n\n  # Do comparison of each member of the array\n  # On WinNT dev and rdev seem to be different\n  # depending on whether it is a file or a handle.\n  # Cannot simply compare all members of the stat return\n  # Select the ones we can use\n  my \@okstat = (0..\$#fh);  # Use all by default\n  if (\$^O eq 'MSWin32') {\n    \@okstat = (1,2,3,4,5,7,8,9,10);\n  } elsif (\$^O eq 'os2') {\n    \@okstat = (0, 2..\$#fh);\n  } elsif (\$^O eq 'VMS') { # device and file ID are sufficient\n    \@okstat = (0, 1);\n  } elsif (\$^O eq 'dos') {\n     \@okstat = (0,2..7,11..\$#fh);\n  }\n\n  # Now compare each entry explicitly by number\n  for (\@okstat) {\n    print "Comparing: \$_ : \$fh[\$_] and \$path[\$_]\\n" if \$DEBUG;\n    # Use eq rather than == since rdev, blksize, and blocks (6, 11,\n    # and 12) will be '' on platforms that do not support them.  This\n    # is fine since we are only comparing integers.\n    unless (\$fh[\$_] eq \$path[\$_]) {\n      warn "Did not match \$_ element of stat\\n" if \$DEBUG;\n      return 0;\n    }\n  }\n\n  # attempt remove the file (does not work on some platforms)\n  if (_can_unlink_opened_file()) {\n    # XXX: do *not* call this on a directory; possible race\n    #      resulting in recursive removal\n    croak "unlink0: \$path has become a directory!" if -d \$path;\n    unlink(\$path) or return 0;\n\n    # Stat the filehandle\n    \@fh = stat \$fh;\n\n    print "Link count = \$fh[3] \\n" if \$DEBUG;\n\n    # Make sure that the link count is zero\n    # - Cygwin provides deferred unlinking, however,\n    #   on Win9x the link count remains 1\n    # On NFS the link count may still be 1 but we cant know that\n    # we are on NFS\n    return ( \$fh[3] == 0 or \$^O eq 'cygwin' ? 1 : 0);\n\n  } else {\n    _deferred_unlink(\$fh, \$path, 0);\n    return 1;\n  }\n\n}\n\n=back\n\n=head1 PACKAGE VARIABLES\n\nThese functions control the global state of the package.\n\n=over 4\n\n=item B<safe_level>\n\nControls the lengths to which the module will go to check the safety of the\ntemporary file or directory before proceeding.\nOptions are:\n\n=over 8\n\n=item STANDARD\n\nDo the basic security measures to ensure the directory exists and\nis writable, that the umask() is fixed before opening of the file,\nthat temporary files are opened only if they do not already exist, and\nthat possible race conditions are avoided.  Finally the L<unlink0|"unlink0">\nfunction is used to remove files safely.\n\n=item MEDIUM\n\nIn addition to the STANDARD security, the output directory is checked\nto make sure that it is owned either by root or the user running the\nprogram. If the directory is writable by group or by other, it is then\nchecked to make sure that the sticky bit is set.\n\nWill not work on platforms that do not support the C<-k> test\nfor sticky bit.\n\n=item HIGH\n\nIn addition to the MEDIUM security checks, also check for the\npossibility of ``chown() giveaway'' using the L<POSIX|POSIX>\nsysconf() function. If this is a possibility, each directory in the\npath is checked in turn for safeness, recursively walking back to the \nroot directory.\n\nFor platforms that do not support the L<POSIX|POSIX>\nC<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is \nassumed that ``chown() giveaway'' is possible and the recursive test\nis performed.\n\n=back\n\nThe level can be changed as follows:\n\n  File::Temp->safe_level( File::Temp::HIGH );\n\nThe level constants are not exported by the module.\n\nCurrently, you must be running at least perl v5.6.0 in order to\nrun with MEDIUM or HIGH security. This is simply because the \nsafety tests use functions from L<Fcntl|Fcntl> that are not\navailable in older versions of perl. The problem is that the version\nnumber for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though\nthey are different versions.\n\nOn systems that do not support the HIGH or MEDIUM safety levels\n(for example Win NT or OS/2) any attempt to change the level will\nbe ignored. The decision to ignore rather than raise an exception\nallows portable programs to be written with high security in mind\nfor the systems that can support this without those programs failing\non systems where the extra tests are irrelevant.\n\nIf you really need to see whether the change has been accepted\nsimply examine the return value of C<safe_level>.\n\n  \$newlevel = File::Temp->safe_level( File::Temp::HIGH );\n  die "Could not change to high security" \n      if \$newlevel != File::Temp::HIGH;\n\n=cut\n\n{\n  # protect from using the variable itself\n  my \$LEVEL = STANDARD;\n  sub safe_level {\n    my \$self = shift;\n    if (\@_) { \n      my \$level = shift;\n      if ((\$level != STANDARD) && (\$level != MEDIUM) && (\$level != HIGH)) {\n\x09carp "safe_level: Specified level (\$level) not STANDARD, MEDIUM or HIGH - ignoring\\n" if \$^W;\n      } else {\n\x09# Dont allow this on perl 5.005 or earlier\n\x09if (\$] < 5.006 && \$level != STANDARD) {\n\x09  # Cant do MEDIUM or HIGH checks\n\x09  croak "Currently requires perl 5.006 or newer to do the safe checks";\n\x09}\n\x09# Check that we are allowed to change level\n\x09# Silently ignore if we can not.\n        \$LEVEL = \$level if _can_do_level(\$level);\n      }\n    }\n    return \$LEVEL;\n  }\n}\n\n=item TopSystemUID\n\nThis is the highest UID on the current system that refers to a root\nUID. This is used to make sure that the temporary directory is \nowned by a system UID (C<root>, C<bin>, C<sys> etc) rather than \nsimply by root.\n\nThis is required since on many unix systems C</tmp> is not owned\nby root.\n\nDefault is to assume that any UID less than or equal to 10 is a root\nUID.\n\n  File::Temp->top_system_uid(10);\n  my \$topid = File::Temp->top_system_uid;\n\nThis value can be adjusted to reduce security checking if required.\nThe value is only relevant when C<safe_level> is set to MEDIUM or higher.\n\n=back\n\n=cut\n\n{\n  my \$TopSystemUID = 10;\n  sub top_system_uid {\n    my \$self = shift;\n    if (\@_) {\n      my \$newuid = shift;\n      croak "top_system_uid: UIDs should be numeric"\n        unless \$newuid =~ /^\\d+\$/s;\n      \$TopSystemUID = \$newuid;\n    }\n    return \$TopSystemUID;\n  }\n}\n\n=head1 WARNING\n\nFor maximum security, endeavour always to avoid ever looking at,\ntouching, or even imputing the existence of the filename.  You do not\nknow that that filename is connected to the same file as the handle\nyou have, and attempts to check this can only trigger more race\nconditions.  It's far more secure to use the filehandle alone and\ndispense with the filename altogether.\n\nIf you need to pass the handle to something that expects a filename\nthen, on a unix system, use C<"/dev/fd/" . fileno(\$fh)> for arbitrary\nprograms, or more generally C<< "+<=&" . fileno(\$fh) >> for Perl\nprograms.  You will have to clear the close-on-exec bit on that file\ndescriptor before passing it to another process.\n\n    use Fcntl qw/F_SETFD F_GETFD/;\n    fcntl(\$tmpfh, F_SETFD, 0)\n        or die "Can't clear close-on-exec flag on temp fh: \$!\\n";\n\n=head2 Temporary files and NFS\n\nSome problems are associated with using temporary files that reside\non NFS file systems and it is recommended that a local filesystem\nis used whenever possible. Some of the security tests will most probably\nfail when the temp file is not local. Additionally, be aware that\nthe performance of I/O operations over NFS will not be as good as for\na local disk.\n\n=head1 HISTORY\n\nOriginally began life in May 1999 as an XS interface to the system\nmkstemp() function. In March 2000, the OpenBSD mkstemp() code was\ntranslated to Perl for total control of the code's\nsecurity checking, to ensure the presence of the function regardless of\noperating system and to help with portability.\n\n=head1 SEE ALSO\n\nL<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>\n\nSee L<IO::File> and L<File::MkTemp> for different implementations of \ntemporary file handling.\n\n=head1 AUTHOR\n\nTim Jenness E<lt>t.jenness\@jach.hawaii.eduE<gt>\n\nCopyright (C) 1999-2001 Tim Jenness and the UK Particle Physics and\nAstronomy Research Council. All Rights Reserved.  This program is free\nsoftware; you can redistribute it and/or modify it under the same\nterms as Perl itself.\n\nOriginal Perl implementation loosely based on the OpenBSD C code for \nmkstemp(). Thanks to Tom Christiansen for suggesting that this module\nshould be written and providing ideas for code improvements and\nsecurity enhancements.\n\n=cut\n\n\n1;\n
END_OF_FILE_AAAAAAAAAADR
#=#----%<--------%<--------%<--------%<--------%<--------%<--------%<------#=#
{
no strict;

#!/usr/local/bin/perl -w

eval 'exec /usr/local/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell

=head1 NAME

vcp - Copy versions of files between repositories and/or RevML

=head1 SYNOPSIS

   vcp [vcp_opts] <source> <dest>

   vcp help [topic]

   vcp html <destination dir>

=head1 DESCRIPTION

C<vcp> ('version copy') copies versions of files from one repository to another,
translating as much metadata as possible along the way.  This allows you to
copy and translate files and their histories between revision storage systems.

Supported source and destination types are C<cvs:>, C<p4:>, and C<revml:>.

=head2 Copying Versions

The general syntax of the vcp command line is:

   vcp [<vcp options>] <source> <dest>

The three portions of the command line are:

=over

=item C<E<lt>vcp optionsE<gt>>

Command line options that control the operation of the C<vcp> command, like
C<-d> for debugging or C<-h> for help.  There are very few global options,
these are covered below. Note that they must come before the
C<E<lt>sourceE<gt>> specification.

=item C<E<lt>sourceE<gt>>

Were to extract versions from, including any command line options needed to
control what is extracted and how.  See the next section.

=item C<E<lt>destE<gt>>

Where to insert versions, including any command line options needed to control
how files are stored.  See the next section.

=back

=head2 Specifying Repositories

The C<E<lt>sourceE<gt>> and C<E<lt>destE<gt>> specifications are meant to
resemble URIs.  They my have several fields delimited by C<:> and C<@>, and may
have trailing command line options.  The full (rarely used) syntax is:

   scheme:user(view):password@repository:filespec [<options>]

where

=over

=item C<scheme:>

The repository type (C<p4:>, C<cvs:>, C<revml:>).

=item C<user>, C<view>, and C<password>

Optional values for authenticating with the repository and identifying which
view to use.  C<cvs> does not use C<view>.  For C<p4>, C<view> is the client
setting (equibalent to setting C<P4CLIENT> or using C<p4>'s C<-c> option).

=item C<repository>

The repository spec, CVSROOT for CVS or P4PORT for p4.

=item C<filespec>

Which versions of what files to move.  As much as possible, this spec is
similar to the native filespecs used by the repository indicated by the scheme.

=item C<E<lt>optionsE<gt>>

Command line options that usually mimic the options provided by the underlying
repositories' command line tools (C<cvs>, C<p4>, etc).

=back

Most of these fields are omitted in practice, only the C<scheme> field is
required, though (in most cases) the C<repository> field is also needed unless
you set the appropriate environment variables (C<CVSROOT>, C<P4PORT>, etc).

The a bit confusing, here are some examples specs:

   cvs:server:/foo
   p4:user@server://depot/foo/...
   p4:user:password@public.perforce.com:1666://depot/foo/...

Options and formats for of individual schemes can be found in the relevant
help topics, for instance:

   vcp help source::cvs

See C<vcp help> for a list of source and destination topics.

=head2 C<vcp> Options

All general options to vcp must precede the C<E<lt>sourceE<gt>>.
Scheme-specific options must be placed immediately after the
C<E<lt>sourceE<gt>> or C<E<lt>destE<gt>> spec and before the next one.

=over

=item --debug <spec>, -d <spec>

Enables display of debugging information.  A debug spec is part or all of a
module name like C<Source::revml> or a perl5 regular expression to match module
names.  Debug specs are not case insensitively.

The most general, show-me-everything debug option is:

   -d ".*"

The quotations are needed to slip the ".*" past most command shells.

Any debug specs that don't match anything during a run are printed out
when vcp exits in order to help identify mispelled patterns.  vcp will also list
all of the internal names that didn't match during a run to
give clues as to what specs might be useful.

The special name 'what' is guaranteed to not match anything, so you can
do

   vcp -d what ...

to see the list of names that might be useful for the arguments '...' .

You may use multiple
C<-d> options or provide a comma separated list to enable debugging
within that module. Do not start a pattern with a "-".

Debugging messages are emitted to stderr. See L</VCPDEBUG> for how to specify
debug options in the environment.

=item --help, -h, -?

These are all equivalent to C<vcp help>.

=back

=head2 Getting help

(See also L<Generating HTML Documentation|Generating HTML Documentation>,
below).

There is a slightly different command line format for requesting help:

   vcp help [<topic>]

where C<E<lt>topicE<gt>> is the optional name of a topic.  C<vcp help> without
a C<E<lt>>topicC<E<gt>> prints out a list of topics, and C<vcp help vcp>
emits this page.

All help documents are also available as Unix C<man> pages and using the
C<perldoc> command, although the names are slightly different:

   with vcp               via perldoc        
   ================       ===========
   vcp help vcp           perldoc vcp
   vcp help source::cvs   perldoc VCP::Source::cvs
   vcp help source::cvs   perldoc VCP::Dest::p4

C<vcp help> is case insensitive, C<perldoc> and C<man> may or may not be
depending on your filesystem.  The C<man> commands look just like the example
C<perldoc> commands except for the command name.  Both have the advantage that
they use your system's configured pager if possible.

=head2 Environment Variables

The environment is often used to set context for the source and destination
by way of variables like P4USER, P4CLIENT, CVSROOT, etc.

There is also one environment variable that is used to enable
command line debugging.  The VCPDEBUG variable acts just like a leading
C<-d=$VCPDEBUG> was present on the command line.

   VCPDEBUG=main,p4

(see L<"--debug E<lt>specE<gt>, -d E<lt>specE<gt>"> for more info).  This is useful when VCP is
embedded in another application, like a makefile or a test suite.

=head2 Generating HTML Documentation

All of the help pages in C<vcp> can be built in to an HTML tree with the
command:

   vcp html <dest_dir>

The index file will be C<E<lt>dest_dirE<gt>/index.html>.

=cut

use strict ;

use Getopt::Long ;
use File::Basename ;
use File::Spec ;
use VCP ;
use VCP::Debug qw( :debug ) ;
use XML::Doctype ;


{
   my $pname = basename( $0 ) ;
   my $dtd_spec ;
   my $arg = 'help' ;

   usage_and_exit() unless @ARGV ;

   enable_debug( split /,/, $ENV{VCPDEBUG} ) if defined $ENV{VCPDEBUG} ;

   debug "vcp: ", join " ", map "'$_'", $pname, @ARGV if debugging "main" ;

   ## Parse up to the first non-option, then let sources & dests parse
   ## from there.
   Getopt::Long::Configure( qw( no_auto_abbrev no_bundling no_permute ) ) ;
   GetOptions(
      'debug|d=s'   => sub {
         enable_debug( length $_[1] ? split /,/, $_[1] : () )
      },
      'help|h|?'    => \&help_and_exit,
      'versions'    => \&versions_and_exit,
   ) or options_and_exit() ;

   usage_and_exit() unless @ARGV ;

   $arg = shift ;

   build_html_tree_and_exit( $pname, @ARGV ) if $arg eq "html";

   help_and_exit( $pname, @ARGV ) if $arg eq 'help' ;

   my @errors ;

   ## We pass \@ARGV to the constructors for source and dest so that
   ## they may parse some of @ARGV and leave the rest.  Actually, that's
   ## only important for sources, since the dests should consume it all
   ## anyway.  But, for consistency's sake, I do the same to both.

   my $source ;
   if ( defined $arg && $arg =~ /^\w+:/ ) {
      my ( $scheme, $spec ) = $arg =~ /^([^:]+):(.*)/ ;

      ## This next one consumes all options up to the dest scheme.
      $source = load_module( "VCP::Source::$scheme", $arg, \@ARGV );
      die "unknown source scheme '$scheme:', try ",
         list_modules( "VCP::Source" ), "\n"
         unless defined $source ;
   }

   my $dest ;
   if ( defined $source ? $source->dest_expected : @ARGV ) {
      my ( $scheme, $spec ) = @ARGV
         ? ( $_ = shift ) =~ /^([^:]+?):(.*)/
         : ( "revml", "" )
         or die "Unable to parse '$_'";

      $dest = load_module("VCP::Dest::$scheme", "$scheme:$spec", \@ARGV );
      die "unknown destination scheme '$scheme:', try ",
         list_modules( "VCP::Dest" ), "\n"
         unless defined $dest ;
      @ARGV = () ;
   }
   elsif ( @ARGV ) {
      push @errors, "extra parameters: " . join( ' ', @ARGV ) . "\n" ;
   }

   if ( debugging ) {
      debug 'vcp: no dest expected' unless ! $source || $source->dest_expected ;
      debug 'vcp: $source is ', $source ;
      debug 'vcp: $dest   is ',   $dest ;
   }

   unless ( @errors ) {
      my $cp = VCP->new( $source, $dest ) ;
      my $header = {} ;
      my $footer = {} ;
      $cp->copy_all( $header, $footer ) ;
   }

   if ( @errors ) {
      my $errors = join( '', @errors ) ;
      $errors =~ s/^/$pname: /mg ;
      die $errors ;
   }

}

###############################################################################
###############################################################################

sub load_module {
   my ( $name, @args ) = @_ ;

   my $filename = $name ;
   $filename =~ s{::}{/}g ;

   my $x ;
   {
      local $@ ;
      my $v = eval "require '$filename.pm'; 1" ;
      return undef if $@ && $@ =~ /^Can't locate $filename.pm/ ;
      $x = $@ ;
   }
   die $x if $x ;

   debug "vcp: loaded '$name' from '", $INC{"$filename.pm"}, "'"
      if debugging 'main', $name ;
   return $name->new( @args ) ;#if $v == 1 ;
}


sub list_modules {
   my ( $prefix ) = @_ ;

   my $dirname = $prefix . '::' ;
   $dirname =~ s{(::)+}{/}g ;

   my %seen ;
   for ( @INC ) {
      my $dir = File::Spec->catdir( $_, $dirname ) ;
      opendir( D, $dir ) or next ;
      my @files = grep $_ !~ /^\.\.?$/ && s/\.pm$//i, readdir D ;
      closedir D ;
      $seen{$_} = 1 for @files ;
   }

   my $list = join( ', ', map "$_:", sort keys %seen ) ;

   $list =~ s/,([^,]*)$/ or$1/ ;
   return $list ;
}


sub usage_and_exit {
   require Pod::Usage ;
   Pod::Usage::pod2usage( -message => shift, -verbose => 0, -exitval => 1 ) ;
}

sub options_and_exit {
   require Pod::Usage ;
   Pod::Usage::pod2usage( -verbose => 1, -exitval => 1 ) ;
}


sub find_help_modules {
   my ( $desired_module ) = @_;

   require File::Find;

   my %modules;

   for my $inc_dir ( @INC ) {
      $inc_dir = File::Spec->rel2abs( $inc_dir );

      my $vcp_file = File::Spec->catfile( $inc_dir, "VCP.pm" );
      $modules{VCP} ||= $vcp_file if -f $vcp_file;

      my $vcp_dir  = File::Spec->catdir(  $inc_dir, "VCP"    );
      next unless -d $vcp_dir;

      File::Find::find(
         sub {
            return if -d $_;
            return unless /\.(pm|pod)\Z/i;

            my $mod_name = File::Spec->abs2rel( $File::Find::name, $vcp_dir );

            $mod_name =~ s{[:\\/]+}{::}g;
            $mod_name =~ s{\.(pm|pod)}{}i;

            if ( defined $desired_module && lc $mod_name eq $desired_module ) {
               die "FOUND $File::Find::name\n";
            }
            else {
               $modules{$mod_name} ||= $File::Find::name;
            }

         },
         $vcp_dir
      )
   }

   return %modules;
}


sub help_and_exit {
   require Pod::Usage ;

   my ( $prog_name, $topic ) = @_;

   my $result = 0;

   if ( defined $topic ) {
      $topic = lc $topic;

      if ( $topic eq "vcp" ) {
          system( "pod2text", $0 );
          exit $result;
      }

      eval {
         find_help_modules( $topic );
      };
      if ( $@ =~ /FOUND (.*)/ ) {
         exit system( "pod2text", $1 ) >> 8;
      }
      elsif ( $@ ) {
          die $@;
      }

      $result = 1;
      warn "Unrecognized help topic '$topic'\n";
   }

    print <<END_HELP_TOPICS;

$prog_name - Version Copy, a tool for copying versions file repositories

help topics (use "vcp help <topic>" to see):

   vcp            General help for the vcp command

   source::p4     Extracting from a p4 repository
   dest::p4       Inserting in to a p4 repository
   source::cvs    Extracting from a cvs repository
   dest::cvs      Inserting in to a cvs repository

   newlines       Newline, ^Z and NULL issues
   process        How $prog_name works

   license        Copyright and license information
   maintenance    VCP Code maintenance, debugging tips & tricks

END_HELP_TOPICS
   exit $result;
}


sub build_html_tree_and_exit {
   my ( $prog_name, $dest_dir ) = @_;

   unless ( defined $dest_dir && length $dest_dir ) {
       $dest_dir = $prog_name . "_html";
   }

   $dest_dir = File::Spec->rel2abs( $dest_dir );

   $| = 1;
   print "Generating HTML in $dest_dir/";

   my %modules = find_help_modules;

   require Pod::Links;
   require Pod::HTML_Elements;
   require File::Path;
   require IO::File;

   ## BEGIN CODE ADAPTED FROM NICK ING-SIMMONS' PodToHTML package
   my $links = Pod::Links->new();
   for my $fn (
      $0,
      grep /Source[^.]|Dest[^.]|\.pod/, values %modules
   ) {
      print ".";
      $links->parse_from_file($fn);
   }

   for my $name ($links->names) {
      $links->link(
         $name,
         do {
            my $outfile = $name;
            $outfile =~ s#::#/#g;
            $outfile =~ s#[^/a-z0-9A-Z._-]#_#g;
            $outfile .= ".html";
            File::Spec->catfile( $dest_dir, $outfile );
         }
      ) if $links->pod($name);
   }

   my $index_file = File::Spec->catfile( $dest_dir, "index.html" );

   my $parser = Pod::HTML_Elements->new(
      Index => $index_file,
      Links => $links,
   );

   ## the sort {} makes sure "vcp" is listed first in the
   ## resulting index.
   for my $name (
      sort {
         $a eq "vcp"
            ? -1
            : $b eq "vcp"
               ? 1
               : $a cmp $b
      } $links->names
   ) {
      print ".";
      my $file = $links->pod($name);
      my $outfile = $links->link($name);
      if (defined $file) {
         File::Path::mkpath( File::Basename::dirname( $outfile ), 0, 0755 );
         $parser->parse_from_file($file,$outfile);
      }
   }
   $parser->write_index;
   ## END CODE ADAPTED FROM NICK ING-SIMMONS' PodToHTML package
   print "\n";

   print "Finished, index file is $index_file\n";

   exit( 0 );
}


sub versions_and_exit {
   require File::Find ;

   my $require_module = sub {
      return unless m/\.pm$/i ;
      ## Avoid "name used only once" warning
      my $fn = $File::Find::name ;
      $fn = $File::Find::name ;
      require $fn ;
   } ;

   File::Find::find(
      {
         no_chdir => 1,
	 wanted   => $require_module,
      },
      grep -d $_,
      map {
         ( File::Spec->catdir( $_, "lib", "VCP", "Source" ),
         File::Spec->catdir( $_, "lib", "VCP", "Dest" ),
	 ) ;
      } @INC
   ) ;

   my %vers ;
   my %no_vers ;

   my $recur ;
   $recur = sub {
      my ( $pkg_namespace ) = @_ ;

      no strict "refs" ;

      my $pkg_name = substr( $pkg_namespace, 0, -2 ) ;

      ## The grep means "only bother with namespaces that contain somthing
      ## other than child namespaces.
      if ( ! grep /::/, keys %{$pkg_namespace} ) {
         if ( exists ${$pkg_namespace}{VERSION} ) {
	    $vers{$pkg_name} = ${"${pkg_namespace}VERSION"}
	 }
	 else {
	    $no_vers{$pkg_name} = undef ;
	 }
      }

      my $prefix = $pkg_namespace eq "main::" ? "" : $pkg_namespace ;
      for ( keys %{$pkg_namespace} ) {
	 next unless /::$/ ;
	 next if /^main::/ ;
	 $recur->( "$prefix$_" ) ;
      }
   } ;

   $recur->( "main::" ) ;

   my $max_len = 0 ;
   $max_len = length > $max_len ? length : $max_len for keys %vers ;
      
   print "Package \$VERSIONs:\n" ;
   for ( sort keys %vers ) {
      printf(
         "   %-${max_len}s: %s\n",
	 $_,
	 defined $vers{$_} ? $vers{$_} : "undef"
      ) ;
   }

   print "No \$VERSION found for: ", join( ", ", sort keys %no_vers ), "\n" ;

   $max_len = 0 ;
   $max_len = length > $max_len ? length : $max_len for values %INC ;
   print "\nFile sizes:\n" ;
   for ( sort values %INC ) {
      printf( "   %-${max_len}s: %7d\n", $_, -s $_ ) ;
   }

   print "\nperl -V:\n" ;

   my $v = `$^X -V` ;
   $v =~ s/^/   /gm ;
   print $v ;

   exit ;
}

=head1 SEE ALSO

L<VCP::Process>, L<VCP::Newlines>, L<VCP::Source::p4>, L<VCP::Dest::p4>,
L<VCP::Source::cvs>, L<VCP::Dest::cvs>, L<VCP::Source::revml>,
L<VCP::Dest::revml>, L<VCP::Newlines>.  All are also available using C<vcp
help>.

=head1 AUTHOR

Barrie Slaymaker <barries@slaysys.com>

=head1 COPYRIGHT

Copyright (c) 2000, 2001, 2002 Perforce Software, Inc.
All rights reserved.

See L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.

=cut


=for nothing
Just in case the POD isn't closed off...

=cut

$INC{"/home/barries/src/VCP/dist/foo/bin/vcp"} = "inlined" if length "/home/barries/src/VCP/dist/foo/bin/vcp";
chdir $original_cwd or die $!;
}

}