diff options
author | Karl Berry <karl@freefriends.org> | 2009-01-30 00:33:26 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2009-01-30 00:33:26 +0000 |
commit | a5df6b939c049edcc1fcd805b056a002904f6aea (patch) | |
tree | b8725970f457042e324911da4c06732dea9def39 /Master/tlpkg/installer | |
parent | 233e8430afec69ca29c28c798cc0912785ea29d1 (diff) |
add everything from tlperl/lib to installer/perllib except for Tk, unicore, and auto (report from Gregor Zimmermann, 29 Jan 2009 12:38:19)
git-svn-id: svn://tug.org/texlive/trunk@12015 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/installer')
162 files changed, 73885 insertions, 0 deletions
diff --git a/Master/tlpkg/installer/perllib/AnyDBM_File.pm b/Master/tlpkg/installer/perllib/AnyDBM_File.pm new file mode 100644 index 00000000000..d73abab0f9e --- /dev/null +++ b/Master/tlpkg/installer/perllib/AnyDBM_File.pm @@ -0,0 +1,93 @@ +package AnyDBM_File; + +use 5.006_001; +our $VERSION = '1.00'; +our @ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA; + +my $mod; +for $mod (@ISA) { + if (eval "require $mod") { + @ISA = ($mod); # if we leave @ISA alone, warnings abound + return 1; + } +} + +die "No DBM package was successfully found or installed"; +#return 0; + +=head1 NAME + +AnyDBM_File - provide framework for multiple DBMs + +NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations + +=head1 SYNOPSIS + + use AnyDBM_File; + +=head1 DESCRIPTION + +This module is a "pure virtual base class"--it has nothing of its own. +It's just there to inherit from one of the various DBM packages. It +prefers ndbm for compatibility reasons with Perl 4, then Berkeley DB (See +L<DB_File>), GDBM, SDBM (which is always there--it comes with Perl), and +finally ODBM. This way old programs that used to use NDBM via dbmopen() +can still do so, but new ones can reorder @ISA: + + BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) } + use AnyDBM_File; + +Having multiple DBM implementations makes it trivial to copy database formats: + + use POSIX; use NDBM_File; use DB_File; + tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR; + tie %oldhash, 'NDBM_File', $old_filename, 1, 0; + %newhash = %oldhash; + +=head2 DBM Comparisons + +Here's a partial table of features the different packages offer: + + odbm ndbm sdbm gdbm bsd-db + ---- ---- ---- ---- ------ + Linkage comes w/ perl yes yes yes yes yes + Src comes w/ perl no no yes no no + Comes w/ many unix os yes yes[0] no no no + Builds ok on !unix ? ? yes yes ? + Code Size ? ? small big big + Database Size ? ? small big? ok[1] + Speed ? ? slow ok fast + FTPable no no yes yes yes + Easy to build N/A N/A yes yes ok[2] + Size limits 1k 4k 1k[3] none none + Byte-order independent no no no no yes + Licensing restrictions ? ? no yes no + + +=over 4 + +=item [0] + +on mixed universe machines, may be in the bsd compat library, +which is often shunned. + +=item [1] + +Can be trimmed if you compile for one access method. + +=item [2] + +See L<DB_File>. +Requires symbolic links. + +=item [3] + +By default, but can be redefined. + +=back + +=head1 SEE ALSO + +dbm(3), ndbm(3), DB_File(3), L<perldbmfilter> + +=cut diff --git a/Master/tlpkg/installer/perllib/B.pm b/Master/tlpkg/installer/perllib/B.pm new file mode 100644 index 00000000000..12917347cd0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B.pm @@ -0,0 +1,1111 @@ +# B.pm +# +# Copyright (c) 1996, 1997, 1998 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +package B; + +our $VERSION = '1.09_01'; + +use XSLoader (); +require Exporter; +@ISA = qw(Exporter); + +# walkoptree_slow comes from B.pm (you are there), +# walkoptree comes from B.xs +@EXPORT_OK = qw(minus_c ppname save_BEGINs + class peekop cast_I32 cstring cchar hash threadsv_names + main_root main_start main_cv svref_2object opnumber + amagic_generation perlstring + walkoptree_slow walkoptree walkoptree_exec walksymtable + parents comppadlist sv_undef compile_stats timing_info + begin_av init_av check_av end_av regex_padav dowarn + defstash curstash warnhook diehook inc_gv + ); + +sub OPf_KIDS (); +use strict; +@B::SV::ISA = 'B::OBJECT'; +@B::NULL::ISA = 'B::SV'; +@B::PV::ISA = 'B::SV'; +@B::IV::ISA = 'B::SV'; +@B::NV::ISA = 'B::SV'; +@B::RV::ISA = 'B::SV'; +@B::PVIV::ISA = qw(B::PV B::IV); +@B::PVNV::ISA = qw(B::PVIV B::NV); +@B::PVMG::ISA = 'B::PVNV'; +# Change in the inheritance hierarchy post 5.9.0 +@B::PVLV::ISA = $] > 5.009 ? 'B::GV' : 'B::PVMG'; +@B::BM::ISA = 'B::PVMG'; +@B::AV::ISA = 'B::PVMG'; +@B::GV::ISA = 'B::PVMG'; +@B::HV::ISA = 'B::PVMG'; +@B::CV::ISA = 'B::PVMG'; +@B::IO::ISA = 'B::PVMG'; +@B::FM::ISA = 'B::CV'; + +@B::OP::ISA = 'B::OBJECT'; +@B::UNOP::ISA = 'B::OP'; +@B::BINOP::ISA = 'B::UNOP'; +@B::LOGOP::ISA = 'B::UNOP'; +@B::LISTOP::ISA = 'B::BINOP'; +@B::SVOP::ISA = 'B::OP'; +@B::PADOP::ISA = 'B::OP'; +@B::PVOP::ISA = 'B::OP'; +@B::LOOP::ISA = 'B::LISTOP'; +@B::PMOP::ISA = 'B::LISTOP'; +@B::COP::ISA = 'B::OP'; + +@B::SPECIAL::ISA = 'B::OBJECT'; + +{ + # Stop "-w" from complaining about the lack of a real B::OBJECT class + package B::OBJECT; +} + +sub B::GV::SAFENAME { + my $name = (shift())->NAME; + + # The regex below corresponds to the isCONTROLVAR macro + # from toke.c + + $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^". + chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e; + + # When we say unicode_to_native we really mean ascii_to_native, + # which matters iff this is a non-ASCII platform (EBCDIC). + + return $name; +} + +sub B::IV::int_value { + my ($self) = @_; + return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV); +} + +sub B::NULL::as_string() {""} +sub B::IV::as_string() {goto &B::IV::int_value} +sub B::PV::as_string() {goto &B::PV::PV} + +my $debug; +my $op_count = 0; +my @parents = (); + +sub debug { + my ($class, $value) = @_; + $debug = $value; + walkoptree_debug($value); +} + +sub class { + my $obj = shift; + my $name = ref $obj; + $name =~ s/^.*:://; + return $name; +} + +sub parents { \@parents } + +# For debugging +sub peekop { + my $op = shift; + return sprintf("%s (0x%x) %s", class($op), $$op, $op->name); +} + +sub walkoptree_slow { + my($op, $method, $level) = @_; + $op_count++; # just for statistics + $level ||= 0; + warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug; + $op->$method($level); + if ($$op && ($op->flags & OPf_KIDS)) { + my $kid; + unshift(@parents, $op); + for ($kid = $op->first; $$kid; $kid = $kid->sibling) { + walkoptree_slow($kid, $method, $level + 1); + } + shift @parents; + } + if (class($op) eq 'PMOP' && ref($op->pmreplroot) && ${$op->pmreplroot}) { + unshift(@parents, $op); + walkoptree_slow($op->pmreplroot, $method, $level + 1); + shift @parents; + } +} + +sub compile_stats { + return "Total number of OPs processed: $op_count\n"; +} + +sub timing_info { + my ($sec, $min, $hr) = localtime; + my ($user, $sys) = times; + sprintf("%02d:%02d:%02d user=$user sys=$sys", + $hr, $min, $sec, $user, $sys); +} + +my %symtable; + +sub clearsym { + %symtable = (); +} + +sub savesym { + my ($obj, $value) = @_; +# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug + $symtable{sprintf("sym_%x", $$obj)} = $value; +} + +sub objsym { + my $obj = shift; + return $symtable{sprintf("sym_%x", $$obj)}; +} + +sub walkoptree_exec { + my ($op, $method, $level) = @_; + $level ||= 0; + my ($sym, $ppname); + my $prefix = " " x $level; + for (; $$op; $op = $op->next) { + $sym = objsym($op); + if (defined($sym)) { + print $prefix, "goto $sym\n"; + return; + } + savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); + $op->$method($level); + $ppname = $op->name; + if ($ppname =~ + /^(d?or(assign)?|and(assign)?|mapwhile|grepwhile|entertry|range|cond_expr)$/) + { + print $prefix, uc($1), " => {\n"; + walkoptree_exec($op->other, $method, $level + 1); + print $prefix, "}\n"; + } elsif ($ppname eq "match" || $ppname eq "subst") { + my $pmreplstart = $op->pmreplstart; + if ($$pmreplstart) { + print $prefix, "PMREPLSTART => {\n"; + walkoptree_exec($pmreplstart, $method, $level + 1); + print $prefix, "}\n"; + } + } elsif ($ppname eq "substcont") { + print $prefix, "SUBSTCONT => {\n"; + walkoptree_exec($op->other->pmreplstart, $method, $level + 1); + print $prefix, "}\n"; + $op = $op->other; + } elsif ($ppname eq "enterloop") { + print $prefix, "REDO => {\n"; + walkoptree_exec($op->redoop, $method, $level + 1); + print $prefix, "}\n", $prefix, "NEXT => {\n"; + walkoptree_exec($op->nextop, $method, $level + 1); + print $prefix, "}\n", $prefix, "LAST => {\n"; + walkoptree_exec($op->lastop, $method, $level + 1); + print $prefix, "}\n"; + } elsif ($ppname eq "subst") { + my $replstart = $op->pmreplstart; + if ($$replstart) { + print $prefix, "SUBST => {\n"; + walkoptree_exec($replstart, $method, $level + 1); + print $prefix, "}\n"; + } + } + } +} + +sub walksymtable { + my ($symref, $method, $recurse, $prefix) = @_; + my $sym; + my $ref; + my $fullname; + no strict 'refs'; + $prefix = '' unless defined $prefix; + while (($sym, $ref) = each %$symref) { + $fullname = "*main::".$prefix.$sym; + if ($sym =~ /::$/) { + $sym = $prefix . $sym; + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { + walksymtable(\%$fullname, $method, $recurse, $sym); + } + } else { + svref_2object(\*$fullname)->$method(); + } + } +} + +{ + package B::Section; + my $output_fh; + my %sections; + + sub new { + my ($class, $section, $symtable, $default) = @_; + $output_fh ||= FileHandle->new_tmpfile; + my $obj = bless [-1, $section, $symtable, $default], $class; + $sections{$section} = $obj; + return $obj; + } + + sub get { + my ($class, $section) = @_; + return $sections{$section}; + } + + sub add { + my $section = shift; + while (defined($_ = shift)) { + print $output_fh "$section->[1]\t$_\n"; + $section->[0]++; + } + } + + sub index { + my $section = shift; + return $section->[0]; + } + + sub name { + my $section = shift; + return $section->[1]; + } + + sub symtable { + my $section = shift; + return $section->[2]; + } + + sub default { + my $section = shift; + return $section->[3]; + } + + sub output { + my ($section, $fh, $format) = @_; + my $name = $section->name; + my $sym = $section->symtable || {}; + my $default = $section->default; + + seek($output_fh, 0, 0); + while (<$output_fh>) { + chomp; + s/^(.*?)\t//; + if ($1 eq $name) { + s{(s\\_[0-9a-f]+)} { + exists($sym->{$1}) ? $sym->{$1} : $default; + }ge; + printf $fh $format, $_; + } + } + } +} + +XSLoader::load 'B'; + +1; + +__END__ + +=head1 NAME + +B - The Perl Compiler + +=head1 SYNOPSIS + + use B; + +=head1 DESCRIPTION + +The C<B> module supplies classes which allow a Perl program to delve +into its own innards. It is the module used to implement the +"backends" of the Perl compiler. Usage of the compiler does not +require knowledge of this module: see the F<O> module for the +user-visible part. The C<B> module is of use to those who want to +write new compiler backends. This documentation assumes that the +reader knows a fair amount about perl's internals including such +things as SVs, OPs and the internal symbol table and syntax tree +of a program. + +=head1 OVERVIEW + +The C<B> module contains a set of utility functions for querying the +current state of the Perl interpreter; typically these functions +return objects from the B::SV and B::OP classes, or their derived +classes. These classes in turn define methods for querying the +resulting objects about their own internal state. + +=head1 Utility Functions + +The C<B> module exports a variety of functions: some are simple +utility functions, others provide a Perl program with a way to +get an initial "handle" on an internal object. + +=head2 Functions Returning C<B::SV>, C<B::AV>, C<B::HV>, and C<B::CV> objects + +For descriptions of the class hierarchy of these objects and the +methods that can be called on them, see below, L<"OVERVIEW OF +CLASSES"> and L<"SV-RELATED CLASSES">. + +=over 4 + +=item sv_undef + +Returns the SV object corresponding to the C variable C<sv_undef>. + +=item sv_yes + +Returns the SV object corresponding to the C variable C<sv_yes>. + +=item sv_no + +Returns the SV object corresponding to the C variable C<sv_no>. + +=item svref_2object(SVREF) + +Takes a reference to any Perl value, and turns the referred-to value +into an object in the appropriate B::OP-derived or B::SV-derived +class. Apart from functions such as C<main_root>, this is the primary +way to get an initial "handle" on an internal perl data structure +which can then be followed with the other access methods. + +The returned object will only be valid as long as the underlying OPs +and SVs continue to exist. Do not attempt to use the object after the +underlying structures are freed. + +=item amagic_generation + +Returns the SV object corresponding to the C variable C<amagic_generation>. + +=item init_av + +Returns the AV object (i.e. in class B::AV) representing INIT blocks. + +=item check_av + +Returns the AV object (i.e. in class B::AV) representing CHECK blocks. + +=item begin_av + +Returns the AV object (i.e. in class B::AV) representing BEGIN blocks. + +=item end_av + +Returns the AV object (i.e. in class B::AV) representing END blocks. + +=item comppadlist + +Returns the AV object (i.e. in class B::AV) of the global comppadlist. + +=item regex_padav + +Only when perl was compiled with ithreads. + +=item main_cv + +Return the (faked) CV corresponding to the main part of the Perl +program. + +=back + +=head2 Functions for Examining the Symbol Table + +=over 4 + +=item walksymtable(SYMREF, METHOD, RECURSE, PREFIX) + +Walk the symbol table starting at SYMREF and call METHOD on each +symbol (a B::GV object) visited. When the walk reaches package +symbols (such as "Foo::") it invokes RECURSE, passing in the symbol +name, and only recurses into the package if that sub returns true. + +PREFIX is the name of the SYMREF you're walking. + +For example: + + # Walk CGI's symbol table calling print_subs on each symbol. + # Recurse only into CGI::Util:: + walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' }, + 'CGI::'); + +print_subs() is a B::GV method you have declared. Also see L<"B::GV +Methods">, below. + +=back + +=head2 Functions Returning C<B::OP> objects or for walking op trees + +For descriptions of the class hierarchy of these objects and the +methods that can be called on them, see below, L<"OVERVIEW OF +CLASSES"> and L<"OP-RELATED CLASSES">. + +=over 4 + +=item main_root + +Returns the root op (i.e. an object in the appropriate B::OP-derived +class) of the main part of the Perl program. + +=item main_start + +Returns the starting op of the main part of the Perl program. + +=item walkoptree(OP, METHOD) + +Does a tree-walk of the syntax tree based at OP and calls METHOD on +each op it visits. Each node is visited before its children. If +C<walkoptree_debug> (see below) has been called to turn debugging on then +the method C<walkoptree_debug> is called on each op before METHOD is +called. + +=item walkoptree_debug(DEBUG) + +Returns the current debugging flag for C<walkoptree>. If the optional +DEBUG argument is non-zero, it sets the debugging flag to that. See +the description of C<walkoptree> above for what the debugging flag +does. + +=back + +=head2 Miscellaneous Utility Functions + +=over 4 + +=item ppname(OPNUM) + +Return the PP function name (e.g. "pp_add") of op number OPNUM. + +=item hash(STR) + +Returns a string in the form "0x..." representing the value of the +internal hash function used by perl on string STR. + +=item cast_I32(I) + +Casts I to the internal I32 type used by that perl. + +=item minus_c + +Does the equivalent of the C<-c> command-line option. Obviously, this +is only useful in a BEGIN block or else the flag is set too late. + +=item cstring(STR) + +Returns a double-quote-surrounded escaped version of STR which can +be used as a string in C source code. + +=item perlstring(STR) + +Returns a double-quote-surrounded escaped version of STR which can +be used as a string in Perl source code. + +=item class(OBJ) + +Returns the class of an object without the part of the classname +preceding the first C<"::">. This is used to turn C<"B::UNOP"> into +C<"UNOP"> for example. + +=item threadsv_names + +In a perl compiled for threads, this returns a list of the special +per-thread threadsv variables. + +=back + + + + +=head1 OVERVIEW OF CLASSES + +The C structures used by Perl's internals to hold SV and OP +information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a +class hierarchy and the C<B> module gives access to them via a true +object hierarchy. Structure fields which point to other objects +(whether types of SV or types of OP) are represented by the C<B> +module as Perl objects of the appropriate class. + +The bulk of the C<B> module is the methods for accessing fields of +these structures. + +Note that all access is read-only. You cannot modify the internals by +using this module. Also, note that the B::OP and B::SV objects created +by this module are only valid for as long as the underlying objects +exist; their creation doesn't increase the reference counts of the +underlying objects. Trying to access the fields of a freed object will +give incomprehensible results, or worse. + +=head2 SV-RELATED CLASSES + +B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV, +B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in +the obvious way to the underlying C structures of similar names. The +inheritance hierarchy mimics the underlying C "inheritance". For 5.9.1 +and later this is: + + B::SV + | + +--------------+----------+------------+ + | | | | + B::PV B::IV B::NV B::RV + \ / / + \ / / + B::PVIV / + \ / + \ / + \ / + B::PVNV + | + | + B::PVMG + | + +-----+----+------+-----+-----+ + | | | | | | + B::BM B::AV B::GV B::HV B::CV B::IO + | | + B::PVLV | + B::FM + + +For 5.9.0 and earlier, PVLV is a direct subclass of PVMG, so the base +of this diagram is + + | + B::PVMG + | + +------+-----+----+------+-----+-----+ + | | | | | | | + B::PVLV B::BM B::AV B::GV B::HV B::CV B::IO + | + | + B::FM + + +Access methods correspond to the underlying C macros for field access, +usually with the leading "class indication" prefix removed (Sv, Av, +Hv, ...). The leading prefix is only left in cases where its removal +would cause a clash in method name. For example, C<GvREFCNT> stays +as-is since its abbreviation would clash with the "superclass" method +C<REFCNT> (corresponding to the C function C<SvREFCNT>). + +=head2 B::SV Methods + +=over 4 + +=item REFCNT + +=item FLAGS + +=item object_2svref + +Returns a reference to the regular scalar corresponding to this +B::SV object. In other words, this method is the inverse operation +to the svref_2object() subroutine. This scalar and other data it points +at should be considered read-only: modifying them is neither safe nor +guaranteed to have a sensible effect. + +=back + +=head2 B::IV Methods + +=over 4 + +=item IV + +Returns the value of the IV, I<interpreted as +a signed integer>. This will be misleading +if C<FLAGS & SVf_IVisUV>. Perhaps you want the +C<int_value> method instead? + +=item IVX + +=item UVX + +=item int_value + +This method returns the value of the IV as an integer. +It differs from C<IV> in that it returns the correct +value regardless of whether it's stored signed or +unsigned. + +=item needs64bits + +=item packiv + +=back + +=head2 B::NV Methods + +=over 4 + +=item NV + +=item NVX + +=back + +=head2 B::RV Methods + +=over 4 + +=item RV + +=back + +=head2 B::PV Methods + +=over 4 + +=item PV + +This method is the one you usually want. It constructs a +string using the length and offset information in the struct: +for ordinary scalars it will return the string that you'd see +from Perl, even if it contains null characters. + +=item RV + +Same as B::RV::RV, except that it will die() if the PV isn't +a reference. + +=item PVX + +This method is less often useful. It assumes that the string +stored in the struct is null-terminated, and disregards the +length information. + +It is the appropriate method to use if you need to get the name +of a lexical variable from a padname array. Lexical variable names +are always stored with a null terminator, and the length field +(SvCUR) is overloaded for other purposes and can't be relied on here. + +=back + +=head2 B::PVMG Methods + +=over 4 + +=item MAGIC + +=item SvSTASH + +=back + +=head2 B::MAGIC Methods + +=over 4 + +=item MOREMAGIC + +=item precomp + +Only valid on r-magic, returns the string that generated the regexp. + +=item PRIVATE + +=item TYPE + +=item FLAGS + +=item OBJ + +Will die() if called on r-magic. + +=item PTR + +=item REGEX + +Only valid on r-magic, returns the integer value of the REGEX stored +in the MAGIC. + +=back + +=head2 B::PVLV Methods + +=over 4 + +=item TARGOFF + +=item TARGLEN + +=item TYPE + +=item TARG + +=back + +=head2 B::BM Methods + +=over 4 + +=item USEFUL + +=item PREVIOUS + +=item RARE + +=item TABLE + +=back + +=head2 B::GV Methods + +=over 4 + +=item is_empty + +This method returns TRUE if the GP field of the GV is NULL. + +=item NAME + +=item SAFENAME + +This method returns the name of the glob, but if the first +character of the name is a control character, then it converts +it to ^X first, so that *^G would return "^G" rather than "\cG". + +It's useful if you want to print out the name of a variable. +If you restrict yourself to globs which exist at compile-time +then the result ought to be unambiguous, because code like +C<${"^G"} = 1> is compiled as two ops - a constant string and +a dereference (rv2gv) - so that the glob is created at runtime. + +If you're working with globs at runtime, and need to disambiguate +*^G from *{"^G"}, then you should use the raw NAME method. + +=item STASH + +=item SV + +=item IO + +=item FORM + +=item AV + +=item HV + +=item EGV + +=item CV + +=item CVGEN + +=item LINE + +=item FILE + +=item FILEGV + +=item GvREFCNT + +=item FLAGS + +=back + +=head2 B::IO Methods + +=over 4 + +=item LINES + +=item PAGE + +=item PAGE_LEN + +=item LINES_LEFT + +=item TOP_NAME + +=item TOP_GV + +=item FMT_NAME + +=item FMT_GV + +=item BOTTOM_NAME + +=item BOTTOM_GV + +=item SUBPROCESS + +=item IoTYPE + +=item IoFLAGS + +=item IsSTD + +Takes one arguments ( 'stdin' | 'stdout' | 'stderr' ) and returns true +if the IoIFP of the object is equal to the handle whose name was +passed as argument ( i.e. $io->IsSTD('stderr') is true if +IoIFP($io) == PerlIO_stdin() ). + +=back + +=head2 B::AV Methods + +=over 4 + +=item FILL + +=item MAX + +=item OFF + +=item ARRAY + +=item ARRAYelt + +Like C<ARRAY>, but takes an index as an argument to get only one element, +rather than a list of all of them. + +=item AvFLAGS + +=back + +=head2 B::CV Methods + +=over 4 + +=item STASH + +=item START + +=item ROOT + +=item GV + +=item FILE + +=item DEPTH + +=item PADLIST + +=item OUTSIDE + +=item OUTSIDE_SEQ + +=item XSUB + +=item XSUBANY + +For constant subroutines, returns the constant SV returned by the subroutine. + +=item CvFLAGS + +=item const_sv + +=back + +=head2 B::HV Methods + +=over 4 + +=item FILL + +=item MAX + +=item KEYS + +=item RITER + +=item NAME + +=item PMROOT + +=item ARRAY + +=back + +=head2 OP-RELATED CLASSES + +C<B::OP>, C<B::UNOP>, C<B::BINOP>, C<B::LOGOP>, C<B::LISTOP>, C<B::PMOP>, +C<B::SVOP>, C<B::PADOP>, C<B::PVOP>, C<B::LOOP>, C<B::COP>. + +These classes correspond in the obvious way to the underlying C +structures of similar names. The inheritance hierarchy mimics the +underlying C "inheritance": + + B::OP + | + +---------------+--------+--------+ + | | | | + B::UNOP B::SVOP B::PADOP B::COP + ,' `-. + / `--. + B::BINOP B::LOGOP + | + | + B::LISTOP + ,' `. + / \ + B::LOOP B::PMOP + +Access methods correspond to the underlying C structre field names, +with the leading "class indication" prefix (C<"op_">) removed. + +=head2 B::OP Methods + +These methods get the values of similarly named fields within the OP +data structure. See top of C<op.h> for more info. + +=over 4 + +=item next + +=item sibling + +=item name + +This returns the op name as a string (e.g. "add", "rv2av"). + +=item ppaddr + +This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]", +"PL_ppaddr[OP_RV2AV]"). + +=item desc + +This returns the op description from the global C PL_op_desc array +(e.g. "addition" "array deref"). + +=item targ + +=item type + +=item opt + +=item static + +=item flags + +=item private + +=item spare + +=back + +=head2 B::UNOP METHOD + +=over 4 + +=item first + +=back + +=head2 B::BINOP METHOD + +=over 4 + +=item last + +=back + +=head2 B::LOGOP METHOD + +=over 4 + +=item other + +=back + +=head2 B::LISTOP METHOD + +=over 4 + +=item children + +=back + +=head2 B::PMOP Methods + +=over 4 + +=item pmreplroot + +=item pmreplstart + +=item pmnext + +=item pmregexp + +=item pmflags + +=item pmdynflags + +=item pmpermflags + +=item precomp + +=item pmoffset + +Only when perl was compiled with ithreads. + +=back + +=head2 B::SVOP METHOD + +=over 4 + +=item sv + +=item gv + +=back + +=head2 B::PADOP METHOD + +=over 4 + +=item padix + +=back + +=head2 B::PVOP METHOD + +=over 4 + +=item pv + +=back + +=head2 B::LOOP Methods + +=over 4 + +=item redoop + +=item nextop + +=item lastop + +=back + +=head2 B::COP Methods + +=over 4 + +=item label + +=item stash + +=item stashpv + +=item file + +=item cop_seq + +=item arybase + +=item line + +=item warnings + +=item io + +=back + + +=head1 AUTHOR + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Asmdata.pm b/Master/tlpkg/installer/perllib/B/Asmdata.pm new file mode 100644 index 00000000000..9e41d6dd757 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Asmdata.pm @@ -0,0 +1,250 @@ +# -#- buffer-read-only: t -#- +# +# Copyright (c) 1996-1999 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +# +# +# This file is autogenerated from bytecode.pl. Changes made here will be lost. +# +package B::Asmdata; + +our $VERSION = '1.01'; + +use Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name); +our(%insn_data, @insn_name, @optype, @specialsv_name); + +@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP); +@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE); + +# XXX insn_data is initialised this way because with a large +# %insn_data = (foo => [...], bar => [...], ...) initialiser +# I get a hard-to-track-down stack underflow and segfault. +$insn_data{comment} = [35, \&PUT_comment_t, "GET_comment_t"]; +$insn_data{nop} = [10, \&PUT_none, "GET_none"]; +$insn_data{ret} = [0, \&PUT_none, "GET_none"]; +$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"]; +$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"]; +$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"]; +$insn_data{stop} = [4, \&PUT_U32, "GET_U32"]; +$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"]; +$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"]; +$insn_data{ldspecsvx} = [7, \&PUT_U8, "GET_U8"]; +$insn_data{newsv} = [8, \&PUT_U8, "GET_U8"]; +$insn_data{newsvx} = [9, \&PUT_U32, "GET_U32"]; +$insn_data{newop} = [11, \&PUT_U8, "GET_U8"]; +$insn_data{newopx} = [12, \&PUT_U16, "GET_U16"]; +$insn_data{newopn} = [13, \&PUT_U8, "GET_U8"]; +$insn_data{newpv} = [14, \&PUT_PV, "GET_PV"]; +$insn_data{pv_cur} = [15, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{pv_free} = [16, \&PUT_none, "GET_none"]; +$insn_data{sv_upgrade} = [17, \&PUT_U8, "GET_U8"]; +$insn_data{sv_refcnt} = [18, \&PUT_U32, "GET_U32"]; +$insn_data{sv_refcnt_add} = [19, \&PUT_I32, "GET_I32"]; +$insn_data{sv_flags} = [20, \&PUT_U32, "GET_U32"]; +$insn_data{xrv} = [21, \&PUT_svindex, "GET_svindex"]; +$insn_data{xpv} = [22, \&PUT_none, "GET_none"]; +$insn_data{xpv_cur} = [23, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{xpv_len} = [24, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{xiv} = [25, \&PUT_IV, "GET_IV"]; +$insn_data{xnv} = [26, \&PUT_NV, "GET_NV"]; +$insn_data{xlv_targoff} = [27, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{xlv_targlen} = [28, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{xlv_targ} = [29, \&PUT_svindex, "GET_svindex"]; +$insn_data{xlv_type} = [30, \&PUT_U8, "GET_U8"]; +$insn_data{xbm_useful} = [31, \&PUT_I32, "GET_I32"]; +$insn_data{xbm_previous} = [32, \&PUT_U16, "GET_U16"]; +$insn_data{xbm_rare} = [33, \&PUT_U8, "GET_U8"]; +$insn_data{xfm_lines} = [34, \&PUT_IV, "GET_IV"]; +$insn_data{xio_lines} = [36, \&PUT_IV, "GET_IV"]; +$insn_data{xio_page} = [37, \&PUT_IV, "GET_IV"]; +$insn_data{xio_page_len} = [38, \&PUT_IV, "GET_IV"]; +$insn_data{xio_lines_left} = [39, \&PUT_IV, "GET_IV"]; +$insn_data{xio_top_name} = [40, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{xio_top_gv} = [41, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_fmt_name} = [42, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{xio_fmt_gv} = [43, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_bottom_name} = [44, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{xio_bottom_gv} = [45, \&PUT_svindex, "GET_svindex"]; +$insn_data{xio_subprocess} = [46, \&PUT_U16, "GET_U16"]; +$insn_data{xio_type} = [47, \&PUT_U8, "GET_U8"]; +$insn_data{xio_flags} = [48, \&PUT_U8, "GET_U8"]; +$insn_data{xcv_xsubany} = [49, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_stash} = [50, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_start} = [51, \&PUT_opindex, "GET_opindex"]; +$insn_data{xcv_root} = [52, \&PUT_opindex, "GET_opindex"]; +$insn_data{xcv_gv} = [53, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_file} = [54, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{xcv_depth} = [55, \&PUT_long, "GET_long"]; +$insn_data{xcv_padlist} = [56, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_outside} = [57, \&PUT_svindex, "GET_svindex"]; +$insn_data{xcv_outside_seq} = [58, \&PUT_U32, "GET_U32"]; +$insn_data{xcv_flags} = [59, \&PUT_U16, "GET_U16"]; +$insn_data{av_extend} = [60, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{av_pushx} = [61, \&PUT_svindex, "GET_svindex"]; +$insn_data{av_push} = [62, \&PUT_svindex, "GET_svindex"]; +$insn_data{xav_fill} = [63, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{xav_max} = [64, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{xav_flags} = [65, \&PUT_U8, "GET_U8"]; +$insn_data{xhv_riter} = [66, \&PUT_I32, "GET_I32"]; +$insn_data{xhv_name} = [67, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{xhv_pmroot} = [68, \&PUT_opindex, "GET_opindex"]; +$insn_data{hv_store} = [69, \&PUT_svindex, "GET_svindex"]; +$insn_data{sv_magic} = [70, \&PUT_U8, "GET_U8"]; +$insn_data{mg_obj} = [71, \&PUT_svindex, "GET_svindex"]; +$insn_data{mg_private} = [72, \&PUT_U16, "GET_U16"]; +$insn_data{mg_flags} = [73, \&PUT_U8, "GET_U8"]; +$insn_data{mg_name} = [74, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{mg_namex} = [75, \&PUT_svindex, "GET_svindex"]; +$insn_data{xmg_stash} = [76, \&PUT_svindex, "GET_svindex"]; +$insn_data{gv_fetchpv} = [77, \&PUT_strconst, "GET_strconst"]; +$insn_data{gv_fetchpvx} = [78, \&PUT_strconst, "GET_strconst"]; +$insn_data{gv_stashpv} = [79, \&PUT_strconst, "GET_strconst"]; +$insn_data{gv_stashpvx} = [80, \&PUT_strconst, "GET_strconst"]; +$insn_data{gp_sv} = [81, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_refcnt} = [82, \&PUT_U32, "GET_U32"]; +$insn_data{gp_refcnt_add} = [83, \&PUT_I32, "GET_I32"]; +$insn_data{gp_av} = [84, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_hv} = [85, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_cv} = [86, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_file} = [87, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{gp_io} = [88, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_form} = [89, \&PUT_svindex, "GET_svindex"]; +$insn_data{gp_cvgen} = [90, \&PUT_U32, "GET_U32"]; +$insn_data{gp_line} = [91, \&PUT_U32, "GET_U32"]; +$insn_data{gp_share} = [92, \&PUT_svindex, "GET_svindex"]; +$insn_data{xgv_flags} = [93, \&PUT_U8, "GET_U8"]; +$insn_data{op_next} = [94, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_sibling} = [95, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_ppaddr} = [96, \&PUT_strconst, "GET_strconst"]; +$insn_data{op_targ} = [97, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{op_type} = [98, \&PUT_U16, "GET_U16"]; +$insn_data{op_seq} = [99, \&PUT_U16, "GET_U16"]; +$insn_data{op_flags} = [100, \&PUT_U8, "GET_U8"]; +$insn_data{op_private} = [101, \&PUT_U8, "GET_U8"]; +$insn_data{op_first} = [102, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_last} = [103, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_other} = [104, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmreplroot} = [105, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmreplstart} = [106, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmnext} = [107, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmstashpv} = [108, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{op_pmreplrootpo} = [109, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{op_pmstash} = [110, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_pmreplrootgv} = [111, \&PUT_svindex, "GET_svindex"]; +$insn_data{pregcomp} = [112, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pmflags} = [113, \&PUT_U16, "GET_U16"]; +$insn_data{op_pmpermflags} = [114, \&PUT_U16, "GET_U16"]; +$insn_data{op_pmdynflags} = [115, \&PUT_U8, "GET_U8"]; +$insn_data{op_sv} = [116, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_padix} = [117, \&PUT_PADOFFSET, "GET_PADOFFSET"]; +$insn_data{op_pv} = [118, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pv_tr} = [119, \&PUT_op_tr_array, "GET_op_tr_array"]; +$insn_data{op_redoop} = [120, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_nextop} = [121, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_lastop} = [122, \&PUT_opindex, "GET_opindex"]; +$insn_data{cop_label} = [123, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{cop_stashpv} = [124, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{cop_file} = [125, \&PUT_pvindex, "GET_pvindex"]; +$insn_data{cop_stash} = [126, \&PUT_svindex, "GET_svindex"]; +$insn_data{cop_filegv} = [127, \&PUT_svindex, "GET_svindex"]; +$insn_data{cop_seq} = [128, \&PUT_U32, "GET_U32"]; +$insn_data{cop_arybase} = [129, \&PUT_I32, "GET_I32"]; +$insn_data{cop_line} = [130, \&PUT_U32, "GET_U32"]; +$insn_data{cop_io} = [131, \&PUT_svindex, "GET_svindex"]; +$insn_data{cop_warnings} = [132, \&PUT_svindex, "GET_svindex"]; +$insn_data{main_start} = [133, \&PUT_opindex, "GET_opindex"]; +$insn_data{main_root} = [134, \&PUT_opindex, "GET_opindex"]; +$insn_data{main_cv} = [135, \&PUT_svindex, "GET_svindex"]; +$insn_data{curpad} = [136, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_begin} = [137, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_init} = [138, \&PUT_svindex, "GET_svindex"]; +$insn_data{push_end} = [139, \&PUT_svindex, "GET_svindex"]; +$insn_data{curstash} = [140, \&PUT_svindex, "GET_svindex"]; +$insn_data{defstash} = [141, \&PUT_svindex, "GET_svindex"]; +$insn_data{data} = [142, \&PUT_U8, "GET_U8"]; +$insn_data{incav} = [143, \&PUT_svindex, "GET_svindex"]; +$insn_data{load_glob} = [144, \&PUT_svindex, "GET_svindex"]; +$insn_data{regex_padav} = [145, \&PUT_svindex, "GET_svindex"]; +$insn_data{dowarn} = [146, \&PUT_U8, "GET_U8"]; +$insn_data{comppad_name} = [147, \&PUT_svindex, "GET_svindex"]; +$insn_data{xgv_stash} = [148, \&PUT_svindex, "GET_svindex"]; +$insn_data{signal} = [149, \&PUT_strconst, "GET_strconst"]; +$insn_data{formfeed} = [150, \&PUT_svindex, "GET_svindex"]; + +my ($insn_name, $insn_data); +while (($insn_name, $insn_data) = each %insn_data) { + $insn_name[$insn_data->[0]] = $insn_name; +} +# Fill in any gaps +@insn_name = map($_ || "unused", @insn_name); + +1; + +__END__ + +=head1 NAME + +B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode + +=head1 SYNOPSIS + + use B::Asmdata qw(%insn_data @insn_name @optype @specialsv_name); + +=head1 DESCRIPTION + +Provides information about Perl ops in order to generate bytecode via +a bunch of exported variables. Its mostly used by B::Assembler and +B::Disassembler. + +=over 4 + +=item %insn_data + + my($bytecode_num, $put_sub, $get_meth) = @$insn_data{$op_name}; + +For a given $op_name (for example, 'cop_label', 'sv_flags', etc...) +you get an array ref containing the bytecode number of the op, a +reference to the subroutine used to 'PUT', and the name of the method +used to 'GET'. + +=for _private +Add more detail about what $put_sub and $get_meth are and how to use them. + +=item @insn_name + + my $op_name = $insn_name[$bytecode_num]; + +A simple mapping of the bytecode number to the name of the op. +Suitable for using with %insn_data like so: + + my $op_info = $insn_data{$insn_name[$bytecode_num]}; + +=item @optype + + my $op_type = $optype[$op_type_num]; + +A simple mapping of the op type number to its type (like 'COP' or 'BINOP'). + +=item @specialsv_name + + my $sv_name = $specialsv_name[$sv_index]; + +Certain SV types are considered 'special'. They're represented by +B::SPECIAL and are referred to by a number from the specialsv_list. +This array maps that number back to the name of the SV (like 'Nullsv' +or '&PL_sv_undef'). + +=back + +=head1 AUTHOR + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> + +=cut + +# ex: set ro: diff --git a/Master/tlpkg/installer/perllib/B/Assembler.pm b/Master/tlpkg/installer/perllib/B/Assembler.pm new file mode 100644 index 00000000000..f312273ce36 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Assembler.pm @@ -0,0 +1,328 @@ +# Assembler.pm +# +# Copyright (c) 1996 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. + +package B::Assembler; +use Exporter; +use B qw(ppname); +use B::Asmdata qw(%insn_data @insn_name); +use Config qw(%Config); +require ByteLoader; # we just need its $VERSION + +no warnings; # XXX + +@ISA = qw(Exporter); +@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm); +$VERSION = 0.07; + +use strict; +my %opnumber; +my ($i, $opname); +for ($i = 0; defined($opname = ppname($i)); $i++) { + $opnumber{$opname} = $i; +} + +my($linenum, $errors, $out); # global state, set up by newasm + +sub error { + my $str = shift; + warn "$linenum: $str\n"; + $errors++; +} + +my $debug = 0; +sub debug { $debug = shift } + +sub limcheck($$$$){ + my( $val, $lo, $hi, $loc ) = @_; + if( $val < $lo || $hi < $val ){ + error "argument for $loc outside [$lo, $hi]: $val"; + $val = $hi; + } + return $val; +} + +# +# First define all the data conversion subs to which Asmdata will refer +# + +sub B::Asmdata::PUT_U8 { + my $arg = shift; + my $c = uncstring($arg); + if (defined($c)) { + if (length($c) != 1) { + error "argument for U8 is too long: $c"; + $c = substr($c, 0, 1); + } + } else { + $arg = limcheck( $arg, 0, 0xff, 'U8' ); + $c = chr($arg); + } + return $c; +} + +sub B::Asmdata::PUT_U16 { + my $arg = limcheck( $_[0], 0, 0xffff, 'U16' ); + pack("S", $arg); +} +sub B::Asmdata::PUT_U32 { + my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' ); + pack("L", $arg); +} +sub B::Asmdata::PUT_I32 { + my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' ); + pack("l", $arg); +} +sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...) + # may not even be portable between compilers +sub B::Asmdata::PUT_objindex { # could allow names here + my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' ); + pack("L", $arg); +} +sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex } +sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex } +sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex } + +sub B::Asmdata::PUT_strconst { + my $arg = shift; + my $str = uncstring($arg); + if (!defined($str)) { + error "bad string constant: $arg"; + $str = ''; + } + if ($str =~ s/\0//g) { + error "string constant argument contains NUL: $arg"; + $str = ''; + } + return $str . "\0"; +} + +sub B::Asmdata::PUT_pvcontents { + my $arg = shift; + error "extraneous argument: $arg" if defined $arg; + return ""; +} +sub B::Asmdata::PUT_PV { + my $arg = shift; + my $str = uncstring($arg); + if( ! defined($str) ){ + error "bad string argument: $arg"; + $str = ''; + } + return pack("L", length($str)) . $str; +} +sub B::Asmdata::PUT_comment_t { + my $arg = shift; + $arg = uncstring($arg); + error "bad string argument: $arg" unless defined($arg); + if ($arg =~ s/\n//g) { + error "comment argument contains linefeed: $arg"; + } + return $arg . "\n"; +} +sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above +sub B::Asmdata::PUT_none { + my $arg = shift; + error "extraneous argument: $arg" if defined $arg; + return ""; +} +sub B::Asmdata::PUT_op_tr_array { + my @ary = split /\s*,\s*/, shift; + return pack "S*", @ary; +} + +sub B::Asmdata::PUT_IV64 { + return pack "Q", shift; +} + +sub B::Asmdata::PUT_IV { + $Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64; +} + +sub B::Asmdata::PUT_PADOFFSET { + $Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32; +} + +sub B::Asmdata::PUT_long { + $Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32; +} + +my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a", + b => "\b", f => "\f", v => "\013"); + +sub uncstring { + my $s = shift; + $s =~ s/^"// and $s =~ s/"$// or return undef; + $s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg; + return $s; +} + +sub strip_comments { + my $stmt = shift; + # Comments only allowed in instructions which don't take string arguments + # Treat string as a single line so .* eats \n characters. + $stmt =~ s{ + ^\s* # Ignore leading whitespace + ( + [^"]* # A double quote '"' indicates a string argument. If we + # find a double quote, the match fails and we strip nothing. + ) + \s*\# # Any amount of whitespace plus the comment marker... + .*$ # ...which carries on to end-of-string. + }{$1}sx; # Keep only the instruction and optional argument. + return $stmt; +} + +# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize, +# ptrsize, byteorder +# nvtype is irrelevant (floats are stored as strings) +# byteorder is strconst not U32 because of varying size issues + +sub gen_header { + my $header = ""; + + $header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC' + $header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"'); + $header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]); + $header .= B::Asmdata::PUT_U32($Config{ivsize}); + $header .= B::Asmdata::PUT_U32($Config{ptrsize}); + $header; +} + +sub parse_statement { + my $stmt = shift; + my ($insn, $arg) = $stmt =~ m{ + ^\s* # allow (but ignore) leading whitespace + (.*?) # Instruction continues up until... + (?: # ...an optional whitespace+argument group + \s+ # first whitespace. + (.*) # The argument is all the rest (newlines included). + )?$ # anchor at end-of-line + }sx; + if (defined($arg)) { + if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) { + $arg = hex($arg); + } elsif ($arg =~ s/^0(?=[0-7]+$)//) { + $arg = oct($arg); + } elsif ($arg =~ /^pp_/) { + $arg =~ s/\s*$//; # strip trailing whitespace + my $opnum = $opnumber{$arg}; + if (defined($opnum)) { + $arg = $opnum; + } else { + error qq(No such op type "$arg"); + $arg = 0; + } + } + } + return ($insn, $arg); +} + +sub assemble_insn { + my ($insn, $arg) = @_; + my $data = $insn_data{$insn}; + if (defined($data)) { + my ($bytecode, $putsub) = @{$data}[0, 1]; + my $argcode = &$putsub($arg); + return chr($bytecode).$argcode; + } else { + error qq(no such instruction "$insn"); + return ""; + } +} + +sub assemble_fh { + my ($fh, $out) = @_; + my $line; + my $asm = newasm($out); + while ($line = <$fh>) { + assemble($line); + } + endasm(); +} + +sub newasm { + my($outsub) = @_; + + die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE'; + die <<EOD if ref $out; +Can't have multiple byteassembly sessions at once! + (perhaps you forgot an endasm()?) +EOD + + $linenum = $errors = 0; + $out = $outsub; + + $out->(gen_header()); +} + +sub endasm { + if ($errors) { + die "There were $errors assembly errors\n"; + } + $linenum = $errors = $out = 0; +} + +sub assemble { + my($line) = @_; + my ($insn, $arg); + $linenum++; + chomp $line; + if ($debug) { + my $quotedline = $line; + $quotedline =~ s/\\/\\\\/g; + $quotedline =~ s/"/\\"/g; + $out->(assemble_insn("comment", qq("$quotedline"))); + } + if( $line = strip_comments($line) ){ + ($insn, $arg) = parse_statement($line); + $out->(assemble_insn($insn, $arg)); + if ($debug) { + $out->(assemble_insn("nop", undef)); + } + } +} + +### temporary workaround + +sub asm { + return if $_[0] =~ /\s*\W/; + if (defined $_[1]) { + return if $_[1] eq "0" and + $_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/; + return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/; + } + assemble "@_"; +} + +1; + +__END__ + +=head1 NAME + +B::Assembler - Assemble Perl bytecode + +=head1 SYNOPSIS + + use B::Assembler qw(newasm endasm assemble); + newasm(\&printsub); # sets up for assembly + assemble($buf); # assembles one line + endasm(); # closes down + + use B::Assembler qw(assemble_fh); + assemble_fh($fh, \&printsub); # assemble everything in $fh + +=head1 DESCRIPTION + +See F<ext/B/B/Assembler.pm>. + +=head1 AUTHORS + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> +Per-statement interface by Benjamin Stuhl, C<sho_pi@hotmail.com> + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Bblock.pm b/Master/tlpkg/installer/perllib/B/Bblock.pm new file mode 100644 index 00000000000..9566d125aaa --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Bblock.pm @@ -0,0 +1,224 @@ +package B::Bblock; + +our $VERSION = '1.02_01'; + +use Exporter (); +@ISA = "Exporter"; +@EXPORT_OK = qw(find_leaders); + +use B qw(peekop walkoptree walkoptree_exec + main_root main_start svref_2object + OPf_SPECIAL OPf_STACKED ); + +use B::Concise qw(concise_cv concise_main set_style_standard); +use strict; + +my $bblock; +my @bblock_ends; + +sub mark_leader { + my $op = shift; + if ($$op) { + $bblock->{$$op} = $op; + } +} + +sub remove_sortblock{ + foreach (keys %$bblock){ + my $leader=$$bblock{$_}; + delete $$bblock{$_} if( $leader == 0); + } +} +sub find_leaders { + my ($root, $start) = @_; + $bblock = {}; + mark_leader($start) if ( ref $start ne "B::NULL" ); + walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ; + remove_sortblock(); + return $bblock; +} + +# Debugging +sub walk_bblocks { + my ($root, $start) = @_; + my ($op, $lastop, $leader, $bb); + $bblock = {}; + mark_leader($start); + walkoptree($root, "mark_if_leader"); + my @leaders = values %$bblock; + while ($leader = shift @leaders) { + $lastop = $leader; + $op = $leader->next; + while ($$op && !exists($bblock->{$$op})) { + $bblock->{$$op} = $leader; + $lastop = $op; + $op = $op->next; + } + push(@bblock_ends, [$leader, $lastop]); + } + foreach $bb (@bblock_ends) { + ($leader, $lastop) = @$bb; + printf "%s .. %s\n", peekop($leader), peekop($lastop); + for ($op = $leader; $$op != $$lastop; $op = $op->next) { + printf " %s\n", peekop($op); + } + printf " %s\n", peekop($lastop); + } +} + +sub walk_bblocks_obj { + my $cvref = shift; + my $cv = svref_2object($cvref); + walk_bblocks($cv->ROOT, $cv->START); +} + +sub B::OP::mark_if_leader {} + +sub B::COP::mark_if_leader { + my $op = shift; + if ($op->label) { + mark_leader($op); + } +} + +sub B::LOOP::mark_if_leader { + my $op = shift; + mark_leader($op->next); + mark_leader($op->nextop); + mark_leader($op->redoop); + mark_leader($op->lastop->next); +} + +sub B::LOGOP::mark_if_leader { + my $op = shift; + my $opname = $op->name; + mark_leader($op->next); + if ($opname eq "entertry") { + mark_leader($op->other->next); + } else { + mark_leader($op->other); + } +} + +sub B::LISTOP::mark_if_leader { + my $op = shift; + my $first=$op->first; + $first=$first->next while ($first->name eq "null"); + mark_leader($op->first) unless (exists( $bblock->{$$first})); + mark_leader($op->next); + if ($op->name eq "sort" and $op->flags & OPf_SPECIAL + and $op->flags & OPf_STACKED){ + my $root=$op->first->sibling->first; + my $leader=$root->first; + $bblock->{$$leader} = 0; + } +} + +sub B::PMOP::mark_if_leader { + my $op = shift; + if ($op->name ne "pushre") { + my $replroot = $op->pmreplroot; + if ($$replroot) { + mark_leader($replroot); + mark_leader($op->next); + mark_leader($op->pmreplstart); + } + } +} + +# PMOP stuff omitted + +sub compile { + my @options = @_; + B::clearsym(); + if (@options) { + return sub { + my $objname; + foreach $objname (@options) { + $objname = "main::$objname" unless $objname =~ /::/; + eval "walk_bblocks_obj(\\&$objname)"; + die "walk_bblocks_obj(\\&$objname) failed: $@" if $@; + print "-------\n"; + set_style_standard("terse"); + eval "concise_cv('exec', \\&$objname)"; + die "concise_cv('exec', \\&$objname) failed: $@" if $@; + } + } + } else { + return sub { + walk_bblocks(main_root, main_start); + print "-------\n"; + set_style_standard("terse"); + concise_main("exec"); + }; + } +} + +# Basic block leaders: +# Any COP (pp_nextstate) with a non-NULL label +# [The op after a pp_enter] Omit +# [The op after a pp_entersub. Don't count this one.] +# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP +# The ops pointed at by op_next and op_other of a LOGOP, except +# for pp_entertry which has op_next and op_other->op_next +# The op pointed at by op_pmreplstart of a PMOP +# The op pointed at by op_other->op_pmreplstart of pp_substcont? +# [The op after a pp_return] Omit + +1; + +__END__ + +=head1 NAME + +B::Bblock - Walk basic blocks + +=head1 SYNOPSIS + + # External interface + perl -MO=Bblock[,OPTIONS] foo.pl + + # Programmatic API + use B::Bblock qw(find_leaders); + my $leaders = find_leaders($root_op, $start_op); + +=head1 DESCRIPTION + +This module is used by the B::CC back end. It walks "basic blocks". +A basic block is a series of operations which is known to execute from +start to finish, with no possibility of branching or halting. + +It can be used either stand alone or from inside another program. + +=for _private +Somebody who understands the stand-alone options document them, please. + +=head2 Functions + +=over 4 + +=item B<find_leaders> + + my $leaders = find_leaders($root_op, $start_op); + +Given the root of the op tree and an op from which to start +processing, it will return a hash ref representing all the ops which +start a block. + +=for _private +The above description may be somewhat wrong. + +The values of %$leaders are the op objects themselves. Keys are $$op +addresses. + +=for _private +Above cribbed from B::CC's comments. What's a $$op address? + +=back + + +=head1 AUTHOR + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Bytecode.pm b/Master/tlpkg/installer/perllib/B/Bytecode.pm new file mode 100644 index 00000000000..250569ae57b --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Bytecode.pm @@ -0,0 +1,889 @@ +# B::Bytecode.pm +# Copyright (c) 2003 Enache Adrian. All rights reserved. +# This module is free software; you can redistribute and/or modify +# it under the same terms as Perl itself. + +# Based on the original Bytecode.pm module written by Malcolm Beattie. + +package B::Bytecode; + +our $VERSION = '1.01_01'; + +use strict; +use Config; +use B qw(class main_cv main_root main_start cstring comppadlist + defstash curstash begin_av init_av end_av inc_gv warnhook diehook + dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD + OPpLVAL_INTRO SVf_FAKE SVf_READONLY); +use B::Asmdata qw(@specialsv_name); +use B::Assembler qw(asm newasm endasm); + +################################################# + +my ($varix, $opix, $savebegins, %walked, %files, @cloop); +my %strtab = (0,0); +my %svtab = (0,0); +my %optab = (0,0); +my %spectab = (0,0); +my $tix = 1; +sub asm; +sub nice ($) { } + +BEGIN { + my $ithreads = $Config{'useithreads'} eq 'define'; + eval qq{ + sub ITHREADS() { $ithreads } + sub VERSION() { $] } + }; die $@ if $@; +} + +################################################# + +sub pvstring { + my $pv = shift; + defined($pv) ? cstring ($pv."\0") : "\"\""; +} + +sub pvix { + my $str = pvstring shift; + my $ix = $strtab{$str}; + defined($ix) ? $ix : do { + asm "newpv", $str; + asm "stpv", $strtab{$str} = $tix; + $tix++; + } +} + +sub B::OP::ix { + my $op = shift; + my $ix = $optab{$$op}; + defined($ix) ? $ix : do { + nice "[".$op->name." $tix]"; + asm "newopx", $op->size | $op->type <<7; + $optab{$$op} = $opix = $ix = $tix++; + $op->bsave($ix); + $ix; + } +} + +sub B::SPECIAL::ix { + my $spec = shift; + my $ix = $spectab{$$spec}; + defined($ix) ? $ix : do { + nice '['.$specialsv_name[$$spec].']'; + asm "ldspecsvx", $$spec; + $spectab{$$spec} = $varix = $tix++; + } +} + +sub B::SV::ix { + my $sv = shift; + my $ix = $svtab{$$sv}; + defined($ix) ? $ix : do { + nice '['.class($sv).']'; + asm "newsvx", $sv->FLAGS; + $svtab{$$sv} = $varix = $ix = $tix++; + $sv->bsave($ix); + $ix; + } +} + +sub B::GV::ix { + my ($gv,$desired) = @_; + my $ix = $svtab{$$gv}; + defined($ix) ? $ix : do { + if ($gv->GP) { + my ($svix, $avix, $hvix, $cvix, $ioix, $formix); + nice "[GV]"; + my $name = $gv->STASH->NAME . "::" . $gv->NAME; + asm "gv_fetchpvx", cstring $name; + $svtab{$$gv} = $varix = $ix = $tix++; + asm "sv_flags", $gv->FLAGS; + asm "sv_refcnt", $gv->REFCNT; + asm "xgv_flags", $gv->GvFLAGS; + + asm "gp_refcnt", $gv->GvREFCNT; + asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob"; + return $ix + unless $desired || desired $gv; + $svix = $gv->SV->ix; + $avix = $gv->AV->ix; + $hvix = $gv->HV->ix; + + # XXX {{{{ + my $cv = $gv->CV; + $cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0; + my $form = $gv->FORM; + $formix = $$form && defined $files{$form->FILE} ? $form->ix : 0; + + $ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0; + # }}}} XXX + + nice "-GV-", + asm "ldsv", $varix = $ix unless $ix == $varix; + asm "gp_sv", $svix; + asm "gp_av", $avix; + asm "gp_hv", $hvix; + asm "gp_cv", $cvix; + asm "gp_io", $ioix; + asm "gp_cvgen", $gv->CVGEN; + asm "gp_form", $formix; + asm "gp_file", pvix $gv->FILE; + asm "gp_line", $gv->LINE; + asm "formfeed", $svix if $name eq "main::\cL"; + } else { + nice "[GV]"; + asm "newsvx", $gv->FLAGS; + $svtab{$$gv} = $varix = $ix = $tix++; + my $stashix = $gv->STASH->ix; + $gv->B::PVMG::bsave($ix); + asm "xgv_flags", $gv->GvFLAGS; + asm "xgv_stash", $stashix; + } + $ix; + } +} + +sub B::HV::ix { + my $hv = shift; + my $ix = $svtab{$$hv}; + defined($ix) ? $ix : do { + my ($ix,$i,@array); + my $name = $hv->NAME; + if ($name) { + nice "[STASH]"; + asm "gv_stashpvx", cstring $name; + asm "sv_flags", $hv->FLAGS; + $svtab{$$hv} = $varix = $ix = $tix++; + asm "xhv_name", pvix $name; + # my $pmrootix = $hv->PMROOT->ix; # XXX + asm "ldsv", $varix = $ix unless $ix == $varix; + # asm "xhv_pmroot", $pmrootix; # XXX + } else { + nice "[HV]"; + asm "newsvx", $hv->FLAGS; + $svtab{$$hv} = $varix = $ix = $tix++; + my $stashix = $hv->SvSTASH->ix; + for (@array = $hv->ARRAY) { + next if $i = not $i; + $_ = $_->ix; + } + nice "-HV-", + asm "ldsv", $varix = $ix unless $ix == $varix; + ($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_) + for @array; + if (VERSION < 5.009) { + asm "xnv", $hv->NVX; + } + asm "xmg_stash", $stashix; + asm "xhv_riter", $hv->RITER; + } + asm "sv_refcnt", $hv->REFCNT; + $ix; + } +} + +sub B::NULL::ix { + my $sv = shift; + $$sv ? $sv->B::SV::ix : 0; +} + +sub B::NULL::opwalk { 0 } + +################################################# + +sub B::NULL::bsave { + my ($sv,$ix) = @_; + + nice '-'.class($sv).'-', + asm "ldsv", $varix = $ix unless $ix == $varix; + asm "sv_refcnt", $sv->REFCNT; +} + +sub B::SV::bsave; + *B::SV::bsave = *B::NULL::bsave; + +sub B::RV::bsave { + my ($sv,$ix) = @_; + my $rvix = $sv->RV->ix; + $sv->B::NULL::bsave($ix); + asm "xrv", $rvix; +} + +sub B::PV::bsave { + my ($sv,$ix) = @_; + $sv->B::NULL::bsave($ix); + asm "newpv", pvstring $sv->PVBM; + asm "xpv"; +} + +sub B::IV::bsave { + my ($sv,$ix) = @_; + $sv->B::NULL::bsave($ix); + asm "xiv", $sv->IVX; +} + +sub B::NV::bsave { + my ($sv,$ix) = @_; + $sv->B::NULL::bsave($ix); + asm "xnv", sprintf "%.40g", $sv->NVX; +} + +sub B::PVIV::bsave { + my ($sv,$ix) = @_; + $sv->POK ? + $sv->B::PV::bsave($ix): + $sv->ROK ? + $sv->B::RV::bsave($ix): + $sv->B::NULL::bsave($ix); + if (VERSION >= 5.009) { + # See note below in B::PVNV::bsave + return if $sv->isa('B::AV'); + return if $sv->isa('B::HV'); + } + asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ? + "0 but true" : $sv->IVX; +} + +sub B::PVNV::bsave { + my ($sv,$ix) = @_; + $sv->B::PVIV::bsave($ix); + if (VERSION >= 5.009) { + # Magical AVs end up here, but AVs now don't have an NV slot actually + # allocated. Hence don't write out assembly to store the NV slot if + # we're actually an array. + return if $sv->isa('B::AV'); + # Likewise HVs have no NV slot actually allocated. + # I don't think that they can get here, but better safe than sorry + return if $sv->isa('B::HV'); + } + asm "xnv", sprintf "%.40g", $sv->NVX; +} + +sub B::PVMG::domagic { + my ($sv,$ix) = @_; + nice '-MAGICAL-'; + my @mglist = $sv->MAGIC; + my (@mgix, @namix); + for (@mglist) { + push @mgix, $_->OBJ->ix; + push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY; + } + + nice '-'.class($sv).'-', + asm "ldsv", $varix = $ix unless $ix == $varix; + for (@mglist) { + asm "sv_magic", cstring $_->TYPE; + asm "mg_obj", shift @mgix; + my $length = $_->LENGTH; + if ($length == B::HEf_SVKEY) { + asm "mg_namex", shift @namix; + } elsif ($length) { + asm "newpv", pvstring $_->PTR; + asm "mg_name"; + } + } +} + +sub B::PVMG::bsave { + my ($sv,$ix) = @_; + my $stashix = $sv->SvSTASH->ix; + $sv->B::PVNV::bsave($ix); + asm "xmg_stash", $stashix; + $sv->domagic($ix) if $sv->MAGICAL; +} + +sub B::PVLV::bsave { + my ($sv,$ix) = @_; + my $targix = $sv->TARG->ix; + $sv->B::PVMG::bsave($ix); + asm "xlv_targ", $targix; + asm "xlv_targoff", $sv->TARGOFF; + asm "xlv_targlen", $sv->TARGLEN; + asm "xlv_type", $sv->TYPE; + +} + +sub B::BM::bsave { + my ($sv,$ix) = @_; + $sv->B::PVMG::bsave($ix); + asm "xpv_cur", $sv->CUR; + asm "xbm_useful", $sv->USEFUL; + asm "xbm_previous", $sv->PREVIOUS; + asm "xbm_rare", $sv->RARE; +} + +sub B::IO::bsave { + my ($io,$ix) = @_; + my $topix = $io->TOP_GV->ix; + my $fmtix = $io->FMT_GV->ix; + my $bottomix = $io->BOTTOM_GV->ix; + $io->B::PVMG::bsave($ix); + asm "xio_lines", $io->LINES; + asm "xio_page", $io->PAGE; + asm "xio_page_len", $io->PAGE_LEN; + asm "xio_lines_left", $io->LINES_LEFT; + asm "xio_top_name", pvix $io->TOP_NAME; + asm "xio_top_gv", $topix; + asm "xio_fmt_name", pvix $io->FMT_NAME; + asm "xio_fmt_gv", $fmtix; + asm "xio_bottom_name", pvix $io->BOTTOM_NAME; + asm "xio_bottom_gv", $bottomix; + asm "xio_subprocess", $io->SUBPROCESS; + asm "xio_type", ord $io->IoTYPE; + # asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX +} + +sub B::CV::bsave { + my ($cv,$ix) = @_; + my $stashix = $cv->STASH->ix; + my $gvix = $cv->GV->ix; + my $padlistix = $cv->PADLIST->ix; + my $outsideix = $cv->OUTSIDE->ix; + my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0; + my $startix = $cv->START->opwalk; + my $rootix = $cv->ROOT->ix; + + $cv->B::PVMG::bsave($ix); + asm "xcv_stash", $stashix; + asm "xcv_start", $startix; + asm "xcv_root", $rootix; + asm "xcv_xsubany", $constix; + asm "xcv_gv", $gvix; + asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD + asm "xcv_padlist", $padlistix; + asm "xcv_outside", $outsideix; + asm "xcv_flags", $cv->CvFLAGS; + asm "xcv_outside_seq", $cv->OUTSIDE_SEQ; + asm "xcv_depth", $cv->DEPTH; +} + +sub B::FM::bsave { + my ($form,$ix) = @_; + + $form->B::CV::bsave($ix); + asm "xfm_lines", $form->LINES; +} + +sub B::AV::bsave { + my ($av,$ix) = @_; + return $av->B::PVMG::bsave($ix) if $av->MAGICAL; + my @array = $av->ARRAY; + $_ = $_->ix for @array; + my $stashix = $av->SvSTASH->ix; + + nice "-AV-", + asm "ldsv", $varix = $ix unless $ix == $varix; + asm "av_extend", $av->MAX if $av->MAX >= 0; + asm "av_pushx", $_ for @array; + asm "sv_refcnt", $av->REFCNT; + if (VERSION < 5.009) { + asm "xav_flags", $av->AvFLAGS; + } + asm "xmg_stash", $stashix; +} + +sub B::GV::desired { + my $gv = shift; + my ($cv, $form); + $files{$gv->FILE} && $gv->LINE + || ${$cv = $gv->CV} && $files{$cv->FILE} + || ${$form = $gv->FORM} && $files{$form->FILE} +} + +sub B::HV::bwalk { + my $hv = shift; + return if $walked{$$hv}++; + my %stash = $hv->ARRAY; + while (my($k,$v) = each %stash) { + if ($v->SvTYPE == SVt_PVGV) { + my $hash = $v->HV; + if ($$hash && $hash->NAME) { + $hash->bwalk; + } + $v->ix(1) if desired $v; + } else { + nice "[prototype]"; + asm "gv_fetchpvx", cstring $hv->NAME . "::$k"; + $svtab{$$v} = $varix = $tix; + $v->bsave($tix++); + asm "sv_flags", $v->FLAGS; + } + } +} + +###################################################### + + +sub B::OP::bsave_thin { + my ($op, $ix) = @_; + my $next = $op->next; + my $nextix = $optab{$$next}; + $nextix = 0, push @cloop, $op unless defined $nextix; + if ($ix != $opix) { + nice '-'.$op->name.'-', + asm "ldop", $opix = $ix; + } + asm "op_next", $nextix; + asm "op_targ", $op->targ if $op->type; # tricky + asm "op_flags", $op->flags; + asm "op_private", $op->private; +} + +sub B::OP::bsave; + *B::OP::bsave = *B::OP::bsave_thin; + +sub B::UNOP::bsave { + my ($op, $ix) = @_; + my $name = $op->name; + my $flags = $op->flags; + my $first = $op->first; + my $firstix = + $name =~ /fl[io]p/ + # that's just neat + || (!ITHREADS && $name eq 'regcomp') + # trick for /$a/o in pp_regcomp + || $name eq 'rv2sv' + && $op->flags & OPf_MOD + && $op->private & OPpLVAL_INTRO + # change #18774 made my life hard + ? $first->ix + : 0; + + $op->B::OP::bsave($ix); + asm "op_first", $firstix; +} + +sub B::BINOP::bsave { + my ($op, $ix) = @_; + if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) { + my $last = $op->last; + my $lastix = do { + local *B::OP::bsave = *B::OP::bsave_fat; + local *B::UNOP::bsave = *B::UNOP::bsave_fat; + $last->ix; + }; + asm "ldop", $lastix unless $lastix == $opix; + asm "op_targ", $last->targ; + $op->B::OP::bsave($ix); + asm "op_last", $lastix; + } else { + $op->B::OP::bsave($ix); + } +} + +# not needed if no pseudohashes + +*B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009; + +# deal with sort / formline + +sub B::LISTOP::bsave { + my ($op, $ix) = @_; + my $name = $op->name; + sub blocksort() { OPf_SPECIAL|OPf_STACKED } + if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) { + my $first = $op->first; + my $pushmark = $first->sibling; + my $rvgv = $pushmark->first; + my $leave = $rvgv->first; + + my $leaveix = $leave->ix; + + my $rvgvix = $rvgv->ix; + asm "ldop", $rvgvix unless $rvgvix == $opix; + asm "op_first", $leaveix; + + my $pushmarkix = $pushmark->ix; + asm "ldop", $pushmarkix unless $pushmarkix == $opix; + asm "op_first", $rvgvix; + + my $firstix = $first->ix; + asm "ldop", $firstix unless $firstix == $opix; + asm "op_sibling", $pushmarkix; + + $op->B::OP::bsave($ix); + asm "op_first", $firstix; + } elsif ($name eq 'formline') { + $op->B::UNOP::bsave_fat($ix); + } else { + $op->B::OP::bsave($ix); + } +} + +# fat versions + +sub B::OP::bsave_fat { + my ($op, $ix) = @_; + my $siblix = $op->sibling->ix; + + $op->B::OP::bsave_thin($ix); + asm "op_sibling", $siblix; + # asm "op_seq", -1; XXX don't allocate OPs piece by piece +} + +sub B::UNOP::bsave_fat { + my ($op,$ix) = @_; + my $firstix = $op->first->ix; + + $op->B::OP::bsave($ix); + asm "op_first", $firstix; +} + +sub B::BINOP::bsave_fat { + my ($op,$ix) = @_; + my $last = $op->last; + my $lastix = $op->last->ix; + if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') { + asm "ldop", $lastix unless $lastix == $opix; + asm "op_targ", $last->targ; + } + + $op->B::UNOP::bsave($ix); + asm "op_last", $lastix; +} + +sub B::LOGOP::bsave { + my ($op,$ix) = @_; + my $otherix = $op->other->ix; + + $op->B::UNOP::bsave($ix); + asm "op_other", $otherix; +} + +sub B::PMOP::bsave { + my ($op,$ix) = @_; + my ($rrop, $rrarg, $rstart); + + # my $pmnextix = $op->pmnext->ix; # XXX + + if (ITHREADS) { + if ($op->name eq 'subst') { + $rrop = "op_pmreplroot"; + $rrarg = $op->pmreplroot->ix; + $rstart = $op->pmreplstart->ix; + } elsif ($op->name eq 'pushre') { + $rrop = "op_pmreplrootpo"; + $rrarg = $op->pmreplroot; + } + $op->B::BINOP::bsave($ix); + asm "op_pmstashpv", pvix $op->pmstashpv; + } else { + $rrop = "op_pmreplrootgv"; + $rrarg = $op->pmreplroot->ix; + $rstart = $op->pmreplstart->ix if $op->name eq 'subst'; + my $stashix = $op->pmstash->ix; + $op->B::BINOP::bsave($ix); + asm "op_pmstash", $stashix; + } + + asm $rrop, $rrarg if $rrop; + asm "op_pmreplstart", $rstart if $rstart; + + asm "op_pmflags", $op->pmflags; + asm "op_pmpermflags", $op->pmpermflags; + asm "op_pmdynflags", $op->pmdynflags; + # asm "op_pmnext", $pmnextix; # XXX + asm "newpv", pvstring $op->precomp; + asm "pregcomp"; +} + +sub B::SVOP::bsave { + my ($op,$ix) = @_; + my $svix = $op->sv->ix; + + $op->B::OP::bsave($ix); + asm "op_sv", $svix; +} + +sub B::PADOP::bsave { + my ($op,$ix) = @_; + + $op->B::OP::bsave($ix); + asm "op_padix", $op->padix; +} + +sub B::PVOP::bsave { + my ($op,$ix) = @_; + $op->B::OP::bsave($ix); + return unless my $pv = $op->pv; + + if ($op->name eq 'trans') { + asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv); + } else { + asm "newpv", pvstring $pv; + asm "op_pv"; + } +} + +sub B::LOOP::bsave { + my ($op,$ix) = @_; + my $nextix = $op->nextop->ix; + my $lastix = $op->lastop->ix; + my $redoix = $op->redoop->ix; + + $op->B::BINOP::bsave($ix); + asm "op_redoop", $redoix; + asm "op_nextop", $nextix; + asm "op_lastop", $lastix; +} + +sub B::COP::bsave { + my ($cop,$ix) = @_; + my $warnix = $cop->warnings->ix; + my $ioix = $cop->io->ix; + if (ITHREADS) { + $cop->B::OP::bsave($ix); + asm "cop_stashpv", pvix $cop->stashpv; + asm "cop_file", pvix $cop->file; + } else { + my $stashix = $cop->stash->ix; + my $fileix = $cop->filegv->ix(1); + $cop->B::OP::bsave($ix); + asm "cop_stash", $stashix; + asm "cop_filegv", $fileix; + } + asm "cop_label", pvix $cop->label if $cop->label; # XXX AD + asm "cop_seq", $cop->cop_seq; + asm "cop_arybase", $cop->arybase; + asm "cop_line", $cop->line; + asm "cop_warnings", $warnix; + asm "cop_io", $ioix; +} + +sub B::OP::opwalk { + my $op = shift; + my $ix = $optab{$$op}; + defined($ix) ? $ix : do { + my $ix; + my @oplist = $op->oplist; + push @cloop, undef; + $ix = $_->ix while $_ = pop @oplist; + while ($_ = pop @cloop) { + asm "ldop", $optab{$$_}; + asm "op_next", $optab{${$_->next}}; + } + $ix; + } +} + +################################################# + +sub save_cq { + my $av; + if (($av=begin_av)->isa("B::AV")) { + if ($savebegins) { + for ($av->ARRAY) { + next unless $_->FILE eq $0; + asm "push_begin", $_->ix; + } + } else { + for ($av->ARRAY) { + next unless $_->FILE eq $0; + # XXX BEGIN { goto A while 1; A: } + for (my $op = $_->START; $$op; $op = $op->next) { + next unless $op->name eq 'require' || + # this kludge needed for tests + $op->name eq 'gv' && do { + my $gv = class($op) eq 'SVOP' ? + $op->gv : + (($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix]; + $$gv && $gv->NAME =~ /use_ok|plan/ + }; + asm "push_begin", $_->ix; + last; + } + } + } + } + if (($av=init_av)->isa("B::AV")) { + for ($av->ARRAY) { + next unless $_->FILE eq $0; + asm "push_init", $_->ix; + } + } + if (($av=end_av)->isa("B::AV")) { + for ($av->ARRAY) { + next unless $_->FILE eq $0; + asm "push_end", $_->ix; + } + } +} + +sub compile { + my ($head, $scan, $T_inhinc, $keep_syn); + my $cwd = ''; + $files{$0} = 1; + sub keep_syn { + $keep_syn = 1; + *B::OP::bsave = *B::OP::bsave_fat; + *B::UNOP::bsave = *B::UNOP::bsave_fat; + *B::BINOP::bsave = *B::BINOP::bsave_fat; + *B::LISTOP::bsave = *B::LISTOP::bsave_fat; + } + sub bwarn { print STDERR "Bytecode.pm: @_\n" } + + for (@_) { + if (/^-S/) { + *newasm = *endasm = sub { }; + *asm = sub { print " @_\n" }; + *nice = sub ($) { print "\n@_\n" }; + } elsif (/^-H/) { + require ByteLoader; + $head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n"; + } elsif (/^-k/) { + keep_syn; + } elsif (/^-o(.*)$/) { + open STDOUT, ">$1" or die "open $1: $!"; + } elsif (/^-f(.*)$/) { + $files{$1} = 1; + } elsif (/^-s(.*)$/) { + $scan = length($1) ? $1 : $0; + } elsif (/^-b/) { + $savebegins = 1; + # this is here for the testsuite + } elsif (/^-TI/) { + $T_inhinc = 1; + } elsif (/^-TF(.*)/) { + my $thatfile = $1; + *B::COP::file = sub { $thatfile }; + } else { + bwarn "Ignoring '$_' option"; + } + } + if ($scan) { + my $f; + if (open $f, $scan) { + while (<$f>) { + /^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1; + /^#/ and next; + if (/\bgoto\b\s*[^&]/ && !$keep_syn) { + bwarn "keeping the syntax tree: \"goto\" op found"; + keep_syn; + } + } + } else { + bwarn "cannot rescan '$scan'"; + } + close $f; + } + binmode STDOUT; + return sub { + print $head if $head; + newasm sub { print @_ }; + + defstash->bwalk; + asm "main_start", main_start->opwalk; + asm "main_root", main_root->ix; + asm "main_cv", main_cv->ix; + asm "curpad", (comppadlist->ARRAY)[1]->ix; + + asm "signal", cstring "__WARN__" # XXX + if warnhook->ix; + asm "incav", inc_gv->AV->ix if $T_inhinc; + save_cq; + asm "incav", inc_gv->AV->ix if $T_inhinc; + asm "dowarn", dowarn; + + { + no strict 'refs'; + nice "<DATA>"; + my $dh = *{defstash->NAME."::DATA"}; + unless (eof $dh) { + local undef $/; + asm "data", ord 'D'; + print <$dh>; + } else { + asm "ret"; + } + } + + endasm; + } +} + +1; + +=head1 NAME + +B::Bytecode - Perl compiler's bytecode backend + +=head1 SYNOPSIS + +B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl> + +=head1 DESCRIPTION + +Compiles a Perl script into a bytecode format that could be loaded +later by the ByteLoader module and executed as a regular Perl script. + +=head1 EXAMPLE + + $ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"' + $ perl hi + hi! + +=head1 OPTIONS + +=over 4 + +=item B<-b> + +Save all the BEGIN blocks. Normally only BEGIN blocks that C<require> +other files (ex. C<use Foo;>) are saved. + +=item B<-H> + +prepend a C<use ByteLoader VERSION;> line to the produced bytecode. + +=item B<-k> + +keep the syntax tree - it is stripped by default. + +=item B<-o>I<outfile> + +put the bytecode in <outfile> instead of dumping it to STDOUT. + +=item B<-s> + +scan the script for C<# line ..> directives and for <goto LABEL> +expressions. When gotos are found keep the syntax tree. + +=back + +=head1 KNOWN BUGS + +=over 4 + +=item * + +C<BEGIN { goto A: while 1; A: }> won't even compile. + +=item * + +C<?...?> and C<reset> do not work as expected. + +=item * + +variables in C<(?{ ... })> constructs are not properly scoped. + +=item * + +scripts that use source filters will fail miserably. + +=back + +=head1 NOTICE + +There are also undocumented bugs and options. + +THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK. + +=head1 AUTHORS + +Originally written by Malcolm Beattie <mbeattie@sable.ox.ac.uk> and +modified by Benjamin Stuhl <sho_pi@hotmail.com>. + +Rewritten by Enache Adrian <enache@rdslink.ro>, 2003 a.d. + +=cut diff --git a/Master/tlpkg/installer/perllib/B/C.pm b/Master/tlpkg/installer/perllib/B/C.pm new file mode 100644 index 00000000000..cebf4132ffd --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/C.pm @@ -0,0 +1,2272 @@ +# C.pm +# +# Copyright (c) 1996, 1997, 1998 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# + +package B::C; + +our $VERSION = '1.04_01'; + +package B::C::Section; + +use B (); +use base B::Section; + +sub new +{ + my $class = shift; + my $o = $class->SUPER::new(@_); + push @$o, { values => [] }; + return $o; +} + +sub add +{ + my $section = shift; + push(@{$section->[-1]{values}},@_); +} + +sub index +{ + my $section = shift; + return scalar(@{$section->[-1]{values}})-1; +} + +sub output +{ + my ($section, $fh, $format) = @_; + my $sym = $section->symtable || {}; + my $default = $section->default; + my $i; + foreach (@{$section->[-1]{values}}) + { + s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge; + printf $fh $format, $_, $i; + ++$i; + } +} + +package B::C::InitSection; + +# avoid use vars +@B::C::InitSection::ISA = qw(B::C::Section); + +sub new { + my $class = shift; + my $max_lines = 10000; #pop; + my $section = $class->SUPER::new( @_ ); + + $section->[-1]{evals} = []; + $section->[-1]{chunks} = []; + $section->[-1]{nosplit} = 0; + $section->[-1]{current} = []; + $section->[-1]{count} = 0; + $section->[-1]{max_lines} = $max_lines; + + return $section; +} + +sub split { + my $section = shift; + $section->[-1]{nosplit}-- + if $section->[-1]{nosplit} > 0; +} + +sub no_split { + shift->[-1]{nosplit}++; +} + +sub inc_count { + my $section = shift; + + $section->[-1]{count} += $_[0]; + # this is cheating + $section->add(); +} + +sub add { + my $section = shift->[-1]; + my $current = $section->{current}; + my $nosplit = $section->{nosplit}; + + push @$current, @_; + $section->{count} += scalar(@_); + if( !$nosplit && $section->{count} >= $section->{max_lines} ) { + push @{$section->{chunks}}, $current; + $section->{current} = []; + $section->{count} = 0; + } +} + +sub add_eval { + my $section = shift; + my @strings = @_; + + foreach my $i ( @strings ) { + $i =~ s/\"/\\\"/g; + } + push @{$section->[-1]{evals}}, @strings; +} + +sub output { + my( $section, $fh, $format, $init_name ) = @_; + my $sym = $section->symtable || {}; + my $default = $section->default; + push @{$section->[-1]{chunks}}, $section->[-1]{current}; + + my $name = "aaaa"; + foreach my $i ( @{$section->[-1]{chunks}} ) { + print $fh <<"EOT"; +static int perl_init_${name}() +{ + dTARG; + dSP; +EOT + foreach my $j ( @$i ) { + $j =~ s{(s\\_[0-9a-f]+)} + { exists($sym->{$1}) ? $sym->{$1} : $default; }ge; + print $fh "\t$j\n"; + } + print $fh "\treturn 0;\n}\n"; + + $section->SUPER::add( "perl_init_${name}();" ); + ++$name; + } + foreach my $i ( @{$section->[-1]{evals}} ) { + $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i ); + } + + print $fh <<"EOT"; +static int ${init_name}() +{ + dTARG; + dSP; +EOT + $section->SUPER::output( $fh, $format ); + print $fh "\treturn 0;\n}\n"; +} + + +package B::C; +use Exporter (); +our %REGEXP; + +{ # block necessary for caller to work + my $caller = caller; + if( $caller eq 'O' ) { + require XSLoader; + XSLoader::load( 'B::C' ); + } +} + +@ISA = qw(Exporter); +@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused + init_sections set_callback save_unused_subs objsym save_context); + +use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop + class cstring cchar svref_2object compile_stats comppadlist hash + threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation + HEf_SVKEY SVf_POK SVf_ROK CVf_CONST); +use B::Asmdata qw(@specialsv_name); + +use FileHandle; +use Carp; +use strict; +use Config; + +my $hv_index = 0; +my $gv_index = 0; +my $re_index = 0; +my $pv_index = 0; +my $cv_index = 0; +my $anonsub_index = 0; +my $initsub_index = 0; + +my %symtable; +my %xsub; +my $warn_undefined_syms; +my $verbose; +my %unused_sub_packages; +my $use_xsloader; +my $nullop_count; +my $pv_copy_on_grow = 0; +my $optimize_ppaddr = 0; +my $optimize_warn_sv = 0; +my $use_perl_script_name = 0; +my $save_data_fh = 0; +my $save_sig = 0; +my ($debug_cops, $debug_av, $debug_cv, $debug_mg); +my $max_string_len; + +my $ithreads = $Config{useithreads} eq 'define'; + +my @threadsv_names; +BEGIN { + @threadsv_names = threadsv_names(); +} + +# Code sections +my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, + $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect, + $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect, + $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, + $xrvsect, $xpvbmsect, $xpviosect ); +my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect, + $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect, + $unopsect ); + +sub walk_and_save_optree; +my $saveoptree_callback = \&walk_and_save_optree; +sub set_callback { $saveoptree_callback = shift } +sub saveoptree { &$saveoptree_callback(@_) } + +sub walk_and_save_optree { + my ($name, $root, $start) = @_; + walkoptree($root, "save"); + return objsym($start); +} + +# Look this up here so we can do just a number compare +# rather than looking up the name of every BASEOP in B::OP +my $OP_THREADSV = opnumber('threadsv'); + +sub savesym { + my ($obj, $value) = @_; + my $sym = sprintf("s\\_%x", $$obj); + $symtable{$sym} = $value; +} + +sub objsym { + my $obj = shift; + return $symtable{sprintf("s\\_%x", $$obj)}; +} + +sub getsym { + my $sym = shift; + my $value; + + return 0 if $sym eq "sym_0"; # special case + $value = $symtable{$sym}; + if (defined($value)) { + return $value; + } else { + warn "warning: undefined symbol $sym\n" if $warn_undefined_syms; + return "UNUSED"; + } +} + +sub savere { + my $re = shift; + my $sym = sprintf("re%d", $re_index++); + $decl->add(sprintf("static char *$sym = %s;", cstring($re))); + + return ($sym,length(pack "a*",$re)); +} + +sub savepv { + my $pv = pack "a*", shift; + my $pvsym = 0; + my $pvmax = 0; + if ($pv_copy_on_grow) { + $pvsym = sprintf("pv%d", $pv_index++); + + if( defined $max_string_len && length($pv) > $max_string_len ) { + my $chars = join ', ', map { cchar $_ } split //, $pv; + $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars)); + } + else { + my $cstring = cstring($pv); + if ($cstring ne "0") { # sic + $decl->add(sprintf("static char %s[] = %s;", + $pvsym, $cstring)); + } + } + } else { + $pvmax = length(pack "a*",$pv) + 1; + } + return ($pvsym, $pvmax); +} + +sub save_rv { + my $sv = shift; +# confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK; + my $rv = $sv->RV->save; + + $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/; + + return $rv; +} + +# savesym, pvmax, len, pv +sub save_pv_or_rv { + my $sv = shift; + + my $rok = $sv->FLAGS & SVf_ROK; + my $pok = $sv->FLAGS & SVf_POK; + my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 ); + if( $rok ) { + $savesym = '(char*)' . save_rv( $sv ); + } + else { + $pv = $pok ? (pack "a*", $sv->PV) : undef; + $len = $pok ? length($pv) : 0; + ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 ); + } + + return ( $savesym, $pvmax, $len, $pv ); +} + +# see also init_op_ppaddr below; initializes the ppaddt to the +# OpTYPE; init_op_ppaddr iterates over the ops and sets +# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente +# in perl_init ( ~10 bytes/op with GCC/i386 ) +sub B::OP::fake_ppaddr { + return $optimize_ppaddr ? + sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) : + 'NULL'; +} + +# This pair is needed becase B::FAKEOP::save doesn't scalar dereference +# $op->next and $op->sibling + +{ + # For 5.9 the hard coded text is the values for op_opt and op_static in each + # op. The value of op_opt is irrelevant, and the value of op_static needs to + # be 1 to tell op_free that this is a statically defined op and that is + # shouldn't be freed. + + # For 5.8: + # Current workaround/fix for op_free() trying to free statically + # defined OPs is to set op_seq = -1 and check for that in op_free(). + # Instead of hardwiring -1 in place of $op->seq, we use $op_seq + # so that it can be changed back easily if necessary. In fact, to + # stop compilers from moaning about a U16 being initialised with an + # uncast -1 (the printf format is %d so we can't tweak it), we have + # to "know" that op_seq is a U16 and use 65535. Ugh. + + my $static = $] > 5.009 ? '0, 1, 0' : sprintf "%u", 65535; + sub B::OP::_save_common_middle { + my $op = shift; + sprintf ("%s, %u, %u, $static, 0x%x, 0x%x", + $op->fake_ppaddr, $op->targ, $op->type, $op->flags, $op->private); + } +} + +sub B::OP::_save_common { + my $op = shift; + return sprintf("s\\_%x, s\\_%x, %s", + ${$op->next}, ${$op->sibling}, $op->_save_common_middle); +} + +sub B::OP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + my $type = $op->type; + $nullop_count++ unless $type; + if ($type == $OP_THREADSV) { + # saves looking up ppaddr but it's a bit naughty to hard code this + $init->add(sprintf("(void)find_threadsv(%s);", + cstring($threadsv_names[$op->targ]))); + } + $opsect->add($op->_save_common); + my $ix = $opsect->index; + $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + savesym($op, "&op_list[$ix]"); +} + +sub B::FAKEOP::new { + my ($class, %objdata) = @_; + bless \%objdata, $class; +} + +sub B::FAKEOP::save { + my ($op, $level) = @_; + $opsect->add(sprintf("%s, %s, %s", + $op->next, $op->sibling, $op->_save_common_middle)); + my $ix = $opsect->index; + $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + return "&op_list[$ix]"; +} + +sub B::FAKEOP::next { $_[0]->{"next"} || 0 } +sub B::FAKEOP::type { $_[0]->{type} || 0} +sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 } +sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 } +sub B::FAKEOP::targ { $_[0]->{targ} || 0 } +sub B::FAKEOP::flags { $_[0]->{flags} || 0 } +sub B::FAKEOP::private { $_[0]->{private} || 0 } + +sub B::UNOP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + $unopsect->add(sprintf("%s, s\\_%x", $op->_save_common, ${$op->first})); + my $ix = $unopsect->index; + $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + savesym($op, "(OP*)&unop_list[$ix]"); +} + +sub B::BINOP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + $binopsect->add(sprintf("%s, s\\_%x, s\\_%x", + $op->_save_common, ${$op->first}, ${$op->last})); + my $ix = $binopsect->index; + $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + savesym($op, "(OP*)&binop_list[$ix]"); +} + +sub B::LISTOP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + $listopsect->add(sprintf("%s, s\\_%x, s\\_%x", + $op->_save_common, ${$op->first}, ${$op->last})); + my $ix = $listopsect->index; + $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + savesym($op, "(OP*)&listop_list[$ix]"); +} + +sub B::LOGOP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + $logopsect->add(sprintf("%s, s\\_%x, s\\_%x", + $op->_save_common, ${$op->first}, ${$op->other})); + my $ix = $logopsect->index; + $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + savesym($op, "(OP*)&logop_list[$ix]"); +} + +sub B::LOOP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n", + # peekop($op->redoop), peekop($op->nextop), + # peekop($op->lastop)); # debug + $loopsect->add(sprintf("%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x", + $op->_save_common, ${$op->first}, ${$op->last}, + ${$op->redoop}, ${$op->nextop}, + ${$op->lastop})); + my $ix = $loopsect->index; + $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + savesym($op, "(OP*)&loop_list[$ix]"); +} + +sub B::PVOP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + $pvopsect->add(sprintf("%s, %s", $op->_save_common, cstring($op->pv))); + my $ix = $pvopsect->index; + $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + savesym($op, "(OP*)&pvop_list[$ix]"); +} + +sub B::SVOP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + my $sv = $op->sv; + my $svsym = '(SV*)' . $sv->save; + my $is_const_addr = $svsym =~ m/Null|\&/; + $svopsect->add(sprintf("%s, %s", $op->_save_common, + ( $is_const_addr ? $svsym : 'Nullsv' ))); + my $ix = $svopsect->index; + $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + $init->add("svop_list[$ix].op_sv = $svsym;") + unless $is_const_addr; + savesym($op, "(OP*)&svop_list[$ix]"); +} + +sub B::PADOP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + $padopsect->add(sprintf("%s, %d", + $op->_save_common, $op->padix)); + my $ix = $padopsect->index; + $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; +# $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix)); + savesym($op, "(OP*)&padop_list[$ix]"); +} + +sub B::COP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + warn sprintf("COP: line %d file %s\n", $op->line, $op->file) + if $debug_cops; + # shameless cut'n'paste from B::Deparse + my $warn_sv; + my $warnings = $op->warnings; + my $is_special = $warnings->isa("B::SPECIAL"); + if ($is_special && $$warnings == 4) { + # use warnings 'all'; + $warn_sv = $optimize_warn_sv ? + 'INT2PTR(SV*,1)' : + 'pWARN_ALL'; + } + elsif ($is_special && $$warnings == 5) { + # no warnings 'all'; + $warn_sv = $optimize_warn_sv ? + 'INT2PTR(SV*,2)' : + 'pWARN_NONE'; + } + elsif ($is_special) { + # use warnings; + $warn_sv = $optimize_warn_sv ? + 'INT2PTR(SV*,3)' : + 'pWARN_STD'; + } + else { + # something else + $warn_sv = $warnings->save; + } + + $copsect->add(sprintf("%s, %s, NULL, NULL, %u, %d, %u, %s", + $op->_save_common, cstring($op->label), $op->cop_seq, + $op->arybase, $op->line, + ( $optimize_warn_sv ? $warn_sv : 'NULL' ))); + my $ix = $copsect->index; + $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr)) + unless $optimize_ppaddr; + $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv )) + unless $optimize_warn_sv; + $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)), + sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv))); + + savesym($op, "(OP*)&cop_list[$ix]"); +} + +sub B::PMOP::save { + my ($op, $level) = @_; + my $sym = objsym($op); + return $sym if defined $sym; + my $replroot = $op->pmreplroot; + my $replstart = $op->pmreplstart; + my $replrootfield; + my $replstartfield = sprintf("s\\_%x", $$replstart); + my $gvsym; + my $ppaddr = $op->ppaddr; + # under ithreads, OP_PUSHRE.op_replroot is an integer + $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot; + if($ithreads && $op->name eq "pushre") { + $replrootfield = "INT2PTR(OP*,${replroot})"; + } elsif ($$replroot) { + # OP_PUSHRE (a mutated version of OP_MATCH for the regexp + # argument to a split) stores a GV in op_pmreplroot instead + # of a substitution syntax tree. We don't want to walk that... + if ($op->name eq "pushre") { + $gvsym = $replroot->save; +# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug + $replrootfield = 0; + } else { + $replstartfield = saveoptree("*ignore*", $replroot, $replstart); + } + } + # pmnext handling is broken in perl itself, I think. Bad op_pmnext + # fields aren't noticed in perl's runtime (unless you try reset) but we + # segfault when trying to dereference it to find op->op_pmnext->op_type + $pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x", + $op->_save_common, ${$op->first}, ${$op->last}, + $replrootfield, $replstartfield, + ( $ithreads ? $op->pmoffset : 0 ), + $op->pmflags, $op->pmpermflags, $op->pmdynflags )); + my $pm = sprintf("pmop_list[%d]", $pmopsect->index); + $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr)) + unless $optimize_ppaddr; + my $re = $op->precomp; + if (defined($re)) { + my( $resym, $relen ) = savere( $re ); + $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));", + $relen)); + } + if ($gvsym) { + $init->add("$pm.op_pmreplroot = (OP*)$gvsym;"); + } + savesym($op, "(OP*)&$pm"); +} + +sub B::SPECIAL::save { + my ($sv) = @_; + # special case: $$sv is not the address but an index into specialsv_list +# warn "SPECIAL::save specialsv $$sv\n"; # debug + my $sym = $specialsv_name[$$sv]; + if (!defined($sym)) { + confess "unknown specialsv index $$sv passed to B::SPECIAL::save"; + } + return $sym; +} + +sub B::OBJECT::save {} + +sub B::NULL::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; +# warn "Saving SVt_NULL SV\n"; # debug + # debug + if ($$sv == 0) { + warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n"; + return savesym($sv, "(void*)Nullsv /* XXX */"); + } + $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::IV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX)); + $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x", + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::NV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; + $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val)); + $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub savepvn { + my ($dest,$pv) = @_; + my @res; + # work with byte offsets/lengths + my $pv = pack "a*", $pv; + if (defined $max_string_len && length($pv) > $max_string_len) { + push @res, sprintf("Newx(%s,%u,char);", $dest, length($pv)+1); + my $offset = 0; + while (length $pv) { + my $str = substr $pv, 0, $max_string_len, ''; + push @res, sprintf("Copy(%s,$dest+$offset,%u,char);", + cstring($str), length($str)); + $offset += length $str; + } + push @res, sprintf("%s[%u] = '\\0';", $dest, $offset); + } + else { + push @res, sprintf("%s = savepvn(%s, %u);", $dest, + cstring($pv), length($pv)); + } + return @res; +} + +sub B::PVLV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $pv = $sv->PV; + my $len = length($pv); + my ($pvsym, $pvmax) = savepv($pv); + my ($lvtarg, $lvtarg_sym); + $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s", + $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX, + $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE))); + $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", + $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS)); + if (!$pv_copy_on_grow) { + $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv", + $xpvlvsect->index), $pv)); + } + $sv->save_magic; + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::PVIV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); + $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX)); + $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x", + $xpvivsect->index, $sv->REFCNT , $sv->FLAGS)); + if (defined($pv) && !$pv_copy_on_grow) { + $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv", + $xpvivsect->index), $pv)); + } + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::PVNV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); + my $val= $sv->NVX; + $val .= '.00' if $val =~ /^-?\d+$/; + $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s", + $savesym, $len, $pvmax, $sv->IVX, $val)); + $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x", + $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS)); + if (defined($pv) && !$pv_copy_on_grow) { + $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv", + $xpvnvsect->index), $pv)); + } + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::BM::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE); + my $len = length($pv); + $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x", + $len, $len + 258, $sv->IVX, $sv->NVX, + $sv->USEFUL, $sv->PREVIOUS, $sv->RARE)); + $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", + $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS)); + $sv->save_magic; + $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv", + $xpvbmsect->index), $pv), + sprintf("xpvbm_list[%d].xpv_cur = %u;", + $xpvbmsect->index, $len - 257)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::PV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); + $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax)); + $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x", + $xpvsect->index, $sv->REFCNT , $sv->FLAGS)); + if (defined($pv) && !$pv_copy_on_grow) { + $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv", + $xpvsect->index), $pv)); + } + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub B::PVMG::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv ); + + $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0", + $savesym, $len, $pvmax, + $sv->IVX, $sv->NVX)); + $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", + $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS)); + if (defined($pv) && !$pv_copy_on_grow) { + $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv", + $xpvmgsect->index), $pv)); + } + $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); + $sv->save_magic; + return $sym; +} + +sub B::PVMG::save_magic { + my ($sv) = @_; + #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug + my $stash = $sv->SvSTASH; + $stash->save; + if ($$stash) { + warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash) + if $debug_mg; + # XXX Hope stash is already going to be saved. + $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash)); + } + my @mgchain = $sv->MAGIC; + my ($mg, $type, $obj, $ptr,$len,$ptrsv); + foreach $mg (@mgchain) { + $type = $mg->TYPE; + $ptr = $mg->PTR; + $len=$mg->LENGTH; + if ($debug_mg) { + warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n", + class($sv), $$sv, class($obj), $$obj, + cchar($type), cstring($ptr)); + } + + unless( $type eq 'r' ) { + $obj = $mg->OBJ; + $obj->save; + } + + if ($len == HEf_SVKEY){ + #The pointer is an SV* + $ptrsv=svref_2object($ptr)->save; + $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);", + $$sv, $$obj, cchar($type),$ptrsv,$len)); + }elsif( $type eq 'r' ){ + my $rx = $mg->REGEX; + my $pmop = $REGEXP{$rx}; + + confess "PMOP not found for REGEXP $rx" unless $pmop; + + my( $resym, $relen ) = savere( $mg->precomp ); + my $pmsym = $pmop->save; + $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) ); +{ + REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym); + sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d); +} +CODE + }else{ + $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);", + $$sv, $$obj, cchar($type),cstring($ptr),$len)); + } + } +} + +sub B::RV::save { + my ($sv) = @_; + my $sym = objsym($sv); + return $sym if defined $sym; + my $rv = save_rv( $sv ); + # GVs need to be handled at runtime + if( ref( $sv->RV ) eq 'B::GV' ) { + $xrvsect->add( "(SV*)Nullgv" ); + $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv)); + } + # and stashes, too + elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) { + $xrvsect->add( "(SV*)Nullhv" ); + $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv)); + } + else { + $xrvsect->add($rv); + } + $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x", + $xrvsect->index, $sv->REFCNT , $sv->FLAGS)); + return savesym($sv, sprintf("&sv_list[%d]", $svsect->index)); +} + +sub try_autoload { + my ($cvstashname, $cvname) = @_; + warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname); + # Handle AutoLoader classes explicitly. Any more general AUTOLOAD + # use should be handled by the class itself. + no strict 'refs'; + my $isa = \@{"$cvstashname\::ISA"}; + if (grep($_ eq "AutoLoader", @$isa)) { + warn "Forcing immediate load of sub derived from AutoLoader\n"; + # Tweaked version of AutoLoader::AUTOLOAD + my $dir = $cvstashname; + $dir =~ s(::)(/)g; + eval { require "auto/$dir/$cvname.al" }; + if ($@) { + warn qq(failed require "auto/$dir/$cvname.al": $@\n); + return 0; + } else { + return 1; + } + } +} +sub Dummy_initxs{}; +sub B::CV::save { + my ($cv) = @_; + my $sym = objsym($cv); + if (defined($sym)) { +# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug + return $sym; + } + # Reserve a place in svsect and xpvcvsect and record indices + my $gv = $cv->GV; + my ($cvname, $cvstashname); + if ($$gv){ + $cvname = $gv->NAME; + $cvstashname = $gv->STASH->NAME; + } + my $root = $cv->ROOT; + my $cvxsub = $cv->XSUB; + my $isconst = $cv->CvFLAGS & CVf_CONST; + if( $isconst ) { + my $value = $cv->XSUBANY; + my $stash = $gv->STASH; + my $vsym = $value->save; + my $stsym = $stash->save; + my $name = cstring($cvname); + $decl->add( "static CV* cv$cv_index;" ); + $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" ); + my $sym = savesym( $cv, "cv$cv_index" ); + $cv_index++; + return $sym; + } + #INIT is removed from the symbol table, so this call must come + # from PL_initav->save. Re-bootstrapping will push INIT back in + # so nullop should be sent. + if (!$isconst && $cvxsub && ($cvname ne "INIT")) { + my $egv = $gv->EGV; + my $stashname = $egv->STASH->NAME; + if ($cvname eq "bootstrap") + { + my $file = $gv->FILE; + $decl->add("/* bootstrap $file */"); + warn "Bootstrap $stashname $file\n"; + # if it not isa('DynaLoader'), it should hopefully be XSLoaded + # ( attributes being an exception, of course ) + if( $stashname ne 'attributes' && + !UNIVERSAL::isa($stashname,'DynaLoader') ) { + $xsub{$stashname}='Dynamic-XSLoaded'; + $use_xsloader = 1; + } + else { + $xsub{$stashname}='Dynamic'; + } + # $xsub{$stashname}='Static' unless $xsub{$stashname}; + return qq/NULL/; + } + else + { + # XSUBs for IO::File, IO::Handle, IO::Socket, + # IO::Seekable and IO::Poll + # are defined in IO.xs, so let's bootstrap it + svref_2object( \&IO::bootstrap )->save + if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket + IO::Seekable IO::Poll); + } + warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv; + return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/; + } + if ($cvxsub && $cvname eq "INIT") { + no strict 'refs'; + return svref_2object(\&Dummy_initxs)->save; + } + my $sv_ix = $svsect->index + 1; + $svsect->add("svix$sv_ix"); + my $xpvcv_ix = $xpvcvsect->index + 1; + $xpvcvsect->add("xpvcvix$xpvcv_ix"); + # Save symbol now so that GvCV() doesn't recurse back to us via CvGV() + $sym = savesym($cv, "&sv_list[$sv_ix]"); + warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv; + if (!$$root && !$cvxsub) { + if (try_autoload($cvstashname, $cvname)) { + # Recalculate root and xsub + $root = $cv->ROOT; + $cvxsub = $cv->XSUB; + if ($$root || $cvxsub) { + warn "Successful forced autoload\n"; + } + } + } + my $startfield = 0; + my $padlist = $cv->PADLIST; + my $pv = $cv->PV; + my $xsub = 0; + my $xsubany = "Nullany"; + if ($$root) { + warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n", + $$cv, $$root) if $debug_cv; + my $ppname = ""; + if ($$gv) { + my $stashname = $gv->STASH->NAME; + my $gvname = $gv->NAME; + if ($gvname ne "__ANON__") { + $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_"; + $ppname .= ($stashname eq "main") ? + $gvname : "$stashname\::$gvname"; + $ppname =~ s/::/__/g; + if ($gvname eq "INIT"){ + $ppname .= "_$initsub_index"; + $initsub_index++; + } + } + } + if (!$ppname) { + $ppname = "pp_anonsub_$anonsub_index"; + $anonsub_index++; + } + $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY); + warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n", + $$cv, $ppname, $$root) if $debug_cv; + if ($$padlist) { + warn sprintf("saving PADLIST 0x%x for CV 0x%x\n", + $$padlist, $$cv) if $debug_cv; + $padlist->save; + warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n", + $$padlist, $$cv) if $debug_cv; + } + } + else { + warn sprintf("No definition for sub %s::%s (unable to autoload)\n", + $cvstashname, $cvname); # debug + } + $pv = '' unless defined $pv; # Avoid use of undef warnings + $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, \"\", %d, s\\_%x, (CV*)s\\_%x, 0x%x, 0x%x", + $xpvcv_ix, cstring($pv), length($pv), $cv->IVX, + $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH, + $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS, + $cv->OUTSIDE_SEQ)); + + if (${$cv->OUTSIDE} == ${main_cv()}){ + $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv)); + $init->add(sprintf("SvREFCNT_inc(PL_main_cv);")); + } + + if ($$gv) { + $gv->save; + $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv)); + warn sprintf("done saving GV 0x%x for CV 0x%x\n", + $$gv, $$cv) if $debug_cv; + } + if( $ithreads ) { + $init->add( savepvn( "CvFILE($sym)", $cv->FILE) ); + } + else { + $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE))); + } + my $stash = $cv->STASH; + if ($$stash) { + $stash->save; + $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash)); + warn sprintf("done saving STASH 0x%x for CV 0x%x\n", + $$stash, $$cv) if $debug_cv; + } + $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x", + $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS)); + return $sym; +} + +sub B::GV::save { + my ($gv) = @_; + my $sym = objsym($gv); + if (defined($sym)) { + #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug + return $sym; + } else { + my $ix = $gv_index++; + $sym = savesym($gv, "gv_list[$ix]"); + #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug + } + my $is_empty = $gv->is_empty; + my $gvname = $gv->NAME; + my $fullname = $gv->STASH->NAME . "::" . $gvname; + my $name = cstring($fullname); + #warn "GV name is $name\n"; # debug + my $egvsym; + unless ($is_empty) { + my $egv = $gv->EGV; + if ($$gv != $$egv) { + #warn(sprintf("EGV name is %s, saving it now\n", + # $egv->STASH->NAME . "::" . $egv->NAME)); # debug + $egvsym = $egv->save; + } + } + $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);], + sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ), + sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS)); + $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty; + # XXX hack for when Perl accesses PVX of GVs + $init->add("SvPVX($sym) = emptystring;\n"); + # Shouldn't need to do save_magic since gv_fetchpv handles that + #$gv->save_magic; + # XXX will always be > 1!!! + my $refcnt = $gv->REFCNT + 1; + $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1; + + return $sym if $is_empty; + + # XXX B::walksymtable creates an extra reference to the GV + my $gvrefcnt = $gv->GvREFCNT; + if ($gvrefcnt > 1) { + $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1)); + } + # some non-alphavetic globs require some parts to be saved + # ( ex. %!, but not $! ) + sub Save_HV() { 1 } + sub Save_AV() { 2 } + sub Save_SV() { 4 } + sub Save_CV() { 8 } + sub Save_FORM() { 16 } + sub Save_IO() { 32 } + my $savefields = 0; + if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) { + $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO; + } + elsif( $gvname eq '!' ) { + $savefields = Save_HV; + } + # attributes::bootstrap is created in perl_parse + # saving it would overwrite it, because perl_init() is + # called after perl_parse() + $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap'; + + # save it + # XXX is that correct? + if (defined($egvsym) && $egvsym !~ m/Null/ ) { + # Shared glob *foo = *bar + $init->add("gp_free($sym);", + "GvGP($sym) = GvGP($egvsym);"); + } elsif ($savefields) { + # Don't save subfields of special GVs (*_, *1, *# and so on) +# warn "GV::save saving subfields\n"; # debug + my $gvsv = $gv->SV; + if ($$gvsv && $savefields&Save_SV) { + $gvsv->save; + $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv)); +# warn "GV::save \$$name\n"; # debug + } + my $gvav = $gv->AV; + if ($$gvav && $savefields&Save_AV) { + $gvav->save; + $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav)); +# warn "GV::save \@$name\n"; # debug + } + my $gvhv = $gv->HV; + if ($$gvhv && $savefields&Save_HV) { + $gvhv->save; + $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv)); +# warn "GV::save \%$name\n"; # debug + } + my $gvcv = $gv->CV; + if ($$gvcv && $savefields&Save_CV) { + my $origname=cstring($gvcv->GV->EGV->STASH->NAME . + "::" . $gvcv->GV->EGV->NAME); + if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias + # must save as a 'stub' so newXS() has a CV to populate + $init->add("{ CV *cv;"); + $init->add("\tcv=perl_get_cv($origname,TRUE);"); + $init->add("\tGvCV($sym)=cv;"); + $init->add("\tSvREFCNT_inc((SV *)cv);"); + $init->add("}"); + } else { + $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save)); +# warn "GV::save &$name\n"; # debug + } + } + $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE))); +# warn "GV::save GvFILE(*$name)\n"; # debug + my $gvform = $gv->FORM; + if ($$gvform && $savefields&Save_FORM) { + $gvform->save; + $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform)); +# warn "GV::save GvFORM(*$name)\n"; # debug + } + my $gvio = $gv->IO; + if ($$gvio && $savefields&Save_IO) { + $gvio->save; + $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio)); + if( $fullname =~ m/::DATA$/ && $save_data_fh ) { + no strict 'refs'; + my $fh = *{$fullname}{IO}; + use strict 'refs'; + $gvio->save_data( $fullname, <$fh> ) if $fh->opened; + } +# warn "GV::save GvIO(*$name)\n"; # debug + } + } + return $sym; +} + +sub B::AV::save { + my ($av) = @_; + my $sym = objsym($av); + return $sym if defined $sym; + my $line = "0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0"; + $line .= sprintf(", 0x%x", $av->AvFLAGS) if $] < 5.009; + $xpvavsect->add($line); + $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", + $xpvavsect->index, $av->REFCNT , $av->FLAGS)); + my $sv_list_index = $svsect->index; + my $fill = $av->FILL; + $av->save_magic; + if ($debug_av) { + $line = sprintf("saving AV 0x%x FILL=$fill", $$av); + $line .= sprintf(" AvFLAGS=0x%x", $av->AvFLAGS) if $] < 5.009; + warn $line; + } + # XXX AVf_REAL is wrong test: need to save comppadlist but not stack + #if ($fill > -1 && ($avflags & AVf_REAL)) { + if ($fill > -1) { + my @array = $av->ARRAY; + if ($debug_av) { + my $el; + my $i = 0; + foreach $el (@array) { + warn sprintf("AV 0x%x[%d] = %s 0x%x\n", + $$av, $i++, class($el), $$el); + } + } +# my @names = map($_->save, @array); + # XXX Better ways to write loop? + # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...; + # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...; + + # micro optimization: op/pat.t ( and other code probably ) + # has very large pads ( 20k/30k elements ) passing them to + # ->add is a performance bottleneck: passing them as a + # single string cuts runtime from 6min20sec to 40sec + + # you want to keep this out of the no_split/split + # map("\t*svp++ = (SV*)$_;", @names), + my $acc = ''; + foreach my $i ( 0..$#array ) { + $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t"; + } + $acc .= "\n"; + + $init->no_split; + $init->add("{", + "\tSV **svp;", + "\tAV *av = (AV*)&sv_list[$sv_list_index];", + "\tav_extend(av, $fill);", + "\tsvp = AvARRAY(av);" ); + $init->add($acc); + $init->add("\tAvFILLp(av) = $fill;", + "}"); + $init->split; + # we really added a lot of lines ( B::C::InitSection->add + # should really scan for \n, but that would slow + # it down + $init->inc_count( $#array ); + } else { + my $max = $av->MAX; + $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);") + if $max > -1; + } + return savesym($av, "(AV*)&sv_list[$sv_list_index]"); +} + +sub B::HV::save { + my ($hv) = @_; + my $sym = objsym($hv); + return $sym if defined $sym; + my $name = $hv->NAME; + if ($name) { + # It's a stash + + # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually + # the only symptom is that sv_reset tries to reset the PMf_USED flag of + # a trashed op but we look at the trashed op_type and segfault. + #my $adpmroot = ${$hv->PMROOT}; + my $adpmroot = 0; + $decl->add("static HV *hv$hv_index;"); + # XXX Beware of weird package names containing double-quotes, \n, ...? + $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]); + if ($adpmroot) { + $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;", + $adpmroot)); + } + $sym = savesym($hv, "hv$hv_index"); + $hv_index++; + return $sym; + } + # It's just an ordinary HV + $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0", + $hv->MAX, $hv->RITER)); + $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x", + $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS)); + my $sv_list_index = $svsect->index; + my @contents = $hv->ARRAY; + if (@contents) { + my $i; + for ($i = 1; $i < @contents; $i += 2) { + $contents[$i] = $contents[$i]->save; + } + $init->no_split; + $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];"); + while (@contents) { + my ($key, $value) = splice(@contents, 0, 2); + $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", + cstring($key),length(pack "a*",$key), + $value, hash($key))); +# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", +# cstring($key),length($key),$value, 0)); + } + $init->add("}"); + $init->split; + } + $hv->save_magic(); + return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); +} + +sub B::IO::save_data { + my( $io, $globname, @data ) = @_; + my $data = join '', @data; + + # XXX using $DATA might clobber it! + my $sym = svref_2object( \\$data )->save; + $init->add( split /\n/, <<CODE ); + { + GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV ); + SV* sv = $sym; + GvSV( gv ) = sv; + } +CODE + # for PerlIO::scalar + $use_xsloader = 1; + $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname ); +} + +sub B::IO::save { + my ($io) = @_; + my $sym = objsym($io); + return $sym if defined $sym; + my $pv = $io->PV; + $pv = '' unless defined $pv; + my $len = length($pv); + $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x", + $len, $len+1, $io->IVX, $io->NVX, $io->LINES, + $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT, + cstring($io->TOP_NAME), cstring($io->FMT_NAME), + cstring($io->BOTTOM_NAME), $io->SUBPROCESS, + cchar($io->IoTYPE), $io->IoFLAGS)); + $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", + $xpviosect->index, $io->REFCNT , $io->FLAGS)); + $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); + # deal with $x = *STDIN/STDOUT/STDERR{IO} + my $perlio_func; + foreach ( qw(stdin stdout stderr) ) { + $io->IsSTD($_) and $perlio_func = $_; + } + if( $perlio_func ) { + $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" ); + $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" ); + } + + my ($field, $fsym); + foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) { + $fsym = $io->$field(); + if ($$fsym) { + $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym)); + $fsym->save; + } + } + $io->save_magic; + return $sym; +} + +sub B::SV::save { + my $sv = shift; + # This is where we catch an honest-to-goodness Nullsv (which gets + # blessed into B::SV explicitly) and any stray erroneous SVs. + return 0 unless $$sv; + confess sprintf("cannot save that type of SV: %s (0x%x)\n", + class($sv), $$sv); +} + +sub output_all { + my $init_name = shift; + my $section; + my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect, + $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect, + $loopsect, $copsect, $svsect, $xpvsect, + $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, + $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); + $symsect->output(\*STDOUT, "#define %s\n"); + print "\n"; + output_declarations(); + foreach $section (@sections) { + my $lines = $section->index + 1; + if ($lines) { + my $name = $section->name; + my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); + print "Static $typename ${name}_list[$lines];\n"; + } + } + # XXX hack for when Perl accesses PVX of GVs + print 'Static char emptystring[] = "\0";'; + + $decl->output(\*STDOUT, "%s\n"); + print "\n"; + foreach $section (@sections) { + my $lines = $section->index + 1; + if ($lines) { + my $name = $section->name; + my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); + printf "static %s %s_list[%u] = {\n", $typename, $name, $lines; + $section->output(\*STDOUT, "\t{ %s }, /* %d */\n"); + print "};\n\n"; + } + } + + $init->output(\*STDOUT, "\t%s\n", $init_name ); + if ($verbose) { + warn compile_stats(); + warn "NULLOP count: $nullop_count\n"; + } +} + +sub output_declarations { + print <<'EOT'; +#ifdef BROKEN_STATIC_REDECL +#define Static extern +#else +#define Static static +#endif /* BROKEN_STATIC_REDECL */ + +#ifdef BROKEN_UNION_INIT +/* + * Cribbed from cv.h with ANY (a union) replaced by void*. + * Some pre-Standard compilers can't cope with initialising unions. Ho hum. + */ +typedef struct { + char * xpv_pv; /* pointer to malloced string */ + STRLEN xpv_cur; /* length of xp_pv as a C string */ + STRLEN xpv_len; /* allocated size */ + IV xof_off; /* integer value */ + NV xnv_nv; /* numeric value, if any */ + MAGIC* xmg_magic; /* magic for scalar array */ + HV* xmg_stash; /* class package */ + + HV * xcv_stash; + OP * xcv_start; + OP * xcv_root; + void (*xcv_xsub) (pTHX_ CV*); + ANY xcv_xsubany; + GV * xcv_gv; + char * xcv_file; + long xcv_depth; /* >= 2 indicates recursive call */ + AV * xcv_padlist; + CV * xcv_outside; +EOT + print <<'EOT' if $] < 5.009; +#ifdef USE_5005THREADS + perl_mutex *xcv_mutexp; + struct perl_thread *xcv_owner; /* current owner thread */ +#endif /* USE_5005THREADS */ +EOT + print <<'EOT'; + cv_flags_t xcv_flags; + U32 xcv_outside_seq; /* the COP sequence (at the point of our + * compilation) in the lexically enclosing + * sub */ +} XPVCV_or_similar; +#define ANYINIT(i) i +#else +#define XPVCV_or_similar XPVCV +#define ANYINIT(i) {i} +#endif /* BROKEN_UNION_INIT */ +#define Nullany ANYINIT(0) + +#define UNUSED 0 +#define sym_0 0 +EOT + print "static GV *gv_list[$gv_index];\n" if $gv_index; + print "\n"; +} + + +sub output_boilerplate { + print <<'EOT'; +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +/* Workaround for mapstart: the only op which needs a different ppaddr */ +#undef Perl_pp_mapstart +#define Perl_pp_mapstart Perl_pp_grepstart +#undef OP_MAPSTART +#define OP_MAPSTART OP_GREPSTART +#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); + +static void xs_init (pTHX); +static void dl_init (pTHX); +static PerlInterpreter *my_perl; +EOT +} + +sub init_op_addr { + my( $op_type, $num ) = @_; + my $op_list = $op_type."_list"; + + $init->add( split /\n/, <<EOT ); + { + int i; + + for( i = 0; i < ${num}; ++i ) + { + ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)]; + } + } +EOT +} + +sub init_op_warn { + my( $op_type, $num ) = @_; + my $op_list = $op_type."_list"; + + # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const + $init->add( split /\n/, <<EOT ); + { + int i; + + for( i = 0; i < ${num}; ++i ) + { + switch( (int)(${op_list}\[i].cop_warnings) ) + { + case 1: + ${op_list}\[i].cop_warnings = pWARN_ALL; + break; + case 2: + ${op_list}\[i].cop_warnings = pWARN_NONE; + break; + case 3: + ${op_list}\[i].cop_warnings = pWARN_STD; + break; + default: + break; + } + } + } +EOT +} + +sub output_main { + print <<'EOT'; +/* if USE_IMPLICIT_SYS, we need a 'real' exit */ +#if defined(exit) +#undef exit +#endif + +int +main(int argc, char **argv, char **env) +{ + int exitstatus; + int i; + char **fakeargv; + GV* tmpgv; + SV* tmpsv; + int options_count; + + PERL_SYS_INIT3(&argc,&argv,&env); + + if (!PL_do_undump) { + my_perl = perl_alloc(); + if (!my_perl) + exit(1); + perl_construct( my_perl ); + PL_perl_destruct_level = 0; + } +EOT + if( $ithreads ) { + # XXX init free elems! + my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref + + print <<EOT; +#ifdef USE_ITHREADS + for( i = 0; i < $pad_len; ++i ) { + av_push( PL_regex_padav, newSViv(0) ); + } + PL_regex_pad = AvARRAY( PL_regex_padav ); +#endif +EOT + } + + print <<'EOT'; +#ifdef CSH + if (!PL_cshlen) + PL_cshlen = strlen(PL_cshname); +#endif + +#ifdef ALLOW_PERL_OPTIONS +#define EXTRA_OPTIONS 3 +#else +#define EXTRA_OPTIONS 4 +#endif /* ALLOW_PERL_OPTIONS */ + Newx(fakeargv, argc + EXTRA_OPTIONS + 1, char *); + + fakeargv[0] = argv[0]; + fakeargv[1] = "-e"; + fakeargv[2] = ""; + options_count = 3; +EOT + # honour -T + print <<EOT; + if( ${^TAINT} ) { + fakeargv[options_count] = "-T"; + ++options_count; + } +EOT + print <<'EOT'; +#ifndef ALLOW_PERL_OPTIONS + fakeargv[options_count] = "--"; + ++options_count; +#endif /* ALLOW_PERL_OPTIONS */ + for (i = 1; i < argc; i++) + fakeargv[i + options_count - 1] = argv[i]; + fakeargv[argc + options_count - 1] = 0; + + exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1, + fakeargv, NULL); + + if (exitstatus) + exit( exitstatus ); + + TAINT; +EOT + + if( $use_perl_script_name ) { + my $dollar_0 = $0; + $dollar_0 =~ s/\\/\\\\/g; + $dollar_0 = '"' . $dollar_0 . '"'; + + print <<EOT; + if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */ + tmpsv = GvSV(tmpgv); + sv_setpv(tmpsv, ${dollar_0}); + SvSETMAGIC(tmpsv); + } +EOT + } + else { + print <<EOT; + if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */ + tmpsv = GvSV(tmpgv); + sv_setpv(tmpsv, argv[0]); + SvSETMAGIC(tmpsv); + } +EOT + } + + print <<'EOT'; + if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */ + tmpsv = GvSV(tmpgv); +#ifdef WIN32 + sv_setpv(tmpsv,"perl.exe"); +#else + sv_setpv(tmpsv,"perl"); +#endif + SvSETMAGIC(tmpsv); + } + + TAINT_NOT; + + /* PL_main_cv = PL_compcv; */ + PL_compcv = 0; + + exitstatus = perl_init(); + if (exitstatus) + exit( exitstatus ); + dl_init(aTHX); + + exitstatus = perl_run( my_perl ); + + perl_destruct( my_perl ); + perl_free( my_perl ); + + PERL_SYS_TERM(); + + exit( exitstatus ); +} + +/* yanked from perl.c */ +static void +xs_init(pTHX) +{ + char *file = __FILE__; + dTARG; + dSP; +EOT + print "\n#ifdef USE_DYNAMIC_LOADING"; + print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; + print "\n#endif\n" ; + # delete $xsub{'DynaLoader'}; + delete $xsub{'UNIVERSAL'}; + print("/* bootstrapping code*/\n\tSAVETMPS;\n"); + print("\ttarg=sv_newmortal();\n"); + print "#ifdef USE_DYNAMIC_LOADING\n"; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/; + print qq/\tPUTBACK;\n/; + print "\tboot_DynaLoader(aTHX_ NULL);\n"; + print qq/\tSPAGAIN;\n/; + print "#endif\n"; + foreach my $stashname (keys %xsub){ + if ($xsub{$stashname} !~ m/Dynamic/ ) { + my $stashxsub=$stashname; + $stashxsub =~ s/::/__/g; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/; + print qq/\tPUTBACK;\n/; + print "\tboot_$stashxsub(aTHX_ NULL);\n"; + print qq/\tSPAGAIN;\n/; + } + } + print("\tFREETMPS;\n/* end bootstrapping code */\n"); + print "}\n"; + +print <<'EOT'; +static void +dl_init(pTHX) +{ + char *file = __FILE__; + dTARG; + dSP; +EOT + print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); + print("\ttarg=sv_newmortal();\n"); + foreach my $stashname (@DynaLoader::dl_modules) { + warn "Loaded $stashname\n"; + if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) { + my $stashxsub=$stashname; + $stashxsub =~ s/::/__/g; + print "\tPUSHMARK(sp);\n"; + print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/; + print qq/\tPUTBACK;\n/; + print "#ifdef USE_DYNAMIC_LOADING\n"; + warn "bootstrapping $stashname added to xs_init\n"; + if( $xsub{$stashname} eq 'Dynamic' ) { + print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/; + } + else { + print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/; + } + print "#else\n"; + print "\tboot_$stashxsub(aTHX_ NULL);\n"; + print "#endif\n"; + print qq/\tSPAGAIN;\n/; + } + } + print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n"); + print "}\n"; +} +sub dump_symtable { + # For debugging + my ($sym, $val); + warn "----Symbol table:\n"; + while (($sym, $val) = each %symtable) { + warn "$sym => $val\n"; + } + warn "---End of symbol table\n"; +} + +sub save_object { + my $sv; + foreach $sv (@_) { + svref_2object($sv)->save; + } +} + +sub Dummy_BootStrap { } + +sub B::GV::savecv +{ + my $gv = shift; + my $package=$gv->STASH->NAME; + my $name = $gv->NAME; + my $cv = $gv->CV; + my $sv = $gv->SV; + my $av = $gv->AV; + my $hv = $gv->HV; + + my $fullname = $gv->STASH->NAME . "::" . $gv->NAME; + + # We may be looking at this package just because it is a branch in the + # symbol table which is on the path to a package which we need to save + # e.g. this is 'Getopt' and we need to save 'Getopt::Long' + # + return unless ($unused_sub_packages{$package}); + return unless ($$cv || $$av || $$sv || $$hv); + $gv->save; +} + +sub mark_package +{ + my $package = shift; + unless ($unused_sub_packages{$package}) + { + no strict 'refs'; + $unused_sub_packages{$package} = 1; + if (defined @{$package.'::ISA'}) + { + foreach my $isa (@{$package.'::ISA'}) + { + if ($isa eq 'DynaLoader') + { + unless (defined(&{$package.'::bootstrap'})) + { + warn "Forcing bootstrap of $package\n"; + eval { $package->bootstrap }; + } + } +# else + { + unless ($unused_sub_packages{$isa}) + { + warn "$isa saved (it is in $package\'s \@ISA)\n"; + mark_package($isa); + } + } + } + } + } + return 1; +} + +sub should_save +{ + no strict qw(vars refs); + my $package = shift; + $package =~ s/::$//; + return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. + # warn "Considering $package\n";#debug + foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages)) + { + # If this package is a prefix to something we are saving, traverse it + # but do not mark it for saving if it is not already + # e.g. to get to Getopt::Long we need to traverse Getopt but need + # not save Getopt + return 1 if ($u =~ /^$package\:\:/); + } + if (exists $unused_sub_packages{$package}) + { + # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; + delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ; + return $unused_sub_packages{$package}; + } + # Omit the packages which we use (and which cause grief + # because of fancy "goto &$AUTOLOAD" stuff). + # XXX Surely there must be a nicer way to do this. + if ($package eq "FileHandle" || $package eq "Config" || + $package eq "SelectSaver" || $package =~/^(B|IO)::/) + { + delete_unsaved_hashINC($package); + return $unused_sub_packages{$package} = 0; + } + # Now see if current package looks like an OO class this is probably too strong. + foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) + { + if (UNIVERSAL::can($package, $m)) + { + warn "$package has method $m: saving package\n";#debug + return mark_package($package); + } + } + delete_unsaved_hashINC($package); + return $unused_sub_packages{$package} = 0; +} +sub delete_unsaved_hashINC{ + my $packname=shift; + $packname =~ s/\:\:/\//g; + $packname .= '.pm'; +# warn "deleting $packname" if $INC{$packname} ;# debug + delete $INC{$packname}; +} +sub walkpackages +{ + my ($symref, $recurse, $prefix) = @_; + my $sym; + my $ref; + no strict 'vars'; + $prefix = '' unless defined $prefix; + while (($sym, $ref) = each %$symref) + { + local(*glob); + *glob = $ref; + if ($sym =~ /::$/) + { + $sym = $prefix . $sym; + if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) + { + walkpackages(\%glob, $recurse, $sym); + } + } + } +} + + +sub save_unused_subs +{ + no strict qw(refs); + &descend_marked_unused; + warn "Prescan\n"; + walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 }); + warn "Saving methods\n"; + walksymtable(\%{"main::"}, "savecv", \&should_save); +} + +sub save_context +{ + my $curpad_nam = (comppadlist->ARRAY)[0]->save; + my $curpad_sym = (comppadlist->ARRAY)[1]->save; + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; + my $amagic_generate= amagic_generation; + $init->add( "PL_curpad = AvARRAY($curpad_sym);", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", + "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + "PL_amagic_generation= $amagic_generate;" ); +} + +sub descend_marked_unused { + foreach my $pack (keys %unused_sub_packages) + { + mark_package($pack); + } +} + +sub save_main { + # this is mainly for the test suite + my $warner = $SIG{__WARN__}; + local $SIG{__WARN__} = sub { print STDERR @_ }; + + warn "Starting compile\n"; + warn "Walking tree\n"; + seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output + walkoptree(main_root, "save"); + warn "done main optree, walking symtable for extras\n" if $debug_cv; + save_unused_subs(); + # XSLoader was used, force saving of XSLoader::load + if( $use_xsloader ) { + my $cv = svref_2object( \&XSLoader::load ); + $cv->save; + } + # save %SIG ( in case it was set in a BEGIN block ) + if( $save_sig ) { + local $SIG{__WARN__} = $warner; + $init->no_split; + $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" ); + foreach my $k ( keys %SIG ) { + next unless ref $SIG{$k}; + my $cv = svref_2object( \$SIG{$k} ); + my $sv = $cv->save; + $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv ); + $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", + cstring($k),length(pack "a*",$k), + 'sv', hash($k))); + $init->add('mg_set(sv);','}'); + } + $init->add('}'); + $init->split; + } + # honour -w + $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W ); + # + my $init_av = init_av->save; + my $end_av = end_av->save; + $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), + sprintf("PL_main_start = s\\_%x;", ${main_start()}), + "PL_initav = (AV *) $init_av;", + "PL_endav = (AV*) $end_av;"); + save_context(); + # init op addrs ( must be the last action, otherwise + # some ops might not be initialized + if( $optimize_ppaddr ) { + foreach my $i ( @op_sections ) { + my $section = $$i; + next unless $section->index >= 0; + init_op_addr( $section->name, $section->index + 1); + } + } + init_op_warn( $copsect->name, $copsect->index + 1) + if $optimize_warn_sv && $copsect->index >= 0; + + warn "Writing output\n"; + output_boilerplate(); + print "\n"; + output_all("perl_init"); + print "\n"; + output_main(); +} + +sub init_sections { + my @sections = (decl => \$decl, sym => \$symsect, + binop => \$binopsect, condop => \$condopsect, + cop => \$copsect, padop => \$padopsect, + listop => \$listopsect, logop => \$logopsect, + loop => \$loopsect, op => \$opsect, pmop => \$pmopsect, + pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect, + sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect, + xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect, + xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, + xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, + xrv => \$xrvsect, xpvbm => \$xpvbmsect, + xpvio => \$xpviosect); + my ($name, $sectref); + while (($name, $sectref) = splice(@sections, 0, 2)) { + $$sectref = new B::C::Section $name, \%symtable, 0; + } + $init = new B::C::InitSection 'init', \%symtable, 0; +} + +sub mark_unused +{ + my ($arg,$val) = @_; + $unused_sub_packages{$arg} = $val; +} + +sub compile { + my @options = @_; + my ($option, $opt, $arg); + my @eval_at_startup; + my %option_map = ( 'cog' => \$pv_copy_on_grow, + 'save-data' => \$save_data_fh, + 'ppaddr' => \$optimize_ppaddr, + 'warn-sv' => \$optimize_warn_sv, + 'use-script-name' => \$use_perl_script_name, + 'save-sig-hash' => \$save_sig, + ); + my %optimization_map = ( 0 => [ qw() ], # special case + 1 => [ qw(-fcog) ], + 2 => [ qw(-fwarn-sv -fppaddr) ], + ); + OPTION: + while ($option = shift @options) { + if ($option =~ /^-(.)(.*)/) { + $opt = $1; + $arg = $2; + } else { + unshift @options, $option; + last OPTION; + } + if ($opt eq "-" && $arg eq "-") { + shift @options; + last OPTION; + } + if ($opt eq "w") { + $warn_undefined_syms = 1; + } elsif ($opt eq "D") { + $arg ||= shift @options; + foreach $arg (split(//, $arg)) { + if ($arg eq "o") { + B->debug(1); + } elsif ($arg eq "c") { + $debug_cops = 1; + } elsif ($arg eq "A") { + $debug_av = 1; + } elsif ($arg eq "C") { + $debug_cv = 1; + } elsif ($arg eq "M") { + $debug_mg = 1; + } else { + warn "ignoring unknown debug option: $arg\n"; + } + } + } elsif ($opt eq "o") { + $arg ||= shift @options; + open(STDOUT, ">$arg") or return "$arg: $!\n"; + } elsif ($opt eq "v") { + $verbose = 1; + } elsif ($opt eq "u") { + $arg ||= shift @options; + mark_unused($arg,undef); + } elsif ($opt eq "f") { + $arg ||= shift @options; + $arg =~ m/(no-)?(.*)/; + my $no = defined($1) && $1 eq 'no-'; + $arg = $no ? $2 : $arg; + if( exists $option_map{$arg} ) { + ${$option_map{$arg}} = !$no; + } else { + die "Invalid optimization '$arg'"; + } + } elsif ($opt eq "O") { + $arg = 1 if $arg eq ""; + my @opt; + foreach my $i ( 1 .. $arg ) { + push @opt, @{$optimization_map{$i}} + if exists $optimization_map{$i}; + } + unshift @options, @opt; + } elsif ($opt eq "e") { + push @eval_at_startup, $arg; + } elsif ($opt eq "l") { + $max_string_len = $arg; + } + } + init_sections(); + foreach my $i ( @eval_at_startup ) { + $init->add_eval( $i ); + } + if (@options) { + return sub { + my $objname; + foreach $objname (@options) { + eval "save_object(\\$objname)"; + } + output_all(); + } + } else { + return sub { save_main() }; + } +} + +1; + +__END__ + +=head1 NAME + +B::C - Perl compiler's C backend + +=head1 SYNOPSIS + + perl -MO=C[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This compiler backend takes Perl source and generates C source code +corresponding to the internal structures that perl uses to run +your program. When the generated C source is compiled and run, it +cuts out the time which perl would have taken to load and parse +your program into its internal semi-compiled form. That means that +compiling with this backend will not help improve the runtime +execution speed of your program but may improve the start-up time. +Depending on the environment in which your program runs this may be +either a help or a hindrance. + +=head1 OPTIONS + +If there are any non-option arguments, they are taken to be +names of objects to be saved (probably doesn't work properly yet). +Without extra arguments, it saves the main program. + +=over 4 + +=item B<-ofilename> + +Output to filename instead of STDOUT + +=item B<-v> + +Verbose compilation (currently gives a few compilation statistics). + +=item B<--> + +Force end of options + +=item B<-uPackname> + +Force apparently unused subs from package Packname to be compiled. +This allows programs to use eval "foo()" even when sub foo is never +seen to be used at compile time. The down side is that any subs which +really are never used also have code generated. This option is +necessary, for example, if you have a signal handler foo which you +initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just +to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> +options. The compiler tries to figure out which packages may possibly +have subs in which need compiling but the current version doesn't do +it very well. In particular, it is confused by nested packages (i.e. +of the form C<A::B>) where package C<A> does not contain any subs. + +=item B<-D> + +Debug options (concatenated or separate flags like C<perl -D>). + +=item B<-Do> + +OPs, prints each OP as it's processed + +=item B<-Dc> + +COPs, prints COPs as processed (incl. file & line num) + +=item B<-DA> + +prints AV information on saving + +=item B<-DC> + +prints CV information on saving + +=item B<-DM> + +prints MAGIC information on saving + +=item B<-f> + +Force options/optimisations on or off one at a time. You can explicitly +disable an option using B<-fno-option>. All options default to +B<disabled>. + +=over 4 + +=item B<-fcog> + +Copy-on-grow: PVs declared and initialised statically. + +=item B<-fsave-data> + +Save package::DATA filehandles ( only available with PerlIO ). + +=item B<-fppaddr> + +Optimize the initialization of op_ppaddr. + +=item B<-fwarn-sv> + +Optimize the initialization of cop_warnings. + +=item B<-fuse-script-name> + +Use the script name instead of the program name as $0. + +=item B<-fsave-sig-hash> + +Save compile-time modifications to the %SIG hash. + +=back + +=item B<-On> + +Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. + +=over 4 + +=item B<-O0> + +Disable all optimizations. + +=item B<-O1> + +Enable B<-fcog>. + +=item B<-O2> + +Enable B<-fppaddr>, B<-fwarn-sv>. + +=back + +=item B<-llimit> + +Some C compilers impose an arbitrary limit on the length of string +constants (e.g. 2048 characters for Microsoft Visual C++). The +B<-llimit> options tells the C backend not to generate string literals +exceeding that limit. + +=back + +=head1 EXAMPLES + + perl -MO=C,-ofoo.c foo.pl + perl cc_harness -o foo foo.c + +Note that C<cc_harness> lives in the C<B> subdirectory of your perl +library directory. The utility called C<perlcc> may also be used to +help make use of this compiler. + + perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null + +=head1 BUGS + +Plenty. Current status: experimental. + +=head1 AUTHOR + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> + +=cut diff --git a/Master/tlpkg/installer/perllib/B/CC.pm b/Master/tlpkg/installer/perllib/B/CC.pm new file mode 100644 index 00000000000..079313a0a4e --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/CC.pm @@ -0,0 +1,2005 @@ +# CC.pm +# +# Copyright (c) 1996, 1997, 1998 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +package B::CC; + +our $VERSION = '1.00_01'; + +use Config; +use strict; +use B qw(main_start main_root class comppadlist peekop svref_2object + timing_info init_av sv_undef amagic_generation + OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL + OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV + OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR + CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK + ); +use B::C qw(save_unused_subs objsym init_sections mark_unused + output_all output_boilerplate output_main); +use B::Bblock qw(find_leaders); +use B::Stackobj qw(:types :flags); + +# These should probably be elsewhere +# Flags for $op->flags + +my $module; # module name (when compiled with -m) +my %done; # hash keyed by $$op of leaders of basic blocks + # which have already been done. +my $leaders; # ref to hash of basic block leaders. Keys are $$op + # addresses, values are the $op objects themselves. +my @bblock_todo; # list of leaders of basic blocks that need visiting + # sometime. +my @cc_todo; # list of tuples defining what PP code needs to be + # saved (e.g. CV, main or PMOP repl code). Each tuple + # is [$name, $root, $start, @padlist]. PMOP repl code + # tuples inherit padlist. +my @stack; # shadows perl's stack when contents are known. + # Values are objects derived from class B::Stackobj +my @pad; # Lexicals in current pad as Stackobj-derived objects +my @padlist; # Copy of current padlist so PMOP repl code can find it +my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo +my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs +my %constobj; # OP_CONST constants as Stackobj-derived objects + # keyed by $$sv. +my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic + # block or even to the end of each loop of blocks, + # depending on optimisation options. +my $know_op = 0; # Set when C variable op already holds the right op + # (from an immediately preceding DOOP(ppname)). +my $errors = 0; # Number of errors encountered +my %skip_stack; # Hash of PP names which don't need write_back_stack +my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals +my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals +my %ignore_op; # Hash of ops which do nothing except returning op_next +my %need_curcop; # Hash of ops which need PL_curcop + +my %lexstate; #state of padsvs at the start of a bblock + +BEGIN { + foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) { + $ignore_op{$_} = 1; + } +} + +my ($module_name); +my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime, + $debug_shadow, $debug_queue, $debug_lineno, $debug_timings); + +# Optimisation options. On the command line, use hyphens instead of +# underscores for compatibility with gcc-style options. We use +# underscores here because they are OK in (strict) barewords. +my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint); +my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock, + freetmps_each_loop => \$freetmps_each_loop, + omit_taint => \$omit_taint); +# perl patchlevel to generate code for (defaults to current patchlevel) +my $patchlevel = int(0.5 + 1000 * ($] - 5)); + +# Could rewrite push_runtime() and output_runtime() to use a +# temporary file if memory is at a premium. +my $ppname; # name of current fake PP function +my $runtime_list_ref; +my $declare_ref; # Hash ref keyed by C variable type of declarations. + +my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref] + # tuples to be written out. + +my ($init, $decl); + +sub init_hash { map { $_ => 1 } @_ } + +# +# Initialise the hashes for the default PP functions where we can avoid +# either write_back_stack, write_back_lexicals or invalidate_lexicals. +# +%skip_lexicals = init_hash qw(pp_enter pp_enterloop); +%skip_invalidate = init_hash qw(pp_enter pp_enterloop); +%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller + pp_reset pp_rv2cv pp_entereval pp_require pp_dofile + pp_entertry pp_enterloop pp_enteriter pp_entersub + pp_enter pp_method); + +sub debug { + if ($debug_runtime) { + warn(@_); + } else { + my @tmp=@_; + runtime(map { chomp; "/* $_ */"} @tmp); + } +} + +sub declare { + my ($type, $var) = @_; + push(@{$declare_ref->{$type}}, $var); +} + +sub push_runtime { + push(@$runtime_list_ref, @_); + warn join("\n", @_) . "\n" if $debug_runtime; +} + +sub save_runtime { + push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]); +} + +sub output_runtime { + my $ppdata; + print qq(#include "cc_runtime.h"\n); + foreach $ppdata (@pp_list) { + my ($name, $runtime, $declare) = @$ppdata; + print "\nstatic\nCCPP($name)\n{\n"; + my ($type, $varlist, $line); + while (($type, $varlist) = each %$declare) { + print "\t$type ", join(", ", @$varlist), ";\n"; + } + foreach $line (@$runtime) { + print $line, "\n"; + } + print "}\n"; + } +} + +sub runtime { + my $line; + foreach $line (@_) { + push_runtime("\t$line"); + } +} + +sub init_pp { + $ppname = shift; + $runtime_list_ref = []; + $declare_ref = {}; + runtime("dSP;"); + declare("I32", "oldsave"); + declare("SV", "**svp"); + map { declare("SV", "*$_") } qw(sv src dst left right); + declare("MAGIC", "*mg"); + $decl->add("static OP * $ppname (pTHX);"); + debug "init_pp: $ppname\n" if $debug_queue; +} + +# Initialise runtime_callback function for Stackobj class +BEGIN { B::Stackobj::set_callback(\&runtime) } + +# Initialise saveoptree_callback for B::C class +sub cc_queue { + my ($name, $root, $start, @pl) = @_; + debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n" + if $debug_queue; + if ($name eq "*ignore*") { + $name = 0; + } else { + push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]); + } + my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name); + $start = $fakeop->save; + debug "cc_queue: name $name returns $start\n" if $debug_queue; + return $start; +} +BEGIN { B::C::set_callback(\&cc_queue) } + +sub valid_int { $_[0]->{flags} & VALID_INT } +sub valid_double { $_[0]->{flags} & VALID_DOUBLE } +sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) } +sub valid_sv { $_[0]->{flags} & VALID_SV } + +sub top_int { @stack ? $stack[-1]->as_int : "TOPi" } +sub top_double { @stack ? $stack[-1]->as_double : "TOPn" } +sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" } +sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" } +sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" } + +sub pop_int { @stack ? (pop @stack)->as_int : "POPi" } +sub pop_double { @stack ? (pop @stack)->as_double : "POPn" } +sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" } +sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" } +sub pop_bool { + if (@stack) { + return ((pop @stack)->as_bool); + } else { + # Careful: POPs has an auto-decrement and SvTRUE evaluates + # its argument more than once. + runtime("sv = POPs;"); + return "SvTRUE(sv)"; + } +} + +sub write_back_lexicals { + my $avoid = shift || 0; + debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n" + if $debug_shadow; + my $lex; + foreach $lex (@pad) { + next unless ref($lex); + $lex->write_back unless $lex->{flags} & $avoid; + } +} + +sub save_or_restore_lexical_state { + my $bblock=shift; + unless( exists $lexstate{$bblock}){ + foreach my $lex (@pad) { + next unless ref($lex); + ${$lexstate{$bblock}}{$lex->{iv}} = $lex->{flags} ; + } + } + else { + foreach my $lex (@pad) { + next unless ref($lex); + my $old_flags=${$lexstate{$bblock}}{$lex->{iv}} ; + next if ( $old_flags eq $lex->{flags}); + if (($old_flags & VALID_SV) && !($lex->{flags} & VALID_SV)){ + $lex->write_back; + } + if (($old_flags & VALID_DOUBLE) && !($lex->{flags} & VALID_DOUBLE)){ + $lex->load_double; + } + if (($old_flags & VALID_INT) && !($lex->{flags} & VALID_INT)){ + $lex->load_int; + } + } + } +} + +sub write_back_stack { + my $obj; + return unless @stack; + runtime(sprintf("EXTEND(sp, %d);", scalar(@stack))); + foreach $obj (@stack) { + runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv)); + } + @stack = (); +} + +sub invalidate_lexicals { + my $avoid = shift || 0; + debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n" + if $debug_shadow; + my $lex; + foreach $lex (@pad) { + next unless ref($lex); + $lex->invalidate unless $lex->{flags} & $avoid; + } +} + +sub reload_lexicals { + my $lex; + foreach $lex (@pad) { + next unless ref($lex); + my $type = $lex->{type}; + if ($type == T_INT) { + $lex->as_int; + } elsif ($type == T_DOUBLE) { + $lex->as_double; + } else { + $lex->as_sv; + } + } +} + +{ + package B::Pseudoreg; + # + # This class allocates pseudo-registers (OK, so they're C variables). + # + my %alloc; # Keyed by variable name. A value of 1 means the + # variable has been declared. A value of 2 means + # it's in use. + + sub new_scope { %alloc = () } + + sub new ($$$) { + my ($class, $type, $prefix) = @_; + my ($ptr, $i, $varname, $status, $obj); + $prefix =~ s/^(\**)//; + $ptr = $1; + $i = 0; + do { + $varname = "$prefix$i"; + $status = $alloc{$varname}; + } while $status == 2; + if ($status != 1) { + # Not declared yet + B::CC::declare($type, "$ptr$varname"); + $alloc{$varname} = 2; # declared and in use + } + $obj = bless \$varname, $class; + return $obj; + } + sub DESTROY { + my $obj = shift; + $alloc{$$obj} = 1; # no longer in use but still declared + } +} +{ + package B::Shadow; + # + # This class gives a standard API for a perl object to shadow a + # C variable and only generate reloads/write-backs when necessary. + # + # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo"). + # Use $obj->write_back whenever shadowed_c_var needs to be up to date. + # Use $obj->invalidate whenever an unknown function may have + # set shadow itself. + + sub new { + my ($class, $write_back) = @_; + # Object fields are perl shadow variable, validity flag + # (for *C* variable) and callback sub for write_back + # (passed perl shadow variable as argument). + bless [undef, 1, $write_back], $class; + } + sub load { + my ($obj, $newval) = @_; + $obj->[1] = 0; # C variable no longer valid + $obj->[0] = $newval; + } + sub write_back { + my $obj = shift; + if (!($obj->[1])) { + $obj->[1] = 1; # C variable will now be valid + &{$obj->[2]}($obj->[0]); + } + } + sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid +} +my $curcop = new B::Shadow (sub { + my $opsym = shift->save; + runtime("PL_curcop = (COP*)$opsym;"); +}); + +# +# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on. +# +sub dopoptoloop { + my $cxix = $#cxstack; + while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) { + $cxix--; + } + debug "dopoptoloop: returning $cxix" if $debug_cxstack; + return $cxix; +} + +sub dopoptolabel { + my $label = shift; + my $cxix = $#cxstack; + while ($cxix >= 0 && + ($cxstack[$cxix]->{type} != CXt_LOOP || + $cxstack[$cxix]->{label} ne $label)) { + $cxix--; + } + debug "dopoptolabel: returning $cxix" if $debug_cxstack; + return $cxix; +} + +sub error { + my $format = shift; + my $file = $curcop->[0]->file; + my $line = $curcop->[0]->line; + $errors++; + if (@_) { + warn sprintf("%s:%d: $format\n", $file, $line, @_); + } else { + warn sprintf("%s:%d: %s\n", $file, $line, $format); + } +} + +# +# Load pad takes (the elements of) a PADLIST as arguments and loads +# up @pad with Stackobj-derived objects which represent those lexicals. +# If/when perl itself can generate type information (my int $foo) then +# we'll take advantage of that here. Until then, we'll use various hacks +# to tell the compiler when we want a lexical to be a particular type +# or to be a register. +# +sub load_pad { + my ($namelistav, $valuelistav) = @_; + @padlist = @_; + my @namelist = $namelistav->ARRAY; + my @valuelist = $valuelistav->ARRAY; + my $ix; + @pad = (); + debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad; + # Temporary lexicals don't get named so it's possible for @valuelist + # to be strictly longer than @namelist. We count $ix up to the end of + # @valuelist but index into @namelist for the name. Any temporaries which + # run off the end of @namelist will make $namesv undefined and we treat + # that the same as having an explicit SPECIAL sv_undef object in @namelist. + # [XXX If/when @_ becomes a lexical, we must start at 0 here.] + for ($ix = 1; $ix < @valuelist; $ix++) { + my $namesv = $namelist[$ix]; + my $type = T_UNKNOWN; + my $flags = 0; + my $name = "tmp$ix"; + my $class = class($namesv); + if (!defined($namesv) || $class eq "SPECIAL") { + # temporaries have &PL_sv_undef instead of a PVNV for a name + $flags = VALID_SV|TEMPORARY|REGISTER; + } else { + if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) { + $name = $1; + if ($2 eq "i") { + $type = T_INT; + $flags = VALID_SV|VALID_INT; + } elsif ($2 eq "d") { + $type = T_DOUBLE; + $flags = VALID_SV|VALID_DOUBLE; + } + $flags |= REGISTER if $3; + } + } + $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix, + "i_$name", "d_$name"); + + debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad; + } +} + +sub declare_pad { + my $ix; + for ($ix = 1; $ix <= $#pad; $ix++) { + my $type = $pad[$ix]->{type}; + declare("IV", $type == T_INT ? + sprintf("%s=0",$pad[$ix]->{iv}):$pad[$ix]->{iv}) if $pad[$ix]->save_int; + declare("double", $type == T_DOUBLE ? + sprintf("%s = 0",$pad[$ix]->{nv}):$pad[$ix]->{nv} )if $pad[$ix]->save_double; + + } +} +# +# Debugging stuff +# +sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) } + +# +# OP stuff +# + +sub label { + my $op = shift; + # XXX Preserve original label name for "real" labels? + return sprintf("lab_%x", $$op); +} + +sub write_label { + my $op = shift; + push_runtime(sprintf(" %s:", label($op))); +} + +sub loadop { + my $op = shift; + my $opsym = $op->save; + runtime("PL_op = $opsym;") unless $know_op; + return $opsym; +} + +sub doop { + my $op = shift; + my $ppname = $op->ppaddr; + my $sym = loadop($op); + runtime("DOOP($ppname);"); + $know_op = 1; + return $sym; +} + +sub gimme { + my $op = shift; + my $flags = $op->flags; + return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "dowantarray()"); +} + +# +# Code generation for PP code +# + +sub pp_null { + my $op = shift; + return $op->next; +} + +sub pp_stub { + my $op = shift; + my $gimme = gimme($op); + if ($gimme != G_ARRAY) { + my $obj= new B::Stackobj::Const(sv_undef); + push(@stack, $obj); + # XXX Change to push a constant sv_undef Stackobj onto @stack + #write_back_stack(); + #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);"); + } + return $op->next; +} + +sub pp_unstack { + my $op = shift; + @stack = (); + runtime("PP_UNSTACK;"); + return $op->next; +} + +sub pp_and { + my $op = shift; + my $next = $op->next; + reload_lexicals(); + unshift(@bblock_todo, $next); + if (@stack >= 1) { + my $bool = pop_bool(); + write_back_stack(); + save_or_restore_lexical_state($$next); + runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next))); + } else { + save_or_restore_lexical_state($$next); + runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)), + "*sp--;"); + } + return $op->other; +} + +sub pp_or { + my $op = shift; + my $next = $op->next; + reload_lexicals(); + unshift(@bblock_todo, $next); + if (@stack >= 1) { + my $bool = pop_bool @stack; + write_back_stack(); + save_or_restore_lexical_state($$next); + runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }", + $bool, label($next))); + } else { + save_or_restore_lexical_state($$next); + runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)), + "*sp--;"); + } + return $op->other; +} + +sub pp_cond_expr { + my $op = shift; + my $false = $op->next; + unshift(@bblock_todo, $false); + reload_lexicals(); + my $bool = pop_bool(); + write_back_stack(); + save_or_restore_lexical_state($$false); + runtime(sprintf("if (!$bool) goto %s;", label($false))); + return $op->other; +} + +sub pp_padsv { + my $op = shift; + my $ix = $op->targ; + push(@stack, $pad[$ix]); + if ($op->flags & OPf_MOD) { + my $private = $op->private; + if ($private & OPpLVAL_INTRO) { + runtime("SAVECLEARSV(PL_curpad[$ix]);"); + } elsif ($private & OPpDEREF) { + runtime(sprintf("vivify_ref(PL_curpad[%d], %d);", + $ix, $private & OPpDEREF)); + $pad[$ix]->invalidate; + } + } + return $op->next; +} + +sub pp_const { + my $op = shift; + my $sv = $op->sv; + my $obj; + # constant could be in the pad (under useithreads) + if ($$sv) { + $obj = $constobj{$$sv}; + if (!defined($obj)) { + $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv); + } + } + else { + $obj = $pad[$op->targ]; + } + push(@stack, $obj); + return $op->next; +} + +sub pp_nextstate { + my $op = shift; + $curcop->load($op); + @stack = (); + debug(sprintf("%s:%d\n", $op->file, $op->line)) if $debug_lineno; + runtime("TAINT_NOT;") unless $omit_taint; + runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;"); + if ($freetmps_each_bblock || $freetmps_each_loop) { + $need_freetmps = 1; + } else { + runtime("FREETMPS;"); + } + return $op->next; +} + +sub pp_dbstate { + my $op = shift; + $curcop->invalidate; # XXX? + return default_pp($op); +} + +#default_pp will handle this: +#sub pp_bless { $curcop->write_back; default_pp(@_) } +#sub pp_repeat { $curcop->write_back; default_pp(@_) } +# The following subs need $curcop->write_back if we decide to support arybase: +# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice +#sub pp_caller { $curcop->write_back; default_pp(@_) } +#sub pp_reset { $curcop->write_back; default_pp(@_) } + +sub pp_rv2gv{ + my $op =shift; + $curcop->write_back; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + my $sym=doop($op); + if ($op->private & OPpDEREF) { + $init->add(sprintf("((UNOP *)$sym)->op_first = $sym;")); + $init->add(sprintf("((UNOP *)$sym)->op_type = %d;", + $op->first->type)); + } + return $op->next; +} +sub pp_sort { + my $op = shift; + my $ppname = $op->ppaddr; + if ( $op->flags & OPf_SPECIAL && $op->flags & OPf_STACKED){ + #this indicates the sort BLOCK Array case + #ugly surgery required. + my $root=$op->first->sibling->first; + my $start=$root->first; + $op->first->save; + $op->first->sibling->save; + $root->save; + my $sym=$start->save; + my $fakeop=cc_queue("pp_sort".$$op,$root,$start); + $init->add(sprintf("(%s)->op_next=%s;",$sym,$fakeop)); + } + $curcop->write_back; + write_back_lexicals(); + write_back_stack(); + doop($op); + return $op->next; +} + +sub pp_gv { + my $op = shift; + my $gvsym; + if ($Config{useithreads}) { + $gvsym = $pad[$op->padix]->as_sv; + } + else { + $gvsym = $op->gv->save; + } + write_back_stack(); + runtime("XPUSHs((SV*)$gvsym);"); + return $op->next; +} + +sub pp_gvsv { + my $op = shift; + my $gvsym; + if ($Config{useithreads}) { + $gvsym = $pad[$op->padix]->as_sv; + } + else { + $gvsym = $op->gv->save; + } + write_back_stack(); + if ($op->private & OPpLVAL_INTRO) { + runtime("XPUSHs(save_scalar($gvsym));"); + } else { + runtime("XPUSHs(GvSV($gvsym));"); + } + return $op->next; +} + +sub pp_aelemfast { + my $op = shift; + my $gvsym; + if ($Config{useithreads}) { + $gvsym = $pad[$op->padix]->as_sv; + } + else { + $gvsym = $op->gv->save; + } + my $ix = $op->private; + my $flag = $op->flags & OPf_MOD; + write_back_stack(); + runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);", + "PUSHs(svp ? *svp : &PL_sv_undef);"); + return $op->next; +} + +sub int_binop { + my ($op, $operator) = @_; + if ($op->flags & OPf_STACKED) { + my $right = pop_int(); + if (@stack >= 1) { + my $left = top_int(); + $stack[-1]->set_int(&$operator($left, $right)); + } else { + runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right))); + } + } else { + my $targ = $pad[$op->targ]; + my $right = new B::Pseudoreg ("IV", "riv"); + my $left = new B::Pseudoreg ("IV", "liv"); + runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int)); + $targ->set_int(&$operator($$left, $$right)); + push(@stack, $targ); + } + return $op->next; +} + +sub INTS_CLOSED () { 0x1 } +sub INT_RESULT () { 0x2 } +sub NUMERIC_RESULT () { 0x4 } + +sub numeric_binop { + my ($op, $operator, $flags) = @_; + my $force_int = 0; + $force_int ||= ($flags & INT_RESULT); + $force_int ||= ($flags & INTS_CLOSED && @stack >= 2 + && valid_int($stack[-2]) && valid_int($stack[-1])); + if ($op->flags & OPf_STACKED) { + my $right = pop_numeric(); + if (@stack >= 1) { + my $left = top_numeric(); + if ($force_int) { + $stack[-1]->set_int(&$operator($left, $right)); + } else { + $stack[-1]->set_numeric(&$operator($left, $right)); + } + } else { + if ($force_int) { + my $rightruntime = new B::Pseudoreg ("IV", "riv"); + runtime(sprintf("$$rightruntime = %s;",$right)); + runtime(sprintf("sv_setiv(TOPs, %s);", + &$operator("TOPi", $$rightruntime))); + } else { + my $rightruntime = new B::Pseudoreg ("double", "rnv"); + runtime(sprintf("$$rightruntime = %s;",$right)); + runtime(sprintf("sv_setnv(TOPs, %s);", + &$operator("TOPn",$$rightruntime))); + } + } + } else { + my $targ = $pad[$op->targ]; + $force_int ||= ($targ->{type} == T_INT); + if ($force_int) { + my $right = new B::Pseudoreg ("IV", "riv"); + my $left = new B::Pseudoreg ("IV", "liv"); + runtime(sprintf("$$right = %s; $$left = %s;", + pop_numeric(), pop_numeric)); + $targ->set_int(&$operator($$left, $$right)); + } else { + my $right = new B::Pseudoreg ("double", "rnv"); + my $left = new B::Pseudoreg ("double", "lnv"); + runtime(sprintf("$$right = %s; $$left = %s;", + pop_numeric(), pop_numeric)); + $targ->set_numeric(&$operator($$left, $$right)); + } + push(@stack, $targ); + } + return $op->next; +} + +sub pp_ncmp { + my ($op) = @_; + if ($op->flags & OPf_STACKED) { + my $right = pop_numeric(); + if (@stack >= 1) { + my $left = top_numeric(); + runtime sprintf("if (%s > %s){",$left,$right); + $stack[-1]->set_int(1); + $stack[-1]->write_back(); + runtime sprintf("}else if (%s < %s ) {",$left,$right); + $stack[-1]->set_int(-1); + $stack[-1]->write_back(); + runtime sprintf("}else if (%s == %s) {",$left,$right); + $stack[-1]->set_int(0); + $stack[-1]->write_back(); + runtime sprintf("}else {"); + $stack[-1]->set_sv("&PL_sv_undef"); + runtime "}"; + } else { + my $rightruntime = new B::Pseudoreg ("double", "rnv"); + runtime(sprintf("$$rightruntime = %s;",$right)); + runtime sprintf(qq/if ("TOPn" > %s){/,$rightruntime); + runtime sprintf("sv_setiv(TOPs,1);"); + runtime sprintf(qq/}else if ( "TOPn" < %s ) {/,$$rightruntime); + runtime sprintf("sv_setiv(TOPs,-1);"); + runtime sprintf(qq/} else if ("TOPn" == %s) {/,$$rightruntime); + runtime sprintf("sv_setiv(TOPs,0);"); + runtime sprintf(qq/}else {/); + runtime sprintf("sv_setiv(TOPs,&PL_sv_undef;"); + runtime "}"; + } + } else { + my $targ = $pad[$op->targ]; + my $right = new B::Pseudoreg ("double", "rnv"); + my $left = new B::Pseudoreg ("double", "lnv"); + runtime(sprintf("$$right = %s; $$left = %s;", + pop_numeric(), pop_numeric)); + runtime sprintf("if (%s > %s){",$$left,$$right); + $targ->set_int(1); + $targ->write_back(); + runtime sprintf("}else if (%s < %s ) {",$$left,$$right); + $targ->set_int(-1); + $targ->write_back(); + runtime sprintf("}else if (%s == %s) {",$$left,$$right); + $targ->set_int(0); + $targ->write_back(); + runtime sprintf("}else {"); + $targ->set_sv("&PL_sv_undef"); + runtime "}"; + push(@stack, $targ); + } + return $op->next; +} + +sub sv_binop { + my ($op, $operator, $flags) = @_; + if ($op->flags & OPf_STACKED) { + my $right = pop_sv(); + if (@stack >= 1) { + my $left = top_sv(); + if ($flags & INT_RESULT) { + $stack[-1]->set_int(&$operator($left, $right)); + } elsif ($flags & NUMERIC_RESULT) { + $stack[-1]->set_numeric(&$operator($left, $right)); + } else { + # XXX Does this work? + runtime(sprintf("sv_setsv($left, %s);", + &$operator($left, $right))); + $stack[-1]->invalidate; + } + } else { + my $f; + if ($flags & INT_RESULT) { + $f = "sv_setiv"; + } elsif ($flags & NUMERIC_RESULT) { + $f = "sv_setnv"; + } else { + $f = "sv_setsv"; + } + runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right))); + } + } else { + my $targ = $pad[$op->targ]; + runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv)); + if ($flags & INT_RESULT) { + $targ->set_int(&$operator("left", "right")); + } elsif ($flags & NUMERIC_RESULT) { + $targ->set_numeric(&$operator("left", "right")); + } else { + # XXX Does this work? + runtime(sprintf("sv_setsv(%s, %s);", + $targ->as_sv, &$operator("left", "right"))); + $targ->invalidate; + } + push(@stack, $targ); + } + return $op->next; +} + +sub bool_int_binop { + my ($op, $operator) = @_; + my $right = new B::Pseudoreg ("IV", "riv"); + my $left = new B::Pseudoreg ("IV", "liv"); + runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int())); + my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); + $bool->set_int(&$operator($$left, $$right)); + push(@stack, $bool); + return $op->next; +} + +sub bool_numeric_binop { + my ($op, $operator) = @_; + my $right = new B::Pseudoreg ("double", "rnv"); + my $left = new B::Pseudoreg ("double", "lnv"); + runtime(sprintf("$$right = %s; $$left = %s;", + pop_numeric(), pop_numeric())); + my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); + $bool->set_numeric(&$operator($$left, $$right)); + push(@stack, $bool); + return $op->next; +} + +sub bool_sv_binop { + my ($op, $operator) = @_; + runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv())); + my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b")); + $bool->set_numeric(&$operator("left", "right")); + push(@stack, $bool); + return $op->next; +} + +sub infix_op { + my $opname = shift; + return sub { "$_[0] $opname $_[1]" } +} + +sub prefix_op { + my $opname = shift; + return sub { sprintf("%s(%s)", $opname, join(", ", @_)) } +} + +BEGIN { + my $plus_op = infix_op("+"); + my $minus_op = infix_op("-"); + my $multiply_op = infix_op("*"); + my $divide_op = infix_op("/"); + my $modulo_op = infix_op("%"); + my $lshift_op = infix_op("<<"); + my $rshift_op = infix_op(">>"); + my $scmp_op = prefix_op("sv_cmp"); + my $seq_op = prefix_op("sv_eq"); + my $sne_op = prefix_op("!sv_eq"); + my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" }; + my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" }; + my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" }; + my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" }; + my $eq_op = infix_op("=="); + my $ne_op = infix_op("!="); + my $lt_op = infix_op("<"); + my $gt_op = infix_op(">"); + my $le_op = infix_op("<="); + my $ge_op = infix_op(">="); + + # + # XXX The standard perl PP code has extra handling for + # some special case arguments of these operators. + # + sub pp_add { numeric_binop($_[0], $plus_op) } + sub pp_subtract { numeric_binop($_[0], $minus_op) } + sub pp_multiply { numeric_binop($_[0], $multiply_op) } + sub pp_divide { numeric_binop($_[0], $divide_op) } + sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's + + sub pp_left_shift { int_binop($_[0], $lshift_op) } + sub pp_right_shift { int_binop($_[0], $rshift_op) } + sub pp_i_add { int_binop($_[0], $plus_op) } + sub pp_i_subtract { int_binop($_[0], $minus_op) } + sub pp_i_multiply { int_binop($_[0], $multiply_op) } + sub pp_i_divide { int_binop($_[0], $divide_op) } + sub pp_i_modulo { int_binop($_[0], $modulo_op) } + + sub pp_eq { bool_numeric_binop($_[0], $eq_op) } + sub pp_ne { bool_numeric_binop($_[0], $ne_op) } + sub pp_lt { bool_numeric_binop($_[0], $lt_op) } + sub pp_gt { bool_numeric_binop($_[0], $gt_op) } + sub pp_le { bool_numeric_binop($_[0], $le_op) } + sub pp_ge { bool_numeric_binop($_[0], $ge_op) } + + sub pp_i_eq { bool_int_binop($_[0], $eq_op) } + sub pp_i_ne { bool_int_binop($_[0], $ne_op) } + sub pp_i_lt { bool_int_binop($_[0], $lt_op) } + sub pp_i_gt { bool_int_binop($_[0], $gt_op) } + sub pp_i_le { bool_int_binop($_[0], $le_op) } + sub pp_i_ge { bool_int_binop($_[0], $ge_op) } + + sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) } + sub pp_slt { bool_sv_binop($_[0], $slt_op) } + sub pp_sgt { bool_sv_binop($_[0], $sgt_op) } + sub pp_sle { bool_sv_binop($_[0], $sle_op) } + sub pp_sge { bool_sv_binop($_[0], $sge_op) } + sub pp_seq { bool_sv_binop($_[0], $seq_op) } + sub pp_sne { bool_sv_binop($_[0], $sne_op) } +} + + +sub pp_sassign { + my $op = shift; + my $backwards = $op->private & OPpASSIGN_BACKWARDS; + my ($dst, $src); + if (@stack >= 2) { + $dst = pop @stack; + $src = pop @stack; + ($src, $dst) = ($dst, $src) if $backwards; + my $type = $src->{type}; + if ($type == T_INT) { + $dst->set_int($src->as_int,$src->{flags} & VALID_UNSIGNED); + } elsif ($type == T_DOUBLE) { + $dst->set_numeric($src->as_numeric); + } else { + $dst->set_sv($src->as_sv); + } + push(@stack, $dst); + } elsif (@stack == 1) { + if ($backwards) { + my $src = pop @stack; + my $type = $src->{type}; + runtime("if (PL_tainting && PL_tainted) TAINT_NOT;"); + if ($type == T_INT) { + if ($src->{flags} & VALID_UNSIGNED){ + runtime sprintf("sv_setuv(TOPs, %s);", $src->as_int); + }else{ + runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int); + } + } elsif ($type == T_DOUBLE) { + runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double); + } else { + runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv); + } + runtime("SvSETMAGIC(TOPs);"); + } else { + my $dst = $stack[-1]; + my $type = $dst->{type}; + runtime("sv = POPs;"); + runtime("MAYBE_TAINT_SASSIGN_SRC(sv);"); + if ($type == T_INT) { + $dst->set_int("SvIV(sv)"); + } elsif ($type == T_DOUBLE) { + $dst->set_double("SvNV(sv)"); + } else { + runtime("SvSetMagicSV($dst->{sv}, sv);"); + $dst->invalidate; + } + } + } else { + if ($backwards) { + runtime("src = POPs; dst = TOPs;"); + } else { + runtime("dst = POPs; src = TOPs;"); + } + runtime("MAYBE_TAINT_SASSIGN_SRC(src);", + "SvSetSV(dst, src);", + "SvSETMAGIC(dst);", + "SETs(dst);"); + } + return $op->next; +} + +sub pp_preinc { + my $op = shift; + if (@stack >= 1) { + my $obj = $stack[-1]; + my $type = $obj->{type}; + if ($type == T_INT || $type == T_DOUBLE) { + $obj->set_int($obj->as_int . " + 1"); + } else { + runtime sprintf("PP_PREINC(%s);", $obj->as_sv); + $obj->invalidate(); + } + } else { + runtime sprintf("PP_PREINC(TOPs);"); + } + return $op->next; +} + + +sub pp_pushmark { + my $op = shift; + write_back_stack(); + runtime("PUSHMARK(sp);"); + return $op->next; +} + +sub pp_list { + my $op = shift; + write_back_stack(); + my $gimme = gimme($op); + if ($gimme == G_ARRAY) { # sic + runtime("POPMARK;"); # need this even though not a "full" pp_list + } else { + runtime("PP_LIST($gimme);"); + } + return $op->next; +} + +sub pp_entersub { + my $op = shift; + $curcop->write_back; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = doop($op); + runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); + runtime("PL_op = (*PL_op->op_ppaddr)(aTHX);"); + runtime("SPAGAIN;}"); + $know_op = 0; + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} +sub pp_formline { + my $op = shift; + my $ppname = $op->ppaddr; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + my $sym=doop($op); + # See comment in pp_grepwhile to see why! + $init->add("((LISTOP*)$sym)->op_first = $sym;"); + runtime("if (PL_op == ((LISTOP*)($sym))->op_first){"); + save_or_restore_lexical_state(${$op->first}); + runtime( sprintf("goto %s;",label($op->first))); + runtime("}"); + return $op->next; +} + +sub pp_goto{ + + my $op = shift; + my $ppname = $op->ppaddr; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + my $sym=doop($op); + runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}"); + invalidate_lexicals() unless $skip_invalidate{$ppname}; + return $op->next; +} +sub pp_enterwrite { + my $op = shift; + pp_entersub($op); +} +sub pp_leavesub{ + my $op = shift; + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + runtime("if (PL_curstackinfo->si_type == PERLSI_SORT){"); + runtime("\tPUTBACK;return 0;"); + runtime("}"); + doop($op); + return $op->next; +} +sub pp_leavewrite { + my $op = shift; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = doop($op); + # XXX Is this the right way to distinguish between it returning + # CvSTART(cv) (via doform) and pop_return()? + #runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(aTHX);"); + runtime("SPAGAIN;"); + $know_op = 0; + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + +sub doeval { + my $op = shift; + $curcop->write_back; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = loadop($op); + my $ppaddr = $op->ppaddr; + #runtime(qq/printf("$ppaddr type eval\n");/); + runtime("PP_EVAL($ppaddr, ($sym)->op_next);"); + $know_op = 1; + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + +sub pp_entereval { doeval(@_) } +sub pp_dofile { doeval(@_) } + +#pp_require is protected by pp_entertry, so no protection for it. +sub pp_require { + my $op = shift; + $curcop->write_back; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = doop($op); + runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){"); + runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);"); + runtime("SPAGAIN;}"); + $know_op = 1; + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + + +sub pp_entertry { + my $op = shift; + $curcop->write_back; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + my $sym = doop($op); + my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++); + declare("JMPENV", $jmpbuf); + runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next))); + invalidate_lexicals(REGISTER|TEMPORARY); + return $op->next; +} + +sub pp_leavetry{ + my $op=shift; + default_pp($op); + runtime("PP_LEAVETRY;"); + return $op->next; +} + +sub pp_grepstart { + my $op = shift; + if ($need_freetmps && $freetmps_each_loop) { + runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up + $need_freetmps = 0; + } + write_back_stack(); + my $sym= doop($op); + my $next=$op->next; + $next->save; + my $nexttonext=$next->next; + $nexttonext->save; + save_or_restore_lexical_state($$nexttonext); + runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", + label($nexttonext))); + return $op->next->other; +} + +sub pp_mapstart { + my $op = shift; + if ($need_freetmps && $freetmps_each_loop) { + runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up + $need_freetmps = 0; + } + write_back_stack(); + # pp_mapstart can return either op_next->op_next or op_next->op_other and + # we need to be able to distinguish the two at runtime. + my $sym= doop($op); + my $next=$op->next; + $next->save; + my $nexttonext=$next->next; + $nexttonext->save; + save_or_restore_lexical_state($$nexttonext); + runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;", + label($nexttonext))); + return $op->next->other; +} + +sub pp_grepwhile { + my $op = shift; + my $next = $op->next; + unshift(@bblock_todo, $next); + write_back_lexicals(); + write_back_stack(); + my $sym = doop($op); + # pp_grepwhile can return either op_next or op_other and we need to + # be able to distinguish the two at runtime. Since it's possible for + # both ops to be "inlined", the fields could both be zero. To get + # around that, we hack op_next to be our own op (purely because we + # know it's a non-NULL pointer and can't be the same as op_other). + $init->add("((LOGOP*)$sym)->op_next = $sym;"); + save_or_restore_lexical_state($$next); + runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next))); + $know_op = 0; + return $op->other; +} + +sub pp_mapwhile { + pp_grepwhile(@_); +} + +sub pp_return { + my $op = shift; + write_back_lexicals(REGISTER|TEMPORARY); + write_back_stack(); + doop($op); + runtime("PUTBACK;", "return PL_op;"); + $know_op = 0; + return $op->next; +} + +sub nyi { + my $op = shift; + warn sprintf("%s not yet implemented properly\n", $op->ppaddr); + return default_pp($op); +} + +sub pp_range { + my $op = shift; + my $flags = $op->flags; + if (!($flags & OPf_WANT)) { + error("context of range unknown at compile-time"); + } + write_back_lexicals(); + write_back_stack(); + unless (($flags & OPf_WANT)== OPf_WANT_LIST) { + # We need to save our UNOP structure since pp_flop uses + # it to find and adjust out targ. We don't need it ourselves. + $op->save; + save_or_restore_lexical_state(${$op->other}); + runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;", + $op->targ, label($op->other)); + unshift(@bblock_todo, $op->other); + } + return $op->next; +} + +sub pp_flip { + my $op = shift; + my $flags = $op->flags; + if (!($flags & OPf_WANT)) { + error("context of flip unknown at compile-time"); + } + if (($flags & OPf_WANT)==OPf_WANT_LIST) { + return $op->first->other; + } + write_back_lexicals(); + write_back_stack(); + # We need to save our UNOP structure since pp_flop uses + # it to find and adjust out targ. We don't need it ourselves. + $op->save; + my $ix = $op->targ; + my $rangeix = $op->first->targ; + runtime(($op->private & OPpFLIP_LINENUM) ? + "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {" + : "if (SvTRUE(TOPs)) {"); + runtime("\tsv_setiv(PL_curpad[$rangeix], 1);"); + if ($op->flags & OPf_SPECIAL) { + runtime("sv_setiv(PL_curpad[$ix], 1);"); + } else { + save_or_restore_lexical_state(${$op->first->other}); + runtime("\tsv_setiv(PL_curpad[$ix], 0);", + "\tsp--;", + sprintf("\tgoto %s;", label($op->first->other))); + } + runtime("}", + qq{sv_setpv(PL_curpad[$ix], "");}, + "SETs(PL_curpad[$ix]);"); + $know_op = 0; + return $op->next; +} + +sub pp_flop { + my $op = shift; + default_pp($op); + $know_op = 0; + return $op->next; +} + +sub enterloop { + my $op = shift; + my $nextop = $op->nextop; + my $lastop = $op->lastop; + my $redoop = $op->redoop; + $curcop->write_back; + debug "enterloop: pushing on cxstack" if $debug_cxstack; + push(@cxstack, { + type => CXt_LOOP, + op => $op, + "label" => $curcop->[0]->label, + nextop => $nextop, + lastop => $lastop, + redoop => $redoop + }); + $nextop->save; + $lastop->save; + $redoop->save; + return default_pp($op); +} + +sub pp_enterloop { enterloop(@_) } +sub pp_enteriter { enterloop(@_) } + +sub pp_leaveloop { + my $op = shift; + if (!@cxstack) { + die "panic: leaveloop"; + } + debug "leaveloop: popping from cxstack" if $debug_cxstack; + pop(@cxstack); + return default_pp($op); +} + +sub pp_next { + my $op = shift; + my $cxix; + if ($op->flags & OPf_SPECIAL) { + $cxix = dopoptoloop(); + if ($cxix < 0) { + error('"next" used outside loop'); + return $op->next; # ignore the op + } + } else { + $cxix = dopoptolabel($op->pv); + if ($cxix < 0) { + error('Label not found at compile time for "next %s"', $op->pv); + return $op->next; # ignore the op + } + } + default_pp($op); + my $nextop = $cxstack[$cxix]->{nextop}; + push(@bblock_todo, $nextop); + save_or_restore_lexical_state($$nextop); + runtime(sprintf("goto %s;", label($nextop))); + return $op->next; +} + +sub pp_redo { + my $op = shift; + my $cxix; + if ($op->flags & OPf_SPECIAL) { + $cxix = dopoptoloop(); + if ($cxix < 0) { + error('"redo" used outside loop'); + return $op->next; # ignore the op + } + } else { + $cxix = dopoptolabel($op->pv); + if ($cxix < 0) { + error('Label not found at compile time for "redo %s"', $op->pv); + return $op->next; # ignore the op + } + } + default_pp($op); + my $redoop = $cxstack[$cxix]->{redoop}; + push(@bblock_todo, $redoop); + save_or_restore_lexical_state($$redoop); + runtime(sprintf("goto %s;", label($redoop))); + return $op->next; +} + +sub pp_last { + my $op = shift; + my $cxix; + if ($op->flags & OPf_SPECIAL) { + $cxix = dopoptoloop(); + if ($cxix < 0) { + error('"last" used outside loop'); + return $op->next; # ignore the op + } + } else { + $cxix = dopoptolabel($op->pv); + if ($cxix < 0) { + error('Label not found at compile time for "last %s"', $op->pv); + return $op->next; # ignore the op + } + # XXX Add support for "last" to leave non-loop blocks + if ($cxstack[$cxix]->{type} != CXt_LOOP) { + error('Use of "last" for non-loop blocks is not yet implemented'); + return $op->next; # ignore the op + } + } + default_pp($op); + my $lastop = $cxstack[$cxix]->{lastop}->next; + push(@bblock_todo, $lastop); + save_or_restore_lexical_state($$lastop); + runtime(sprintf("goto %s;", label($lastop))); + return $op->next; +} + +sub pp_subst { + my $op = shift; + write_back_lexicals(); + write_back_stack(); + my $sym = doop($op); + my $replroot = $op->pmreplroot; + if ($$replroot) { + save_or_restore_lexical_state($$replroot); + runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;", + $sym, label($replroot)); + $op->pmreplstart->save; + push(@bblock_todo, $replroot); + } + invalidate_lexicals(); + return $op->next; +} + +sub pp_substcont { + my $op = shift; + write_back_lexicals(); + write_back_stack(); + doop($op); + my $pmop = $op->other; + # warn sprintf("substcont: op = %s, pmop = %s\n", + # peekop($op), peekop($pmop));#debug +# my $pmopsym = objsym($pmop); + my $pmopsym = $pmop->save; # XXX can this recurse? +# warn "pmopsym = $pmopsym\n";#debug + save_or_restore_lexical_state(${$pmop->pmreplstart}); + runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;", + $pmopsym, label($pmop->pmreplstart)); + invalidate_lexicals(); + return $pmop->next; +} + +sub default_pp { + my $op = shift; + my $ppname = "pp_" . $op->name; + if ($curcop and $need_curcop{$ppname}){ + $curcop->write_back; + } + write_back_lexicals() unless $skip_lexicals{$ppname}; + write_back_stack() unless $skip_stack{$ppname}; + doop($op); + # XXX If the only way that ops can write to a TEMPORARY lexical is + # when it's named in $op->targ then we could call + # invalidate_lexicals(TEMPORARY) and avoid having to write back all + # the temporaries. For now, we'll play it safe and write back the lot. + invalidate_lexicals() unless $skip_invalidate{$ppname}; + return $op->next; +} + +sub compile_op { + my $op = shift; + my $ppname = "pp_" . $op->name; + if (exists $ignore_op{$ppname}) { + return $op->next; + } + debug peek_stack() if $debug_stack; + if ($debug_op) { + debug sprintf("%s [%s]\n", + peekop($op), + $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ); + } + no strict 'refs'; + if (defined(&$ppname)) { + $know_op = 0; + return &$ppname($op); + } else { + return default_pp($op); + } +} + +sub compile_bblock { + my $op = shift; + #warn "compile_bblock: ", peekop($op), "\n"; # debug + save_or_restore_lexical_state($$op); + write_label($op); + $know_op = 0; + do { + $op = compile_op($op); + } while (defined($op) && $$op && !exists($leaders->{$$op})); + write_back_stack(); # boo hoo: big loss + reload_lexicals(); + return $op; +} + +sub cc { + my ($name, $root, $start, @padlist) = @_; + my $op; + if($done{$$start}){ + #warn "repeat=>".ref($start)."$name,\n";#debug + $decl->add(sprintf("#define $name %s",$done{$$start})); + return; + } + init_pp($name); + load_pad(@padlist); + %lexstate=(); + B::Pseudoreg->new_scope; + @cxstack = (); + if ($debug_timings) { + warn sprintf("Basic block analysis at %s\n", timing_info); + } + $leaders = find_leaders($root, $start); + my @leaders= keys %$leaders; + if ($#leaders > -1) { + @bblock_todo = ($start, values %$leaders) ; + } else{ + runtime("return PL_op?PL_op->op_next:0;"); + } + if ($debug_timings) { + warn sprintf("Compilation at %s\n", timing_info); + } + while (@bblock_todo) { + $op = shift @bblock_todo; + #warn sprintf("Considering basic block %s\n", peekop($op)); # debug + next if !defined($op) || !$$op || $done{$$op}; + #warn "...compiling it\n"; # debug + do { + $done{$$op} = $name; + $op = compile_bblock($op); + if ($need_freetmps && $freetmps_each_bblock) { + runtime("FREETMPS;"); + $need_freetmps = 0; + } + } while defined($op) && $$op && !$done{$$op}; + if ($need_freetmps && $freetmps_each_loop) { + runtime("FREETMPS;"); + $need_freetmps = 0; + } + if (!$$op) { + runtime("PUTBACK;","return PL_op;"); + } elsif ($done{$$op}) { + save_or_restore_lexical_state($$op); + runtime(sprintf("goto %s;", label($op))); + } + } + if ($debug_timings) { + warn sprintf("Saving runtime at %s\n", timing_info); + } + declare_pad(@padlist) ; + save_runtime(); +} + +sub cc_recurse { + my $ccinfo; + my $start; + $start = cc_queue(@_) if @_; + while ($ccinfo = shift @cc_todo) { + cc(@$ccinfo); + } + return $start; +} + +sub cc_obj { + my ($name, $cvref) = @_; + my $cv = svref_2object($cvref); + my @padlist = $cv->PADLIST->ARRAY; + my $curpad_sym = $padlist[1]->save; + cc_recurse($name, $cv->ROOT, $cv->START, @padlist); +} + +sub cc_main { + my @comppadlist = comppadlist->ARRAY; + my $curpad_nam = $comppadlist[0]->save; + my $curpad_sym = $comppadlist[1]->save; + my $init_av = init_av->save; + my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist); + # Do save_unused_subs before saving inc_hv + save_unused_subs(); + cc_recurse(); + + my $inc_hv = svref_2object(\%INC)->save; + my $inc_av = svref_2object(\@INC)->save; + my $amagic_generate= amagic_generation; + return if $errors; + if (!defined($module)) { + $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), + "PL_main_start = $start;", + "PL_curpad = AvARRAY($curpad_sym);", + "PL_initav = (AV *) $init_av;", + "GvHV(PL_incgv) = $inc_hv;", + "GvAV(PL_incgv) = $inc_av;", + "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", + "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", + "PL_amagic_generation= $amagic_generate;", + ); + + } + seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output + output_boilerplate(); + print "\n"; + output_all("perl_init"); + output_runtime(); + print "\n"; + output_main(); + if (defined($module)) { + my $cmodule = $module; + $cmodule =~ s/::/__/g; + print <<"EOT"; + +#include "XSUB.h" +XS(boot_$cmodule) +{ + dXSARGS; + perl_init(); + ENTER; + SAVETMPS; + SAVEVPTR(PL_curpad); + SAVEVPTR(PL_op); + PL_curpad = AvARRAY($curpad_sym); + PL_op = $start; + pp_main(aTHX); + FREETMPS; + LEAVE; + ST(0) = &PL_sv_yes; + XSRETURN(1); +} +EOT + } + if ($debug_timings) { + warn sprintf("Done at %s\n", timing_info); + } +} + +sub compile { + my @options = @_; + my ($option, $opt, $arg); + OPTION: + while ($option = shift @options) { + if ($option =~ /^-(.)(.*)/) { + $opt = $1; + $arg = $2; + } else { + unshift @options, $option; + last OPTION; + } + if ($opt eq "-" && $arg eq "-") { + shift @options; + last OPTION; + } elsif ($opt eq "o") { + $arg ||= shift @options; + open(STDOUT, ">$arg") or return "open '>$arg': $!\n"; + } elsif ($opt eq "n") { + $arg ||= shift @options; + $module_name = $arg; + } elsif ($opt eq "u") { + $arg ||= shift @options; + mark_unused($arg,undef); + } elsif ($opt eq "f") { + $arg ||= shift @options; + my $value = $arg !~ s/^no-//; + $arg =~ s/-/_/g; + my $ref = $optimise{$arg}; + if (defined($ref)) { + $$ref = $value; + } else { + warn qq(ignoring unknown optimisation option "$arg"\n); + } + } elsif ($opt eq "O") { + $arg = 1 if $arg eq ""; + my $ref; + foreach $ref (values %optimise) { + $$ref = 0; + } + if ($arg >= 2) { + $freetmps_each_loop = 1; + } + if ($arg >= 1) { + $freetmps_each_bblock = 1 unless $freetmps_each_loop; + } + } elsif ($opt eq "m") { + $arg ||= shift @options; + $module = $arg; + mark_unused($arg,undef); + } elsif ($opt eq "p") { + $arg ||= shift @options; + $patchlevel = $arg; + } elsif ($opt eq "D") { + $arg ||= shift @options; + foreach $arg (split(//, $arg)) { + if ($arg eq "o") { + B->debug(1); + } elsif ($arg eq "O") { + $debug_op = 1; + } elsif ($arg eq "s") { + $debug_stack = 1; + } elsif ($arg eq "c") { + $debug_cxstack = 1; + } elsif ($arg eq "p") { + $debug_pad = 1; + } elsif ($arg eq "r") { + $debug_runtime = 1; + } elsif ($arg eq "S") { + $debug_shadow = 1; + } elsif ($arg eq "q") { + $debug_queue = 1; + } elsif ($arg eq "l") { + $debug_lineno = 1; + } elsif ($arg eq "t") { + $debug_timings = 1; + } + } + } + } + init_sections(); + $init = B::Section->get("init"); + $decl = B::Section->get("decl"); + + if (@options) { + return sub { + my ($objname, $ppname); + foreach $objname (@options) { + $objname = "main::$objname" unless $objname =~ /::/; + ($ppname = $objname) =~ s/^.*?:://; + eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)"; + die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@; + return if $errors; + } + output_boilerplate(); + print "\n"; + output_all($module_name || "init_module"); + output_runtime(); + } + } else { + return sub { cc_main() }; + } +} + +1; + +__END__ + +=head1 NAME + +B::CC - Perl compiler's optimized C translation backend + +=head1 SYNOPSIS + + perl -MO=CC[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This compiler backend takes Perl source and generates C source code +corresponding to the flow of your program. In other words, this +backend is somewhat a "real" compiler in the sense that many people +think about compilers. Note however that, currently, it is a very +poor compiler in that although it generates (mostly, or at least +sometimes) correct code, it performs relatively few optimisations. +This will change as the compiler develops. The result is that +running an executable compiled with this backend may start up more +quickly than running the original Perl program (a feature shared +by the B<C> compiler backend--see F<B::C>) and may also execute +slightly faster. This is by no means a good optimising compiler--yet. + +=head1 OPTIONS + +If there are any non-option arguments, they are taken to be +names of objects to be saved (probably doesn't work properly yet). +Without extra arguments, it saves the main program. + +=over 4 + +=item B<-ofilename> + +Output to filename instead of STDOUT + +=item B<-v> + +Verbose compilation (currently gives a few compilation statistics). + +=item B<--> + +Force end of options + +=item B<-uPackname> + +Force apparently unused subs from package Packname to be compiled. +This allows programs to use eval "foo()" even when sub foo is never +seen to be used at compile time. The down side is that any subs which +really are never used also have code generated. This option is +necessary, for example, if you have a signal handler foo which you +initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just +to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> +options. The compiler tries to figure out which packages may possibly +have subs in which need compiling but the current version doesn't do +it very well. In particular, it is confused by nested packages (i.e. +of the form C<A::B>) where package C<A> does not contain any subs. + +=item B<-mModulename> + +Instead of generating source for a runnable executable, generate +source for an XSUB module. The boot_Modulename function (which +DynaLoader can look for) does the appropriate initialisation and runs +the main part of the Perl source that is being compiled. + + +=item B<-D> + +Debug options (concatenated or separate flags like C<perl -D>). + +=item B<-Dr> + +Writes debugging output to STDERR just as it's about to write to the +program's runtime (otherwise writes debugging info as comments in +its C output). + +=item B<-DO> + +Outputs each OP as it's compiled + +=item B<-Ds> + +Outputs the contents of the shadow stack at each OP + +=item B<-Dp> + +Outputs the contents of the shadow pad of lexicals as it's loaded for +each sub or the main program. + +=item B<-Dq> + +Outputs the name of each fake PP function in the queue as it's about +to process it. + +=item B<-Dl> + +Output the filename and line number of each original line of Perl +code as it's processed (C<pp_nextstate>). + +=item B<-Dt> + +Outputs timing information of compilation stages. + +=item B<-f> + +Force optimisations on or off one at a time. + +=item B<-ffreetmps-each-bblock> + +Delays FREETMPS from the end of each statement to the end of the each +basic block. + +=item B<-ffreetmps-each-loop> + +Delays FREETMPS from the end of each statement to the end of the group +of basic blocks forming a loop. At most one of the freetmps-each-* +options can be used. + +=item B<-fomit-taint> + +Omits generating code for handling perl's tainting mechanism. + +=item B<-On> + +Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. +Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2> +sets B<-ffreetmps-each-loop>. + +=back + +=head1 EXAMPLES + + perl -MO=CC,-O2,-ofoo.c foo.pl + perl cc_harness -o foo foo.c + +Note that C<cc_harness> lives in the C<B> subdirectory of your perl +library directory. The utility called C<perlcc> may also be used to +help make use of this compiler. + + perl -MO=CC,-mFoo,-oFoo.c Foo.pm + perl cc_harness -shared -c -o Foo.so Foo.c + +=head1 BUGS + +Plenty. Current status: experimental. + +=head1 DIFFERENCES + +These aren't really bugs but they are constructs which are heavily +tied to perl's compile-and-go implementation and with which this +compiler backend cannot cope. + +=head2 Loops + +Standard perl calculates the target of "next", "last", and "redo" +at run-time. The compiler calculates the targets at compile-time. +For example, the program + + sub skip_on_odd { next NUMBER if $_[0] % 2 } + NUMBER: for ($i = 0; $i < 5; $i++) { + skip_on_odd($i); + print $i; + } + +produces the output + + 024 + +with standard perl but gives a compile-time error with the compiler. + +=head2 Context of ".." + +The context (scalar or array) of the ".." operator determines whether +it behaves as a range or a flip/flop. Standard perl delays until +runtime the decision of which context it is in but the compiler needs +to know the context at compile-time. For example, + + @a = (4,6,1,0,0,1); + sub range { (shift @a)..(shift @a) } + print range(); + while (@a) { print scalar(range()) } + +generates the output + + 456123E0 + +with standard Perl but gives a compile-time error with compiled Perl. + +=head2 Arithmetic + +Compiled Perl programs use native C arithmetic much more frequently +than standard perl. Operations on large numbers or on boundary +cases may produce different behaviour. + +=head2 Deprecated features + +Features of standard perl such as C<$[> which have been deprecated +in standard perl since Perl5 was released have not been implemented +in the compiler. + +=head1 AUTHOR + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Concise.pm b/Master/tlpkg/installer/perllib/B/Concise.pm new file mode 100644 index 00000000000..c84578e44c4 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Concise.pm @@ -0,0 +1,1628 @@ +package B::Concise; +# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved. +# This program is free software; you can redistribute and/or modify it +# under the same terms as Perl itself. + +# Note: we need to keep track of how many use declarations/BEGIN +# blocks this module uses, so we can avoid printing them when user +# asks for the BEGIN blocks in her program. Update the comments and +# the count in concise_specials if you add or delete one. The +# -MO=Concise counts as use #1. + +use strict; # use #2 +use warnings; # uses #3 and #4, since warnings uses Carp + +use Exporter (); # use #5 + +our $VERSION = "0.66"; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw( set_style set_style_standard add_callback + concise_subref concise_cv concise_main + add_style walk_output compile reset_sequence ); +our %EXPORT_TAGS = + ( io => [qw( walk_output compile reset_sequence )], + style => [qw( add_style set_style_standard )], + cb => [qw( add_callback )], + mech => [qw( concise_subref concise_cv concise_main )], ); + +# use #6 +use B qw(class ppname main_start main_root main_cv cstring svref_2object + SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL + CVf_ANON); + +my %style = + ("terse" => + ["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) " + . "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n", + "(*( )*)goto #class (#addr)\n", + "#class pp_#name"], + "concise" => + ["#hyphseq2 (*( (x( ;)x))*)<#classsym> " + . "#exname#arg(?([#targarglife])?)~#flags(?(/#private)?)(x(;~->#next)x)\n" + , " (*( )*) goto #seq\n", + "(?(<#seq>)?)#exname#arg(?([#targarglife])?)"], + "linenoise" => + ["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)", + "gt_#seq ", + "(?(#seq)?)#noise#arg(?([#targarg])?)"], + "debug" => + ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t" + . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" . + ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n") + . "\top_flags\t#flagval\n\top_private\t#privval\n" + . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)" + . "(?(\top_sv\t\t#svaddr\n)?)", + " GOTO #addr\n", + "#addr"], + "env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT}, + $ENV{B_CONCISE_TREE_FORMAT}], + ); + +# Renderings, ie how Concise prints, is controlled by these vars +# primary: +our $stylename; # selects current style from %style +my $order = "basic"; # how optree is walked & printed: basic, exec, tree + +# rendering mechanics: +# these 'formats' are the line-rendering templates +# they're updated from %style when $stylename changes +my ($format, $gotofmt, $treefmt); + +# lesser players: +my $base = 36; # how <sequence#> is displayed +my $big_endian = 1; # more <sequence#> display +my $tree_style = 0; # tree-order details +my $banner = 1; # print banner before optree is traversed +my $do_main = 0; # force printing of main routine + +# another factor: can affect all styles! +our @callbacks; # allow external management + +set_style_standard("concise"); + +my $curcv; +my $cop_seq_base; + +sub set_style { + ($format, $gotofmt, $treefmt) = @_; + #warn "set_style: deprecated, use set_style_standard instead\n"; # someday + die "expecting 3 style-format args\n" unless @_ == 3; +} + +sub add_style { + my ($newstyle,@args) = @_; + die "style '$newstyle' already exists, choose a new name\n" + if exists $style{$newstyle}; + die "expecting 3 style-format args\n" unless @args == 3; + $style{$newstyle} = [@args]; + $stylename = $newstyle; # update rendering state +} + +sub set_style_standard { + ($stylename) = @_; # update rendering state + die "err: style '$stylename' unknown\n" unless exists $style{$stylename}; + set_style(@{$style{$stylename}}); +} + +sub add_callback { + push @callbacks, @_; +} + +# output handle, used with all Concise-output printing +our $walkHandle; # public for your convenience +BEGIN { $walkHandle = \*STDOUT } + +sub walk_output { # updates $walkHandle + my $handle = shift; + return $walkHandle unless $handle; # allow use as accessor + + if (ref $handle eq 'SCALAR') { + require Config; + die "no perlio in this build, can't call walk_output (\\\$scalar)\n" + unless $Config::Config{useperlio}; + # in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string + open my $tmp, '>', $handle; # but cant re-set existing STDOUT + $walkHandle = $tmp; # so use my $tmp as intermediate var + return $walkHandle; + } + my $iotype = ref $handle; + die "expecting argument/object that can print\n" + unless $iotype eq 'GLOB' or $iotype and $handle->can('print'); + $walkHandle = $handle; +} + +sub concise_subref { + my($order, $coderef, $name) = @_; + my $codeobj = svref_2object($coderef); + + return concise_stashref(@_) + unless ref $codeobj eq 'B::CV'; + concise_cv_obj($order, $codeobj, $name); +} + +sub concise_stashref { + my($order, $h) = @_; + foreach my $k (sort keys %$h) { + local *s = $h->{$k}; + my $coderef = *s{CODE} or next; + reset_sequence(); + print "FUNC: ", *s, "\n"; + my $codeobj = svref_2object($coderef); + next unless ref $codeobj eq 'B::CV'; + eval { concise_cv_obj($order, $codeobj) } + or warn "err $@ on $codeobj"; + } +} + +# This should have been called concise_subref, but it was exported +# under this name in versions before 0.56 +*concise_cv = \&concise_subref; + +sub concise_cv_obj { + my ($order, $cv, $name) = @_; + # name is either a string, or a CODE ref (copy of $cv arg??) + + $curcv = $cv; + if ($cv->XSUB) { + print $walkHandle "$name is XS code\n"; + return; + } + if (class($cv->START) eq "NULL") { + no strict 'refs'; + if (ref $name eq 'CODE') { + print $walkHandle "coderef $name has no START\n"; + } + elsif (exists &$name) { + print $walkHandle "$name exists in stash, but has no START\n"; + } + else { + print $walkHandle "$name not in symbol table\n"; + } + return; + } + sequence($cv->START); + if ($order eq "exec") { + walk_exec($cv->START); + } + elsif ($order eq "basic") { + # walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0); + my $root = $cv->ROOT; + unless (ref $root eq 'B::NULL') { + walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0); + } else { + print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n"; + } + } else { + print $walkHandle tree($cv->ROOT, 0); + } +} + +sub concise_main { + my($order) = @_; + sequence(main_start); + $curcv = main_cv; + if ($order eq "exec") { + return if class(main_start) eq "NULL"; + walk_exec(main_start); + } elsif ($order eq "tree") { + return if class(main_root) eq "NULL"; + print $walkHandle tree(main_root, 0); + } elsif ($order eq "basic") { + return if class(main_root) eq "NULL"; + walk_topdown(main_root, + sub { $_[0]->concise($_[1]) }, 0); + } +} + +sub concise_specials { + my($name, $order, @cv_s) = @_; + my $i = 1; + if ($name eq "BEGIN") { + splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ?? + } elsif ($name eq "CHECK") { + pop @cv_s; # skip the CHECK block that calls us + } + for my $cv (@cv_s) { + print $walkHandle "$name $i:\n"; + $i++; + concise_cv_obj($order, $cv, $name); + } +} + +my $start_sym = "\e(0"; # "\cN" sometimes also works +my $end_sym = "\e(B"; # "\cO" respectively + +my @tree_decorations = + ([" ", "--", "+-", "|-", "| ", "`-", "-", 1], + [" ", "-", "+", "+", "|", "`", "", 0], + [" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1], + [" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0], + ); + + +sub compileOpts { + # set rendering state from options and args + my (@options,@args); + if (@_) { + @options = grep(/^-/, @_); + @args = grep(!/^-/, @_); + } + for my $o (@options) { + # mode/order + if ($o eq "-basic") { + $order = "basic"; + } elsif ($o eq "-exec") { + $order = "exec"; + } elsif ($o eq "-tree") { + $order = "tree"; + } + # tree-specific + elsif ($o eq "-compact") { + $tree_style |= 1; + } elsif ($o eq "-loose") { + $tree_style &= ~1; + } elsif ($o eq "-vt") { + $tree_style |= 2; + } elsif ($o eq "-ascii") { + $tree_style &= ~2; + } + # sequence numbering + elsif ($o =~ /^-base(\d+)$/) { + $base = $1; + } elsif ($o eq "-bigendian") { + $big_endian = 1; + } elsif ($o eq "-littleendian") { + $big_endian = 0; + } + elsif ($o eq "-nobanner") { + $banner = 0; + } elsif ($o eq "-banner") { + $banner = 1; + } + elsif ($o eq "-main") { + $do_main = 1; + } elsif ($o eq "-nomain") { + $do_main = 0; + } + # line-style options + elsif (exists $style{substr($o, 1)}) { + $stylename = substr($o, 1); + set_style_standard($stylename); + } else { + warn "Option $o unrecognized"; + } + } + return (@args); +} + +sub compile { + my (@args) = compileOpts(@_); + return sub { + my @newargs = compileOpts(@_); # accept new rendering options + warn "disregarding non-options: @newargs\n" if @newargs; + + for my $objname (@args) { + next unless $objname; # skip null args to avoid noisy responses + + if ($objname eq "BEGIN") { + concise_specials("BEGIN", $order, + B::begin_av->isa("B::AV") ? + B::begin_av->ARRAY : ()); + } elsif ($objname eq "INIT") { + concise_specials("INIT", $order, + B::init_av->isa("B::AV") ? + B::init_av->ARRAY : ()); + } elsif ($objname eq "CHECK") { + concise_specials("CHECK", $order, + B::check_av->isa("B::AV") ? + B::check_av->ARRAY : ()); + } elsif ($objname eq "END") { + concise_specials("END", $order, + B::end_av->isa("B::AV") ? + B::end_av->ARRAY : ()); + } + else { + # convert function names to subrefs + my $objref; + if (ref $objname) { + print $walkHandle "B::Concise::compile($objname)\n" + if $banner; + $objref = $objname; + } else { + $objname = "main::" . $objname unless $objname =~ /::/; + print $walkHandle "$objname:\n"; + no strict 'refs'; + unless (exists &$objname) { + print $walkHandle "err: unknown function ($objname)\n"; + return; + } + $objref = \&$objname; + } + concise_subref($order, $objref, $objname); + } + } + if (!@args or $do_main) { + print $walkHandle "main program:\n" if $do_main; + concise_main($order); + } + return @args; # something + } +} + +my %labels; +my $lastnext; # remembers op-chain, used to insert gotos + +my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|", + 'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*", + 'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#"); + +no warnings 'qw'; # "Possible attempt to put comments..."; use #7 +my @linenoise = + qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl + ` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I + -1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i< + > i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i + ! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy + uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@ + a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s} + v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o + ^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v + ^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r + -w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd + co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3 + g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e + e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn + Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO'; + +my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; + +sub op_flags { # common flags (see BASOP.op_flags in op.h) + my($x) = @_; + my(@v); + push @v, "v" if ($x & 3) == 1; + push @v, "s" if ($x & 3) == 2; + push @v, "l" if ($x & 3) == 3; + push @v, "K" if $x & 4; + push @v, "P" if $x & 8; + push @v, "R" if $x & 16; + push @v, "M" if $x & 32; + push @v, "S" if $x & 64; + push @v, "*" if $x & 128; + return join("", @v); +} + +sub base_n { + my $x = shift; + return "-" . base_n(-$x) if $x < 0; + my $str = ""; + do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base); + $str = reverse $str if $big_endian; + return $str; +} + +my %sequence_num; +my $seq_max = 1; + +sub reset_sequence { + # reset the sequence + %sequence_num = (); + $seq_max = 1; + $lastnext = 0; +} + +sub seq { + my($op) = @_; + return "-" if not exists $sequence_num{$$op}; + return base_n($sequence_num{$$op}); +} + +sub walk_topdown { + my($op, $sub, $level) = @_; + $sub->($op, $level); + if ($op->flags & OPf_KIDS) { + for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { + walk_topdown($kid, $sub, $level + 1); + } + } + elsif (class($op) eq "PMOP") { + my $maybe_root = $op->pmreplroot; + if (ref($maybe_root) and $maybe_root->isa("B::OP")) { + # It really is the root of the replacement, not something + # else stored here for lack of space elsewhere + walk_topdown($maybe_root, $sub, $level + 1); + } + } +} + +sub walklines { + my($ar, $level) = @_; + for my $l (@$ar) { + if (ref($l) eq "ARRAY") { + walklines($l, $level + 1); + } else { + $l->concise($level); + } + } +} + +sub walk_exec { + my($top, $level) = @_; + my %opsseen; + my @lines; + my @todo = ([$top, \@lines]); + while (@todo and my($op, $targ) = @{shift @todo}) { + for (; $$op; $op = $op->next) { + last if $opsseen{$$op}++; + push @$targ, $op; + my $name = $op->name; + if (class($op) eq "LOGOP") { + my $ar = []; + push @$targ, $ar; + push @todo, [$op->other, $ar]; + } elsif ($name eq "subst" and $ {$op->pmreplstart}) { + my $ar = []; + push @$targ, $ar; + push @todo, [$op->pmreplstart, $ar]; + } elsif ($name =~ /^enter(loop|iter)$/) { + if ($] > 5.009) { + $labels{${$op->nextop}} = "NEXT"; + $labels{${$op->lastop}} = "LAST"; + $labels{${$op->redoop}} = "REDO"; + } else { + $labels{$op->nextop->seq} = "NEXT"; + $labels{$op->lastop->seq} = "LAST"; + $labels{$op->redoop->seq} = "REDO"; + } + } + } + } + walklines(\@lines, 0); +} + +# The structure of this routine is purposely modeled after op.c's peep() +sub sequence { + my($op) = @_; + my $oldop = 0; + return if class($op) eq "NULL" or exists $sequence_num{$$op}; + for (; $$op; $op = $op->next) { + last if exists $sequence_num{$$op}; + my $name = $op->name; + if ($name =~ /^(null|scalar|lineseq|scope)$/) { + next if $oldop and $ {$op->next}; + } else { + $sequence_num{$$op} = $seq_max++; + if (class($op) eq "LOGOP") { + my $other = $op->other; + $other = $other->next while $other->name eq "null"; + sequence($other); + } elsif (class($op) eq "LOOP") { + my $redoop = $op->redoop; + $redoop = $redoop->next while $redoop->name eq "null"; + sequence($redoop); + my $nextop = $op->nextop; + $nextop = $nextop->next while $nextop->name eq "null"; + sequence($nextop); + my $lastop = $op->lastop; + $lastop = $lastop->next while $lastop->name eq "null"; + sequence($lastop); + } elsif ($name eq "subst" and $ {$op->pmreplstart}) { + my $replstart = $op->pmreplstart; + $replstart = $replstart->next while $replstart->name eq "null"; + sequence($replstart); + } + } + $oldop = $op; + } +} + +sub fmt_line { # generate text-line for op. + my($hr, $op, $text, $level) = @_; + + $_->($hr, $op, \$text, \$level, $stylename) for @callbacks; + + return '' if $hr->{SKIP}; # suppress line if a callback said so + return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere + + # spec: (?(text1#varText2)?) + $text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/ + $hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg; + + # spec: (x(exec_text;basic_text)x) + $text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs; + + # spec: (*(text)*) + $text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs; + + # spec: (*(text1;text2)*) + $text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs; + + # convert #Var to tag=>val form: Var\t#var + $text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs; + + # spec: #varN + $text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg; + + $text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's + $text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes + chomp $text; + return "$text\n" if $text ne ""; + return $text; # suppress empty lines +} + +our %priv; # used to display each opcode's BASEOP.op_private values + +$priv{$_}{128} = "LVINTRO" + for ("pos", "substr", "vec", "threadsv", "gvsv", "rv2sv", "rv2hv", "rv2gv", + "rv2av", "rv2arylen", "aelem", "helem", "aslice", "hslice", "padsv", + "padav", "padhv", "enteriter"); +$priv{$_}{64} = "REFC" for ("leave", "leavesub", "leavesublv", "leavewrite"); +$priv{"aassign"}{64} = "COMMON"; +$priv{"aassign"}{32} = "PHASH" if $] < 5.009; +$priv{"sassign"}{64} = "BKWARD"; +$priv{$_}{64} = "RTIME" for ("match", "subst", "substcont", "qr"); +@{$priv{"trans"}}{1,2,4,8,16,64} = ("<UTF", ">UTF", "IDENT", "SQUASH", "DEL", + "COMPL", "GROWS"); +$priv{"repeat"}{64} = "DOLIST"; +$priv{"leaveloop"}{64} = "CONT"; +@{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") + for (qw(rv2gv rv2sv padsv aelem helem)); +@{$priv{"entersub"}}{16,32,64} = ("DBG","TARG","NOMOD"); +@{$priv{$_}}{4,8,128} = ("INARGS","AMPER","NO()") for ("entersub", "rv2cv"); +$priv{"gv"}{32} = "EARLYCV"; +$priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; +$priv{$_}{16} = "OURINTR" for ("gvsv", "rv2sv", "rv2av", "rv2hv", "r2gv", + "enteriter"); +$priv{$_}{16} = "TARGMY" + for (map(($_,"s$_"),"chop", "chomp"), + map(($_,"i_$_"), "postinc", "postdec", "multiply", "divide", "modulo", + "add", "subtract", "negate"), "pow", "concat", "stringify", + "left_shift", "right_shift", "bit_and", "bit_xor", "bit_or", + "complement", "atan2", "sin", "cos", "rand", "exp", "log", "sqrt", + "int", "hex", "oct", "abs", "length", "index", "rindex", "sprintf", + "ord", "chr", "crypt", "quotemeta", "join", "push", "unshift", "flock", + "chdir", "chown", "chroot", "unlink", "chmod", "utime", "rename", + "link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system", + "exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority", + "setpriority", "time", "sleep"); +$priv{$_}{4} = "REVERSED" for ("enteriter", "iter"); +@{$priv{"const"}}{4,8,16,32,64,128} = ("SHORT","STRICT","ENTERED",'$[',"BARE","WARN"); +$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM"; +$priv{"list"}{64} = "GUESSED"; +$priv{"delete"}{64} = "SLICE"; +$priv{"exists"}{64} = "SUB"; +$priv{$_}{64} = "LOCALE" + for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge", + "scmp", "lc", "uc", "lcfirst", "ucfirst"); +@{$priv{"sort"}}{1,2,4,8,16} = ("NUM", "INT", "REV", "INPLACE","DESC"); +$priv{"threadsv"}{64} = "SVREFd"; +@{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR") + for ("open", "backtick"); +$priv{"exit"}{128} = "VMS"; +$priv{$_}{2} = "FTACCESS" + for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec"); +if ($] >= 5.009) { + # Stacked filetests are post 5.8.x + $priv{$_}{4} = "FTSTACKED" + for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec", + "ftis", "fteowned", "ftrowned", "ftzero", "ftsize", "ftmtime", + "ftatime", "ftctime", "ftsock", "ftchr", "ftblk", "ftfile", "ftdir", + "ftpipe", "ftlink", "ftsuid", "ftsgid", "ftsvtx", "fttty", "fttext", + "ftbinary"); + # Lexical $_ is post 5.8.x + $priv{$_}{2} = "GREPLEX" + for ("mapwhile", "mapstart", "grepwhile", "grepstart"); +} + +sub private_flags { + my($name, $x) = @_; + my @s; + for my $flag (128, 96, 64, 32, 16, 8, 4, 2, 1) { + if ($priv{$name}{$flag} and $x & $flag and $x >= $flag) { + $x -= $flag; + push @s, $priv{$name}{$flag}; + } + } + push @s, $x if $x; + return join(",", @s); +} + +sub concise_sv { + my($sv, $hr, $preferpv) = @_; + $hr->{svclass} = class($sv); + $hr->{svclass} = "UV" + if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV; + Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv; + $hr->{svaddr} = sprintf("%#x", $$sv); + if ($hr->{svclass} eq "GV") { + my $gv = $sv; + my $stash = $gv->STASH->NAME; + if ($stash eq "main") { + $stash = ""; + } else { + $stash = $stash . "::"; + } + $hr->{svval} = "*$stash" . $gv->SAFENAME; + return "*$stash" . $gv->SAFENAME; + } else { + while (class($sv) eq "RV") { + $hr->{svval} .= "\\"; + $sv = $sv->RV; + } + if (class($sv) eq "SPECIAL") { + $hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no"]->[$$sv]; + } elsif ($preferpv && $sv->FLAGS & SVf_POK) { + $hr->{svval} .= cstring($sv->PV); + } elsif ($sv->FLAGS & SVf_NOK) { + $hr->{svval} .= $sv->NV; + } elsif ($sv->FLAGS & SVf_IOK) { + $hr->{svval} .= $sv->int_value; + } elsif ($sv->FLAGS & SVf_POK) { + $hr->{svval} .= cstring($sv->PV); + } elsif (class($sv) eq "HV") { + $hr->{svval} .= 'HASH'; + } + + $hr->{svval} = 'undef' unless defined $hr->{svval}; + my $out = $hr->{svclass}; + return $out .= " $hr->{svval}" ; + } +} + +sub concise_op { + my ($op, $level, $format) = @_; + my %h; + $h{exname} = $h{name} = $op->name; + $h{NAME} = uc $h{name}; + $h{class} = class($op); + $h{extarg} = $h{targ} = $op->targ; + $h{extarg} = "" unless $h{extarg}; + if ($h{name} eq "null" and $h{targ}) { + # targ holds the old type + $h{exname} = "ex-" . substr(ppname($h{targ}), 3); + $h{extarg} = ""; + } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) { + # targ potentially holds a reference count + if ($op->private & 64) { + my $refs = "ref" . ($h{targ} != 1 ? "s" : ""); + $h{targarglife} = $h{targarg} = "$h{targ} $refs"; + } + } elsif ($h{targ}) { + my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}]; + if (defined $padname and class($padname) ne "SPECIAL") { + $h{targarg} = $padname->PVX; + if ($padname->FLAGS & SVf_FAKE) { + if ($] < 5.009) { + $h{targarglife} = "$h{targarg}:FAKE"; + } else { + # These changes relate to the jumbo closure fix. + # See changes 19939 and 20005 + my $fake = ''; + $fake .= 'a' if $padname->IVX & 1; # PAD_FAKELEX_ANON + $fake .= 'm' if $padname->IVX & 2; # PAD_FAKELEX_MULTI + $fake .= ':' . $padname->NVX if $curcv->CvFLAGS & CVf_ANON; + $h{targarglife} = "$h{targarg}:FAKE:$fake"; + } + } + else { + my $intro = $padname->NVX - $cop_seq_base; + my $finish = int($padname->IVX) - $cop_seq_base; + $finish = "end" if $finish == 999999999 - $cop_seq_base; + $h{targarglife} = "$h{targarg}:$intro,$finish"; + } + } else { + $h{targarglife} = $h{targarg} = "t" . $h{targ}; + } + } + $h{arg} = ""; + $h{svclass} = $h{svaddr} = $h{svval} = ""; + if ($h{class} eq "PMOP") { + my $precomp = $op->precomp; + if (defined $precomp) { + $precomp = cstring($precomp); # Escape literal control sequences + $precomp = "/$precomp/"; + } else { + $precomp = ""; + } + my $pmreplroot = $op->pmreplroot; + my $pmreplstart; + if (ref($pmreplroot) eq "B::GV") { + # with C<@stash_array = split(/pat/, str);>, + # *stash_array is stored in /pat/'s pmreplroot. + $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")"; + } elsif (!ref($pmreplroot) and $pmreplroot) { + # same as the last case, except the value is actually a + # pad offset for where the GV is kept (this happens under + # ithreads) + my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot]; + $h{arg} = "($precomp => \@" . $gv->NAME . ")"; + } elsif ($ {$op->pmreplstart}) { + undef $lastnext; + $pmreplstart = "replstart->" . seq($op->pmreplstart); + $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")"; + } else { + $h{arg} = "($precomp)"; + } + } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") { + $h{arg} = '("' . $op->pv . '")'; + $h{svval} = '"' . $op->pv . '"'; + } elsif ($h{class} eq "COP") { + my $label = $op->label; + $h{coplabel} = $label; + $label = $label ? "$label: " : ""; + my $loc = $op->file; + $loc =~ s[.*/][]; + $loc .= ":" . $op->line; + my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base); + my $arybase = $op->arybase; + $arybase = $arybase ? ' $[=' . $arybase : ""; + $h{arg} = "($label$stash $cseq $loc$arybase)"; + } elsif ($h{class} eq "LOOP") { + $h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop) + . " redo->" . seq($op->redoop) . ")"; + } elsif ($h{class} eq "LOGOP") { + undef $lastnext; + $h{arg} = "(other->" . seq($op->other) . ")"; + } + elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") { + unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) { + my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix; + my $preferpv = $h{name} eq "method_named"; + if ($h{class} eq "PADOP" or !${$op->sv}) { + my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx]; + $h{arg} = "[" . concise_sv($sv, \%h, $preferpv) . "]"; + $h{targarglife} = $h{targarg} = ""; + } else { + $h{arg} = "(" . concise_sv($op->sv, \%h, $preferpv) . ")"; + } + } + } + $h{seq} = $h{hyphseq} = seq($op); + $h{seq} = "" if $h{seq} eq "-"; + if ($] > 5.009) { + $h{opt} = $op->opt; + $h{static} = $op->static; + $h{label} = $labels{$$op}; + } else { + $h{seqnum} = $op->seq; + $h{label} = $labels{$op->seq}; + } + $h{next} = $op->next; + $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next}); + $h{nextaddr} = sprintf("%#x", $ {$op->next}); + $h{sibaddr} = sprintf("%#x", $ {$op->sibling}); + $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first"); + $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last"); + + $h{classsym} = $opclass{$h{class}}; + $h{flagval} = $op->flags; + $h{flags} = op_flags($op->flags); + $h{privval} = $op->private; + $h{private} = private_flags($h{name}, $op->private); + $h{addr} = sprintf("%#x", $$op); + $h{typenum} = $op->type; + $h{noise} = $linenoise[$op->type]; + + return fmt_line(\%h, $op, $format, $level); +} + +sub B::OP::concise { + my($op, $level) = @_; + if ($order eq "exec" and $lastnext and $$lastnext != $$op) { + # insert a 'goto' line + my $synth = {"seq" => seq($lastnext), "class" => class($lastnext), + "addr" => sprintf("%#x", $$lastnext), + "goto" => seq($lastnext), # simplify goto '-' removal + }; + print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1); + } + $lastnext = $op->next; + print $walkHandle concise_op($op, $level, $format); +} + +# B::OP::terse (see Terse.pm) now just calls this +sub b_terse { + my($op, $level) = @_; + + # This isn't necessarily right, but there's no easy way to get + # from an OP to the right CV. This is a limitation of the + # ->terse() interface style, and there isn't much to do about + # it. In particular, we can die in concise_op if the main pad + # isn't long enough, or has the wrong kind of entries, compared to + # the pad a sub was compiled with. The fix for that would be to + # make a backwards compatible "terse" format that never even + # looked at the pad, just like the old B::Terse. I don't think + # that's worth the effort, though. + $curcv = main_cv unless $curcv; + + if ($order eq "exec" and $lastnext and $$lastnext != $$op) { + # insert a 'goto' + my $h = {"seq" => seq($lastnext), "class" => class($lastnext), + "addr" => sprintf("%#x", $$lastnext)}; + print # $walkHandle + fmt_line($h, $op, $style{"terse"}[1], $level+1); + } + $lastnext = $op->next; + print # $walkHandle + concise_op($op, $level, $style{"terse"}[0]); +} + +sub tree { + my $op = shift; + my $level = shift; + my $style = $tree_decorations[$tree_style]; + my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style; + my $name = concise_op($op, $level, $treefmt); + if (not $op->flags & OPf_KIDS) { + return $name . "\n"; + } + my @lines; + for (my $kid = $op->first; $$kid; $kid = $kid->sibling) { + push @lines, tree($kid, $level+1); + } + my $i; + for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) { + $lines[$i] = $space . $lines[$i]; + } + if ($i > 0) { + $lines[$i] = $last . $lines[$i]; + while ($i-- > 1) { + if (substr($lines[$i], 0, 1) eq " ") { + $lines[$i] = $nokid . $lines[$i]; + } else { + $lines[$i] = $kid . $lines[$i]; + } + } + $lines[$i] = $kids . $lines[$i]; + } else { + $lines[0] = $single . $lines[0]; + } + return("$name$lead" . shift @lines, + map(" " x (length($name)+$size) . $_, @lines)); +} + +# *** Warning: fragile kludge ahead *** +# Because the B::* modules run in the same interpreter as the code +# they're compiling, their presence tends to distort the view we have of +# the code we're looking at. In particular, perl gives sequence numbers +# to COPs. If the program we're looking at were run on its own, this +# would start at 1. Because all of B::Concise and all the modules it +# uses are compiled first, though, by the time we get to the user's +# program the sequence number is already pretty high, which could be +# distracting if you're trying to tell OPs apart. Therefore we'd like to +# subtract an offset from all the sequence numbers we display, to +# restore the simpler view of the world. The trick is to know what that +# offset will be, when we're still compiling B::Concise! If we +# hardcoded a value, it would have to change every time B::Concise or +# other modules we use do. To help a little, what we do here is compile +# a little code at the end of the module, and compute the base sequence +# number for the user's program as being a small offset later, so all we +# have to worry about are changes in the offset. + +# [For 5.8.x and earlier perl is generating sequence numbers for all ops, +# and using them to reference labels] + + +# When you say "perl -MO=Concise -e '$a'", the output should look like: + +# 4 <@> leave[t1] vKP/REFC ->(end) +# 1 <0> enter ->2 + #^ smallest OP sequence number should be 1 +# 2 <;> nextstate(main 1 -e:1) v ->3 + # ^ smallest COP sequence number should be 1 +# - <1> ex-rv2sv vK/1 ->4 +# 3 <$> gvsv(*a) s ->4 + +# If the second of the marked numbers there isn't 1, it means you need +# to update the corresponding magic number in the next line. +# Remember, this needs to stay the last things in the module. + +# Why is this different for MacOS? Does it matter? +my $cop_seq_mnum = $^O eq 'MacOS' ? 12 : 11; +$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum; + +1; + +__END__ + +=head1 NAME + +B::Concise - Walk Perl syntax tree, printing concise info about ops + +=head1 SYNOPSIS + + perl -MO=Concise[,OPTIONS] foo.pl + + use B::Concise qw(set_style add_callback); + +=head1 DESCRIPTION + +This compiler backend prints the internal OPs of a Perl program's syntax +tree in one of several space-efficient text formats suitable for debugging +the inner workings of perl or other compiler backends. It can print OPs in +the order they appear in the OP tree, in the order they will execute, or +in a text approximation to their tree structure, and the format of the +information displayed is customizable. Its function is similar to that of +perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more +sophisticated and flexible. + +=head1 EXAMPLE + +Here's an example of 2 outputs (aka 'renderings'), using the +-exec and -basic (i.e. default) formatting conventions on the same code +snippet. + + % perl -MO=Concise,-exec -e '$a = $b + 42' + 1 <0> enter + 2 <;> nextstate(main 1 -e:1) v + 3 <#> gvsv[*b] s + 4 <$> const[IV 42] s + * 5 <2> add[t3] sK/2 + 6 <#> gvsv[*a] s + 7 <2> sassign vKS/2 + 8 <@> leave[1 ref] vKP/REFC + +Each line corresponds to an opcode. The opcode marked with '*' is used +in a few examples below. + +The 1st column is the op's sequence number, starting at 1, and is +displayed in base 36 by default. This rendering is in -exec (i.e. +execution) order. + +The symbol between angle brackets indicates the op's type, for +example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is +used in threaded perls. (see L</"OP class abbreviations">). + +The opname, as in B<'add[t1]'>, which may be followed by op-specific +information in parentheses or brackets (ex B<'[t1]'>). + +The op-flags (ex B<'sK/2'>) follow, and are described in (L</"OP flags +abbreviations">). + + % perl -MO=Concise -e '$a = $b + 42' + 8 <@> leave[1 ref] vKP/REFC ->(end) + 1 <0> enter ->2 + 2 <;> nextstate(main 1 -e:1) v ->3 + 7 <2> sassign vKS/2 ->8 + * 5 <2> add[t1] sK/2 ->6 + - <1> ex-rv2sv sK/1 ->4 + 3 <$> gvsv(*b) s ->4 + 4 <$> const(IV 42) s ->5 + - <1> ex-rv2sv sKRM*/1 ->7 + 6 <$> gvsv(*a) s ->7 + +The default rendering is top-down, so they're not in execution order. +This form reflects the way the stack is used to parse and evaluate +expressions; the add operates on the two terms below it in the tree. + +Nullops appear as C<ex-opname>, where I<opname> is an op that has been +optimized away by perl. They're displayed with a sequence-number of +'-', because they are not executed (they don't appear in previous +example), they're printed here because they reflect the parse. + +The arrow points to the sequence number of the next op; they're not +displayed in -exec mode, for obvious reasons. + +Note that because this rendering was done on a non-threaded perl, the +PADOPs in the previous examples are now SVOPs, and some (but not all) +of the square brackets have been replaced by round ones. This is a +subtle feature to provide some visual distinction between renderings +on threaded and un-threaded perls. + + +=head1 OPTIONS + +Arguments that don't start with a hyphen are taken to be the names of +subroutines to print the OPs of; if no such functions are specified, +the main body of the program (outside any subroutines, and not +including use'd or require'd files) is rendered. Passing C<BEGIN>, +C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding +special blocks to be printed. + +Options affect how things are rendered (ie printed). They're presented +here by their visual effect, 1st being strongest. They're grouped +according to how they interrelate; within each group the options are +mutually exclusive (unless otherwise stated). + +=head2 Options for Opcode Ordering + +These options control the 'vertical display' of opcodes. The display +'order' is also called 'mode' elsewhere in this document. + +=over 4 + +=item B<-basic> + +Print OPs in the order they appear in the OP tree (a preorder +traversal, starting at the root). The indentation of each OP shows its +level in the tree, and the '->' at the end of the line indicates the +next opcode in execution order. This mode is the default, so the flag +is included simply for completeness. + +=item B<-exec> + +Print OPs in the order they would normally execute (for the majority +of constructs this is a postorder traversal of the tree, ending at the +root). In most cases the OP that usually follows a given OP will +appear directly below it; alternate paths are shown by indentation. In +cases like loops when control jumps out of a linear path, a 'goto' +line is generated. + +=item B<-tree> + +Print OPs in a text approximation of a tree, with the root of the tree +at the left and 'left-to-right' order of children transformed into +'top-to-bottom'. Because this mode grows both to the right and down, +it isn't suitable for large programs (unless you have a very wide +terminal). + +=back + +=head2 Options for Line-Style + +These options select the line-style (or just style) used to render +each opcode, and dictates what info is actually printed into each line. + +=over 4 + +=item B<-concise> + +Use the author's favorite set of formatting conventions. This is the +default, of course. + +=item B<-terse> + +Use formatting conventions that emulate the output of B<B::Terse>. The +basic mode is almost indistinguishable from the real B<B::Terse>, and the +exec mode looks very similar, but is in a more logical order and lacks +curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode +is only vaguely reminiscent of B<B::Terse>. + +=item B<-linenoise> + +Use formatting conventions in which the name of each OP, rather than being +written out in full, is represented by a one- or two-character abbreviation. +This is mainly a joke. + +=item B<-debug> + +Use formatting conventions reminiscent of B<B::Debug>; these aren't +very concise at all. + +=item B<-env> + +Use formatting conventions read from the environment variables +C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>. + +=back + +=head2 Options for tree-specific formatting + +=over 4 + +=item B<-compact> + +Use a tree format in which the minimum amount of space is used for the +lines connecting nodes (one character in most cases). This squeezes out +a few precious columns of screen real estate. + +=item B<-loose> + +Use a tree format that uses longer edges to separate OP nodes. This format +tends to look better than the compact one, especially in ASCII, and is +the default. + +=item B<-vt> + +Use tree connecting characters drawn from the VT100 line-drawing set. +This looks better if your terminal supports it. + +=item B<-ascii> + +Draw the tree with standard ASCII characters like C<+> and C<|>. These don't +look as clean as the VT100 characters, but they'll work with almost any +terminal (or the horizontal scrolling mode of less(1)) and are suitable +for text documentation or email. This is the default. + +=back + +These are pairwise exclusive, i.e. compact or loose, vt or ascii. + +=head2 Options controlling sequence numbering + +=over 4 + +=item B<-base>I<n> + +Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the +digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit +for 37 will be 'A', and so on until 62. Values greater than 62 are not +currently supported. The default is 36. + +=item B<-bigendian> + +Print sequence numbers with the most significant digit first. This is the +usual convention for Arabic numerals, and the default. + +=item B<-littleendian> + +Print seqence numbers with the least significant digit first. This is +obviously mutually exclusive with bigendian. + +=back + +=head2 Other options + +These are pairwise exclusive. + +=over 4 + +=item B<-main> + +Include the main program in the output, even if subroutines were also +specified. This rendering is normally suppressed when a subroutine +name or reference is given. + +=item B<-nomain> + +This restores the default behavior after you've changed it with '-main' +(it's not normally needed). If no subroutine name/ref is given, main is +rendered, regardless of this flag. + +=item B<-nobanner> + +Renderings usually include a banner line identifying the function name +or stringified subref. This suppresses the printing of the banner. + +TBC: Remove the stringified coderef; while it provides a 'cookie' for +each function rendered, the cookies used should be 1,2,3.. not a +random hex-address. It also complicates string comparison of two +different trees. + +=item B<-banner> + +restores default banner behavior. + +=item B<-banneris> => subref + +TBC: a hookpoint (and an option to set it) for a user-supplied +function to produce a banner appropriate for users needs. It's not +ideal, because the rendering-state variables, which are a natural +candidate for use in concise.t, are unavailable to the user. + +=back + +=head2 Option Stickiness + +If you invoke Concise more than once in a program, you should know that +the options are 'sticky'. This means that the options you provide in +the first call will be remembered for the 2nd call, unless you +re-specify or change them. + +=head1 ABBREVIATIONS + +The concise style uses symbols to convey maximum info with minimal +clutter (like hex addresses). With just a little practice, you can +start to see the flowers, not just the branches, in the trees. + +=head2 OP class abbreviations + +These symbols appear before the op-name, and indicate the +B:: namespace that represents the ops in your Perl code. + + 0 OP (aka BASEOP) An OP with no children + 1 UNOP An OP with one child + 2 BINOP An OP with two children + | LOGOP A control branch OP + @ LISTOP An OP that could have lots of children + / PMOP An OP with a regular expression + $ SVOP An OP with an SV + " PVOP An OP with a string + { LOOP An OP that holds pointers for a loop + ; COP An OP that marks the start of a statement + # PADOP An OP with a GV on the pad + +=head2 OP flags abbreviations + +OP flags are either public or private. The public flags alter the +behavior of each opcode in consistent ways, and are represented by 0 +or more single characters. + + v OPf_WANT_VOID Want nothing (void context) + s OPf_WANT_SCALAR Want single value (scalar context) + l OPf_WANT_LIST Want list of any length (list context) + Want is unknown + K OPf_KIDS There is a firstborn child. + P OPf_PARENS This operator was parenthesized. + (Or block needs explicit scope entry.) + R OPf_REF Certified reference. + (Return container, not containee). + M OPf_MOD Will modify (lvalue). + S OPf_STACKED Some arg is arriving on the stack. + * OPf_SPECIAL Do something weird for this op (see op.h) + +Private flags, if any are set for an opcode, are displayed after a '/' + + 8 <@> leave[1 ref] vKP/REFC ->(end) + 7 <2> sassign vKS/2 ->8 + +They're opcode specific, and occur less often than the public ones, so +they're represented by short mnemonics instead of single-chars; see +F<op.h> for gory details, or try this quick 2-liner: + + $> perl -MB::Concise -de 1 + DB<1> |x \%B::Concise::priv + +=head1 FORMATTING SPECIFICATIONS + +For each line-style ('concise', 'terse', 'linenoise', etc.) there are +3 format-specs which control how OPs are rendered. + +The first is the 'default' format, which is used in both basic and exec +modes to print all opcodes. The 2nd, goto-format, is used in exec +mode when branches are encountered. They're not real opcodes, and are +inserted to look like a closing curly brace. The tree-format is tree +specific. + +When a line is rendered, the correct format-spec is copied and scanned +for the following items; data is substituted in, and other +manipulations like basic indenting are done, for each opcode rendered. + +There are 3 kinds of items that may be populated; special patterns, +#vars, and literal text, which is copied verbatim. (Yes, it's a set +of s///g steps.) + +=head2 Special Patterns + +These items are the primitives used to perform indenting, and to +select text from amongst alternatives. + +=over 4 + +=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)> + +Generates I<exec_text> in exec mode, or I<basic_text> in basic mode. + +=item B<(*(>I<text>B<)*)> + +Generates one copy of I<text> for each indentation level. + +=item B<(*(>I<text1>B<;>I<text2>B<)*)> + +Generates one fewer copies of I<text1> than the indentation level, followed +by one copy of I<text2> if the indentation level is more than 0. + +=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)> + +If the value of I<var> is true (not empty or zero), generates the +value of I<var> surrounded by I<text1> and I<Text2>, otherwise +nothing. + +=item B<~> + +Any number of tildes and surrounding whitespace will be collapsed to +a single space. + +=back + +=head2 # Variables + +These #vars represent opcode properties that you may want as part of +your rendering. The '#' is intended as a private sigil; a #var's +value is interpolated into the style-line, much like "read $this". + +These vars take 3 forms: + +=over 4 + +=item B<#>I<var> + +A property named 'var' is assumed to exist for the opcodes, and is +interpolated into the rendering. + +=item B<#>I<var>I<N> + +Generates the value of I<var>, left justified to fill I<N> spaces. +Note that this means while you can have properties 'foo' and 'foo2', +you cannot render 'foo2', but you could with 'foo2a'. You would be +wise not to rely on this behavior going forward ;-) + +=item B<#>I<Var> + +This ucfirst form of #var generates a tag-value form of itself for +display; it converts '#Var' into a 'Var => #var' style, which is then +handled as described above. (Imp-note: #Vars cannot be used for +conditional-fills, because the => #var transform is done after the check +for #Var's value). + +=back + +The following variables are 'defined' by B::Concise; when they are +used in a style, their respective values are plugged into the +rendering of each opcode. + +Only some of these are used by the standard styles, the others are +provided for you to delve into optree mechanics, should you wish to +add a new style (see L</add_style> below) that uses them. You can +also add new ones using L</add_callback>. + +=over 4 + +=item B<#addr> + +The address of the OP, in hexadecimal. + +=item B<#arg> + +The OP-specific information of the OP (such as the SV for an SVOP, the +non-local exit pointers for a LOOP, etc.) enclosed in parentheses. + +=item B<#class> + +The B-determined class of the OP, in all caps. + +=item B<#classsym> + +A single symbol abbreviating the class of the OP. + +=item B<#coplabel> + +The label of the statement or block the OP is the start of, if any. + +=item B<#exname> + +The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo. + +=item B<#extarg> + +The target of the OP, or nothing for a nulled OP. + +=item B<#firstaddr> + +The address of the OP's first child, in hexadecimal. + +=item B<#flags> + +The OP's flags, abbreviated as a series of symbols. + +=item B<#flagval> + +The numeric value of the OP's flags. + +=item B<#hyphseq> + +The sequence number of the OP, or a hyphen if it doesn't have one. + +=item B<#label> + +'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec +mode, or empty otherwise. + +=item B<#lastaddr> + +The address of the OP's last child, in hexadecimal. + +=item B<#name> + +The OP's name. + +=item B<#NAME> + +The OP's name, in all caps. + +=item B<#next> + +The sequence number of the OP's next OP. + +=item B<#nextaddr> + +The address of the OP's next OP, in hexadecimal. + +=item B<#noise> + +A one- or two-character abbreviation for the OP's name. + +=item B<#private> + +The OP's private flags, rendered with abbreviated names if possible. + +=item B<#privval> + +The numeric value of the OP's private flags. + +=item B<#seq> + +The sequence number of the OP. Note that this is a sequence number +generated by B::Concise. + +=item B<#seqnum> + +5.8.x and earlier only. 5.9 and later do not provide this. + +The real sequence number of the OP, as a regular number and not adjusted +to be relative to the start of the real program. (This will generally be +a fairly large number because all of B<B::Concise> is compiled before +your program is). + +=item B<#opt> + +Whether or not the op has been optimised by the peephole optimiser. + +Only available in 5.9 and later. + +=item B<#static> + +Whether or not the op is statically defined. This flag is used by the +B::C compiler backend and indicates that the op should not be freed. + +Only available in 5.9 and later. + +=item B<#sibaddr> + +The address of the OP's next youngest sibling, in hexadecimal. + +=item B<#svaddr> + +The address of the OP's SV, if it has an SV, in hexadecimal. + +=item B<#svclass> + +The class of the OP's SV, if it has one, in all caps (e.g., 'IV'). + +=item B<#svval> + +The value of the OP's SV, if it has one, in a short human-readable format. + +=item B<#targ> + +The numeric value of the OP's targ. + +=item B<#targarg> + +The name of the variable the OP's targ refers to, if any, otherwise the +letter t followed by the OP's targ in decimal. + +=item B<#targarglife> + +Same as B<#targarg>, but followed by the COP sequence numbers that delimit +the variable's lifetime (or 'end' for a variable in an open scope) for a +variable. + +=item B<#typenum> + +The numeric value of the OP's type, in decimal. + +=back + +=head1 Using B::Concise outside of the O framework + +The common (and original) usage of B::Concise was for command-line +renderings of simple code, as given in EXAMPLE. But you can also use +B<B::Concise> from your code, and call compile() directly, and +repeatedly. By doing so, you can avoid the compile-time only +operation of O.pm, and even use the debugger to step through +B::Concise::compile() itself. + +Once you're doing this, you may alter Concise output by adding new +rendering styles, and by optionally adding callback routines which +populate new variables, if such were referenced from those (just +added) styles. + +=head2 Example: Altering Concise Renderings + + use B::Concise qw(set_style add_callback); + add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt); + add_callback + ( sub { + my ($h, $op, $format, $level, $stylename) = @_; + $h->{variable} = some_func($op); + }); + $walker = B::Concise::compile(@options,@subnames,@subrefs); + $walker->(); + +=head2 set_style() + +B<set_style> accepts 3 arguments, and updates the three format-specs +comprising a line-style (basic-exec, goto, tree). It has one minor +drawback though; it doesn't register the style under a new name. This +can become an issue if you render more than once and switch styles. +Thus you may prefer to use add_style() and/or set_style_standard() +instead. + +=head2 set_style_standard($name) + +This restores one of the standard line-styles: C<terse>, C<concise>, +C<linenoise>, C<debug>, C<env>, into effect. It also accepts style +names previously defined with add_style(). + +=head2 add_style() + +This subroutine accepts a new style name and three style arguments as +above, and creates, registers, and selects the newly named style. It is +an error to re-add a style; call set_style_standard() to switch between +several styles. + +=head2 add_callback() + +If your newly minted styles refer to any new #variables, you'll need +to define a callback subroutine that will populate (or modify) those +variables. They are then available for use in the style you've +chosen. + +The callbacks are called for each opcode visited by Concise, in the +same order as they are added. Each subroutine is passed five +parameters. + + 1. A hashref, containing the variable names and values which are + populated into the report-line for the op + 2. the op, as a B<B::OP> object + 3. a reference to the format string + 4. the formatting (indent) level + 5. the selected stylename + +To define your own variables, simply add them to the hash, or change +existing values if you need to. The level and format are passed in as +references to scalars, but it is unlikely that they will need to be +changed or even used. + +=head2 Running B::Concise::compile() + +B<compile> accepts options as described above in L</OPTIONS>, and +arguments, which are either coderefs, or subroutine names. + +It constructs and returns a $treewalker coderef, which when invoked, +traverses, or walks, and renders the optrees of the given arguments to +STDOUT. You can reuse this, and can change the rendering style used +each time; thereafter the coderef renders in the new style. + +B<walk_output> lets you change the print destination from STDOUT to +another open filehandle, or into a string passed as a ref (unless +you've built perl with -Uuseperlio). + + my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1 + walk_output(\my $buf); + $walker->(); # 1 renders -terse + set_style_standard('concise'); # 2 + $walker->(); # 2 renders -concise + $walker->(@new); # 3 renders whatever + print "3 different renderings: terse, concise, and @new: $buf\n"; + +When $walker is called, it traverses the subroutines supplied when it +was created, and renders them using the current style. You can change +the style afterwards in several different ways: + + 1. call C<compile>, altering style or mode/order + 2. call C<set_style_standard> + 3. call $walker, passing @new options + +Passing new options to the $walker is the easiest way to change +amongst any pre-defined styles (the ones you add are automatically +recognized as options), and is the only way to alter rendering order +without calling compile again. Note however that rendering state is +still shared amongst multiple $walker objects, so they must still be +used in a coordinated manner. + +=head2 B::Concise::reset_sequence() + +This function (not exported) lets you reset the sequence numbers (note +that they're numbered arbitrarily, their goal being to be human +readable). Its purpose is mostly to support testing, i.e. to compare +the concise output from two identical anonymous subroutines (but +different instances). Without the reset, B::Concise, seeing that +they're separate optrees, generates different sequence numbers in +the output. + +=head2 Errors + +Errors in rendering (non-existent function-name, non-existent coderef) +are written to the STDOUT, or wherever you've set it via +walk_output(). + +Errors using the various *style* calls, and bad args to walk_output(), +result in die(). Use an eval if you wish to catch these errors and +continue processing. + +=head1 AUTHOR + +Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>. + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Debug.pm b/Master/tlpkg/installer/perllib/B/Debug.pm new file mode 100644 index 00000000000..cb369682d66 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Debug.pm @@ -0,0 +1,305 @@ +package B::Debug; + +our $VERSION = '1.02_01'; + +use strict; +use B qw(peekop class walkoptree walkoptree_exec + main_start main_root cstring sv_undef); +use B::Asmdata qw(@specialsv_name); + +my %done_gv; + +sub B::OP::debug { + my ($op) = @_; + printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type; +%s (0x%lx) + op_next 0x%x + op_sibling 0x%x + op_ppaddr %s + op_targ %d + op_type %d +EOT + if ($] > 5.009) { + printf <<'EOT', $op->opt, $op->static; + op_opt %d + op_static %d +EOT + } else { + printf <<'EOT', $op->seq; + op_seq %d +EOT + } + printf <<'EOT', $op->flags, $op->private; + op_flags %d + op_private %d +EOT +} + +sub B::UNOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_first\t0x%x\n", ${$op->first}; +} + +sub B::BINOP::debug { + my ($op) = @_; + $op->B::UNOP::debug(); + printf "\top_last\t\t0x%x\n", ${$op->last}; +} + +sub B::LOOP::debug { + my ($op) = @_; + $op->B::BINOP::debug(); + printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop}; + op_redoop 0x%x + op_nextop 0x%x + op_lastop 0x%x +EOT +} + +sub B::LOGOP::debug { + my ($op) = @_; + $op->B::UNOP::debug(); + printf "\top_other\t0x%x\n", ${$op->other}; +} + +sub B::LISTOP::debug { + my ($op) = @_; + $op->B::BINOP::debug(); + printf "\top_children\t%d\n", $op->children; +} + +sub B::PMOP::debug { + my ($op) = @_; + $op->B::LISTOP::debug(); + printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot}; + printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; + printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; + printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); + printf "\top_pmflags\t0x%x\n", $op->pmflags; + $op->pmreplroot->debug; +} + +sub B::COP::debug { + my ($op) = @_; + $op->B::OP::debug(); + my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; + printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io); + cop_label %s + cop_stashpv %s + cop_file %s + cop_seq %d + cop_arybase %d + cop_line %d + cop_warnings 0x%x + cop_io %s +EOT +} + +sub B::SVOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_sv\t\t0x%x\n", ${$op->sv}; + $op->sv->debug; +} + +sub B::PVOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_pv\t\t%s\n", cstring($op->pv); +} + +sub B::PADOP::debug { + my ($op) = @_; + $op->B::OP::debug(); + printf "\top_padix\t\t%ld\n", $op->padix; +} + +sub B::NULL::debug { + my ($sv) = @_; + if ($$sv == ${sv_undef()}) { + print "&sv_undef\n"; + } else { + printf "NULL (0x%x)\n", $$sv; + } +} + +sub B::SV::debug { + my ($sv) = @_; + if (!$$sv) { + print class($sv), " = NULL\n"; + return; + } + printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; +%s (0x%x) + REFCNT %d + FLAGS 0x%x +EOT +} + +sub B::RV::debug { + my ($rv) = @_; + B::SV::debug($rv); + printf <<'EOT', ${$rv->RV}; + RV 0x%x +EOT + $rv->RV->debug; +} + +sub B::PV::debug { + my ($sv) = @_; + $sv->B::SV::debug(); + my $pv = $sv->PV(); + printf <<'EOT', cstring($pv), length($pv); + xpv_pv %s + xpv_cur %d +EOT +} + +sub B::IV::debug { + my ($sv) = @_; + $sv->B::SV::debug(); + printf "\txiv_iv\t\t%d\n", $sv->IV; +} + +sub B::NV::debug { + my ($sv) = @_; + $sv->B::IV::debug(); + printf "\txnv_nv\t\t%s\n", $sv->NV; +} + +sub B::PVIV::debug { + my ($sv) = @_; + $sv->B::PV::debug(); + printf "\txiv_iv\t\t%d\n", $sv->IV; +} + +sub B::PVNV::debug { + my ($sv) = @_; + $sv->B::PVIV::debug(); + printf "\txnv_nv\t\t%s\n", $sv->NV; +} + +sub B::PVLV::debug { + my ($sv) = @_; + $sv->B::PVNV::debug(); + printf "\txlv_targoff\t%d\n", $sv->TARGOFF; + printf "\txlv_targlen\t%u\n", $sv->TARGLEN; + printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); +} + +sub B::BM::debug { + my ($sv) = @_; + $sv->B::PVNV::debug(); + printf "\txbm_useful\t%d\n", $sv->USEFUL; + printf "\txbm_previous\t%u\n", $sv->PREVIOUS; + printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); +} + +sub B::CV::debug { + my ($sv) = @_; + $sv->B::PVNV::debug(); + my ($stash) = $sv->STASH; + my ($start) = $sv->START; + my ($root) = $sv->ROOT; + my ($padlist) = $sv->PADLIST; + my ($file) = $sv->FILE; + my ($gv) = $sv->GV; + printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ; + STASH 0x%x + START 0x%x + ROOT 0x%x + GV 0x%x + FILE %s + DEPTH %d + PADLIST 0x%x + OUTSIDE 0x%x + OUTSIDE_SEQ %d +EOT + $start->debug if $start; + $root->debug if $root; + $gv->debug if $gv; + $padlist->debug if $padlist; +} + +sub B::AV::debug { + my ($av) = @_; + $av->B::SV::debug; + my(@array) = $av->ARRAY; + print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; + printf <<'EOT', scalar(@array), $av->MAX, $av->OFF; + FILL %d + MAX %d + OFF %d +EOT + printf <<'EOT', $av->AvFLAGS if $] < 5.009; + AvFLAGS %d +EOT +} + +sub B::GV::debug { + my ($gv) = @_; + if ($done_gv{$$gv}++) { + printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; + return; + } + my ($sv) = $gv->SV; + my ($av) = $gv->AV; + my ($cv) = $gv->CV; + $gv->B::SV::debug; + printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS; + NAME %s + STASH %s (0x%x) + SV 0x%x + GvREFCNT %d + FORM 0x%x + AV 0x%x + HV 0x%x + EGV 0x%x + CV 0x%x + CVGEN %d + LINE %d + FILE %s + GvFLAGS 0x%x +EOT + $sv->debug if $sv; + $av->debug if $av; + $cv->debug if $cv; +} + +sub B::SPECIAL::debug { + my $sv = shift; + print $specialsv_name[$$sv], "\n"; +} + +sub compile { + my $order = shift; + B::clearsym(); + if ($order && $order eq "exec") { + return sub { walkoptree_exec(main_start, "debug") } + } else { + return sub { walkoptree(main_root, "debug") } + } +} + +1; + +__END__ + +=head1 NAME + +B::Debug - Walk Perl syntax tree, printing debug info about ops + +=head1 SYNOPSIS + + perl -MO=Debug[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +See F<ext/B/README>. + +=head1 AUTHOR + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Deparse.pm b/Master/tlpkg/installer/perllib/B/Deparse.pm new file mode 100644 index 00000000000..3db6fbe6e1f --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Deparse.pm @@ -0,0 +1,4642 @@ +# B::Deparse.pm +# Copyright (c) 1998-2000, 2002, 2003 Stephen McCamant. All rights reserved. +# This module is free software; you can redistribute and/or modify +# it under the same terms as Perl itself. + +# This is based on the module of the same name by Malcolm Beattie, +# but essentially none of his code remains. + +package B::Deparse; +use Carp; +use B qw(class main_root main_start main_cv svref_2object opnumber perlstring + OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST + OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD + OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE + OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY + OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER + OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED + SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG + CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION + PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_SKIPWHITE + PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); +$VERSION = 0.71; +use strict; +use vars qw/$AUTOLOAD/; +use warnings (); + +# Changes between 0.50 and 0.51: +# - fixed nulled leave with live enter in sort { } +# - fixed reference constants (\"str") +# - handle empty programs gracefully +# - handle infinte loops (for (;;) {}, while (1) {}) +# - differentiate between `for my $x ...' and `my $x; for $x ...' +# - various minor cleanups +# - moved globals into an object +# - added `-u', like B::C +# - package declarations using cop_stash +# - subs, formats and code sorted by cop_seq +# Changes between 0.51 and 0.52: +# - added pp_threadsv (special variables under USE_5005THREADS) +# - added documentation +# Changes between 0.52 and 0.53: +# - many changes adding precedence contexts and associativity +# - added `-p' and `-s' output style options +# - various other minor fixes +# Changes between 0.53 and 0.54: +# - added support for new `for (1..100)' optimization, +# thanks to Gisle Aas +# Changes between 0.54 and 0.55: +# - added support for new qr// construct +# - added support for new pp_regcreset OP +# Changes between 0.55 and 0.56: +# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t +# - fixed $# on non-lexicals broken in last big rewrite +# - added temporary fix for change in opcode of OP_STRINGIFY +# - fixed problem in 0.54's for() patch in `for (@ary)' +# - fixed precedence in conditional of ?: +# - tweaked list paren elimination in `my($x) = @_' +# - made continue-block detection trickier wrt. null ops +# - fixed various prototype problems in pp_entersub +# - added support for sub prototypes that never get GVs +# - added unquoting for special filehandle first arg in truncate +# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV' +# - added semicolons at the ends of blocks +# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28 +# Changes between 0.56 and 0.561: +# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy) +# - used new B.pm symbolic constants (done by Nick Ing-Simmons) +# Changes between 0.561 and 0.57: +# - stylistic changes to symbolic constant stuff +# - handled scope in s///e replacement code +# - added unquote option for expanding "" into concats, etc. +# - split method and proto parts of pp_entersub into separate functions +# - various minor cleanups +# Changes after 0.57: +# - added parens in \&foo (patch by Albert Dvornik) +# Changes between 0.57 and 0.58: +# - fixed `0' statements that weren't being printed +# - added methods for use from other programs +# (based on patches from James Duncan and Hugo van der Sanden) +# - added -si and -sT to control indenting (also based on a patch from Hugo) +# - added -sv to print something else instead of '???' +# - preliminary version of utf8 tr/// handling +# Changes after 0.58: +# - uses of $op->ppaddr changed to new $op->name (done by Sarathy) +# - added support for Hugo's new OP_SETSTATE (like nextstate) +# Changes between 0.58 and 0.59 +# - added support for Chip's OP_METHOD_NAMED +# - added support for Ilya's OPpTARGET_MY optimization +# - elided arrows before `()' subscripts when possible +# Changes between 0.59 and 0.60 +# - support for method attribues was added +# - some warnings fixed +# - separate recognition of constant subs +# - rewrote continue block handling, now recoginizing for loops +# - added more control of expanding control structures +# Changes between 0.60 and 0.61 (mostly by Robin Houston) +# - many bug-fixes +# - support for pragmas and 'use' +# - support for the little-used $[ variable +# - support for __DATA__ sections +# - UTF8 support +# - BEGIN, CHECK, INIT and END blocks +# - scoping of subroutine declarations fixed +# - compile-time output from the input program can be suppressed, so that the +# output is just the deparsed code. (a change to O.pm in fact) +# - our() declarations +# - *all* the known bugs are now listed in the BUGS section +# - comprehensive test mechanism (TEST -deparse) +# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez) +# - bug-fixes +# - new switch -P +# - support for command-line switches (-l, -0, etc.) +# Changes between 0.63 and 0.64 +# - support for //, CHECK blocks, and assertions +# - improved handling of foreach loops and lexicals +# - option to use Data::Dumper for constants +# - more bug fixes +# - discovered lots more bugs not yet fixed + +# Todo: +# (See also BUGS section at the end of this file) +# +# - finish tr/// changes +# - add option for even more parens (generalize \&foo change) +# - left/right context +# - copy comments (look at real text with $^P?) +# - avoid semis in one-statement blocks +# - associativity of &&=, ||=, ?: +# - ',' => '=>' (auto-unquote?) +# - break long lines ("\r" as discretionary break?) +# - configurable syntax highlighting: ANSI color, HTML, TeX, etc. +# - more style options: brace style, hex vs. octal, quotes, ... +# - print big ints as hex/octal instead of decimal (heuristic?) +# - handle `my $x if 0'? +# - version using op_next instead of op_first/sibling? +# - avoid string copies (pass arrays, one big join?) +# - here-docs? + +# Current test.deparse failures +# comp/assertions 38 - disabled assertions should be like "my($x) if 0" +# 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}' +# comp/hints 6 - location of BEGIN blocks wrt. block openings +# run/switchI 1 - missing -I switches entirely +# perl -Ifoo -e 'print @INC' +# op/caller 2 - warning mask propagates backwards before warnings::register +# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register' +# op/getpid 2 - can't assign to shared my() declaration (threads only) +# 'my $x : shared = 5' +# op/override 7 - parens on overriden require change v-string interpretation +# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6' +# c.f. 'BEGIN { *f = sub {0} }; f 2' +# op/pat 774 - losing Unicode-ness of Latin1-only strings +# 'use charnames ":short"; $x="\N{latin:a with acute}"' +# op/recurse 12 - missing parens on recursive call makes it look like method +# 'sub f { f($x) }' +# op/subst 90 - inconsistent handling of utf8 under "use utf8" +# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open +# op/tiehandle compile - "use strict" deparsed in the wrong place +# uni/tr_ several +# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs +# ext/Data/Dumper/t/dumper compile +# ext/DB_file/several +# ext/Encode/several +# ext/Ernno/Errno warnings +# ext/IO/lib/IO/t/io_sel 23 +# ext/PerlIO/t/encoding compile +# ext/POSIX/t/posix 6 +# ext/Socket/Socket 8 +# ext/Storable/t/croak compile +# lib/Attribute/Handlers/t/multi compile +# lib/bignum/ several +# lib/charnames 35 +# lib/constant 32 +# lib/English 40 +# lib/ExtUtils/t/bytes 4 +# lib/File/DosGlob compile +# lib/Filter/Simple/t/data 1 +# lib/Math/BigInt/t/constant 1 +# lib/Net/t/config Deparse-warning +# lib/overload compile +# lib/Switch/ several +# lib/Symbol 4 +# lib/Test/Simple several +# lib/Term/Complete +# lib/Tie/File/t/29_downcopy 5 +# lib/vars 22 + +# Object fields (were globals): +# +# avoid_local: +# (local($a), local($b)) and local($a, $b) have the same internal +# representation but the short form looks better. We notice we can +# use a large-scale local when checking the list, but need to prevent +# individual locals too. This hash holds the addresses of OPs that +# have already had their local-ness accounted for. The same thing +# is done with my(). +# +# curcv: +# CV for current sub (or main program) being deparsed +# +# curcvlex: +# Cached hash of lexical variables for curcv: keys are names, +# each value is an array of pairs, indicating the cop_seq of scopes +# in which a var of that name is valid. +# +# curcop: +# COP for statement being deparsed +# +# curstash: +# name of the current package for deparsed code +# +# subs_todo: +# array of [cop_seq, CV, is_format?] for subs and formats we still +# want to deparse +# +# protos_todo: +# as above, but [name, prototype] for subs that never got a GV +# +# subs_done, forms_done: +# keys are addresses of GVs for subs and formats we've already +# deparsed (or at least put into subs_todo) +# +# subs_declared +# keys are names of subs for which we've printed declarations. +# That means we can omit parentheses from the arguments. +# +# subs_deparsed +# Keeps track of fully qualified names of all deparsed subs. +# +# parens: -p +# linenums: -l +# unquote: -q +# cuddle: ` ' or `\n', depending on -sC +# indent_size: -si +# use_tabs: -sT +# ex_const: -sv + +# A little explanation of how precedence contexts and associativity +# work: +# +# deparse() calls each per-op subroutine with an argument $cx (short +# for context, but not the same as the cx* in the perl core), which is +# a number describing the op's parents in terms of precedence, whether +# they're inside an expression or at statement level, etc. (see +# chart below). When ops with children call deparse on them, they pass +# along their precedence. Fractional values are used to implement +# associativity (`($x + $y) + $z' => `$x + $y + $y') and related +# parentheses hacks. The major disadvantage of this scheme is that +# it doesn't know about right sides and left sides, so say if you +# assign a listop to a variable, it can't tell it's allowed to leave +# the parens off the listop. + +# Precedences: +# 26 [TODO] inside interpolation context ("") +# 25 left terms and list operators (leftward) +# 24 left -> +# 23 nonassoc ++ -- +# 22 right ** +# 21 right ! ~ \ and unary + and - +# 20 left =~ !~ +# 19 left * / % x +# 18 left + - . +# 17 left << >> +# 16 nonassoc named unary operators +# 15 nonassoc < > <= >= lt gt le ge +# 14 nonassoc == != <=> eq ne cmp +# 13 left & +# 12 left | ^ +# 11 left && +# 10 left || +# 9 nonassoc .. ... +# 8 right ?: +# 7 right = += -= *= etc. +# 6 left , => +# 5 nonassoc list operators (rightward) +# 4 right not +# 3 left and +# 2 left or xor +# 1 statement modifiers +# 0.5 statements, but still print scopes as do { ... } +# 0 statement level + +# Nonprinting characters with special meaning: +# \cS - steal parens (see maybe_parens_unop) +# \n - newline and indent +# \t - increase indent +# \b - decrease indent (`outdent') +# \f - flush left (no indent) +# \cK - kill following semicolon, if any + +sub null { + my $op = shift; + return class($op) eq "NULL"; +} + +sub todo { + my $self = shift; + my($cv, $is_form) = @_; + return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE}); + my $seq; + if ($cv->OUTSIDE_SEQ) { + $seq = $cv->OUTSIDE_SEQ; + } elsif (!null($cv->START) and is_state($cv->START)) { + $seq = $cv->START->cop_seq; + } else { + $seq = 0; + } + push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form]; + unless ($is_form || class($cv->STASH) eq 'SPECIAL') { + $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1; + } +} + +sub next_todo { + my $self = shift; + my $ent = shift @{$self->{'subs_todo'}}; + my $cv = $ent->[1]; + my $gv = $cv->GV; + my $name = $self->gv_name($gv); + if ($ent->[2]) { + return "format $name =\n" + . $self->deparse_format($ent->[1]). "\n"; + } else { + $self->{'subs_declared'}{$name} = 1; + if ($name eq "BEGIN") { + my $use_dec = $self->begin_is_use($cv); + if (defined ($use_dec) and $self->{'expand'} < 5) { + return () if 0 == length($use_dec); + return $use_dec; + } + } + my $l = ''; + if ($self->{'linenums'}) { + my $line = $gv->LINE; + my $file = $gv->FILE; + $l = "\n\f#line $line \"$file\"\n"; + } + my $p = ''; + if (class($cv->STASH) ne "SPECIAL") { + my $stash = $cv->STASH->NAME; + if ($stash ne $self->{'curstash'}) { + $p = "package $stash;\n"; + $name = "$self->{'curstash'}::$name" unless $name =~ /::/; + $self->{'curstash'} = $stash; + } + $name =~ s/^\Q$stash\E:://; + } + return "${p}${l}sub $name " . $self->deparse_sub($cv); + } +} + +# Return a "use" declaration for this BEGIN block, if appropriate +sub begin_is_use { + my ($self, $cv) = @_; + my $root = $cv->ROOT; + local @$self{qw'curcv curcvlex'} = ($cv); +#require B::Debug; +#B::walkoptree($cv->ROOT, "debug"); + my $lineseq = $root->first; + return if $lineseq->name ne "lineseq"; + + my $req_op = $lineseq->first->sibling; + return if $req_op->name ne "require"; + + my $module; + if ($req_op->first->private & OPpCONST_BARE) { + # Actually it should always be a bareword + $module = $self->const_sv($req_op->first)->PV; + $module =~ s[/][::]g; + $module =~ s/.pm$//; + } + else { + $module = $self->const($self->const_sv($req_op->first), 6); + } + + my $version; + my $version_op = $req_op->sibling; + return if class($version_op) eq "NULL"; + if ($version_op->name eq "lineseq") { + # We have a version parameter; skip nextstate & pushmark + my $constop = $version_op->first->next->next; + + return unless $self->const_sv($constop)->PV eq $module; + $constop = $constop->sibling; + $version = $self->const_sv($constop); + if (class($version) eq "IV") { + $version = $version->int_value; + } elsif (class($version) eq "NV") { + $version = $version->NV; + } elsif (class($version) ne "PVMG") { + # Includes PVIV and PVNV + $version = $version->PV; + } else { + # version specified as a v-string + $version = 'v'.join '.', map ord, split //, $version->PV; + } + $constop = $constop->sibling; + return if $constop->name ne "method_named"; + return if $self->const_sv($constop)->PV ne "VERSION"; + } + + $lineseq = $version_op->sibling; + return if $lineseq->name ne "lineseq"; + my $entersub = $lineseq->first->sibling; + if ($entersub->name eq "stub") { + return "use $module $version ();\n" if defined $version; + return "use $module ();\n"; + } + return if $entersub->name ne "entersub"; + + # See if there are import arguments + my $args = ''; + + my $svop = $entersub->first->sibling; # Skip over pushmark + return unless $self->const_sv($svop)->PV eq $module; + + # Pull out the arguments + for ($svop=$svop->sibling; $svop->name ne "method_named"; + $svop = $svop->sibling) { + $args .= ", " if length($args); + $args .= $self->deparse($svop, 6); + } + + my $use = 'use'; + my $method_named = $svop; + return if $method_named->name ne "method_named"; + my $method_name = $self->const_sv($method_named)->PV; + + if ($method_name eq "unimport") { + $use = 'no'; + } + + # Certain pragmas are dealt with using hint bits, + # so we ignore them here + if ($module eq 'strict' || $module eq 'integer' + || $module eq 'bytes' || $module eq 'warnings') { + return ""; + } + + if (defined $version && length $args) { + return "$use $module $version ($args);\n"; + } elsif (defined $version) { + return "$use $module $version;\n"; + } elsif (length $args) { + return "$use $module ($args);\n"; + } else { + return "$use $module;\n"; + } +} + +sub stash_subs { + my ($self, $pack) = @_; + my (@ret, $stash); + if (!defined $pack) { + $pack = ''; + $stash = \%::; + } + else { + $pack =~ s/(::)?$/::/; + no strict 'refs'; + $stash = \%$pack; + } + my %stash = svref_2object($stash)->ARRAY; + while (my ($key, $val) = each %stash) { + next if $key eq 'main::'; # avoid infinite recursion + my $class = class($val); + if ($class eq "PV") { + # Just a prototype. As an ugly but fairly effective way + # to find out if it belongs here is to see if the AUTOLOAD + # (if any) for the stash was defined in one of our files. + my $A = $stash{"AUTOLOAD"}; + if (defined ($A) && class($A) eq "GV" && defined($A->CV) + && class($A->CV) eq "CV") { + my $AF = $A->FILE; + next unless $AF eq $0 || exists $self->{'files'}{$AF}; + } + push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV]; + } elsif ($class eq "IV") { + # Just a name. As above. + my $A = $stash{"AUTOLOAD"}; + if (defined ($A) && class($A) eq "GV" && defined($A->CV) + && class($A->CV) eq "CV") { + my $AF = $A->FILE; + next unless $AF eq $0 || exists $self->{'files'}{$AF}; + } + push @{$self->{'protos_todo'}}, [$pack . $key, undef]; + } elsif ($class eq "GV") { + if (class(my $cv = $val->CV) ne "SPECIAL") { + next if $self->{'subs_done'}{$$val}++; + next if $$val != ${$cv->GV}; # Ignore imposters + $self->todo($cv, 0); + } + if (class(my $cv = $val->FORM) ne "SPECIAL") { + next if $self->{'forms_done'}{$$val}++; + next if $$val != ${$cv->GV}; # Ignore imposters + $self->todo($cv, 1); + } + if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) { + $self->stash_subs($pack . $key); + } + } + } +} + +sub print_protos { + my $self = shift; + my $ar; + my @ret; + foreach $ar (@{$self->{'protos_todo'}}) { + my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : ""); + push @ret, "sub " . $ar->[0] . "$proto;\n"; + } + delete $self->{'protos_todo'}; + return @ret; +} + +sub style_opts { + my $self = shift; + my $opts = shift; + my $opt; + while (length($opt = substr($opts, 0, 1))) { + if ($opt eq "C") { + $self->{'cuddle'} = " "; + $opts = substr($opts, 1); + } elsif ($opt eq "i") { + $opts =~ s/^i(\d+)//; + $self->{'indent_size'} = $1; + } elsif ($opt eq "T") { + $self->{'use_tabs'} = 1; + $opts = substr($opts, 1); + } elsif ($opt eq "v") { + $opts =~ s/^v([^.]*)(.|$)//; + $self->{'ex_const'} = $1; + } + } +} + +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->{'cuddle'} = "\n"; + $self->{'curcop'} = undef; + $self->{'curstash'} = "main"; + $self->{'ex_const'} = "'???'"; + $self->{'expand'} = 0; + $self->{'files'} = {}; + $self->{'indent_size'} = 4; + $self->{'linenums'} = 0; + $self->{'parens'} = 0; + $self->{'subs_todo'} = []; + $self->{'unquote'} = 0; + $self->{'use_dumper'} = 0; + $self->{'use_tabs'} = 0; + + $self->{'ambient_arybase'} = 0; + $self->{'ambient_warnings'} = undef; # Assume no lexical warnings + $self->{'ambient_hints'} = 0; + $self->init(); + + while (my $arg = shift @_) { + if ($arg eq "-d") { + $self->{'use_dumper'} = 1; + require Data::Dumper; + } elsif ($arg =~ /^-f(.*)/) { + $self->{'files'}{$1} = 1; + } elsif ($arg eq "-l") { + $self->{'linenums'} = 1; + } elsif ($arg eq "-p") { + $self->{'parens'} = 1; + } elsif ($arg eq "-P") { + $self->{'noproto'} = 1; + } elsif ($arg eq "-q") { + $self->{'unquote'} = 1; + } elsif (substr($arg, 0, 2) eq "-s") { + $self->style_opts(substr $arg, 2); + } elsif ($arg =~ /^-x(\d)$/) { + $self->{'expand'} = $1; + } + } + return $self; +} + +{ + # Mask out the bits that L<warnings::register> uses + my $WARN_MASK; + BEGIN { + $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all}; + } + sub WARN_MASK () { + return $WARN_MASK; + } +} + +# Initialise the contextual information, either from +# defaults provided with the ambient_pragmas method, +# or from perl's own defaults otherwise. +sub init { + my $self = shift; + + $self->{'arybase'} = $self->{'ambient_arybase'}; + $self->{'warnings'} = defined ($self->{'ambient_warnings'}) + ? $self->{'ambient_warnings'} & WARN_MASK + : undef; + $self->{'hints'} = $self->{'ambient_hints'} & 0xFF; + + # also a convenient place to clear out subs_declared + delete $self->{'subs_declared'}; +} + +sub compile { + my(@args) = @_; + return sub { + my $self = B::Deparse->new(@args); + # First deparse command-line args + if (defined $^I) { # deparse -i + print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n); + } + if ($^W) { # deparse -w + print qq(BEGIN { \$^W = $^W; }\n); + } + if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0 + my $fs = perlstring($/) || 'undef'; + my $bs = perlstring($O::savebackslash) || 'undef'; + print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n); + } + my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : (); + my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : (); + my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : (); + my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : (); + for my $block (@BEGINs, @CHECKs, @INITs, @ENDs) { + $self->todo($block, 0); + } + $self->stash_subs(); + local($SIG{"__DIE__"}) = + sub { + if ($self->{'curcop'}) { + my $cop = $self->{'curcop'}; + my($line, $file) = ($cop->line, $cop->file); + print STDERR "While deparsing $file near line $line,\n"; + } + }; + $self->{'curcv'} = main_cv; + $self->{'curcvlex'} = undef; + print $self->print_protos; + @{$self->{'subs_todo'}} = + sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}; + print $self->indent($self->deparse_root(main_root)), "\n" + unless null main_root; + my @text; + while (scalar(@{$self->{'subs_todo'}})) { + push @text, $self->next_todo; + } + print $self->indent(join("", @text)), "\n" if @text; + + # Print __DATA__ section, if necessary + no strict 'refs'; + my $laststash = defined $self->{'curcop'} + ? $self->{'curcop'}->stash->NAME : $self->{'curstash'}; + if (defined *{$laststash."::DATA"}{IO}) { + print "package $laststash;\n" + unless $laststash eq $self->{'curstash'}; + print "__DATA__\n"; + print readline(*{$laststash."::DATA"}); + } + } +} + +sub coderef2text { + my $self = shift; + my $sub = shift; + croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE"); + + $self->init(); + return $self->indent($self->deparse_sub(svref_2object($sub))); +} + +sub ambient_pragmas { + my $self = shift; + my ($arybase, $hint_bits, $warning_bits) = (0, 0); + + while (@_ > 1) { + my $name = shift(); + my $val = shift(); + + if ($name eq 'strict') { + require strict; + + if ($val eq 'none') { + $hint_bits &= ~strict::bits(qw/refs subs vars/); + next(); + } + + my @names; + if ($val eq "all") { + @names = qw/refs subs vars/; + } + elsif (ref $val) { + @names = @$val; + } + else { + @names = split' ', $val; + } + $hint_bits |= strict::bits(@names); + } + + elsif ($name eq '$[') { + $arybase = $val; + } + + elsif ($name eq 'integer' + || $name eq 'bytes' + || $name eq 'utf8') { + require "$name.pm"; + if ($val) { + $hint_bits |= ${$::{"${name}::"}{"hint_bits"}}; + } + else { + $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}}; + } + } + + elsif ($name eq 're') { + require re; + if ($val eq 'none') { + $hint_bits &= ~re::bits(qw/taint eval/); + next(); + } + + my @names; + if ($val eq 'all') { + @names = qw/taint eval/; + } + elsif (ref $val) { + @names = @$val; + } + else { + @names = split' ',$val; + } + $hint_bits |= re::bits(@names); + } + + elsif ($name eq 'warnings') { + if ($val eq 'none') { + $warning_bits = $warnings::NONE; + next(); + } + + my @names; + if (ref $val) { + @names = @$val; + } + else { + @names = split/\s+/, $val; + } + + $warning_bits = $warnings::NONE if !defined ($warning_bits); + $warning_bits |= warnings::bits(@names); + } + + elsif ($name eq 'warning_bits') { + $warning_bits = $val; + } + + elsif ($name eq 'hint_bits') { + $hint_bits = $val; + } + + else { + croak "Unknown pragma type: $name"; + } + } + if (@_) { + croak "The ambient_pragmas method expects an even number of args"; + } + + $self->{'ambient_arybase'} = $arybase; + $self->{'ambient_warnings'} = $warning_bits; + $self->{'ambient_hints'} = $hint_bits; +} + +# This method is the inner loop, so try to keep it simple +sub deparse { + my $self = shift; + my($op, $cx) = @_; + + Carp::confess("Null op in deparse") if !defined($op) + || class($op) eq "NULL"; + my $meth = "pp_" . $op->name; + return $self->$meth($op, $cx); +} + +sub indent { + my $self = shift; + my $txt = shift; + my @lines = split(/\n/, $txt); + my $leader = ""; + my $level = 0; + my $line; + for $line (@lines) { + my $cmd = substr($line, 0, 1); + if ($cmd eq "\t" or $cmd eq "\b") { + $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'}; + if ($self->{'use_tabs'}) { + $leader = "\t" x ($level / 8) . " " x ($level % 8); + } else { + $leader = " " x $level; + } + $line = substr($line, 1); + } + if (substr($line, 0, 1) eq "\f") { + $line = substr($line, 1); # no indent + } else { + $line = $leader . $line; + } + $line =~ s/\cK;?//g; + } + return join("\n", @lines); +} + +sub deparse_sub { + my $self = shift; + my $cv = shift; + my $proto = ""; +Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL"); +Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL"); + local $self->{'curcop'} = $self->{'curcop'}; + if ($cv->FLAGS & SVf_POK) { + $proto = "(". $cv->PV . ") "; + } + if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE|CVf_ASSERTION)) { + $proto .= ": "; + $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE; + $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED; + $proto .= "method " if $cv->CvFLAGS & CVf_METHOD; + $proto .= "assertion " if $cv->CvFLAGS & CVf_ASSERTION; + } + + local($self->{'curcv'}) = $cv; + local($self->{'curcvlex'}); + local(@$self{qw'curstash warnings hints'}) + = @$self{qw'curstash warnings hints'}; + my $body; + if (not null $cv->ROOT) { + my $lineseq = $cv->ROOT->first; + if ($lineseq->name eq "lineseq") { + my @ops; + for(my$o=$lineseq->first; $$o; $o=$o->sibling) { + push @ops, $o; + } + $body = $self->lineseq(undef, @ops).";"; + my $scope_en = $self->find_scope_en($lineseq); + if (defined $scope_en) { + my $subs = join"", $self->seq_subs($scope_en); + $body .= ";\n$subs" if length($subs); + } + } + else { + $body = $self->deparse($cv->ROOT->first, 0); + } + } + else { + my $sv = $cv->const_sv; + if ($$sv) { + # uh-oh. inlinable sub... format it differently + return $proto . "{ " . $self->const($sv, 0) . " }\n"; + } else { # XSUB? (or just a declaration) + return "$proto;\n"; + } + } + return $proto ."{\n\t$body\n\b}" ."\n"; +} + +sub deparse_format { + my $self = shift; + my $form = shift; + my @text; + local($self->{'curcv'}) = $form; + local($self->{'curcvlex'}); + local($self->{'in_format'}) = 1; + local(@$self{qw'curstash warnings hints'}) + = @$self{qw'curstash warnings hints'}; + my $op = $form->ROOT; + my $kid; + return "\f." if $op->first->name eq 'stub' + || $op->first->name eq 'nextstate'; + $op = $op->first->first; # skip leavewrite, lineseq + while (not null $op) { + $op = $op->sibling; # skip nextstate + my @exprs; + $kid = $op->first->sibling; # skip pushmark + push @text, "\f".$self->const_sv($kid)->PV; + $kid = $kid->sibling; + for (; not null $kid; $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 0); + } + push @text, "\f".join(", ", @exprs)."\n" if @exprs; + $op = $op->sibling; + } + return join("", @text) . "\f."; +} + +sub is_scope { + my $op = shift; + return $op->name eq "leave" || $op->name eq "scope" + || $op->name eq "lineseq" + || ($op->name eq "null" && class($op) eq "UNOP" + && (is_scope($op->first) || $op->first->name eq "enter")); +} + +sub is_state { + my $name = $_[0]->name; + return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate"; +} + +sub is_miniwhile { # check for one-line loop (`foo() while $y--') + my $op = shift; + return (!null($op) and null($op->sibling) + and $op->name eq "null" and class($op) eq "UNOP" + and (($op->first->name =~ /^(and|or)$/ + and $op->first->first->sibling->name eq "lineseq") + or ($op->first->name eq "lineseq" + and not null $op->first->first->sibling + and $op->first->first->sibling->name eq "unstack") + )); +} + +# Check if the op and its sibling are the initialization and the rest of a +# for (..;..;..) { ... } loop +sub is_for_loop { + my $op = shift; + # This OP might be almost anything, though it won't be a + # nextstate. (It's the initialization, so in the canonical case it + # will be an sassign.) The sibling is a lineseq whose first child + # is a nextstate and whose second is a leaveloop. + my $lseq = $op->sibling; + if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") { + if ($lseq->first && !null($lseq->first) && is_state($lseq->first) + && (my $sib = $lseq->first->sibling)) { + return (!null($sib) && $sib->name eq "leaveloop"); + } + } + return 0; +} + +sub is_scalar { + my $op = shift; + return ($op->name eq "rv2sv" or + $op->name eq "padsv" or + $op->name eq "gv" or # only in array/hash constructs + $op->flags & OPf_KIDS && !null($op->first) + && $op->first->name eq "gvsv"); +} + +sub maybe_parens { + my $self = shift; + my($text, $cx, $prec) = @_; + if ($prec < $cx # unary ops nest just fine + or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21 + or $self->{'parens'}) + { + $text = "($text)"; + # In a unop, let parent reuse our parens; see maybe_parens_unop + $text = "\cS" . $text if $cx == 16; + return $text; + } else { + return $text; + } +} + +# same as above, but get around the `if it looks like a function' rule +sub maybe_parens_unop { + my $self = shift; + my($name, $kid, $cx) = @_; + if ($cx > 16 or $self->{'parens'}) { + $kid = $self->deparse($kid, 1); + if ($name eq "umask" && $kid =~ /^\d+$/) { + $kid = sprintf("%#o", $kid); + } + return "$name($kid)"; + } else { + $kid = $self->deparse($kid, 16); + if ($name eq "umask" && $kid =~ /^\d+$/) { + $kid = sprintf("%#o", $kid); + } + if (substr($kid, 0, 1) eq "\cS") { + # use kid's parens + return $name . substr($kid, 1); + } elsif (substr($kid, 0, 1) eq "(") { + # avoid looks-like-a-function trap with extra parens + # (`+' can lead to ambiguities) + return "$name(" . $kid . ")"; + } else { + return "$name $kid"; + } + } +} + +sub maybe_parens_func { + my $self = shift; + my($func, $text, $cx, $prec) = @_; + if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) { + return "$func($text)"; + } else { + return "$func $text"; + } +} + +sub maybe_local { + my $self = shift; + my($op, $cx, $text) = @_; + my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0; + if ($op->private & (OPpLVAL_INTRO|$our_intro) + and not $self->{'avoid_local'}{$$op}) { + my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our"; + if( $our_local eq 'our' ) { + # XXX This assertion fails code with non-ASCII identifiers, + # like ./ext/Encode/t/jperl.t + die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/; + $text =~ s/(\w+::)+//; + } + if (want_scalar($op)) { + return "$our_local $text"; + } else { + return $self->maybe_parens_func("$our_local", $text, $cx, 16); + } + } else { + return $text; + } +} + +sub maybe_targmy { + my $self = shift; + my($op, $cx, $func, @args) = @_; + if ($op->private & OPpTARGET_MY) { + my $var = $self->padname($op->targ); + my $val = $func->($self, $op, 7, @args); + return $self->maybe_parens("$var = $val", $cx, 7); + } else { + return $func->($self, $op, $cx, @args); + } +} + +sub padname_sv { + my $self = shift; + my $targ = shift; + return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ); +} + +sub maybe_my { + my $self = shift; + my($op, $cx, $text) = @_; + if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { + if (want_scalar($op)) { + return "my $text"; + } else { + return $self->maybe_parens_func("my", $text, $cx, 16); + } + } else { + return $text; + } +} + +# The following OPs don't have functions: + +# pp_padany -- does not exist after parsing + +sub AUTOLOAD { + if ($AUTOLOAD =~ s/^.*::pp_//) { + warn "unexpected OP_".uc $AUTOLOAD; + return "XXX"; + } else { + die "Undefined subroutine $AUTOLOAD called"; + } +} + +sub DESTROY {} # Do not AUTOLOAD + +# $root should be the op which represents the root of whatever +# we're sequencing here. If it's undefined, then we don't append +# any subroutine declarations to the deparsed ops, otherwise we +# append appropriate declarations. +sub lineseq { + my($self, $root, @ops) = @_; + my($expr, @exprs); + + my $out_cop = $self->{'curcop'}; + my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef; + my $limit_seq; + if (defined $root) { + $limit_seq = $out_seq; + my $nseq; + $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling}; + $limit_seq = $nseq if !defined($limit_seq) + or defined($nseq) && $nseq < $limit_seq; + } + $limit_seq = $self->{'limit_seq'} + if defined($self->{'limit_seq'}) + && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq); + local $self->{'limit_seq'} = $limit_seq; + for (my $i = 0; $i < @ops; $i++) { + $expr = ""; + if (is_state $ops[$i]) { + $expr = $self->deparse($ops[$i], 0); + $i++; + if ($i > $#ops) { + push @exprs, $expr; + last; + } + } + if (!is_state $ops[$i] and (my $ls = $ops[$i+1]) and + !null($ops[$i+1]) and $ops[$i+1]->name eq "lineseq") + { + if ($ls->first && !null($ls->first) && is_state($ls->first) + && (my $sib = $ls->first->sibling)) { + if (!null($sib) && $sib->name eq "leaveloop") { + push @exprs, $expr . $self->for_loop($ops[$i], 0); + $i++; + next; + } + } + } + $expr .= $self->deparse($ops[$i], (@ops != 1)/2); + $expr =~ s/;\n?\z//; + push @exprs, $expr; + } + my $body = join(";\n", grep {length} @exprs); + my $subs = ""; + if (defined $root && defined $limit_seq && !$self->{'in_format'}) { + $subs = join "\n", $self->seq_subs($limit_seq); + } + return join(";\n", grep {length} $body, $subs); +} + +sub scopeop { + my($real_block, $self, $op, $cx) = @_; + my $kid; + my @kids; + + local(@$self{qw'curstash warnings hints'}) + = @$self{qw'curstash warnings hints'} if $real_block; + if ($real_block) { + $kid = $op->first->sibling; # skip enter + if (is_miniwhile($kid)) { + my $top = $kid->first; + my $name = $top->name; + if ($name eq "and") { + $name = "while"; + } elsif ($name eq "or") { + $name = "until"; + } else { # no conditional -> while 1 or until 0 + return $self->deparse($top->first, 1) . " while 1"; + } + my $cond = $top->first; + my $body = $cond->sibling->first; # skip lineseq + $cond = $self->deparse($cond, 1); + $body = $self->deparse($body, 1); + return "$body $name $cond"; + } + } else { + $kid = $op->first; + } + for (; !null($kid); $kid = $kid->sibling) { + push @kids, $kid; + } + if ($cx > 0) { # inside an expression, (a do {} while for lineseq) + return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}"; + } else { + my $lineseq = $self->lineseq($op, @kids); + return (length ($lineseq) ? "$lineseq;" : ""); + } +} + +sub pp_scope { scopeop(0, @_); } +sub pp_lineseq { scopeop(0, @_); } +sub pp_leave { scopeop(1, @_); } + +# This is a special case of scopeop and lineseq, for the case of the +# main_root. The difference is that we print the output statements as +# soon as we get them, for the sake of impatient users. +sub deparse_root { + my $self = shift; + my($op) = @_; + local(@$self{qw'curstash warnings hints'}) + = @$self{qw'curstash warnings hints'}; + my @kids; + for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) { + push @kids, $kid; + } + for (my $i = 0; $i < @kids; $i++) { + my $expr = ""; + if (is_state $kids[$i]) { + $expr = $self->deparse($kids[$i], 0); + $i++; + if ($i > $#kids) { + print $self->indent($expr); + last; + } + } + if (is_for_loop($kids[$i])) { + $expr .= $self->for_loop($kids[$i], 0); + $expr .= ";\n" unless $i == $#kids; + print $self->indent($expr); + $i++; + next; + } + $expr .= $self->deparse($kids[$i], (@kids != 1)/2); + $expr =~ s/;\n?\z//; + $expr .= ";"; + print $self->indent($expr); + print "\n" unless $i == $#kids; + } +} + +# The BEGIN {} is used here because otherwise this code isn't executed +# when you run B::Deparse on itself. +my %globalnames; +BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC", + "ENV", "ARGV", "ARGVOUT", "_"); } + +sub gv_name { + my $self = shift; + my $gv = shift; +Carp::confess() unless ref($gv) eq "B::GV"; + my $stash = $gv->STASH->NAME; + my $name = $gv->SAFENAME; + if (($stash eq 'main' && $globalnames{$name}) + or ($stash eq $self->{'curstash'} && !$globalnames{$name}) + or $name =~ /^[^A-Za-z_:]/) + { + $stash = ""; + } else { + $stash = $stash . "::"; + } + if ($name =~ /^(\^..|{)/) { + $name = "{$name}"; # ${^WARNING_BITS}, etc and ${ + } + return $stash . $name; +} + +# Return the name to use for a stash variable. +# If a lexical with the same name is in scope, it may need to be +# fully-qualified. +sub stash_variable { + my ($self, $prefix, $name) = @_; + + return "$prefix$name" if $name =~ /::/; + + unless ($prefix eq '$' || $prefix eq '@' || #' + $prefix eq '%' || $prefix eq '$#') { + return "$prefix$name"; + } + + my $v = ($prefix eq '$#' ? '@' : $prefix) . $name; + return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v); + return "$prefix$name"; +} + +sub lex_in_scope { + my ($self, $name) = @_; + $self->populate_curcvlex() if !defined $self->{'curcvlex'}; + + return 0 if !defined($self->{'curcop'}); + my $seq = $self->{'curcop'}->cop_seq; + return 0 if !exists $self->{'curcvlex'}{$name}; + for my $a (@{$self->{'curcvlex'}{$name}}) { + my ($st, $en) = @$a; + return 1 if $seq > $st && $seq <= $en; + } + return 0; +} + +sub populate_curcvlex { + my $self = shift; + for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) { + my $padlist = $cv->PADLIST; + # an undef CV still in lexical chain + next if class($padlist) eq "SPECIAL"; + my @padlist = $padlist->ARRAY; + my @ns = $padlist[0]->ARRAY; + + for (my $i=0; $i<@ns; ++$i) { + next if class($ns[$i]) eq "SPECIAL"; + next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars + if (class($ns[$i]) eq "PV") { + # Probably that pesky lexical @_ + next; + } + my $name = $ns[$i]->PVX; + my ($seq_st, $seq_en) = + ($ns[$i]->FLAGS & SVf_FAKE) + ? (0, 999999) + : ($ns[$i]->NVX, $ns[$i]->IVX); + + push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en]; + } + } +} + +sub find_scope_st { ((find_scope(@_))[0]); } +sub find_scope_en { ((find_scope(@_))[1]); } + +# Recurses down the tree, looking for pad variable introductions and COPs +sub find_scope { + my ($self, $op, $scope_st, $scope_en) = @_; + carp("Undefined op in find_scope") if !defined $op; + return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS; + + for (my $o=$op->first; $$o; $o=$o->sibling) { + if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) { + my $s = int($self->padname_sv($o->targ)->NVX); + my $e = $self->padname_sv($o->targ)->IVX; + $scope_st = $s if !defined($scope_st) || $s < $scope_st; + $scope_en = $e if !defined($scope_en) || $e > $scope_en; + } + elsif (is_state($o)) { + my $c = $o->cop_seq; + $scope_st = $c if !defined($scope_st) || $c < $scope_st; + $scope_en = $c if !defined($scope_en) || $c > $scope_en; + } + elsif ($o->flags & OPf_KIDS) { + ($scope_st, $scope_en) = + $self->find_scope($o, $scope_st, $scope_en) + } + } + + return ($scope_st, $scope_en); +} + +# Returns a list of subs which should be inserted before the COP +sub cop_subs { + my ($self, $op, $out_seq) = @_; + my $seq = $op->cop_seq; + # If we have nephews, then our sequence number indicates + # the cop_seq of the end of some sort of scope. + if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS + and my $nseq = $self->find_scope_st($op->sibling) ) { + $seq = $nseq; + } + $seq = $out_seq if defined($out_seq) && $out_seq < $seq; + return $self->seq_subs($seq); +} + +sub seq_subs { + my ($self, $seq) = @_; + my @text; +#push @text, "# ($seq)\n"; + + return "" if !defined $seq; + while (scalar(@{$self->{'subs_todo'}}) + and $seq > $self->{'subs_todo'}[0][0]) { + push @text, $self->next_todo; + } + return @text; +} + +# Notice how subs and formats are inserted between statements here; +# also $[ assignments and pragmas. +sub pp_nextstate { + my $self = shift; + my($op, $cx) = @_; + $self->{'curcop'} = $op; + my @text; + push @text, $self->cop_subs($op); + push @text, $op->label . ": " if $op->label; + my $stash = $op->stashpv; + if ($stash ne $self->{'curstash'}) { + push @text, "package $stash;\n"; + $self->{'curstash'} = $stash; + } + + if ($self->{'arybase'} != $op->arybase) { + push @text, '$[ = '. $op->arybase .";\n"; + $self->{'arybase'} = $op->arybase; + } + + my $warnings = $op->warnings; + my $warning_bits; + if ($warnings->isa("B::SPECIAL") && $$warnings == 4) { + $warning_bits = $warnings::Bits{"all"} & WARN_MASK; + } + elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) { + $warning_bits = $warnings::NONE; + } + elsif ($warnings->isa("B::SPECIAL")) { + $warning_bits = undef; + } + else { + $warning_bits = $warnings->PV & WARN_MASK; + } + + if (defined ($warning_bits) and + !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) { + push @text, declare_warnings($self->{'warnings'}, $warning_bits); + $self->{'warnings'} = $warning_bits; + } + + if ($self->{'hints'} != $op->private) { + push @text, declare_hints($self->{'hints'}, $op->private); + $self->{'hints'} = $op->private; + } + + # This should go after of any branches that add statements, to + # increase the chances that it refers to the same line it did in + # the original program. + if ($self->{'linenums'}) { + push @text, "\f#line " . $op->line . + ' "' . $op->file, qq'"\n'; + } + + return join("", @text); +} + +sub declare_warnings { + my ($from, $to) = @_; + if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) { + return "use warnings;\n"; + } + elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) { + return "no warnings;\n"; + } + return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n"; +} + +sub declare_hints { + my ($from, $to) = @_; + my $use = $to & ~$from; + my $no = $from & ~$to; + my $decls = ""; + for my $pragma (hint_pragmas($use)) { + $decls .= "use $pragma;\n"; + } + for my $pragma (hint_pragmas($no)) { + $decls .= "no $pragma;\n"; + } + return $decls; +} + +sub hint_pragmas { + my ($bits) = @_; + my @pragmas; + push @pragmas, "integer" if $bits & 0x1; + push @pragmas, "strict 'refs'" if $bits & 0x2; + push @pragmas, "bytes" if $bits & 0x8; + return @pragmas; +} + +sub pp_dbstate { pp_nextstate(@_) } +sub pp_setstate { pp_nextstate(@_) } + +sub pp_unstack { return "" } # see also leaveloop + +sub baseop { + my $self = shift; + my($op, $cx, $name) = @_; + return $name; +} + +sub pp_stub { + my $self = shift; + my($op, $cx, $name) = @_; + if ($cx >= 1) { + return "()"; + } + else { + return "();"; + } +} +sub pp_wantarray { baseop(@_, "wantarray") } +sub pp_fork { baseop(@_, "fork") } +sub pp_wait { maybe_targmy(@_, \&baseop, "wait") } +sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") } +sub pp_time { maybe_targmy(@_, \&baseop, "time") } +sub pp_tms { baseop(@_, "times") } +sub pp_ghostent { baseop(@_, "gethostent") } +sub pp_gnetent { baseop(@_, "getnetent") } +sub pp_gprotoent { baseop(@_, "getprotoent") } +sub pp_gservent { baseop(@_, "getservent") } +sub pp_ehostent { baseop(@_, "endhostent") } +sub pp_enetent { baseop(@_, "endnetent") } +sub pp_eprotoent { baseop(@_, "endprotoent") } +sub pp_eservent { baseop(@_, "endservent") } +sub pp_gpwent { baseop(@_, "getpwent") } +sub pp_spwent { baseop(@_, "setpwent") } +sub pp_epwent { baseop(@_, "endpwent") } +sub pp_ggrent { baseop(@_, "getgrent") } +sub pp_sgrent { baseop(@_, "setgrent") } +sub pp_egrent { baseop(@_, "endgrent") } +sub pp_getlogin { baseop(@_, "getlogin") } + +sub POSTFIX () { 1 } + +# I couldn't think of a good short name, but this is the category of +# symbolic unary operators with interesting precedence + +sub pfixop { + my $self = shift; + my($op, $cx, $name, $prec, $flags) = (@_, 0); + my $kid = $op->first; + $kid = $self->deparse($kid, $prec); + return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid", + $cx, $prec); +} + +sub pp_preinc { pfixop(@_, "++", 23) } +sub pp_predec { pfixop(@_, "--", 23) } +sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } +sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } +sub pp_i_preinc { pfixop(@_, "++", 23) } +sub pp_i_predec { pfixop(@_, "--", 23) } +sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) } +sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) } +sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) } + +sub pp_negate { maybe_targmy(@_, \&real_negate) } +sub real_negate { + my $self = shift; + my($op, $cx) = @_; + if ($op->first->name =~ /^(i_)?negate$/) { + # avoid --$x + $self->pfixop($op, $cx, "-", 21.5); + } else { + $self->pfixop($op, $cx, "-", 21); + } +} +sub pp_i_negate { pp_negate(@_) } + +sub pp_not { + my $self = shift; + my($op, $cx) = @_; + if ($cx <= 4) { + $self->pfixop($op, $cx, "not ", 4); + } else { + $self->pfixop($op, $cx, "!", 21); + } +} + +sub unop { + my $self = shift; + my($op, $cx, $name) = @_; + my $kid; + if ($op->flags & OPf_KIDS) { + $kid = $op->first; + if (defined prototype("CORE::$name") + && prototype("CORE::$name") =~ /^;?\*/ + && $kid->name eq "rv2gv") { + $kid = $kid->first; + } + + return $self->maybe_parens_unop($name, $kid, $cx); + } else { + return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); + } +} + +sub pp_chop { maybe_targmy(@_, \&unop, "chop") } +sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") } +sub pp_schop { maybe_targmy(@_, \&unop, "chop") } +sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") } +sub pp_defined { unop(@_, "defined") } +sub pp_undef { unop(@_, "undef") } +sub pp_study { unop(@_, "study") } +sub pp_ref { unop(@_, "ref") } +sub pp_pos { maybe_local(@_, unop(@_, "pos")) } + +sub pp_sin { maybe_targmy(@_, \&unop, "sin") } +sub pp_cos { maybe_targmy(@_, \&unop, "cos") } +sub pp_rand { maybe_targmy(@_, \&unop, "rand") } +sub pp_srand { unop(@_, "srand") } +sub pp_exp { maybe_targmy(@_, \&unop, "exp") } +sub pp_log { maybe_targmy(@_, \&unop, "log") } +sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") } +sub pp_int { maybe_targmy(@_, \&unop, "int") } +sub pp_hex { maybe_targmy(@_, \&unop, "hex") } +sub pp_oct { maybe_targmy(@_, \&unop, "oct") } +sub pp_abs { maybe_targmy(@_, \&unop, "abs") } + +sub pp_length { maybe_targmy(@_, \&unop, "length") } +sub pp_ord { maybe_targmy(@_, \&unop, "ord") } +sub pp_chr { maybe_targmy(@_, \&unop, "chr") } + +sub pp_each { unop(@_, "each") } +sub pp_values { unop(@_, "values") } +sub pp_keys { unop(@_, "keys") } +sub pp_pop { unop(@_, "pop") } +sub pp_shift { unop(@_, "shift") } + +sub pp_caller { unop(@_, "caller") } +sub pp_reset { unop(@_, "reset") } +sub pp_exit { unop(@_, "exit") } +sub pp_prototype { unop(@_, "prototype") } + +sub pp_close { unop(@_, "close") } +sub pp_fileno { unop(@_, "fileno") } +sub pp_umask { unop(@_, "umask") } +sub pp_untie { unop(@_, "untie") } +sub pp_tied { unop(@_, "tied") } +sub pp_dbmclose { unop(@_, "dbmclose") } +sub pp_getc { unop(@_, "getc") } +sub pp_eof { unop(@_, "eof") } +sub pp_tell { unop(@_, "tell") } +sub pp_getsockname { unop(@_, "getsockname") } +sub pp_getpeername { unop(@_, "getpeername") } + +sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") } +sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") } +sub pp_readlink { unop(@_, "readlink") } +sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") } +sub pp_readdir { unop(@_, "readdir") } +sub pp_telldir { unop(@_, "telldir") } +sub pp_rewinddir { unop(@_, "rewinddir") } +sub pp_closedir { unop(@_, "closedir") } +sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") } +sub pp_localtime { unop(@_, "localtime") } +sub pp_gmtime { unop(@_, "gmtime") } +sub pp_alarm { unop(@_, "alarm") } +sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") } + +sub pp_dofile { unop(@_, "do") } +sub pp_entereval { unop(@_, "eval") } + +sub pp_ghbyname { unop(@_, "gethostbyname") } +sub pp_gnbyname { unop(@_, "getnetbyname") } +sub pp_gpbyname { unop(@_, "getprotobyname") } +sub pp_shostent { unop(@_, "sethostent") } +sub pp_snetent { unop(@_, "setnetent") } +sub pp_sprotoent { unop(@_, "setprotoent") } +sub pp_sservent { unop(@_, "setservent") } +sub pp_gpwnam { unop(@_, "getpwnam") } +sub pp_gpwuid { unop(@_, "getpwuid") } +sub pp_ggrnam { unop(@_, "getgrnam") } +sub pp_ggrgid { unop(@_, "getgrgid") } + +sub pp_lock { unop(@_, "lock") } + +sub pp_exists { + my $self = shift; + my($op, $cx) = @_; + my $arg; + if ($op->private & OPpEXISTS_SUB) { + # Checking for the existence of a subroutine + return $self->maybe_parens_func("exists", + $self->pp_rv2cv($op->first, 16), $cx, 16); + } + if ($op->flags & OPf_SPECIAL) { + # Array element, not hash element + return $self->maybe_parens_func("exists", + $self->pp_aelem($op->first, 16), $cx, 16); + } + return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16), + $cx, 16); +} + +sub pp_delete { + my $self = shift; + my($op, $cx) = @_; + my $arg; + if ($op->private & OPpSLICE) { + if ($op->flags & OPf_SPECIAL) { + # Deleting from an array, not a hash + return $self->maybe_parens_func("delete", + $self->pp_aslice($op->first, 16), + $cx, 16); + } + return $self->maybe_parens_func("delete", + $self->pp_hslice($op->first, 16), + $cx, 16); + } else { + if ($op->flags & OPf_SPECIAL) { + # Deleting from an array, not a hash + return $self->maybe_parens_func("delete", + $self->pp_aelem($op->first, 16), + $cx, 16); + } + return $self->maybe_parens_func("delete", + $self->pp_helem($op->first, 16), + $cx, 16); + } +} + +sub pp_require { + my $self = shift; + my($op, $cx) = @_; + my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require'; + if (class($op) eq "UNOP" and $op->first->name eq "const" + and $op->first->private & OPpCONST_BARE) + { + my $name = $self->const_sv($op->first)->PV; + $name =~ s[/][::]g; + $name =~ s/\.pm//g; + return "$opname $name"; + } else { + $self->unop($op, $cx, $opname); + } +} + +sub pp_scalar { + my $self = shift; + my($op, $cv) = @_; + my $kid = $op->first; + if (not null $kid->sibling) { + # XXX Was a here-doc + return $self->dquote($op); + } + $self->unop(@_, "scalar"); +} + + +sub padval { + my $self = shift; + my $targ = shift; + return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ); +} + +sub pp_refgen { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + if ($kid->name eq "null") { + $kid = $kid->first; + if ($kid->name eq "anonlist" || $kid->name eq "anonhash") { + my($pre, $post) = @{{"anonlist" => ["[","]"], + "anonhash" => ["{","}"]}->{$kid->name}}; + my($expr, @exprs); + $kid = $kid->first->sibling; # skip pushmark + for (; !null($kid); $kid = $kid->sibling) { + $expr = $self->deparse($kid, 6); + push @exprs, $expr; + } + return $pre . join(", ", @exprs) . $post; + } elsif (!null($kid->sibling) and + $kid->sibling->name eq "anoncode") { + return "sub " . + $self->deparse_sub($self->padval($kid->sibling->targ)); + } elsif ($kid->name eq "pushmark") { + my $sib_name = $kid->sibling->name; + if ($sib_name =~ /^(pad|rv2)[ah]v$/ + and not $kid->sibling->flags & OPf_REF) + { + # The @a in \(@a) isn't in ref context, but only when the + # parens are there. + return "\\(" . $self->pp_list($op->first) . ")"; + } elsif ($sib_name eq 'entersub') { + my $text = $self->deparse($kid->sibling, 1); + # Always show parens for \(&func()), but only with -p otherwise + $text = "($text)" if $self->{'parens'} + or $kid->sibling->private & OPpENTERSUB_AMPER; + return "\\$text"; + } + } + } + $self->pfixop($op, $cx, "\\", 20); +} + +sub pp_srefgen { pp_refgen(@_) } + +sub pp_readline { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh> + return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid); + return $self->unop($op, $cx, "readline"); +} + +sub pp_rcatline { + my $self = shift; + my($op) = @_; + return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">"; +} + +# Unary operators that can occur as pseudo-listops inside double quotes +sub dq_unop { + my $self = shift; + my($op, $cx, $name, $prec, $flags) = (@_, 0, 0); + my $kid; + if ($op->flags & OPf_KIDS) { + $kid = $op->first; + # If there's more than one kid, the first is an ex-pushmark. + $kid = $kid->sibling if not null $kid->sibling; + return $self->maybe_parens_unop($name, $kid, $cx); + } else { + return $name . ($op->flags & OPf_SPECIAL ? "()" : ""); + } +} + +sub pp_ucfirst { dq_unop(@_, "ucfirst") } +sub pp_lcfirst { dq_unop(@_, "lcfirst") } +sub pp_uc { dq_unop(@_, "uc") } +sub pp_lc { dq_unop(@_, "lc") } +sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") } + +sub loopex { + my $self = shift; + my ($op, $cx, $name) = @_; + if (class($op) eq "PVOP") { + return "$name " . $op->pv; + } elsif (class($op) eq "OP") { + return $name; + } elsif (class($op) eq "UNOP") { + # Note -- loop exits are actually exempt from the + # looks-like-a-func rule, but a few extra parens won't hurt + return $self->maybe_parens_unop($name, $op->first, $cx); + } +} + +sub pp_last { loopex(@_, "last") } +sub pp_next { loopex(@_, "next") } +sub pp_redo { loopex(@_, "redo") } +sub pp_goto { loopex(@_, "goto") } +sub pp_dump { loopex(@_, "dump") } + +sub ftst { + my $self = shift; + my($op, $cx, $name) = @_; + if (class($op) eq "UNOP") { + # Genuine `-X' filetests are exempt from the LLAFR, but not + # l?stat(); for the sake of clarity, give'em all parens + return $self->maybe_parens_unop($name, $op->first, $cx); + } elsif (class($op) =~ /^(SV|PAD)OP$/) { + return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16); + } else { # I don't think baseop filetests ever survive ck_ftst, but... + return $name; + } +} + +sub pp_lstat { ftst(@_, "lstat") } +sub pp_stat { ftst(@_, "stat") } +sub pp_ftrread { ftst(@_, "-R") } +sub pp_ftrwrite { ftst(@_, "-W") } +sub pp_ftrexec { ftst(@_, "-X") } +sub pp_fteread { ftst(@_, "-r") } +sub pp_ftewrite { ftst(@_, "-w") } +sub pp_fteexec { ftst(@_, "-x") } +sub pp_ftis { ftst(@_, "-e") } +sub pp_fteowned { ftst(@_, "-O") } +sub pp_ftrowned { ftst(@_, "-o") } +sub pp_ftzero { ftst(@_, "-z") } +sub pp_ftsize { ftst(@_, "-s") } +sub pp_ftmtime { ftst(@_, "-M") } +sub pp_ftatime { ftst(@_, "-A") } +sub pp_ftctime { ftst(@_, "-C") } +sub pp_ftsock { ftst(@_, "-S") } +sub pp_ftchr { ftst(@_, "-c") } +sub pp_ftblk { ftst(@_, "-b") } +sub pp_ftfile { ftst(@_, "-f") } +sub pp_ftdir { ftst(@_, "-d") } +sub pp_ftpipe { ftst(@_, "-p") } +sub pp_ftlink { ftst(@_, "-l") } +sub pp_ftsuid { ftst(@_, "-u") } +sub pp_ftsgid { ftst(@_, "-g") } +sub pp_ftsvtx { ftst(@_, "-k") } +sub pp_fttty { ftst(@_, "-t") } +sub pp_fttext { ftst(@_, "-T") } +sub pp_ftbinary { ftst(@_, "-B") } + +sub SWAP_CHILDREN () { 1 } +sub ASSIGN () { 2 } # has OP= variant +sub LIST_CONTEXT () { 4 } # Assignment is in list context + +my(%left, %right); + +sub assoc_class { + my $op = shift; + my $name = $op->name; + if ($name eq "concat" and $op->first->name eq "concat") { + # avoid spurious `=' -- see comment in pp_concat + return "concat"; + } + if ($name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|x?or)$/ + and null $op->first->sibling) + { + # Like all conditional constructs, OP_ANDs and OP_ORs are topped + # with a null that's used as the common end point of the two + # flows of control. For precedence purposes, ignore it. + # (COND_EXPRs have these too, but we don't bother with + # their associativity). + return assoc_class($op->first); + } + return $name . ($op->flags & OPf_STACKED ? "=" : ""); +} + +# Left associative operators, like `+', for which +# $a + $b + $c is equivalent to ($a + $b) + $c + +BEGIN { + %left = ('multiply' => 19, 'i_multiply' => 19, + 'divide' => 19, 'i_divide' => 19, + 'modulo' => 19, 'i_modulo' => 19, + 'repeat' => 19, + 'add' => 18, 'i_add' => 18, + 'subtract' => 18, 'i_subtract' => 18, + 'concat' => 18, + 'left_shift' => 17, 'right_shift' => 17, + 'bit_and' => 13, + 'bit_or' => 12, 'bit_xor' => 12, + 'and' => 3, + 'or' => 2, 'xor' => 2, + ); +} + +sub deparse_binop_left { + my $self = shift; + my($op, $left, $prec) = @_; + if ($left{assoc_class($op)} && $left{assoc_class($left)} + and $left{assoc_class($op)} == $left{assoc_class($left)}) + { + return $self->deparse($left, $prec - .00001); + } else { + return $self->deparse($left, $prec); + } +} + +# Right associative operators, like `=', for which +# $a = $b = $c is equivalent to $a = ($b = $c) + +BEGIN { + %right = ('pow' => 22, + 'sassign=' => 7, 'aassign=' => 7, + 'multiply=' => 7, 'i_multiply=' => 7, + 'divide=' => 7, 'i_divide=' => 7, + 'modulo=' => 7, 'i_modulo=' => 7, + 'repeat=' => 7, + 'add=' => 7, 'i_add=' => 7, + 'subtract=' => 7, 'i_subtract=' => 7, + 'concat=' => 7, + 'left_shift=' => 7, 'right_shift=' => 7, + 'bit_and=' => 7, + 'bit_or=' => 7, 'bit_xor=' => 7, + 'andassign' => 7, + 'orassign' => 7, + ); +} + +sub deparse_binop_right { + my $self = shift; + my($op, $right, $prec) = @_; + if ($right{assoc_class($op)} && $right{assoc_class($right)} + and $right{assoc_class($op)} == $right{assoc_class($right)}) + { + return $self->deparse($right, $prec - .00001); + } else { + return $self->deparse($right, $prec); + } +} + +sub binop { + my $self = shift; + my ($op, $cx, $opname, $prec, $flags) = (@_, 0); + my $left = $op->first; + my $right = $op->last; + my $eq = ""; + if ($op->flags & OPf_STACKED && $flags & ASSIGN) { + $eq = "="; + $prec = 7; + } + if ($flags & SWAP_CHILDREN) { + ($left, $right) = ($right, $left); + } + $left = $self->deparse_binop_left($op, $left, $prec); + $left = "($left)" if $flags & LIST_CONTEXT + && $left !~ /^(my|our|local|)[\@\(]/; + $right = $self->deparse_binop_right($op, $right, $prec); + return $self->maybe_parens("$left $opname$eq $right", $cx, $prec); +} + +sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } +sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } +sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) } +sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } +sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } +sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) } +sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) } +sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) } +sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) } +sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) } +sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) } + +sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) } +sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) } +sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) } +sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) } +sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) } + +sub pp_eq { binop(@_, "==", 14) } +sub pp_ne { binop(@_, "!=", 14) } +sub pp_lt { binop(@_, "<", 15) } +sub pp_gt { binop(@_, ">", 15) } +sub pp_ge { binop(@_, ">=", 15) } +sub pp_le { binop(@_, "<=", 15) } +sub pp_ncmp { binop(@_, "<=>", 14) } +sub pp_i_eq { binop(@_, "==", 14) } +sub pp_i_ne { binop(@_, "!=", 14) } +sub pp_i_lt { binop(@_, "<", 15) } +sub pp_i_gt { binop(@_, ">", 15) } +sub pp_i_ge { binop(@_, ">=", 15) } +sub pp_i_le { binop(@_, "<=", 15) } +sub pp_i_ncmp { binop(@_, "<=>", 14) } + +sub pp_seq { binop(@_, "eq", 14) } +sub pp_sne { binop(@_, "ne", 14) } +sub pp_slt { binop(@_, "lt", 15) } +sub pp_sgt { binop(@_, "gt", 15) } +sub pp_sge { binop(@_, "ge", 15) } +sub pp_sle { binop(@_, "le", 15) } +sub pp_scmp { binop(@_, "cmp", 14) } + +sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) } +sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) } + +# `.' is special because concats-of-concats are optimized to save copying +# by making all but the first concat stacked. The effect is as if the +# programmer had written `($a . $b) .= $c', except legal. +sub pp_concat { maybe_targmy(@_, \&real_concat) } +sub real_concat { + my $self = shift; + my($op, $cx) = @_; + my $left = $op->first; + my $right = $op->last; + my $eq = ""; + my $prec = 18; + if ($op->flags & OPf_STACKED and $op->first->name ne "concat") { + $eq = "="; + $prec = 7; + } + $left = $self->deparse_binop_left($op, $left, $prec); + $right = $self->deparse_binop_right($op, $right, $prec); + return $self->maybe_parens("$left .$eq $right", $cx, $prec); +} + +# `x' is weird when the left arg is a list +sub pp_repeat { + my $self = shift; + my($op, $cx) = @_; + my $left = $op->first; + my $right = $op->last; + my $eq = ""; + my $prec = 19; + if ($op->flags & OPf_STACKED) { + $eq = "="; + $prec = 7; + } + if (null($right)) { # list repeat; count is inside left-side ex-list + my $kid = $left->first->sibling; # skip pushmark + my @exprs; + for (; !null($kid->sibling); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + $right = $kid; + $left = "(" . join(", ", @exprs). ")"; + } else { + $left = $self->deparse_binop_left($op, $left, $prec); + } + $right = $self->deparse_binop_right($op, $right, $prec); + return $self->maybe_parens("$left x$eq $right", $cx, $prec); +} + +sub range { + my $self = shift; + my ($op, $cx, $type) = @_; + my $left = $op->first; + my $right = $left->sibling; + $left = $self->deparse($left, 9); + $right = $self->deparse($right, 9); + return $self->maybe_parens("$left $type $right", $cx, 9); +} + +sub pp_flop { + my $self = shift; + my($op, $cx) = @_; + my $flip = $op->first; + my $type = ($flip->flags & OPf_SPECIAL) ? "..." : ".."; + return $self->range($flip->first, $cx, $type); +} + +# one-line while/until is handled in pp_leave + +sub logop { + my $self = shift; + my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_; + my $left = $op->first; + my $right = $op->first->sibling; + if ($cx < 1 and is_scope($right) and $blockname + and $self->{'expand'} < 7) + { # if ($a) {$b} + $left = $self->deparse($left, 1); + $right = $self->deparse($right, 0); + return "$blockname ($left) {\n\t$right\n\b}\cK"; + } elsif ($cx < 1 and $blockname and not $self->{'parens'} + and $self->{'expand'} < 7) { # $b if $a + $right = $self->deparse($right, 1); + $left = $self->deparse($left, 1); + return "$right $blockname $left"; + } elsif ($cx > $lowprec and $highop) { # $a && $b + $left = $self->deparse_binop_left($op, $left, $highprec); + $right = $self->deparse_binop_right($op, $right, $highprec); + return $self->maybe_parens("$left $highop $right", $cx, $highprec); + } else { # $a and $b + $left = $self->deparse_binop_left($op, $left, $lowprec); + $right = $self->deparse_binop_right($op, $right, $lowprec); + return $self->maybe_parens("$left $lowop $right", $cx, $lowprec); + } +} + +sub pp_and { logop(@_, "and", 3, "&&", 11, "if") } +sub pp_or { logop(@_, "or", 2, "||", 10, "unless") } +sub pp_dor { logop(@_, "err", 2, "//", 10, "") } + +# xor is syntactically a logop, but it's really a binop (contrary to +# old versions of opcode.pl). Syntax is what matters here. +sub pp_xor { logop(@_, "xor", 2, "", 0, "") } + +sub logassignop { + my $self = shift; + my ($op, $cx, $opname) = @_; + my $left = $op->first; + my $right = $op->first->sibling->first; # skip sassign + $left = $self->deparse($left, 7); + $right = $self->deparse($right, 7); + return $self->maybe_parens("$left $opname $right", $cx, 7); +} + +sub pp_andassign { logassignop(@_, "&&=") } +sub pp_orassign { logassignop(@_, "||=") } +sub pp_dorassign { logassignop(@_, "//=") } + +sub listop { + my $self = shift; + my($op, $cx, $name) = @_; + my(@exprs); + my $parens = ($cx >= 5) || $self->{'parens'}; + my $kid = $op->first->sibling; + return $name if null $kid; + my $first; + $name = "socketpair" if $name eq "sockpair"; + my $proto = prototype("CORE::$name"); + if (defined $proto + && $proto =~ /^;?\*/ + && $kid->name eq "rv2gv") { + $first = $self->deparse($kid->first, 6); + } + else { + $first = $self->deparse($kid, 6); + } + if ($name eq "chmod" && $first =~ /^\d+$/) { + $first = sprintf("%#o", $first); + } + $first = "+$first" if not $parens and substr($first, 0, 1) eq "("; + push @exprs, $first; + $kid = $kid->sibling; + if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") { + push @exprs, $self->deparse($kid->first, 6); + $kid = $kid->sibling; + } + for (; !null($kid); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + if ($parens) { + return "$name(" . join(", ", @exprs) . ")"; + } else { + return "$name " . join(", ", @exprs); + } +} + +sub pp_bless { listop(@_, "bless") } +sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") } +sub pp_substr { maybe_local(@_, listop(@_, "substr")) } +sub pp_vec { maybe_local(@_, listop(@_, "vec")) } +sub pp_index { maybe_targmy(@_, \&listop, "index") } +sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") } +sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") } +sub pp_formline { listop(@_, "formline") } # see also deparse_format +sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") } +sub pp_unpack { listop(@_, "unpack") } +sub pp_pack { listop(@_, "pack") } +sub pp_join { maybe_targmy(@_, \&listop, "join") } +sub pp_splice { listop(@_, "splice") } +sub pp_push { maybe_targmy(@_, \&listop, "push") } +sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") } +sub pp_reverse { listop(@_, "reverse") } +sub pp_warn { listop(@_, "warn") } +sub pp_die { listop(@_, "die") } +# Actually, return is exempt from the LLAFR (see examples in this very +# module!), but for consistency's sake, ignore that fact +sub pp_return { listop(@_, "return") } +sub pp_open { listop(@_, "open") } +sub pp_pipe_op { listop(@_, "pipe") } +sub pp_tie { listop(@_, "tie") } +sub pp_binmode { listop(@_, "binmode") } +sub pp_dbmopen { listop(@_, "dbmopen") } +sub pp_sselect { listop(@_, "select") } +sub pp_select { listop(@_, "select") } +sub pp_read { listop(@_, "read") } +sub pp_sysopen { listop(@_, "sysopen") } +sub pp_sysseek { listop(@_, "sysseek") } +sub pp_sysread { listop(@_, "sysread") } +sub pp_syswrite { listop(@_, "syswrite") } +sub pp_send { listop(@_, "send") } +sub pp_recv { listop(@_, "recv") } +sub pp_seek { listop(@_, "seek") } +sub pp_fcntl { listop(@_, "fcntl") } +sub pp_ioctl { listop(@_, "ioctl") } +sub pp_flock { maybe_targmy(@_, \&listop, "flock") } +sub pp_socket { listop(@_, "socket") } +sub pp_sockpair { listop(@_, "sockpair") } +sub pp_bind { listop(@_, "bind") } +sub pp_connect { listop(@_, "connect") } +sub pp_listen { listop(@_, "listen") } +sub pp_accept { listop(@_, "accept") } +sub pp_shutdown { listop(@_, "shutdown") } +sub pp_gsockopt { listop(@_, "getsockopt") } +sub pp_ssockopt { listop(@_, "setsockopt") } +sub pp_chown { maybe_targmy(@_, \&listop, "chown") } +sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") } +sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") } +sub pp_utime { maybe_targmy(@_, \&listop, "utime") } +sub pp_rename { maybe_targmy(@_, \&listop, "rename") } +sub pp_link { maybe_targmy(@_, \&listop, "link") } +sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") } +sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") } +sub pp_open_dir { listop(@_, "opendir") } +sub pp_seekdir { listop(@_, "seekdir") } +sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") } +sub pp_system { maybe_targmy(@_, \&listop, "system") } +sub pp_exec { maybe_targmy(@_, \&listop, "exec") } +sub pp_kill { maybe_targmy(@_, \&listop, "kill") } +sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") } +sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") } +sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") } +sub pp_shmget { listop(@_, "shmget") } +sub pp_shmctl { listop(@_, "shmctl") } +sub pp_shmread { listop(@_, "shmread") } +sub pp_shmwrite { listop(@_, "shmwrite") } +sub pp_msgget { listop(@_, "msgget") } +sub pp_msgctl { listop(@_, "msgctl") } +sub pp_msgsnd { listop(@_, "msgsnd") } +sub pp_msgrcv { listop(@_, "msgrcv") } +sub pp_semget { listop(@_, "semget") } +sub pp_semctl { listop(@_, "semctl") } +sub pp_semop { listop(@_, "semop") } +sub pp_ghbyaddr { listop(@_, "gethostbyaddr") } +sub pp_gnbyaddr { listop(@_, "getnetbyaddr") } +sub pp_gpbynumber { listop(@_, "getprotobynumber") } +sub pp_gsbyname { listop(@_, "getservbyname") } +sub pp_gsbyport { listop(@_, "getservbyport") } +sub pp_syscall { listop(@_, "syscall") } + +sub pp_glob { + my $self = shift; + my($op, $cx) = @_; + my $text = $self->dq($op->first->sibling); # skip pushmark + if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline + or $text =~ /[<>]/) { + return 'glob(' . single_delim('qq', '"', $text) . ')'; + } else { + return '<' . $text . '>'; + } +} + +# Truncate is special because OPf_SPECIAL makes a bareword first arg +# be a filehandle. This could probably be better fixed in the core +# by moving the GV lookup into ck_truc. + +sub pp_truncate { + my $self = shift; + my($op, $cx) = @_; + my(@exprs); + my $parens = ($cx >= 5) || $self->{'parens'}; + my $kid = $op->first->sibling; + my $fh; + if ($op->flags & OPf_SPECIAL) { + # $kid is an OP_CONST + $fh = $self->const_sv($kid)->PV; + } else { + $fh = $self->deparse($kid, 6); + $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "("; + } + my $len = $self->deparse($kid->sibling, 6); + if ($parens) { + return "truncate($fh, $len)"; + } else { + return "truncate $fh, $len"; + } +} + +sub indirop { + my $self = shift; + my($op, $cx, $name) = @_; + my($expr, @exprs); + my $kid = $op->first->sibling; + my $indir = ""; + if ($op->flags & OPf_STACKED) { + $indir = $kid; + $indir = $indir->first; # skip rv2gv + if (is_scope($indir)) { + $indir = "{" . $self->deparse($indir, 0) . "}"; + $indir = "{;}" if $indir eq "{}"; + } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) { + $indir = $self->const_sv($indir)->PV; + } else { + $indir = $self->deparse($indir, 24); + } + $indir = $indir . " "; + $kid = $kid->sibling; + } + if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) { + $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} ' + : '{$a <=> $b} '; + } + elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) { + $indir = '{$b cmp $a} '; + } + for (; !null($kid); $kid = $kid->sibling) { + $expr = $self->deparse($kid, 6); + push @exprs, $expr; + } + my $name2 = $name; + if ($name eq "sort" && $op->private & OPpSORT_REVERSE) { + $name2 = 'reverse sort'; + } + if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) { + return "$exprs[0] = $name2 $indir $exprs[0]"; + } + + my $args = $indir . join(", ", @exprs); + if ($indir ne "" and $name eq "sort") { + # We don't want to say "sort(f 1, 2, 3)", since perl -w will + # give bareword warnings in that case. Therefore if context + # requires, we'll put parens around the outside "(sort f 1, 2, + # 3)". Unfortunately, we'll currently think the parens are + # necessary more often that they really are, because we don't + # distinguish which side of an assignment we're on. + if ($cx >= 5) { + return "($name2 $args)"; + } else { + return "$name2 $args"; + } + } else { + return $self->maybe_parens_func($name2, $args, $cx, 5); + } + +} + +sub pp_prtf { indirop(@_, "printf") } +sub pp_print { indirop(@_, "print") } +sub pp_sort { indirop(@_, "sort") } + +sub mapop { + my $self = shift; + my($op, $cx, $name) = @_; + my($expr, @exprs); + my $kid = $op->first; # this is the (map|grep)start + $kid = $kid->first->sibling; # skip a pushmark + my $code = $kid->first; # skip a null + if (is_scope $code) { + $code = "{" . $self->deparse($code, 0) . "} "; + } else { + $code = $self->deparse($code, 24) . ", "; + } + $kid = $kid->sibling; + for (; !null($kid); $kid = $kid->sibling) { + $expr = $self->deparse($kid, 6); + push @exprs, $expr if defined $expr; + } + return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5); +} + +sub pp_mapwhile { mapop(@_, "map") } +sub pp_grepwhile { mapop(@_, "grep") } +sub pp_mapstart { baseop(@_, "map") } +sub pp_grepstart { baseop(@_, "grep") } + +sub pp_list { + my $self = shift; + my($op, $cx) = @_; + my($expr, @exprs); + my $kid = $op->first->sibling; # skip pushmark + my $lop; + my $local = "either"; # could be local(...), my(...) or our(...) + for ($lop = $kid; !null($lop); $lop = $lop->sibling) { + # This assumes that no other private flags equal 128, and that + # OPs that store things other than flags in their op_private, + # like OP_AELEMFAST, won't be immediate children of a list. + # + # OP_ENTERSUB can break this logic, so check for it. + # I suspect that open and exit can too. + + if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO) + or $lop->name eq "undef") + or $lop->name eq "entersub" + or $lop->name eq "exit" + or $lop->name eq "open") + { + $local = ""; # or not + last; + } + if ($lop->name =~ /^pad[ash]v$/) { # my() + ($local = "", last) if $local eq "local" || $local eq "our"; + $local = "my"; + } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/ + && $lop->private & OPpOUR_INTRO + or $lop->name eq "null" && $lop->first->name eq "gvsv" + && $lop->first->private & OPpOUR_INTRO) { # our() + ($local = "", last) if $local eq "my" || $local eq "local"; + $local = "our"; + } elsif ($lop->name ne "undef" + # specifically avoid the "reverse sort" optimisation, + # where "reverse" is nullified + && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE))) + { + # local() + ($local = "", last) if $local eq "my" || $local eq "our"; + $local = "local"; + } + } + $local = "" if $local eq "either"; # no point if it's all undefs + return $self->deparse($kid, $cx) if null $kid->sibling and not $local; + for (; !null($kid); $kid = $kid->sibling) { + if ($local) { + if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") { + $lop = $kid->first; + } else { + $lop = $kid; + } + $self->{'avoid_local'}{$$lop}++; + $expr = $self->deparse($kid, 6); + delete $self->{'avoid_local'}{$$lop}; + } else { + $expr = $self->deparse($kid, 6); + } + push @exprs, $expr; + } + if ($local) { + return "$local(" . join(", ", @exprs) . ")"; + } else { + return $self->maybe_parens( join(", ", @exprs), $cx, 6); + } +} + +sub is_ifelse_cont { + my $op = shift; + return ($op->name eq "null" and class($op) eq "UNOP" + and $op->first->name =~ /^(and|cond_expr)$/ + and is_scope($op->first->first->sibling)); +} + +sub pp_cond_expr { + my $self = shift; + my($op, $cx) = @_; + my $cond = $op->first; + my $true = $cond->sibling; + my $false = $true->sibling; + my $cuddle = $self->{'cuddle'}; + unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and + (is_scope($false) || is_ifelse_cont($false)) + and $self->{'expand'} < 7) { + $cond = $self->deparse($cond, 8); + $true = $self->deparse($true, 8); + $false = $self->deparse($false, 8); + return $self->maybe_parens("$cond ? $true : $false", $cx, 8); + } + + $cond = $self->deparse($cond, 1); + $true = $self->deparse($true, 0); + my $head = "if ($cond) {\n\t$true\n\b}"; + my @elsifs; + while (!null($false) and is_ifelse_cont($false)) { + my $newop = $false->first; + my $newcond = $newop->first; + my $newtrue = $newcond->sibling; + $false = $newtrue->sibling; # last in chain is OP_AND => no else + $newcond = $self->deparse($newcond, 1); + $newtrue = $self->deparse($newtrue, 0); + push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}"; + } + if (!null($false)) { + $false = $cuddle . "else {\n\t" . + $self->deparse($false, 0) . "\n\b}\cK"; + } else { + $false = "\cK"; + } + return $head . join($cuddle, "", @elsifs) . $false; +} + +sub loop_common { + my $self = shift; + my($op, $cx, $init) = @_; + my $enter = $op->first; + my $kid = $enter->sibling; + local(@$self{qw'curstash warnings hints'}) + = @$self{qw'curstash warnings hints'}; + my $head = ""; + my $bare = 0; + my $body; + my $cond = undef; + if ($kid->name eq "lineseq") { # bare or infinite loop + if ($kid->last->name eq "unstack") { # infinite + $head = "while (1) "; # Can't use for(;;) if there's a continue + $cond = ""; + } else { + $bare = 1; + } + $body = $kid; + } elsif ($enter->name eq "enteriter") { # foreach + my $ary = $enter->first->sibling; # first was pushmark + my $var = $ary->sibling; + if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) { + # "reverse" was optimised away + $ary = listop($self, $ary->first->sibling, 1, 'reverse'); + } elsif ($enter->flags & OPf_STACKED + and not null $ary->first->sibling->sibling) + { + $ary = $self->deparse($ary->first->sibling, 9) . " .. " . + $self->deparse($ary->first->sibling->sibling, 9); + } else { + $ary = $self->deparse($ary, 1); + } + if (null $var) { + if ($enter->flags & OPf_SPECIAL) { # thread special var + $var = $self->pp_threadsv($enter, 1); + } else { # regular my() variable + $var = $self->pp_padsv($enter, 1); + } + } elsif ($var->name eq "rv2gv") { + $var = $self->pp_rv2sv($var, 1); + if ($enter->private & OPpOUR_INTRO) { + # our declarations don't have package names + $var =~ s/^(.).*::/$1/; + $var = "our $var"; + } + } elsif ($var->name eq "gv") { + $var = "\$" . $self->deparse($var, 1); + } + $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER + if (!is_state $body->first and $body->first->name ne "stub") { + confess unless $var eq '$_'; + $body = $body->first; + return $self->deparse($body, 2) . " foreach ($ary)"; + } + $head = "foreach $var ($ary) "; + } elsif ($kid->name eq "null") { # while/until + $kid = $kid->first; + my $name = {"and" => "while", "or" => "until"}->{$kid->name}; + $cond = $self->deparse($kid->first, 1); + $head = "$name ($cond) "; + $body = $kid->first->sibling; + } elsif ($kid->name eq "stub") { # bare and empty + return "{;}"; # {} could be a hashref + } + # If there isn't a continue block, then the next pointer for the loop + # will point to the unstack, which is kid's last child, except + # in a bare loop, when it will point to the leaveloop. When neither of + # these conditions hold, then the second-to-last child is the continue + # block (or the last in a bare loop). + my $cont_start = $enter->nextop; + my $cont; + if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) { + if ($bare) { + $cont = $body->last; + } else { + $cont = $body->first; + while (!null($cont->sibling->sibling)) { + $cont = $cont->sibling; + } + } + my $state = $body->first; + my $cuddle = $self->{'cuddle'}; + my @states; + for (; $$state != $$cont; $state = $state->sibling) { + push @states, $state; + } + $body = $self->lineseq(undef, @states); + if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) { + $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") "; + $cont = "\cK"; + } else { + $cont = $cuddle . "continue {\n\t" . + $self->deparse($cont, 0) . "\n\b}\cK"; + } + } else { + return "" if !defined $body; + if (length $init) { + $head = "for ($init; $cond;) "; + } + $cont = "\cK"; + $body = $self->deparse($body, 0); + } + $body =~ s/;?$/;\n/; + + return $head . "{\n\t" . $body . "\b}" . $cont; +} + +sub pp_leaveloop { loop_common(@_, "") } + +sub for_loop { + my $self = shift; + my($op, $cx) = @_; + my $init = $self->deparse($op, 1); + return $self->loop_common($op->sibling->first->sibling, $cx, $init); +} + +sub pp_leavetry { + my $self = shift; + return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}"; +} + +BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" } +BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" } +BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" } +BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" } + +sub pp_null { + my $self = shift; + my($op, $cx) = @_; + if (class($op) eq "OP") { + # old value is lost + return $self->{'ex_const'} if $op->targ == OP_CONST; + } elsif ($op->first->name eq "pushmark") { + return $self->pp_list($op, $cx); + } elsif ($op->first->name eq "enter") { + return $self->pp_leave($op, $cx); + } elsif ($op->targ == OP_STRINGIFY) { + return $self->dquote($op, $cx); + } elsif (!null($op->first->sibling) and + $op->first->sibling->name eq "readline" and + $op->first->sibling->flags & OPf_STACKED) { + return $self->maybe_parens($self->deparse($op->first, 7) . " = " + . $self->deparse($op->first->sibling, 7), + $cx, 7); + } elsif (!null($op->first->sibling) and + $op->first->sibling->name eq "trans" and + $op->first->sibling->flags & OPf_STACKED) { + return $self->maybe_parens($self->deparse($op->first, 20) . " =~ " + . $self->deparse($op->first->sibling, 20), + $cx, 20); + } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) { + return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};"; + } elsif (!null($op->first->sibling) and + $op->first->sibling->name eq "null" and + class($op->first->sibling) eq "UNOP" and + $op->first->sibling->first->flags & OPf_STACKED and + $op->first->sibling->first->name eq "rcatline") { + return $self->maybe_parens($self->deparse($op->first, 18) . " .= " + . $self->deparse($op->first->sibling, 18), + $cx, 18); + } else { + return $self->deparse($op->first, $cx); + } +} + +sub padname { + my $self = shift; + my $targ = shift; + return $self->padname_sv($targ)->PVX; +} + +sub padany { + my $self = shift; + my $op = shift; + return substr($self->padname($op->targ), 1); # skip $/@/% +} + +sub pp_padsv { + my $self = shift; + my($op, $cx) = @_; + return $self->maybe_my($op, $cx, $self->padname($op->targ)); +} + +sub pp_padav { pp_padsv(@_) } +sub pp_padhv { pp_padsv(@_) } + +my @threadsv_names; + +BEGIN { + @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9", + "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";", + "^", "-", "%", "=", "|", "~", ":", "^A", "^E", + "!", "@"); +} + +sub pp_threadsv { + my $self = shift; + my($op, $cx) = @_; + return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); +} + +sub gv_or_padgv { + my $self = shift; + my $op = shift; + if (class($op) eq "PADOP") { + return $self->padval($op->padix); + } else { # class($op) eq "SVOP" + return $op->gv; + } +} + +sub pp_gvsv { + my $self = shift; + my($op, $cx) = @_; + my $gv = $self->gv_or_padgv($op); + return $self->maybe_local($op, $cx, $self->stash_variable("\$", + $self->gv_name($gv))); +} + +sub pp_gv { + my $self = shift; + my($op, $cx) = @_; + my $gv = $self->gv_or_padgv($op); + return $self->gv_name($gv); +} + +sub pp_aelemfast { + my $self = shift; + my($op, $cx) = @_; + my $name; + if ($op->flags & OPf_SPECIAL) { # optimised PADAV + $name = $self->padname($op->targ); + $name =~ s/^@/\$/; + } + else { + my $gv = $self->gv_or_padgv($op); + $name = $self->gv_name($gv); + $name = $self->{'curstash'}."::$name" + if $name !~ /::/ && $self->lex_in_scope('@'.$name); + $name = '$' . $name; + } + + return $name . "[" . ($op->private + $self->{'arybase'}) . "]"; +} + +sub rv2x { + my $self = shift; + my($op, $cx, $type) = @_; + + if (class($op) eq 'NULL' || !$op->can("first")) { + carp("Unexpected op in pp_rv2x"); + return 'XXX'; + } + my $kid = $op->first; + if ($kid->name eq "gv") { + return $self->stash_variable($type, $self->deparse($kid, 0)); + } elsif (is_scalar $kid) { + my $str = $self->deparse($kid, 0); + if ($str =~ /^\$([^\w\d])\z/) { + # "$$+" isn't a legal way to write the scalar dereference + # of $+, since the lexer can't tell you aren't trying to + # do something like "$$ + 1" to get one more than your + # PID. Either "${$+}" or "$${+}" are workable + # disambiguations, but if the programmer did the former, + # they'd be in the "else" clause below rather than here. + # It's not clear if this should somehow be unified with + # the code in dq and re_dq that also adds lexer + # disambiguation braces. + $str = '$' . "{$1}"; #' + } + return $type . $str; + } else { + return $type . "{" . $self->deparse($kid, 0) . "}"; + } +} + +sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) } +sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) } +sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) } + +# skip rv2av +sub pp_av2arylen { + my $self = shift; + my($op, $cx) = @_; + if ($op->first->name eq "padav") { + return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first)); + } else { + return $self->maybe_local($op, $cx, + $self->rv2x($op->first, $cx, '$#')); + } +} + +# skip down to the old, ex-rv2cv +sub pp_rv2cv { + my ($self, $op, $cx) = @_; + if (!null($op->first) && $op->first->name eq 'null' && + $op->first->targ eq OP_LIST) + { + return $self->rv2x($op->first->first->sibling, $cx, "&") + } + else { + return $self->rv2x($op, $cx, "") + } +} + +sub list_const { + my $self = shift; + my($cx, @list) = @_; + my @a = map $self->const($_, 6), @list; + if (@a == 0) { + return "()"; + } elsif (@a == 1) { + return $a[0]; + } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) { + # collapse (-1,0,1,2) into (-1..2) + my ($s, $e) = @a[0,-1]; + my $i = $s; + return $self->maybe_parens("$s..$e", $cx, 9) + unless grep $i++ != $_, @a; + } + return $self->maybe_parens(join(", ", @a), $cx, 6); +} + +sub pp_rv2av { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + if ($kid->name eq "const") { # constant list + my $av = $self->const_sv($kid); + return $self->list_const($cx, $av->ARRAY); + } else { + return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@")); + } + } + +sub is_subscriptable { + my $op = shift; + if ($op->name =~ /^[ahg]elem/) { + return 1; + } elsif ($op->name eq "entersub") { + my $kid = $op->first; + return 0 unless null $kid->sibling; + $kid = $kid->first; + $kid = $kid->sibling until null $kid->sibling; + return 0 if is_scope($kid); + $kid = $kid->first; + return 0 if $kid->name eq "gv"; + return 0 if is_scalar($kid); + return is_subscriptable($kid); + } else { + return 0; + } +} + +sub elem { + my $self = shift; + my ($op, $cx, $left, $right, $padname) = @_; + my($array, $idx) = ($op->first, $op->first->sibling); + unless ($array->name eq $padname) { # Maybe this has been fixed + $array = $array->first; # skip rv2av (or ex-rv2av in _53+) + } + if ($array->name eq $padname) { + $array = $self->padany($array); + } elsif (is_scope($array)) { # ${expr}[0] + $array = "{" . $self->deparse($array, 0) . "}"; + } elsif ($array->name eq "gv") { + $array = $self->gv_name($self->gv_or_padgv($array)); + if ($array !~ /::/) { + my $prefix = ($left eq '[' ? '@' : '%'); + $array = $self->{curstash}.'::'.$array + if $self->lex_in_scope($prefix . $array); + } + } elsif (is_scalar $array) { # $x[0], $$x[0], ... + $array = $self->deparse($array, 24); + } else { + # $x[20][3]{hi} or expr->[20] + my $arrow = is_subscriptable($array) ? "" : "->"; + return $self->deparse($array, 24) . $arrow . + $left . $self->deparse($idx, 1) . $right; + } + $idx = $self->deparse($idx, 1); + + # Outer parens in an array index will confuse perl + # if we're interpolating in a regular expression, i.e. + # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/ + # + # If $self->{parens}, then an initial '(' will + # definitely be paired with a final ')'. If + # !$self->{parens}, the misleading parens won't + # have been added in the first place. + # + # [You might think that we could get "(...)...(...)" + # where the initial and final parens do not match + # each other. But we can't, because the above would + # only happen if there's an infix binop between the + # two pairs of parens, and *that* means that the whole + # expression would be parenthesized as well.] + # + $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'}; + + # Hash-element braces will autoquote a bareword inside themselves. + # We need to make sure that C<$hash{warn()}> doesn't come out as + # C<$hash{warn}>, which has a quite different meaning. Currently + # B::Deparse will always quote strings, even if the string was a + # bareword in the original (i.e. the OPpCONST_BARE flag is ignored + # for constant strings.) So we can cheat slightly here - if we see + # a bareword, we know that it is supposed to be a function call. + # + $idx =~ s/^([A-Za-z_]\w*)$/$1()/; + + return "\$" . $array . $left . $idx . $right; +} + +sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) } +sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) } + +sub pp_gelem { + my $self = shift; + my($op, $cx) = @_; + my($glob, $part) = ($op->first, $op->last); + $glob = $glob->first; # skip rv2gv + $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug + my $scope = is_scope($glob); + $glob = $self->deparse($glob, 0); + $part = $self->deparse($part, 1); + return "*" . ($scope ? "{$glob}" : $glob) . "{$part}"; +} + +sub slice { + my $self = shift; + my ($op, $cx, $left, $right, $regname, $padname) = @_; + my $last; + my(@elems, $kid, $array, $list); + if (class($op) eq "LISTOP") { + $last = $op->last; + } else { # ex-hslice inside delete() + for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {} + $last = $kid; + } + $array = $last; + $array = $array->first + if $array->name eq $regname or $array->name eq "null"; + if (is_scope($array)) { + $array = "{" . $self->deparse($array, 0) . "}"; + } elsif ($array->name eq $padname) { + $array = $self->padany($array); + } else { + $array = $self->deparse($array, 24); + } + $kid = $op->first->sibling; # skip pushmark + if ($kid->name eq "list") { + $kid = $kid->first->sibling; # skip list, pushmark + for (; !null $kid; $kid = $kid->sibling) { + push @elems, $self->deparse($kid, 6); + } + $list = join(", ", @elems); + } else { + $list = $self->deparse($kid, 1); + } + return "\@" . $array . $left . $list . $right; +} + +sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) } +sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) } + +sub pp_lslice { + my $self = shift; + my($op, $cx) = @_; + my $idx = $op->first; + my $list = $op->last; + my(@elems, $kid); + $list = $self->deparse($list, 1); + $idx = $self->deparse($idx, 1); + return "($list)" . "[$idx]"; +} + +sub want_scalar { + my $op = shift; + return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR; +} + +sub want_list { + my $op = shift; + return ($op->flags & OPf_WANT) == OPf_WANT_LIST; +} + +sub method { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first->sibling; # skip pushmark + my($meth, $obj, @exprs); + if ($kid->name eq "list" and want_list $kid) { + # When an indirect object isn't a bareword but the args are in + # parens, the parens aren't part of the method syntax (the LLAFR + # doesn't apply), but they make a list with OPf_PARENS set that + # doesn't get flattened by the append_elem that adds the method, + # making a (object, arg1, arg2, ...) list where the object + # usually is. This can be distinguished from + # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an + # object) because in the later the list is in scalar context + # as the left side of -> always is, while in the former + # the list is in list context as method arguments always are. + # (Good thing there aren't method prototypes!) + $meth = $kid->sibling; + $kid = $kid->first->sibling; # skip pushmark + $obj = $kid; + $kid = $kid->sibling; + for (; not null $kid; $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + } else { + $obj = $kid; + $kid = $kid->sibling; + for (; !null ($kid->sibling) && $kid->name ne "method_named"; + $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + $meth = $kid; + } + $obj = $self->deparse($obj, 24); + if ($meth->name eq "method_named") { + $meth = $self->const_sv($meth)->PV; + } else { + $meth = $meth->first; + if ($meth->name eq "const") { + # As of 5.005_58, this case is probably obsoleted by the + # method_named case above + $meth = $self->const_sv($meth)->PV; # needs to be bare + } else { + $meth = $self->deparse($meth, 1); + } + } + my $args = join(", ", @exprs); + $kid = $obj . "->" . $meth; + if (length $args) { + return $kid . "(" . $args . ")"; # parens mandatory + } else { + return $kid; + } +} + +# returns "&" if the prototype doesn't match the args, +# or ("", $args_after_prototype_demunging) if it does. +sub check_proto { + my $self = shift; + return "&" if $self->{'noproto'}; + my($proto, @args) = @_; + my($arg, $real); + my $doneok = 0; + my @reals; + # An unbackslashed @ or % gobbles up the rest of the args + 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/; + while ($proto) { + $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//; + my $chr = $1; + if ($chr eq "") { + return "&" if @args; + } elsif ($chr eq ";") { + $doneok = 1; + } elsif ($chr eq "@" or $chr eq "%") { + push @reals, map($self->deparse($_, 6), @args); + @args = (); + } else { + $arg = shift @args; + last unless $arg; + if ($chr eq "\$") { + if (want_scalar $arg) { + push @reals, $self->deparse($arg, 6); + } else { + return "&"; + } + } elsif ($chr eq "&") { + if ($arg->name =~ /^(s?refgen|undef)$/) { + push @reals, $self->deparse($arg, 6); + } else { + return "&"; + } + } elsif ($chr eq "*") { + if ($arg->name =~ /^s?refgen$/ + and $arg->first->first->name eq "rv2gv") + { + $real = $arg->first->first; # skip refgen, null + if ($real->first->name eq "gv") { + push @reals, $self->deparse($real, 6); + } else { + push @reals, $self->deparse($real->first, 6); + } + } else { + return "&"; + } + } elsif (substr($chr, 0, 1) eq "\\") { + $chr =~ tr/\\[]//d; + if ($arg->name =~ /^s?refgen$/ and + !null($real = $arg->first) and + ($chr =~ /\$/ && is_scalar($real->first) + or ($chr =~ /@/ + && class($real->first->sibling) ne 'NULL' + && $real->first->sibling->name + =~ /^(rv2|pad)av$/) + or ($chr =~ /%/ + && class($real->first->sibling) ne 'NULL' + && $real->first->sibling->name + =~ /^(rv2|pad)hv$/) + #or ($chr =~ /&/ # This doesn't work + # && $real->first->name eq "rv2cv") + or ($chr =~ /\*/ + && $real->first->name eq "rv2gv"))) + { + push @reals, $self->deparse($real, 6); + } else { + return "&"; + } + } + } + } + return "&" if $proto and !$doneok; # too few args and no `;' + return "&" if @args; # too many args + return ("", join ", ", @reals); +} + +sub pp_entersub { + my $self = shift; + my($op, $cx) = @_; + return $self->method($op, $cx) unless null $op->first->sibling; + my $prefix = ""; + my $amper = ""; + my($kid, @exprs); + if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) { + $prefix = "do "; + } elsif ($op->private & OPpENTERSUB_AMPER) { + $amper = "&"; + } + $kid = $op->first; + $kid = $kid->first->sibling; # skip ex-list, pushmark + for (; not null $kid->sibling; $kid = $kid->sibling) { + push @exprs, $kid; + } + my $simple = 0; + my $proto = undef; + if (is_scope($kid)) { + $amper = "&"; + $kid = "{" . $self->deparse($kid, 0) . "}"; + } elsif ($kid->first->name eq "gv") { + my $gv = $self->gv_or_padgv($kid->first); + if (class($gv->CV) ne "SPECIAL") { + $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; + } + $simple = 1; # only calls of named functions can be prototyped + $kid = $self->deparse($kid, 24); + } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') { + $amper = "&"; + $kid = $self->deparse($kid, 24); + } else { + $prefix = ""; + my $arrow = is_subscriptable($kid->first) ? "" : "->"; + $kid = $self->deparse($kid, 24) . $arrow; + } + + # Doesn't matter how many prototypes there are, if + # they haven't happened yet! + my $declared; + { + no strict 'refs'; + no warnings 'uninitialized'; + $declared = exists $self->{'subs_declared'}{$kid} + || ( + defined &{ ${$self->{'curstash'}."::"}{$kid} } + && !exists + $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid} + && defined prototype $self->{'curstash'}."::".$kid + ); + if (!$declared && defined($proto)) { + # Avoid "too early to check prototype" warning + ($amper, $proto) = ('&'); + } + } + + my $args; + if ($declared and defined $proto and not $amper) { + ($amper, $args) = $self->check_proto($proto, @exprs); + if ($amper eq "&") { + $args = join(", ", map($self->deparse($_, 6), @exprs)); + } + } else { + $args = join(", ", map($self->deparse($_, 6), @exprs)); + } + if ($prefix or $amper) { + if ($op->flags & OPf_STACKED) { + return $prefix . $amper . $kid . "(" . $args . ")"; + } else { + return $prefix . $amper. $kid; + } + } else { + # glob() invocations can be translated into calls of + # CORE::GLOBAL::glob with a second parameter, a number. + # Reverse this. + if ($kid eq "CORE::GLOBAL::glob") { + $kid = "glob"; + $args =~ s/\s*,[^,]+$//; + } + + # It's a syntax error to call CORE::GLOBAL::foo without a prefix, + # so it must have been translated from a keyword call. Translate + # it back. + $kid =~ s/^CORE::GLOBAL:://; + + my $dproto = defined($proto) ? $proto : "undefined"; + if (!$declared) { + return "$kid(" . $args . ")"; + } elsif ($dproto eq "") { + return $kid; + } elsif ($dproto eq "\$" and is_scalar($exprs[0])) { + # is_scalar is an excessively conservative test here: + # really, we should be comparing to the precedence of the + # top operator of $exprs[0] (ala unop()), but that would + # take some major code restructuring to do right. + return $self->maybe_parens_func($kid, $args, $cx, 16); + } elsif ($dproto ne '$' and defined($proto) || $simple) { #' + return $self->maybe_parens_func($kid, $args, $cx, 5); + } else { + return "$kid(" . $args . ")"; + } + } +} + +sub pp_enterwrite { unop(@_, "write") } + +# escape things that cause interpolation in double quotes, +# but not character escapes +sub uninterp { + my($str) = @_; + $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g; + return $str; +} + +{ +my $bal; +BEGIN { + use re "eval"; + # Matches any string which is balanced with respect to {braces} + $bal = qr( + (?: + [^\\{}] + | \\\\ + | \\[{}] + | \{(??{$bal})\} + )* + )x; +} + +# the same, but treat $|, $), $( and $ at the end of the string differently +sub re_uninterp { + my($str) = @_; + + $str =~ s/ + ( ^|\G # $1 + | [^\\] + ) + + ( # $2 + (?:\\\\)* + ) + + ( # $3 + (\(\?\??\{$bal\}\)) # $4 + | [\$\@] + (?!\||\)|\(|$) + | \\[uUlLQE] + ) + + /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; + + return $str; +} + +# This is for regular expressions with the /x modifier +# We have to leave comments unmangled. +sub re_uninterp_extended { + my($str) = @_; + + $str =~ s/ + ( ^|\G # $1 + | [^\\] + ) + + ( # $2 + (?:\\\\)* + ) + + ( # $3 + ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks) + | \#[^\n]* # (skip over comments) + ) + | [\$\@] + (?!\||\)|\(|$|\s) + | \\[uUlLQE] + ) + + /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg; + + return $str; +} +} + +my %unctrl = # portable to to EBCDIC + ( + "\c@" => '\c@', # unused + "\cA" => '\cA', + "\cB" => '\cB', + "\cC" => '\cC', + "\cD" => '\cD', + "\cE" => '\cE', + "\cF" => '\cF', + "\cG" => '\cG', + "\cH" => '\cH', + "\cI" => '\cI', + "\cJ" => '\cJ', + "\cK" => '\cK', + "\cL" => '\cL', + "\cM" => '\cM', + "\cN" => '\cN', + "\cO" => '\cO', + "\cP" => '\cP', + "\cQ" => '\cQ', + "\cR" => '\cR', + "\cS" => '\cS', + "\cT" => '\cT', + "\cU" => '\cU', + "\cV" => '\cV', + "\cW" => '\cW', + "\cX" => '\cX', + "\cY" => '\cY', + "\cZ" => '\cZ', + "\c[" => '\c[', # unused + "\c\\" => '\c\\', # unused + "\c]" => '\c]', # unused + "\c_" => '\c_', # unused + ); + +# character escapes, but not delimiters that might need to be escaped +sub escape_str { # ASCII, UTF8 + my($str) = @_; + $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; + $str =~ s/\a/\\a/g; +# $str =~ s/\cH/\\b/g; # \b means something different in a regex + $str =~ s/\t/\\t/g; + $str =~ s/\n/\\n/g; + $str =~ s/\e/\\e/g; + $str =~ s/\f/\\f/g; + $str =~ s/\r/\\r/g; + $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge; + $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge; + return $str; +} + +# For regexes with the /x modifier. +# Leave whitespace unmangled. +sub escape_extended_re { + my($str) = @_; + $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg; + $str =~ s/([[:^print:]])/ + ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge; + $str =~ s/\n/\n\f/g; + return $str; +} + +# Don't do this for regexen +sub unback { + my($str) = @_; + $str =~ s/\\/\\\\/g; + return $str; +} + +# Remove backslashes which precede literal control characters, +# to avoid creating ambiguity when we escape the latter. +sub re_unback { + my($str) = @_; + + # the insane complexity here is due to the behaviour of "\c\" + $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g; + return $str; +} + +sub balanced_delim { + my($str) = @_; + my @str = split //, $str; + my($ar, $open, $close, $fail, $c, $cnt); + for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) { + ($open, $close) = @$ar; + $fail = 0; $cnt = 0; + for $c (@str) { + if ($c eq $open) { + $cnt++; + } elsif ($c eq $close) { + $cnt--; + if ($cnt < 0) { + # qq()() isn't ")(" + $fail = 1; + last; + } + } + } + $fail = 1 if $cnt != 0; + return ($open, "$open$str$close") if not $fail; + } + return ("", $str); +} + +sub single_delim { + my($q, $default, $str) = @_; + return "$default$str$default" if $default and index($str, $default) == -1; + if ($q ne 'qr') { + (my $succeed, $str) = balanced_delim($str); + return "$q$str" if $succeed; + } + for my $delim ('/', '"', '#') { + return "$q$delim" . $str . $delim if index($str, $delim) == -1; + } + if ($default) { + $str =~ s/$default/\\$default/g; + return "$default$str$default"; + } else { + $str =~ s[/][\\/]g; + return "$q/$str/"; + } +} + +my $max_prec; +BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); } + +# Split a floating point number into an integer mantissa and a binary +# exponent. Assumes you've already made sure the number isn't zero or +# some weird infinity or NaN. +sub split_float { + my($f) = @_; + my $exponent = 0; + if ($f == int($f)) { + while ($f % 2 == 0) { + $f /= 2; + $exponent++; + } + } else { + while ($f != int($f)) { + $f *= 2; + $exponent--; + } + } + my $mantissa = sprintf("%.0f", $f); + return ($mantissa, $exponent); +} + +sub const { + my $self = shift; + my($sv, $cx) = @_; + if ($self->{'use_dumper'}) { + return $self->const_dumper($sv, $cx); + } + if (class($sv) eq "SPECIAL") { + # sv_undef, sv_yes, sv_no + return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1]; + } elsif (class($sv) eq "NULL") { + return 'undef'; + } + # convert a version object into the "v1.2.3" string in its V magic + if ($sv->FLAGS & SVs_RMG) { + for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) { + return $mg->PTR if $mg->TYPE eq 'V'; + } + } + + if ($sv->FLAGS & SVf_IOK) { + my $str = $sv->int_value; + $str = $self->maybe_parens($str, $cx, 21) if $str < 0; + return $str; + } elsif ($sv->FLAGS & SVf_NOK) { + my $nv = $sv->NV; + if ($nv == 0) { + if (pack("F", $nv) eq pack("F", 0)) { + # positive zero + return "0"; + } else { + # negative zero + return $self->maybe_parens("-.0", $cx, 21); + } + } elsif (1/$nv == 0) { + if ($nv > 0) { + # positive infinity + return $self->maybe_parens("9**9**9", $cx, 22); + } else { + # negative infinity + return $self->maybe_parens("-9**9**9", $cx, 21); + } + } elsif ($nv != $nv) { + # NaN + if (pack("F", $nv) eq pack("F", sin(9**9**9))) { + # the normal kind + return "sin(9**9**9)"; + } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) { + # the inverted kind + return $self->maybe_parens("-sin(9**9**9)", $cx, 21); + } else { + # some other kind + my $hex = unpack("h*", pack("F", $nv)); + return qq'unpack("F", pack("h*", "$hex"))'; + } + } + # first, try the default stringification + my $str = "$nv"; + if ($str != $nv) { + # failing that, try using more precision + $str = sprintf("%.${max_prec}g", $nv); +# if (pack("F", $str) ne pack("F", $nv)) { + if ($str != $nv) { + # not representable in decimal with whatever sprintf() + # and atof() Perl is using here. + my($mant, $exp) = split_float($nv); + return $self->maybe_parens("$mant * 2**$exp", $cx, 19); + } + } + $str = $self->maybe_parens($str, $cx, 21) if $nv < 0; + return $str; + } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) { + my $ref = $sv->RV; + if (class($ref) eq "AV") { + return "[" . $self->list_const(2, $ref->ARRAY) . "]"; + } elsif (class($ref) eq "HV") { + my %hash = $ref->ARRAY; + my @elts; + for my $k (sort keys %hash) { + push @elts, "$k => " . $self->const($hash{$k}, 6); + } + return "{" . join(", ", @elts) . "}"; + } elsif (class($ref) eq "CV") { + return "sub " . $self->deparse_sub($ref); + } + if ($ref->FLAGS & SVs_SMG) { + for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) { + if ($mg->TYPE eq 'r') { + my $re = re_uninterp(escape_str(re_unback($mg->precomp))); + return single_delim("qr", "", $re); + } + } + } + + return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20); + } elsif ($sv->FLAGS & SVf_POK) { + my $str = $sv->PV; + if ($str =~ /[^ -~]/) { # ASCII for non-printing + return single_delim("qq", '"', uninterp escape_str unback $str); + } else { + return single_delim("q", "'", unback $str); + } + } else { + return "undef"; + } +} + +sub const_dumper { + my $self = shift; + my($sv, $cx) = @_; + my $ref = $sv->object_2svref(); + my $dumper = Data::Dumper->new([$$ref], ['$v']); + $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1); + my $str = $dumper->Dump(); + if ($str =~ /^\$v/) { + return '${my ' . $str . ' \$v}'; + } else { + return $str; + } +} + +sub const_sv { + my $self = shift; + my $op = shift; + my $sv = $op->sv; + # the constant could be in the pad (under useithreads) + $sv = $self->padval($op->targ) unless $$sv; + return $sv; +} + +sub pp_const { + my $self = shift; + my($op, $cx) = @_; + if ($op->private & OPpCONST_ARYBASE) { + return '$['; + } +# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting +# return $self->const_sv($op)->PV; +# } + my $sv = $self->const_sv($op); + return $self->const($sv, $cx); +} + +sub dq { + my $self = shift; + my $op = shift; + my $type = $op->name; + if ($type eq "const") { + return '$[' if $op->private & OPpCONST_ARYBASE; + return uninterp(escape_str(unback($self->const_sv($op)->as_string))); + } elsif ($type eq "concat") { + my $first = $self->dq($op->first); + my $last = $self->dq($op->last); + + # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar" + ($last =~ /^[A-Z\\\^\[\]_?]/ && + $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc + || ($last =~ /^[:'{\[\w_]/ && #' + $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); + + return $first . $last; + } elsif ($type eq "uc") { + return '\U' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "lc") { + return '\L' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "ucfirst") { + return '\u' . $self->dq($op->first->sibling); + } elsif ($type eq "lcfirst") { + return '\l' . $self->dq($op->first->sibling); + } elsif ($type eq "quotemeta") { + return '\Q' . $self->dq($op->first->sibling) . '\E'; + } elsif ($type eq "join") { + return $self->deparse($op->last, 26); # was join($", @ary) + } else { + return $self->deparse($op, 26); + } +} + +sub pp_backtick { + my $self = shift; + my($op, $cx) = @_; + # skip pushmark + return single_delim("qx", '`', $self->dq($op->first->sibling)); +} + +sub dquote { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first->sibling; # skip ex-stringify, pushmark + return $self->deparse($kid, $cx) if $self->{'unquote'}; + $self->maybe_targmy($kid, $cx, + sub {single_delim("qq", '"', $self->dq($_[1]))}); +} + +# OP_STRINGIFY is a listop, but it only ever has one arg +sub pp_stringify { maybe_targmy(@_, \&dquote) } + +# tr/// and s/// (and tr[][], tr[]//, tr###, etc) +# note that tr(from)/to/ is OK, but not tr/from/(to) +sub double_delim { + my($from, $to) = @_; + my($succeed, $delim); + if ($from !~ m[/] and $to !~ m[/]) { + return "/$from/$to/"; + } elsif (($succeed, $from) = balanced_delim($from) and $succeed) { + if (($succeed, $to) = balanced_delim($to) and $succeed) { + return "$from$to"; + } else { + for $delim ('/', '"', '#') { # note no `'' -- s''' is special + return "$from$delim$to$delim" if index($to, $delim) == -1; + } + $to =~ s[/][\\/]g; + return "$from/$to/"; + } + } else { + for $delim ('/', '"', '#') { # note no ' + return "$delim$from$delim$to$delim" + if index($to . $from, $delim) == -1; + } + $from =~ s[/][\\/]g; + $to =~ s[/][\\/]g; + return "/$from/$to/"; + } +} + +# Only used by tr///, so backslashes hyphens +sub pchr { # ASCII + my($n) = @_; + if ($n == ord '\\') { + return '\\\\'; + } elsif ($n == ord "-") { + return "\\-"; + } elsif ($n >= ord(' ') and $n <= ord('~')) { + return chr($n); + } elsif ($n == ord "\a") { + return '\\a'; + } elsif ($n == ord "\b") { + return '\\b'; + } elsif ($n == ord "\t") { + return '\\t'; + } elsif ($n == ord "\n") { + return '\\n'; + } elsif ($n == ord "\e") { + return '\\e'; + } elsif ($n == ord "\f") { + return '\\f'; + } elsif ($n == ord "\r") { + return '\\r'; + } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) { + return '\\c' . chr(ord("@") + $n); + } else { +# return '\x' . sprintf("%02x", $n); + return '\\' . sprintf("%03o", $n); + } +} + +sub collapse { + my(@chars) = @_; + my($str, $c, $tr) = (""); + for ($c = 0; $c < @chars; $c++) { + $tr = $chars[$c]; + $str .= pchr($tr); + if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and + $chars[$c + 2] == $tr + 2) + { + for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++) + {} + $str .= "-"; + $str .= pchr($chars[$c]); + } + } + return $str; +} + +sub tr_decode_byte { + my($table, $flags) = @_; + my(@table) = unpack("s*", $table); + splice @table, 0x100, 1; # Number of subsequent elements + my($c, $tr, @from, @to, @delfrom, $delhyphen); + if ($table[ord "-"] != -1 and + $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1) + { + $tr = $table[ord "-"]; + $table[ord "-"] = -1; + if ($tr >= 0) { + @from = ord("-"); + @to = $tr; + } else { # -2 ==> delete + $delhyphen = 1; + } + } + for ($c = 0; $c < @table; $c++) { + $tr = $table[$c]; + if ($tr >= 0) { + push @from, $c; push @to, $tr; + } elsif ($tr == -2) { + push @delfrom, $c; + } + } + @from = (@from, @delfrom); + if ($flags & OPpTRANS_COMPLEMENT) { + my @newfrom = (); + my %from; + @from{@from} = (1) x @from; + for ($c = 0; $c < 256; $c++) { + push @newfrom, $c unless $from{$c}; + } + @from = @newfrom; + } + unless ($flags & OPpTRANS_DELETE || !@to) { + pop @to while $#to and $to[$#to] == $to[$#to -1]; + } + my($from, $to); + $from = collapse(@from); + $to = collapse(@to); + $from .= "-" if $delhyphen; + return ($from, $to); +} + +sub tr_chr { + my $x = shift; + if ($x == ord "-") { + return "\\-"; + } elsif ($x == ord "\\") { + return "\\\\"; + } else { + return chr $x; + } +} + +# XXX This doesn't yet handle all cases correctly either + +sub tr_decode_utf8 { + my($swash_hv, $flags) = @_; + my %swash = $swash_hv->ARRAY; + my $final = undef; + $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'}; + my $none = $swash{"NONE"}->IV; + my $extra = $none + 1; + my(@from, @delfrom, @to); + my $line; + foreach $line (split /\n/, $swash{'LIST'}->PV) { + my($min, $max, $result) = split(/\t/, $line); + $min = hex $min; + if (length $max) { + $max = hex $max; + } else { + $max = $min; + } + $result = hex $result; + if ($result == $extra) { + push @delfrom, [$min, $max]; + } else { + push @from, [$min, $max]; + push @to, [$result, $result + $max - $min]; + } + } + for my $i (0 .. $#from) { + if ($from[$i][0] == ord '-') { + unshift @from, splice(@from, $i, 1); + unshift @to, splice(@to, $i, 1); + last; + } elsif ($from[$i][1] == ord '-') { + $from[$i][1]--; + $to[$i][1]--; + unshift @from, ord '-'; + unshift @to, ord '-'; + last; + } + } + for my $i (0 .. $#delfrom) { + if ($delfrom[$i][0] == ord '-') { + push @delfrom, splice(@delfrom, $i, 1); + last; + } elsif ($delfrom[$i][1] == ord '-') { + $delfrom[$i][1]--; + push @delfrom, ord '-'; + last; + } + } + if (defined $final and $to[$#to][1] != $final) { + push @to, [$final, $final]; + } + push @from, @delfrom; + if ($flags & OPpTRANS_COMPLEMENT) { + my @newfrom; + my $next = 0; + for my $i (0 .. $#from) { + push @newfrom, [$next, $from[$i][0] - 1]; + $next = $from[$i][1] + 1; + } + @from = (); + for my $range (@newfrom) { + if ($range->[0] <= $range->[1]) { + push @from, $range; + } + } + } + my($from, $to, $diff); + for my $chunk (@from) { + $diff = $chunk->[1] - $chunk->[0]; + if ($diff > 1) { + $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); + } elsif ($diff == 1) { + $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); + } else { + $from .= tr_chr($chunk->[0]); + } + } + for my $chunk (@to) { + $diff = $chunk->[1] - $chunk->[0]; + if ($diff > 1) { + $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]); + } elsif ($diff == 1) { + $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]); + } else { + $to .= tr_chr($chunk->[0]); + } + } + #$final = sprintf("%04x", $final) if defined $final; + #$none = sprintf("%04x", $none) if defined $none; + #$extra = sprintf("%04x", $extra) if defined $extra; + #print STDERR "final: $final\n none: $none\nextra: $extra\n"; + #print STDERR $swash{'LIST'}->PV; + return (escape_str($from), escape_str($to)); +} + +sub pp_trans { + my $self = shift; + my($op, $cx) = @_; + my($from, $to); + if (class($op) eq "PVOP") { + ($from, $to) = tr_decode_byte($op->pv, $op->private); + } else { # class($op) eq "SVOP" + ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private); + } + my $flags = ""; + $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT; + $flags .= "d" if $op->private & OPpTRANS_DELETE; + $to = "" if $from eq $to and $flags eq ""; + $flags .= "s" if $op->private & OPpTRANS_SQUASH; + return "tr" . double_delim($from, $to) . $flags; +} + +# Like dq(), but different +sub re_dq { + my $self = shift; + my ($op, $extended) = @_; + + my $type = $op->name; + if ($type eq "const") { + return '$[' if $op->private & OPpCONST_ARYBASE; + my $unbacked = re_unback($self->const_sv($op)->as_string); + return re_uninterp_extended(escape_extended_re($unbacked)) + if $extended; + return re_uninterp(escape_str($unbacked)); + } elsif ($type eq "concat") { + my $first = $self->re_dq($op->first, $extended); + my $last = $self->re_dq($op->last, $extended); + + # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]" + ($last =~ /^[A-Z\\\^\[\]_?]/ && + $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc + || ($last =~ /^[{\[\w_]/ && + $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/); + + return $first . $last; + } elsif ($type eq "uc") { + return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E'; + } elsif ($type eq "lc") { + return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E'; + } elsif ($type eq "ucfirst") { + return '\u' . $self->re_dq($op->first->sibling, $extended); + } elsif ($type eq "lcfirst") { + return '\l' . $self->re_dq($op->first->sibling, $extended); + } elsif ($type eq "quotemeta") { + return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E'; + } elsif ($type eq "join") { + return $self->deparse($op->last, 26); # was join($", @ary) + } else { + return $self->deparse($op, 26); + } +} + +sub pure_string { + my ($self, $op) = @_; + return 0 if null $op; + my $type = $op->name; + + if ($type eq 'const') { + return 1; + } + elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') { + return $self->pure_string($op->first->sibling); + } + elsif ($type eq 'join') { + my $join_op = $op->first->sibling; # Skip pushmark + return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV; + + my $gvop = $join_op->first; + return 0 unless $gvop->name eq 'gvsv'; + return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop)); + + return 0 unless ${$join_op->sibling} eq ${$op->last}; + return 0 unless $op->last->name =~ /^(rv2|pad)av$/; + } + elsif ($type eq 'concat') { + return $self->pure_string($op->first) + && $self->pure_string($op->last); + } + elsif (is_scalar($op) || $type =~ /^[ah]elem$/) { + return 1; + } + elsif ($type eq "null" and $op->can('first') and not null $op->first and + $op->first->name eq "null" and $op->first->can('first') + and not null $op->first->first and + $op->first->first->name eq "aelemfast") { + return 1; + } + else { + return 0; + } + + return 1; +} + +sub regcomp { + my $self = shift; + my($op, $cx, $extended) = @_; + my $kid = $op->first; + $kid = $kid->first if $kid->name eq "regcmaybe"; + $kid = $kid->first if $kid->name eq "regcreset"; + if ($kid->name eq "null" and !null($kid->first) + and $kid->first->name eq 'pushmark') + { + my $str = ''; + $kid = $kid->first->sibling; + while (!null($kid)) { + $str .= $self->re_dq($kid, $extended); + $kid = $kid->sibling; + } + return $str, 1; + } + + return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid); + return ($self->deparse($kid, $cx), 0); +} + +sub pp_regcomp { + my ($self, $op, $cx) = @_; + return (($self->regcomp($op, $cx, 0))[0]); +} + +# osmic acid -- see osmium tetroxide + +my %matchwords; +map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs', + 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic', + 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi'); + +sub matchop { + my $self = shift; + my($op, $cx, $name, $delim) = @_; + my $kid = $op->first; + my ($binop, $var, $re) = ("", "", ""); + if ($op->flags & OPf_STACKED) { + $binop = 1; + $var = $self->deparse($kid, 20); + $kid = $kid->sibling; + } + my $quote = 1; + my $extended = ($op->pmflags & PMf_EXTENDED); + if (null $kid) { + my $unbacked = re_unback($op->precomp); + if ($extended) { + $re = re_uninterp_extended(escape_extended_re($unbacked)); + } else { + $re = re_uninterp(escape_str(re_unback($op->precomp))); + } + } elsif ($kid->name ne 'regcomp') { + carp("found ".$kid->name." where regcomp expected"); + } else { + ($re, $quote) = $self->regcomp($kid, 21, $extended); + } + my $flags = ""; + $flags .= "c" if $op->pmflags & PMf_CONTINUE; + $flags .= "g" if $op->pmflags & PMf_GLOBAL; + $flags .= "i" if $op->pmflags & PMf_FOLD; + $flags .= "m" if $op->pmflags & PMf_MULTILINE; + $flags .= "o" if $op->pmflags & PMf_KEEP; + $flags .= "s" if $op->pmflags & PMf_SINGLELINE; + $flags .= "x" if $op->pmflags & PMf_EXTENDED; + $flags = $matchwords{$flags} if $matchwords{$flags}; + if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here + $re =~ s/\?/\\?/g; + $re = "?$re?"; + } elsif ($quote) { + $re = single_delim($name, $delim, $re); + } + $re = $re . $flags if $quote; + if ($binop) { + return $self->maybe_parens("$var =~ $re", $cx, 20); + } else { + return $re; + } +} + +sub pp_match { matchop(@_, "m", "/") } +sub pp_pushre { matchop(@_, "m", "/") } +sub pp_qr { matchop(@_, "qr", "") } + +sub pp_split { + my $self = shift; + my($op, $cx) = @_; + my($kid, @exprs, $ary, $expr); + $kid = $op->first; + + # For our kid (an OP_PUSHRE), pmreplroot is never actually the + # root of a replacement; it's either empty, or abused to point to + # the GV for an array we split into (an optimization to save + # assignment overhead). Depending on whether we're using ithreads, + # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs + # figures out for us which it is. + my $replroot = $kid->pmreplroot; + my $gv = 0; + if (ref($replroot) eq "B::GV") { + $gv = $replroot; + } elsif (!ref($replroot) and $replroot > 0) { + $gv = $self->padval($replroot); + } + $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv; + + for (; !null($kid); $kid = $kid->sibling) { + push @exprs, $self->deparse($kid, 6); + } + + # handle special case of split(), and split(" ") that compiles to /\s+/ + $kid = $op->first; + if ($kid->flags & OPf_SPECIAL + && $exprs[0] eq '/\\s+/' + && $kid->pmflags & PMf_SKIPWHITE ) { + $exprs[0] = '" "'; + } + + $expr = "split(" . join(", ", @exprs) . ")"; + if ($ary) { + return $self->maybe_parens("$ary = $expr", $cx, 7); + } else { + return $expr; + } +} + +# oxime -- any of various compounds obtained chiefly by the action of +# hydroxylamine on aldehydes and ketones and characterized by the +# bivalent grouping C=NOH [Webster's Tenth] + +my %substwords; +map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em', + 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me', + 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem', + 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi'); + +sub pp_subst { + my $self = shift; + my($op, $cx) = @_; + my $kid = $op->first; + my($binop, $var, $re, $repl) = ("", "", "", ""); + if ($op->flags & OPf_STACKED) { + $binop = 1; + $var = $self->deparse($kid, 20); + $kid = $kid->sibling; + } + my $flags = ""; + if (null($op->pmreplroot)) { + $repl = $self->dq($kid); + $kid = $kid->sibling; + } else { + $repl = $op->pmreplroot->first; # skip substcont + while ($repl->name eq "entereval") { + $repl = $repl->first; + $flags .= "e"; + } + if ($op->pmflags & PMf_EVAL) { + $repl = $self->deparse($repl->first, 0); + } else { + $repl = $self->dq($repl); + } + } + my $extended = ($op->pmflags & PMf_EXTENDED); + if (null $kid) { + my $unbacked = re_unback($op->precomp); + if ($extended) { + $re = re_uninterp_extended(escape_extended_re($unbacked)); + } + else { + $re = re_uninterp(escape_str($unbacked)); + } + } else { + ($re) = $self->regcomp($kid, 1, $extended); + } + $flags .= "e" if $op->pmflags & PMf_EVAL; + $flags .= "g" if $op->pmflags & PMf_GLOBAL; + $flags .= "i" if $op->pmflags & PMf_FOLD; + $flags .= "m" if $op->pmflags & PMf_MULTILINE; + $flags .= "o" if $op->pmflags & PMf_KEEP; + $flags .= "s" if $op->pmflags & PMf_SINGLELINE; + $flags .= "x" if $extended; + $flags = $substwords{$flags} if $substwords{$flags}; + if ($binop) { + return $self->maybe_parens("$var =~ s" + . double_delim($re, $repl) . $flags, + $cx, 20); + } else { + return "s". double_delim($re, $repl) . $flags; + } +} + +1; +__END__ + +=head1 NAME + +B::Deparse - Perl compiler backend to produce perl code + +=head1 SYNOPSIS + +B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>] + [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl> + +=head1 DESCRIPTION + +B::Deparse is a backend module for the Perl compiler that generates +perl source code, based on the internal compiled structure that perl +itself creates after parsing a program. The output of B::Deparse won't +be exactly the same as the original source, since perl doesn't keep +track of comments or whitespace, and there isn't a one-to-one +correspondence between perl's syntactical constructions and their +compiled form, but it will often be close. When you use the B<-p> +option, the output also includes parentheses even when they are not +required by precedence, which can make it easy to see if perl is +parsing your expressions the way you intended. + +While B::Deparse goes to some lengths to try to figure out what your +original program was doing, some parts of the language can still trip +it up; it still fails even on some parts of Perl's own test suite. If +you encounter a failure other than the most common ones described in +the BUGS section below, you can help contribute to B::Deparse's +ongoing development by submitting a bug report with a small +example. + +=head1 OPTIONS + +As with all compiler backend options, these must follow directly after +the '-MO=Deparse', separated by a comma but not any white space. + +=over 4 + +=item B<-d> + +Output data values (when they appear as constants) using Data::Dumper. +Without this option, B::Deparse will use some simple routines of its +own for the same purpose. Currently, Data::Dumper is better for some +kinds of data (such as complex structures with sharing and +self-reference) while the built-in routines are better for others +(such as odd floating-point values). + +=item B<-f>I<FILE> + +Normally, B::Deparse deparses the main code of a program, and all the subs +defined in the same file. To include subs defined in other files, pass the +B<-f> option with the filename. You can pass the B<-f> option several times, to +include more than one secondary file. (Most of the time you don't want to +use it at all.) You can also use this option to include subs which are +defined in the scope of a B<#line> directive with two parameters. + +=item B<-l> + +Add '#line' declarations to the output based on the line and file +locations of the original code. + +=item B<-p> + +Print extra parentheses. Without this option, B::Deparse includes +parentheses in its output only when they are needed, based on the +structure of your program. With B<-p>, it uses parentheses (almost) +whenever they would be legal. This can be useful if you are used to +LISP, or if you want to see how perl parses your input. If you say + + if ($var & 0x7f == 65) {print "Gimme an A!"} + print ($which ? $a : $b), "\n"; + $name = $ENV{USER} or "Bob"; + +C<B::Deparse,-p> will print + + if (($var & 0)) { + print('Gimme an A!') + }; + (print(($which ? $a : $b)), '???'); + (($name = $ENV{'USER'}) or '???') + +which probably isn't what you intended (the C<'???'> is a sign that +perl optimized away a constant value). + +=item B<-P> + +Disable prototype checking. With this option, all function calls are +deparsed as if no prototype was defined for them. In other words, + + perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x' + +will print + + sub foo (\@) { + 1; + } + &foo(\@x); + +making clear how the parameters are actually passed to C<foo>. + +=item B<-q> + +Expand double-quoted strings into the corresponding combinations of +concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For +instance, print + + print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!"; + +as + + print 'Hello, ' . $world . ', ' . join($", @ladies) . ', ' + . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!'); + +Note that the expanded form represents the way perl handles such +constructions internally -- this option actually turns off the reverse +translation that B::Deparse usually does. On the other hand, note that +C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value +of $y into a string before doing the assignment. + +=item B<-s>I<LETTERS> + +Tweak the style of B::Deparse's output. The letters should follow +directly after the 's', with no space or punctuation. The following +options are available: + +=over 4 + +=item B<C> + +Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print + + if (...) { + ... + } else { + ... + } + +instead of + + if (...) { + ... + } + else { + ... + } + +The default is not to cuddle. + +=item B<i>I<NUMBER> + +Indent lines by multiples of I<NUMBER> columns. The default is 4 columns. + +=item B<T> + +Use tabs for each 8 columns of indent. The default is to use only spaces. +For instance, if the style options are B<-si4T>, a line that's indented +3 times will be preceded by one tab and four spaces; if the options were +B<-si8T>, the same line would be preceded by three tabs. + +=item B<v>I<STRING>B<.> + +Print I<STRING> for the value of a constant that can't be determined +because it was optimized away (mnemonic: this happens when a constant +is used in B<v>oid context). The end of the string is marked by a period. +The string should be a valid perl expression, generally a constant. +Note that unless it's a number, it probably needs to be quoted, and on +a command line quotes need to be protected from the shell. Some +conventional values include 0, 1, 42, '', 'foo', and +'Useless use of constant omitted' (which may need to be +B<-sv"'Useless use of constant omitted'."> +or something similar depending on your shell). The default is '???'. +If you're using B::Deparse on a module or other file that's require'd, +you shouldn't use a value that evaluates to false, since the customary +true constant at the end of a module will be in void context when the +file is compiled as a main program. + +=back + +=item B<-x>I<LEVEL> + +Expand conventional syntax constructions into equivalent ones that expose +their internal operation. I<LEVEL> should be a digit, with higher values +meaning more expansion. As with B<-q>, this actually involves turning off +special cases in B::Deparse's normal operations. + +If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent +while loops with continue blocks; for instance + + for ($i = 0; $i < 10; ++$i) { + print $i; + } + +turns into + + $i = 0; + while ($i < 10) { + print $i; + } continue { + ++$i + } + +Note that in a few cases this translation can't be perfectly carried back +into the source code -- if the loop's initializer declares a my variable, +for instance, it won't have the correct scope outside of the loop. + +If I<LEVEL> is at least 5, C<use> declarations will be translated into +C<BEGIN> blocks containing calls to C<require> and C<import>; for +instance, + + use strict 'refs'; + +turns into + + sub BEGIN { + require strict; + do { + 'strict'->import('refs') + }; + } + +If I<LEVEL> is at least 7, C<if> statements will be translated into +equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance + + print 'hi' if $nice; + if ($nice) { + print 'hi'; + } + if ($nice) { + print 'hi'; + } else { + print 'bye'; + } + +turns into + + $nice and print 'hi'; + $nice and do { print 'hi' }; + $nice ? do { print 'hi' } : do { print 'bye' }; + +Long sequences of elsifs will turn into nested ternary operators, which +B::Deparse doesn't know how to indent nicely. + +=back + +=head1 USING B::Deparse AS A MODULE + +=head2 Synopsis + + use B::Deparse; + $deparse = B::Deparse->new("-p", "-sC"); + $body = $deparse->coderef2text(\&func); + eval "sub func $body"; # the inverse operation + +=head2 Description + +B::Deparse can also be used on a sub-by-sub basis from other perl +programs. + +=head2 new + + $deparse = B::Deparse->new(OPTIONS) + +Create an object to store the state of a deparsing operation and any +options. The options are the same as those that can be given on the +command line (see L</OPTIONS>); options that are separated by commas +after B<-MO=Deparse> should be given as separate strings. Some +options, like B<-u>, don't make sense for a single subroutine, so +don't pass them. + +=head2 ambient_pragmas + + $deparse->ambient_pragmas(strict => 'all', '$[' => $[); + +The compilation of a subroutine can be affected by a few compiler +directives, B<pragmas>. These are: + +=over 4 + +=item * + +use strict; + +=item * + +use warnings; + +=item * + +Assigning to the special variable $[ + +=item * + +use integer; + +=item * + +use bytes; + +=item * + +use utf8; + +=item * + +use re; + +=back + +Ordinarily, if you use B::Deparse on a subroutine which has +been compiled in the presence of one or more of these pragmas, +the output will include statements to turn on the appropriate +directives. So if you then compile the code returned by coderef2text, +it will behave the same way as the subroutine which you deparsed. + +However, you may know that you intend to use the results in a +particular context, where some pragmas are already in scope. In +this case, you use the B<ambient_pragmas> method to describe the +assumptions you wish to make. + +Not all of the options currently have any useful effect. See +L</BUGS> for more details. + +The parameters it accepts are: + +=over 4 + +=item strict + +Takes a string, possibly containing several values separated +by whitespace. The special values "all" and "none" mean what you'd +expect. + + $deparse->ambient_pragmas(strict => 'subs refs'); + +=item $[ + +Takes a number, the value of the array base $[. + +=item bytes + +=item utf8 + +=item integer + +If the value is true, then the appropriate pragma is assumed to +be in the ambient scope, otherwise not. + +=item re + +Takes a string, possibly containing a whitespace-separated list of +values. The values "all" and "none" are special. It's also permissible +to pass an array reference here. + + $deparser->ambient_pragmas(re => 'eval'); + + +=item warnings + +Takes a string, possibly containing a whitespace-separated list of +values. The values "all" and "none" are special, again. It's also +permissible to pass an array reference here. + + $deparser->ambient_pragmas(warnings => [qw[void io]]); + +If one of the values is the string "FATAL", then all the warnings +in that list will be considered fatal, just as with the B<warnings> +pragma itself. Should you need to specify that some warnings are +fatal, and others are merely enabled, you can pass the B<warnings> +parameter twice: + + $deparser->ambient_pragmas( + warnings => 'all', + warnings => [FATAL => qw/void io/], + ); + +See L<perllexwarn> for more information about lexical warnings. + +=item hint_bits + +=item warning_bits + +These two parameters are used to specify the ambient pragmas in +the format used by the special variables $^H and ${^WARNING_BITS}. + +They exist principally so that you can write code like: + + { my ($hint_bits, $warning_bits); + BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})} + $deparser->ambient_pragmas ( + hint_bits => $hint_bits, + warning_bits => $warning_bits, + '$[' => 0 + $[ + ); } + +which specifies that the ambient pragmas are exactly those which +are in scope at the point of calling. + +=back + +=head2 coderef2text + + $body = $deparse->coderef2text(\&func) + $body = $deparse->coderef2text(sub ($$) { ... }) + +Return source code for the body of a subroutine (a block, optionally +preceded by a prototype in parens), given a reference to the +sub. Because a subroutine can have no names, or more than one name, +this method doesn't return a complete subroutine definition -- if you +want to eval the result, you should prepend "sub subname ", or "sub " +for an anonymous function constructor. Unless the sub was defined in +the main:: package, the code will include a package declaration. + +=head1 BUGS + +=over 4 + +=item * + +The only pragmas to be completely supported are: C<use warnings>, +C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which +behaves like a pragma, is also supported.) + +Excepting those listed above, we're currently unable to guarantee that +B::Deparse will produce a pragma at the correct point in the program. +(Specifically, pragmas at the beginning of a block often appear right +before the start of the block instead.) +Since the effects of pragmas are often lexically scoped, this can mean +that the pragma holds sway over a different portion of the program +than in the input file. + +=item * + +In fact, the above is a specific instance of a more general problem: +we can't guarantee to produce BEGIN blocks or C<use> declarations in +exactly the right place. So if you use a module which affects compilation +(such as by over-riding keywords, overloading constants or whatever) +then the output code might not work as intended. + +This is the most serious outstanding problem, and will require some help +from the Perl core to fix. + +=item * + +If a keyword is over-ridden, and your program explicitly calls +the built-in version by using CORE::keyword, the output of B::Deparse +will not reflect this. If you run the resulting code, it will call +the over-ridden version rather than the built-in one. (Maybe there +should be an option to B<always> print keyword calls as C<CORE::name>.) + +=item * + +Some constants don't print correctly either with or without B<-d>. +For instance, neither B::Deparse nor Data::Dumper know how to print +dual-valued scalars correctly, as in: + + use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y; + +=item * + +An input file that uses source filtering probably won't be deparsed into +runnable code, because it will still include the B<use> declaration +for the source filtering module, even though the code that is +produced is already ordinary Perl which shouldn't be filtered again. + +=item * + +Optimised away statements are rendered as '???'. This includes statements that +have a compile-time side-effect, such as the obscure + + my $x if 0; + +which is not, consequently, deparsed correctly. + +=item * + +There are probably many more bugs on non-ASCII platforms (EBCDIC). + +=back + +=head1 AUTHOR + +Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version +by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from +Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell, +Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael +Garcia-Suarez. + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Disassembler.pm b/Master/tlpkg/installer/perllib/B/Disassembler.pm new file mode 100644 index 00000000000..e1993aa9537 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Disassembler.pm @@ -0,0 +1,233 @@ +# Disassembler.pm +# +# Copyright (c) 1996 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. + +$B::Disassembler::VERSION = '1.05'; + +package B::Disassembler::BytecodeStream; + +use FileHandle; +use Carp; +use Config qw(%Config); +use B qw(cstring cast_I32); +@ISA = qw(FileHandle); +sub readn { + my ($fh, $len) = @_; + my $data; + read($fh, $data, $len); + croak "reached EOF while reading $len bytes" unless length($data) == $len; + return $data; +} + +sub GET_U8 { + my $fh = shift; + my $c = $fh->getc; + croak "reached EOF while reading U8" unless defined($c); + return ord($c); +} + +sub GET_U16 { + my $fh = shift; + my $str = $fh->readn(2); + croak "reached EOF while reading U16" unless length($str) == 2; + return unpack("S", $str); +} + +sub GET_NV { + my $fh = shift; + my ($str, $c); + while (defined($c = $fh->getc) && $c ne "\0") { + $str .= $c; + } + croak "reached EOF while reading double" unless defined($c); + return $str; +} + +sub GET_U32 { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading U32" unless length($str) == 4; + return unpack("L", $str); +} + +sub GET_I32 { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading I32" unless length($str) == 4; + return unpack("l", $str); +} + +sub GET_objindex { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading objindex" unless length($str) == 4; + return unpack("L", $str); +} + +sub GET_opindex { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading opindex" unless length($str) == 4; + return unpack("L", $str); +} + +sub GET_svindex { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading svindex" unless length($str) == 4; + return unpack("L", $str); +} + +sub GET_pvindex { + my $fh = shift; + my $str = $fh->readn(4); + croak "reached EOF while reading pvindex" unless length($str) == 4; + return unpack("L", $str); +} + +sub GET_strconst { + my $fh = shift; + my ($str, $c); + $str = ''; + while (defined($c = $fh->getc) && $c ne "\0") { + $str .= $c; + } + croak "reached EOF while reading strconst" unless defined($c); + return cstring($str); +} + +sub GET_pvcontents {} + +sub GET_PV { + my $fh = shift; + my $str; + my $len = $fh->GET_U32; + if ($len) { + read($fh, $str, $len); + croak "reached EOF while reading PV" unless length($str) == $len; + return cstring($str); + } else { + return '""'; + } +} + +sub GET_comment_t { + my $fh = shift; + my ($str, $c); + while (defined($c = $fh->getc) && $c ne "\n") { + $str .= $c; + } + croak "reached EOF while reading comment" unless defined($c); + return cstring($str); +} + +sub GET_double { + my $fh = shift; + my ($str, $c); + while (defined($c = $fh->getc) && $c ne "\0") { + $str .= $c; + } + croak "reached EOF while reading double" unless defined($c); + return $str; +} + +sub GET_none {} + +sub GET_op_tr_array { + my $fh = shift; + my $len = unpack "S", $fh->readn(2); + my @ary = unpack "S*", $fh->readn($len*2); + return join(",", $len, @ary); +} + +sub GET_IV64 { + my $fh = shift; + my $str = $fh->readn(8); + croak "reached EOF while reading I32" unless length($str) == 8; + return sprintf "0x%09llx", unpack("q", $str); +} + +sub GET_IV { + $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64; +} + +sub GET_PADOFFSET { + $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32; +} + +sub GET_long { + $Config{longsize} == 8 ? &GET_IV64 : &GET_U32; +} + + +package B::Disassembler; +use Exporter; +@ISA = qw(Exporter); +@EXPORT_OK = qw(disassemble_fh get_header); +use Carp; +use strict; + +use B::Asmdata qw(%insn_data @insn_name); + +our( $magic, $archname, $blversion, $ivsize, $ptrsize ); + +sub dis_header($){ + my( $fh ) = @_; + $magic = $fh->GET_U32(); + warn( "bad magic" ) if $magic != 0x43424c50; + $archname = $fh->GET_strconst(); + $blversion = $fh->GET_strconst(); + $ivsize = $fh->GET_U32(); + $ptrsize = $fh->GET_U32(); +} + +sub get_header(){ + return( $magic, $archname, $blversion, $ivsize, $ptrsize); +} + +sub disassemble_fh { + my ($fh, $out) = @_; + my ($c, $getmeth, $insn, $arg); + bless $fh, "B::Disassembler::BytecodeStream"; + dis_header( $fh ); + while (defined($c = $fh->getc)) { + $c = ord($c); + $insn = $insn_name[$c]; + if (!defined($insn) || $insn eq "unused") { + my $pos = $fh->tell - 1; + die "Illegal instruction code $c at stream offset $pos\n"; + } + $getmeth = $insn_data{$insn}->[2]; + $arg = $fh->$getmeth(); + if (defined($arg)) { + &$out($insn, $arg); + } else { + &$out($insn); + } + } +} + +1; + +__END__ + +=head1 NAME + +B::Disassembler - Disassemble Perl bytecode + +=head1 SYNOPSIS + + use Disassembler; + +=head1 DESCRIPTION + +See F<ext/B/B/Disassembler.pm>. + +=head1 AUTHOR + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Lint.pm b/Master/tlpkg/installer/perllib/B/Lint.pm new file mode 100644 index 00000000000..3475bd2596e --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Lint.pm @@ -0,0 +1,392 @@ +package B::Lint; + +our $VERSION = '1.03'; + +=head1 NAME + +B::Lint - Perl lint + +=head1 SYNOPSIS + +perl -MO=Lint[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +The B::Lint module is equivalent to an extended version of the B<-w> +option of B<perl>. It is named after the program F<lint> which carries +out a similar process for C programs. + +=head1 OPTIONS AND LINT CHECKS + +Option words are separated by commas (not whitespace) and follow the +usual conventions of compiler backend options. Following any options +(indicated by a leading B<->) come lint check arguments. Each such +argument (apart from the special B<all> and B<none> options) is a +word representing one possible lint check (turning on that check) or +is B<no-foo> (turning off that check). Before processing the check +arguments, a standard list of checks is turned on. Later options +override earlier ones. Available options are: + +=over 8 + +=item B<context> + +Produces a warning whenever an array is used in an implicit scalar +context. For example, both of the lines + + $foo = length(@bar); + $foo = @bar; + +will elicit a warning. Using an explicit B<scalar()> silences the +warning. For example, + + $foo = scalar(@bar); + +=item B<implicit-read> and B<implicit-write> + +These options produce a warning whenever an operation implicitly +reads or (respectively) writes to one of Perl's special variables. +For example, B<implicit-read> will warn about these: + + /foo/; + +and B<implicit-write> will warn about these: + + s/foo/bar/; + +Both B<implicit-read> and B<implicit-write> warn about this: + + for (@a) { ... } + +=item B<bare-subs> + +This option warns whenever a bareword is implicitly quoted, but is also +the name of a subroutine in the current package. Typical mistakes that it will +trap are: + + use constant foo => 'bar'; + @a = ( foo => 1 ); + $b{foo} = 2; + +Neither of these will do what a naive user would expect. + +=item B<dollar-underscore> + +This option warns whenever C<$_> is used either explicitly anywhere or +as the implicit argument of a B<print> statement. + +=item B<private-names> + +This option warns on each use of any variable, subroutine or +method name that lives in a non-current package but begins with +an underscore ("_"). Warnings aren't issued for the special case +of the single character name "_" by itself (e.g. C<$_> and C<@_>). + +=item B<undefined-subs> + +This option warns whenever an undefined subroutine is invoked. +This option will only catch explicitly invoked subroutines such +as C<foo()> and not indirect invocations such as C<&$subref()> +or C<$obj-E<gt>meth()>. Note that some programs or modules delay +definition of subs until runtime by means of the AUTOLOAD +mechanism. + +=item B<regexp-variables> + +This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'> +is used. Any occurrence of any of these variables in your +program can slow your whole program down. See L<perlre> for +details. + +=item B<all> + +Turn all warnings on. + +=item B<none> + +Turn all warnings off. + +=back + +=head1 NON LINT-CHECK OPTIONS + +=over 8 + +=item B<-u Package> + +Normally, Lint only checks the main code of the program together +with all subs defined in package main. The B<-u> option lets you +include other package names whose subs are then checked by Lint. + +=back + +=head1 BUGS + +This is only a very preliminary version. + +This module doesn't work correctly on thread-enabled perls. + +=head1 AUTHOR + +Malcolm Beattie, mbeattie@sable.ox.ac.uk. + +=cut + +use strict; +use B qw(walkoptree_slow main_root walksymtable svref_2object parents + OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK + ); + +my $file = "unknown"; # shadows current filename +my $line = 0; # shadows current line number +my $curstash = "main"; # shadows current stash + +# Lint checks +my %check; +my %implies_ok_context; +BEGIN { + map($implies_ok_context{$_}++, + qw(scalar av2arylen aelem aslice helem hslice + keys values hslice defined undef delete)); +} + +# Lint checks turned on by default +my @default_checks = qw(context); + +my %valid_check; +# All valid checks +BEGIN { + map($valid_check{$_}++, + qw(context implicit_read implicit_write dollar_underscore + private_names bare_subs undefined_subs regexp_variables)); +} + +# Debugging options +my ($debug_op); + +my %done_cv; # used to mark which subs have already been linted +my @extra_packages; # Lint checks mainline code and all subs which are + # in main:: or in one of these packages. + +sub warning { + my $format = (@_ < 2) ? "%s" : shift; + warn sprintf("$format at %s line %d\n", @_, $file, $line); +} + +# This gimme can't cope with context that's only determined +# at runtime via dowantarray(). +sub gimme { + my $op = shift; + my $flags = $op->flags; + if ($flags & OPf_WANT) { + return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0); + } + return undef; +} + +sub B::OP::lint {} + +sub B::COP::lint { + my $op = shift; + if ($op->name eq "nextstate") { + $file = $op->file; + $line = $op->line; + $curstash = $op->stash->NAME; + } +} + +sub B::UNOP::lint { + my $op = shift; + my $opname = $op->name; + if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) { + my $parent = parents->[0]; + my $pname = $parent->name; + return if gimme($op) || $implies_ok_context{$pname}; + # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" + # null out the parent so we have to check for a parent of pp_null and + # a grandparent of pp_enteriter or pp_delete + if ($pname eq "null") { + my $gpname = parents->[1]->name; + return if $gpname eq "enteriter" || $gpname eq "delete"; + } + warning("Implicit scalar context for %s in %s", + $opname eq "rv2av" ? "array" : "hash", $parent->desc); + } + if ($check{private_names} && $opname eq "method") { + my $methop = $op->first; + if ($methop->name eq "const") { + my $method = $methop->sv->PV; + if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { + warning("Illegal reference to private method name $method"); + } + } + } +} + +sub B::PMOP::lint { + my $op = shift; + if ($check{implicit_read}) { + if ($op->name eq "match" && !($op->flags & OPf_STACKED)) { + warning('Implicit match on $_'); + } + } + if ($check{implicit_write}) { + if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) { + warning('Implicit substitution on $_'); + } + } +} + +sub B::LOOP::lint { + my $op = shift; + if ($check{implicit_read} || $check{implicit_write}) { + if ($op->name eq "enteriter") { + my $last = $op->last; + if ($last->name eq "gv" && $last->gv->NAME eq "_") { + warning('Implicit use of $_ in foreach'); + } + } + } +} + +sub B::SVOP::lint { + my $op = shift; + if ( $check{bare_subs} && $op->name eq 'const' + && $op->private & 64 ) # OPpCONST_BARE = 64 in op.h + { + my $sv = $op->sv; + if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) { + warning "Bare sub name '" . $sv->PV . "' interpreted as string"; + } + } + if ($check{dollar_underscore} && $op->name eq "gvsv" + && $op->gv->NAME eq "_") + { + warning('Use of $_'); + } + if ($check{private_names}) { + my $opname = $op->name; + if ($opname eq "gv" || $opname eq "gvsv") { + my $gv = $op->gv; + if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) { + warning('Illegal reference to private name %s', $gv->NAME); + } + } elsif ($opname eq "method_named") { + my $method = $op->gv->PV; + if ($method =~ /^_./) { + warning("Illegal reference to private method name $method"); + } + } + } + if ($check{undefined_subs}) { + if ($op->name eq "gv" + && $op->next->name eq "entersub") + { + my $gv = $op->gv; + my $subname = $gv->STASH->NAME . "::" . $gv->NAME; + no strict 'refs'; + if (!defined(&$subname)) { + $subname =~ s/^main:://; + warning('Undefined subroutine %s called', $subname); + } + } + } + if ($check{regexp_variables} && $op->name eq "gvsv") { + my $name = $op->gv->NAME; + if ($name =~ /^[&'`]$/) { + warning('Use of regexp variable $%s', $name); + } + } +} + +sub B::GV::lintcv { + my $gv = shift; + my $cv = $gv->CV; + #warn sprintf("lintcv: %s::%s (done=%d)\n", + # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug + return if !$$cv || $done_cv{$$cv}++; + my $root = $cv->ROOT; + #warn " root = $root (0x$$root)\n";#debug + walkoptree_slow($root, "lint") if $$root; +} + +sub do_lint { + my %search_pack; + walkoptree_slow(main_root, "lint") if ${main_root()}; + + # Now do subs in main + no strict qw(vars refs); + local(*glob); + for my $sym (keys %main::) { + next if $sym =~ /::$/; + *glob = $main::{$sym}; + svref_2object(\*glob)->EGV->lintcv; + } + + # Now do subs in non-main packages given by -u options + map { $search_pack{$_} = 1 } @extra_packages; + walksymtable(\%{"main::"}, "lintcv", sub { + my $package = shift; + $package =~ s/::$//; + #warn "Considering $package\n";#debug + return exists $search_pack{$package}; + }); +} + +sub compile { + my @options = @_; + my ($option, $opt, $arg); + # Turn on default lint checks + for $opt (@default_checks) { + $check{$opt} = 1; + } + OPTION: + while ($option = shift @options) { + if ($option =~ /^-(.)(.*)/) { + $opt = $1; + $arg = $2; + } else { + unshift @options, $option; + last OPTION; + } + if ($opt eq "-" && $arg eq "-") { + shift @options; + last OPTION; + } elsif ($opt eq "D") { + $arg ||= shift @options; + foreach $arg (split(//, $arg)) { + if ($arg eq "o") { + B->debug(1); + } elsif ($arg eq "O") { + $debug_op = 1; + } + } + } elsif ($opt eq "u") { + $arg ||= shift @options; + push(@extra_packages, $arg); + } + } + foreach $opt (@default_checks, @options) { + $opt =~ tr/-/_/; + if ($opt eq "all") { + %check = %valid_check; + } + elsif ($opt eq "none") { + %check = (); + } + else { + if ($opt =~ s/^no_//) { + $check{$opt} = 0; + } + else { + $check{$opt} = 1; + } + warn "No such check: $opt\n" unless defined $valid_check{$opt}; + } + } + # Remaining arguments are things to check + + return \&do_lint; +} + +1; diff --git a/Master/tlpkg/installer/perllib/B/Showlex.pm b/Master/tlpkg/installer/perllib/B/Showlex.pm new file mode 100644 index 00000000000..3b261a337df --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Showlex.pm @@ -0,0 +1,205 @@ +package B::Showlex; + +our $VERSION = '1.02'; + +use strict; +use B qw(svref_2object comppadlist class); +use B::Terse (); +use B::Concise (); + +# +# Invoke as +# perl -MO=Showlex,foo bar.pl +# to see the names of lexical variables used by &foo +# or as +# perl -MO=Showlex bar.pl +# to see the names of file scope lexicals used by bar.pl +# + + +# borrowed from B::Concise +our $walkHandle = \*STDOUT; + +sub walk_output { # updates $walkHandle + $walkHandle = B::Concise::walk_output(@_); + #print "got $walkHandle"; + #print $walkHandle "using it"; + $walkHandle; +} + +sub shownamearray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print $walkHandle "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + my $sv = $els[$i]; + if (class($sv) ne "SPECIAL") { + printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX; + } else { + printf $walkHandle "$i: %s\n", $sv->terse; + #printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv); + } + } +} + +sub showvaluearray { + my ($name, $av) = @_; + my @els = $av->ARRAY; + my $count = @els; + my $i; + print $walkHandle "$name has $count entries\n"; + for ($i = 0; $i < $count; $i++) { + printf $walkHandle "$i: %s\n", $els[$i]->terse; + #print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]); + } +} + +sub showlex { + my ($objname, $namesav, $valsav) = @_; + shownamearray("Pad of lexical names for $objname", $namesav); + showvaluearray("Pad of lexical values for $objname", $valsav); +} + +my ($newlex, $nosp1); # rendering state vars + +sub newlex { # drop-in for showlex + my ($objname, $names, $vals) = @_; + my @names = $names->ARRAY; + my @vals = $vals->ARRAY; + my $count = @names; + print $walkHandle "$objname Pad has $count entries\n"; + printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1; + for (my $i = 1; $i < $count; $i++) { + printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse + unless $nosp1 and $names[$i]->terse =~ /SPECIAL/; + } +} + +sub showlex_obj { + my ($objname, $obj) = @_; + $objname =~ s/^&main::/&/; + showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex; + newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex; +} + +sub showlex_main { + showlex("comppadlist", comppadlist->ARRAY) if !$newlex; + newlex ("main", comppadlist->ARRAY) if $newlex; +} + +sub compile { + my @options = grep(/^-/, @_); + my @args = grep(!/^-/, @_); + for my $o (@options) { + $newlex = 1 if $o eq "-newlex"; + $nosp1 = 1 if $o eq "-nosp"; + } + + return \&showlex_main unless @args; + return sub { + my $objref; + foreach my $objname (@args) { + next unless $objname; # skip nulls w/o carping + + if (ref $objname) { + print $walkHandle "B::Showlex::compile($objname)\n"; + $objref = $objname; + } else { + $objname = "main::$objname" unless $objname =~ /::/; + print $walkHandle "$objname:\n"; + no strict 'refs'; + die "err: unknown function ($objname)\n" + unless *{$objname}{CODE}; + $objref = \&$objname; + } + showlex_obj($objname, $objref); + } + } +} + +1; + +__END__ + +=head1 NAME + +B::Showlex - Show lexical variables used in functions or files + +=head1 SYNOPSIS + + perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl + +=head1 DESCRIPTION + +When a comma-separated list of subroutine names is given as options, Showlex +prints the lexical variables used in those subroutines. Otherwise, it prints +the file-scope lexicals in the file. + +=head1 EXAMPLES + +Traditional form: + + $ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")' + Pad of lexical names for comppadlist has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0x9db0fb0) $i + 2: PVNV (0x9db0f38) $j + 3: PVNV (0x9db0f50) $k + Pad of lexical values for comppadlist has 5 entries + 0: SPECIAL #1 &PL_sv_undef + 1: NULL (0x9da4234) + 2: NULL (0x9db0f2c) + 3: NULL (0x9db0f44) + 4: NULL (0x9da4264) + -e syntax OK + +New-style form: + + $ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")' + main Pad has 4 entries + 0: SPECIAL #1 &PL_sv_undef + 1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234) + 2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34) + 3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c) + -e syntax OK + +New form, no specials, outside O framework: + + $ perl -MB::Showlex -e \ + 'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()' + main Pad has 4 entries + 1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1 + 2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo" + 3: PVNV (0x998ff80) "$k" = NULL (0x998ff74) + +Note that this example shows the values of the lexicals, whereas the other +examples did not (as they're compile-time only). + +=head2 OPTIONS + +The C<-newlex> option produces a more readable C<< name => value >> format, +and is shown in the second example above. + +The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL +#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm +your declared lexicals. + +=head1 SEE ALSO + +C<B::Showlex> can also be used outside of the O framework, as in the third +example. See C<B::Concise> for a fuller explanation of reasons. + +=head1 TODO + +Some of the reported info, such as hex addresses, is not particularly +valuable. Other information would be more useful for the typical +programmer, such as line-numbers, pad-slot reuses, etc.. Given this, +-newlex isnt a particularly good flag-name. + +=head1 AUTHOR + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Stackobj.pm b/Master/tlpkg/installer/perllib/B/Stackobj.pm new file mode 100644 index 00000000000..b17dfb8173a --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Stackobj.pm @@ -0,0 +1,349 @@ +# Stackobj.pm +# +# Copyright (c) 1996 Malcolm Beattie +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +package B::Stackobj; + +our $VERSION = '1.00'; + +use Exporter (); +@ISA = qw(Exporter); +@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED + VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY); +%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)], + flags => [qw(VALID_INT VALID_DOUBLE VALID_SV + VALID_UNSIGNED REGISTER TEMPORARY)]); + +use Carp qw(confess); +use strict; +use B qw(class SVf_IOK SVf_NOK SVf_IVisUV); + +# Types +sub T_UNKNOWN () { 0 } +sub T_DOUBLE () { 1 } +sub T_INT () { 2 } +sub T_SPECIAL () { 3 } + +# Flags +sub VALID_INT () { 0x01 } +sub VALID_UNSIGNED () { 0x02 } +sub VALID_DOUBLE () { 0x04 } +sub VALID_SV () { 0x08 } +sub REGISTER () { 0x10 } # no implicit write-back when calling subs +sub TEMPORARY () { 0x20 } # no implicit write-back needed at all +sub SAVE_INT () { 0x40 } #if int part needs to be saved at all +sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all + + +# +# Callback for runtime code generation +# +my $runtime_callback = sub { confess "set_callback not yet called" }; +sub set_callback (&) { $runtime_callback = shift } +sub runtime { &$runtime_callback(@_) } + +# +# Methods +# + +sub write_back { confess "stack object does not implement write_back" } + +sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) } + +sub as_sv { + my $obj = shift; + if (!($obj->{flags} & VALID_SV)) { + $obj->write_back; + $obj->{flags} |= VALID_SV; + } + return $obj->{sv}; +} + +sub as_int { + my $obj = shift; + if (!($obj->{flags} & VALID_INT)) { + $obj->load_int; + $obj->{flags} |= VALID_INT|SAVE_INT; + } + return $obj->{iv}; +} + +sub as_double { + my $obj = shift; + if (!($obj->{flags} & VALID_DOUBLE)) { + $obj->load_double; + $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; + } + return $obj->{nv}; +} + +sub as_numeric { + my $obj = shift; + return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double; +} + +sub as_bool { + my $obj=shift; + if ($obj->{flags} & VALID_INT ){ + return $obj->{iv}; + } + if ($obj->{flags} & VALID_DOUBLE ){ + return $obj->{nv}; + } + return sprintf("(SvTRUE(%s))", $obj->as_sv) ; +} + +# +# Debugging methods +# +sub peek { + my $obj = shift; + my $type = $obj->{type}; + my $flags = $obj->{flags}; + my @flags; + if ($type == T_UNKNOWN) { + $type = "T_UNKNOWN"; + } elsif ($type == T_INT) { + $type = "T_INT"; + } elsif ($type == T_DOUBLE) { + $type = "T_DOUBLE"; + } else { + $type = "(illegal type $type)"; + } + push(@flags, "VALID_INT") if $flags & VALID_INT; + push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE; + push(@flags, "VALID_SV") if $flags & VALID_SV; + push(@flags, "REGISTER") if $flags & REGISTER; + push(@flags, "TEMPORARY") if $flags & TEMPORARY; + @flags = ("none") unless @flags; + return sprintf("%s type=$type flags=%s sv=$obj->{sv}", + class($obj), join("|", @flags)); +} + +sub minipeek { + my $obj = shift; + my $type = $obj->{type}; + my $flags = $obj->{flags}; + if ($type == T_INT || $flags & VALID_INT) { + return $obj->{iv}; + } elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) { + return $obj->{nv}; + } else { + return $obj->{sv}; + } +} + +# +# Caller needs to ensure that set_int, set_double, +# set_numeric and set_sv are only invoked on legal lvalues. +# +sub set_int { + my ($obj, $expr,$unsigned) = @_; + runtime("$obj->{iv} = $expr;"); + $obj->{flags} &= ~(VALID_SV | VALID_DOUBLE); + $obj->{flags} |= VALID_INT|SAVE_INT; + $obj->{flags} |= VALID_UNSIGNED if $unsigned; +} + +sub set_double { + my ($obj, $expr) = @_; + runtime("$obj->{nv} = $expr;"); + $obj->{flags} &= ~(VALID_SV | VALID_INT); + $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; +} + +sub set_numeric { + my ($obj, $expr) = @_; + if ($obj->{type} == T_INT) { + $obj->set_int($expr); + } else { + $obj->set_double($expr); + } +} + +sub set_sv { + my ($obj, $expr) = @_; + runtime("SvSetSV($obj->{sv}, $expr);"); + $obj->invalidate; + $obj->{flags} |= VALID_SV; +} + +# +# Stackobj::Padsv +# + +@B::Stackobj::Padsv::ISA = 'B::Stackobj'; +sub B::Stackobj::Padsv::new { + my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_; + $extra_flags |= SAVE_INT if $extra_flags & VALID_INT; + $extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE; + bless { + type => $type, + flags => VALID_SV | $extra_flags, + sv => "PL_curpad[$ix]", + iv => "$iname", + nv => "$dname" + }, $class; +} + +sub B::Stackobj::Padsv::load_int { + my $obj = shift; + if ($obj->{flags} & VALID_DOUBLE) { + runtime("$obj->{iv} = $obj->{nv};"); + } else { + runtime("$obj->{iv} = SvIV($obj->{sv});"); + } + $obj->{flags} |= VALID_INT|SAVE_INT; +} + +sub B::Stackobj::Padsv::load_double { + my $obj = shift; + $obj->write_back; + runtime("$obj->{nv} = SvNV($obj->{sv});"); + $obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE; +} +sub B::Stackobj::Padsv::save_int { + my $obj = shift; + return $obj->{flags} & SAVE_INT; +} + +sub B::Stackobj::Padsv::save_double { + my $obj = shift; + return $obj->{flags} & SAVE_DOUBLE; +} + +sub B::Stackobj::Padsv::write_back { + my $obj = shift; + my $flags = $obj->{flags}; + return if $flags & VALID_SV; + if ($flags & VALID_INT) { + if ($flags & VALID_UNSIGNED ){ + runtime("sv_setuv($obj->{sv}, $obj->{iv});"); + }else{ + runtime("sv_setiv($obj->{sv}, $obj->{iv});"); + } + } elsif ($flags & VALID_DOUBLE) { + runtime("sv_setnv($obj->{sv}, $obj->{nv});"); + } else { + confess "write_back failed for lexical @{[$obj->peek]}\n"; + } + $obj->{flags} |= VALID_SV; +} + +# +# Stackobj::Const +# + +@B::Stackobj::Const::ISA = 'B::Stackobj'; +sub B::Stackobj::Const::new { + my ($class, $sv) = @_; + my $obj = bless { + flags => 0, + sv => $sv # holds the SV object until write_back happens + }, $class; + if ( ref($sv) eq "B::SPECIAL" ){ + $obj->{type}= T_SPECIAL; + }else{ + my $svflags = $sv->FLAGS; + if ($svflags & SVf_IOK) { + $obj->{flags} = VALID_INT|VALID_DOUBLE; + $obj->{type} = T_INT; + if ($svflags & SVf_IVisUV){ + $obj->{flags} |= VALID_UNSIGNED; + $obj->{nv} = $obj->{iv} = $sv->UVX; + }else{ + $obj->{nv} = $obj->{iv} = $sv->IV; + } + } elsif ($svflags & SVf_NOK) { + $obj->{flags} = VALID_INT|VALID_DOUBLE; + $obj->{type} = T_DOUBLE; + $obj->{iv} = $obj->{nv} = $sv->NV; + } else { + $obj->{type} = T_UNKNOWN; + } + } + return $obj; +} + +sub B::Stackobj::Const::write_back { + my $obj = shift; + return if $obj->{flags} & VALID_SV; + # Save the SV object and replace $obj->{sv} by its C source code name + $obj->{sv} = $obj->{sv}->save; + $obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE; +} + +sub B::Stackobj::Const::load_int { + my $obj = shift; + if (ref($obj->{sv}) eq "B::RV"){ + $obj->{iv} = int($obj->{sv}->RV->PV); + }else{ + $obj->{iv} = int($obj->{sv}->PV); + } + $obj->{flags} |= VALID_INT; +} + +sub B::Stackobj::Const::load_double { + my $obj = shift; + if (ref($obj->{sv}) eq "B::RV"){ + $obj->{nv} = $obj->{sv}->RV->PV + 0.0; + }else{ + $obj->{nv} = $obj->{sv}->PV + 0.0; + } + $obj->{flags} |= VALID_DOUBLE; +} + +sub B::Stackobj::Const::invalidate {} + +# +# Stackobj::Bool +# + +@B::Stackobj::Bool::ISA = 'B::Stackobj'; +sub B::Stackobj::Bool::new { + my ($class, $preg) = @_; + my $obj = bless { + type => T_INT, + flags => VALID_INT|VALID_DOUBLE, + iv => $$preg, + nv => $$preg, + preg => $preg # this holds our ref to the pseudo-reg + }, $class; + return $obj; +} + +sub B::Stackobj::Bool::write_back { + my $obj = shift; + return if $obj->{flags} & VALID_SV; + $obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)"; + $obj->{flags} |= VALID_SV; +} + +# XXX Might want to handle as_double/set_double/load_double? + +sub B::Stackobj::Bool::invalidate {} + +1; + +__END__ + +=head1 NAME + +B::Stackobj - Helper module for CC backend + +=head1 SYNOPSIS + + use B::Stackobj; + +=head1 DESCRIPTION + +See F<ext/B/README>. + +=head1 AUTHOR + +Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Stash.pm b/Master/tlpkg/installer/perllib/B/Stash.pm new file mode 100644 index 00000000000..5e60868a28e --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Stash.pm @@ -0,0 +1,52 @@ +# Stash.pm -- show what stashes are loaded +# vishalb@hotmail.com +package B::Stash; + +our $VERSION = '1.00'; + +=pod + +=head1 NAME + +B::Stash - show what stashes are loaded + +=cut + +BEGIN { %Seen = %INC } + +CHECK { + my @arr=scan($main::{"main::"}); + @arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr; + print "-umain,-u", join (",-u",@arr) ,"\n"; +} +sub scan{ + my $start=shift; + my $prefix=shift; + $prefix = '' unless defined $prefix; + my @return; + foreach my $key ( keys %{$start}){ +# print $prefix,$key,"\n"; + if ($key =~ /::$/){ + unless ($start eq ${$start}{$key} or $key eq "B::" ){ + push @return, $key unless omit($prefix.$key); + foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){ + push @return, "$key".$subscan; + } + } + } + } + return @return; +} +sub omit{ + my $module = shift; + my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 , + "CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 ); + return 1 if $omit{$module}; + if ($module eq "IO::" or $module eq "IO::Handle::"){ + $module =~ s/::/\//g; + return 1 unless $INC{$module}; + } + + return 0; +} +1; diff --git a/Master/tlpkg/installer/perllib/B/Terse.pm b/Master/tlpkg/installer/perllib/B/Terse.pm new file mode 100644 index 00000000000..1d53950ad3b --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Terse.pm @@ -0,0 +1,103 @@ +package B::Terse; + +our $VERSION = '1.03_01'; + +use strict; +use B qw(class); +use B::Asmdata qw(@specialsv_name); +use B::Concise qw(concise_subref set_style_standard); +use Carp; + +sub terse { + my ($order, $subref) = @_; + set_style_standard("terse"); + if ($order eq "exec") { + concise_subref('exec', $subref); + } else { + concise_subref('basic', $subref); + } +} + +sub compile { + my @args = @_; + my $order = @args ? shift(@args) : ""; + $order = "-exec" if $order eq "exec"; + unshift @args, $order if $order ne ""; + B::Concise::compile("-terse", @args); +} + +sub indent { + my ($level) = @_ ? shift : 0; + return " " x $level; +} + +# Don't use this, at least on OPs in subroutines: it has no way of +# getting to the pad, and will give wrong answers or crash. +sub B::OP::terse { + carp "B::OP::terse is deprecated; use B::Concise instead"; + B::Concise::b_terse(@_); +} + +sub B::SV::terse { + my($sv, $level) = (@_, 0); + my %info; + B::Concise::concise_sv($sv, \%info); + my $s = indent($level) + . B::Concise::fmt_line(\%info, $sv, + "#svclass~(?((#svaddr))?)~#svval", 0); + chomp $s; + print "$s\n" unless defined wantarray; + $s; +} + +sub B::NULL::terse { + my ($sv, $level) = (@_, 0); + my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv; + print "$s\n" unless defined wantarray; + $s; +} + +sub B::SPECIAL::terse { + my ($sv, $level) = (@_, 0); + my $s = indent($level) + . sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]); + print "$s\n" unless defined wantarray; + $s; +} + +1; + +__END__ + +=head1 NAME + +B::Terse - Walk Perl syntax tree, printing terse info about ops + +=head1 SYNOPSIS + + perl -MO=Terse[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +This version of B::Terse is really just a wrapper that calls B::Concise +with the B<-terse> option. It is provided for compatibility with old scripts +(and habits) but using B::Concise directly is now recommended instead. + +For compatibility with the old B::Terse, this module also adds a +method named C<terse> to B::OP and B::SV objects. The B::SV method is +largely compatible with the old one, though authors of new software +might be advised to choose a more user-friendly output format. The +B::OP C<terse> method, however, doesn't work well. Since B::Terse was +first written, much more information in OPs has migrated to the +scratchpad datastructure, but the C<terse> interface doesn't have any +way of getting to the correct pad. As a kludge, the new version will +always use the pad for the main program, but for OPs in subroutines +this will give the wrong answer or crash. + +=head1 AUTHOR + +The original version of B::Terse was written by Malcolm Beattie, +E<lt>mbeattie@sable.ox.ac.ukE<gt>. This wrapper was written by Stephen +McCamant, E<lt>smcc@MIT.EDUE<gt>. + +=cut diff --git a/Master/tlpkg/installer/perllib/B/Xref.pm b/Master/tlpkg/installer/perllib/B/Xref.pm new file mode 100644 index 00000000000..f727dc766b5 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/Xref.pm @@ -0,0 +1,430 @@ +package B::Xref; + +our $VERSION = '1.01'; + +=head1 NAME + +B::Xref - Generates cross reference reports for Perl programs + +=head1 SYNOPSIS + +perl -MO=Xref[,OPTIONS] foo.pl + +=head1 DESCRIPTION + +The B::Xref module is used to generate a cross reference listing of all +definitions and uses of variables, subroutines and formats in a Perl program. +It is implemented as a backend for the Perl compiler. + +The report generated is in the following format: + + File filename1 + Subroutine subname1 + Package package1 + object1 line numbers + object2 line numbers + ... + Package package2 + ... + +Each B<File> section reports on a single file. Each B<Subroutine> section +reports on a single subroutine apart from the special cases +"(definitions)" and "(main)". These report, respectively, on subroutine +definitions found by the initial symbol table walk and on the main part of +the program or module external to all subroutines. + +The report is then grouped by the B<Package> of each variable, +subroutine or format with the special case "(lexicals)" meaning +lexical variables. Each B<object> name (implicitly qualified by its +containing B<Package>) includes its type character(s) at the beginning +where possible. Lexical variables are easier to track and even +included dereferencing information where possible. + +The C<line numbers> are a comma separated list of line numbers (some +preceded by code letters) where that object is used in some way. +Simple uses aren't preceded by a code letter. Introductions (such as +where a lexical is first defined with C<my>) are indicated with the +letter "i". Subroutine and method calls are indicated by the character +"&". Subroutine definitions are indicated by "s" and format +definitions by "f". + +=head1 OPTIONS + +Option words are separated by commas (not whitespace) and follow the +usual conventions of compiler backend options. + +=over 8 + +=item C<-oFILENAME> + +Directs output to C<FILENAME> instead of standard output. + +=item C<-r> + +Raw output. Instead of producing a human-readable report, outputs a line +in machine-readable form for each definition/use of a variable/sub/format. + +=item C<-d> + +Don't output the "(definitions)" sections. + +=item C<-D[tO]> + +(Internal) debug options, probably only useful if C<-r> included. +The C<t> option prints the object on the top of the stack as it's +being tracked. The C<O> option prints each operator as it's being +processed in the execution order of the program. + +=back + +=head1 BUGS + +Non-lexical variables are quite difficult to track through a program. +Sometimes the type of a non-lexical variable's use is impossible to +determine. Introductions of non-lexical non-scalars don't seem to be +reported properly. + +=head1 AUTHOR + +Malcolm Beattie, mbeattie@sable.ox.ac.uk. + +=cut + +use strict; +use Config; +use B qw(peekop class comppadlist main_start svref_2object walksymtable + OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring + ); + +sub UNKNOWN { ["?", "?", "?"] } + +my @pad; # lexicals in current pad + # as ["(lexical)", type, name] +my %done; # keyed by $$op: set when each $op is done +my $top = UNKNOWN; # shadows top element of stack as + # [pack, type, name] (pack can be "(lexical)") +my $file; # shadows current filename +my $line; # shadows current line number +my $subname; # shadows current sub name +my %table; # Multi-level hash to record all uses etc. +my @todo = (); # List of CVs that need processing + +my %code = (intro => "i", used => "", + subdef => "s", subused => "&", + formdef => "f", meth => "->"); + + +# Options +my ($debug_op, $debug_top, $nodefs, $raw); + +sub process { + my ($var, $event) = @_; + my ($pack, $type, $name) = @$var; + if ($type eq "*") { + if ($event eq "used") { + return; + } elsif ($event eq "subused") { + $type = "&"; + } + } + $type =~ s/(.)\*$/$1/g; + if ($raw) { + printf "%-16s %-12s %5d %-12s %4s %-16s %s\n", + $file, $subname, $line, $pack, $type, $name, $event; + } else { + # Wheee + push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}}, + $line); + } +} + +sub load_pad { + my $padlist = shift; + my ($namelistav, $vallistav, @namelist, $ix); + @pad = (); + return if class($padlist) eq "SPECIAL"; + ($namelistav,$vallistav) = $padlist->ARRAY; + @namelist = $namelistav->ARRAY; + for ($ix = 1; $ix < @namelist; $ix++) { + my $namesv = $namelist[$ix]; + next if class($namesv) eq "SPECIAL"; + my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/; + $pad[$ix] = ["(lexical)", $type || '?', $name || '?']; + } + if ($Config{useithreads}) { + my (@vallist); + @vallist = $vallistav->ARRAY; + for ($ix = 1; $ix < @vallist; $ix++) { + my $valsv = $vallist[$ix]; + next unless class($valsv) eq "GV"; + # these pad GVs don't have corresponding names, so same @pad + # array can be used without collisions + $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME]; + } + } +} + +sub xref { + my $start = shift; + my $op; + for ($op = $start; $$op; $op = $op->next) { + last if $done{$$op}++; + warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top; + warn peekop($op), "\n" if $debug_op; + my $opname = $op->name; + if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) { + xref($op->other); + } elsif ($opname eq "match" || $opname eq "subst") { + xref($op->pmreplstart); + } elsif ($opname eq "substcont") { + xref($op->other->pmreplstart); + $op = $op->other; + redo; + } elsif ($opname eq "enterloop") { + xref($op->redoop); + xref($op->nextop); + xref($op->lastop); + } elsif ($opname eq "subst") { + xref($op->pmreplstart); + } else { + no strict 'refs'; + my $ppname = "pp_$opname"; + &$ppname($op) if defined(&$ppname); + } + } +} + +sub xref_cv { + my $cv = shift; + my $pack = $cv->GV->STASH->NAME; + $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME; + load_pad($cv->PADLIST); + xref($cv->START); + $subname = "(main)"; +} + +sub xref_object { + my $cvref = shift; + xref_cv(svref_2object($cvref)); +} + +sub xref_main { + $subname = "(main)"; + load_pad(comppadlist); + xref(main_start); + while (@todo) { + xref_cv(shift @todo); + } +} + +sub pp_nextstate { + my $op = shift; + $file = $op->file; + $line = $op->line; + $top = UNKNOWN; +} + +sub pp_padsv { + my $op = shift; + $top = $pad[$op->targ]; + process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); +} + +sub pp_padav { pp_padsv(@_) } +sub pp_padhv { pp_padsv(@_) } + +sub deref { + my ($op, $var, $as) = @_; + $var->[1] = $as . $var->[1]; + process($var, $op->private & OPpOUR_INTRO ? "intro" : "used"); +} + +sub pp_rv2cv { deref(shift, $top, "&"); } +sub pp_rv2hv { deref(shift, $top, "%"); } +sub pp_rv2sv { deref(shift, $top, "\$"); } +sub pp_rv2av { deref(shift, $top, "\@"); } +sub pp_rv2gv { deref(shift, $top, "*"); } + +sub pp_gvsv { + my $op = shift; + my $gv; + if ($Config{useithreads}) { + $top = $pad[$op->padix]; + $top = UNKNOWN unless $top; + $top->[1] = '$'; + } + else { + $gv = $op->gv; + $top = [$gv->STASH->NAME, '$', $gv->SAFENAME]; + } + process($top, $op->private & OPpLVAL_INTRO || + $op->private & OPpOUR_INTRO ? "intro" : "used"); +} + +sub pp_gv { + my $op = shift; + my $gv; + if ($Config{useithreads}) { + $top = $pad[$op->padix]; + $top = UNKNOWN unless $top; + $top->[1] = '*'; + } + else { + $gv = $op->gv; + $top = [$gv->STASH->NAME, "*", $gv->SAFENAME]; + } + process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used"); +} + +sub pp_const { + my $op = shift; + my $sv = $op->sv; + # constant could be in the pad (under useithreads) + if ($$sv) { + $top = ["?", "", + (class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK) + ? cstring($sv->PV) : "?"]; + } + else { + $top = $pad[$op->targ]; + $top = UNKNOWN unless $top; + } +} + +sub pp_method { + my $op = shift; + $top = ["(method)", "->".$top->[1], $top->[2]]; +} + +sub pp_entersub { + my $op = shift; + if ($top->[1] eq "m") { + process($top, "meth"); + } else { + process($top, "subused"); + } + $top = UNKNOWN; +} + +# +# Stuff for cross referencing definitions of variables and subs +# + +sub B::GV::xref { + my $gv = shift; + my $cv = $gv->CV; + if ($$cv) { + #return if $done{$$cv}++; + $file = $gv->FILE; + $line = $gv->LINE; + process([$gv->STASH->NAME, "&", $gv->NAME], "subdef"); + push(@todo, $cv); + } + my $form = $gv->FORM; + if ($$form) { + return if $done{$$form}++; + $file = $gv->FILE; + $line = $gv->LINE; + process([$gv->STASH->NAME, "", $gv->NAME], "formdef"); + } +} + +sub xref_definitions { + my ($pack, %exclude); + return if $nodefs; + $subname = "(definitions)"; + foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS + strict vars FileHandle Exporter Carp PerlIO::Layer + attributes utf8 warnings)) { + $exclude{$pack."::"} = 1; + } + no strict qw(vars refs); + walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) }); +} + +sub output { + return if $raw; + my ($file, $subname, $pack, $name, $ev, $perfile, $persubname, + $perpack, $pername, $perev); + foreach $file (sort(keys(%table))) { + $perfile = $table{$file}; + print "File $file\n"; + foreach $subname (sort(keys(%$perfile))) { + $persubname = $perfile->{$subname}; + print " Subroutine $subname\n"; + foreach $pack (sort(keys(%$persubname))) { + $perpack = $persubname->{$pack}; + print " Package $pack\n"; + foreach $name (sort(keys(%$perpack))) { + $pername = $perpack->{$name}; + my @lines; + foreach $ev (qw(intro formdef subdef meth subused used)) { + $perev = $pername->{$ev}; + if (defined($perev) && @$perev) { + my $code = $code{$ev}; + push(@lines, map("$code$_", @$perev)); + } + } + printf " %-16s %s\n", $name, join(", ", @lines); + } + } + } + } +} + +sub compile { + my @options = @_; + my ($option, $opt, $arg); + OPTION: + while ($option = shift @options) { + if ($option =~ /^-(.)(.*)/) { + $opt = $1; + $arg = $2; + } else { + unshift @options, $option; + last OPTION; + } + if ($opt eq "-" && $arg eq "-") { + shift @options; + last OPTION; + } elsif ($opt eq "o") { + $arg ||= shift @options; + open(STDOUT, ">$arg") or return "$arg: $!\n"; + } elsif ($opt eq "d") { + $nodefs = 1; + } elsif ($opt eq "r") { + $raw = 1; + } elsif ($opt eq "D") { + $arg ||= shift @options; + foreach $arg (split(//, $arg)) { + if ($arg eq "o") { + B->debug(1); + } elsif ($arg eq "O") { + $debug_op = 1; + } elsif ($arg eq "t") { + $debug_top = 1; + } + } + } + } + if (@options) { + return sub { + my $objname; + xref_definitions(); + foreach $objname (@options) { + $objname = "main::$objname" unless $objname =~ /::/; + eval "xref_object(\\&$objname)"; + die "xref_object(\\&$objname) failed: $@" if $@; + } + output(); + } + } else { + return sub { + xref_definitions(); + xref_main(); + output(); + } + } +} + +1; diff --git a/Master/tlpkg/installer/perllib/B/assemble b/Master/tlpkg/installer/perllib/B/assemble new file mode 100644 index 00000000000..43cc5bc4b33 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/assemble @@ -0,0 +1,30 @@ +use B::Assembler qw(assemble_fh); +use FileHandle; + +my ($filename, $fh, $out); + +if ($ARGV[0] eq "-d") { + B::Assembler::debug(1); + shift; +} + +$out = \*STDOUT; + +if (@ARGV == 0) { + $fh = \*STDIN; + $filename = "-"; +} elsif (@ARGV == 1) { + $filename = $ARGV[0]; + $fh = new FileHandle "<$filename"; +} elsif (@ARGV == 2) { + $filename = $ARGV[0]; + $fh = new FileHandle "<$filename"; + $out = new FileHandle ">$ARGV[1]"; +} else { + die "Usage: assemble [filename] [outfilename]\n"; +} + +binmode $out; +$SIG{__WARN__} = sub { warn "$filename:@_" }; +$SIG{__DIE__} = sub { die "$filename: @_" }; +assemble_fh($fh, sub { print $out @_ }); diff --git a/Master/tlpkg/installer/perllib/B/cc_harness b/Master/tlpkg/installer/perllib/B/cc_harness new file mode 100644 index 00000000000..79f8727a8f0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/cc_harness @@ -0,0 +1,12 @@ +use Config; + +$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE"; + +if (!grep(/^-[cS]$/, @ARGV)) { + $linkargs = sprintf("%s $libdir/$Config{libperl} %s", + @Config{qw(ldflags libs)}); +} + +$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs"; +print "$cccmd\n"; +exec $cccmd; diff --git a/Master/tlpkg/installer/perllib/B/disassemble b/Master/tlpkg/installer/perllib/B/disassemble new file mode 100644 index 00000000000..6530b809502 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/disassemble @@ -0,0 +1,22 @@ +use B::Disassembler qw(disassemble_fh); +use FileHandle; + +my $fh; +if (@ARGV == 0) { + $fh = \*STDIN; +} elsif (@ARGV == 1) { + $fh = new FileHandle "<$ARGV[0]"; +} else { + die "Usage: disassemble [filename]\n"; +} + +sub print_insn { + my ($insn, $arg) = @_; + if (defined($arg)) { + printf "%s %s\n", $insn, $arg; + } else { + print $insn, "\n"; + } +} + +disassemble_fh($fh, \&print_insn); diff --git a/Master/tlpkg/installer/perllib/B/makeliblinks b/Master/tlpkg/installer/perllib/B/makeliblinks new file mode 100644 index 00000000000..82560783c01 --- /dev/null +++ b/Master/tlpkg/installer/perllib/B/makeliblinks @@ -0,0 +1,54 @@ +use File::Find; +use Config; + +if (@ARGV != 2) { + warn <<"EOT"; +Usage: makeliblinks libautodir targetdir +where libautodir is the architecture-dependent auto directory +(e.g. $Config::Config{archlib}/auto). +EOT + exit 2; +} + +my ($libautodir, $targetdir) = @ARGV; + +# Calculate relative path prefix from $targetdir to $libautodir +sub relprefix { + my ($to, $from) = @_; + my $up; + for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) { + $from =~ s( + [^/]+ (?# a group of non-slashes) + /* (?# maybe with some trailing slashes) + $ (?# at the end of the path) + )()x; + } + return (("../" x $up) . substr($to, length($from))); +} + +my $relprefix = relprefix($libautodir, $targetdir); + +my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)}; + +sub link_if_library { + if (/\.($dlext|$lib_ext)$/o) { + my $ext = $1; + my $name = $File::Find::name; + if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") { + die "directory of $name doesn't match $libautodir\n"; + } + substr($name, 0, length($libautodir) + 1) = ''; + my @parts = split(m(/), $name); + if ($parts[-1] ne "$parts[-2].$ext") { + die "module name $_ doesn't match its directory $libautodir\n"; + } + pop @parts; + my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext"; + print "$libpath -> $relprefix/$name\n"; + symlink("$relprefix/$name", $libpath) + or warn "above link failed with error: $!\n"; + } +} + +find(\&link_if_library, $libautodir); +exit 0; diff --git a/Master/tlpkg/installer/perllib/Class/ISA.pm b/Master/tlpkg/installer/perllib/Class/ISA.pm new file mode 100644 index 00000000000..e1371912e2c --- /dev/null +++ b/Master/tlpkg/installer/perllib/Class/ISA.pm @@ -0,0 +1,214 @@ +#!/usr/local/bin/perl +# Time-stamp: "2004-12-29 20:01:02 AST" -*-Perl-*- + +package Class::ISA; +require 5; +use strict; +use vars qw($Debug $VERSION); +$VERSION = '0.33'; +$Debug = 0 unless defined $Debug; + +=head1 NAME + +Class::ISA -- report the search path for a class's ISA tree + +=head1 SYNOPSIS + + # Suppose you go: use Food::Fishstick, and that uses and + # inherits from other things, which in turn use and inherit + # from other things. And suppose, for sake of brevity of + # example, that their ISA tree is the same as: + + @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals); + @Food::Fish::ISA = qw(Food); + @Food::ISA = qw(Matter); + @Life::Fungus::ISA = qw(Life); + @Chemicals::ISA = qw(Matter); + @Life::ISA = qw(Matter); + @Matter::ISA = qw(); + + use Class::ISA; + print "Food::Fishstick path is:\n ", + join(", ", Class::ISA::super_path('Food::Fishstick')), + "\n"; + +That prints: + + Food::Fishstick path is: + Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals + +=head1 DESCRIPTION + +Suppose you have a class (like Food::Fish::Fishstick) that is derived, +via its @ISA, from one or more superclasses (as Food::Fish::Fishstick +is from Food::Fish, Life::Fungus, and Chemicals), and some of those +superclasses may themselves each be derived, via its @ISA, from one or +more superclasses (as above). + +When, then, you call a method in that class ($fishstick->calories), +Perl first searches there for that method, but if it's not there, it +goes searching in its superclasses, and so on, in a depth-first (or +maybe "height-first" is the word) search. In the above example, it'd +first look in Food::Fish, then Food, then Matter, then Life::Fungus, +then Life, then Chemicals. + +This library, Class::ISA, provides functions that return that list -- +the list (in order) of names of classes Perl would search to find a +method, with no duplicates. + +=head1 FUNCTIONS + +=over + +=item the function Class::ISA::super_path($CLASS) + +This returns the ordered list of names of classes that Perl would +search thru in order to find a method, with no duplicates in the list. +$CLASS is not included in the list. UNIVERSAL is not included -- if +you need to consider it, add it to the end. + + +=item the function Class::ISA::self_and_super_path($CLASS) + +Just like C<super_path>, except that $CLASS is included as the first +element. + +=item the function Class::ISA::self_and_super_versions($CLASS) + +This returns a hash whose keys are $CLASS and its +(super-)superclasses, and whose values are the contents of each +class's $VERSION (or undef, for classes with no $VERSION). + +The code for self_and_super_versions is meant to serve as an example +for precisely the kind of tasks I anticipate that self_and_super_path +and super_path will be used for. You are strongly advised to read the +source for self_and_super_versions, and the comments there. + +=back + +=head1 CAUTIONARY NOTES + +* Class::ISA doesn't export anything. You have to address the +functions with a "Class::ISA::" on the front. + +* Contrary to its name, Class::ISA isn't a class; it's just a package. +Strange, isn't it? + +* Say you have a loop in the ISA tree of the class you're calling one +of the Class::ISA functions on: say that Food inherits from Matter, +but Matter inherits from Food (for sake of argument). If Perl, while +searching for a method, actually discovers this cyclicity, it will +throw a fatal error. The functions in Class::ISA effectively ignore +this cyclicity; the Class::ISA algorithm is "never go down the same +path twice", and cyclicities are just a special case of that. + +* The Class::ISA functions just look at @ISAs. But theoretically, I +suppose, AUTOLOADs could bypass Perl's ISA-based search mechanism and +do whatever they please. That would be bad behavior, tho; and I try +not to think about that. + +* If Perl can't find a method anywhere in the ISA tree, it then looks +in the magical class UNIVERSAL. This is rarely relevant to the tasks +that I expect Class::ISA functions to be put to, but if it matters to +you, then instead of this: + + @supers = Class::Tree::super_path($class); + +do this: + + @supers = (Class::Tree::super_path($class), 'UNIVERSAL'); + +And don't say no-one ever told ya! + +* When you call them, the Class::ISA functions look at @ISAs anew -- +that is, there is no memoization, and so if ISAs change during +runtime, you get the current ISA tree's path, not anything memoized. +However, changing ISAs at runtime is probably a sign that you're out +of your mind! + +=head1 COPYRIGHT + +Copyright (c) 1999, 2000 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + +########################################################################### + +sub self_and_super_versions { + no strict 'refs'; + map { + $_ => (defined(${"$_\::VERSION"}) ? ${"$_\::VERSION"} : undef) + } self_and_super_path($_[0]) +} + +# Also consider magic like: +# no strict 'refs'; +# my %class2SomeHashr = +# map { defined(%{"$_\::SomeHash"}) ? ($_ => \%{"$_\::SomeHash"}) : () } +# Class::ISA::self_and_super_path($class); +# to get a hash of refs to all the defined (and non-empty) hashes in +# $class and its superclasses. +# +# Or even consider this incantation for doing something like hash-data +# inheritance: +# no strict 'refs'; +# %union_hash = +# map { defined(%{"$_\::SomeHash"}) ? %{"$_\::SomeHash"}) : () } +# reverse(Class::ISA::self_and_super_path($class)); +# Consider that reverse() is necessary because with +# %foo = ('a', 'wun', 'b', 'tiw', 'a', 'foist'); +# $foo{'a'} is 'foist', not 'wun'. + +########################################################################### +sub super_path { + my @ret = &self_and_super_path(@_); + shift @ret if @ret; + return @ret; +} + +#-------------------------------------------------------------------------- +sub self_and_super_path { + # Assumption: searching is depth-first. + # Assumption: '' (empty string) can't be a class package name. + # Note: 'UNIVERSAL' is not given any special treatment. + return () unless @_; + + my @out = (); + + my @in_stack = ($_[0]); + my %seen = ($_[0] => 1); + + my $current; + while(@in_stack) { + next unless defined($current = shift @in_stack) && length($current); + print "At $current\n" if $Debug; + push @out, $current; + no strict 'refs'; + unshift @in_stack, + map + { my $c = $_; # copy, to avoid being destructive + substr($c,0,2) = "main::" if substr($c,0,2) eq '::'; + # Canonize the :: -> main::, ::foo -> main::foo thing. + # Should I ever canonize the Foo'Bar = Foo::Bar thing? + $seen{$c}++ ? () : $c; + } + @{"$current\::ISA"} + ; + # I.e., if this class has any parents (at least, ones I've never seen + # before), push them, in order, onto the stack of classes I need to + # explore. + } + + return @out; +} +#-------------------------------------------------------------------------- +1; + +__END__ diff --git a/Master/tlpkg/installer/perllib/Class/Struct.pm b/Master/tlpkg/installer/perllib/Class/Struct.pm new file mode 100644 index 00000000000..7a9af54faf8 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Class/Struct.pm @@ -0,0 +1,636 @@ +package Class::Struct; + +## See POD after __END__ + +use 5.006_001; + +use strict; +use warnings::register; +our(@ISA, @EXPORT, $VERSION); + +use Carp; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(struct); + +$VERSION = '0.63'; + +## Tested on 5.002 and 5.003 without class membership tests: +my $CHECK_CLASS_MEMBERSHIP = ($] >= 5.003_95); + +my $print = 0; +sub printem { + if (@_) { $print = shift } + else { $print++ } +} + +{ + package Class::Struct::Tie_ISA; + + sub TIEARRAY { + my $class = shift; + return bless [], $class; + } + + sub STORE { + my ($self, $index, $value) = @_; + Class::Struct::_subclass_error(); + } + + sub FETCH { + my ($self, $index) = @_; + $self->[$index]; + } + + sub FETCHSIZE { + my $self = shift; + return scalar(@$self); + } + + sub DESTROY { } +} + +sub import { + my $self = shift; + + if ( @_ == 0 ) { + $self->export_to_level( 1, $self, @EXPORT ); + } elsif ( @_ == 1 ) { + # This is admittedly a little bit silly: + # do we ever export anything else than 'struct'...? + $self->export_to_level( 1, $self, @_ ); + } else { + goto &struct; + } +} + +sub struct { + + # Determine parameter list structure, one of: + # struct( class => [ element-list ]) + # struct( class => { element-list }) + # struct( element-list ) + # Latter form assumes current package name as struct name. + + my ($class, @decls); + my $base_type = ref $_[1]; + if ( $base_type eq 'HASH' ) { + $class = shift; + @decls = %{shift()}; + _usage_error() if @_; + } + elsif ( $base_type eq 'ARRAY' ) { + $class = shift; + @decls = @{shift()}; + _usage_error() if @_; + } + else { + $base_type = 'ARRAY'; + $class = (caller())[0]; + @decls = @_; + } + + _usage_error() if @decls % 2 == 1; + + # Ensure we are not, and will not be, a subclass. + + my $isa = do { + no strict 'refs'; + \@{$class . '::ISA'}; + }; + _subclass_error() if @$isa; + tie @$isa, 'Class::Struct::Tie_ISA'; + + # Create constructor. + + croak "function 'new' already defined in package $class" + if do { no strict 'refs'; defined &{$class . "::new"} }; + + my @methods = (); + my %refs = (); + my %arrays = (); + my %hashes = (); + my %classes = (); + my $got_class = 0; + my $out = ''; + + $out = "{\n package $class;\n use Carp;\n sub new {\n"; + $out .= " my (\$class, \%init) = \@_;\n"; + $out .= " \$class = __PACKAGE__ unless \@_;\n"; + + my $cnt = 0; + my $idx = 0; + my( $cmt, $name, $type, $elem ); + + if( $base_type eq 'HASH' ){ + $out .= " my(\$r) = {};\n"; + $cmt = ''; + } + elsif( $base_type eq 'ARRAY' ){ + $out .= " my(\$r) = [];\n"; + } + while( $idx < @decls ){ + $name = $decls[$idx]; + $type = $decls[$idx+1]; + push( @methods, $name ); + if( $base_type eq 'HASH' ){ + $elem = "{'${class}::$name'}"; + } + elsif( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + $cmt = " # $name"; + } + if( $type =~ /^\*(.)/ ){ + $refs{$name}++; + $type = $1; + } + my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :"; + if( $type eq '@' ){ + $out .= " croak 'Initializer for $name must be array reference'\n"; + $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n"; + $out .= " \$r->$elem = $init [];$cmt\n"; + $arrays{$name}++; + } + elsif( $type eq '%' ){ + $out .= " croak 'Initializer for $name must be hash reference'\n"; + $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n"; + $out .= " \$r->$elem = $init {};$cmt\n"; + $hashes{$name}++; + } + elsif ( $type eq '$') { + $out .= " \$r->$elem = $init undef;$cmt\n"; + } + elsif( $type =~ /^\w+(?:::\w+)*$/ ){ + $out .= " if (defined(\$init{'$name'})) {\n"; + $out .= " if (ref \$init{'$name'} eq 'HASH')\n"; + $out .= " { \$r->$elem = $type->new(\%{\$init{'$name'}}) } $cmt\n"; + $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n"; + $out .= " { \$r->$elem = \$init{'$name'} } $cmt\n"; + $out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n"; + $out .= " }\n"; + $classes{$name} = $type; + $got_class = 1; + } + else{ + croak "'$type' is not a valid struct element type"; + } + $idx += 2; + } + $out .= " bless \$r, \$class;\n }\n"; + + # Create accessor methods. + + my( $pre, $pst, $sel ); + $cnt = 0; + foreach $name (@methods){ + if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { + warnings::warnif("function '$name' already defined, overrides struct accessor method"); + } + else { + $pre = $pst = $cmt = $sel = ''; + if( defined $refs{$name} ){ + $pre = "\\("; + $pst = ")"; + $cmt = " # returns ref"; + } + $out .= " sub $name {$cmt\n my \$r = shift;\n"; + if( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + } + elsif( $base_type eq 'HASH' ){ + $elem = "{'${class}::$name'}"; + } + if( defined $arrays{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n"; + $sel = "->[\$i]"; + } + elsif( defined $hashes{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n"; + $sel = "->{\$i}"; + } + elsif( defined $classes{$name} ){ + if ( $CHECK_CLASS_MEMBERSHIP ) { + $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; + } + } + $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; + $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n"; + $out .= " }\n"; + } + } + $out .= "}\n1;\n"; + + print $out if $print; + my $result = eval $out; + carp $@ if $@; +} + +sub _usage_error { + confess "struct usage error"; +} + +sub _subclass_error { + croak 'struct class cannot be a subclass (@ISA not allowed)'; +} + +1; # for require + + +__END__ + +=head1 NAME + +Class::Struct - declare struct-like datatypes as Perl classes + +=head1 SYNOPSIS + + use Class::Struct; + # declare struct, based on array: + struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]); + # declare struct, based on hash: + struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }); + + package CLASS_NAME; + use Class::Struct; + # declare struct, based on array, implicit class name: + struct( ELEMENT_NAME => ELEMENT_TYPE, ... ); + + # Declare struct at compile time + use Class::Struct CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]; + use Class::Struct CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }; + + # declare struct at compile time, based on array, implicit class name: + package CLASS_NAME; + use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ; + + package Myobj; + use Class::Struct; + # declare struct with four types of elements: + struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' ); + + $obj = new Myobj; # constructor + + # scalar type accessor: + $element_value = $obj->s; # element value + $obj->s('new value'); # assign to element + + # array type accessor: + $ary_ref = $obj->a; # reference to whole array + $ary_element_value = $obj->a(2); # array element value + $obj->a(2, 'new value'); # assign to array element + + # hash type accessor: + $hash_ref = $obj->h; # reference to whole hash + $hash_element_value = $obj->h('x'); # hash element value + $obj->h('x', 'new value'); # assign to hash element + + # class type accessor: + $element_value = $obj->c; # object reference + $obj->c->method(...); # call method of object + $obj->c(new My_Other_Class); # assign a new object + +=head1 DESCRIPTION + +C<Class::Struct> exports a single function, C<struct>. +Given a list of element names and types, and optionally +a class name, C<struct> creates a Perl 5 class that implements +a "struct-like" data structure. + +The new class is given a constructor method, C<new>, for creating +struct objects. + +Each element in the struct data has an accessor method, which is +used to assign to the element and to fetch its value. The +default accessor can be overridden by declaring a C<sub> of the +same name in the package. (See Example 2.) + +Each element's type can be scalar, array, hash, or class. + +=head2 The C<struct()> function + +The C<struct> function has three forms of parameter-list. + + struct( CLASS_NAME => [ ELEMENT_LIST ]); + struct( CLASS_NAME => { ELEMENT_LIST }); + struct( ELEMENT_LIST ); + +The first and second forms explicitly identify the name of the +class being created. The third form assumes the current package +name as the class name. + +An object of a class created by the first and third forms is +based on an array, whereas an object of a class created by the +second form is based on a hash. The array-based forms will be +somewhat faster and smaller; the hash-based forms are more +flexible. + +The class created by C<struct> must not be a subclass of another +class other than C<UNIVERSAL>. + +It can, however, be used as a superclass for other classes. To facilitate +this, the generated constructor method uses a two-argument blessing. +Furthermore, if the class is hash-based, the key of each element is +prefixed with the class name (see I<Perl Cookbook>, Recipe 13.12). + +A function named C<new> must not be explicitly defined in a class +created by C<struct>. + +The I<ELEMENT_LIST> has the form + + NAME => TYPE, ... + +Each name-type pair declares one element of the struct. Each +element name will be defined as an accessor method unless a +method by that name is explicitly defined; in the latter case, a +warning is issued if the warning flag (B<-w>) is set. + +=head2 Class Creation at Compile Time + +C<Class::Struct> can create your class at compile time. The main reason +for doing this is obvious, so your class acts like every other class in +Perl. Creating your class at compile time will make the order of events +similar to using any other class ( or Perl module ). + +There is no significant speed gain between compile time and run time +class creation, there is just a new, more standard order of events. + +=head2 Element Types and Accessor Methods + +The four element types -- scalar, array, hash, and class -- are +represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name -- +optionally preceded by a C<'*'>. + +The accessor method provided by C<struct> for an element depends +on the declared type of the element. + +=over 4 + +=item Scalar (C<'$'> or C<'*$'>) + +The element is a scalar, and by default is initialized to C<undef> +(but see L<Initializing with new>). + +The accessor's argument, if any, is assigned to the element. + +If the element type is C<'$'>, the value of the element (after +assignment) is returned. If the element type is C<'*$'>, a reference +to the element is returned. + +=item Array (C<'@'> or C<'*@'>) + +The element is an array, initialized by default to C<()>. + +With no argument, the accessor returns a reference to the +element's whole array (whether or not the element was +specified as C<'@'> or C<'*@'>). + +With one or two arguments, the first argument is an index +specifying one element of the array; the second argument, if +present, is assigned to the array element. If the element type +is C<'@'>, the accessor returns the array element value. If the +element type is C<'*@'>, a reference to the array element is +returned. + +As a special case, when the accessor is called with an array reference +as the sole argument, this causes an assignment of the whole array element. +The object reference is returned. + +=item Hash (C<'%'> or C<'*%'>) + +The element is a hash, initialized by default to C<()>. + +With no argument, the accessor returns a reference to the +element's whole hash (whether or not the element was +specified as C<'%'> or C<'*%'>). + +With one or two arguments, the first argument is a key specifying +one element of the hash; the second argument, if present, is +assigned to the hash element. If the element type is C<'%'>, the +accessor returns the hash element value. If the element type is +C<'*%'>, a reference to the hash element is returned. + +As a special case, when the accessor is called with a hash reference +as the sole argument, this causes an assignment of the whole hash element. +The object reference is returned. + +=item Class (C<'Class_Name'> or C<'*Class_Name'>) + +The element's value must be a reference blessed to the named +class or to one of its subclasses. The element is not initialized +by default. + +The accessor's argument, if any, is assigned to the element. The +accessor will C<croak> if this is not an appropriate object +reference. + +If the element type does not start with a C<'*'>, the accessor +returns the element value (after assignment). If the element type +starts with a C<'*'>, a reference to the element itself is returned. + +=back + +=head2 Initializing with C<new> + +C<struct> always creates a constructor called C<new>. That constructor +may take a list of initializers for the various elements of the new +struct. + +Each initializer is a pair of values: I<element name>C< =E<gt> >I<value>. +The initializer value for a scalar element is just a scalar value. The +initializer for an array element is an array reference. The initializer +for a hash is a hash reference. + +The initializer for a class element is an object of the corresponding class, +or of one of it's subclasses, or a reference to a hash containing named +arguments to be passed to the element's constructor. + +See Example 3 below for an example of initialization. + +=head1 EXAMPLES + +=over 4 + +=item Example 1 + +Giving a struct element a class type that is also a struct is how +structs are nested. Here, C<Timeval> represents a time (seconds and +microseconds), and C<Rusage> has two elements, each of which is of +type C<Timeval>. + + use Class::Struct; + + struct( Rusage => { + ru_utime => 'Timeval', # user time used + ru_stime => 'Timeval', # system time used + }); + + struct( Timeval => [ + tv_secs => '$', # seconds + tv_usecs => '$', # microseconds + ]); + + # create an object: + my $t = Rusage->new(ru_utime=>Timeval->new(), ru_stime=>Timeval->new()); + + # $t->ru_utime and $t->ru_stime are objects of type Timeval. + # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec. + $t->ru_utime->tv_secs(100); + $t->ru_utime->tv_usecs(0); + $t->ru_stime->tv_secs(5); + $t->ru_stime->tv_usecs(0); + +=item Example 2 + +An accessor function can be redefined in order to provide +additional checking of values, etc. Here, we want the C<count> +element always to be nonnegative, so we redefine the C<count> +accessor accordingly. + + package MyObj; + use Class::Struct; + + # declare the struct + struct ( 'MyObj', { count => '$', stuff => '%' } ); + + # override the default accessor method for 'count' + sub count { + my $self = shift; + if ( @_ ) { + die 'count must be nonnegative' if $_[0] < 0; + $self->{'MyObj::count'} = shift; + warn "Too many args to count" if @_; + } + return $self->{'MyObj::count'}; + } + + package main; + $x = new MyObj; + print "\$x->count(5) = ", $x->count(5), "\n"; + # prints '$x->count(5) = 5' + + print "\$x->count = ", $x->count, "\n"; + # prints '$x->count = 5' + + print "\$x->count(-5) = ", $x->count(-5), "\n"; + # dies due to negative argument! + +=item Example 3 + +The constructor of a generated class can be passed a list +of I<element>=>I<value> pairs, with which to initialize the struct. +If no initializer is specified for a particular element, its default +initialization is performed instead. Initializers for non-existent +elements are silently ignored. + +Note that the initializer for a nested class may be specified as +an object of that class, or as a reference to a hash of initializers +that are passed on to the nested struct's constructor. + + use Class::Struct; + + struct Breed => + { + name => '$', + cross => '$', + }; + + struct Cat => + [ + name => '$', + kittens => '@', + markings => '%', + breed => 'Breed', + ]; + + + my $cat = Cat->new( name => 'Socks', + kittens => ['Monica', 'Kenneth'], + markings => { socks=>1, blaze=>"white" }, + breed => Breed->new(name=>'short-hair', cross=>1), + or: breed => {name=>'short-hair', cross=>1}, + ); + + print "Once a cat called ", $cat->name, "\n"; + print "(which was a ", $cat->breed->name, ")\n"; + print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n"; + +=back + +=head1 Author and Modification History + +Modified by Damian Conway, 2001-09-10, v0.62. + + Modified implicit construction of nested objects. + Now will also take an object ref instead of requiring a hash ref. + Also default initializes nested object attributes to undef, rather + than calling object constructor without args + Original over-helpfulness was fraught with problems: + * the class's constructor might not be called 'new' + * the class might not have a hash-like-arguments constructor + * the class might not have a no-argument constructor + * "recursive" data structures didn't work well: + package Person; + struct { mother => 'Person', father => 'Person'}; + + +Modified by Casey West, 2000-11-08, v0.59. + + Added the ability for compile time class creation. + +Modified by Damian Conway, 1999-03-05, v0.58. + + Added handling of hash-like arg list to class ctor. + + Changed to two-argument blessing in ctor to support + derivation from created classes. + + Added classname prefixes to keys in hash-based classes + (refer to "Perl Cookbook", Recipe 13.12 for rationale). + + Corrected behaviour of accessors for '*@' and '*%' struct + elements. Package now implements documented behaviour when + returning a reference to an entire hash or array element. + Previously these were returned as a reference to a reference + to the element. + +Renamed to C<Class::Struct> and modified by Jim Miner, 1997-04-02. + + members() function removed. + Documentation corrected and extended. + Use of struct() in a subclass prohibited. + User definition of accessor allowed. + Treatment of '*' in element types corrected. + Treatment of classes as element types corrected. + Class name to struct() made optional. + Diagnostic checks added. + +Originally C<Class::Template> by Dean Roehrich. + + # Template.pm --- struct/member template builder + # 12mar95 + # Dean Roehrich + # + # changes/bugs fixed since 28nov94 version: + # - podified + # changes/bugs fixed since 21nov94 version: + # - Fixed examples. + # changes/bugs fixed since 02sep94 version: + # - Moved to Class::Template. + # changes/bugs fixed since 20feb94 version: + # - Updated to be a more proper module. + # - Added "use strict". + # - Bug in build_methods, was using @var when @$var needed. + # - Now using my() rather than local(). + # + # Uses perl5 classes to create nested data types. + # This is offered as one implementation of Tom Christiansen's "structs.pl" + # idea. + +=cut diff --git a/Master/tlpkg/installer/perllib/Config_heavy.pl b/Master/tlpkg/installer/perllib/Config_heavy.pl new file mode 100644 index 00000000000..919d4637cf2 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Config_heavy.pl @@ -0,0 +1,1185 @@ +# This file was created by configpm when Perl was built. Any changes +# made to this file will be lost the next time perl is built. + +package Config; +use strict; +# use warnings; Pulls in Carp +# use vars pulls in Carp +### Configured by: siepo@xpeco +### Target system: WIN32 + +our $summary = <<'!END!'; +Summary of my $package (revision $revision $version_patchlevel_string) configuration: + Platform: + osname=$osname, osvers=$osvers, archname=$archname + uname='$myuname' + config_args='$config_args' + hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction + usethreads=$usethreads use5005threads=$use5005threads useithreads=$useithreads usemultiplicity=$usemultiplicity + useperlio=$useperlio d_sfio=$d_sfio uselargefiles=$uselargefiles usesocks=$usesocks + use64bitint=$use64bitint use64bitall=$use64bitall uselongdouble=$uselongdouble + usemymalloc=$usemymalloc, bincompat5005=undef + Compiler: + cc='$cc', ccflags ='$ccflags', + optimize='$optimize', + cppflags='$cppflags' + ccversion='$ccversion', gccversion='$gccversion', gccosandvers='$gccosandvers' + intsize=$intsize, longsize=$longsize, ptrsize=$ptrsize, doublesize=$doublesize, byteorder=$byteorder + d_longlong=$d_longlong, longlongsize=$longlongsize, d_longdbl=$d_longdbl, longdblsize=$longdblsize + ivtype='$ivtype', ivsize=$ivsize, nvtype='$nvtype', nvsize=$nvsize, Off_t='$lseektype', lseeksize=$lseeksize + alignbytes=$alignbytes, prototype=$prototype + Linker and Libraries: + ld='$ld', ldflags ='$ldflags' + libpth=$libpth + libs=$libs + perllibs=$perllibs + libc=$libc, so=$so, useshrplib=$useshrplib, libperl=$libperl + gnulibc_version='$gnulibc_version' + Dynamic Linking: + dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags' + cccdlflags='$cccdlflags', lddlflags='$lddlflags' + +!END! +my $summary_expanded; + +sub myconfig { + return $summary_expanded if $summary_expanded; + ($summary_expanded = $summary) =~ s{\$(\w+)} + { my $c = $Config::Config{$1}; defined($c) ? $c : 'undef' }ge; + $summary_expanded; +} + +local *_ = \my $a; +$_ = <<'!END!'; +Author='' +CONFIG='true' +Date='$Date' +Header='' +Id='$Id' +Locker='' +Log='$Log' +Mcc='Mcc' +PATCHLEVEL='8' +PERL_API_REVISION='5' +PERL_API_SUBVERSION='0' +PERL_API_VERSION='8' +PERL_CONFIG_SH='true' +PERL_PATCHLEVEL='8' +PERL_REVISION='5' +PERL_SUBVERSION='8' +PERL_VERSION='8' +RCSfile='$RCSfile' +Revision='$Revision' +SUBVERSION='8' +Source='' +State='' +_a='.a' +_exe='.exe' +_o='.o' +afs='false' +afsroot='/afs' +alignbytes='8' +ansi2knr='' +aphostname='' +api_revision='5' +api_subversion='0' +api_version='8' +api_versionstring='5.8.0' +ar='ar' +archlib='x:\perl\lib' +archlibexp='x:\perl\lib' +archname64='' +archname='MSWin32-x86-multi-thread' +archobjs='' +asctime_r_proto='0' +awk='awk' +baserev='5' +bash='' +bin='x:\perl\bin' +binexp='x:\perl\bin' +bison='' +byacc='byacc' +byteorder='1234' +c='' +castflags='0' +cat='type' +cc='gcc' +cccdlflags=' ' +ccdlflags=' ' +ccflags=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DPERL_IMPLICIT_CONTEXT -fno-strict-aliasing -DPERL_MSVCRT_READFIX' +ccflags_uselargefiles='' +ccname='gcc' +ccsymbols='' +ccversion='' +cf_by='siepo' +cf_email='siepo@xpeco' +cf_time='Sun May 27 17:53:00 2007' +charsize='1' +chgrp='' +chmod='' +chown='' +clocktype='clock_t' +comm='' +compress='' +contains='grep' +cp='copy' +cpio='' +cpp='gcc -E' +cpp_stuff='42' +cppccsymbols='' +cppflags='-DWIN32' +cpplast='' +cppminus='-' +cpprun='gcc -E' +cppstdin='gcc -E' +cppsymbols='' +crypt_r_proto='0' +cryptlib='' +csh='undef' +ctermid_r_proto='0' +ctime_r_proto='0' +d_Gconvert='sprintf((b),"%.*g",(n),(x))' +d_PRIEUldbl='undef' +d_PRIFUldbl='undef' +d_PRIGUldbl='undef' +d_PRIXU64='undef' +d_PRId64='undef' +d_PRIeldbl='undef' +d_PRIfldbl='undef' +d_PRIgldbl='undef' +d_PRIi64='undef' +d_PRIo64='undef' +d_PRIu64='undef' +d_PRIx64='undef' +d_SCNfldbl='undef' +d__fwalk='undef' +d_access='define' +d_accessx='undef' +d_aintl='undef' +d_alarm='define' +d_archlib='define' +d_asctime_r='undef' +d_atolf='undef' +d_atoll='undef' +d_attribute_format='undef' +d_attribute_malloc='undef' +d_attribute_nonnull='undef' +d_attribute_noreturn='undef' +d_attribute_pure='undef' +d_attribute_unused='undef' +d_attribute_warn_unused_result='undef' +d_bcmp='undef' +d_bcopy='undef' +d_bsd='define' +d_bsdgetpgrp='undef' +d_bsdsetpgrp='undef' +d_bzero='undef' +d_casti32='define' +d_castneg='define' +d_charvspr='undef' +d_chown='undef' +d_chroot='undef' +d_chsize='define' +d_class='undef' +d_clearenv='undef' +d_closedir='define' +d_cmsghdr_s='undef' +d_const='define' +d_copysignl='undef' +d_crypt='define' +d_crypt_r='undef' +d_csh='undef' +d_ctermid_r='undef' +d_ctime_r='undef' +d_cuserid='undef' +d_dbl_dig='define' +d_dbminitproto='undef' +d_difftime='define' +d_dirfd='undef' +d_dirnamlen='define' +d_dlerror='define' +d_dlopen='define' +d_dlsymun='undef' +d_dosuid='undef' +d_drand48_r='undef' +d_drand48proto='undef' +d_dup2='define' +d_eaccess='undef' +d_endgrent='undef' +d_endgrent_r='undef' +d_endhent='undef' +d_endhostent_r='undef' +d_endnent='undef' +d_endnetent_r='undef' +d_endpent='undef' +d_endprotoent_r='undef' +d_endpwent='undef' +d_endpwent_r='undef' +d_endsent='undef' +d_endservent_r='undef' +d_eofnblk='define' +d_eunice='undef' +d_faststdio='define' +d_fchdir='undef' +d_fchmod='undef' +d_fchown='undef' +d_fcntl='undef' +d_fcntl_can_lock='undef' +d_fd_macros='define' +d_fd_set='define' +d_fds_bits='define' +d_fgetpos='define' +d_finite='undef' +d_finitel='undef' +d_flexfnam='define' +d_flock='define' +d_flockproto='define' +d_fork='undef' +d_fp_class='undef' +d_fpathconf='undef' +d_fpclass='undef' +d_fpclassify='undef' +d_fpclassl='undef' +d_fpos64_t='undef' +d_frexpl='undef' +d_fs_data_s='undef' +d_fseeko='undef' +d_fsetpos='define' +d_fstatfs='undef' +d_fstatvfs='undef' +d_fsync='undef' +d_ftello='undef' +d_ftime='define' +d_futimes='undef' +d_getcwd='define' +d_getespwnam='undef' +d_getfsstat='undef' +d_getgrent='undef' +d_getgrent_r='undef' +d_getgrgid_r='undef' +d_getgrnam_r='undef' +d_getgrps='undef' +d_gethbyaddr='define' +d_gethbyname='define' +d_gethent='undef' +d_gethname='define' +d_gethostbyaddr_r='undef' +d_gethostbyname_r='undef' +d_gethostent_r='undef' +d_gethostprotos='define' +d_getitimer='undef' +d_getlogin='define' +d_getlogin_r='undef' +d_getmnt='undef' +d_getmntent='undef' +d_getnbyaddr='undef' +d_getnbyname='undef' +d_getnent='undef' +d_getnetbyaddr_r='undef' +d_getnetbyname_r='undef' +d_getnetent_r='undef' +d_getnetprotos='undef' +d_getpagsz='undef' +d_getpbyname='define' +d_getpbynumber='define' +d_getpent='undef' +d_getpgid='undef' +d_getpgrp2='undef' +d_getpgrp='undef' +d_getppid='undef' +d_getprior='undef' +d_getprotobyname_r='undef' +d_getprotobynumber_r='undef' +d_getprotoent_r='undef' +d_getprotoprotos='define' +d_getprpwnam='undef' +d_getpwent='undef' +d_getpwent_r='undef' +d_getpwnam_r='undef' +d_getpwuid_r='undef' +d_getsbyname='define' +d_getsbyport='define' +d_getsent='undef' +d_getservbyname_r='undef' +d_getservbyport_r='undef' +d_getservent_r='undef' +d_getservprotos='define' +d_getspnam='undef' +d_getspnam_r='undef' +d_gettimeod='define' +d_gmtime_r='undef' +d_gnulibc='undef' +d_grpasswd='undef' +d_hasmntopt='undef' +d_htonl='define' +d_ilogbl='undef' +d_index='undef' +d_inetaton='undef' +d_int64_t='undef' +d_isascii='define' +d_isfinite='undef' +d_isinf='undef' +d_isnan='define' +d_isnanl='undef' +d_killpg='undef' +d_lchown='undef' +d_ldbl_dig='define' +d_libm_lib_version='undef' +d_link='define' +d_localtime_r='undef' +d_locconv='define' +d_lockf='undef' +d_longdbl='define' +d_longlong='undef' +d_lseekproto='define' +d_lstat='undef' +d_madvise='undef' +d_malloc_good_size='undef' +d_malloc_size='undef' +d_mblen='define' +d_mbstowcs='define' +d_mbtowc='define' +d_memchr='define' +d_memcmp='define' +d_memcpy='define' +d_memmove='define' +d_memset='define' +d_mkdir='define' +d_mkdtemp='undef' +d_mkfifo='undef' +d_mkstemp='undef' +d_mkstemps='undef' +d_mktime='define' +d_mmap='undef' +d_modfl='undef' +d_modfl_pow32_bug='undef' +d_modflproto='undef' +d_mprotect='undef' +d_msg='undef' +d_msg_ctrunc='undef' +d_msg_dontroute='undef' +d_msg_oob='undef' +d_msg_peek='undef' +d_msg_proxy='undef' +d_msgctl='undef' +d_msgget='undef' +d_msghdr_s='undef' +d_msgrcv='undef' +d_msgsnd='undef' +d_msync='undef' +d_munmap='undef' +d_mymalloc='undef' +d_nice='undef' +d_nl_langinfo='undef' +d_nv_preserves_uv='define' +d_nv_zero_is_allbits_zero='define' +d_off64_t='undef' +d_old_pthread_create_joinable='undef' +d_oldpthreads='undef' +d_oldsock='undef' +d_open3='undef' +d_pathconf='undef' +d_pause='define' +d_perl_otherlibdirs='undef' +d_phostname='undef' +d_pipe='define' +d_poll='undef' +d_portable='define' +d_procselfexe='undef' +d_pthread_atfork='undef' +d_pthread_attr_setscope='undef' +d_pthread_yield='undef' +d_pwage='undef' +d_pwchange='undef' +d_pwclass='undef' +d_pwcomment='undef' +d_pwexpire='undef' +d_pwgecos='undef' +d_pwpasswd='undef' +d_pwquota='undef' +d_qgcvt='undef' +d_quad='undef' +d_random_r='undef' +d_readdir64_r='undef' +d_readdir='define' +d_readdir_r='undef' +d_readlink='undef' +d_readv='undef' +d_recvmsg='undef' +d_rename='define' +d_rewinddir='define' +d_rmdir='define' +d_safebcpy='undef' +d_safemcpy='undef' +d_sanemcmp='define' +d_sbrkproto='undef' +d_scalbnl='undef' +d_sched_yield='undef' +d_scm_rights='undef' +d_seekdir='define' +d_select='define' +d_sem='undef' +d_semctl='undef' +d_semctl_semid_ds='undef' +d_semctl_semun='undef' +d_semget='undef' +d_semop='undef' +d_sendmsg='undef' +d_setegid='undef' +d_seteuid='undef' +d_setgrent='undef' +d_setgrent_r='undef' +d_setgrps='undef' +d_sethent='undef' +d_sethostent_r='undef' +d_setitimer='undef' +d_setlinebuf='undef' +d_setlocale='define' +d_setlocale_r='undef' +d_setnent='undef' +d_setnetent_r='undef' +d_setpent='undef' +d_setpgid='undef' +d_setpgrp2='undef' +d_setpgrp='undef' +d_setprior='undef' +d_setproctitle='undef' +d_setprotoent_r='undef' +d_setpwent='undef' +d_setpwent_r='undef' +d_setregid='undef' +d_setresgid='undef' +d_setresuid='undef' +d_setreuid='undef' +d_setrgid='undef' +d_setruid='undef' +d_setsent='undef' +d_setservent_r='undef' +d_setsid='undef' +d_setvbuf='define' +d_sfio='undef' +d_shm='undef' +d_shmat='undef' +d_shmatprototype='undef' +d_shmctl='undef' +d_shmdt='undef' +d_shmget='undef' +d_sigaction='undef' +d_sigprocmask='undef' +d_sigsetjmp='undef' +d_sockatmark='undef' +d_sockatmarkproto='undef' +d_socket='define' +d_socklen_t='undef' +d_sockpair='undef' +d_socks5_init='undef' +d_sprintf_returns_strlen='define' +d_sqrtl='undef' +d_srand48_r='undef' +d_srandom_r='undef' +d_sresgproto='undef' +d_sresuproto='undef' +d_statblks='undef' +d_statfs_f_flags='undef' +d_statfs_s='undef' +d_statvfs='undef' +d_stdio_cnt_lval='define' +d_stdio_ptr_lval='define' +d_stdio_ptr_lval_nochange_cnt='define' +d_stdio_ptr_lval_sets_cnt='undef' +d_stdio_stream_array='undef' +d_stdiobase='define' +d_stdstdio='define' +d_strchr='define' +d_strcoll='define' +d_strctcpy='define' +d_strerrm='strerror(e)' +d_strerror='define' +d_strerror_r='undef' +d_strftime='define' +d_strlcat='undef' +d_strlcpy='undef' +d_strtod='define' +d_strtol='define' +d_strtold='undef' +d_strtoll='undef' +d_strtoq='undef' +d_strtoul='define' +d_strtoull='undef' +d_strtouq='undef' +d_strxfrm='define' +d_suidsafe='undef' +d_symlink='undef' +d_syscall='undef' +d_syscallproto='undef' +d_sysconf='undef' +d_sysernlst='' +d_syserrlst='define' +d_system='define' +d_tcgetpgrp='undef' +d_tcsetpgrp='undef' +d_telldir='define' +d_telldirproto='define' +d_time='define' +d_times='define' +d_tm_tm_gmtoff='undef' +d_tm_tm_zone='undef' +d_tmpnam_r='undef' +d_truncate='undef' +d_ttyname_r='undef' +d_tzname='define' +d_u32align='define' +d_ualarm='undef' +d_umask='define' +d_uname='define' +d_union_semun='define' +d_unordered='undef' +d_unsetenv='undef' +d_usleep='undef' +d_usleepproto='undef' +d_ustat='undef' +d_vendorarch='undef' +d_vendorbin='undef' +d_vendorlib='undef' +d_vendorscript='undef' +d_vfork='undef' +d_void_closedir='undef' +d_voidsig='define' +d_voidtty='' +d_volatile='define' +d_vprintf='define' +d_wait4='undef' +d_waitpid='define' +d_wcstombs='define' +d_wctomb='define' +d_writev='undef' +d_xenix='undef' +date='date' +db_hashtype='int' +db_prefixtype='int' +db_version_major='0' +db_version_minor='0' +db_version_patch='0' +defvoidused='15' +direntrytype='struct direct' +dlext='dll' +dlsrc='dl_win32.xs' +doublesize='8' +drand01='(rand()/(double)((unsigned)1<<RANDBITS))' +drand48_r_proto='0' +dynamic_ext='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call IO List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attrs re threads threads/shared' +eagain='EAGAIN' +ebcdic='undef' +echo='echo' +egrep='egrep' +emacs='' +endgrent_r_proto='0' +endhostent_r_proto='0' +endnetent_r_proto='0' +endprotoent_r_proto='0' +endpwent_r_proto='0' +endservent_r_proto='0' +eunicefix=':' +exe_ext='.exe' +expr='expr' +extensions='B ByteLoader Cwd Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Errno Fcntl File/Glob Filter/Util/Call IO List/Util MIME/Base64 Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attrs re threads threads/shared' +extras='' +fflushNULL='define' +fflushall='undef' +find='find' +firstmakefile='makefile' +flex='' +fpossize='8' +fpostype='fpos_t' +freetype='void' +from=':' +full_ar='' +full_csh='' +full_sed='' +gccansipedantic='' +gccosandvers='' +gccversion='3.4.5' +getgrent_r_proto='0' +getgrgid_r_proto='0' +getgrnam_r_proto='0' +gethostbyaddr_r_proto='0' +gethostbyname_r_proto='0' +gethostent_r_proto='0' +getlogin_r_proto='0' +getnetbyaddr_r_proto='0' +getnetbyname_r_proto='0' +getnetent_r_proto='0' +getprotobyname_r_proto='0' +getprotobynumber_r_proto='0' +getprotoent_r_proto='0' +getpwent_r_proto='0' +getpwnam_r_proto='0' +getpwuid_r_proto='0' +getservbyname_r_proto='0' +getservbyport_r_proto='0' +getservent_r_proto='0' +getspnam_r_proto='0' +gidformat='"ld"' +gidsign='-1' +gidsize='4' +gidtype='gid_t' +glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib ' +gmake='gmake' +gmtime_r_proto='0' +gnulibc_version='' +grep='grep' +groupcat='' +groupstype='gid_t' +gzip='gzip' +h_fcntl='false' +h_sysfile='true' +hint='recommended' +hostcat='ypcat hosts' +html1dir=' ' +html1direxp='' +html3dir=' ' +html3direxp='' +i16size='2' +i16type='short' +i32size='4' +i32type='long' +i64size='8' +i64type='long long' +i8size='1' +i8type='char' +i_arpainet='define' +i_bsdioctl='' +i_crypt='undef' +i_db='undef' +i_dbm='undef' +i_dirent='define' +i_dld='undef' +i_dlfcn='define' +i_fcntl='define' +i_float='define' +i_fp='undef' +i_fp_class='undef' +i_gdbm='undef' +i_grp='undef' +i_ieeefp='undef' +i_inttypes='undef' +i_langinfo='undef' +i_libutil='undef' +i_limits='define' +i_locale='define' +i_machcthr='undef' +i_malloc='define' +i_math='define' +i_memory='undef' +i_mntent='undef' +i_ndbm='undef' +i_netdb='undef' +i_neterrno='undef' +i_netinettcp='undef' +i_niin='undef' +i_poll='undef' +i_prot='undef' +i_pthread='undef' +i_pwd='undef' +i_rpcsvcdbm='define' +i_sfio='undef' +i_sgtty='undef' +i_shadow='undef' +i_socks='undef' +i_stdarg='define' +i_stddef='define' +i_stdlib='define' +i_string='define' +i_sunmath='undef' +i_sysaccess='undef' +i_sysdir='undef' +i_sysfile='undef' +i_sysfilio='define' +i_sysin='undef' +i_sysioctl='undef' +i_syslog='undef' +i_sysmman='undef' +i_sysmode='undef' +i_sysmount='undef' +i_sysndir='undef' +i_sysparam='undef' +i_sysresrc='undef' +i_syssecrt='undef' +i_sysselct='undef' +i_syssockio='undef' +i_sysstat='define' +i_sysstatfs='undef' +i_sysstatvfs='undef' +i_systime='undef' +i_systimek='undef' +i_systimes='undef' +i_systypes='define' +i_sysuio='undef' +i_sysun='undef' +i_sysutsname='undef' +i_sysvfs='undef' +i_syswait='undef' +i_termio='undef' +i_termios='undef' +i_time='define' +i_unistd='undef' +i_ustat='undef' +i_utime='define' +i_values='undef' +i_varargs='undef' +i_varhdr='varargs.h' +i_vfork='undef' +ignore_versioned_solibs='' +inc_version_list='' +inc_version_list_init='0' +incpath='x:\msys\mingw\include' +inews='' +installarchlib='x:\perl\lib' +installbin='x:\perl\bin' +installhtml1dir='' +installhtml3dir='' +installhtmldir='x:\perl\html' +installhtmlhelpdir='x:\perl\htmlhelp' +installman1dir='x:\perl\man\man1' +installman3dir='x:\perl\man\man3' +installprefix='x:\perl' +installprefixexp='x:\perl' +installprivlib='x:\perl\lib' +installscript='x:\perl\bin' +installsitearch='x:\perl\site\lib' +installsitebin='x:\perl\bin' +installsitehtml1dir='' +installsitehtml3dir='' +installsitelib='x:\perl\site\lib' +installsiteman1dir='' +installsiteman3dir='' +installsitescript='' +installstyle='lib' +installusrbinperl='undef' +installvendorarch='' +installvendorbin='' +installvendorhtml1dir='' +installvendorhtml3dir='' +installvendorlib='' +installvendorman1dir='' +installvendorman3dir='' +installvendorscript='' +intsize='4' +issymlink='' +ivdformat='"ld"' +ivsize='4' +ivtype='long' +known_extensions='B ByteLoader Cwd DB_File Data/Dumper Devel/DProf Devel/PPPort Devel/Peek Digest/MD5 Encode Fcntl File/Glob Filter/Util/Call GDBM_File I18N/Langinfo IO IPC/SysV List/Util MIME/Base64 NDBM_File ODBM_File Opcode POSIX PerlIO/encoding PerlIO/scalar PerlIO/via SDBM_File Socket Storable Sys/Hostname Sys/Syslog Thread Time/HiRes Unicode/Normalize XS/APItest XS/Typemap attrs re threads threads/shared' +ksh='' +ld='g++' +lddlflags='-mdll -s -L"x:\perl\lib\CORE" -L"x:\msys\mingw\lib"' +ldflags='-s -L"x:\perl\lib\CORE" -L"x:\msys\mingw\lib"' +ldflags_uselargefiles='' +ldlibpthname='' +less='less' +lib_ext='.a' +libc='-lmsvcrt' +libperl='libperl58.a' +libpth='x:\msys\mingw\lib' +libs=' -lmsvcrt -lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32' +libsdirs='' +libsfiles='' +libsfound='' +libspath='' +libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x' +libswanted_uselargefiles='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x' +line='line' +lint='' +lkflags='' +ln='' +lns='copy' +localtime_r_proto='0' +locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include' +loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib' +longdblsize='12' +longlongsize='8' +longsize='4' +lp='' +lpr='' +ls='dir' +lseeksize='8' +lseektype='long long' +mail='' +mailx='' +make='dmake' +make_set_make='#' +mallocobj='malloc.o' +mallocsrc='malloc.c' +malloctype='void *' +man1dir='x:\perl\man\man1' +man1direxp='x:\perl\man\man1' +man1ext='1' +man3dir='x:\perl\man\man3' +man3direxp='x:\perl\man\man3' +man3ext='3' +mips_type='' +mistrustnm='' +mkdir='mkdir' +mmaptype='void *' +modetype='mode_t' +more='more /e' +multiarch='undef' +mv='' +myarchname='MSWin32' +mydomain='' +myhostname='' +myuname='' +n='-n' +need_va_copy='undef' +netdb_hlen_type='int' +netdb_host_type='char *' +netdb_name_type='char *' +netdb_net_type='long' +nm='nm' +nm_opt='' +nm_so_opt='' +nonxs_ext='Errno' +nroff='' +nvEUformat='"E"' +nvFUformat='"F"' +nvGUformat='"G"' +nv_preserves_uv_bits='32' +nveformat='"e"' +nvfformat='"f"' +nvgformat='"g"' +nvsize='8' +nvtype='double' +o_nonblock='O_NONBLOCK' +obj_ext='.o' +old_pthread_create_joinable='' +optimize='-s -O2' +orderlib='false' +osname='MSWin32' +osvers='5.1' +otherlibdirs='' +package='perl5' +pager='more /e' +passcat='' +patchlevel='' +path_sep=';' +perl5='' +perl='perl' +perl_patchlevel='' +perladmin='' +perllibs=' -lmsvcrt -lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32' +perlpath='x:\perl\bin\perl.exe' +pg='' +phostname='hostname' +pidtype='int' +plibpth='' +pmake='' +pr='' +prefix='x:\perl' +prefixexp='x:\perl' +privlib='x:\perl\lib' +privlibexp='x:\perl\lib' +procselfexe='' +prototype='define' +ptrsize='4' +quadkind='5' +quadtype='long long' +randbits='15' +randfunc='rand' +random_r_proto='0' +randseedtype='unsigned' +ranlib='rem' +rd_nodata='-1' +readdir64_r_proto='0' +readdir_r_proto='0' +revision='5' +rm='del' +rmail='' +run='' +runnm='true' +sPRIEUldbl='"E"' +sPRIFUldbl='"F"' +sPRIGUldbl='"G"' +sPRIXU64='"lX"' +sPRId64='"ld"' +sPRIeldbl='"e"' +sPRIfldbl='"f"' +sPRIgldbl='"g"' +sPRIi64='"li"' +sPRIo64='"lo"' +sPRIu64='"lu"' +sPRIx64='"lx"' +sSCNfldbl='"f"' +sched_yield='' +scriptdir='x:\perl\bin' +scriptdirexp='x:\perl\bin' +sed='sed' +seedfunc='srand' +selectminbits='32' +selecttype='Perl_fd_set *' +sendmail='blat' +setgrent_r_proto='0' +sethostent_r_proto='0' +setlocale_r_proto='0' +setnetent_r_proto='0' +setprotoent_r_proto='0' +setpwent_r_proto='0' +setservent_r_proto='0' +sh='cmd /x /c' +shar='' +sharpbang='#!' +shmattype='void *' +shortsize='2' +shrpenv='' +shsharp='true' +sig_count='26' +sig_name='ZERO HUP INT QUIT ILL NUM05 NUM06 NUM07 FPE KILL NUM10 SEGV NUM12 PIPE ALRM TERM NUM16 NUM17 NUM18 NUM19 CHLD BREAK ABRT STOP NUM24 CONT CLD' +sig_name_init='"ZERO", "HUP", "INT", "QUIT", "ILL", "NUM05", "NUM06", "NUM07", "FPE", "KILL", "NUM10", "SEGV", "NUM12", "PIPE", "ALRM", "TERM", "NUM16", "NUM17", "NUM18", "NUM19", "CHLD", "BREAK", "ABRT", "STOP", "NUM24", "CONT", "CLD", 0' +sig_num='0 1 2 21 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 20' +sig_num_init='0, 1, 2, 21, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 20, 0' +sig_size='27' +signal_t='void' +sitearch='x:\perl\site\lib' +sitearchexp='x:\perl\site\lib' +sitebin='x:\perl\site\bin' +sitebinexp='x:\perl\site\bin' +sitehtml1dir='' +sitehtml1direxp='' +sitehtml3dir='' +sitehtml3direxp='' +sitelib='x:\perl\site\lib' +sitelib_stem='' +sitelibexp='x:\perl\site\lib' +siteman1dir='' +siteman1direxp='' +siteman3dir='' +siteman3direxp='' +siteprefix='x:\perl\site' +siteprefixexp='x:\perl\site' +sitescript='' +sitescriptexp='' +sizesize='4' +sizetype='size_t' +sleep='' +smail='' +so='dll' +sockethdr='' +socketlib='' +socksizetype='int' +sort='sort' +spackage='Perl5' +spitshell='' +srand48_r_proto='0' +srandom_r_proto='0' +src='' +ssizetype='int' +startperl='#!perl' +startsh='#!/bin/sh' +static_ext=' ' +stdchar='char' +stdio_base='((fp)->_base)' +stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)' +stdio_cnt='((fp)->_cnt)' +stdio_filbuf='' +stdio_ptr='((fp)->_ptr)' +stdio_stream_array='' +strerror_r_proto='0' +strings='/usr/include/string.h' +submit='' +subversion='' +sysman='/usr/man/man1' +tail='' +tar='' +targetarch='' +tbl='' +tee='' +test='' +timeincl='/usr/include/sys/time.h ' +timetype='time_t' +tmpnam_r_proto='0' +to=':' +touch='touch' +tr='' +trnl='\012' +troff='' +ttyname_r_proto='0' +u16size='2' +u16type='unsigned short' +u32size='4' +u32type='unsigned long' +u64size='8' +u64type='unsigned long long' +u8size='1' +u8type='unsigned char' +uidformat='"ld"' +uidsign='-1' +uidsize='4' +uidtype='uid_t' +uname='uname' +uniq='uniq' +uquadtype='unsigned long long' +use5005threads='undef' +use64bitall='undef' +use64bitint='undef' +usecrosscompile='undef' +usedl='define' +usefaststdio='define' +useithreads='define' +uselargefiles='define' +uselongdouble='undef' +usemallocwrap='define' +usemorebits='undef' +usemultiplicity='define' +usemymalloc='n' +usenm='false' +useopcode='true' +useperlio='define' +useposix='true' +usereentrant='undef' +userelocatableinc='undef' +usesfio='false' +useshrplib='yes' +usesitecustomize='undef' +usesocks='undef' +usethreads='define' +usevendorprefix='undef' +usevfork='false' +usrinc='/usr/include' +uuname='' +uvXUformat='"lX"' +uvoformat='"lo"' +uvsize='4' +uvtype='unsigned long' +uvuformat='"lu"' +uvxformat='"lx"' +vendorarch='' +vendorarchexp='' +vendorbin='' +vendorbinexp='' +vendorhtml1dir=' ' +vendorhtml1direxp='' +vendorhtml3dir=' ' +vendorhtml3direxp='' +vendorlib='' +vendorlib_stem='' +vendorlibexp='' +vendorman1dir=' ' +vendorman1direxp='' +vendorman3dir=' ' +vendorman3direxp='' +vendorprefix='' +vendorprefixexp='' +vendorscript='' +vendorscriptexp='' +version='5.8.8' +version_patchlevel_string='version 8 subversion 8' +versiononly='undef' +vi='' +voidflags='15' +xlibpth='/usr/lib/386 /lib/386' +yacc='yacc' +yaccflags='' +zcat='' +zip='zip' +!END! + +my $i = 0; +foreach my $c (4,3,2) { $i |= ord($c); $i <<= 8 } +$i |= ord(1); +our $byteorder = join('', unpack('aaaa', pack('L!', $i))); +s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m; + +my $config_sh_len = length $_; + +our $Config_SH_expanded = "\n$_" . << 'EOVIRTUAL'; +ccflags_nolargefiles=' -s -O2 -DWIN32 -DHAVE_DES_FCRYPT -DPERL_IMPLICIT_CONTEXT -fno-strict-aliasing -DPERL_MSVCRT_READFIX' +ldflags_nolargefiles='-s -L"x:\perl\lib\CORE" -L"x:\msys\mingw\lib"' +libs_nolargefiles='-lmsvcrt -lmoldname -lkernel32 -luser32 -lgdi32 -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr -lwinmm -lversion -lodbc32 -lodbccp32' +libswanted_nolargefiles='' +EOVIRTUAL + +# Search for it in the big string +sub fetch_string { + my($self, $key) = @_; + + # We only have ' delimted. + my $start = index($Config_SH_expanded, "\n$key=\'"); + # Start can never be -1 now, as we've rigged the long string we're + # searching with an initial dummy newline. + return undef if $start == -1; + + $start += length($key) + 3; + + my $value = substr($Config_SH_expanded, $start, + index($Config_SH_expanded, "'\n", $start) + - $start); + # So we can say "if $Config{'foo'}". + $value = undef if $value eq 'undef'; + $self->{$key} = $value; # cache it +} + +my $prevpos = 0; + +sub FIRSTKEY { + $prevpos = 0; + substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 ); +} + +sub NEXTKEY { + my $pos = index($Config_SH_expanded, qq('\n), $prevpos) + 2; + my $len = index($Config_SH_expanded, "=", $pos) - $pos; + $prevpos = $pos; + $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef; +} + +sub EXISTS { + return 1 if exists($_[0]->{$_[1]}); + + return(index($Config_SH_expanded, "\n$_[1]='") != -1 + ); +} + +sub STORE { die "\%Config::Config is read-only\n" } +*DELETE = \&STORE; +*CLEAR = \&STORE; + + +sub config_sh { + substr $Config_SH_expanded, 1, $config_sh_len; +} + +sub config_re { + my $re = shift; + return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/, + $Config_SH_expanded; +} + +sub config_vars { + # implements -V:cfgvar option (see perlrun -V:) + foreach (@_) { + # find optional leading, trailing colons; and query-spec + my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/; # flags fore and aft, + # map colon-flags to print decorations + my $prfx = $notag ? '': "$qry="; # tag-prefix for print + my $lnend = $lncont ? ' ' : ";\n"; # line ending for print + + # all config-vars are by definition \w only, any \W means regex + if ($qry =~ /\W/) { + my @matches = config_re($qry); + print map "$_$lnend", @matches ? @matches : "$qry: not found" if !$notag; + print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found" if $notag; + } else { + my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry} + : 'UNKNOWN'; + $v = 'undef' unless defined $v; + print "${prfx}'${v}'$lnend"; + } + } +} + +# Called by the real AUTOLOAD +sub launcher { + undef &AUTOLOAD; + goto \&$Config::AUTOLOAD; +} + +1; diff --git a/Master/tlpkg/installer/perllib/Data/Dumper.pm b/Master/tlpkg/installer/perllib/Data/Dumper.pm new file mode 100644 index 00000000000..b7fe1d61e77 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Data/Dumper.pm @@ -0,0 +1,1264 @@ +# +# Data/Dumper.pm +# +# convert perl data structures into perl syntax suitable for both printing +# and eval +# +# Documentation at the __END__ +# + +package Data::Dumper; + +$VERSION = '2.121_08'; + +#$| = 1; + +use 5.006_001; +require Exporter; +require overload; + +use Carp; + +BEGIN { + @ISA = qw(Exporter); + @EXPORT = qw(Dumper); + @EXPORT_OK = qw(DumperX); + + # if run under miniperl, or otherwise lacking dynamic loading, + # XSLoader should be attempted to load, or the pure perl flag + # toggled on load failure. + eval { + require XSLoader; + }; + $Useperl = 1 if $@; +} + +XSLoader::load( 'Data::Dumper' ) unless $Useperl; + +# module vars and their defaults +$Indent = 2 unless defined $Indent; +$Purity = 0 unless defined $Purity; +$Pad = "" unless defined $Pad; +$Varname = "VAR" unless defined $Varname; +$Useqq = 0 unless defined $Useqq; +$Terse = 0 unless defined $Terse; +$Freezer = "" unless defined $Freezer; +$Toaster = "" unless defined $Toaster; +$Deepcopy = 0 unless defined $Deepcopy; +$Quotekeys = 1 unless defined $Quotekeys; +$Bless = "bless" unless defined $Bless; +#$Expdepth = 0 unless defined $Expdepth; +$Maxdepth = 0 unless defined $Maxdepth; +$Pair = ' => ' unless defined $Pair; +$Useperl = 0 unless defined $Useperl; +$Sortkeys = 0 unless defined $Sortkeys; +$Deparse = 0 unless defined $Deparse; + +# +# expects an arrayref of values to be dumped. +# can optionally pass an arrayref of names for the values. +# names must have leading $ sign stripped. begin the name with * +# to cause output of arrays and hashes rather than refs. +# +sub new { + my($c, $v, $n) = @_; + + croak "Usage: PACKAGE->new(ARRAYREF, [ARRAYREF])" + unless (defined($v) && (ref($v) eq 'ARRAY')); + $n = [] unless (defined($n) && (ref($v) eq 'ARRAY')); + + my($s) = { + level => 0, # current recursive depth + indent => $Indent, # various styles of indenting + pad => $Pad, # all lines prefixed by this string + xpad => "", # padding-per-level + apad => "", # added padding for hash keys n such + sep => "", # list separator + pair => $Pair, # hash key/value separator: defaults to ' => ' + seen => {}, # local (nested) refs (id => [name, val]) + todump => $v, # values to dump [] + names => $n, # optional names for values [] + varname => $Varname, # prefix to use for tagging nameless ones + purity => $Purity, # degree to which output is evalable + useqq => $Useqq, # use "" for strings (backslashitis ensues) + terse => $Terse, # avoid name output (where feasible) + freezer => $Freezer, # name of Freezer method for objects + toaster => $Toaster, # name of method to revive objects + deepcopy => $Deepcopy, # dont cross-ref, except to stop recursion + quotekeys => $Quotekeys, # quote hash keys + 'bless' => $Bless, # keyword to use for "bless" +# expdepth => $Expdepth, # cutoff depth for explicit dumping + maxdepth => $Maxdepth, # depth beyond which we give up + useperl => $Useperl, # use the pure Perl implementation + sortkeys => $Sortkeys, # flag or filter for sorting hash keys + deparse => $Deparse, # use B::Deparse for coderefs + }; + + if ($Indent > 0) { + $s->{xpad} = " "; + $s->{sep} = "\n"; + } + return bless($s, $c); +} + +sub init_refaddr_format { + require Config; + my $f = $Config::Config{uvxformat}; + $f =~ tr/"//d; + our $refaddr_format = "0x%" . $f; +} + +sub format_refaddr { + require Scalar::Util; + sprintf our $refaddr_format, Scalar::Util::refaddr(shift); +} + +# +# add-to or query the table of already seen references +# +sub Seen { + my($s, $g) = @_; + if (defined($g) && (ref($g) eq 'HASH')) { + my($k, $v, $id); + while (($k, $v) = each %$g) { + if (defined $v and ref $v) { + $id = format_refaddr($v); + if ($k =~ /^[*](.*)$/) { + $k = (ref $v eq 'ARRAY') ? ( "\\\@" . $1 ) : + (ref $v eq 'HASH') ? ( "\\\%" . $1 ) : + (ref $v eq 'CODE') ? ( "\\\&" . $1 ) : + ( "\$" . $1 ) ; + } + elsif ($k !~ /^\$/) { + $k = "\$" . $k; + } + $s->{seen}{$id} = [$k, $v]; + } + else { + carp "Only refs supported, ignoring non-ref item \$$k"; + } + } + return $s; + } + else { + return map { @$_ } values %{$s->{seen}}; + } +} + +# +# set or query the values to be dumped +# +sub Values { + my($s, $v) = @_; + if (defined($v) && (ref($v) eq 'ARRAY')) { + $s->{todump} = [@$v]; # make a copy + return $s; + } + else { + return @{$s->{todump}}; + } +} + +# +# set or query the names of the values to be dumped +# +sub Names { + my($s, $n) = @_; + if (defined($n) && (ref($n) eq 'ARRAY')) { + $s->{names} = [@$n]; # make a copy + return $s; + } + else { + return @{$s->{names}}; + } +} + +sub DESTROY {} + +sub Dump { + return &Dumpxs + unless $Data::Dumper::Useperl || (ref($_[0]) && $_[0]->{useperl}) || + $Data::Dumper::Useqq || (ref($_[0]) && $_[0]->{useqq}) || + $Data::Dumper::Deparse || (ref($_[0]) && $_[0]->{deparse}); + return &Dumpperl; +} + +# +# dump the refs in the current dumper object. +# expects same args as new() if called via package name. +# +sub Dumpperl { + my($s) = shift; + my(@out, $val, $name); + my($i) = 0; + local(@post); + init_refaddr_format(); + + $s = $s->new(@_) unless ref $s; + + for $val (@{$s->{todump}}) { + my $out = ""; + @post = (); + $name = $s->{names}[$i++]; + if (defined $name) { + if ($name =~ /^[*](.*)$/) { + if (defined $val) { + $name = (ref $val eq 'ARRAY') ? ( "\@" . $1 ) : + (ref $val eq 'HASH') ? ( "\%" . $1 ) : + (ref $val eq 'CODE') ? ( "\*" . $1 ) : + ( "\$" . $1 ) ; + } + else { + $name = "\$" . $1; + } + } + elsif ($name !~ /^\$/) { + $name = "\$" . $name; + } + } + else { + $name = "\$" . $s->{varname} . $i; + } + + my $valstr; + { + local($s->{apad}) = $s->{apad}; + $s->{apad} .= ' ' x (length($name) + 3) if $s->{indent} >= 2; + $valstr = $s->_dump($val, $name); + } + + $valstr = "$name = " . $valstr . ';' if @post or !$s->{terse}; + $out .= $s->{pad} . $valstr . $s->{sep}; + $out .= $s->{pad} . join(';' . $s->{sep} . $s->{pad}, @post) + . ';' . $s->{sep} if @post; + + push @out, $out; + } + return wantarray ? @out : join('', @out); +} + +# +# twist, toil and turn; +# and recurse, of course. +# sometimes sordidly; +# and curse if no recourse. +# +sub _dump { + my($s, $val, $name) = @_; + my($sname); + my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad); + + $type = ref $val; + $out = ""; + + if ($type) { + + # Call the freezer method if it's specified and the object has the + # method. Trap errors and warn() instead of die()ing, like the XS + # implementation. + my $freezer = $s->{freezer}; + if ($freezer and UNIVERSAL::can($val, $freezer)) { + eval { $val->$freezer() }; + warn "WARNING(Freezer method call failed): $@" if $@; + } + + require Scalar::Util; + $realpack = Scalar::Util::blessed($val); + $realtype = $realpack ? Scalar::Util::reftype($val) : ref $val; + $id = format_refaddr($val); + + # if it has a name, we need to either look it up, or keep a tab + # on it so we know when we hit it later + if (defined($name) and length($name)) { + # keep a tab on it so that we dont fall into recursive pit + if (exists $s->{seen}{$id}) { +# if ($s->{expdepth} < $s->{level}) { + if ($s->{purity} and $s->{level} > 0) { + $out = ($realtype eq 'HASH') ? '{}' : + ($realtype eq 'ARRAY') ? '[]' : + 'do{my $o}' ; + push @post, $name . " = " . $s->{seen}{$id}[0]; + } + else { + $out = $s->{seen}{$id}[0]; + if ($name =~ /^([\@\%])/) { + my $start = $1; + if ($out =~ /^\\$start/) { + $out = substr($out, 1); + } + else { + $out = $start . '{' . $out . '}'; + } + } + } + return $out; +# } + } + else { + # store our name + $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : + ($realtype eq 'CODE' and + $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : + $name ), + $val ]; + } + } + + if ($realpack and $realpack eq 'Regexp') { + $out = "$val"; + $out =~ s,/,\\/,g; + return "qr/$out/"; + } + + # If purity is not set and maxdepth is set, then check depth: + # if we have reached maximum depth, return the string + # representation of the thing we are currently examining + # at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)'). + if (!$s->{purity} + and $s->{maxdepth} > 0 + and $s->{level} >= $s->{maxdepth}) + { + return qq['$val']; + } + + # we have a blessed ref + if ($realpack) { + $out = $s->{'bless'} . '( '; + $blesspad = $s->{apad}; + $s->{apad} .= ' ' if ($s->{indent} >= 2); + } + + $s->{level}++; + $ipad = $s->{xpad} x $s->{level}; + + if ($realtype eq 'SCALAR' || $realtype eq 'REF') { + if ($realpack) { + $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; + } + else { + $out .= '\\' . $s->_dump($$val, "\${$name}"); + } + } + elsif ($realtype eq 'GLOB') { + $out .= '\\' . $s->_dump($$val, "*{$name}"); + } + elsif ($realtype eq 'ARRAY') { + my($v, $pad, $mname); + my($i) = 0; + $out .= ($name =~ /^\@/) ? '(' : '['; + $pad = $s->{sep} . $s->{pad} . $s->{apad}; + ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : + # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} + ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : + ($mname = $name . '->'); + $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; + for $v (@$val) { + $sname = $mname . '[' . $i . ']'; + $out .= $pad . $ipad . '#' . $i if $s->{indent} >= 3; + $out .= $pad . $ipad . $s->_dump($v, $sname); + $out .= "," if $i++ < $#$val; + } + $out .= $pad . ($s->{xpad} x ($s->{level} - 1)) if $i; + $out .= ($name =~ /^\@/) ? ')' : ']'; + } + elsif ($realtype eq 'HASH') { + my($k, $v, $pad, $lpad, $mname, $pair); + $out .= ($name =~ /^\%/) ? '(' : '{'; + $pad = $s->{sep} . $s->{pad} . $s->{apad}; + $lpad = $s->{apad}; + $pair = $s->{pair}; + ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : + # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} + ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : + ($mname = $name . '->'); + $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; + my ($sortkeys, $keys, $key) = ("$s->{sortkeys}"); + if ($sortkeys) { + if (ref($s->{sortkeys}) eq 'CODE') { + $keys = $s->{sortkeys}($val); + unless (ref($keys) eq 'ARRAY') { + carp "Sortkeys subroutine did not return ARRAYREF"; + $keys = []; + } + } + else { + $keys = [ sort keys %$val ]; + } + } + while (($k, $v) = ! $sortkeys ? (each %$val) : + @$keys ? ($key = shift(@$keys), $val->{$key}) : + () ) + { + my $nk = $s->_dump($k, ""); + $nk = $1 if !$s->{quotekeys} and $nk =~ /^[\"\']([A-Za-z_]\w*)[\"\']$/; + $sname = $mname . '{' . $nk . '}'; + $out .= $pad . $ipad . $nk . $pair; + + # temporarily alter apad + $s->{apad} .= (" " x (length($nk) + 4)) if $s->{indent} >= 2; + $out .= $s->_dump($val->{$k}, $sname) . ","; + $s->{apad} = $lpad if $s->{indent} >= 2; + } + if (substr($out, -1) eq ',') { + chop $out; + $out .= $pad . ($s->{xpad} x ($s->{level} - 1)); + } + $out .= ($name =~ /^\%/) ? ')' : '}'; + } + elsif ($realtype eq 'CODE') { + if ($s->{deparse}) { + require B::Deparse; + my $sub = 'sub ' . (B::Deparse->new)->coderef2text($val); + $pad = $s->{sep} . $s->{pad} . $s->{apad} . $s->{xpad} x ($s->{level} - 1); + $sub =~ s/\n/$pad/gse; + $out .= $sub; + } else { + $out .= 'sub { "DUMMY" }'; + carp "Encountered CODE ref, using dummy placeholder" if $s->{purity}; + } + } + else { + croak "Can\'t handle $realtype type."; + } + + if ($realpack) { # we have a blessed ref + $out .= ', \'' . $realpack . '\'' . ' )'; + $out .= '->' . $s->{toaster} . '()' if $s->{toaster} ne ''; + $s->{apad} = $blesspad; + } + $s->{level}--; + + } + else { # simple scalar + + my $ref = \$_[1]; + # first, catalog the scalar + if ($name ne '') { + $id = format_refaddr($ref); + if (exists $s->{seen}{$id}) { + if ($s->{seen}{$id}[2]) { + $out = $s->{seen}{$id}[0]; + #warn "[<$out]\n"; + return "\${$out}"; + } + } + else { + #warn "[>\\$name]\n"; + $s->{seen}{$id} = ["\\$name", $ref]; + } + } + if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob + my $name = substr($val, 1); + if ($name =~ /^[A-Za-z_][\w:]*$/) { + $name =~ s/^main::/::/; + $sname = $name; + } + else { + $sname = $s->_dump($name, ""); + $sname = '{' . $sname . '}'; + } + if ($s->{purity}) { + my $k; + local ($s->{level}) = 0; + for $k (qw(SCALAR ARRAY HASH)) { + my $gval = *$val{$k}; + next unless defined $gval; + next if $k eq "SCALAR" && ! defined $$gval; # always there + + # _dump can push into @post, so we hold our place using $postlen + my $postlen = scalar @post; + $post[$postlen] = "\*$sname = "; + local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2; + $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}"); + } + } + $out .= '*' . $sname; + } + elsif (!defined($val)) { + $out .= "undef"; + } + elsif ($val =~ /^(?:0|-?[1-9]\d{0,8})\z/) { # safe decimal number + $out .= $val; + } + else { # string + if ($s->{useqq} or $val =~ tr/\0-\377//c) { + # Fall back to qq if there's unicode + $out .= qquote($val, $s->{useqq}); + } + else { + $val =~ s/([\\\'])/\\$1/g; + $out .= '\'' . $val . '\''; + } + } + } + if ($id) { + # if we made it this far, $id was added to seen list at current + # level, so remove it to get deep copies + if ($s->{deepcopy}) { + delete($s->{seen}{$id}); + } + elsif ($name) { + $s->{seen}{$id}[2] = 1; + } + } + return $out; +} + +# +# non-OO style of earlier version +# +sub Dumper { + return Data::Dumper->Dump([@_]); +} + +# compat stub +sub DumperX { + return Data::Dumper->Dumpxs([@_], []); +} + +sub Dumpf { return Data::Dumper->Dump(@_) } + +sub Dumpp { print Data::Dumper->Dump(@_) } + +# +# reset the "seen" cache +# +sub Reset { + my($s) = shift; + $s->{seen} = {}; + return $s; +} + +sub Indent { + my($s, $v) = @_; + if (defined($v)) { + if ($v == 0) { + $s->{xpad} = ""; + $s->{sep} = ""; + } + else { + $s->{xpad} = " "; + $s->{sep} = "\n"; + } + $s->{indent} = $v; + return $s; + } + else { + return $s->{indent}; + } +} + +sub Pair { + my($s, $v) = @_; + defined($v) ? (($s->{pair} = $v), return $s) : $s->{pair}; +} + +sub Pad { + my($s, $v) = @_; + defined($v) ? (($s->{pad} = $v), return $s) : $s->{pad}; +} + +sub Varname { + my($s, $v) = @_; + defined($v) ? (($s->{varname} = $v), return $s) : $s->{varname}; +} + +sub Purity { + my($s, $v) = @_; + defined($v) ? (($s->{purity} = $v), return $s) : $s->{purity}; +} + +sub Useqq { + my($s, $v) = @_; + defined($v) ? (($s->{useqq} = $v), return $s) : $s->{useqq}; +} + +sub Terse { + my($s, $v) = @_; + defined($v) ? (($s->{terse} = $v), return $s) : $s->{terse}; +} + +sub Freezer { + my($s, $v) = @_; + defined($v) ? (($s->{freezer} = $v), return $s) : $s->{freezer}; +} + +sub Toaster { + my($s, $v) = @_; + defined($v) ? (($s->{toaster} = $v), return $s) : $s->{toaster}; +} + +sub Deepcopy { + my($s, $v) = @_; + defined($v) ? (($s->{deepcopy} = $v), return $s) : $s->{deepcopy}; +} + +sub Quotekeys { + my($s, $v) = @_; + defined($v) ? (($s->{quotekeys} = $v), return $s) : $s->{quotekeys}; +} + +sub Bless { + my($s, $v) = @_; + defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; +} + +sub Maxdepth { + my($s, $v) = @_; + defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; +} + +sub Useperl { + my($s, $v) = @_; + defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'}; +} + +sub Sortkeys { + my($s, $v) = @_; + defined($v) ? (($s->{'sortkeys'} = $v), return $s) : $s->{'sortkeys'}; +} + +sub Deparse { + my($s, $v) = @_; + defined($v) ? (($s->{'deparse'} = $v), return $s) : $s->{'deparse'}; +} + +# used by qquote below +my %esc = ( + "\a" => "\\a", + "\b" => "\\b", + "\t" => "\\t", + "\n" => "\\n", + "\f" => "\\f", + "\r" => "\\r", + "\e" => "\\e", +); + +# put a string value in double quotes +sub qquote { + local($_) = shift; + s/([\\\"\@\$])/\\$1/g; + my $bytes; { use bytes; $bytes = length } + s/([^\x00-\x7f])/'\x{'.sprintf("%x",ord($1)).'}'/ge if $bytes > length; + return qq("$_") unless + /[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/; # fast exit + + my $high = shift || ""; + s/([\a\b\t\n\f\r\e])/$esc{$1}/g; + + if (ord('^')==94) { # ascii + # no need for 3 digits in escape for these + s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; + s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; + # all but last branch below not supported --BEHAVIOR SUBJECT TO CHANGE-- + if ($high eq "iso8859") { + s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; + } elsif ($high eq "utf8") { +# use utf8; +# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; + } elsif ($high eq "8bit") { + # leave it as it is + } else { + s/([\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; + s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; + } + } + else { # ebcdic + s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)} + {my $v = ord($1); '\\'.sprintf(($v <= 037 ? '%o' : '%03o'), $v)}eg; + s{([^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])} + {'\\'.sprintf('%03o',ord($1))}eg; + } + + return qq("$_"); +} + +# helper sub to sort hash keys in Perl < 5.8.0 where we don't have +# access to sortsv() from XS +sub _sortkeys { [ sort keys %{$_[0]} ] } + +1; +__END__ + +=head1 NAME + +Data::Dumper - stringified perl data structures, suitable for both printing and C<eval> + +=head1 SYNOPSIS + + use Data::Dumper; + + # simple procedural interface + print Dumper($foo, $bar); + + # extended usage with names + print Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]); + + # configuration variables + { + local $Data::Dumper::Purity = 1; + eval Data::Dumper->Dump([$foo, $bar], [qw(foo *ary)]); + } + + # OO usage + $d = Data::Dumper->new([$foo, $bar], [qw(foo *ary)]); + ... + print $d->Dump; + ... + $d->Purity(1)->Terse(1)->Deepcopy(1); + eval $d->Dump; + + +=head1 DESCRIPTION + +Given a list of scalars or reference variables, writes out their contents in +perl syntax. The references can also be objects. The contents of each +variable is output in a single Perl statement. Handles self-referential +structures correctly. + +The return value can be C<eval>ed to get back an identical copy of the +original reference structure. + +Any references that are the same as one of those passed in will be named +C<$VAR>I<n> (where I<n> is a numeric suffix), and other duplicate references +to substructures within C<$VAR>I<n> will be appropriately labeled using arrow +notation. You can specify names for individual values to be dumped if you +use the C<Dump()> method, or you can change the default C<$VAR> prefix to +something else. See C<$Data::Dumper::Varname> and C<$Data::Dumper::Terse> +below. + +The default output of self-referential structures can be C<eval>ed, but the +nested references to C<$VAR>I<n> will be undefined, since a recursive +structure cannot be constructed using one Perl statement. You should set the +C<Purity> flag to 1 to get additional statements that will correctly fill in +these references. Moreover, if C<eval>ed when strictures are in effect, +you need to ensure that any variables it accesses are previously declared. + +In the extended usage form, the references to be dumped can be given +user-specified names. If a name begins with a C<*>, the output will +describe the dereferenced type of the supplied reference for hashes and +arrays, and coderefs. Output of names will be avoided where possible if +the C<Terse> flag is set. + +In many cases, methods that are used to set the internal state of the +object will return the object itself, so method calls can be conveniently +chained together. + +Several styles of output are possible, all controlled by setting +the C<Indent> flag. See L<Configuration Variables or Methods> below +for details. + + +=head2 Methods + +=over 4 + +=item I<PACKAGE>->new(I<ARRAYREF [>, I<ARRAYREF]>) + +Returns a newly created C<Data::Dumper> object. The first argument is an +anonymous array of values to be dumped. The optional second argument is an +anonymous array of names for the values. The names need not have a leading +C<$> sign, and must be comprised of alphanumeric characters. You can begin +a name with a C<*> to specify that the dereferenced type must be dumped +instead of the reference itself, for ARRAY and HASH references. + +The prefix specified by C<$Data::Dumper::Varname> will be used with a +numeric suffix if the name for a value is undefined. + +Data::Dumper will catalog all references encountered while dumping the +values. Cross-references (in the form of names of substructures in perl +syntax) will be inserted at all possible points, preserving any structural +interdependencies in the original set of values. Structure traversal is +depth-first, and proceeds in order from the first supplied value to +the last. + +=item I<$OBJ>->Dump I<or> I<PACKAGE>->Dump(I<ARRAYREF [>, I<ARRAYREF]>) + +Returns the stringified form of the values stored in the object (preserving +the order in which they were supplied to C<new>), subject to the +configuration options below. In a list context, it returns a list +of strings corresponding to the supplied values. + +The second form, for convenience, simply calls the C<new> method on its +arguments before dumping the object immediately. + +=item I<$OBJ>->Seen(I<[HASHREF]>) + +Queries or adds to the internal table of already encountered references. +You must use C<Reset> to explicitly clear the table if needed. Such +references are not dumped; instead, their names are inserted wherever they +are encountered subsequently. This is useful especially for properly +dumping subroutine references. + +Expects an anonymous hash of name => value pairs. Same rules apply for names +as in C<new>. If no argument is supplied, will return the "seen" list of +name => value pairs, in a list context. Otherwise, returns the object +itself. + +=item I<$OBJ>->Values(I<[ARRAYREF]>) + +Queries or replaces the internal array of values that will be dumped. +When called without arguments, returns the values. Otherwise, returns the +object itself. + +=item I<$OBJ>->Names(I<[ARRAYREF]>) + +Queries or replaces the internal array of user supplied names for the values +that will be dumped. When called without arguments, returns the names. +Otherwise, returns the object itself. + +=item I<$OBJ>->Reset + +Clears the internal table of "seen" references and returns the object +itself. + +=back + +=head2 Functions + +=over 4 + +=item Dumper(I<LIST>) + +Returns the stringified form of the values in the list, subject to the +configuration options below. The values will be named C<$VAR>I<n> in the +output, where I<n> is a numeric suffix. Will return a list of strings +in a list context. + +=back + +=head2 Configuration Variables or Methods + +Several configuration variables can be used to control the kind of output +generated when using the procedural interface. These variables are usually +C<local>ized in a block so that other parts of the code are not affected by +the change. + +These variables determine the default state of the object created by calling +the C<new> method, but cannot be used to alter the state of the object +thereafter. The equivalent method names should be used instead to query +or set the internal state of the object. + +The method forms return the object itself when called with arguments, +so that they can be chained together nicely. + +=over 4 + +=item * + +$Data::Dumper::Indent I<or> I<$OBJ>->Indent(I<[NEWVAL]>) + +Controls the style of indentation. It can be set to 0, 1, 2 or 3. Style 0 +spews output without any newlines, indentation, or spaces between list +items. It is the most compact format possible that can still be called +valid perl. Style 1 outputs a readable form with newlines but no fancy +indentation (each level in the structure is simply indented by a fixed +amount of whitespace). Style 2 (the default) outputs a very readable form +which takes into account the length of hash keys (so the hash value lines +up). Style 3 is like style 2, but also annotates the elements of arrays +with their index (but the comment is on its own line, so array output +consumes twice the number of lines). Style 2 is the default. + +=item * + +$Data::Dumper::Purity I<or> I<$OBJ>->Purity(I<[NEWVAL]>) + +Controls the degree to which the output can be C<eval>ed to recreate the +supplied reference structures. Setting it to 1 will output additional perl +statements that will correctly recreate nested references. The default is +0. + +=item * + +$Data::Dumper::Pad I<or> I<$OBJ>->Pad(I<[NEWVAL]>) + +Specifies the string that will be prefixed to every line of the output. +Empty string by default. + +=item * + +$Data::Dumper::Varname I<or> I<$OBJ>->Varname(I<[NEWVAL]>) + +Contains the prefix to use for tagging variable names in the output. The +default is "VAR". + +=item * + +$Data::Dumper::Useqq I<or> I<$OBJ>->Useqq(I<[NEWVAL]>) + +When set, enables the use of double quotes for representing string values. +Whitespace other than space will be represented as C<[\n\t\r]>, "unsafe" +characters will be backslashed, and unprintable characters will be output as +quoted octal integers. Since setting this variable imposes a performance +penalty, the default is 0. C<Dump()> will run slower if this flag is set, +since the fast XSUB implementation doesn't support it yet. + +=item * + +$Data::Dumper::Terse I<or> I<$OBJ>->Terse(I<[NEWVAL]>) + +When set, Data::Dumper will emit single, non-self-referential values as +atoms/terms rather than statements. This means that the C<$VAR>I<n> names +will be avoided where possible, but be advised that such output may not +always be parseable by C<eval>. + +=item * + +$Data::Dumper::Freezer I<or> $I<OBJ>->Freezer(I<[NEWVAL]>) + +Can be set to a method name, or to an empty string to disable the feature. +Data::Dumper will invoke that method via the object before attempting to +stringify it. This method can alter the contents of the object (if, for +instance, it contains data allocated from C), and even rebless it in a +different package. The client is responsible for making sure the specified +method can be called via the object, and that the object ends up containing +only perl data types after the method has been called. Defaults to an empty +string. + +If an object does not support the method specified (determined using +UNIVERSAL::can()) then the call will be skipped. If the method dies a +warning will be generated. + +=item * + +$Data::Dumper::Toaster I<or> $I<OBJ>->Toaster(I<[NEWVAL]>) + +Can be set to a method name, or to an empty string to disable the feature. +Data::Dumper will emit a method call for any objects that are to be dumped +using the syntax C<bless(DATA, CLASS)-E<gt>METHOD()>. Note that this means that +the method specified will have to perform any modifications required on the +object (like creating new state within it, and/or reblessing it in a +different package) and then return it. The client is responsible for making +sure the method can be called via the object, and that it returns a valid +object. Defaults to an empty string. + +=item * + +$Data::Dumper::Deepcopy I<or> $I<OBJ>->Deepcopy(I<[NEWVAL]>) + +Can be set to a boolean value to enable deep copies of structures. +Cross-referencing will then only be done when absolutely essential +(i.e., to break reference cycles). Default is 0. + +=item * + +$Data::Dumper::Quotekeys I<or> $I<OBJ>->Quotekeys(I<[NEWVAL]>) + +Can be set to a boolean value to control whether hash keys are quoted. +A false value will avoid quoting hash keys when it looks like a simple +string. Default is 1, which will always enclose hash keys in quotes. + +=item * + +$Data::Dumper::Bless I<or> $I<OBJ>->Bless(I<[NEWVAL]>) + +Can be set to a string that specifies an alternative to the C<bless> +builtin operator used to create objects. A function with the specified +name should exist, and should accept the same arguments as the builtin. +Default is C<bless>. + +=item * + +$Data::Dumper::Pair I<or> $I<OBJ>->Pair(I<[NEWVAL]>) + +Can be set to a string that specifies the separator between hash keys +and values. To dump nested hash, array and scalar values to JavaScript, +use: C<$Data::Dumper::Pair = ' : ';>. Implementing C<bless> in JavaScript +is left as an exercise for the reader. +A function with the specified name exists, and accepts the same arguments +as the builtin. + +Default is: C< =E<gt> >. + +=item * + +$Data::Dumper::Maxdepth I<or> $I<OBJ>->Maxdepth(I<[NEWVAL]>) + +Can be set to a positive integer that specifies the depth beyond which +which we don't venture into a structure. Has no effect when +C<Data::Dumper::Purity> is set. (Useful in debugger when we often don't +want to see more than enough). Default is 0, which means there is +no maximum depth. + +=item * + +$Data::Dumper::Useperl I<or> $I<OBJ>->Useperl(I<[NEWVAL]>) + +Can be set to a boolean value which controls whether the pure Perl +implementation of C<Data::Dumper> is used. The C<Data::Dumper> module is +a dual implementation, with almost all functionality written in both +pure Perl and also in XS ('C'). Since the XS version is much faster, it +will always be used if possible. This option lets you override the +default behavior, usually for testing purposes only. Default is 0, which +means the XS implementation will be used if possible. + +=item * + +$Data::Dumper::Sortkeys I<or> $I<OBJ>->Sortkeys(I<[NEWVAL]>) + +Can be set to a boolean value to control whether hash keys are dumped in +sorted order. A true value will cause the keys of all hashes to be +dumped in Perl's default sort order. Can also be set to a subroutine +reference which will be called for each hash that is dumped. In this +case C<Data::Dumper> will call the subroutine once for each hash, +passing it the reference of the hash. The purpose of the subroutine is +to return a reference to an array of the keys that will be dumped, in +the order that they should be dumped. Using this feature, you can +control both the order of the keys, and which keys are actually used. In +other words, this subroutine acts as a filter by which you can exclude +certain keys from being dumped. Default is 0, which means that hash keys +are not sorted. + +=item * + +$Data::Dumper::Deparse I<or> $I<OBJ>->Deparse(I<[NEWVAL]>) + +Can be set to a boolean value to control whether code references are +turned into perl source code. If set to a true value, C<B::Deparse> +will be used to get the source of the code reference. Using this option +will force using the Perl implementation of the dumper, since the fast +XSUB implementation doesn't support it. + +Caution : use this option only if you know that your coderefs will be +properly reconstructed by C<B::Deparse>. + +=back + +=head2 Exports + +=over 4 + +=item Dumper + +=back + +=head1 EXAMPLES + +Run these code snippets to get a quick feel for the behavior of this +module. When you are through with these examples, you may want to +add or change the various configuration variables described above, +to see their behavior. (See the testsuite in the Data::Dumper +distribution for more examples.) + + + use Data::Dumper; + + package Foo; + sub new {bless {'a' => 1, 'b' => sub { return "foo" }}, $_[0]}; + + package Fuz; # a weird REF-REF-SCALAR object + sub new {bless \($_ = \ 'fu\'z'), $_[0]}; + + package main; + $foo = Foo->new; + $fuz = Fuz->new; + $boo = [ 1, [], "abcd", \*foo, + {1 => 'a', 023 => 'b', 0x45 => 'c'}, + \\"p\q\'r", $foo, $fuz]; + + ######## + # simple usage + ######## + + $bar = eval(Dumper($boo)); + print($@) if $@; + print Dumper($boo), Dumper($bar); # pretty print (no array indices) + + $Data::Dumper::Terse = 1; # don't output names where feasible + $Data::Dumper::Indent = 0; # turn off all pretty print + print Dumper($boo), "\n"; + + $Data::Dumper::Indent = 1; # mild pretty print + print Dumper($boo); + + $Data::Dumper::Indent = 3; # pretty print with array indices + print Dumper($boo); + + $Data::Dumper::Useqq = 1; # print strings in double quotes + print Dumper($boo); + + $Data::Dumper::Pair = " : "; # specify hash key/value separator + print Dumper($boo); + + + ######## + # recursive structures + ######## + + @c = ('c'); + $c = \@c; + $b = {}; + $a = [1, $b, $c]; + $b->{a} = $a; + $b->{b} = $a->[1]; + $b->{c} = $a->[2]; + print Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]); + + + $Data::Dumper::Purity = 1; # fill in the holes for eval + print Data::Dumper->Dump([$a, $b], [qw(*a b)]); # print as @a + print Data::Dumper->Dump([$b, $a], [qw(*b a)]); # print as %b + + + $Data::Dumper::Deepcopy = 1; # avoid cross-refs + print Data::Dumper->Dump([$b, $a], [qw(*b a)]); + + + $Data::Dumper::Purity = 0; # avoid cross-refs + print Data::Dumper->Dump([$b, $a], [qw(*b a)]); + + ######## + # deep structures + ######## + + $a = "pearl"; + $b = [ $a ]; + $c = { 'b' => $b }; + $d = [ $c ]; + $e = { 'd' => $d }; + $f = { 'e' => $e }; + print Data::Dumper->Dump([$f], [qw(f)]); + + $Data::Dumper::Maxdepth = 3; # no deeper than 3 refs down + print Data::Dumper->Dump([$f], [qw(f)]); + + + ######## + # object-oriented usage + ######## + + $d = Data::Dumper->new([$a,$b], [qw(a b)]); + $d->Seen({'*c' => $c}); # stash a ref without printing it + $d->Indent(3); + print $d->Dump; + $d->Reset->Purity(0); # empty the seen cache + print join "----\n", $d->Dump; + + + ######## + # persistence + ######## + + package Foo; + sub new { bless { state => 'awake' }, shift } + sub Freeze { + my $s = shift; + print STDERR "preparing to sleep\n"; + $s->{state} = 'asleep'; + return bless $s, 'Foo::ZZZ'; + } + + package Foo::ZZZ; + sub Thaw { + my $s = shift; + print STDERR "waking up\n"; + $s->{state} = 'awake'; + return bless $s, 'Foo'; + } + + package Foo; + use Data::Dumper; + $a = Foo->new; + $b = Data::Dumper->new([$a], ['c']); + $b->Freezer('Freeze'); + $b->Toaster('Thaw'); + $c = $b->Dump; + print $c; + $d = eval $c; + print Data::Dumper->Dump([$d], ['d']); + + + ######## + # symbol substitution (useful for recreating CODE refs) + ######## + + sub foo { print "foo speaking\n" } + *other = \&foo; + $bar = [ \&other ]; + $d = Data::Dumper->new([\&other,$bar],['*other','bar']); + $d->Seen({ '*foo' => \&foo }); + print $d->Dump; + + + ######## + # sorting and filtering hash keys + ######## + + $Data::Dumper::Sortkeys = \&my_filter; + my $foo = { map { (ord, "$_$_$_") } 'I'..'Q' }; + my $bar = { %$foo }; + my $baz = { reverse %$foo }; + print Dumper [ $foo, $bar, $baz ]; + + sub my_filter { + my ($hash) = @_; + # return an array ref containing the hash keys to dump + # in the order that you want them to be dumped + return [ + # Sort the keys of %$foo in reverse numeric order + $hash eq $foo ? (sort {$b <=> $a} keys %$hash) : + # Only dump the odd number keys of %$bar + $hash eq $bar ? (grep {$_ % 2} keys %$hash) : + # Sort keys in default order for all other hashes + (sort keys %$hash) + ]; + } + +=head1 BUGS + +Due to limitations of Perl subroutine call semantics, you cannot pass an +array or hash. Prepend it with a C<\> to pass its reference instead. This +will be remedied in time, now that Perl has subroutine prototypes. +For now, you need to use the extended usage form, and prepend the +name with a C<*> to output it as a hash or array. + +C<Data::Dumper> cheats with CODE references. If a code reference is +encountered in the structure being processed (and if you haven't set +the C<Deparse> flag), an anonymous subroutine that +contains the string '"DUMMY"' will be inserted in its place, and a warning +will be printed if C<Purity> is set. You can C<eval> the result, but bear +in mind that the anonymous sub that gets created is just a placeholder. +Someday, perl will have a switch to cache-on-demand the string +representation of a compiled piece of code, I hope. If you have prior +knowledge of all the code refs that your data structures are likely +to have, you can use the C<Seen> method to pre-seed the internal reference +table and make the dumped output point to them, instead. See L</EXAMPLES> +above. + +The C<Useqq> and C<Deparse> flags makes Dump() run slower, since the +XSUB implementation does not support them. + +SCALAR objects have the weirdest looking C<bless> workaround. + +Pure Perl version of C<Data::Dumper> escapes UTF-8 strings correctly +only in Perl 5.8.0 and later. + +=head2 NOTE + +Starting from Perl 5.8.1 different runs of Perl will have different +ordering of hash keys. The change was done for greater security, +see L<perlsec/"Algorithmic Complexity Attacks">. This means that +different runs of Perl will have different Data::Dumper outputs if +the data contains hashes. If you need to have identical Data::Dumper +outputs from different runs of Perl, use the environment variable +PERL_HASH_SEED, see L<perlrun/PERL_HASH_SEED>. Using this restores +the old (platform-specific) ordering: an even prettier solution might +be to use the C<Sortkeys> filter of Data::Dumper. + +=head1 AUTHOR + +Gurusamy Sarathy gsar@activestate.com + +Copyright (c) 1996-98 Gurusamy Sarathy. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 VERSION + +Version 2.121 (Aug 24 2003) + +=head1 SEE ALSO + +perl(1) + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/CJKConstants.pm b/Master/tlpkg/installer/perllib/Encode/CJKConstants.pm new file mode 100644 index 00000000000..4ab40e72ef2 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/CJKConstants.pm @@ -0,0 +1,66 @@ +# +# $Id: CJKConstants.pm,v 2.0 2004/05/16 20:55:16 dankogai Exp $ +# + +package Encode::CJKConstants; + +use strict; + +our $RCSID = q$Id: CJKConstants.pm,v 2.0 2004/05/16 20:55:16 dankogai Exp $; +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Carp; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(); +our @EXPORT_OK = qw(%CHARCODE %ESC %RE); +our %EXPORT_TAGS = ( 'all' => [ @EXPORT_OK, @EXPORT ] ); + +my %_0208 = ( + 1978 => '\e\$\@', + 1983 => '\e\$B', + 1990 => '\e&\@\e\$B', + ); + +our %CHARCODE = ( + UNDEF_EUC => "\xa2\xae", # ¢® in EUC + UNDEF_SJIS => "\x81\xac", # ¢® in SJIS + UNDEF_JIS => "\xa2\xf7", # ¢÷ -- used in unicode + UNDEF_UNICODE => "\x20\x20", # ¢÷ -- used in unicode + ); + +our %ESC = ( + GB_2312 => "\e\$A", + JIS_0208 => "\e\$B", + JIS_0212 => "\e\$(D", + KSC_5601 => "\e\$(C", + ASC => "\e\(B", + KANA => "\e\(I", + '2022_KR' => "\e\$)C", + ); + +our %RE = + ( + ASCII => '[\x00-\x7f]', + BIN => '[\x00-\x06\x7f\xff]', + EUC_0212 => '\x8f[\xa1-\xfe][\xa1-\xfe]', + EUC_C => '[\xa1-\xfe][\xa1-\xfe]', + EUC_KANA => '\x8e[\xa1-\xdf]', + JIS_0208 => "$_0208{1978}|$_0208{1983}|$_0208{1990}", + JIS_0212 => "\e" . '\$\(D', + ISO_ASC => "\e" . '\([BJ]', + JIS_KANA => "\e" . '\(I', + '2022_KR' => "\e" . '\$\)C', + SJIS_C => '[\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc]', + SJIS_KANA => '[\xa1-\xdf]', + UTF8 => '[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf][\x80-\xbf]' + ); + +1; + +=head1 NAME + +Encode::CJKConstants.pm -- Internally used by Encode::??::ISO_2022_* + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/CN.pm b/Master/tlpkg/installer/perllib/Encode/CN.pm new file mode 100644 index 00000000000..be5a830fc51 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/CN.pm @@ -0,0 +1,76 @@ +package Encode::CN; +BEGIN { + if (ord("A") == 193) { + die "Encode::CN not supported on EBCDIC\n"; + } +} +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Encode; +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +# Relocated from Encode.pm + +use Encode::CN::HZ; +# use Encode::CN::2022_CN; + +1; +__END__ + +=head1 NAME + +Encode::CN - China-based Chinese Encodings + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $euc_cn = encode("euc-cn", $utf8); # loads Encode::CN implicitly + $utf8 = decode("euc-cn", $euc_cn); # ditto + +=head1 DESCRIPTION + +This module implements China-based Chinese charset encodings. +Encodings supported are as follows. + + Canonical Alias Description + -------------------------------------------------------------------- + euc-cn /\beuc.*cn$/i EUC (Extended Unix Character) + /\bcn.*euc$/i + /\bGB[-_ ]?2312(?:\D.*$|$)/i (see below) + gb2312-raw The raw (low-bit) GB2312 character map + gb12345-raw Traditional chinese counterpart to + GB2312 (raw) + iso-ir-165 GB2312 + GB6345 + GB8565 + additions + MacChineseSimp GB2312 + Apple Additions + cp936 Code Page 936, also known as GBK + (Extended GuoBiao) + hz 7-bit escaped GB2312 encoding + -------------------------------------------------------------------- + +To find how to use this module in detail, see L<Encode>. + +=head1 NOTES + +Due to size concerns, C<GB 18030> (an extension to C<GBK>) is distributed +separately on CPAN, under the name L<Encode::HanExtra>. That module +also contains extra Taiwan-based encodings. + +=head1 BUGS + +When you see C<charset=gb2312> on mails and web pages, they really +mean C<euc-cn> encodings. To fix that, C<gb2312> is aliased to C<euc-cn>. +Use C<gb2312-raw> when you really mean it. + +The ASCII region (0x00-0x7f) is preserved for all encodings, even though +this conflicts with mappings by the Unicode Consortium. See + +L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en> + +to find out why it is implemented that way. + +=head1 SEE ALSO + +L<Encode> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/CN/HZ.pm b/Master/tlpkg/installer/perllib/Encode/CN/HZ.pm new file mode 100644 index 00000000000..fbc6ba60ced --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/CN/HZ.pm @@ -0,0 +1,196 @@ +package Encode::CN::HZ; + +use strict; + +use vars qw($VERSION); +$VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Encode qw(:fallbacks); + +use base qw(Encode::Encoding); +__PACKAGE__->Define('hz'); + +# HZ is a combination of ASCII and escaped GB, so we implement it +# with the GB2312(raw) encoding here. Cf. RFCs 1842 & 1843. + +# not ported for EBCDIC. Which should be used, "~" or "\x7E"? + +sub needs_lines { 1 } + +sub decode ($$;$) +{ + my ($obj,$str,$chk) = @_; + + my $GB = Encode::find_encoding('gb2312-raw'); + my $ret = ''; + my $in_ascii = 1; # default mode is ASCII. + + while (length $str) { + if ($in_ascii) { # ASCII mode + if ($str =~ s/^([\x00-\x7D\x7F]+)//) { # no '~' => ASCII + $ret .= $1; + # EBCDIC should need ascii2native, but not ported. + } + elsif ($str =~ s/^\x7E\x7E//) { # escaped tilde + $ret .= '~'; + } + elsif ($str =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII + 1; # no-op + } + elsif ($str =~ s/^\x7E\x7B//) { # '~{' + $in_ascii = 0; # to GB + } + else { # encounters an invalid escape, \x80 or greater + last; + } + } + else { # GB mode; the byte ranges are as in RFC 1843. + if ($str =~ s/^((?:[\x21-\x77][\x21-\x7E])+)//) { + $ret .= $GB->decode($1, $chk); + } + elsif ($str =~ s/^\x7E\x7D//) { # '~}' + $in_ascii = 1; + } + else { # invalid + last; + } + } + } + $_[1] = '' if $chk; # needs_lines guarantees no partial character + return $ret; +} + +sub cat_decode { + my ($obj, undef, $src, $pos, $trm, $chk) = @_; + my ($rdst, $rsrc, $rpos) = \@_[1..3]; + + my $GB = Encode::find_encoding('gb2312-raw'); + my $ret = ''; + my $in_ascii = 1; # default mode is ASCII. + + my $ini_pos = pos($$rsrc); + + substr($src, 0, $pos) = ''; + + my $ini_len = bytes::length($src); + + # $trm is the first of the pair '~~', then 2nd tilde is to be removed. + # XXX: Is better C<$src =~ s/^\x7E// or die if ...>? + $src =~ s/^\x7E// if $trm eq "\x7E"; + + while (length $src) { + my $now; + if ($in_ascii) { # ASCII mode + if ($src =~ s/^([\x00-\x7D\x7F])//) { # no '~' => ASCII + $now = $1; + } + elsif ($src =~ s/^\x7E\x7E//) { # escaped tilde + $now = '~'; + } + elsif ($src =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII + next; + } + elsif ($src =~ s/^\x7E\x7B//) { # '~{' + $in_ascii = 0; # to GB + next; + } + else { # encounters an invalid escape, \x80 or greater + last; + } + } + else { # GB mode; the byte ranges are as in RFC 1843. + if ($src =~ s/^((?:[\x21-\x77][\x21-\x7F])+)//) { + $now = $GB->decode($1, $chk); + } + elsif ($src =~ s/^\x7E\x7D//) { # '~}' + $in_ascii = 1; + next; + } + else { # invalid + last; + } + } + + next if ! defined $now; + + $ret .= $now; + + if ($now eq $trm) { + $$rdst .= $ret; + $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src); + pos($$rsrc) = $ini_pos; + return 1; + } + } + + $$rdst .= $ret; + $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src); + pos($$rsrc) = $ini_pos; + return ''; # terminator not found +} + + +sub encode($$;$) +{ + my ($obj,$str,$chk) = @_; + + my $GB = Encode::find_encoding('gb2312-raw'); + my $ret = ''; + my $in_ascii = 1; # default mode is ASCII. + + no warnings 'utf8'; # $str may be malformed UTF8 at the end of a chunk. + + while (length $str) { + if ($str =~ s/^([[:ascii:]]+)//) { + my $tmp = $1; + $tmp =~ s/~/~~/g; # escapes tildes + if (! $in_ascii) { + $ret .= "\x7E\x7D"; # '~}' + $in_ascii = 1; + } + $ret .= pack 'a*', $tmp; # remove UTF8 flag. + } + elsif ($str =~ s/(.)//) { + my $s = $1; + my $tmp = $GB->encode($s, $chk); + last if !defined $tmp; + if (length $tmp == 2) { # maybe a valid GB char (XXX) + if ($in_ascii) { + $ret .= "\x7E\x7B"; # '~{' + $in_ascii = 0; + } + $ret .= $tmp; + } + elsif (length $tmp) { # maybe FALLBACK in ASCII (XXX) + if (!$in_ascii) { + $ret .= "\x7E\x7D"; # '~}' + $in_ascii = 1; + } + $ret .= $tmp; + } + } + else { # if $str is malformed UTF8 *and* if length $str != 0. + last; + } + } + $_[1] = $str if $chk; + + # The state at the end of the chunk is discarded, even if in GB mode. + # That results in the combination of GB-OUT and GB-IN, i.e. "~}~{". + # Parhaps it is harmless, but further investigations may be required... + + if (! $in_ascii) { + $ret .= "\x7E\x7D"; # '~}' + $in_ascii = 1; + } + return $ret; +} + +1; +__END__ + +=head1 NAME + +Encode::CN::HZ -- internally used by Encode::CN + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Changes.e2x b/Master/tlpkg/installer/perllib/Encode/Changes.e2x new file mode 100644 index 00000000000..5c67c55cb93 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Changes.e2x @@ -0,0 +1,7 @@ +# +# $Id: Changes.e2x,v 2.0 2004/05/16 20:55:15 dankogai Exp $ +# Revision history for Perl extension Encode::$_Name_. +# + +0.01 $_Now_ + Autogenerated by enc2xs version $_Version_. diff --git a/Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x b/Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x new file mode 100644 index 00000000000..e203dfded50 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/ConfigLocal_PM.e2x @@ -0,0 +1,13 @@ +# +# Local demand-load module list +# +# You should not edit this file by hand! use "enc2xs -C" +# +package Encode::ConfigLocal; +our $VERSION = $_LocalVer_; + +use strict; + +$_ModLines_ + +1; diff --git a/Master/tlpkg/installer/perllib/Encode/EBCDIC.pm b/Master/tlpkg/installer/perllib/Encode/EBCDIC.pm new file mode 100644 index 00000000000..200a82fea46 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/EBCDIC.pm @@ -0,0 +1,43 @@ +package Encode::EBCDIC; +use Encode; +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +1; +__END__ + +=head1 NAME + +Encode::EBCDIC - EBCDIC Encodings + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $posix_bc = encode("posix-bc", $utf8); # loads Encode::EBCDIC implicitly + $utf8 = decode("", $posix_bc); # ditto + +=head1 ABSTRACT + +This module implements various EBCDIC-Based encodings. Encodings +supported are as follows. + + Canonical Alias Description + -------------------------------------------------------------------- + cp37 + cp500 + cp875 + cp1026 + cp1047 + posix-bc + +=head1 DESCRIPTION + +To find how to use this module in detail, see L<Encode>. + +=head1 SEE ALSO + +L<Encode>, L<perlebcdic> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Encoder.pm b/Master/tlpkg/installer/perllib/Encode/Encoder.pm new file mode 100644 index 00000000000..fe2a2b90ff6 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Encoder.pm @@ -0,0 +1,249 @@ +# +# $Id: Encoder.pm,v 2.0 2004/05/16 20:55:17 dankogai Exp $ +# +package Encode::Encoder; +use strict; +use warnings; +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw ( encoder ); + +our $AUTOLOAD; +sub DEBUG () { 0 } +use Encode qw(encode decode find_encoding from_to); +use Carp; + +sub new{ + my ($class, $data, $encname) = @_; + unless($encname){ + $encname = Encode::is_utf8($data) ? 'utf8' : ''; + }else{ + my $obj = find_encoding($encname) + or croak __PACKAGE__, ": unknown encoding: $encname"; + $encname = $obj->name; + } + my $self = { + data => $data, + encoding => $encname, + }; + bless $self => $class; +} + +sub encoder{ __PACKAGE__->new(@_) } + +sub data{ + my ($self, $data) = @_; + if (defined $data){ + $self->{data} = $data; + return $data; + }else{ + return $self->{data}; + } +} + +sub encoding{ + my ($self, $encname) = @_; + if ($encname){ + my $obj = find_encoding($encname) + or confess __PACKAGE__, ": unknown encoding: $encname"; + $self->{encoding} = $obj->name; + return $self; + }else{ + return $self->{encoding} + } +} + +sub bytes { + my ($self, $encname) = @_; + $encname ||= $self->{encoding}; + my $obj = find_encoding($encname) + or confess __PACKAGE__, ": unknown encoding: $encname"; + $self->{data} = $obj->decode($self->{data}, 1); + $self->{encoding} = '' ; + return $self; +} + +sub DESTROY{ # defined so it won't autoload. + DEBUG and warn shift; +} + +sub AUTOLOAD { + my $self = shift; + my $type = ref($self) + or confess "$self is not an object"; + my $myname = $AUTOLOAD; + $myname =~ s/.*://; # strip fully-qualified portion + my $obj = find_encoding($myname) + or confess __PACKAGE__, ": unknown encoding: $myname"; + DEBUG and warn $self->{encoding}, " => ", $obj->name; + if ($self->{encoding}){ + from_to($self->{data}, $self->{encoding}, $obj->name, 1); + }else{ + $self->{data} = $obj->encode($self->{data}, 1); + } + $self->{encoding} = $obj->name; + return $self; +} + +use overload + q("") => sub { $_[0]->{data} }, + q(0+) => sub { use bytes (); bytes::length($_[0]->{data}) }, + fallback => 1, + ; + +1; +__END__ + +=head1 NAME + +Encode::Encoder -- Object Oriented Encoder + +=head1 SYNOPSIS + + use Encode::Encoder; + # Encode::encode("ISO-8859-1", $data); + Encode::Encoder->new($data)->iso_8859_1; # OOP way + # shortcut + use Encode::Encoder qw(encoder); + encoder($data)->iso_8859_1; + # you can stack them! + encoder($data)->iso_8859_1->base64; # provided base64() is defined + # you can use it as a decoder as well + encoder($base64)->bytes('base64')->latin1; + # stringified + print encoder($data)->utf8->latin1; # prints the string in latin1 + # numified + encoder("\x{abcd}\x{ef}g")->utf8 == 6; # true. bytes::length($data) + +=head1 ABSTRACT + +B<Encode::Encoder> allows you to use Encode in an object-oriented +style. This is not only more intuitive than a functional approach, +but also handier when you want to stack encodings. Suppose you want +your UTF-8 string converted to Latin1 then Base64: you can simply say + + my $base64 = encoder($utf8)->latin1->base64; + +instead of + + my $latin1 = encode("latin1", $utf8); + my $base64 = encode_base64($utf8); + +or the lazier and more convoluted + + my $base64 = encode_base64(encode("latin1", $utf8)); + +=head1 Description + +Here is how to use this module. + +=over 4 + +=item * + +There are at least two instance variables stored in a hash reference, +{data} and {encoding}. + +=item * + +When there is no method, it takes the method name as the name of the +encoding and encodes the instance I<data> with I<encoding>. If successful, +the instance I<encoding> is set accordingly. + +=item * + +You can retrieve the result via -E<gt>data but usually you don't have to +because the stringify operator ("") is overridden to do exactly that. + +=back + +=head2 Predefined Methods + +This module predefines the methods below: + +=over 4 + +=item $e = Encode::Encoder-E<gt>new([$data, $encoding]); + +returns an encoder object. Its data is initialized with $data if +present, and its encoding is set to $encoding if present. + +When $encoding is omitted, it defaults to utf8 if $data is already in +utf8 or "" (empty string) otherwise. + +=item encoder() + +is an alias of Encode::Encoder-E<gt>new(). This one is exported on demand. + +=item $e-E<gt>data([$data]) + +When $data is present, sets the instance data to $data and returns the +object itself. Otherwise, the current instance data is returned. + +=item $e-E<gt>encoding([$encoding]) + +When $encoding is present, sets the instance encoding to $encoding and +returns the object itself. Otherwise, the current instance encoding is +returned. + +=item $e-E<gt>bytes([$encoding]) + +decodes instance data from $encoding, or the instance encoding if +omitted. If the conversion is successful, the instance encoding +will be set to "". + +The name I<bytes> was deliberately picked to avoid namespace tainting +-- this module may be used as a base class so method names that appear +in Encode::Encoding are avoided. + +=back + +=head2 Example: base64 transcoder + +This module is designed to work with L<Encode::Encoding>. +To make the Base64 transcoder example above really work, you could +write a module like this: + + package Encode::Base64; + use base 'Encode::Encoding'; + __PACKAGE__->Define('base64'); + use MIME::Base64; + sub encode{ + my ($obj, $data) = @_; + return encode_base64($data); + } + sub decode{ + my ($obj, $data) = @_; + return decode_base64($data); + } + 1; + __END__ + +And your caller module would be something like this: + + use Encode::Encoder; + use Encode::Base64; + + # now you can really do the following + + encoder($data)->iso_8859_1->base64; + encoder($base64)->bytes('base64')->latin1; + +=head2 Operator Overloading + +This module overloads two operators, stringify ("") and numify (0+). + +Stringify dumps the data inside the object. + +Numify returns the number of bytes in the instance data. + +They come in handy when you want to print or find the size of data. + +=head1 SEE ALSO + +L<Encode>, +L<Encode::Encoding> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Guess.pm b/Master/tlpkg/installer/perllib/Encode/Guess.pm new file mode 100644 index 00000000000..5692cee9a4a --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Guess.pm @@ -0,0 +1,351 @@ +package Encode::Guess; +use strict; + +use Encode qw(:fallbacks find_encoding); +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +my $Canon = 'Guess'; +sub DEBUG () { 0 } +our %DEF_SUSPECTS = map { $_ => find_encoding($_) } qw(ascii utf8); +$Encode::Encoding{$Canon} = + bless { + Name => $Canon, + Suspects => { %DEF_SUSPECTS }, + } => __PACKAGE__; + +use base qw(Encode::Encoding); +sub needs_lines { 1 } +sub perlio_ok { 0 } + +our @EXPORT = qw(guess_encoding); +our $NoUTFAutoGuess = 0; +our $UTF8_BOM = pack("C3", 0xef, 0xbb, 0xbf); + +sub import { # Exporter not used so we do it on our own + my $callpkg = caller; + for my $item (@EXPORT){ + no strict 'refs'; + *{"$callpkg\::$item"} = \&{"$item"}; + } + set_suspects(@_); +} + +sub set_suspects{ + my $class = shift; + my $self = ref($class) ? $class : $Encode::Encoding{$Canon}; + $self->{Suspects} = { %DEF_SUSPECTS }; + $self->add_suspects(@_); +} + +sub add_suspects{ + my $class = shift; + my $self = ref($class) ? $class : $Encode::Encoding{$Canon}; + for my $c (@_){ + my $e = find_encoding($c) or die "Unknown encoding: $c"; + $self->{Suspects}{$e->name} = $e; + DEBUG and warn "Added: ", $e->name; + } +} + +sub decode($$;$){ + my ($obj, $octet, $chk) = @_; + my $guessed = guess($obj, $octet); + unless (ref($guessed)){ + require Carp; + Carp::croak($guessed); + } + my $utf8 = $guessed->decode($octet, $chk); + $_[1] = $octet if $chk; + return $utf8; +} + +sub guess_encoding{ + guess($Encode::Encoding{$Canon}, @_); +} + +sub guess { + my $class = shift; + my $obj = ref($class) ? $class : $Encode::Encoding{$Canon}; + my $octet = shift; + + # sanity check + return unless defined $octet and length $octet; + + # cheat 0: utf8 flag; + if ( Encode::is_utf8($octet) ) { + return find_encoding('utf8') unless $NoUTFAutoGuess; + Encode::_utf8_off($octet); + } + # cheat 1: BOM + use Encode::Unicode; + unless ($NoUTFAutoGuess) { + my $BOM = pack('C3', unpack("C3", $octet)); + return find_encoding('utf8') + if (defined $BOM and $BOM eq $UTF8_BOM); + $BOM = unpack('N', $octet); + return find_encoding('UTF-32') + if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe0000)); + $BOM = unpack('n', $octet); + return find_encoding('UTF-16') + if (defined $BOM and ($BOM == 0xFeFF or $BOM == 0xFFFe)); + if ($octet =~ /\x00/o){ # if \x00 found, we assume UTF-(16|32)(BE|LE) + my $utf; + my ($be, $le) = (0, 0); + if ($octet =~ /\x00\x00/o){ # UTF-32(BE|LE) assumed + $utf = "UTF-32"; + for my $char (unpack('N*', $octet)){ + $char & 0x0000ffff and $be++; + $char & 0xffff0000 and $le++; + } + }else{ # UTF-16(BE|LE) assumed + $utf = "UTF-16"; + for my $char (unpack('n*', $octet)){ + $char & 0x00ff and $be++; + $char & 0xff00 and $le++; + } + } + DEBUG and warn "$utf, be == $be, le == $le"; + $be == $le + and return + "Encodings ambiguous between $utf BE and LE ($be, $le)"; + $utf .= ($be > $le) ? 'BE' : 'LE'; + return find_encoding($utf); + } + } + my %try = %{$obj->{Suspects}}; + for my $c (@_){ + my $e = find_encoding($c) or die "Unknown encoding: $c"; + $try{$e->name} = $e; + DEBUG and warn "Added: ", $e->name; + } + my $nline = 1; + for my $line (split /\r\n?|\n/, $octet){ + # cheat 2 -- \e in the string + if ($line =~ /\e/o){ + my @keys = keys %try; + delete @try{qw/utf8 ascii/}; + for my $k (@keys){ + ref($try{$k}) eq 'Encode::XS' and delete $try{$k}; + } + } + my %ok = %try; + # warn join(",", keys %try); + for my $k (keys %try){ + my $scratch = $line; + $try{$k}->decode($scratch, FB_QUIET); + if ($scratch eq ''){ + DEBUG and warn sprintf("%4d:%-24s ok\n", $nline, $k); + }else{ + use bytes (); + DEBUG and + warn sprintf("%4d:%-24s not ok; %d bytes left\n", + $nline, $k, bytes::length($scratch)); + delete $ok{$k}; + } + } + %ok or return "No appropriate encodings found!"; + if (scalar(keys(%ok)) == 1){ + my ($retval) = values(%ok); + return $retval; + } + %try = %ok; $nline++; + } + $try{ascii} or + return "Encodings too ambiguous: ", join(" or ", keys %try); + return $try{ascii}; +} + + + +1; +__END__ + +=head1 NAME + +Encode::Guess -- Guesses encoding from data + +=head1 SYNOPSIS + + # if you are sure $data won't contain anything bogus + + use Encode; + use Encode::Guess qw/euc-jp shiftjis 7bit-jis/; + my $utf8 = decode("Guess", $data); + my $data = encode("Guess", $utf8); # this doesn't work! + + # more elaborate way + use Encode::Guess; + my $enc = guess_encoding($data, qw/euc-jp shiftjis 7bit-jis/); + ref($enc) or die "Can't guess: $enc"; # trap error this way + $utf8 = $enc->decode($data); + # or + $utf8 = decode($enc->name, $data) + +=head1 ABSTRACT + +Encode::Guess enables you to guess in what encoding a given data is +encoded, or at least tries to. + +=head1 DESCRIPTION + +By default, it checks only ascii, utf8 and UTF-16/32 with BOM. + + use Encode::Guess; # ascii/utf8/BOMed UTF + +To use it more practically, you have to give the names of encodings to +check (I<suspects> as follows). The name of suspects can either be +canonical names or aliases. + +CAVEAT: Unlike UTF-(16|32), BOM in utf8 is NOT AUTOMATICALLY STRIPPED. + + # tries all major Japanese Encodings as well + use Encode::Guess qw/euc-jp shiftjis 7bit-jis/; + +If the C<$Encode::Guess::NoUTFAutoGuess> variable is set to a true +value, no heuristics will be applied to UTF8/16/32, and the result +will be limited to the suspects and C<ascii>. + +=over 4 + +=item Encode::Guess->set_suspects + +You can also change the internal suspects list via C<set_suspects> +method. + + use Encode::Guess; + Encode::Guess->set_suspects(qw/euc-jp shiftjis 7bit-jis/); + +=item Encode::Guess->add_suspects + +Or you can use C<add_suspects> method. The difference is that +C<set_suspects> flushes the current suspects list while +C<add_suspects> adds. + + use Encode::Guess; + Encode::Guess->add_suspects(qw/euc-jp shiftjis 7bit-jis/); + # now the suspects are euc-jp,shiftjis,7bit-jis, AND + # euc-kr,euc-cn, and big5-eten + Encode::Guess->add_suspects(qw/euc-kr euc-cn big5-eten/); + +=item Encode::decode("Guess" ...) + +When you are content with suspects list, you can now + + my $utf8 = Encode::decode("Guess", $data); + +=item Encode::Guess->guess($data) + +But it will croak if: + +=over + +=item * + +Two or more suspects remain + +=item * + +No suspects left + +=back + +So you should instead try this; + + my $decoder = Encode::Guess->guess($data); + +On success, $decoder is an object that is documented in +L<Encode::Encoding>. So you can now do this; + + my $utf8 = $decoder->decode($data); + +On failure, $decoder now contains an error message so the whole thing +would be as follows; + + my $decoder = Encode::Guess->guess($data); + die $decoder unless ref($decoder); + my $utf8 = $decoder->decode($data); + +=item guess_encoding($data, [, I<list of suspects>]) + +You can also try C<guess_encoding> function which is exported by +default. It takes $data to check and it also takes the list of +suspects by option. The optional suspect list is I<not reflected> to +the internal suspects list. + + my $decoder = guess_encoding($data, qw/euc-jp euc-kr euc-cn/); + die $decoder unless ref($decoder); + my $utf8 = $decoder->decode($data); + # check only ascii and utf8 + my $decoder = guess_encoding($data); + +=back + +=head1 CAVEATS + +=over 4 + +=item * + +Because of the algorithm used, ISO-8859 series and other single-byte +encodings do not work well unless either one of ISO-8859 is the only +one suspect (besides ascii and utf8). + + use Encode::Guess; + # perhaps ok + my $decoder = guess_encoding($data, 'latin1'); + # definitely NOT ok + my $decoder = guess_encoding($data, qw/latin1 greek/); + +The reason is that Encode::Guess guesses encoding by trial and error. +It first splits $data into lines and tries to decode the line for each +suspect. It keeps it going until all but one encoding is eliminated +out of suspects list. ISO-8859 series is just too successful for most +cases (because it fills almost all code points in \x00-\xff). + +=item * + +Do not mix national standard encodings and the corresponding vendor +encodings. + + # a very bad idea + my $decoder + = guess_encoding($data, qw/shiftjis MacJapanese cp932/); + +The reason is that vendor encoding is usually a superset of national +standard so it becomes too ambiguous for most cases. + +=item * + +On the other hand, mixing various national standard encodings +automagically works unless $data is too short to allow for guessing. + + # This is ok if $data is long enough + my $decoder = + guess_encoding($data, qw/euc-cn + euc-jp shiftjis 7bit-jis + euc-kr + big5-eten/); + +=item * + +DO NOT PUT TOO MANY SUSPECTS! Don't you try something like this! + + my $decoder = guess_encoding($data, + Encode->encodings(":all")); + +=back + +It is, after all, just a guess. You should alway be explicit when it +comes to encodings. But there are some, especially Japanese, +environment that guess-coding is a must. Use this module with care. + +=head1 TO DO + +Encode::Guess does not work on EBCDIC platforms. + +=head1 SEE ALSO + +L<Encode>, L<Encode::Encoding> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Encode/JP.pm b/Master/tlpkg/installer/perllib/Encode/JP.pm new file mode 100644 index 00000000000..01ad37f30db --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/JP.pm @@ -0,0 +1,97 @@ +package Encode::JP; +BEGIN { + if (ord("A") == 193) { + die "Encode::JP not supported on EBCDIC\n"; + } +} +use Encode; +our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +use Encode::JP::JIS7; + +1; +__END__ + +=head1 NAME + +Encode::JP - Japanese Encodings + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $euc_jp = encode("euc-jp", $utf8); # loads Encode::JP implicitly + $utf8 = decode("euc-jp", $euc_jp); # ditto + +=head1 ABSTRACT + +This module implements Japanese charset encodings. Encodings +supported are as follows. + + Canonical Alias Description + -------------------------------------------------------------------- + euc-jp /\beuc.*jp$/i EUC (Extended Unix Character) + /\bjp.*euc/i + /\bujis$/i + shiftjis /\bshift.*jis$/i Shift JIS (aka MS Kanji) + /\bsjis$/i + 7bit-jis /\bjis$/i 7bit JIS + iso-2022-jp ISO-2022-JP [RFC1468] + = 7bit JIS with all Halfwidth Kana + converted to Fullwidth + iso-2022-jp-1 ISO-2022-JP-1 [RFC2237] + = ISO-2022-JP with JIS X 0212-1990 + support. See below + MacJapanese Shift JIS + Apple vendor mappings + cp932 /\bwindows-31j$/i Code Page 932 + = Shift JIS + MS/IBM vendor mappings + jis0201-raw JIS0201, raw format + jis0208-raw JIS0201, raw format + jis0212-raw JIS0201, raw format + -------------------------------------------------------------------- + +=head1 DESCRIPTION + +To find out how to use this module in detail, see L<Encode>. + +=head1 Note on ISO-2022-JP(-1)? + +ISO-2022-JP-1 (RFC2237) is a superset of ISO-2022-JP (RFC1468) which +adds support for JIS X 0212-1990. That means you can use the same +code to decode to utf8 but not vice versa. + + $utf8 = decode('iso-2022-jp-1', $stream); + +and + + $utf8 = decode('iso-2022-jp', $stream); + +yield the same result but + + $with_0212 = encode('iso-2022-jp-1', $utf8); + +is now different from + + $without_0212 = encode('iso-2022-jp', $utf8 ); + +In the latter case, characters that map to 0212 are first converted +to U+3013 (0xA2AE in EUC-JP; a white square also known as 'Tofu' or +'geta mark') then fed to the decoding engine. U+FFFD is not used, +in order to preserve text layout as much as possible. + +=head1 BUGS + +The ASCII region (0x00-0x7f) is preserved for all encodings, even +though this conflicts with mappings by the Unicode Consortium. See + +L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en> + +to find out why it is implemented that way. + +=head1 SEE ALSO + +L<Encode> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm b/Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm new file mode 100644 index 00000000000..0c84c62fda6 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/JP/H2Z.pm @@ -0,0 +1,174 @@ +# +# $Id: H2Z.pm,v 2.0 2004/05/16 20:55:17 dankogai Exp $ +# + +package Encode::JP::H2Z; + +use strict; + +our $RCSID = q$Id: H2Z.pm,v 2.0 2004/05/16 20:55:17 dankogai Exp $; +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Encode::CJKConstants qw(:all); + +use vars qw(%_D2Z $_PAT_D2Z + %_Z2D $_PAT_Z2D + %_H2Z $_PAT_H2Z + %_Z2H $_PAT_Z2H); + +%_H2Z = ( + "\x8e\xa1" => "\xa1\xa3", #¡£ + "\x8e\xa2" => "\xa1\xd6", #¡Ö + "\x8e\xa3" => "\xa1\xd7", #¡× + "\x8e\xa4" => "\xa1\xa2", #¡¢ + "\x8e\xa5" => "\xa1\xa6", #¡¦ + "\x8e\xa6" => "\xa5\xf2", #¥ò + "\x8e\xa7" => "\xa5\xa1", #¥¡ + "\x8e\xa8" => "\xa5\xa3", #¥£ + "\x8e\xa9" => "\xa5\xa5", #¥¥ + "\x8e\xaa" => "\xa5\xa7", #¥§ + "\x8e\xab" => "\xa5\xa9", #¥© + "\x8e\xac" => "\xa5\xe3", #¥ã + "\x8e\xad" => "\xa5\xe5", #¥å + "\x8e\xae" => "\xa5\xe7", #¥ç + "\x8e\xaf" => "\xa5\xc3", #¥Ã + "\x8e\xb0" => "\xa1\xbc", #¡¼ + "\x8e\xb1" => "\xa5\xa2", #¥¢ + "\x8e\xb2" => "\xa5\xa4", #¥¤ + "\x8e\xb3" => "\xa5\xa6", #¥¦ + "\x8e\xb4" => "\xa5\xa8", #¥¨ + "\x8e\xb5" => "\xa5\xaa", #¥ª + "\x8e\xb6" => "\xa5\xab", #¥« + "\x8e\xb7" => "\xa5\xad", #¥ + "\x8e\xb8" => "\xa5\xaf", #¥¯ + "\x8e\xb9" => "\xa5\xb1", #¥± + "\x8e\xba" => "\xa5\xb3", #¥³ + "\x8e\xbb" => "\xa5\xb5", #¥µ + "\x8e\xbc" => "\xa5\xb7", #¥· + "\x8e\xbd" => "\xa5\xb9", #¥¹ + "\x8e\xbe" => "\xa5\xbb", #¥» + "\x8e\xbf" => "\xa5\xbd", #¥½ + "\x8e\xc0" => "\xa5\xbf", #¥¿ + "\x8e\xc1" => "\xa5\xc1", #¥Á + "\x8e\xc2" => "\xa5\xc4", #¥Ä + "\x8e\xc3" => "\xa5\xc6", #¥Æ + "\x8e\xc4" => "\xa5\xc8", #¥È + "\x8e\xc5" => "\xa5\xca", #¥Ê + "\x8e\xc6" => "\xa5\xcb", #¥Ë + "\x8e\xc7" => "\xa5\xcc", #¥Ì + "\x8e\xc8" => "\xa5\xcd", #¥Í + "\x8e\xc9" => "\xa5\xce", #¥Î + "\x8e\xca" => "\xa5\xcf", #¥Ï + "\x8e\xcb" => "\xa5\xd2", #¥Ò + "\x8e\xcc" => "\xa5\xd5", #¥Õ + "\x8e\xcd" => "\xa5\xd8", #¥Ø + "\x8e\xce" => "\xa5\xdb", #¥Û + "\x8e\xcf" => "\xa5\xde", #¥Þ + "\x8e\xd0" => "\xa5\xdf", #¥ß + "\x8e\xd1" => "\xa5\xe0", #¥à + "\x8e\xd2" => "\xa5\xe1", #¥á + "\x8e\xd3" => "\xa5\xe2", #¥â + "\x8e\xd4" => "\xa5\xe4", #¥ä + "\x8e\xd5" => "\xa5\xe6", #¥æ + "\x8e\xd6" => "\xa5\xe8", #¥è + "\x8e\xd7" => "\xa5\xe9", #¥é + "\x8e\xd8" => "\xa5\xea", #¥ê + "\x8e\xd9" => "\xa5\xeb", #¥ë + "\x8e\xda" => "\xa5\xec", #¥ì + "\x8e\xdb" => "\xa5\xed", #¥í + "\x8e\xdc" => "\xa5\xef", #¥ï + "\x8e\xdd" => "\xa5\xf3", #¥ó + "\x8e\xde" => "\xa1\xab", #¡« + "\x8e\xdf" => "\xa1\xac", #¡¬ +); + +%_D2Z = ( + "\x8e\xb6\x8e\xde" => "\xa5\xac", #¥¬ + "\x8e\xb7\x8e\xde" => "\xa5\xae", #¥® + "\x8e\xb8\x8e\xde" => "\xa5\xb0", #¥° + "\x8e\xb9\x8e\xde" => "\xa5\xb2", #¥² + "\x8e\xba\x8e\xde" => "\xa5\xb4", #¥´ + "\x8e\xbb\x8e\xde" => "\xa5\xb6", #¥¶ + "\x8e\xbc\x8e\xde" => "\xa5\xb8", #¥¸ + "\x8e\xbd\x8e\xde" => "\xa5\xba", #¥º + "\x8e\xbe\x8e\xde" => "\xa5\xbc", #¥¼ + "\x8e\xbf\x8e\xde" => "\xa5\xbe", #¥¾ + "\x8e\xc0\x8e\xde" => "\xa5\xc0", #¥À + "\x8e\xc1\x8e\xde" => "\xa5\xc2", #¥Â + "\x8e\xc2\x8e\xde" => "\xa5\xc5", #¥Å + "\x8e\xc3\x8e\xde" => "\xa5\xc7", #¥Ç + "\x8e\xc4\x8e\xde" => "\xa5\xc9", #¥É + "\x8e\xca\x8e\xde" => "\xa5\xd0", #¥Ð + "\x8e\xcb\x8e\xde" => "\xa5\xd3", #¥Ó + "\x8e\xcc\x8e\xde" => "\xa5\xd6", #¥Ö + "\x8e\xcd\x8e\xde" => "\xa5\xd9", #¥Ù + "\x8e\xce\x8e\xde" => "\xa5\xdc", #¥Ü + "\x8e\xca\x8e\xdf" => "\xa5\xd1", #¥Ñ + "\x8e\xcb\x8e\xdf" => "\xa5\xd4", #¥Ô + "\x8e\xcc\x8e\xdf" => "\xa5\xd7", #¥× + "\x8e\xcd\x8e\xdf" => "\xa5\xda", #¥Ú + "\x8e\xce\x8e\xdf" => "\xa5\xdd", #¥Ý + "\x8e\xb3\x8e\xde" => "\xa5\xf4", #¥ô +); + +# init only once; + +#$_PAT_D2Z = join("|", keys %_D2Z); +#$_PAT_H2Z = join("|", keys %_H2Z); + +%_Z2H = reverse %_H2Z; +%_Z2D = reverse %_D2Z; + +#$_PAT_Z2H = join("|", keys %_Z2H); +#$_PAT_Z2D = join("|", keys %_Z2D); + +sub h2z { + no warnings qw(uninitialized); + my $r_str = shift; + my ($keep_dakuten) = @_; + my $n = 0; + unless ($keep_dakuten){ + $n = ( + $$r_str =~ s( + ($RE{EUC_KANA} + (?:\x8e[\xde\xdf])?) + ){ + my $str = $1; + $_D2Z{$str} || $_H2Z{$str} || + # in case dakuten and handakuten are side-by-side! + $_H2Z{substr($str,0,2)} . $_H2Z{substr($str,2,2)}; + }eogx + ); + }else{ + $n = ( + $$r_str =~ s( + ($RE{EUC_KANA}) + ){ + $_H2Z{$1}; + }eogx + ); + } + $n; +} + +sub z2h { + my $r_str = shift; + my $n = ( + $$r_str =~ s( + ($RE{EUC_C}|$RE{EUC_0212}|$RE{EUC_KANA}) + ){ + $_Z2D{$1} || $_Z2H{$1} || $1; + }eogx + ); + $n; +} + +1; +__END__ + + +=head1 NAME + +Encode::JP::H2Z -- internally used by Encode::JP::2022_JP* + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm b/Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm new file mode 100644 index 00000000000..28503ec760c --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/JP/JIS7.pm @@ -0,0 +1,165 @@ +package Encode::JP::JIS7; +use strict; + +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Encode qw(:fallbacks); + +for my $name ('7bit-jis', 'iso-2022-jp', 'iso-2022-jp-1'){ + my $h2z = ($name eq '7bit-jis') ? 0 : 1; + my $jis0212 = ($name eq 'iso-2022-jp') ? 0 : 1; + + $Encode::Encoding{$name} = + bless { + Name => $name, + h2z => $h2z, + jis0212 => $jis0212, + } => __PACKAGE__; +} + +use base qw(Encode::Encoding); + +# we override this to 1 so PerlIO works +sub needs_lines { 1 } + +use Encode::CJKConstants qw(:all); + +# +# decode is identical for all 2022 variants +# + +sub decode($$;$) +{ + my ($obj, $str, $chk) = @_; + my $residue = ''; + if ($chk){ + $str =~ s/([^\x00-\x7f].*)$//so and $residue = $1; + } + $residue .= jis_euc(\$str); + $_[1] = $residue if $chk; + return Encode::decode('euc-jp', $str, FB_PERLQQ); +} + +# +# encode is different +# + +sub encode($$;$) +{ + require Encode::JP::H2Z; + my ($obj, $utf8, $chk) = @_; + # empty the input string in the stack so perlio is ok + $_[1] = '' if $chk; + my ($h2z, $jis0212) = @$obj{qw(h2z jis0212)}; + my $octet = Encode::encode('euc-jp', $utf8, FB_PERLQQ) ; + $h2z and &Encode::JP::H2Z::h2z(\$octet); + euc_jis(\$octet, $jis0212); + return $octet; +} + +# +# cat_decode +# +my $re_scan_jis_g = qr{ + \G ( ($RE{JIS_0212}) | $RE{JIS_0208} | + ($RE{ISO_ASC}) | ($RE{JIS_KANA}) | ) + ([^\e]*) +}x; +sub cat_decode { # ($obj, $dst, $src, $pos, $trm, $chk) + my ($obj, undef, undef, $pos, $trm) = @_; # currently ignores $chk + my ($rdst, $rsrc, $rpos) = \@_[1,2,3]; + local ${^ENCODING}; + use bytes; + my $opos = pos($$rsrc); + pos($$rsrc) = $pos; + while ($$rsrc =~ /$re_scan_jis_g/gc) { + my ($esc, $esc_0212, $esc_asc, $esc_kana, $chunk) = + ($1, $2, $3, $4, $5); + + unless ($chunk) { $esc or last; next; } + + if ($esc && !$esc_asc) { + $chunk =~ tr/\x21-\x7e/\xa1-\xfe/; + if ($esc_kana) { + $chunk =~ s/([\xa1-\xdf])/\x8e$1/og; + } elsif ($esc_0212) { + $chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og; + } + $chunk = Encode::decode('euc-jp', $chunk, 0); + } + elsif ((my $npos = index($chunk, $trm)) >= 0) { + $$rdst .= substr($chunk, 0, $npos + length($trm)); + $$rpos += length($esc) + $npos + length($trm); + pos($$rsrc) = $opos; + return 1; + } + $$rdst .= $chunk; + $$rpos = pos($$rsrc); + } + $$rpos = pos($$rsrc); + pos($$rsrc) = $opos; + return ''; +} + +# JIS<->EUC +my $re_scan_jis = qr{ + (?:($RE{JIS_0212})|$RE{JIS_0208}|($RE{ISO_ASC})|($RE{JIS_KANA}))([^\e]*) +}x; + +sub jis_euc { + local ${^ENCODING}; + my $r_str = shift; + $$r_str =~ s($re_scan_jis) + { + my ($esc_0212, $esc_asc, $esc_kana, $chunk) = + ($1, $2, $3, $4); + if (!$esc_asc) { + $chunk =~ tr/\x21-\x7e/\xa1-\xfe/; + if ($esc_kana) { + $chunk =~ s/([\xa1-\xdf])/\x8e$1/og; + } + elsif ($esc_0212) { + $chunk =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og; + } + } + $chunk; + }geox; + my ($residue) = ($$r_str =~ s/(\e.*)$//so); + return $residue; +} + +sub euc_jis{ + no warnings qw(uninitialized); + my $r_str = shift; + my $jis0212 = shift; + $$r_str =~ s{ + ((?:$RE{EUC_C})+|(?:$RE{EUC_KANA})+|(?:$RE{EUC_0212})+) + }{ + my $chunk = $1; + my $esc = + ( $chunk =~ tr/\x8E//d ) ? $ESC{KANA} : + ( $chunk =~ tr/\x8F//d ) ? $ESC{JIS_0212} : + $ESC{JIS_0208}; + if ($esc eq $ESC{JIS_0212} && !$jis0212){ + # fallback to '?' + $chunk =~ tr/\xA1-\xFE/\x3F/; + }else{ + $chunk =~ tr/\xA1-\xFE/\x21-\x7E/; + } + $esc . $chunk . $ESC{ASC}; + }geox; + $$r_str =~ + s/\Q$ESC{ASC}\E + (\Q$ESC{KANA}\E|\Q$ESC{JIS_0212}\E|\Q$ESC{JIS_0208}\E)/$1/gox; + $$r_str; +} + +1; +__END__ + + +=head1 NAME + +Encode::JP::JIS7 -- internally used by Encode::JP + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/KR.pm b/Master/tlpkg/installer/perllib/Encode/KR.pm new file mode 100644 index 00000000000..e9d4073b7b4 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/KR.pm @@ -0,0 +1,72 @@ +package Encode::KR; +BEGIN { + if (ord("A") == 193) { + die "Encode::KR not supported on EBCDIC\n"; + } +} +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Encode; +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +use Encode::KR::2022_KR; + +1; +__END__ + +=head1 NAME + +Encode::KR - Korean Encodings + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $euc_kr = encode("euc-kr", $utf8); # loads Encode::KR implicitly + $utf8 = decode("euc-kr", $euc_kr); # ditto + +=head1 DESCRIPTION + +This module implements Korean charset encodings. Encodings supported +are as follows. + + + Canonical Alias Description + -------------------------------------------------------------------- + euc-kr /\beuc.*kr$/i EUC (Extended Unix Character) + /\bkr.*euc$/i + ksc5601-raw Korean standard code set (as is) + cp949 /(?:x-)?uhc$/i + /(?:x-)?windows-949$/i + /\bks_c_5601-1987$/i + Code Page 949 (EUC-KR + 8,822 + (additional Hangul syllables) + MacKorean EUC-KR + Apple Vendor Mappings + johab JOHAB A supplementary encoding defined in + Annex 3 of KS X 1001:1998 + iso-2022-kr iso-2022-kr [RFC1557] + -------------------------------------------------------------------- + +To find how to use this module in detail, see L<Encode>. + +=head1 BUGS + +When you see C<charset=ks_c_5601-1987> on mails and web pages, they really +mean "cp949" encodings. To fix that, the following aliases are set; + + qr/(?:x-)?uhc$/i => '"cp949"' + qr/(?:x-)?windows-949$/i => '"cp949"' + qr/ks_c_5601-1987$/i => '"cp949"' + +The ASCII region (0x00-0x7f) is preserved for all encodings, even +though this conflicts with mappings by the Unicode Consortium. See + +L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en> + +to find out why it is implemented that way. + +=head1 SEE ALSO + +L<Encode> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm b/Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm new file mode 100644 index 00000000000..8b4052be570 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/KR/2022_KR.pm @@ -0,0 +1,79 @@ +package Encode::KR::2022_KR; +use strict; + +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Encode qw(:fallbacks); + +use base qw(Encode::Encoding); +__PACKAGE__->Define('iso-2022-kr'); + +sub needs_lines { 1 } + +sub perlio_ok { + return 0; # for the time being +} + +sub decode +{ + my ($obj, $str, $chk) = @_; + my $res = $str; + my $residue = iso_euc(\$res); + # This is for PerlIO + $_[1] = $residue if $chk; + return Encode::decode('euc-kr', $res, FB_PERLQQ); +} + +sub encode +{ + my ($obj, $utf8, $chk) = @_; + # empty the input string in the stack so perlio is ok + $_[1] = '' if $chk; + my $octet = Encode::encode('euc-kr', $utf8, FB_PERLQQ) ; + euc_iso(\$octet); + return $octet; +} + +use Encode::CJKConstants qw(:all); + +# ISO<->EUC + +sub iso_euc{ + my $r_str = shift; + $$r_str =~ s/$RE{'2022_KR'}//gox; # remove the designator + $$r_str =~ s{ # replace characters in GL + \x0e # between SO(\x0e) and SI(\x0f) + ([^\x0f]*) # with characters in GR + \x0f + } + { + my $out= $1; + $out =~ tr/\x21-\x7e/\xa1-\xfe/; + $out; + }geox; + my ($residue) = ($$r_str =~ s/(\e.*)$//so); + return $residue; +} + +sub euc_iso{ + no warnings qw(uninitialized); + my $r_str = shift; + substr($$r_str,0,0)=$ESC{'2022_KR'}; # put the designator at the beg. + $$r_str =~ s{ # move KS X 1001 characters in GR to GL + ($RE{EUC_C}+) # and enclose them with SO and SI + }{ + my $str = $1; + $str =~ tr/\xA1-\xFE/\x21-\x7E/; + "\x0e" . $str . "\x0f"; + }geox; + $$r_str; +} + +1; +__END__ + +=head1 NAME + +Encode::KR::2022_KR -- internally used by Encode::KR + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/MIME/Header.pm b/Master/tlpkg/installer/perllib/Encode/MIME/Header.pm new file mode 100644 index 00000000000..f4e2ad6e2b5 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/MIME/Header.pm @@ -0,0 +1,230 @@ +package Encode::MIME::Header; +use strict; +# use warnings; +our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +use Encode qw(find_encoding encode_utf8 decode_utf8); +use MIME::Base64; +use Carp; + +my %seed = + ( + decode_b => '1', # decodes 'B' encoding ? + decode_q => '1', # decodes 'Q' encoding ? + encode => 'B', # encode with 'B' or 'Q' ? + bpl => 75, # bytes per line + ); + +$Encode::Encoding{'MIME-Header'} = + bless { + %seed, + Name => 'MIME-Header', + } => __PACKAGE__; + +$Encode::Encoding{'MIME-B'} = + bless { + %seed, + decode_q => 0, + Name => 'MIME-B', + } => __PACKAGE__; + +$Encode::Encoding{'MIME-Q'} = + bless { + %seed, + decode_q => 1, + encode => 'Q', + Name => 'MIME-Q', + } => __PACKAGE__; + +use base qw(Encode::Encoding); + +sub needs_lines { 1 } +sub perlio_ok{ 0 }; + +sub decode($$;$){ + use utf8; + my ($obj, $str, $chk) = @_; + # zap spaces between encoded words + $str =~ s/\?=\s+=\?/\?==\?/gos; + # multi-line header to single line + $str =~ s/(:?\r|\n|\r\n)[ \t]//gos; + $str =~ + s{ + =\? # begin encoded word + ([0-9A-Za-z\-_]+) # charset (encoding) + \?([QqBb])\? # delimiter + (.*?) # Base64-encodede contents + \?= # end encoded word + }{ + if (uc($2) eq 'B'){ + $obj->{decode_b} or croak qq(MIME "B" unsupported); + decode_b($1, $3); + }elsif(uc($2) eq 'Q'){ + $obj->{decode_q} or croak qq(MIME "Q" unsupported); + decode_q($1, $3); + }else{ + croak qq(MIME "$2" encoding is nonexistent!); + } + }egox; + $_[1] = '' if $chk; + return $str; +} + +sub decode_b{ + my $enc = shift; + my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc"); + my $db64 = decode_base64(shift); + return $d->name eq 'utf8' ? + Encode::decode_utf8($db64) : $d->decode($db64, Encode::FB_PERLQQ); +} + +sub decode_q{ + my ($enc, $q) = @_; + my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc"); + $q =~ s/_/ /go; + $q =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ego; + return $d->name eq 'utf8' ? + Encode::decode_utf8($q) : $d->decode($q, Encode::FB_PERLQQ); +} + +my $especials = + join('|' => + map {quotemeta(chr($_))} + unpack("C*", qq{()<>@,;:\"\'/[]?.=})); + +my $re_encoded_word = + qr{ + (?: + =\? # begin encoded word + (?:[0-9A-Za-z\-_]+) # charset (encoding) + \?(?:[QqBb])\? # delimiter + (?:.*?) # Base64-encodede contents + \?= # end encoded word + ) + }xo; + +my $re_especials = qr{$re_encoded_word|$especials}xo; + +sub encode($$;$){ + my ($obj, $str, $chk) = @_; + my @line = (); + for my $line (split /\r|\n|\r\n/o, $str){ + my (@word, @subline); + for my $word (split /($re_especials)/o, $line){ + if ($word =~ /[^\x00-\x7f]/o or $word =~ /^$re_encoded_word$/o){ + push @word, $obj->_encode($word); + }else{ + push @word, $word; + } + } + my $subline = ''; + for my $word (@word){ + use bytes (); + if (bytes::length($subline) + bytes::length($word) > $obj->{bpl}){ + push @subline, $subline; + $subline = ''; + } + $subline .= $word; + } + $subline and push @subline, $subline; + push @line, join("\n " => @subline); + } + $_[1] = '' if $chk; + return join("\n", @line); +} + +use constant HEAD => '=?UTF-8?'; +use constant TAIL => '?='; +use constant SINGLE => { B => \&_encode_b, Q => \&_encode_q, }; + +sub _encode{ + my ($o, $str) = @_; + my $enc = $o->{encode}; + my $llen = ($o->{bpl} - length(HEAD) - 2 - length(TAIL)); + # to coerce a floating-point arithmetics, the following contains + # .0 in numbers -- dankogai + $llen *= $enc eq 'B' ? 3.0/4.0 : 1.0/3.0; + my @result = (); + my $chunk = ''; + while(length(my $chr = substr($str, 0, 1, ''))){ + use bytes (); + if (bytes::length($chunk) + bytes::length($chr) > $llen){ + push @result, SINGLE->{$enc}($chunk); + $chunk = ''; + } + $chunk .= $chr; + } + $chunk and push @result, SINGLE->{$enc}($chunk); + return @result; +} + +sub _encode_b{ + HEAD . 'B?' . encode_base64(encode_utf8(shift), '') . TAIL; +} + +sub _encode_q{ + my $chunk = shift; + $chunk =~ s{ + ([^0-9A-Za-z]) + }{ + join("" => map {sprintf "=%02X", $_} unpack("C*", $1)) + }egox; + return decode_utf8(HEAD . 'Q?' . $chunk . TAIL); +} + +1; +__END__ + +=head1 NAME + +Encode::MIME::Header -- MIME 'B' and 'Q' header encoding + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $utf8 = decode('MIME-Header', $header); + $header = encode('MIME-Header', $utf8); + +=head1 ABSTRACT + +This module implements RFC 2047 Mime Header Encoding. There are 3 +variant encoding names; C<MIME-Header>, C<MIME-B> and C<MIME-Q>. The +difference is described below + + decode() encode() + ---------------------------------------------- + MIME-Header Both B and Q =?UTF-8?B?....?= + MIME-B B only; Q croaks =?UTF-8?B?....?= + MIME-Q Q only; B croaks =?UTF-8?Q?....?= + +=head1 DESCRIPTION + +When you decode(=?I<encoding>?I<X>?I<ENCODED WORD>?=), I<ENCODED WORD> +is extracted and decoded for I<X> encoding (B for Base64, Q for +Quoted-Printable). Then the decoded chunk is fed to +decode(I<encoding>). So long as I<encoding> is supported by Encode, +any source encoding is fine. + +When you encode, it just encodes UTF-8 string with I<X> encoding then +quoted with =?UTF-8?I<X>?....?= . The parts that RFC 2047 forbids to +encode are left as is and long lines are folded within 76 bytes per +line. + +=head1 BUGS + +It would be nice to support encoding to non-UTF8, such as =?ISO-2022-JP? +and =?ISO-8859-1?= but that makes the implementation too complicated. +These days major mail agents all support =?UTF-8? so I think it is +just good enough. + +Due to popular demand, 'MIME-Header-ISO_2022_JP' was introduced by +Makamaka. Thre are still too many MUAs especially cellular phone +handsets which does not grok UTF-8. + +=head1 SEE ALSO + +L<Encode> + +RFC 2047, L<http://www.faqs.org/rfcs/rfc2047.html> and many other +locations. + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm b/Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm new file mode 100644 index 00000000000..5f637a32472 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/MIME/Header/ISO_2022_JP.pm @@ -0,0 +1,127 @@ +package Encode::MIME::Header::ISO_2022_JP; + +use strict; +use base qw(Encode::MIME::Header); + +$Encode::Encoding{'MIME-Header-ISO_2022_JP'} + = bless {encode => 'B', bpl => 76, Name => 'MIME-Header-ISO_2022_JP'} + => __PACKAGE__; + +use constant HEAD => '=?ISO-2022-JP?B?'; +use constant TAIL => '?='; + +use Encode::CJKConstants qw(%RE); + +our $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + + +# I owe the below codes totally to +# Jcode by Dan Kogai & http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64 + +sub encode { + my $self = shift; + my $str = shift; + + utf8::encode($str) if( Encode::is_utf8($str) ); + Encode::from_to($str, 'utf8', 'euc-jp'); + + my($trailing_crlf) = ($str =~ /(\n|\r|\x0d\x0a)$/o); + + $str = _mime_unstructured_header($str, $self->{bpl}); + + not $trailing_crlf and $str =~ s/(\n|\r|\x0d\x0a)$//o; + + return $str; +} + + +sub _mime_unstructured_header { + my ($oldheader, $bpl) = @_; + my $crlf = $oldheader =~ /\n$/; + my($header, @words, @wordstmp, $i) = (''); + + $oldheader =~ s/\s+$//; + + @wordstmp = split /\s+/, $oldheader; + + for ($i = 0; $i < $#wordstmp; $i++){ + if( $wordstmp[$i] !~ /^[\x21-\x7E]+$/ and $wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/){ + $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]"; + } + else{ + push(@words, $wordstmp[$i]); + } + } + + push(@words, $wordstmp[-1]); + + for my $word (@words){ + if ($word =~ /^[\x21-\x7E]+$/) { + $header =~ /(?:.*\n)*(.*)/; + if (length($1) + length($word) > $bpl) { + $header .= "\n $word"; + } + else{ + $header .= $word; + } + } + else{ + $header = _add_encoded_word($word, $header, $bpl); + } + + $header =~ /(?:.*\n)*(.*)/; + + if(length($1) == $bpl){ + $header .= "\n "; + } + else { + $header .= ' '; + } + } + + $header =~ s/\n? $//mg; + + $crlf ? "$header\n" : $header; +} + + +sub _add_encoded_word { + my($str, $line, $bpl) = @_; + my $result = ''; + + while( length($str) ){ + my $target = $str; + $str = ''; + + if(length($line) + 22 + ($target =~ /^(?:$RE{EUC_0212}|$RE{EUC_C})/o) * 8 > $bpl){ + $line =~ s/[ \t\n\r]*$/\n/; + $result .= $line; + $line = ' '; + } + + while(1){ + my $iso_2022_jp = $target; + Encode::from_to($iso_2022_jp, 'euc-jp', 'iso-2022-jp'); + + my $encoded + = HEAD . MIME::Base64::encode_base64($iso_2022_jp, '') . TAIL; + + if(length($encoded) + length($line) > $bpl){ + $target =~ s/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|$RE{ASCII})$//o; + $str = $1 . $str; + } + else{ + $line .= $encoded; + last; + } + } + + } + + $result . $line; +} + + +1; +__END__ + diff --git a/Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x b/Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x new file mode 100644 index 00000000000..3bca0bff52b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Makefile_PL.e2x @@ -0,0 +1,180 @@ +# +# This file is auto-generated by: +# enc2xs version $_Version_ +# $_Now_ +# +use 5.7.2; +use strict; +use ExtUtils::MakeMaker; +use Config; + +# Please edit the following to the taste! +my $name = '$_Name_'; +my %tables = ( + $_Name__t => [ $_TableFiles_ ], + ); + +#### DO NOT EDIT BEYOND THIS POINT! +require File::Spec; +my ($enc2xs, $encode_h) = (); +PATHLOOP: +for my $d (@Config{qw/bin sitebin vendorbin/}, + (split /$Config{path_sep}/o, $ENV{PATH})){ + for my $f (qw/enc2xs enc2xs5.7.3/){ + my $path = File::Spec->catfile($d, $f); + -r $path and $enc2xs = $path and last PATHLOOP; + } +} +$enc2xs or die "enc2xs not found!"; +print "enc2xs is $enc2xs\n"; +my %encode_h = (); +for my $d (@INC){ + my $dir = File::Spec->catfile($d, "Encode"); + my $file = File::Spec->catfile($dir, "encode.h"); + -f $file and $encode_h{$dir} = -M $file; +} +%encode_h or die "encode.h not found!"; +# find the latest one +($encode_h) = sort {$encode_h{$b} <=> $encode_h{$a}} keys %encode_h; +print "encode.h is at $encode_h\n"; + +WriteMakefile( + INC => "-I$encode_h", +#### END_OF_HEADER -- DO NOT EDIT THIS LINE BY HAND! #### + NAME => 'Encode::'.$name, + VERSION_FROM => "$name.pm", + OBJECT => '$(O_FILES)', + 'dist' => { + COMPRESS => 'gzip -9f', + SUFFIX => 'gz', + DIST_DEFAULT => 'all tardist', + }, + MAN3PODS => {}, + PREREQ_PM => { + 'Encode' => "1.41", + }, + # OS 390 winges about line numbers > 64K ??? + XSOPT => '-nolinenumbers', + ); + +package MY; + +sub post_initialize +{ + my ($self) = @_; + my %o; + my $x = $self->{'OBJ_EXT'}; + # Add the table O_FILES + foreach my $e (keys %tables) + { + $o{$e.$x} = 1; + } + $o{"$name$x"} = 1; + $self->{'O_FILES'} = [sort keys %o]; + my @files = ("$name.xs"); + $self->{'C'} = ["$name.c"]; + # The next two lines to make MacPerl Happy -- dankogai via pudge + $self->{SOURCE} .= " $name.c" + if $^O eq 'MacOS' && $self->{SOURCE} !~ /\b$name\.c\b/; + # $self->{'H'} = [$self->catfile($self->updir,'encode.h')]; + my %xs; + foreach my $table (keys %tables) { + push (@{$self->{'C'}},"$table.c"); + # Do NOT add $table.h etc. to H_FILES unless we own up as to how they + # get built. + foreach my $ext (qw($(OBJ_EXT) .c .h .exh .fnm)) { + push (@files,$table.$ext); + } + } + $self->{'XS'} = { "$name.xs" => "$name.c" }; + $self->{'clean'}{'FILES'} .= join(' ',@files); + open(XS,">$name.xs") || die "Cannot open $name.xs:$!"; + print XS <<'END'; +#include <EXTERN.h> +#include <perl.h> +#include <XSUB.h> +#define U8 U8 +#include "encode.h" +END + foreach my $table (keys %tables) { + print XS qq[#include "${table}.h"\n]; + } + print XS <<"END"; + +static void +Encode_XSEncoding(pTHX_ encode_t *enc) +{ + dSP; + HV *stash = gv_stashpv("Encode::XS", TRUE); + SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash); + int i = 0; + PUSHMARK(sp); + XPUSHs(sv); + while (enc->name[i]) + { + const char *name = enc->name[i++]; + XPUSHs(sv_2mortal(newSVpvn(name,strlen(name)))); + } + PUTBACK; + call_pv("Encode::define_encoding",G_DISCARD); + SvREFCNT_dec(sv); +} + +MODULE = Encode::$name PACKAGE = Encode::$name +PROTOTYPES: DISABLE +BOOT: +{ +END + foreach my $table (keys %tables) { + print XS qq[#include "${table}.exh"\n]; + } + print XS "}\n"; + close(XS); + return "# Built $name.xs\n\n"; +} + +sub postamble +{ + my $self = shift; + my $dir = "."; # $self->catdir('Encode'); + my $str = "# $name\$(OBJ_EXT) depends on .h and .exh files not .c files - but all written by enc2xs\n"; + $str .= "$name.c : $name.xs "; + foreach my $table (keys %tables) + { + $str .= " $table.c"; + } + $str .= "\n\n"; + $str .= "$name\$(OBJ_EXT) : $name.c\n\n"; + + foreach my $table (keys %tables) + { + my $numlines = 1; + my $lengthsofar = length($str); + my $continuator = ''; + $str .= "$table.c : Makefile.PL"; + foreach my $file (@{$tables{$table}}) + { + $str .= $continuator.' '.$self->catfile($dir,$file); + if ( length($str)-$lengthsofar > 128*$numlines ) + { + $continuator .= " \\\n\t"; + $numlines++; + } else { + $continuator = ''; + } + } + my $plib = $self->{PERL_CORE} ? '"-I$(PERL_LIB)"' : ''; + my $ucopts = '-"Q"'; + $str .= + qq{\n\t\$(PERL) $plib $enc2xs $ucopts -o \$\@ -f $table.fnm\n\n}; + open (FILELIST, ">$table.fnm") + || die "Could not open $table.fnm: $!"; + foreach my $file (@{$tables{$table}}) + { + print FILELIST $self->catfile($dir,$file) . "\n"; + } + close(FILELIST); + } + return $str; +} + diff --git a/Master/tlpkg/installer/perllib/Encode/PerlIO.pod b/Master/tlpkg/installer/perllib/Encode/PerlIO.pod new file mode 100644 index 00000000000..abd1f2d10a1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/PerlIO.pod @@ -0,0 +1,167 @@ +=head1 NAME + +Encode::PerlIO -- a detailed document on Encode and PerlIO + +=head1 Overview + +It is very common to want to do encoding transformations when +reading or writing files, network connections, pipes etc. +If Perl is configured to use the new 'perlio' IO system then +C<Encode> provides a "layer" (see L<PerlIO>) which can transform +data as it is read or written. + +Here is how the blind poet would modernise the encoding: + + use Encode; + open(my $iliad,'<:encoding(iso-8859-7)','iliad.greek'); + open(my $utf8,'>:utf8','iliad.utf8'); + my @epic = <$iliad>; + print $utf8 @epic; + close($utf8); + close($illiad); + +In addition, the new IO system can also be configured to read/write +UTF-8 encoded characters (as noted above, this is efficient): + + open(my $fh,'>:utf8','anything'); + print $fh "Any \x{0021} string \N{SMILEY FACE}\n"; + +Either of the above forms of "layer" specifications can be made the default +for a lexical scope with the C<use open ...> pragma. See L<open>. + +Once a handle is open, its layers can be altered using C<binmode>. + +Without any such configuration, or if Perl itself is built using the +system's own IO, then write operations assume that the file handle +accepts only I<bytes> and will C<die> if a character larger than 255 is +written to the handle. When reading, each octet from the handle becomes +a byte-in-a-character. Note that this default is the same behaviour +as bytes-only languages (including Perl before v5.6) would have, +and is sufficient to handle native 8-bit encodings e.g. iso-8859-1, +EBCDIC etc. and any legacy mechanisms for handling other encodings +and binary data. + +In other cases, it is the program's responsibility to transform +characters into bytes using the API above before doing writes, and to +transform the bytes read from a handle into characters before doing +"character operations" (e.g. C<lc>, C</\W+/>, ...). + +You can also use PerlIO to convert larger amounts of data you don't +want to bring into memory. For example, to convert between ISO-8859-1 +(Latin 1) and UTF-8 (or UTF-EBCDIC in EBCDIC machines): + + open(F, "<:encoding(iso-8859-1)", "data.txt") or die $!; + open(G, ">:utf8", "data.utf") or die $!; + while (<F>) { print G } + + # Could also do "print G <F>" but that would pull + # the whole file into memory just to write it out again. + +More examples: + + open(my $f, "<:encoding(cp1252)") + open(my $g, ">:encoding(iso-8859-2)") + open(my $h, ">:encoding(latin9)") # iso-8859-15 + +See also L<encoding> for how to change the default encoding of the +data in your script. + +=head1 How does it work? + +Here is a crude diagram of how filehandle, PerlIO, and Encode +interact. + + filehandle <-> PerlIO PerlIO <-> scalar (read/printed) + \ / + Encode + +When PerlIO receives data from either direction, it fills a buffer +(currently with 1024 bytes) and passes the buffer to Encode. +Encode tries to convert the valid part and passes it back to PerlIO, +leaving invalid parts (usually a partial character) in the buffer. +PerlIO then appends more data to the buffer, calls Encode again, +and so on until the data stream ends. + +To do so, PerlIO always calls (de|en)code methods with CHECK set to 1. +This ensures that the method stops at the right place when it +encounters partial character. The following is what happens when +PerlIO and Encode tries to encode (from utf8) more than 1024 bytes +and the buffer boundary happens to be in the middle of a character. + + A B C .... ~ \x{3000} .... + 41 42 43 .... 7E e3 80 80 .... + <- buffer ---------------> + << encoded >>>>>>>>>> + <- next buffer ------ + +Encode converts from the beginning to \x7E, leaving \xe3 in the buffer +because it is invalid (partial character). + +Unfortunately, this scheme does not work well with escape-based +encodings such as ISO-2022-JP. + +=head1 Line Buffering + +Now let's see what happens when you try to decode from ISO-2022-JP and +the buffer ends in the middle of a character. + + JIS208-ESC \x{5f3e} + A B C .... ~ \e $ B |DAN | .... + 41 42 43 .... 7E 1b 24 41 43 46 .... + <- buffer ---------------------------> + << encoded >>>>>>>>>>>>>>>>>>>>>>> + +As you see, the next buffer begins with \x43. But \x43 is 'C' in +ASCII, which is wrong in this case because we are now in JISX 0208 +area so it has to convert \x43\x46, not \x43. Unlike utf8 and EUC, +in escape-based encodings you can't tell if a given octet is a whole +character or just part of it. + +Fortunately PerlIO also supports line buffer if you tell PerlIO to use +one instead of fixed buffer. Since ISO-2022-JP is guaranteed to revert to ASCII at the end of the line, partial +character will never happen when line buffer is used. + +To tell PerlIO to use line buffer, implement -E<gt>needs_lines method +for your encoding object. See L<Encode::Encoding> for details. + +Thanks to these efforts most encodings that come with Encode support +PerlIO but that still leaves following encodings. + + iso-2022-kr + MIME-B + MIME-Header + MIME-Q + +Fortunately iso-2022-kr is hardly used (according to Jungshik) and +MIME-* are very unlikely to be fed to PerlIO because they are for mail +headers. See L<Encode::MIME::Header> for details. + +=head2 How can I tell whether my encoding fully supports PerlIO ? + +As of this writing, any encoding whose class belongs to Encode::XS and +Encode::Unicode works. The Encode module has a C<perlio_ok> method +which you can use before applying PerlIO encoding to the filehandle. +Here is an example: + + my $use_perlio = perlio_ok($enc); + my $layer = $use_perlio ? "<:raw" : "<:encoding($enc)"; + open my $fh, $layer, $file or die "$file : $!"; + while(<$fh>){ + $_ = decode($enc, $_) unless $use_perlio; + # .... + } + +=head1 SEE ALSO + +L<Encode::Encoding>, +L<Encode::Supported>, +L<Encode::PerlIO>, +L<encoding>, +L<perlebcdic>, +L<perlfunc/open>, +L<perlunicode>, +L<utf8>, +the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Encode/README.e2x b/Master/tlpkg/installer/perllib/Encode/README.e2x new file mode 100644 index 00000000000..28a31a655c2 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/README.e2x @@ -0,0 +1,31 @@ +Encode::$_Name_ version 0.1 +======== + +NAME + Encode::$_Name_ - <describe encoding> + +SYNOPSIS + use Encode::$_Name_; + #<put more words here> +ABSTRACT + <fill this in> +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +DEPENDENCIES + +This module requires perl version 5.7.3 or later. + +COPYRIGHT AND LICENCE + +Copyright (C) 2002 Your Name <your@address.domain> + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + diff --git a/Master/tlpkg/installer/perllib/Encode/Supported.pod b/Master/tlpkg/installer/perllib/Encode/Supported.pod new file mode 100644 index 00000000000..651f7e6ed4f --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Supported.pod @@ -0,0 +1,890 @@ +=head1 NAME + +Encode::Supported -- Encodings supported by Encode + +=head1 DESCRIPTION + +=head2 Encoding Names + +Encoding names are case insensitive. White space in names +is ignored. In addition, an encoding may have aliases. +Each encoding has one "canonical" name. The "canonical" +name is chosen from the names of the encoding by picking +the first in the following sequence (with a few exceptions). + +=over 4 + +=item * + +The name used by the Perl community. That includes 'utf8' and 'ascii'. +Unlike aliases, canonical names directly reach the method so such +frequently used words like 'utf8' don't need to do alias lookups. + +=item * + +The MIME name as defined in IETF RFCs. This includes all "iso-"s. + +=item * + +The name in the IANA registry. + +=item * + +The name used by the organization that defined it. + +=back + +In case I<de jure> canonical names differ from that of the Encode +module, they are always aliased if it ever be implemented. So you can +safely tell if a given encoding is implemented or not just by passing +the canonical name. + +Because of all the alias issues, and because in the general case +encodings have state, "Encode" uses an encoding object internally +once an operation is in progress. + +=head1 Supported Encodings + +As of Perl 5.8.0, at least the following encodings are recognized. +Note that unless otherwise specified, they are all case insensitive +(via alias) and all occurrence of spaces are replaced with '-'. +In other words, "ISO 8859 1" and "iso-8859-1" are identical. + +Encodings are categorized and implemented in several different modules +but you don't have to C<use Encode::XX> to make them available for +most cases. Encode.pm will automatically load those modules on demand. + +=head2 Built-in Encodings + +The following encodings are always available. + + Canonical Aliases Comments & References + ---------------------------------------------------------------- + ascii US-ascii ISO-646-US [ECMA] + ascii-ctrl Special Encoding + iso-8859-1 latin1 [ISO] + null Special Encoding + utf8 UTF-8 [RFC2279] + ---------------------------------------------------------------- + +I<null> and I<ascii-ctrl> are special. "null" fails for all character +so when you set fallback mode to PERLQQ, HTMLCREF or XMLCREF, ALL +CHARACTERS will fall back to character references. Ditto for +"ascii-ctrl" except for control characters. For fallback modes, see +L<Encode>. + +=head2 Encode::Unicode -- other Unicode encodings + +Unicode coding schemes other than native utf8 are supported by +Encode::Unicode, which will be autoloaded on demand. + + ---------------------------------------------------------------- + UCS-2BE UCS-2, iso-10646-1 [IANA, UC] + UCS-2LE [UC] + UTF-16 [UC] + UTF-16BE [UC] + UTF-16LE [UC] + UTF-32 [UC] + UTF-32BE UCS-4 [UC] + UTF-32LE [UC] + UTF-7 [RFC2152] + ---------------------------------------------------------------- + +To find how (UCS-2|UTF-(16|32))(LE|BE)? differ from one another, +see L<Encode::Unicode>. + +UTF-7 is a special encoding which "re-encodes" UTF-16BE into a 7-bit +encoding. It is implemented seperately by Encode::Unicode::UTF7. + +=head2 Encode::Byte -- Extended ASCII + +Encode::Byte implements most single-byte encodings except for +Symbols and EBCDIC. The following encodings are based on single-byte +encodings implemented as extended ASCII. Most of them map +\x80-\xff (upper half) to non-ASCII characters. + +=over 4 + +=item ISO-8859 and corresponding vendor mappings + +Since there are so many, they are presented in table format with +languages and corresponding encoding names by vendors. Note that +the table is sorted in order of ISO-8859 and the corresponding vendor +mappings are slightly different from that of ISO. See +L<http://czyborra.com/charsets/iso8859.html> for details. + + Lang/Regions ISO/Other Std. DOS Windows Macintosh Others + ---------------------------------------------------------------- + N. America (ASCII) cp437 AdobeStandardEncoding + cp863 (DOSCanadaF) + W. Europe iso-8859-1 cp850 cp1252 MacRoman nextstep + hp-roman8 + cp860 (DOSPortuguese) + Cntrl. Europe iso-8859-2 cp852 cp1250 MacCentralEurRoman + MacCroatian + MacRomanian + MacRumanian + Latin3[1] iso-8859-3 + Latin4[2] iso-8859-4 + Cyrillics iso-8859-5 cp855 cp1251 MacCyrillic + (See also next section) cp866 MacUkrainian + Arabic iso-8859-6 cp864 cp1256 MacArabic + cp1006 MacFarsi + Greek iso-8859-7 cp737 cp1253 MacGreek + cp869 (DOSGreek2) + Hebrew iso-8859-8 cp862 cp1255 MacHebrew + Turkish iso-8859-9 cp857 cp1254 MacTurkish + Nordics iso-8859-10 cp865 + cp861 MacIcelandic + MacSami + Thai iso-8859-11[3] cp874 MacThai + (iso-8859-12 is nonexistent. Reserved for Indics?) + Baltics iso-8859-13 cp775 cp1257 + Celtics iso-8859-14 + Latin9 [4] iso-8859-15 + Latin10 iso-8859-16 + Vietnamese viscii cp1258 MacVietnamese + ---------------------------------------------------------------- + + [1] Esperanto, Maltese, and Turkish. Turkish is now on 8859-9. + [2] Baltics. Now on 8859-10, except for Latvian. + [3] TIS 620 + Non-Breaking Space (0xA0 / U+00A0) + [4] Nicknamed Latin0; the Euro sign as well as French and Finnish + letters that are missing from 8859-1 were added. + +All cp* are also available as ibm-*, ms-*, and windows-* . See also +L<http://czyborra.com/charsets/codepages.html>. + +Macintosh encodings don't seem to be registered in such entities as +IANA. "Canonical" names in Encode are based upon Apple's Tech Note +1150. See L<http://developer.apple.com/technotes/tn/tn1150.html> +for details. + +=item KOI8 - De Facto Standard for the Cyrillic world + +Though ISO-8859 does have ISO-8859-5, the KOI8 series is far more +popular in the Net. L<Encode> comes with the following KOI charsets. +For gory details, see L<http://czyborra.com/charsets/cyrillic.html> + + ---------------------------------------------------------------- + koi8-f + koi8-r cp878 [RFC1489] + koi8-u [RFC2319] + ---------------------------------------------------------------- + +=item gsm0338 - Hentai Latin 1 + +GSM0338 is for GSM handsets. Though it shares alphanumerals with +ASCII, control character ranges and other parts are mapped very +differently, mainly to store Greek characters. There are also escape +sequences (starting with 0x1B) to cover e.g. the Euro sign. Some +special cases like a trailing 0x00 byte or a lone 0x1B byte are not +well-defined and decode() will return an empty string for them. +One possible workaround is + + $gsm =~ s/\x00\z/\x00\x00/; + $uni = decode("gsm0338", $gsm); + $uni .= "\xA0" if $gsm =~ /\x1B\z/; + +Note that the Encode implementation of GSM0338 does not implement the +reuse of Latin capital letters as Greek capital letters (for example, +the 0x5A is U+005A (LATIN CAPITAL LETTER Z), not U+0396 (GREEK CAPITAL +LETTER ZETA). + +The GSM0338 is also covered in Encode::Byte even though it is not +an "extended ASCII" encoding. + +=back + +=head2 CJK: Chinese, Japanese, Korean (Multibyte) + +Note that Vietnamese is listed above. Also read "Encoding vs Charset" +below. Also note that these are implemented in distinct modules by +countries, due to the size concerns (simplified Chinese is mapped +to 'CN', continental China, while traditional Chinese is mapped to +'TW', Taiwan). Please refer to their respective documentation pages. + +=over 4 + +=item Encode::CN -- Continental China + + Standard DOS/Win Macintosh Comment/Reference + ---------------------------------------------------------------- + euc-cn [1] MacChineseSimp + (gbk) cp936 [2] + gb12345-raw { GB12345 without CES } + gb2312-raw { GB2312 without CES } + hz + iso-ir-165 + ---------------------------------------------------------------- + + [1] GB2312 is aliased to this. See L<Microsoft-related naming mess> + [2] gbk is aliased to this. See L<Microsoft-related naming mess> + +=item Encode::JP -- Japan + + Standard DOS/Win Macintosh Comment/Reference + ---------------------------------------------------------------- + euc-jp + shiftjis cp932 macJapanese + 7bit-jis + iso-2022-jp [RFC1468] + iso-2022-jp-1 [RFC2237] + jis0201-raw { JIS X 0201 (roman + halfwidth kana) without CES } + jis0208-raw { JIS X 0208 (Kanji + fullwidth kana) without CES } + jis0212-raw { JIS X 0212 (Extended Kanji) without CES } + ---------------------------------------------------------------- + +=item Encode::KR -- Korea + + Standard DOS/Win Macintosh Comment/Reference + ---------------------------------------------------------------- + euc-kr MacKorean [RFC1557] + cp949 [1] + iso-2022-kr [RFC1557] + johab [KS X 1001:1998, Annex 3] + ksc5601-raw { KSC5601 without CES } + ---------------------------------------------------------------- + + [1] ks_c_5601-1987, (x-)?windows-949, and uhc are aliased to this. + See below. + +=item Encode::TW -- Taiwan + + Standard DOS/Win Macintosh Comment/Reference + ---------------------------------------------------------------- + big5-eten cp950 MacChineseTrad {big5 aliased to big5-eten} + big5-hkscs + ---------------------------------------------------------------- + +=item Encode::HanExtra -- More Chinese via CPAN + +Due to the size concerns, additional Chinese encodings below are +distributed separately on CPAN, under the name Encode::HanExtra. + + Standard DOS/Win Macintosh Comment/Reference + ---------------------------------------------------------------- + big5ext CMEX's Big5e Extension + big5plus CMEX's Big5+ Extension + cccii Chinese Character Code for Information Interchange + euc-tw EUC (Extended Unix Character) + gb18030 GBK with Traditional Characters + ---------------------------------------------------------------- + +=item Encode::JIS2K -- JIS X 0213 encodings via CPAN + +Due to size concerns, additional Japanese encodings below are +distributed separately on CPAN, under the name Encode::JIS2K. + + Standard DOS/Win Macintosh Comment/Reference + ---------------------------------------------------------------- + euc-jisx0213 + shiftjisx0123 + iso-2022-jp-3 + jis0213-1-raw + jis0213-2-raw + ---------------------------------------------------------------- + +=back + +=head2 Miscellaneous encodings + +=over 4 + +=item Encode::EBCDIC + +See L<perlebcdic> for details. + + ---------------------------------------------------------------- + cp37 + cp500 + cp875 + cp1026 + cp1047 + posix-bc + ---------------------------------------------------------------- + +=item Encode::Symbols + +For symbols and dingbats. + + ---------------------------------------------------------------- + symbol + dingbats + MacDingbats + AdobeZdingbat + AdobeSymbol + ---------------------------------------------------------------- + +=item Encode::MIME::Header + +Strictly speaking, MIME header encoding documented in RFC 2047 is more +of encapsulation than encoding. However, their support in modern +world is imperative so they are supported. + + ---------------------------------------------------------------- + MIME-Header [RFC2047] + MIME-B [RFC2047] + MIME-Q [RFC2047] + ---------------------------------------------------------------- + +=item Encode::Guess + +This one is not a name of encoding but a utility that lets you pick up +the most appropriate encoding for a data out of given I<suspects>. See +L<Encode::Guess> for details. + +=back + +=head1 Unsupported encodings + +The following encodings are not supported as yet; some because they +are rarely used, some because of technical difficulties. They may +be supported by external modules via CPAN in the future, however. + +=over 4 + +=item ISO-2022-JP-2 [RFC1554] + +Not very popular yet. Needs Unicode Database or equivalent to +implement encode() (because it includes JIS X 0208/0212, KSC5601, and +GB2312 simultaneously, whose code points in Unicode overlap. So you +need to lookup the database to determine to what character set a given +Unicode character should belong). + +=item ISO-2022-CN [RFC1922] + +Not very popular. Needs CNS 11643-1 and -2 which are not available in +this module. CNS 11643 is supported (via euc-tw) in Encode::HanExtra. +Autrijus Tang may add support for this encoding in his module in future. + +=item Various HP-UX encodings + +The following are unsupported due to the lack of mapping data. + + '8' - arabic8, greek8, hebrew8, kana8, thai8, and turkish8 + '15' - japanese15, korean15, and roi15 + +=item Cyrillic encoding ISO-IR-111 + +Anton Tagunov doubts its usefulness. + +=item ISO-8859-8-1 [Hebrew] + +None of the Encode team knows Hebrew enough (ISO-8859-8, cp1255 and +MacHebrew are supported because and just because there were mappings +available at L<http://www.unicode.org/>). Contributions welcome. + +=item ISIRI 3342, Iran System, ISIRI 2900 [Farsi] + +Ditto. + +=item Thai encoding TCVN + +Ditto. + +=item Vietnamese encodings VPS + +Though Jungshik Shin has reported that Mozilla supports this encoding, +it was too late before 5.8.0 for us to add it. In the future, it +may be available via a separate module. See +L<http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.uf> +and +L<http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.ut> +if you are interested in helping us. + +=item Various Mac encodings + +The following are unsupported due to the lack of mapping data. + + MacArmenian, MacBengali, MacBurmese, MacEthiopic + MacExtArabic, MacGeorgian, MacKannada, MacKhmer + MacLaotian, MacMalayalam, MacMongolian, MacOriya + MacSinhalese, MacTamil, MacTelugu, MacTibetan + MacVietnamese + +The rest which are already available are based upon the vendor mappings +at L<http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/> . + +=item (Mac) Indic encodings + +The maps for the following are available at L<http://www.unicode.org/> +but remain unsupport because those encodings need algorithmical +approach, currently unsupported by F<enc2xs>: + + MacDevanagari + MacGurmukhi + MacGujarati + +For details, please see C<Unicode mapping issues and notes:> at +L<http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/DEVANAGA.TXT> . + +I believe this issue is prevalent not only for Mac Indics but also in +other Indic encodings, but the above were the only Indic encodings +maps that I could find at L<http://www.unicode.org/> . + +=back + +=head1 Encoding vs. Charset -- terminology + +We are used to using the term (character) I<encoding> and I<character +set> interchangeably. But just as confusing the terms byte and +character is dangerous and the terms should be differentiated when +needed, we need to differentiate I<encoding> and I<character set>. + +To understand that, here is a description of how we make computers +grok our characters. + +=over 4 + +=item * + +First we start with which characters to include. We call this +collection of characters I<character repertoire>. + +=item * + +Then we have to give each character a unique ID so your computer can +tell the difference between 'a' and 'A'. This itemized character +repertoire is now a I<character set>. + +=item * + +If your computer can grow the character set without further +processing, you can go ahead and use it. This is called a I<coded +character set> (CCS) or I<raw character encoding>. ASCII is used this +way for most cases. + +=item * + +But in many cases, especially multi-byte CJK encodings, you have to +tweak a little more. Your network connection may not accept any data +with the Most Significant Bit set, and your computer may not be able to +tell if a given byte is a whole character or just half of it. So you +have to I<encode> the character set to use it. + +A I<character encoding scheme> (CES) determines how to encode a given +character set, or a set of multiple character sets. 7bit ISO-2022 is +an example of a CES. You switch between character sets via I<escape +sequences>. + +=back + +Technically, or mathematically, speaking, a character set encoded in +such a CES that maps character by character may form a CCS. EUC is such +an example. The CES of EUC is as follows: + +=over 4 + +=item * + +Map ASCII unchanged. + +=item * + +Map such a character set that consists of 94 or 96 powered by N +members by adding 0x80 to each byte. + +=item * + +You can also use 0x8e and 0x8f to indicate that the following sequence of +characters belongs to yet another character set. To each following byte +is added the value 0x80. + +=back + +By carefully looking at the encoded byte sequence, you can find that the +byte sequence conforms a unique number. In that sense, EUC is a CCS +generated by a CES above from up to four CCS (complicated?). UTF-8 +falls into this category. See L<perlUnicode/"UTF-8"> to find out how +UTF-8 maps Unicode to a byte sequence. + +You may also have found out by now why 7bit ISO-2022 cannot comprise +a CCS. If you look at a byte sequence \x21\x21, you can't tell if +it is two !'s or IDEOGRAPHIC SPACE. EUC maps the latter to \xA1\xA1 +so you have no trouble differentiating between "!!". and S<" ">. + +=head1 Encoding Classification (by Anton Tagunov and Dan Kogai) + +This section tries to classify the supported encodings by their +applicability for information exchange over the Internet and to +choose the most suitable aliases to name them in the context of +such communication. + +=over 4 + +=item * + +To (en|de)code encodings marked by C<(**)>, you need +C<Encode::HanExtra>, available from CPAN. + +=back + +Encoding names + + US-ASCII UTF-8 ISO-8859-* KOI8-R + Shift_JIS EUC-JP ISO-2022-JP ISO-2022-JP-1 + EUC-KR Big5 GB2312 + +are registered with IANA as preferred MIME names and may +be used over the Internet. + +C<Shift_JIS> has been officialized by JIS X 0208:1997. +L<Microsoft-related naming mess> gives details. + +C<GB2312> is the IANA name for C<EUC-CN>. +See L<Microsoft-related naming mess> for details. + +C<GB_2312-80> I<raw> encoding is available as C<gb2312-raw> +with Encode. See L<Encode::CN> for details. + + EUC-CN + KOI8-U [RFC2319] + +have not been registered with IANA (as of March 2002) but +seem to be supported by major web browsers. +The IANA name for C<EUC-CN> is C<GB2312>. + + KS_C_5601-1987 + +is heavily misused. +See L<Microsoft-related naming mess> for details. + +C<KS_C_5601-1987> I<raw> encoding is available as C<kcs5601-raw> +with Encode. See L<Encode::KR> for details. + + UTF-16 UTF-16BE UTF-16LE + +are IANA-registered C<charset>s. See [RFC 2781] for details. +Jungshik Shin reports that UTF-16 with a BOM is well accepted +by MS IE 5/6 and NS 4/6. Beware however that + +=over 4 + +=item * + +C<UTF-16> support in any software you're going to be +using/interoperating with has probably been less tested +then C<UTF-8> support + +=item * + +C<UTF-8> coded data seamlessly passes traditional +command piping (C<cat>, C<more>, etc.) while C<UTF-16> coded +data is likely to cause confusion (with its zero bytes, +for example) + +=item * + +it is beyond the power of words to describe the way HTML browsers +encode non-C<ASCII> form data. To get a general impression, visit +L<http://ppewww.ph.gla.ac.uk/~flavell/charset/form-i18n.html>. +While encoding of form data has stabilized for C<UTF-8> encoded pages +(at least IE 5/6, NS 6, and Opera 6 behave consistently), be sure to +expect fun (and cross-browser discrepancies) with C<UTF-16> encoded +pages! + +=back + +The rule of thumb is to use C<UTF-8> unless you know what +you're doing and unless you really benefit from using C<UTF-16>. + + ISO-IR-165 [RFC1345] + VISCII + GB 12345 + GB 18030 (**) (see links bellow) + EUC-TW (**) + +are totally valid encodings but not registered at IANA. +The names under which they are listed here are probably the +most widely-known names for these encodings and are recommended +names. + + BIG5PLUS (**) + +is a proprietary name. + +=head2 Microsoft-related naming mess + +Microsoft products misuse the following names: + +=over 4 + +=item KS_C_5601-1987 + +Microsoft extension to C<EUC-KR>. + +Proper names: C<CP949>, C<UHC>, C<x-windows-949> (as used by Mozilla). + +See L<http://lists.w3.org/Archives/Public/ietf-charsets/2001AprJun/0033.html> +for details. + +Encode aliases C<KS_C_5601-1987> to C<cp949> to reflect this common +misusage. I<Raw> C<KS_C_5601-1987> encoding is available as +C<kcs5601-raw>. + +See L<Encode::KR> for details. + +=item GB2312 + +Microsoft extension to C<EUC-CN>. + +Proper names: C<CP936>, C<GBK>. + +C<GB2312> has been registered in the C<EUC-CN> meaning at +IANA. This has partially repaired the situation: Microsoft's +C<GB2312> has become a superset of the official C<GB2312>. + +Encode aliases C<GB2312> to C<euc-cn> in full agreement with +IANA registration. C<cp936> is supported separately. +I<Raw> C<GB_2312-80> encoding is available as C<gb2312-raw>. + +See L<Encode::CN> for details. + +=item Big5 + +Microsoft extension to C<Big5>. + +Proper name: C<CP950>. + +Encode separately supports C<Big5> and C<cp950>. + +=item Shift_JIS + +Microsoft's understanding of C<Shift_JIS>. + +JIS has not endorsed the full Microsoft standard however. +The official C<Shift_JIS> includes only JIS X 0201 and JIS X 0208 +character sets, while Microsoft has always used C<Shift_JIS> +to encode a wider character repertoire. See C<IANA> registration for +C<Windows-31J>. + +As a historical predecessor, Microsoft's variant +probably has more rights for the name, though it may be objected +that Microsoft shouldn't have used JIS as part of the name +in the first place. + +Unambiguous name: C<CP932>. C<IANA> name (also used by Mozilla, and +provided as an alias by Encode): C<Windows-31J>. + +Encode separately supports C<Shift_JIS> and C<cp932>. + +=back + +=head1 Glossary + +=over 4 + +=item character repertoire + +A collection of unique characters. A I<character> set in the strictest +sense. At this stage, characters are not numbered. + +=item coded character set (CCS) + +A character set that is mapped in a way computers can use directly. +Many character encodings, including EUC, fall in this category. + +=item character encoding scheme (CES) + +An algorithm to map a character set to a byte sequence. You don't +have to be able to tell which character set a given byte sequence +belongs. 7-bit ISO-2022 is a CES but it cannot be a CCS. EUC is an +example of being both a CCS and CES. + +=item charset (in MIME context) + +has long been used in the meaning of C<encoding>, CES. + +While the word combination C<character set> has lost this meaning +in MIME context since [RFC 2130], the C<charset> abbreviation has +retained it. This is how [RFC 2277] and [RFC 2278] bless C<charset>: + + This document uses the term "charset" to mean a set of rules for + mapping from a sequence of octets to a sequence of characters, such + as the combination of a coded character set and a character encoding + scheme; this is also what is used as an identifier in MIME "charset=" + parameters, and registered in the IANA charset registry ... (Note + that this is NOT a term used by other standards bodies, such as ISO). + [RFC 2277] + +=item EUC + +Extended Unix Character. See ISO-2022. + +=item ISO-2022 + +A CES that was carefully designed to coexist with ASCII. There are a 7 +bit version and an 8 bit version. + +The 7 bit version switches character set via escape sequence so it +cannot form a CCS. Since this is more difficult to handle in programs +than the 8 bit version, the 7 bit version is not very popular except for +iso-2022-jp, the I<de facto> standard CES for e-mails. + +The 8 bit version can form a CCS. EUC and ISO-8859 are two examples +thereof. Pre-5.6 perl could use them as string literals. + +=item UCS + +Short for I<Universal Character Set>. When you say just UCS, it means +I<Unicode>. + +=item UCS-2 + +ISO/IEC 10646 encoding form: Universal Character Set coded in two +octets. + +=item Unicode + +A character set that aims to include all character repertoires of the +world. Many character sets in various national as well as industrial +standards have become, in a way, just subsets of Unicode. + +=item UTF + +Short for I<Unicode Transformation Format>. Determines how to map a +Unicode character into a byte sequence. + +=item UTF-16 + +A UTF in 16-bit encoding. Can either be in big endian or little +endian. The big endian version is called UTF-16BE (equal to UCS-2 + +surrogate support) and the little endian version is called UTF-16LE. + +=back + +=head1 See Also + +L<Encode>, +L<Encode::Byte>, +L<Encode::CN>, L<Encode::JP>, L<Encode::KR>, L<Encode::TW>, +L<Encode::EBCDIC>, L<Encode::Symbol> +L<Encode::MIME::Header>, L<Encode::Guess> + +=head1 References + +=over 4 + +=item ECMA + +European Computer Manufacturers Association +L<http://www.ecma.ch> + +=over 4 + +=item ECMA-035 (eq C<ISO-2022>) + +L<http://www.ecma.ch/ecma1/STAND/ECMA-035.HTM> + +The specification of ISO-2022 is available from the link above. + +=back + +=item IANA + +Internet Assigned Numbers Authority +L<http://www.iana.org/> + +=over 4 + +=item Assigned Charset Names by IANA + +L<http://www.iana.org/assignments/character-sets> + +Most of the C<canonical names> in Encode derive from this list +so you can directly apply the string you have extracted from MIME +header of mails and web pages. + +=back + +=item ISO + +International Organization for Standardization +L<http://www.iso.ch/> + +=item RFC + +Request For Comments -- need I say more? +L<http://www.rfc-editor.org/>, L<http://www.rfc.net/>, +L<http://www.faqs.org/rfcs/> + +=item UC + +Unicode Consortium +L<http://www.unicode.org/> + +=over 4 + +=item Unicode Glossary + +L<http://www.unicode.org/glossary/> + +The glossary of this document is based upon this site. + +=back + +=back + +=head2 Other Notable Sites + +=over 4 + +=item czyborra.com + +L<http://czyborra.com/> + +Contains a lot of useful information, especially gory details of ISO +vs. vendor mappings. + +=item CJK.inf + +L<http://www.oreilly.com/people/authors/lunde/cjk_inf.html> + +Somewhat obsolete (last update in 1996), but still useful. Also try + +L<ftp://ftp.oreilly.com/pub/examples/nutshell/cjkv/pdf/GB18030_Summary.pdf> + +You will find brief info on C<EUC-CN>, C<GBK> and mostly on C<GB 18030>. + +=item Jungshik Shin's Hangul FAQ + +L<http://jshin.net/faq> + +And especially its subject 8. + +L<http://jshin.net/faq/qa8.html> + +A comprehensive overview of the Korean (C<KS *>) standards. + +=item debian.org: "Introduction to i18n" + +A brief description for most of the mentioned CJK encodings is +contained in +L<http://www.debian.org/doc/manuals/intro-i18n/ch-codes.en.html> + +=back + +=head2 Offline sources + +=over 4 + +=item C<CJKV Information Processing> by Ken Lunde + +CJKV Information Processing +1999 O'Reilly & Associates, ISBN : 1-56592-224-7 + +The modern successor of C<CJK.inf>. + +Features a comprehensive coverage of CJKV character sets and +encodings along with many other issues faced by anyone trying +to better support CJKV languages/scripts in all the areas of +information processing. + +To purchase this book, visit +L<http://www.oreilly.com/catalog/cjkvinfo/> +or your favourite bookstore. + +=back + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Symbol.pm b/Master/tlpkg/installer/perllib/Encode/Symbol.pm new file mode 100644 index 00000000000..7ad8ca92c7d --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Symbol.pm @@ -0,0 +1,42 @@ +package Encode::Symbol; +use Encode; +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +1; +__END__ + +=head1 NAME + +Encode::Symbol - Symbol Encodings + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $symbol = encode("symbol", $utf8); # loads Encode::Symbol implicitly + $utf8 = decode("", $symbol); # ditto + +=head1 ABSTRACT + +This module implements symbol and dingbats encodings. Encodings +supported are as follows. + + Canonical Alias Description + -------------------------------------------------------------------- + symbol + dingbats + AdobeZDingbat + AdobeSymbol + MacDingbats + +=head1 DESCRIPTION + +To find out how to use this module in detail, see L<Encode>. + +=head1 SEE ALSO + +L<Encode> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/TW.pm b/Master/tlpkg/installer/perllib/Encode/TW.pm new file mode 100644 index 00000000000..2e1abc0c7f9 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/TW.pm @@ -0,0 +1,78 @@ +package Encode::TW; +BEGIN { + if (ord("A") == 193) { + die "Encode::TW not supported on EBCDIC\n"; + } +} +our $VERSION = do { my @r = (q$Revision: 2.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Encode; +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +1; +__END__ + +=head1 NAME + +Encode::TW - Taiwan-based Chinese Encodings + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $big5 = encode("big5", $utf8); # loads Encode::TW implicitly + $utf8 = decode("big5", $big5); # ditto + +=head1 DESCRIPTION + +This module implements tradition Chinese charset encodings as used +in Taiwan and Hong Kong. +Encodings supported are as follows. + + Canonical Alias Description + -------------------------------------------------------------------- + big5-eten /\bbig-?5$/i Big5 encoding (with ETen extensions) + /\bbig5-?et(en)?$/i + /\btca-?big5$/i + big5-hkscs /\bbig5-?hk(scs)?$/i + /\bhk(scs)?-?big5$/i + Big5 + Cantonese characters in Hong Kong + MacChineseTrad Big5 + Apple Vendor Mappings + cp950 Code Page 950 + = Big5 + Microsoft vendor mappings + -------------------------------------------------------------------- + +To find out how to use this module in detail, see L<Encode>. + +=head1 NOTES + +Due to size concerns, C<EUC-TW> (Extended Unix Character), C<CCCII> +(Chinese Character Code for Information Interchange), C<BIG5PLUS> +(CMEX's Big5+) and C<BIG5EXT> (CMEX's Big5e) are distributed separately +on CPAN, under the name L<Encode::HanExtra>. That module also contains +extra China-based encodings. + +=head1 BUGS + +Since the original C<big5> encoding (1984) is not supported anywhere +(glibc and DOS-based systems uses C<big5> to mean C<big5-eten>; Microsoft +uses C<big5> to mean C<cp950>), a conscious decision was made to alias +C<big5> to C<big5-eten>, which is the de facto superset of the original +big5. + +The C<CNS11643> encoding files are not complete. For common C<CNS11643> +manipulation, please use C<EUC-TW> in L<Encode::HanExtra>, which contains +planes 1-7. + +The ASCII region (0x00-0x7f) is preserved for all encodings, even +though this conflicts with mappings by the Unicode Consortium. See + +L<http://www.debian.or.jp/~kubota/unicode-symbols.html.en> + +to find out why it is implemented that way. + +=head1 SEE ALSO + +L<Encode> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/Unicode/UTF7.pm b/Master/tlpkg/installer/perllib/Encode/Unicode/UTF7.pm new file mode 100644 index 00000000000..dc75ce37816 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/Unicode/UTF7.pm @@ -0,0 +1,118 @@ +# +# $Id: UTF7.pm,v 2.1 2004/05/25 16:27:14 dankogai Exp $ +# +package Encode::Unicode::UTF7; +use strict; +no warnings 'redefine'; +use base qw(Encode::Encoding); +__PACKAGE__->Define('UTF-7'); +our $VERSION = do { my @r = (q$Revision: 2.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +use MIME::Base64; +use Encode; + +# +# Algorithms taken from Unicode::String by Gisle Aas +# + +our $OPTIONAL_DIRECT_CHARS = 1; +my $specials = quotemeta "\'(),-./:?"; +$OPTIONAL_DIRECT_CHARS and + $specials .= quotemeta "!\"#$%&*;<=>@[]^_`{|}"; +# \s will not work because it matches U+3000 DEOGRAPHIC SPACE +# We use qr/[\n\r\t\ ] instead +my $re_asis = qr/(?:[\n\r\t\ A-Za-z0-9$specials])/; +my $re_encoded = qr/(?:[^\n\r\t\ A-Za-z0-9$specials])/; +my $e_utf16 = find_encoding("UTF-16BE"); + +sub needs_lines { 1 }; + +sub encode($$;$){ + my ($obj, $str, $chk) = @_; + my $len = length($str); + pos($str) = 0; + my $bytes = ''; + while (pos($str) < $len){ + if ($str =~ /\G($re_asis+)/ogc){ + $bytes .= $1; + }elsif($str =~ /\G($re_encoded+)/ogsc){ + if ($1 eq "+"){ + $bytes .= "+-"; + }else{ + my $s = $1; + my $base64 = encode_base64($e_utf16->encode($s), ''); + $base64 =~ s/=+$//; + $bytes .= "+$base64-"; + } + }else{ + die "This should not happen! (pos=" . pos($str) . ")"; + } + } + $_[1] = '' if $chk; + return $bytes; +} + +sub decode{ + my ($obj, $bytes, $chk) = @_; + my $len = length($bytes); + my $str = ""; + while (pos($bytes) < $len) { + if ($bytes =~ /\G([^+]+)/ogc) { + $str .= $1; + }elsif($bytes =~ /\G\+-/ogc) { + $str .= "+"; + }elsif($bytes =~ /\G\+([A-Za-z0-9+\/]+)-?/ogsc) { + my $base64 = $1; + my $pad = length($base64) % 4; + $base64 .= "=" x (4 - $pad) if $pad; + $str .= $e_utf16->decode(decode_base64($base64)); + }elsif($bytes =~ /\G\+/ogc) { + $^W and warn "Bad UTF7 data escape"; + $str .= "+"; + }else{ + die "This should not happen " . pos($bytes); + } + } + $_[1] = '' if $chk; + return $str; +} +1; +__END__ + +=head1 NAME + +Encode::Unicode::UTF7 -- UTF-7 encoding + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $utf7 = encode("UTF-7", $utf8); + $utf8 = decode("UTF-7", $ucs2); + +=head1 ABSTRACT + +This module implements UTF-7 encoding documented in RFC 2152. UTF-7, +as its name suggests, is a 7-bit re-encoded version of UTF-16BE. It +is designed to be MTA-safe and expected to be a standard way to +exchange Unicoded mails via mails. But with the advent of UTF-8 and +8-bit compliant MTAs, UTF-7 is hardly ever used. + +UTF-7 was not supported by Encode until version 1.95 because of that. +But Unicode::String, a module by Gisle Aas which adds Unicode supports +to non-utf8-savvy perl did support UTF-7, the UTF-7 support was added +so Encode can supersede Unicode::String 100%. + +=head1 In Practice + +When you want to encode Unicode for mails and web pages, however, do +not use UTF-7 unless you are sure your recipients and readers can +handle it. Very few MUAs and WWW Browsers support these days (only +Mozilla seems to support one). For general cases, use UTF-8 for +message body and MIME-Header for header instead. + +=head1 SEE ALSO + +L<Encode>, L<Encode::Unicode>, L<Unicode::String> + +RFC 2781 L<http://www.ietf.org/rfc/rfc2152.txt> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/_PM.e2x b/Master/tlpkg/installer/perllib/Encode/_PM.e2x new file mode 100644 index 00000000000..eb59cd1b520 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/_PM.e2x @@ -0,0 +1,23 @@ +package Encode::$_Name_; +our $VERSION = "0.01"; + +use Encode; +use XSLoader; +XSLoader::load(__PACKAGE__,$VERSION); + +1; +__END__ + +=head1 NAME + +Encode::$_Name_ - New Encoding + +=head1 SYNOPSIS + +You got to fill this in! + +=head1 SEE ALSO + +L<Encode> + +=cut diff --git a/Master/tlpkg/installer/perllib/Encode/_T.e2x b/Master/tlpkg/installer/perllib/Encode/_T.e2x new file mode 100644 index 00000000000..6cf5f293d54 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/_T.e2x @@ -0,0 +1,7 @@ +use strict; +# Adjust the number here! +use Test::More tests => 2; + +use_ok('Encode'); +use_ok('Encode::$_Name_'); +# Add more test here! diff --git a/Master/tlpkg/installer/perllib/Encode/encode.h b/Master/tlpkg/installer/perllib/Encode/encode.h new file mode 100644 index 00000000000..94764a6a14c --- /dev/null +++ b/Master/tlpkg/installer/perllib/Encode/encode.h @@ -0,0 +1,111 @@ +#ifndef ENCODE_H +#define ENCODE_H + +#ifndef U8 +/* + A tad devious this: + perl normally has a #define for U8 - if that isn't present then we + typedef it - leaving it #ifndef so we can do data parts without + getting extern references to the code parts +*/ +typedef unsigned char U8; +#endif + +typedef struct encpage_s encpage_t; + +struct encpage_s +{ + /* fields ordered to pack nicely on 32-bit machines */ + const U8 *seq; /* Packed output sequences we generate + if we match */ + encpage_t *next; /* Page to go to if we match */ + U8 min; /* Min value of octet to match this entry */ + U8 max; /* Max value of octet to match this entry */ + U8 dlen; /* destination length - + size of entries in seq */ + U8 slen; /* source length - + number of source octets needed */ +}; + +/* + At any point in a translation there is a page pointer which points + at an array of the above structures. + + Basic operation : + get octet from source stream. + if (octet >= min && octet < max) { + if slen is 0 then we cannot represent this character. + if we have less than slen octets (including this one) then + we have a partial character. + otherwise + copy dlen octets from seq + dlen*(octet-min) to output + (dlen may be zero if we don't know yet.) + load page pointer with next to continue. + (is slen is one this is end of a character) + get next octet. + } + else { + increment the page pointer to look at next slot in the array + } + + arrays SHALL be constructed so there is an entry which matches + ..0xFF at the end, and either maps it or indicates no + representation. + + if MSB of slen is set then mapping is an approximate "FALLBACK" entry. + +*/ + + +typedef struct encode_s encode_t; +struct encode_s +{ + encpage_t *t_utf8; /* Starting table for translation from + the encoding to UTF-8 form */ + encpage_t *f_utf8; /* Starting table for translation + from UTF-8 to the encoding */ + const U8 *rep; /* Replacement character in this encoding + e.g. "?" */ + int replen; /* Number of octets in rep */ + U8 min_el; /* Minimum octets to represent a character */ + U8 max_el; /* Maximum octets to represent a character */ + const char *name[2]; /* name(s) of this encoding */ +}; + +#ifdef U8 +/* See comment at top of file for deviousness */ + +extern int do_encode(encpage_t *enc, const U8 *src, STRLEN *slen, + U8 *dst, STRLEN dlen, STRLEN *dout, int approx, + const U8 *term, STRLEN tlen); + +extern void Encode_DefineEncoding(encode_t *enc); + +#endif /* U8 */ + +#define ENCODE_NOSPACE 1 +#define ENCODE_PARTIAL 2 +#define ENCODE_NOREP 3 +#define ENCODE_FALLBACK 4 +#define ENCODE_FOUND_TERM 5 + +#define FBCHAR_UTF8 "\xEF\xBF\xBD" + +#define ENCODE_DIE_ON_ERR 0x0001 /* croaks immediately */ +#define ENCODE_WARN_ON_ERR 0x0002 /* warn on error; may proceed */ +#define ENCODE_RETURN_ON_ERR 0x0004 /* immediately returns on NOREP */ +#define ENCODE_LEAVE_SRC 0x0008 /* $src updated unless set */ +#define ENCODE_PERLQQ 0x0100 /* perlqq fallback string */ +#define ENCODE_HTMLCREF 0x0200 /* HTML character ref. fb mode */ +#define ENCODE_XMLCREF 0x0400 /* XML character ref. fb mode */ +#define ENCODE_STOP_AT_PARTIAL 0x0800 /* stop at partial explicitly */ + +#define ENCODE_FB_DEFAULT 0x0000 +#define ENCODE_FB_CROAK 0x0001 +#define ENCODE_FB_QUIET ENCODE_RETURN_ON_ERR +#define ENCODE_FB_WARN (ENCODE_RETURN_ON_ERR|ENCODE_WARN_ON_ERR) +#define ENCODE_FB_PERLQQ (ENCODE_PERLQQ|ENCODE_LEAVE_SRC) +#define ENCODE_FB_HTMLCREF (ENCODE_HTMLCREF|ENCODE_LEAVE_SRC) +#define ENCODE_FB_XMLCREF (ENCODE_XMLCREF|ENCODE_LEAVE_SRC) + +#endif /* ENCODE_H */ diff --git a/Master/tlpkg/installer/perllib/Errno.pm b/Master/tlpkg/installer/perllib/Errno.pm new file mode 100644 index 00000000000..23c07ea0482 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Errno.pm @@ -0,0 +1,227 @@ +# +# This file is auto-generated. ***ANY*** changes here will be lost +# + +package Errno; +our (@EXPORT_OK,%EXPORT_TAGS,@ISA,$VERSION,%errno,$AUTOLOAD); +use Exporter (); +use strict; + +$VERSION = "1.09_01"; +$VERSION = eval $VERSION; +@ISA = qw(Exporter); + +@EXPORT_OK = qw(EBADR ENOMSG ENOTSUP ESTRPIPE EADDRINUSE EL3HLT EBADF + ENOTBLK ENAVAIL ECHRNG ENOTNAM ELNRNG ENOKEY EXDEV EBADE EBADSLT + ECONNREFUSED ENOSTR ENONET EOVERFLOW EISCONN EFBIG EKEYREVOKED + ECONNRESET EWOULDBLOCK ELIBMAX EREMOTEIO ENOPKG ELIBSCN EDESTADDRREQ + ENOTSOCK EIO EMEDIUMTYPE EINPROGRESS ERANGE EAFNOSUPPORT EADDRNOTAVAIL + EINTR EREMOTE EILSEQ ENOMEM EPIPE ENETUNREACH ENODATA EUSERS + EOPNOTSUPP EPROTO EISNAM ESPIPE EALREADY ENAMETOOLONG ENOEXEC EISDIR + EBADRQC EEXIST EDOTDOT ELIBBAD EOWNERDEAD ESRCH EFAULT EXFULL + EDEADLOCK EAGAIN ENOPROTOOPT ENETDOWN EPROTOTYPE EL2NSYNC ENETRESET + EUCLEAN EADV EROFS ESHUTDOWN EMULTIHOP EPROTONOSUPPORT ENFILE ENOLCK + ECONNABORTED ECANCELED EDEADLK ESRMNT ENOLINK ETIME ENOTDIR EINVAL + ENOTTY ENOANO ELOOP ENOENT EPFNOSUPPORT EBADMSG ENOMEDIUM EL2HLT EDOM + EBFONT EKEYEXPIRED EMSGSIZE ENOCSI EL3RST ENOSPC EIDRM ENOBUFS ENOSYS + EHOSTDOWN EBADFD ENOSR ENOTCONN ESTALE EDQUOT EKEYREJECTED EMFILE + ENOTRECOVERABLE EACCES EBUSY E2BIG EPERM ELIBEXEC ETOOMANYREFS ELIBACC + ENOTUNIQ ECOMM ERESTART ESOCKTNOSUPPORT EUNATCH ETIMEDOUT ENXIO ENODEV + ETXTBSY EMLINK ECHILD EHOSTUNREACH EREMCHG ENOTEMPTY); + +%EXPORT_TAGS = ( + POSIX => [qw( + E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY + EBADF EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK + EDESTADDRREQ EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH + EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS + ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK + ENOTCONN ENOTDIR ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART + EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT + ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV + )] +); + +sub EPERM () { 1 } +sub ENOENT () { 2 } +sub ESRCH () { 3 } +sub EINTR () { 4 } +sub EIO () { 5 } +sub ENXIO () { 6 } +sub E2BIG () { 7 } +sub ENOEXEC () { 8 } +sub EBADF () { 9 } +sub ECHILD () { 10 } +sub EWOULDBLOCK () { 11 } +sub EAGAIN () { 11 } +sub ENOMEM () { 12 } +sub EACCES () { 13 } +sub EFAULT () { 14 } +sub ENOTBLK () { 15 } +sub EBUSY () { 16 } +sub EEXIST () { 17 } +sub EXDEV () { 18 } +sub ENODEV () { 19 } +sub ENOTDIR () { 20 } +sub EISDIR () { 21 } +sub EINVAL () { 22 } +sub ENFILE () { 23 } +sub EMFILE () { 24 } +sub ENOTTY () { 25 } +sub ETXTBSY () { 26 } +sub EFBIG () { 27 } +sub ENOSPC () { 28 } +sub ESPIPE () { 29 } +sub EROFS () { 30 } +sub EMLINK () { 31 } +sub EPIPE () { 32 } +sub EDOM () { 33 } +sub ERANGE () { 34 } +sub EDEADLOCK () { 35 } +sub EDEADLK () { 35 } +sub ENAMETOOLONG () { 36 } +sub ENOLCK () { 37 } +sub ENOSYS () { 38 } +sub ENOTEMPTY () { 39 } +sub ELOOP () { 40 } +sub ENOMSG () { 42 } +sub EIDRM () { 43 } +sub ECHRNG () { 44 } +sub EL2NSYNC () { 45 } +sub EL3HLT () { 46 } +sub EL3RST () { 47 } +sub ELNRNG () { 48 } +sub EUNATCH () { 49 } +sub ENOCSI () { 50 } +sub EL2HLT () { 51 } +sub EBADE () { 52 } +sub EBADR () { 53 } +sub EXFULL () { 54 } +sub ENOANO () { 55 } +sub EBADRQC () { 56 } +sub EBADSLT () { 57 } +sub EBFONT () { 59 } +sub ENOSTR () { 60 } +sub ENODATA () { 61 } +sub ETIME () { 62 } +sub ENOSR () { 63 } +sub ENONET () { 64 } +sub ENOPKG () { 65 } +sub EREMOTE () { 66 } +sub ENOLINK () { 67 } +sub EADV () { 68 } +sub ESRMNT () { 69 } +sub ECOMM () { 70 } +sub EPROTO () { 71 } +sub EMULTIHOP () { 72 } +sub EDOTDOT () { 73 } +sub EBADMSG () { 74 } +sub EOVERFLOW () { 75 } +sub ENOTUNIQ () { 76 } +sub EBADFD () { 77 } +sub EREMCHG () { 78 } +sub ELIBACC () { 79 } +sub ELIBBAD () { 80 } +sub ELIBSCN () { 81 } +sub ELIBMAX () { 82 } +sub ELIBEXEC () { 83 } +sub EILSEQ () { 84 } +sub ERESTART () { 85 } +sub ESTRPIPE () { 86 } +sub EUSERS () { 87 } +sub ENOTSOCK () { 88 } +sub EDESTADDRREQ () { 89 } +sub EMSGSIZE () { 90 } +sub EPROTOTYPE () { 91 } +sub ENOPROTOOPT () { 92 } +sub EPROTONOSUPPORT () { 93 } +sub ESOCKTNOSUPPORT () { 94 } +sub ENOTSUP () { 95 } +sub EOPNOTSUPP () { 95 } +sub EPFNOSUPPORT () { 96 } +sub EAFNOSUPPORT () { 97 } +sub EADDRINUSE () { 98 } +sub EADDRNOTAVAIL () { 99 } +sub ENETDOWN () { 100 } +sub ENETUNREACH () { 101 } +sub ENETRESET () { 102 } +sub ECONNABORTED () { 103 } +sub ECONNRESET () { 104 } +sub ENOBUFS () { 105 } +sub EISCONN () { 106 } +sub ENOTCONN () { 107 } +sub ESHUTDOWN () { 108 } +sub ETOOMANYREFS () { 109 } +sub ETIMEDOUT () { 110 } +sub ECONNREFUSED () { 111 } +sub EHOSTDOWN () { 112 } +sub EHOSTUNREACH () { 113 } +sub EALREADY () { 114 } +sub EINPROGRESS () { 115 } +sub ESTALE () { 116 } +sub EUCLEAN () { 117 } +sub ENOTNAM () { 118 } +sub ENAVAIL () { 119 } +sub EISNAM () { 120 } +sub EREMOTEIO () { 121 } +sub EDQUOT () { 122 } +sub ENOMEDIUM () { 123 } +sub EMEDIUMTYPE () { 124 } +sub ECANCELED () { 125 } +sub ENOKEY () { 126 } +sub EKEYEXPIRED () { 127 } +sub EKEYREVOKED () { 128 } +sub EKEYREJECTED () { 129 } +sub EOWNERDEAD () { 130 } +sub ENOTRECOVERABLE () { 131 } + +sub TIEHASH { bless [] } + +sub FETCH { + my ($self, $errname) = @_; + my $proto = prototype("Errno::$errname"); + my $errno = ""; + if (defined($proto) && $proto eq "") { + no strict 'refs'; + $errno = &$errname; + $errno = 0 unless $! == $errno; + } + return $errno; +} + +sub STORE { + require Carp; + Carp::confess("ERRNO hash is read only!"); +} + +*CLEAR = \&STORE; +*DELETE = \&STORE; + +sub NEXTKEY { + my($k,$v); + while(($k,$v) = each %Errno::) { + my $proto = prototype("Errno::$k"); + last if (defined($proto) && $proto eq ""); + } + $k +} + +sub FIRSTKEY { + my $s = scalar keys %Errno::; # initialize iterator + goto &NEXTKEY; +} + +sub EXISTS { + my ($self, $errname) = @_; + my $r = ref $errname; + my $proto = !$r || $r eq 'CODE' ? prototype($errname) : undef; + defined($proto) && $proto eq ""; +} + +tie %!, __PACKAGE__; + +1; +__END__ + diff --git a/Master/tlpkg/installer/perllib/Fcntl.pm b/Master/tlpkg/installer/perllib/Fcntl.pm new file mode 100644 index 00000000000..7ef0038bd18 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Fcntl.pm @@ -0,0 +1,236 @@ +package Fcntl; + +=head1 NAME + +Fcntl - load the C Fcntl.h defines + +=head1 SYNOPSIS + + use Fcntl; + use Fcntl qw(:DEFAULT :flock); + +=head1 DESCRIPTION + +This module is just a translation of the C F<fcntl.h> file. +Unlike the old mechanism of requiring a translated F<fcntl.ph> +file, this uses the B<h2xs> program (see the Perl source distribution) +and your native C compiler. This means that it has a +far more likely chance of getting the numbers right. + +=head1 NOTE + +Only C<#define> symbols get translated; you must still correctly +pack up your own arguments to pass as args for locking functions, etc. + +=head1 EXPORTED SYMBOLS + +By default your system's F_* and O_* constants (eg, F_DUPFD and +O_CREAT) and the FD_CLOEXEC constant are exported into your namespace. + +You can request that the flock() constants (LOCK_SH, LOCK_EX, LOCK_NB +and LOCK_UN) be provided by using the tag C<:flock>. See L<Exporter>. + +You can request that the old constants (FAPPEND, FASYNC, FCREAT, +FDEFER, FEXCL, FNDELAY, FNONBLOCK, FSYNC, FTRUNC) be provided for +compatibility reasons by using the tag C<:Fcompat>. For new +applications the newer versions of these constants are suggested +(O_APPEND, O_ASYNC, O_CREAT, O_DEFER, O_EXCL, O_NDELAY, O_NONBLOCK, +O_SYNC, O_TRUNC). + +For ease of use also the SEEK_* constants (for seek() and sysseek(), +e.g. SEEK_END) and the S_I* constants (for chmod() and stat()) are +available for import. They can be imported either separately or using +the tags C<:seek> and C<:mode>. + +Please refer to your native fcntl(2), open(2), fseek(3), lseek(2) +(equal to Perl's seek() and sysseek(), respectively), and chmod(2) +documentation to see what constants are implemented in your system. + +See L<perlopentut> to learn about the uses of the O_* constants +with sysopen(). + +See L<perlfunc/seek> and L<perlfunc/sysseek> about the SEEK_* constants. + +See L<perlfunc/stat> about the S_I* constants. + +=cut + +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $AUTOLOAD); + +require Exporter; +use XSLoader (); +@ISA = qw(Exporter); +$VERSION = "1.05"; +# Items to export into callers namespace by default +# (move infrequently used names to @EXPORT_OK below) +@EXPORT = + qw( + FD_CLOEXEC + F_ALLOCSP + F_ALLOCSP64 + F_COMPAT + F_DUP2FD + F_DUPFD + F_EXLCK + F_FREESP + F_FREESP64 + F_FSYNC + F_FSYNC64 + F_GETFD + F_GETFL + F_GETLK + F_GETLK64 + F_GETOWN + F_NODNY + F_POSIX + F_RDACC + F_RDDNY + F_RDLCK + F_RWACC + F_RWDNY + F_SETFD + F_SETFL + F_SETLK + F_SETLK64 + F_SETLKW + F_SETLKW64 + F_SETOWN + F_SHARE + F_SHLCK + F_UNLCK + F_UNSHARE + F_WRACC + F_WRDNY + F_WRLCK + O_ACCMODE + O_ALIAS + O_APPEND + O_ASYNC + O_BINARY + O_CREAT + O_DEFER + O_DIRECT + O_DIRECTORY + O_DSYNC + O_EXCL + O_EXLOCK + O_LARGEFILE + O_NDELAY + O_NOCTTY + O_NOFOLLOW + O_NOINHERIT + O_NONBLOCK + O_RANDOM + O_RAW + O_RDONLY + O_RDWR + O_RSRC + O_RSYNC + O_SEQUENTIAL + O_SHLOCK + O_SYNC + O_TEMPORARY + O_TEXT + O_TRUNC + O_WRONLY + ); + +# Other items we are prepared to export if requested +@EXPORT_OK = qw( + DN_ACCESS + DN_ATTRIB + DN_CREATE + DN_DELETE + DN_MODIFY + DN_MULTISHOT + DN_RENAME + FAPPEND + FASYNC + FCREAT + FDEFER + FDSYNC + FEXCL + FLARGEFILE + FNDELAY + FNONBLOCK + FRSYNC + FSYNC + FTRUNC + F_GETLEASE + F_GETSIG + F_NOTIFY + F_SETLEASE + F_SETSIG + LOCK_EX + LOCK_MAND + LOCK_NB + LOCK_READ + LOCK_RW + LOCK_SH + LOCK_UN + LOCK_WRITE + O_IGNORE_CTTY + O_NOATIME + O_NOLINK + O_NOTRANS + SEEK_CUR + SEEK_END + SEEK_SET + S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT + S_IREAD S_IWRITE S_IEXEC + S_IRGRP S_IWGRP S_IXGRP S_IRWXG + S_IROTH S_IWOTH S_IXOTH S_IRWXO + S_IRUSR S_IWUSR S_IXUSR S_IRWXU + S_ISUID S_ISGID S_ISVTX S_ISTXT + _S_IFMT S_IFREG S_IFDIR S_IFLNK + &S_ISREG &S_ISDIR &S_ISLNK &S_ISSOCK &S_ISBLK &S_ISCHR &S_ISFIFO + &S_ISWHT &S_ISENFMT &S_IFMT &S_IMODE +); +# Named groups of exports +%EXPORT_TAGS = ( + 'flock' => [qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN)], + 'Fcompat' => [qw(FAPPEND FASYNC FCREAT FDEFER FDSYNC FEXCL FLARGEFILE + FNDELAY FNONBLOCK FRSYNC FSYNC FTRUNC)], + 'seek' => [qw(SEEK_SET SEEK_CUR SEEK_END)], + 'mode' => [qw(S_ISUID S_ISGID S_ISVTX S_ISTXT + _S_IFMT S_IFREG S_IFDIR S_IFLNK + S_IFSOCK S_IFBLK S_IFCHR S_IFIFO S_IFWHT S_ENFMT + S_IRUSR S_IWUSR S_IXUSR S_IRWXU + S_IRGRP S_IWGRP S_IXGRP S_IRWXG + S_IROTH S_IWOTH S_IXOTH S_IRWXO + S_IREAD S_IWRITE S_IEXEC + S_ISREG S_ISDIR S_ISLNK S_ISSOCK + S_ISBLK S_ISCHR S_ISFIFO + S_ISWHT S_ISENFMT + S_IFMT S_IMODE + )], +); + +sub S_IFMT { @_ ? ( $_[0] & _S_IFMT() ) : _S_IFMT() } +sub S_IMODE { $_[0] & 07777 } + +sub S_ISREG { ( $_[0] & _S_IFMT() ) == S_IFREG() } +sub S_ISDIR { ( $_[0] & _S_IFMT() ) == S_IFDIR() } +sub S_ISLNK { ( $_[0] & _S_IFMT() ) == S_IFLNK() } +sub S_ISSOCK { ( $_[0] & _S_IFMT() ) == S_IFSOCK() } +sub S_ISBLK { ( $_[0] & _S_IFMT() ) == S_IFBLK() } +sub S_ISCHR { ( $_[0] & _S_IFMT() ) == S_IFCHR() } +sub S_ISFIFO { ( $_[0] & _S_IFMT() ) == S_IFIFO() } +sub S_ISWHT { ( $_[0] & _S_IFMT() ) == S_IFWHT() } +sub S_ISENFMT { ( $_[0] & _S_IFMT() ) == S_IFENFMT() } + +sub AUTOLOAD { + (my $constname = $AUTOLOAD) =~ s/.*:://; + die "&Fcntl::constant not defined" if $constname eq 'constant'; + my ($error, $val) = constant($constname); + if ($error) { + my (undef,$file,$line) = caller; + die "$error at $file line $line.\n"; + } + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + +XSLoader::load 'Fcntl', $VERSION; + +1; diff --git a/Master/tlpkg/installer/perllib/File/Basename.pm b/Master/tlpkg/installer/perllib/File/Basename.pm new file mode 100644 index 00000000000..837b753972a --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Basename.pm @@ -0,0 +1,398 @@ +=head1 NAME + +File::Basename - Parse file paths into directory, filename and suffix. + +=head1 SYNOPSIS + + use File::Basename; + + ($name,$path,$suffix) = fileparse($fullname,@suffixlist); + $name = fileparse($fullname,@suffixlist); + + $basename = basename($fullname,@suffixlist); + $dirname = dirname($fullname); + + +=head1 DESCRIPTION + +These routines allow you to parse file paths into their directory, filename +and suffix. + +B<NOTE>: C<dirname()> and C<basename()> emulate the behaviours, and +quirks, of the shell and C functions of the same name. See each +function's documentation for details. If your concern is just parsing +paths it is safer to use L<File::Spec>'s C<splitpath()> and +C<splitdir()> methods. + +It is guaranteed that + + # Where $path_separator is / for Unix, \ for Windows, etc... + dirname($path) . $path_separator . basename($path); + +is equivalent to the original path for all systems but VMS. + + +=cut + + +package File::Basename; + +# A bit of juggling to insure that C<use re 'taint';> always works, since +# File::Basename is used during the Perl build, when the re extension may +# not be available. +BEGIN { + unless (eval { require re; }) + { eval ' sub re::import { $^H |= 0x00100000; } ' } # HINT_RE_TAINT + import re 'taint'; +} + + +use strict; +use 5.006; +use warnings; +our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(fileparse fileparse_set_fstype basename dirname); +$VERSION = "2.74"; + +fileparse_set_fstype($^O); + + +=over 4 + +=item C<fileparse> + + my($filename, $directories, $suffix) = fileparse($path); + my($filename, $directories, $suffix) = fileparse($path, @suffixes); + my $filename = fileparse($path, @suffixes); + +The C<fileparse()> routine divides a file path into its $directories, $filename +and (optionally) the filename $suffix. + +$directories contains everything up to and including the last +directory separator in the $path including the volume (if applicable). +The remainder of the $path is the $filename. + + # On Unix returns ("baz", "/foo/bar/", "") + fileparse("/foo/bar/baz"); + + # On Windows returns ("baz", "C:\foo\bar\", "") + fileparse("C:\foo\bar\baz"); + + # On Unix returns ("", "/foo/bar/baz/", "") + fileparse("/foo/bar/baz/"); + +If @suffixes are given each element is a pattern (either a string or a +C<qr//>) matched against the end of the $filename. The matching +portion is removed and becomes the $suffix. + + # On Unix returns ("baz", "/foo/bar", ".txt") + fileparse("/foo/bar/baz", qr/\.[^.]*/); + +If type is non-Unix (see C<fileparse_set_fstype()>) then the pattern +matching for suffix removal is performed case-insensitively, since +those systems are not case-sensitive when opening existing files. + +You are guaranteed that C<$directories . $filename . $suffix> will +denote the same location as the original $path. + +=cut + + +sub fileparse { + my($fullname,@suffices) = @_; + + unless (defined $fullname) { + require Carp; + Carp::croak("fileparse(): need a valid pathname"); + } + + my $orig_type = ''; + my($type,$igncase) = ($Fileparse_fstype, $Fileparse_igncase); + + my($taint) = substr($fullname,0,0); # Is $fullname tainted? + + if ($type eq "VMS" and $fullname =~ m{/} ) { + # We're doing Unix emulation + $orig_type = $type; + $type = 'Unix'; + } + + my($dirpath, $basename); + + if (grep { $type eq $_ } qw(MSDOS DOS MSWin32 Epoc)) { + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); + $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; + } + elsif ($type eq "OS2") { + ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s); + $dirpath = './' unless $dirpath; # Can't be 0 + $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#; + } + elsif ($type eq "MacOS") { + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s); + $dirpath = ':' unless $dirpath; + } + elsif ($type eq "AmigaOS") { + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s); + $dirpath = './' unless $dirpath; + } + elsif ($type eq 'VMS' ) { + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s); + $dirpath ||= ''; # should always be defined + } + else { # Default to Unix semantics. + ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s); + if ($orig_type eq 'VMS' and $fullname =~ m:^(/[^/]+/000000(/|$))(.*):) { + # dev:[000000] is top of VMS tree, similar to Unix '/' + # so strip it off and treat the rest as "normal" + my $devspec = $1; + my $remainder = $3; + ($dirpath,$basename) = ($remainder =~ m#^(.*/)?(.*)#s); + $dirpath ||= ''; # should always be defined + $dirpath = $devspec.$dirpath; + } + $dirpath = './' unless $dirpath; + } + + + my $tail = ''; + my $suffix = ''; + if (@suffices) { + foreach $suffix (@suffices) { + my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; + if ($basename =~ s/$pat//s) { + $taint .= substr($suffix,0,0); + $tail = $1 . $tail; + } + } + } + + # Ensure taint is propgated from the path to its pieces. + $tail .= $taint; + wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) + : ($basename .= $taint); +} + + + +=item C<basename> + + my $filename = basename($path); + my $filename = basename($path, @suffixes); + +This function is provided for compatibility with the Unix shell command +C<basename(1)>. It does B<NOT> always return the file name portion of a +path as you might expect. To be safe, if you want the file name portion of +a path use C<fileparse()>. + +C<basename()> returns the last level of a filepath even if the last +level is clearly directory. In effect, it is acting like C<pop()> for +paths. This differs from C<fileparse()>'s behaviour. + + # Both return "bar" + basename("/foo/bar"); + basename("/foo/bar/"); + +@suffixes work as in C<fileparse()> except all regex metacharacters are +quoted. + + # These two function calls are equivalent. + my $filename = basename("/foo/bar/baz.txt", ".txt"); + my $filename = fileparse("/foo/bar/baz.txt", qr/\Q.txt\E/); + +Also note that in order to be compatible with the shell command, +C<basename()> does not strip off a suffix if it is identical to the +remaining characters in the filename. + +=cut + + +sub basename { + my($path) = shift; + + # From BSD basename(1) + # The basename utility deletes any prefix ending with the last slash `/' + # character present in string (after first stripping trailing slashes) + _strip_trailing_sep($path); + + my($basename, $dirname, $suffix) = fileparse( $path, map("\Q$_\E",@_) ); + + # From BSD basename(1) + # The suffix is not stripped if it is identical to the remaining + # characters in string. + if( length $suffix and !length $basename ) { + $basename = $suffix; + } + + # Ensure that basename '/' == '/' + if( !length $basename ) { + $basename = $dirname; + } + + return $basename; +} + + + +=item C<dirname> + +This function is provided for compatibility with the Unix shell +command C<dirname(1)> and has inherited some of its quirks. In spite of +its name it does B<NOT> always return the directory name as you might +expect. To be safe, if you want the directory name of a path use +C<fileparse()>. + +Only on VMS (where there is no ambiguity between the file and directory +portions of a path) and AmigaOS (possibly due to an implementation quirk in +this module) does C<dirname()> work like C<fileparse($path)>, returning just the +$directories. + + # On VMS and AmigaOS + my $directories = dirname($path); + +When using Unix or MSDOS syntax this emulates the C<dirname(1)> shell function +which is subtly different from how C<fileparse()> works. It returns all but +the last level of a file path even if the last level is clearly a directory. +In effect, it is not returning the directory portion but simply the path one +level up acting like C<chop()> for file paths. + +Also unlike C<fileparse()>, C<dirname()> does not include a trailing slash on +its returned path. + + # returns /foo/bar. fileparse() would return /foo/bar/ + dirname("/foo/bar/baz"); + + # also returns /foo/bar despite the fact that baz is clearly a + # directory. fileparse() would return /foo/bar/baz/ + dirname("/foo/bar/baz/"); + + # returns '.'. fileparse() would return 'foo/' + dirname("foo/"); + +Under VMS, if there is no directory information in the $path, then the +current default device and directory is used. + +=cut + + +sub dirname { + my $path = shift; + + my($type) = $Fileparse_fstype; + + if( $type eq 'VMS' and $path =~ m{/} ) { + # Parse as Unix + local($File::Basename::Fileparse_fstype) = ''; + return dirname($path); + } + + my($basename, $dirname) = fileparse($path); + + if ($type eq 'VMS') { + $dirname ||= $ENV{DEFAULT}; + } + elsif ($type eq 'MacOS') { + if( !length($basename) && $dirname !~ /^[^:]+:\z/) { + _strip_trailing_sep($dirname); + ($basename,$dirname) = fileparse $dirname; + } + $dirname .= ":" unless $dirname =~ /:\z/; + } + elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { + _strip_trailing_sep($dirname); + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + _strip_trailing_sep($dirname); + } + } + elsif ($type eq 'AmigaOS') { + if ( $dirname =~ /:\z/) { return $dirname } + chop $dirname; + $dirname =~ s#[^:/]+\z## unless length($basename); + } + else { + _strip_trailing_sep($dirname); + unless( length($basename) ) { + ($basename,$dirname) = fileparse $dirname; + _strip_trailing_sep($dirname); + } + } + + $dirname; +} + + +# Strip the trailing path separator. +sub _strip_trailing_sep { + my $type = $Fileparse_fstype; + + if ($type eq 'MacOS') { + $_[0] =~ s/([^:]):\z/$1/s; + } + elsif (grep { $type eq $_ } qw(MSDOS DOS MSWin32 OS2)) { + $_[0] =~ s/([^:])[\\\/]*\z/$1/; + } + else { + $_[0] =~ s{(.)/*\z}{$1}s; + } +} + + +=item C<fileparse_set_fstype> + + my $type = fileparse_set_fstype(); + my $previous_type = fileparse_set_fstype($type); + +Normally File::Basename will assume a file path type native to your current +operating system (ie. /foo/bar style on Unix, \foo\bar on Windows, etc...). +With this function you can override that assumption. + +Valid $types are "MacOS", "VMS", "AmigaOS", "OS2", "RISCOS", +"MSWin32", "DOS" (also "MSDOS" for backwards bug compatibility), +"Epoc" and "Unix" (all case-insensitive). If an unrecognized $type is +given "Unix" will be assumed. + +If you've selected VMS syntax, and the file specification you pass to +one of these routines contains a "/", they assume you are using Unix +emulation and apply the Unix syntax rules instead, for that function +call only. + +=back + +=cut + + +BEGIN { + +my @Ignore_Case = qw(MacOS VMS AmigaOS OS2 RISCOS MSWin32 MSDOS DOS Epoc); +my @Types = (@Ignore_Case, qw(Unix)); + +sub fileparse_set_fstype { + my $old = $Fileparse_fstype; + + if (@_) { + my $new_type = shift; + + $Fileparse_fstype = 'Unix'; # default + foreach my $type (@Types) { + $Fileparse_fstype = $type if $new_type =~ /^$type/i; + } + + $Fileparse_igncase = + (grep $Fileparse_fstype eq $_, @Ignore_Case) ? 1 : 0; + } + + return $old; +} + +} + + +1; + + +=head1 SEE ALSO + +L<dirname(1)>, L<basename(1)>, L<File::Spec> diff --git a/Master/tlpkg/installer/perllib/File/CheckTree.pm b/Master/tlpkg/installer/perllib/File/CheckTree.pm new file mode 100644 index 00000000000..20ffd68124d --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/CheckTree.pm @@ -0,0 +1,229 @@ +package File::CheckTree; + +use 5.006; +use Cwd; +use Exporter; +use File::Spec; +use warnings; +use strict; + +our $VERSION = '4.3'; +our @ISA = qw(Exporter); +our @EXPORT = qw(validate); + +=head1 NAME + +validate - run many filetest checks on a tree + +=head1 SYNOPSIS + + use File::CheckTree; + + $num_warnings = validate( q{ + /vmunix -e || die + /boot -e || die + /bin cd + csh -ex + csh !-ug + sh -ex + sh !-ug + /usr -d || warn "What happened to $file?\n" + }); + +=head1 DESCRIPTION + +The validate() routine takes a single multiline string consisting of +directives, each containing a filename plus a file test to try on it. +(The file test may also be a "cd", causing subsequent relative filenames +to be interpreted relative to that directory.) After the file test +you may put C<|| die> to make it a fatal error if the file test fails. +The default is C<|| warn>. The file test may optionally have a "!' prepended +to test for the opposite condition. If you do a cd and then list some +relative filenames, you may want to indent them slightly for readability. +If you supply your own die() or warn() message, you can use $file to +interpolate the filename. + +Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>. +Only the first failed test of the bunch will produce a warning. + +The routine returns the number of warnings issued. + +=head1 AUTHOR + +File::CheckTree was derived from lib/validate.pl which was +written by Larry Wall. +Revised by Paul Grassie <F<grassie@perl.com>> in 2002. + +=head1 HISTORY + +File::CheckTree used to not display fatal error messages. +It used to count only those warnings produced by a generic C<|| warn> +(and not those in which the user supplied the message). In addition, +the validate() routine would leave the user program in whatever +directory was last entered through the use of "cd" directives. +These bugs were fixed during the development of perl 5.8. +The first fixed version of File::CheckTree was 4.2. + +=cut + +my $Warnings; + +sub validate { + my ($starting_dir, $file, $test, $cwd, $oldwarnings); + + $starting_dir = cwd; + + $cwd = ""; + $Warnings = 0; + + foreach my $check (split /\n/, $_[0]) { + my ($testlist, @testlist); + + # skip blanks/comments + next if $check =~ /^\s*#/ || $check =~ /^\s*$/; + + # Todo: + # should probably check for invalid directives and die + # but earlier versions of File::CheckTree did not do this either + + # split a line like "/foo -r || die" + # so that $file is "/foo", $test is "-rwx || die" + ($file, $test) = split(' ', $check, 2); # special whitespace split + + # change a $test like "!-ug || die" to "!-Z || die", + # capturing the bundled tests (e.g. "ug") in $2 + if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) { + $testlist = $2; + # split bundled tests, e.g. "ug" to 'u', 'g' + @testlist = split(//, $testlist); + } + else { + # put in placeholder Z for stand-alone test + @testlist = ('Z'); + } + + # will compare these two later to stop on 1st warning w/in a bundle + $oldwarnings = $Warnings; + + foreach my $one (@testlist) { + # examples of $test: "!-Z || die" or "-w || warn" + my $this = $test; + + # expand relative $file to full pathname if preceded by cd directive + $file = File::Spec->catfile($cwd, $file) + if $cwd && !File::Spec->file_name_is_absolute($file); + + # put filename in after the test operator + $this =~ s/(-\w\b)/$1 "\$file"/g; + + # change the "-Z" representing a bundle with the $one test + $this =~ s/-Z/-$one/; + + # if it's a "cd" directive... + if ($this =~ /^cd\b/) { + # add "|| die ..." + $this .= ' || die "cannot cd to $file\n"'; + # expand "cd" directive with directory name + $this =~ s/\bcd\b/chdir(\$cwd = '$file')/; + } + else { + # add "|| warn" as a default disposition + $this .= ' || warn' unless $this =~ /\|\|/; + + # change a generic ".. || die" or ".. || warn" + # to call valmess instead of die/warn directly + # valmess will look up the error message from %Val_Message + $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $ + /$1 || valmess('$3', '$2', \$file)/x; + } + + { + # count warnings, either from valmess or '-r || warn "my msg"' + # also, call any pre-existing signal handler for __WARN__ + my $orig_sigwarn = $SIG{__WARN__}; + local $SIG{__WARN__} = sub { + ++$Warnings; + if ( $orig_sigwarn ) { + $orig_sigwarn->(@_); + } + else { + warn "@_"; + } + }; + + # do the test + eval $this; + + # re-raise an exception caused by a "... || die" test + if ($@) { + # in case of any cd directives, return from whence we came + if ($starting_dir ne cwd) { + chdir($starting_dir) || die "$starting_dir: $!"; + } + die $@ if $@; + } + } + + # stop on 1st warning within a bundle of tests + last if $Warnings > $oldwarnings; + } + } + + # in case of any cd directives, return from whence we came + if ($starting_dir ne cwd) { + chdir($starting_dir) || die "chdir $starting_dir: $!"; + } + + return $Warnings; +} + +my %Val_Message = ( + 'r' => "is not readable by uid $>.", + 'w' => "is not writable by uid $>.", + 'x' => "is not executable by uid $>.", + 'o' => "is not owned by uid $>.", + 'R' => "is not readable by you.", + 'W' => "is not writable by you.", + 'X' => "is not executable by you.", + 'O' => "is not owned by you.", + 'e' => "does not exist.", + 'z' => "does not have zero size.", + 's' => "does not have non-zero size.", + 'f' => "is not a plain file.", + 'd' => "is not a directory.", + 'l' => "is not a symbolic link.", + 'p' => "is not a named pipe (FIFO).", + 'S' => "is not a socket.", + 'b' => "is not a block special file.", + 'c' => "is not a character special file.", + 'u' => "does not have the setuid bit set.", + 'g' => "does not have the setgid bit set.", + 'k' => "does not have the sticky bit set.", + 'T' => "is not a text file.", + 'B' => "is not a binary file." +); + +sub valmess { + my ($disposition, $test, $file) = @_; + my $ferror; + + if ($test =~ / ^ (!?) -(\w) \s* $ /x) { + my ($neg, $ftype) = ($1, $2); + + $ferror = "$file $Val_Message{$ftype}"; + + if ($neg eq '!') { + $ferror =~ s/ is not / should not be / || + $ferror =~ s/ does not / should not / || + $ferror =~ s/ not / /; + } + } + else { + $ferror = "Can't do $test $file.\n"; + } + + die "$ferror\n" if $disposition eq 'die'; + warn "$ferror\n"; +} + +1; diff --git a/Master/tlpkg/installer/perllib/File/Compare.pm b/Master/tlpkg/installer/perllib/File/Compare.pm new file mode 100644 index 00000000000..0b73d7c7657 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Compare.pm @@ -0,0 +1,178 @@ +package File::Compare; + +use 5.006; +use strict; +use warnings; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big); + +require Exporter; +use Carp; + +$VERSION = '1.1003'; +@ISA = qw(Exporter); +@EXPORT = qw(compare); +@EXPORT_OK = qw(cmp compare_text); + +$Too_Big = 1024 * 1024 * 2; + +sub compare { + croak("Usage: compare( file1, file2 [, buffersize]) ") + unless(@_ == 2 || @_ == 3); + + my ($from,$to,$size) = @_; + my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0); + + my ($fromsize,$closefrom,$closeto); + local (*FROM, *TO); + + croak("from undefined") unless (defined $from); + croak("to undefined") unless (defined $to); + + if (ref($from) && + (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) { + *FROM = *$from; + } elsif (ref(\$from) eq 'GLOB') { + *FROM = $from; + } else { + open(FROM,"<$from") or goto fail_open1; + unless ($text_mode) { + binmode FROM; + $fromsize = -s FROM; + } + $closefrom = 1; + } + + if (ref($to) && + (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) { + *TO = *$to; + } elsif (ref(\$to) eq 'GLOB') { + *TO = $to; + } else { + open(TO,"<$to") or goto fail_open2; + binmode TO unless $text_mode; + $closeto = 1; + } + + if (!$text_mode && $closefrom && $closeto) { + # If both are opened files we know they differ if their size differ + goto fail_inner if $fromsize != -s TO; + } + + if ($text_mode) { + local $/ = "\n"; + my ($fline,$tline); + while (defined($fline = <FROM>)) { + goto fail_inner unless defined($tline = <TO>); + if (ref $size) { + # $size contains ref to comparison function + goto fail_inner if &$size($fline, $tline); + } else { + goto fail_inner if $fline ne $tline; + } + } + goto fail_inner if defined($tline = <TO>); + } + else { + unless (defined($size) && $size > 0) { + $size = $fromsize || -s TO || 0; + $size = 1024 if $size < 512; + $size = $Too_Big if $size > $Too_Big; + } + + my ($fr,$tr,$fbuf,$tbuf); + $fbuf = $tbuf = ''; + while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { + unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) { + goto fail_inner; + } + } + goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0; + } + + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 0; + + # All of these contortions try to preserve error messages... + fail_inner: + close(TO) || goto fail_open2 if $closeto; + close(FROM) || goto fail_open1 if $closefrom; + + return 1; + + fail_open2: + if ($closefrom) { + my $status = $!; + $! = 0; + close FROM; + $! = $status unless $!; + } + fail_open1: + return -1; +} + +sub cmp; +*cmp = \&compare; + +sub compare_text { + my ($from,$to,$cmp) = @_; + croak("Usage: compare_text( file1, file2 [, cmp-function])") + unless @_ == 2 || @_ == 3; + croak("Third arg to compare_text() function must be a code reference") + if @_ == 3 && ref($cmp) ne 'CODE'; + + # Using a negative buffer size puts compare into text_mode too + $cmp = -1 unless defined $cmp; + compare($from, $to, $cmp); +} + +1; + +__END__ + +=head1 NAME + +File::Compare - Compare files or filehandles + +=head1 SYNOPSIS + + use File::Compare; + + if (compare("file1","file2") == 0) { + print "They're equal\n"; + } + +=head1 DESCRIPTION + +The File::Compare::compare function compares the contents of two +sources, each of which can be a file or a file handle. It is exported +from File::Compare by default. + +File::Compare::cmp is a synonym for File::Compare::compare. It is +exported from File::Compare only by request. + +File::Compare::compare_text does a line by line comparison of the two +files. It stops as soon as a difference is detected. compare_text() +accepts an optional third argument: This must be a CODE reference to +a line comparison function, which returns 0 when both lines are considered +equal. For example: + + compare_text($file1, $file2) + +is basically equivalent to + + compare_text($file1, $file2, sub {$_[0] ne $_[1]} ) + +=head1 RETURN + +File::Compare::compare and its sibling functions return 0 if the files +are equal, 1 if the files are unequal, or -1 if an error was encountered. + +=head1 AUTHOR + +File::Compare was written by Nick Ing-Simmons. +Its original documentation was written by Chip Salzenberg. + +=cut + diff --git a/Master/tlpkg/installer/perllib/File/Copy.pm b/Master/tlpkg/installer/perllib/File/Copy.pm new file mode 100644 index 00000000000..52ba7c6d81a --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Copy.pm @@ -0,0 +1,459 @@ +# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This +# source code has been placed in the public domain by the author. +# Please be kind and preserve the documentation. +# +# Additions copyright 1996 by Charles Bailey. Permission is granted +# to distribute the revised code under the same terms as Perl itself. + +package File::Copy; + +use 5.006; +use strict; +use warnings; +use Carp; +use File::Spec; +use Config; +our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); +sub copy; +sub syscopy; +sub cp; +sub mv; + +# Note that this module implements only *part* of the API defined by +# the File/Copy.pm module of the File-Tools-2.0 package. However, that +# package has not yet been updated to work with Perl 5.004, and so it +# would be a Bad Thing for the CPAN module to grab it and replace this +# module. Therefore, we set this module's version higher than 2.0. +$VERSION = '2.09'; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(copy move); +@EXPORT_OK = qw(cp mv); + +$Too_Big = 1024 * 1024 * 2; + +my $macfiles; +if ($^O eq 'MacOS') { + $macfiles = eval { require Mac::MoreFiles }; + warn 'Mac::MoreFiles could not be loaded; using non-native syscopy' + if $@ && $^W; +} + +sub _catname { + my($from, $to) = @_; + if (not defined &basename) { + require File::Basename; + import File::Basename 'basename'; + } + + if ($^O eq 'MacOS') { + # a partial dir name that's valid only in the cwd (e.g. 'tmp') + $to = ':' . $to if $to !~ /:/; + } + + return File::Spec->catfile($to, basename($from)); +} + +sub copy { + croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") + unless(@_ == 2 || @_ == 3); + + my $from = shift; + my $to = shift; + + my $from_a_handle = (ref($from) + ? (ref($from) eq 'GLOB' + || UNIVERSAL::isa($from, 'GLOB') + || UNIVERSAL::isa($from, 'IO::Handle')) + : (ref(\$from) eq 'GLOB')); + my $to_a_handle = (ref($to) + ? (ref($to) eq 'GLOB' + || UNIVERSAL::isa($to, 'GLOB') + || UNIVERSAL::isa($to, 'IO::Handle')) + : (ref(\$to) eq 'GLOB')); + + if ($from eq $to) { # works for references, too + carp("'$from' and '$to' are identical (not copied)"); + # The "copy" was a success as the source and destination contain + # the same data. + return 1; + } + + if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && + !($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'vms')) { + my @fs = stat($from); + if (@fs) { + my @ts = stat($to); + if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) { + carp("'$from' and '$to' are identical (not copied)"); + return 0; + } + } + } + + if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { + $to = _catname($from, $to); + } + + if (defined &syscopy && !$Syscopy_is_copy + && !$to_a_handle + && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles + && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. + && !($from_a_handle && $^O eq 'MSWin32') + && !($from_a_handle && $^O eq 'MacOS') + && !($from_a_handle && $^O eq 'NetWare') + ) + { + return syscopy($from, $to); + } + + my $closefrom = 0; + my $closeto = 0; + my ($size, $status, $r, $buf); + local($\) = ''; + + my $from_h; + if ($from_a_handle) { + $from_h = $from; + } else { + $from = _protect($from) if $from =~ /^\s/s; + $from_h = \do { local *FH }; + open($from_h, "< $from\0") or goto fail_open1; + binmode $from_h or die "($!,$^E)"; + $closefrom = 1; + } + + my $to_h; + if ($to_a_handle) { + $to_h = $to; + } else { + $to = _protect($to) if $to =~ /^\s/s; + $to_h = \do { local *FH }; + open($to_h,"> $to\0") or goto fail_open2; + binmode $to_h or die "($!,$^E)"; + $closeto = 1; + } + + if (@_) { + $size = shift(@_) + 0; + croak("Bad buffer size for copy: $size\n") unless ($size > 0); + } else { + $size = tied(*$from_h) ? 0 : -s $from_h || 0; + $size = 1024 if ($size < 512); + $size = $Too_Big if ($size > $Too_Big); + } + + $! = 0; + for (;;) { + my ($r, $w, $t); + defined($r = sysread($from_h, $buf, $size)) + or goto fail_inner; + last unless $r; + for ($w = 0; $w < $r; $w += $t) { + $t = syswrite($to_h, $buf, $r - $w, $w) + or goto fail_inner; + } + } + + close($to_h) || goto fail_open2 if $closeto; + close($from_h) || goto fail_open1 if $closefrom; + + # Use this idiom to avoid uninitialized value warning. + return 1; + + # All of these contortions try to preserve error messages... + fail_inner: + if ($closeto) { + $status = $!; + $! = 0; + close $to_h; + $! = $status unless $!; + } + fail_open2: + if ($closefrom) { + $status = $!; + $! = 0; + close $from_h; + $! = $status unless $!; + } + fail_open1: + return 0; +} + +sub move { + croak("Usage: move(FROM, TO) ") unless @_ == 2; + + my($from,$to) = @_; + + my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts); + + if (-d $to && ! -d $from) { + $to = _catname($from, $to); + } + + ($tosz1,$tomt1) = (stat($to))[7,9]; + $fromsz = -s $from; + if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) { + # will not rename with overwrite + unlink $to; + } + return 1 if rename $from, $to; + + # Did rename return an error even though it succeeded, because $to + # is on a remote NFS file system, and NFS lost the server's ack? + return 1 if defined($fromsz) && !-e $from && # $from disappeared + (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there + ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed + $tosz2 == $fromsz; # it's all there + + ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something + + { + local $@; + eval { + local $SIG{__DIE__}; + copy($from,$to) or die; + my($atime, $mtime) = (stat($from))[8,9]; + utime($atime, $mtime, $to); + unlink($from) or die; + }; + return 1 unless $@; + } + ($sts,$ossts) = ($! + 0, $^E + 0); + + ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; + unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; + ($!,$^E) = ($sts,$ossts); + return 0; +} + +*cp = \© +*mv = \&move; + + +if ($^O eq 'MacOS') { + *_protect = sub { MacPerl::MakeFSSpec($_[0]) }; +} else { + *_protect = sub { "./$_[0]" }; +} + +# &syscopy is an XSUB under OS/2 +unless (defined &syscopy) { + if ($^O eq 'VMS') { + *syscopy = \&rmscopy; + } elsif ($^O eq 'mpeix') { + *syscopy = sub { + return 0 unless @_ == 2; + # Use the MPE cp program in order to + # preserve MPE file attributes. + return system('/bin/cp', '-f', $_[0], $_[1]) == 0; + }; + } elsif ($^O eq 'MSWin32') { + *syscopy = sub { + return 0 unless @_ == 2; + return Win32::CopyFile(@_, 1); + }; + } elsif ($macfiles) { + *syscopy = sub { + my($from, $to) = @_; + my($dir, $toname); + + return 0 unless -e $from; + + if ($to =~ /(.*:)([^:]+):?$/) { + ($dir, $toname) = ($1, $2); + } else { + ($dir, $toname) = (":", $to); + } + + unlink($to); + Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1); + }; + } else { + $Syscopy_is_copy = 1; + *syscopy = \© + } +} + +1; + +__END__ + +=head1 NAME + +File::Copy - Copy files or filehandles + +=head1 SYNOPSIS + + use File::Copy; + + copy("file1","file2") or die "Copy failed: $!"; + copy("Copy.pm",\*STDOUT); + move("/dev1/fileA","/dev2/fileB"); + + use File::Copy "cp"; + + $n = FileHandle->new("/a/file","r"); + cp($n,"x"); + +=head1 DESCRIPTION + +The File::Copy module provides two basic functions, C<copy> and +C<move>, which are useful for getting the contents of a file from +one place to another. + +=over 4 + +=item * + +The C<copy> function takes two +parameters: a file to copy from and a file to copy to. Either +argument may be a string, a FileHandle reference or a FileHandle +glob. Obviously, if the first argument is a filehandle of some +sort, it will be read from, and if it is a file I<name> it will +be opened for reading. Likewise, the second argument will be +written to (and created if need be). Trying to copy a file on top +of itself is a fatal error. + +B<Note that passing in +files as handles instead of names may lead to loss of information +on some operating systems; it is recommended that you use file +names whenever possible.> Files are opened in binary mode where +applicable. To get a consistent behaviour when copying from a +filehandle to a file, use C<binmode> on the filehandle. + +An optional third parameter can be used to specify the buffer +size used for copying. This is the number of bytes from the +first file, that wil be held in memory at any given time, before +being written to the second file. The default buffer size depends +upon the file, but will generally be the whole file (up to 2Mb), or +1k for filehandles that do not reference files (eg. sockets). + +You may use the syntax C<use File::Copy "cp"> to get at the +"cp" alias for this function. The syntax is I<exactly> the same. + +=item * + +The C<move> function also takes two parameters: the current name +and the intended name of the file to be moved. If the destination +already exists and is a directory, and the source is not a +directory, then the source file will be renamed into the directory +specified by the destination. + +If possible, move() will simply rename the file. Otherwise, it copies +the file to the new location and deletes the original. If an error occurs +during this copy-and-delete process, you may be left with a (possibly partial) +copy of the file under the destination name. + +You may use the "mv" alias for this function in the same way that +you may use the "cp" alias for C<copy>. + +=back + +File::Copy also provides the C<syscopy> routine, which copies the +file specified in the first parameter to the file specified in the +second parameter, preserving OS-specific attributes and file +structure. For Unix systems, this is equivalent to the simple +C<copy> routine, which doesn't preserve OS-specific attributes. For +VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 +systems, this calls the C<syscopy> XSUB directly. For Win32 systems, +this calls C<Win32::CopyFile>. + +On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>, +if available. + +=head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32) + +If both arguments to C<copy> are not file handles, +then C<copy> will perform a "system copy" of +the input file to a new output file, in order to preserve file +attributes, indexed file structure, I<etc.> The buffer size +parameter is ignored. If either argument to C<copy> is a +handle to an opened file, then data is copied using Perl +operators, and no effort is made to preserve file attributes +or record structure. + +The system copy routine may also be called directly under VMS and OS/2 +as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which +is the routine that does the actual work for syscopy). + +=over 4 + +=item rmscopy($from,$to[,$date_flag]) + +The first and second arguments may be strings, typeglobs, typeglob +references, or objects inheriting from IO::Handle; +they are used in all cases to obtain the +I<filespec> of the input and output files, respectively. The +name and type of the input file are used as defaults for the +output file, if necessary. + +A new version of the output file is always created, which +inherits the structure and RMS attributes of the input file, +except for owner and protections (and possibly timestamps; +see below). All data from the input file is copied to the +output file; if either of the first two parameters to C<rmscopy> +is a file handle, its position is unchanged. (Note that this +means a file handle pointing to the output file will be +associated with an old version of that file after C<rmscopy> +returns, not the newly created version.) + +The third parameter is an integer flag, which tells C<rmscopy> +how to handle timestamps. If it is E<lt> 0, none of the input file's +timestamps are propagated to the output file. If it is E<gt> 0, then +it is interpreted as a bitmask: if bit 0 (the LSB) is set, then +timestamps other than the revision date are propagated; if bit 1 +is set, the revision date is propagated. If the third parameter +to C<rmscopy> is 0, then it behaves much like the DCL COPY command: +if the name or type of the output file was explicitly specified, +then no timestamps are propagated, but if they were taken implicitly +from the input filespec, then all timestamps other than the +revision date are propagated. If this parameter is not supplied, +it defaults to 0. + +Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, +it sets C<$!>, deletes the output file, and returns 0. + +=back + +=head1 RETURN + +All functions return 1 on success, 0 on failure. +$! will be set if an error was encountered. + +=head1 NOTES + +=over 4 + +=item * + +On Mac OS (Classic), the path separator is ':', not '/', and the +current directory is denoted as ':', not '.'. You should be careful +about specifying relative pathnames. While a full path always begins +with a volume name, a relative pathname should always begin with a +':'. If specifying a volume name only, a trailing ':' is required. + +E.g. + + copy("file1", "tmp"); # creates the file 'tmp' in the current directory + copy("file1", ":tmp:"); # creates :tmp:file1 + copy("file1", ":tmp"); # same as above + copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do + # that, since it may cause confusion, see example #1) + copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume + copy("file1", ":tmp:file1"); # ok, partial path + copy("file1", "DataHD:"); # creates DataHD:file1 + + move("MacintoshHD:fileA", "DataHD:fileB"); # moves (don't copies) files from one + # volume to another + +=back + +=head1 AUTHOR + +File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995, +and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996. + +=cut + diff --git a/Master/tlpkg/installer/perllib/File/DosGlob.pm b/Master/tlpkg/installer/perllib/File/DosGlob.pm new file mode 100644 index 00000000000..a1c27d5c32a --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/DosGlob.pm @@ -0,0 +1,571 @@ +#!perl -w + +# use strict fails +#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. + +# +# Documentation at the __END__ +# + +package File::DosGlob; + +our $VERSION = '1.00'; +use strict; +use warnings; + +sub doglob { + my $cond = shift; + my @retval = (); + #print "doglob: ", join('|', @_), "\n"; + OUTER: + for my $pat (@_) { + my @matched = (); + my @globdirs = (); + my $head = '.'; + my $sepchr = '/'; + my $tail; + next OUTER unless defined $pat and $pat ne ''; + # if arg is within quotes strip em and do no globbing + if ($pat =~ /^"(.*)"\z/s) { + $pat = $1; + if ($cond eq 'd') { push(@retval, $pat) if -d $pat } + else { push(@retval, $pat) if -e $pat } + next OUTER; + } + # wildcards with a drive prefix such as h:*.pm must be changed + # to h:./*.pm to expand correctly + if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) { + substr($_,0,2) = $1 . "./"; + } + if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { + ($head, $sepchr, $tail) = ($1,$2,$3); + #print "div: |$head|$sepchr|$tail|\n"; + push (@retval, $pat), next OUTER if $tail eq ''; + if ($head =~ /[*?]/) { + @globdirs = doglob('d', $head); + push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), + next OUTER if @globdirs; + } + $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s; + $pat = $tail; + } + # + # If file component has no wildcards, we can avoid opendir + unless ($pat =~ /[*?]/) { + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + $head .= $pat; + if ($cond eq 'd') { push(@retval,$head) if -d $head } + else { push(@retval,$head) if -e $head } + next OUTER; + } + opendir(D, $head) or next OUTER; + my @leaves = readdir D; + closedir D; + $head = '' if $head eq '.'; + $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; + + # escape regex metachars but not glob chars + $pat =~ s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex + $pat =~ s/\*/.*/g; + $pat =~ s/\?/.?/g; + + #print "regex: '$pat', head: '$head'\n"; + my $matchsub = sub { $_[0] =~ m|^$pat\z|is }; + INNER: + for my $e (@leaves) { + next INNER if $e eq '.' or $e eq '..'; + next INNER if $cond eq 'd' and ! -d "$head$e"; + push(@matched, "$head$e"), next INNER if &$matchsub($e); + # + # [DOS compatibility special case] + # Failed, add a trailing dot and try again, but only + # if name does not have a dot in it *and* pattern + # has a dot *and* name is shorter than 9 chars. + # + if (index($e,'.') == -1 and length($e) < 9 + and index($pat,'\\.') != -1) { + push(@matched, "$head$e"), next INNER if &$matchsub("$e."); + } + } + push @retval, @matched if @matched; + } + return @retval; +} + + +# +# Do DOS-like globbing on Mac OS +# +sub doglob_Mac { + my $cond = shift; + my @retval = (); + + #print "doglob_Mac: ", join('|', @_), "\n"; + OUTER: + for my $arg (@_) { + local $_ = $arg; + my @matched = (); + my @globdirs = (); + my $head = ':'; + my $not_esc_head = $head; + my $sepchr = ':'; + next OUTER unless defined $_ and $_ ne ''; + # if arg is within quotes strip em and do no globbing + if (/^"(.*)"\z/s) { + $_ = $1; + # $_ may contain escaped metachars '\*', '\?' and '\' + my $not_esc_arg = $_; + $not_esc_arg =~ s/\\([*?\\])/$1/g; + if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg } + else { push(@retval, $not_esc_arg) if -e $not_esc_arg } + next OUTER; + } + + if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy + my $tail; + ($head, $sepchr, $tail) = ($1,$2,$3); + #print "div: |$head|$sepchr|$tail|\n"; + push (@retval, $_), next OUTER if $tail eq ''; + # + # $head may contain escaped metachars '\*' and '\?' + + my $tmp_head = $head; + # if a '*' or '?' is preceded by an odd count of '\', temporary delete + # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as + # wildcards + $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; + + if ($tmp_head =~ /[*?]/) { # if there are wildcards ... + @globdirs = doglob_Mac('d', $head); + push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)), + next OUTER if @globdirs; + } + + $head .= $sepchr; + $not_esc_head = $head; + # unescape $head for file operations + $not_esc_head =~ s/\\([*?\\])/$1/g; + $_ = $tail; + } + # + # If file component has no wildcards, we can avoid opendir + + my $tmp_tail = $_; + # if a '*' or '?' is preceded by an odd count of '\', temporary delete + # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as + # wildcards + $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; + + unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ... + $not_esc_head = $head = '' if $head eq ':'; + my $not_esc_tail = $_; + # unescape $head and $tail for file operations + $not_esc_tail =~ s/\\([*?\\])/$1/g; + $head .= $_; + $not_esc_head .= $not_esc_tail; + if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head } + else { push(@retval,$head) if -e $not_esc_head } + next OUTER; + } + #print "opendir($not_esc_head)\n"; + opendir(D, $not_esc_head) or next OUTER; + my @leaves = readdir D; + closedir D; + + # escape regex metachars but not '\' and glob chars '*', '?' + $_ =~ s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex, + # but only if they are not escaped + $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; + + #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n"; + my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; + warn($@), next OUTER if $@; + INNER: + for my $e (@leaves) { + next INNER if $e eq '.' or $e eq '..'; + next INNER if $cond eq 'd' and ! -d "$not_esc_head$e"; + + if (&$matchsub($e)) { + my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ? + "$e" : "$not_esc_head$e"; + # + # On Mac OS, the two glob metachars '*' and '?' and the escape + # char '\' are valid characters for file and directory names. + # We have to escape and treat them specially. + $leave =~ s|([*?\\])|\\$1|g; + push(@matched, $leave); + next INNER; + } + } + push @retval, @matched if @matched; + } + return @retval; +} + +# +# _expand_volume() will only be used on Mac OS (Classic): +# Takes an array of original patterns as argument and returns an array of +# possibly modified patterns. Each original pattern is processed like +# that: +# + If there's a volume name in the pattern, we push a separate pattern +# for each mounted volume that matches (with '*', '?' and '\' escaped). +# + If there's no volume name in the original pattern, it is pushed +# unchanged. +# Note that the returned array of patterns may be empty. +# +sub _expand_volume { + + require MacPerl; # to be verbose + + my @pat = @_; + my @new_pat = (); + my @FSSpec_Vols = MacPerl::Volumes(); + my @mounted_volumes = (); + + foreach my $spec_vol (@FSSpec_Vols) { + # push all mounted volumes into array + push @mounted_volumes, MacPerl::MakePath($spec_vol); + } + #print "mounted volumes: |@mounted_volumes|\n"; + + while (@pat) { + my $pat = shift @pat; + if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name? + my $vol_pat = $1; + my $tail = $2; + # + # escape regex metachars but not '\' and glob chars '*', '?' + $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex, + # but only if they are not escaped + $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; + #print "volume regex: '$vol_pat' \n"; + + foreach my $volume (@mounted_volumes) { + if ($volume =~ m|^$vol_pat\z|ios) { + # + # On Mac OS, the two glob metachars '*' and '?' and the + # escape char '\' are valid characters for volume names. + # We have to escape and treat them specially. + $volume =~ s|([*?\\])|\\$1|g; + push @new_pat, $volume . $tail; + } + } + } else { # no volume name in pattern, push original pattern + push @new_pat, $pat; + } + } + return @new_pat; +} + + +# +# _preprocess_pattern() will only be used on Mac OS (Classic): +# Resolves any updirs in the pattern. Removes a single trailing colon +# from the pattern, unless it's a volume name pattern like "*HD:" +# +sub _preprocess_pattern { + my @pat = @_; + + foreach my $p (@pat) { + my $proceed; + # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*" + do { + $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); + } while ($proceed); + # remove a single trailing colon, e.g. ":*:" -> ":*" + $p =~ s/:([^:]+):\z/:$1/; + } + return @pat; +} + + +# +# _un_escape() will only be used on Mac OS (Classic): +# Unescapes a list of arguments which may contain escaped +# metachars '*', '?' and '\'. +# +sub _un_escape { + foreach (@_) { + s/\\([*?\\])/$1/g; + } + return @_; +} + +# +# this can be used to override CORE::glob in a specific +# package by saying C<use File::DosGlob 'glob';> in that +# namespace. +# + +# context (keyed by second cxix arg provided by core) +my %iter; +my %entries; + +sub glob { + my($pat,$cxix) = @_; + my @pat; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # extract patterns + if ($pat =~ /\s/) { + require Text::ParseWords; + @pat = Text::ParseWords::parse_line('\s+',0,$pat); + } + else { + push @pat, $pat; + } + + # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3. + # abc3 will be the original {3} (and drop the {}). + # abc1 abc2 will be put in @appendpat. + # This was just the esiest way, not nearly the best. + REHASH: { + my @appendpat = (); + for (@pat) { + # There must be a "," I.E. abc{efg} is not what we want. + while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) { + my ($start, $match, $end) = ($1, $2, $3); + #print "Got: \n\t$start\n\t$match\n\t$end\n"; + my $tmp = "$start$match$end"; + while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) { + #print "Striped: $tmp\n"; + # these expanshions will be preformed by the original, + # when we call REHASH. + } + push @appendpat, ("$tmp"); + s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/; + if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) { + $match = $1; + #print "GOT: \n\t$start\n\t$match\n\t$end\n\n"; + $_ = "$start$match$end"; + } + } + #print "Sould have "GOT" vs "Got"!\n"; + #FIXME: There should be checking for this. + # How or what should be done about failure is beond me. + } + if ( $#appendpat != -1 + ) { + #print "LOOP\n"; + #FIXME: Max loop, no way! :") + for ( @appendpat ) { + push @pat, $_; + } + goto REHASH; + } + } + for ( @pat ) { + s/\\{/{/g; + s/\\}/}/g; + s/\\,/,/g; + } + #print join ("\n", @pat). "\n"; + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + if ($^O eq 'MacOS') { + # first, take care of updirs and trailing colons + @pat = _preprocess_pattern(@pat); + # expand volume names + @pat = _expand_volume(@pat); + $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@pat) )] : [()]; + } else { + $entries{$cxix} = [doglob(1,@pat)]; + } + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} + +{ + no strict 'refs'; + + sub import { + my $pkg = shift; + return unless @_; + my $sym = shift; + my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0)); + *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; + } +} +1; + +__END__ + +=head1 NAME + +File::DosGlob - DOS like globbing and then some + +=head1 SYNOPSIS + + require 5.004; + + # override CORE::glob in current package + use File::DosGlob 'glob'; + + # override CORE::glob in ALL packages (use with extreme caution!) + use File::DosGlob 'GLOBAL_glob'; + + @perlfiles = glob "..\\pe?l/*.p?"; + print <..\\pe?l/*.p?>; + + # from the command line (overrides only in main::) + > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" + +=head1 DESCRIPTION + +A module that implements DOS-like globbing with a few enhancements. +It is largely compatible with perlglob.exe (the M$ setargv.obj +version) in all but one respect--it understands wildcards in +directory components. + +For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in +that it will find something like '..\lib\File/DosGlob.pm' alright). +Note that all path components are case-insensitive, and that +backslashes and forward slashes are both accepted, and preserved. +You may have to double the backslashes if you are putting them in +literally, due to double-quotish parsing of the pattern by perl. + +Spaces in the argument delimit distinct patterns, so +C<glob('*.exe *.dll')> globs all filenames that end in C<.exe> +or C<.dll>. If you want to put in literal spaces in the glob +pattern, you can escape them with either double quotes, or backslashes. +e.g. C<glob('c:/"Program Files"/*/*.dll')>, or +C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using +C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details +of the quoting rules used. + +Extending it to csh patterns is left as an exercise to the reader. + +=head1 NOTES + +=over 4 + +=item * + +Mac OS (Classic) users should note a few differences. The specification +of pathnames in glob patterns adheres to the usual Mac OS conventions: +The path separator is a colon ':', not a slash '/' or backslash '\'. A +full path always begins with a volume name. A relative pathname on Mac +OS must always begin with a ':', except when specifying a file or +directory name in the current working directory, where the leading colon +is optional. If specifying a volume name only, a trailing ':' is +required. Due to these rules, a glob like E<lt>*:E<gt> will find all +mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find +all files and directories in the current directory. + +Note that updirs in the glob pattern are resolved before the matching begins, +i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also, +that a single trailing ':' in the pattern is ignored (unless it's a volume +name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories +I<and> files (and not, as one might expect, only directories). + +The metachars '*', '?' and the escape char '\' are valid characters in +volume, directory and file names on Mac OS. Hence, if you want to match +a '*', '?' or '\' literally, you have to escape these characters. Due to +perl's quoting rules, things may get a bit complicated, when you want to +match a string like '\*' literally, or when you want to match '\' literally, +but treat the immediately following character '*' as metachar. So, here's a +rule of thumb (applies to both single- and double-quoted strings): escape +each '*' or '?' or '\' with a backslash, if you want to treat them literally, +and then double each backslash and your are done. E.g. + +- Match '\*' literally + + escape both '\' and '*' : '\\\*' + double the backslashes : '\\\\\\*' + +(Internally, the glob routine sees a '\\\*', which means that both '\' and +'*' are escaped.) + + +- Match '\' literally, treat '*' as metachar + + escape '\' but not '*' : '\\*' + double the backslashes : '\\\\*' + +(Internally, the glob routine sees a '\\*', which means that '\' is escaped and +'*' is not.) + +Note that you also have to quote literal spaces in the glob pattern, as described +above. + +=back + +=head1 EXPORTS (by request only) + +glob() + +=head1 BUGS + +Should probably be built into the core, and needs to stop +pandering to DOS habits. Needs a dose of optimizium too. + +=head1 AUTHOR + +Gurusamy Sarathy <gsar@activestate.com> + +=head1 HISTORY + +=over 4 + +=item * + +Support for globally overriding glob() (GSAR 3-JUN-98) + +=item * + +Scalar context, independent iterator context fixes (GSAR 15-SEP-97) + +=item * + +A few dir-vs-file optimizations result in glob importation being +10 times faster than using perlglob.exe, and using perlglob.bat is +only twice as slow as perlglob.exe (GSAR 28-MAY-97) + +=item * + +Several cleanups prompted by lack of compatible perlglob.exe +under Borland (GSAR 27-MAY-97) + +=item * + +Initial version (GSAR 20-FEB-97) + +=back + +=head1 SEE ALSO + +perl + +perlglob.bat + +Text::ParseWords + +=cut + diff --git a/Master/tlpkg/installer/perllib/File/Find.pm b/Master/tlpkg/installer/perllib/File/Find.pm new file mode 100644 index 00000000000..497051e0635 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Find.pm @@ -0,0 +1,1275 @@ +package File::Find; +use 5.006; +use strict; +use warnings; +use warnings::register; +our $VERSION = '1.10'; +require Exporter; +require Cwd; + +# +# Modified to ensure sub-directory traversal order is not inverded by stack +# push and pops. That is remains in the same order as in the directory file, +# or user pre-processing (EG:sorted). +# + +=head1 NAME + +File::Find - Traverse a directory tree. + +=head1 SYNOPSIS + + use File::Find; + find(\&wanted, @directories_to_search); + sub wanted { ... } + + use File::Find; + finddepth(\&wanted, @directories_to_search); + sub wanted { ... } + + use File::Find; + find({ wanted => \&process, follow => 1 }, '.'); + +=head1 DESCRIPTION + +These are functions for searching through directory trees doing work +on each file found similar to the Unix I<find> command. File::Find +exports two functions, C<find> and C<finddepth>. They work similarly +but have subtle differences. + +=over 4 + +=item B<find> + + find(\&wanted, @directories); + find(\%options, @directories); + +C<find()> does a depth-first search over the given C<@directories> in +the order they are given. For each file or directory found, it calls +the C<&wanted> subroutine. (See below for details on how to use the +C<&wanted> function). Additionally, for each directory found, it will +C<chdir()> into that directory and continue the search, invoking the +C<&wanted> function on each file or subdirectory in the directory. + +=item B<finddepth> + + finddepth(\&wanted, @directories); + finddepth(\%options, @directories); + +C<finddepth()> works just like C<find()> except that is invokes the +C<&wanted> function for a directory I<after> invoking it for the +directory's contents. It does a postorder traversal instead of a +preorder traversal, working from the bottom of the directory tree up +where C<find()> works from the top of the tree down. + +=back + +=head2 %options + +The first argument to C<find()> is either a code reference to your +C<&wanted> function, or a hash reference describing the operations +to be performed for each file. The +code reference is described in L<The wanted function> below. + +Here are the possible keys for the hash: + +=over 3 + +=item C<wanted> + +The value should be a code reference. This code reference is +described in L<The wanted function> below. + +=item C<bydepth> + +Reports the name of a directory only AFTER all its entries +have been reported. Entry point C<finddepth()> is a shortcut for +specifying C<<{ bydepth => 1 }>> in the first argument of C<find()>. + +=item C<preprocess> + +The value should be a code reference. This code reference is used to +preprocess the current directory. The name of the currently processed +directory is in C<$File::Find::dir>. Your preprocessing function is +called after C<readdir()>, but before the loop that calls the C<wanted()> +function. It is called with a list of strings (actually file/directory +names) and is expected to return a list of strings. The code can be +used to sort the file/directory names alphabetically, numerically, +or to filter out directory entries based on their name alone. When +I<follow> or I<follow_fast> are in effect, C<preprocess> is a no-op. + +=item C<postprocess> + +The value should be a code reference. It is invoked just before leaving +the currently processed directory. It is called in void context with no +arguments. The name of the current directory is in C<$File::Find::dir>. This +hook is handy for summarizing a directory, such as calculating its disk +usage. When I<follow> or I<follow_fast> are in effect, C<postprocess> is a +no-op. + +=item C<follow> + +Causes symbolic links to be followed. Since directory trees with symbolic +links (followed) may contain files more than once and may even have +cycles, a hash has to be built up with an entry for each file. +This might be expensive both in space and time for a large +directory tree. See I<follow_fast> and I<follow_skip> below. +If either I<follow> or I<follow_fast> is in effect: + +=over 6 + +=item * + +It is guaranteed that an I<lstat> has been called before the user's +C<wanted()> function is called. This enables fast file checks involving S<_>. +Note that this guarantee no longer holds if I<follow> or I<follow_fast> +are not set. + +=item * + +There is a variable C<$File::Find::fullname> which holds the absolute +pathname of the file with all symbolic links resolved. If the link is +a dangling symbolic link, then fullname will be set to C<undef>. + +=back + +This is a no-op on Win32. + +=item C<follow_fast> + +This is similar to I<follow> except that it may report some files more +than once. It does detect cycles, however. Since only symbolic links +have to be hashed, this is much cheaper both in space and time. If +processing a file more than once (by the user's C<wanted()> function) +is worse than just taking time, the option I<follow> should be used. + +This is also a no-op on Win32. + +=item C<follow_skip> + +C<follow_skip==1>, which is the default, causes all files which are +neither directories nor symbolic links to be ignored if they are about +to be processed a second time. If a directory or a symbolic link +are about to be processed a second time, File::Find dies. + +C<follow_skip==0> causes File::Find to die if any file is about to be +processed a second time. + +C<follow_skip==2> causes File::Find to ignore any duplicate files and +directories but to proceed normally otherwise. + +=item C<dangling_symlinks> + +If true and a code reference, will be called with the symbolic link +name and the directory it lives in as arguments. Otherwise, if true +and warnings are on, warning "symbolic_link_name is a dangling +symbolic link\n" will be issued. If false, the dangling symbolic link +will be silently ignored. + +=item C<no_chdir> + +Does not C<chdir()> to each directory as it recurses. The C<wanted()> +function will need to be aware of this, of course. In this case, +C<$_> will be the same as C<$File::Find::name>. + +=item C<untaint> + +If find is used in taint-mode (-T command line switch or if EUID != UID +or if EGID != GID) then internally directory names have to be untainted +before they can be chdir'ed to. Therefore they are checked against a regular +expression I<untaint_pattern>. Note that all names passed to the user's +I<wanted()> function are still tainted. If this option is used while +not in taint-mode, C<untaint> is a no-op. + +=item C<untaint_pattern> + +See above. This should be set using the C<qr> quoting operator. +The default is set to C<qr|^([-+@\w./]+)$|>. +Note that the parentheses are vital. + +=item C<untaint_skip> + +If set, a directory which fails the I<untaint_pattern> is skipped, +including all its sub-directories. The default is to 'die' in such a case. + +=back + +=head2 The wanted function + +The C<wanted()> function does whatever verifications you want on +each file and directory. Note that despite its name, the C<wanted()> +function is a generic callback function, and does B<not> tell +File::Find if a file is "wanted" or not. In fact, its return value +is ignored. + +The wanted function takes no arguments but rather does its work +through a collection of variables. + +=over 4 + +=item C<$File::Find::dir> is the current directory name, + +=item C<$_> is the current filename within that directory + +=item C<$File::Find::name> is the complete pathname to the file. + +=back + +Don't modify these variables. + +For example, when examining the file F</some/path/foo.ext> you will have: + + $File::Find::dir = /some/path/ + $_ = foo.ext + $File::Find::name = /some/path/foo.ext + +You are chdir()'d to C<$File::Find::dir> when the function is called, +unless C<no_chdir> was specified. Note that when changing to +directories is in effect the root directory (F</>) is a somewhat +special case inasmuch as the concatenation of C<$File::Find::dir>, +C<'/'> and C<$_> is not literally equal to C<$File::Find::name>. The +table below summarizes all variants: + + $File::Find::name $File::Find::dir $_ + default / / . + no_chdir=>0 /etc / etc + /etc/x /etc x + + no_chdir=>1 / / / + /etc / /etc + /etc/x /etc /etc/x + + +When <follow> or <follow_fast> are in effect, there is +also a C<$File::Find::fullname>. The function may set +C<$File::Find::prune> to prune the tree unless C<bydepth> was +specified. Unless C<follow> or C<follow_fast> is specified, for +compatibility reasons (find.pl, find2perl) there are in addition the +following globals available: C<$File::Find::topdir>, +C<$File::Find::topdev>, C<$File::Find::topino>, +C<$File::Find::topmode> and C<$File::Find::topnlink>. + +This library is useful for the C<find2perl> tool, which when fed, + + find2perl / -name .nfs\* -mtime +7 \ + -exec rm -f {} \; -o -fstype nfs -prune + +produces something like: + + sub wanted { + /^\.nfs.*\z/s && + (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) && + int(-M _) > 7 && + unlink($_) + || + ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) && + $dev < 0 && + ($File::Find::prune = 1); + } + +Notice the C<_> in the above C<int(-M _)>: the C<_> is a magical +filehandle that caches the information from the preceding +C<stat()>, C<lstat()>, or filetest. + +Here's another interesting wanted function. It will find all symbolic +links that don't resolve: + + sub wanted { + -l && !-e && print "bogus link: $File::Find::name\n"; + } + +See also the script C<pfind> on CPAN for a nice application of this +module. + +=head1 WARNINGS + +If you run your program with the C<-w> switch, or if you use the +C<warnings> pragma, File::Find will report warnings for several weird +situations. You can disable these warnings by putting the statement + + no warnings 'File::Find'; + +in the appropriate scope. See L<perllexwarn> for more info about lexical +warnings. + +=head1 CAVEAT + +=over 2 + +=item $dont_use_nlink + +You can set the variable C<$File::Find::dont_use_nlink> to 1, if you want to +force File::Find to always stat directories. This was used for file systems +that do not have an C<nlink> count matching the number of sub-directories. +Examples are ISO-9660 (CD-ROM), AFS, HPFS (OS/2 file system), FAT (DOS file +system) and a couple of others. + +You shouldn't need to set this variable, since File::Find should now detect +such file systems on-the-fly and switch itself to using stat. This works even +for parts of your file system, like a mounted CD-ROM. + +If you do set C<$File::Find::dont_use_nlink> to 1, you will notice slow-downs. + +=item symlinks + +Be aware that the option to follow symbolic links can be dangerous. +Depending on the structure of the directory tree (including symbolic +links to directories) you might traverse a given (physical) directory +more than once (only if C<follow_fast> is in effect). +Furthermore, deleting or changing files in a symbolically linked directory +might cause very unpleasant surprises, since you delete or change files +in an unknown directory. + +=back + +=head1 NOTES + +=over 4 + +=item * + +Mac OS (Classic) users should note a few differences: + +=over 4 + +=item * + +The path separator is ':', not '/', and the current directory is denoted +as ':', not '.'. You should be careful about specifying relative pathnames. +While a full path always begins with a volume name, a relative pathname +should always begin with a ':'. If specifying a volume name only, a +trailing ':' is required. + +=item * + +C<$File::Find::dir> is guaranteed to end with a ':'. If C<$_> +contains the name of a directory, that name may or may not end with a +':'. Likewise, C<$File::Find::name>, which contains the complete +pathname to that directory, and C<$File::Find::fullname>, which holds +the absolute pathname of that directory with all symbolic links resolved, +may or may not end with a ':'. + +=item * + +The default C<untaint_pattern> (see above) on Mac OS is set to +C<qr|^(.+)$|>. Note that the parentheses are vital. + +=item * + +The invisible system file "Icon\015" is ignored. While this file may +appear in every directory, there are some more invisible system files +on every volume, which are all located at the volume root level (i.e. +"MacintoshHD:"). These system files are B<not> excluded automatically. +Your filter may use the following code to recognize invisible files or +directories (requires Mac::Files): + + use Mac::Files; + + # invisible() -- returns 1 if file/directory is invisible, + # 0 if it's visible or undef if an error occurred + + sub invisible($) { + my $file = shift; + my ($fileCat, $fileInfo); + my $invisible_flag = 1 << 14; + + if ( $fileCat = FSpGetCatInfo($file) ) { + if ($fileInfo = $fileCat->ioFlFndrInfo() ) { + return (($fileInfo->fdFlags & $invisible_flag) && 1); + } + } + return undef; + } + +Generally, invisible files are system files, unless an odd application +decides to use invisible files for its own purposes. To distinguish +such files from system files, you have to look at the B<type> and B<creator> +file attributes. The MacPerl built-in functions C<GetFileInfo(FILE)> and +C<SetFileInfo(CREATOR, TYPE, FILES)> offer access to these attributes +(see MacPerl.pm for details). + +Files that appear on the desktop actually reside in an (hidden) directory +named "Desktop Folder" on the particular disk volume. Note that, although +all desktop files appear to be on the same "virtual" desktop, each disk +volume actually maintains its own "Desktop Folder" directory. + +=back + +=back + +=head1 BUGS AND CAVEATS + +Despite the name of the C<finddepth()> function, both C<find()> and +C<finddepth()> perform a depth-first search of the directory +hierarchy. + +=head1 HISTORY + +File::Find used to produce incorrect results if called recursively. +During the development of perl 5.8 this bug was fixed. +The first fixed version of File::Find was 1.01. + +=cut + +our @ISA = qw(Exporter); +our @EXPORT = qw(find finddepth); + + +use strict; +my $Is_VMS; +my $Is_MacOS; + +require File::Basename; +require File::Spec; + +# Should ideally be my() not our() but local() currently +# refuses to operate on lexicals + +our %SLnkSeen; +our ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, + $pre_process, $post_process, $dangling_symlinks); + +sub contract_name { + my ($cdir,$fn) = @_; + + return substr($cdir,0,rindex($cdir,'/')) if $fn eq $File::Find::current_dir; + + $cdir = substr($cdir,0,rindex($cdir,'/')+1); + + $fn =~ s|^\./||; + + my $abs_name= $cdir . $fn; + + if (substr($fn,0,3) eq '../') { + 1 while $abs_name =~ s!/[^/]*/\.\./!/!; + } + + return $abs_name; +} + +# return the absolute name of a directory or file +sub contract_name_Mac { + my ($cdir,$fn) = @_; + my $abs_name; + + if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':' + + my $colon_count = length ($1); + if ($colon_count == 1) { + $abs_name = $cdir . $2; + return $abs_name; + } + else { + # need to move up the tree, but + # only if it's not a volume name + for (my $i=1; $i<$colon_count; $i++) { + unless ($cdir =~ /^[^:]+:$/) { # volume name + $cdir =~ s/[^:]+:$//; + } + else { + return undef; + } + } + $abs_name = $cdir . $2; + return $abs_name; + } + + } + else { + + # $fn may be a valid path to a directory or file or (dangling) + # symlink, without a leading ':' + if ( (-e $fn) || (-l $fn) ) { + if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:* + return $fn; # $fn is already an absolute path + } + else { + $abs_name = $cdir . $fn; + return $abs_name; + } + } + else { # argh!, $fn is not a valid directory/file + return undef; + } + } +} + +sub PathCombine($$) { + my ($Base,$Name) = @_; + my $AbsName; + + if ($Is_MacOS) { + # $Name is the resolved symlink (always a full path on MacOS), + # i.e. there's no need to call contract_name_Mac() + $AbsName = $Name; + + # (simple) check for recursion + if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion + return undef; + } + } + else { + if (substr($Name,0,1) eq '/') { + $AbsName= $Name; + } + else { + $AbsName= contract_name($Base,$Name); + } + + # (simple) check for recursion + my $newlen= length($AbsName); + if ($newlen <= length($Base)) { + if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/') + && $AbsName eq substr($Base,0,$newlen)) + { + return undef; + } + } + } + return $AbsName; +} + +sub Follow_SymLink($) { + my ($AbsName) = @_; + + my ($NewName,$DEV, $INO); + ($DEV, $INO)= lstat $AbsName; + + while (-l _) { + if ($SLnkSeen{$DEV, $INO}++) { + if ($follow_skip < 2) { + die "$AbsName is encountered a second time"; + } + else { + return undef; + } + } + $NewName= PathCombine($AbsName, readlink($AbsName)); + unless(defined $NewName) { + if ($follow_skip < 2) { + die "$AbsName is a recursive symbolic link"; + } + else { + return undef; + } + } + else { + $AbsName= $NewName; + } + ($DEV, $INO) = lstat($AbsName); + return undef unless defined $DEV; # dangling symbolic link + } + + if ($full_check && defined $DEV && $SLnkSeen{$DEV, $INO}++) { + if ( ($follow_skip < 1) || ((-d _) && ($follow_skip < 2)) ) { + die "$AbsName encountered a second time"; + } + else { + return undef; + } + } + + return $AbsName; +} + +our($dir, $name, $fullname, $prune); +sub _find_dir_symlnk($$$); +sub _find_dir($$$); + +# check whether or not a scalar variable is tainted +# (code straight from the Camel, 3rd ed., page 561) +sub is_tainted_pp { + my $arg = shift; + my $nada = substr($arg, 0, 0); # zero-length + local $@; + eval { eval "# $nada" }; + return length($@) != 0; +} + +sub _find_opt { + my $wanted = shift; + die "invalid top directory" unless defined $_[0]; + + # This function must local()ize everything because callbacks may + # call find() or finddepth() + + local %SLnkSeen; + local ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat, + $pre_process, $post_process, $dangling_symlinks); + local($dir, $name, $fullname, $prune); + local *_ = \my $a; + + my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::getcwd(); + my $cwd_untainted = $cwd; + my $check_t_cwd = 1; + $wanted_callback = $wanted->{wanted}; + $bydepth = $wanted->{bydepth}; + $pre_process = $wanted->{preprocess}; + $post_process = $wanted->{postprocess}; + $no_chdir = $wanted->{no_chdir}; + $full_check = $^O eq 'MSWin32' ? 0 : $wanted->{follow}; + $follow = $^O eq 'MSWin32' ? 0 : + $full_check || $wanted->{follow_fast}; + $follow_skip = $wanted->{follow_skip}; + $untaint = $wanted->{untaint}; + $untaint_pat = $wanted->{untaint_pattern}; + $untaint_skip = $wanted->{untaint_skip}; + $dangling_symlinks = $wanted->{dangling_symlinks}; + + # for compatibility reasons (find.pl, find2perl) + local our ($topdir, $topdev, $topino, $topmode, $topnlink); + + # a symbolic link to a directory doesn't increase the link count + $avoid_nlink = $follow || $File::Find::dont_use_nlink; + + my ($abs_dir, $Is_Dir); + + Proc_Top_Item: + foreach my $TOP (@_) { + my $top_item = $TOP; + + ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item; + + if ($Is_MacOS) { + $top_item = ":$top_item" + if ( (-d _) && ( $top_item !~ /:/ ) ); + } elsif ($^O eq 'MSWin32') { + $top_item =~ s|/\z|| unless $top_item =~ m|\w:/$|; + } + else { + $top_item =~ s|/\z|| unless $top_item eq '/'; + } + + $Is_Dir= 0; + + if ($follow) { + + if ($Is_MacOS) { + $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety + + if ($top_item eq $File::Find::current_dir) { + $abs_dir = $cwd; + } + else { + $abs_dir = contract_name_Mac($cwd, $top_item); + unless (defined $abs_dir) { + warnings::warnif "Can't determine absolute path for $top_item (No such file or directory)\n"; + next Proc_Top_Item; + } + } + + } + else { + if (substr($top_item,0,1) eq '/') { + $abs_dir = $top_item; + } + elsif ($top_item eq $File::Find::current_dir) { + $abs_dir = $cwd; + } + else { # care about any ../ + $abs_dir = contract_name("$cwd/",$top_item); + } + } + $abs_dir= Follow_SymLink($abs_dir); + unless (defined $abs_dir) { + if ($dangling_symlinks) { + if (ref $dangling_symlinks eq 'CODE') { + $dangling_symlinks->($top_item, $cwd); + } else { + warnings::warnif "$top_item is a dangling symbolic link\n"; + } + } + next Proc_Top_Item; + } + + if (-d _) { + _find_dir_symlnk($wanted, $abs_dir, $top_item); + $Is_Dir= 1; + } + } + else { # no follow + $topdir = $top_item; + unless (defined $topnlink) { + warnings::warnif "Can't stat $top_item: $!\n"; + next Proc_Top_Item; + } + if (-d _) { + $top_item =~ s/\.dir\z//i if $Is_VMS; + _find_dir($wanted, $top_item, $topnlink); + $Is_Dir= 1; + } + else { + $abs_dir= $top_item; + } + } + + unless ($Is_Dir) { + unless (($_,$dir) = File::Basename::fileparse($abs_dir)) { + if ($Is_MacOS) { + ($dir,$_) = (':', $top_item); # $File::Find::dir, $_ + } + else { + ($dir,$_) = ('./', $top_item); + } + } + + $abs_dir = $dir; + if (( $untaint ) && (is_tainted($dir) )) { + ( $abs_dir ) = $dir =~ m|$untaint_pat|; + unless (defined $abs_dir) { + if ($untaint_skip == 0) { + die "directory $dir is still tainted"; + } + else { + next Proc_Top_Item; + } + } + } + + unless ($no_chdir || chdir $abs_dir) { + warnings::warnif "Couldn't chdir $abs_dir: $!\n"; + next Proc_Top_Item; + } + + $name = $abs_dir . $_; # $File::Find::name + $_ = $name if $no_chdir; + + { $wanted_callback->() }; # protect against wild "next" + + } + + unless ( $no_chdir ) { + if ( ($check_t_cwd) && (($untaint) && (is_tainted($cwd) )) ) { + ( $cwd_untainted ) = $cwd =~ m|$untaint_pat|; + unless (defined $cwd_untainted) { + die "insecure cwd in find(depth)"; + } + $check_t_cwd = 0; + } + unless (chdir $cwd_untainted) { + die "Can't cd to $cwd: $!\n"; + } + } + } +} + +# API: +# $wanted +# $p_dir : "parent directory" +# $nlink : what came back from the stat +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir($$$) { + my ($wanted, $p_dir, $nlink) = @_; + my ($CdLvl,$Level) = (0,0); + my @Stack; + my @filenames; + my ($subcount,$sub_nlink); + my $SE= []; + my $dir_name= $p_dir; + my $dir_pref; + my $dir_rel = $File::Find::current_dir; + my $tainted = 0; + my $no_nlink; + + if ($Is_MacOS) { + $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface + } elsif ($^O eq 'MSWin32') { + $dir_pref = ($p_dir =~ m|\w:/$| ? $p_dir : "$p_dir/" ); + } + else { + $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" ); + } + + local ($dir, $name, $prune, *DIR); + + unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) { + my $udir = $p_dir; + if (( $untaint ) && (is_tainted($p_dir) )) { + ( $udir ) = $p_dir =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory $p_dir is still tainted"; + } + else { + return; + } + } + } + unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { + warnings::warnif "Can't cd to $udir: $!\n"; + return; + } + } + + # push the starting directory + push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; + + if ($Is_MacOS) { + $p_dir = $dir_pref; # ensure trailing ':' + } + + while (defined $SE) { + unless ($bydepth) { + $dir= $p_dir; # $File::Find::dir + $name= $dir_name; # $File::Find::name + $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ + # prune may happen here + $prune= 0; + { $wanted_callback->() }; # protect against wild "next" + next if $prune; + } + + # change to that directory + unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { + my $udir= $dir_rel; + if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_rel) )) ) { + ( $udir ) = $dir_rel =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + if ($Is_MacOS) { + die "directory ($p_dir) $dir_rel is still tainted"; + } + else { + die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted"; + } + } else { # $untaint_skip == 1 + next; + } + } + } + unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) { + if ($Is_MacOS) { + warnings::warnif "Can't cd to ($p_dir) $udir: $!\n"; + } + else { + warnings::warnif "Can't cd to (" . + ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n"; + } + next; + } + $CdLvl++; + } + + if ($Is_MacOS) { + $dir_name = "$dir_name:" unless ($dir_name =~ /:$/); + } + + $dir= $dir_name; # $File::Find::dir + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) { + warnings::warnif "Can't opendir($dir_name): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + @filenames = $pre_process->(@filenames) if $pre_process; + push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process; + + # default: use whatever was specifid + # (if $nlink >= 2, and $avoid_nlink == 0, this will switch back) + $no_nlink = $avoid_nlink; + # if dir has wrong nlink count, force switch to slower stat method + $no_nlink = 1 if ($nlink < 2); + + if ($nlink == 2 && !$no_nlink) { + # This dir has no subdirectories. + for my $FN (@filenames) { + next if $FN =~ $File::Find::skip_pattern; + + $name = $dir_pref . $FN; # $File::Find::name + $_ = ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + + } + else { + # This dir has subdirectories. + $subcount = $nlink - 2; + + # HACK: insert directories at this position. so as to preserve + # the user pre-processed ordering of files. + # EG: directory traversal is in user sorted order, not at random. + my $stack_top = @Stack; + + for my $FN (@filenames) { + next if $FN =~ $File::Find::skip_pattern; + if ($subcount > 0 || $no_nlink) { + # Seen all the subdirs? + # check for directoriness. + # stat is faster for a file in the current directory + $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3]; + + if (-d _) { + --$subcount; + $FN =~ s/\.dir\z//i if $Is_VMS; + # HACK: replace push to preserve dir traversal order + #push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink]; + splice @Stack, $stack_top, 0, + [$CdLvl,$dir_name,$FN,$sub_nlink]; + } + else { + $name = $dir_pref . $FN; # $File::Find::name + $_= ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + } + else { + $name = $dir_pref . $FN; # $File::Find::name + $_= ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + } + } + } + continue { + while ( defined ($SE = pop @Stack) ) { + ($Level, $p_dir, $dir_rel, $nlink) = @$SE; + if ($CdLvl > $Level && !$no_chdir) { + my $tmp; + if ($Is_MacOS) { + $tmp = (':' x ($CdLvl-$Level)) . ':'; + } + else { + $tmp = join('/',('..') x ($CdLvl-$Level)); + } + die "Can't cd to $dir_name" . $tmp + unless chdir ($tmp); + $CdLvl = $Level; + } + + if ($Is_MacOS) { + # $pdir always has a trailing ':', except for the starting dir, + # where $dir_rel eq ':' + $dir_name = "$p_dir$dir_rel"; + $dir_pref = "$dir_name:"; + } + elsif ($^O eq 'MSWin32') { + $dir_name = ($p_dir =~ m|\w:/$| ? "$p_dir$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + } + else { + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + } + + if ( $nlink == -2 ) { + $name = $dir = $p_dir; # $File::Find::name / dir + $_ = $File::Find::current_dir; + $post_process->(); # End-of-directory processing + } + elsif ( $nlink < 0 ) { # must be finddepth, report dirname now + $name = $dir_name; + if ($Is_MacOS) { + if ($dir_rel eq ':') { # must be the top dir, where we started + $name =~ s|:$||; # $File::Find::name + $p_dir = "$p_dir:" unless ($p_dir =~ /:$/); + } + $dir = $p_dir; # $File::Find::dir + $_ = ($no_chdir ? $name : $dir_rel); # $_ + } + else { + if ( substr($name,-2) eq '/.' ) { + substr($name, length($name) == 2 ? -1 : -2) = ''; + } + $dir = $p_dir; + $_ = ($no_chdir ? $dir_name : $dir_rel ); + if ( substr($_,-2) eq '/.' ) { + substr($_, length($_) == 2 ? -1 : -2) = ''; + } + } + { $wanted_callback->() }; # protect against wild "next" + } + else { + push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; + last; + } + } + } +} + + +# API: +# $wanted +# $dir_loc : absolute location of a dir +# $p_dir : "parent directory" +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir_symlnk($$$) { + my ($wanted, $dir_loc, $p_dir) = @_; # $dir_loc is the absolute directory + my @Stack; + my @filenames; + my $new_loc; + my $updir_loc = $dir_loc; # untainted parent directory + my $SE = []; + my $dir_name = $p_dir; + my $dir_pref; + my $loc_pref; + my $dir_rel = $File::Find::current_dir; + my $byd_flag; # flag for pending stack entry if $bydepth + my $tainted = 0; + my $ok = 1; + + if ($Is_MacOS) { + $dir_pref = ($p_dir =~ /:$/) ? "$p_dir" : "$p_dir:"; + $loc_pref = ($dir_loc =~ /:$/) ? "$dir_loc" : "$dir_loc:"; + } else { + $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" ); + $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" ); + } + + local ($dir, $name, $fullname, $prune, *DIR); + + unless ($no_chdir) { + # untaint the topdir + if (( $untaint ) && (is_tainted($dir_loc) )) { + ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; # parent dir, now untainted + # once untainted, $updir_loc is pushed on the stack (as parent directory); + # hence, we don't need to untaint the parent directory every time we chdir + # to it later + unless (defined $updir_loc) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; + } + else { + return; + } + } + } + $ok = chdir($updir_loc) unless ($p_dir eq $File::Find::current_dir); + unless ($ok) { + warnings::warnif "Can't cd to $updir_loc: $!\n"; + return; + } + } + + push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth; + + if ($Is_MacOS) { + $p_dir = $dir_pref; # ensure trailing ':' + } + + while (defined $SE) { + + unless ($bydepth) { + # change (back) to parent directory (always untainted) + unless ($no_chdir) { + unless (chdir $updir_loc) { + warnings::warnif "Can't cd to $updir_loc: $!\n"; + next; + } + } + $dir= $p_dir; # $File::Find::dir + $name= $dir_name; # $File::Find::name + $_= ($no_chdir ? $dir_name : $dir_rel ); # $_ + $fullname= $dir_loc; # $File::Find::fullname + # prune may happen here + $prune= 0; + lstat($_); # make sure file tests with '_' work + { $wanted_callback->() }; # protect against wild "next" + next if $prune; + } + + # change to that directory + unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { + $updir_loc = $dir_loc; + if ( ($untaint) && (($tainted) || ($tainted = is_tainted($dir_loc) )) ) { + # untaint $dir_loc, what will be pushed on the stack as (untainted) parent dir + ( $updir_loc ) = $dir_loc =~ m|$untaint_pat|; + unless (defined $updir_loc) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; + } + else { + next; + } + } + } + unless (chdir $updir_loc) { + warnings::warnif "Can't cd to $updir_loc: $!\n"; + next; + } + } + + if ($Is_MacOS) { + $dir_name = "$dir_name:" unless ($dir_name =~ /:$/); + } + + $dir = $dir_name; # $File::Find::dir + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) { + warnings::warnif "Can't opendir($dir_loc): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + + for my $FN (@filenames) { + next if $FN =~ $File::Find::skip_pattern; + + # follow symbolic links / do an lstat + $new_loc = Follow_SymLink($loc_pref.$FN); + + # ignore if invalid symlink + unless (defined $new_loc) { + if ($dangling_symlinks) { + if (ref $dangling_symlinks eq 'CODE') { + $dangling_symlinks->($FN, $dir_pref); + } else { + warnings::warnif "$dir_pref$FN is a dangling symbolic link\n"; + } + } + + $fullname = undef; + $name = $dir_pref . $FN; + $_ = ($no_chdir ? $name : $FN); + { $wanted_callback->() }; + next; + } + + if (-d _) { + push @Stack,[$new_loc,$updir_loc,$dir_name,$FN,1]; + } + else { + $fullname = $new_loc; # $File::Find::fullname + $name = $dir_pref . $FN; # $File::Find::name + $_ = ($no_chdir ? $name : $FN); # $_ + { $wanted_callback->() }; # protect against wild "next" + } + } + + } + continue { + while (defined($SE = pop @Stack)) { + ($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE; + if ($Is_MacOS) { + # $p_dir always has a trailing ':', except for the starting dir, + # where $dir_rel eq ':' + $dir_name = "$p_dir$dir_rel"; + $dir_pref = "$dir_name:"; + $loc_pref = ($dir_loc =~ /:$/) ? $dir_loc : "$dir_loc:"; + } + else { + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + $loc_pref = "$dir_loc/"; + } + if ( $byd_flag < 0 ) { # must be finddepth, report dirname now + unless ($no_chdir || ($dir_rel eq $File::Find::current_dir)) { + unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted + warnings::warnif "Can't cd to $updir_loc: $!\n"; + next; + } + } + $fullname = $dir_loc; # $File::Find::fullname + $name = $dir_name; # $File::Find::name + if ($Is_MacOS) { + if ($dir_rel eq ':') { # must be the top dir, where we started + $name =~ s|:$||; # $File::Find::name + $p_dir = "$p_dir:" unless ($p_dir =~ /:$/); + } + $dir = $p_dir; # $File::Find::dir + $_ = ($no_chdir ? $name : $dir_rel); # $_ + } + else { + if ( substr($name,-2) eq '/.' ) { + substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name + } + $dir = $p_dir; # $File::Find::dir + $_ = ($no_chdir ? $dir_name : $dir_rel); # $_ + if ( substr($_,-2) eq '/.' ) { + substr($_, length($_) == 2 ? -1 : -2) = ''; + } + } + + lstat($_); # make sure file tests with '_' work + { $wanted_callback->() }; # protect against wild "next" + } + else { + push @Stack,[$dir_loc, $updir_loc, $p_dir, $dir_rel,-1] if $bydepth; + last; + } + } + } +} + + +sub wrap_wanted { + my $wanted = shift; + if ( ref($wanted) eq 'HASH' ) { + if ( $wanted->{follow} || $wanted->{follow_fast}) { + $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; + } + if ( $wanted->{untaint} ) { + $wanted->{untaint_pattern} = $File::Find::untaint_pattern + unless defined $wanted->{untaint_pattern}; + $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; + } + return $wanted; + } + else { + return { wanted => $wanted }; + } +} + +sub find { + my $wanted = shift; + _find_opt(wrap_wanted($wanted), @_); +} + +sub finddepth { + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + _find_opt($wanted, @_); +} + +# default +$File::Find::skip_pattern = qr/^\.{1,2}\z/; +$File::Find::untaint_pattern = qr|^([-+@\w./]+)$|; + +# These are hard-coded for now, but may move to hint files. +if ($^O eq 'VMS') { + $Is_VMS = 1; + $File::Find::dont_use_nlink = 1; +} +elsif ($^O eq 'MacOS') { + $Is_MacOS = 1; + $File::Find::dont_use_nlink = 1; + $File::Find::skip_pattern = qr/^Icon\015\z/; + $File::Find::untaint_pattern = qr|^(.+)$|; +} + +# this _should_ work properly on all platforms +# where File::Find can be expected to work +$File::Find::current_dir = File::Spec->curdir || '.'; + +$File::Find::dont_use_nlink = 1 + if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' || + $^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'epoc' || $^O eq 'qnx' || + $^O eq 'nto'; + +# Set dont_use_nlink in your hint file if your system's stat doesn't +# report the number of links in a directory as an indication +# of the number of files. +# See, e.g. hints/machten.sh for MachTen 2.2. +unless ($File::Find::dont_use_nlink) { + require Config; + $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +} + +# We need a function that checks if a scalar is tainted. Either use the +# Scalar::Util module's tainted() function or our (slower) pure Perl +# fallback is_tainted_pp() +{ + local $@; + eval { require Scalar::Util }; + *is_tainted = $@ ? \&is_tainted_pp : \&Scalar::Util::tainted; +} + +1; diff --git a/Master/tlpkg/installer/perllib/File/Glob.pm b/Master/tlpkg/installer/perllib/File/Glob.pm new file mode 100644 index 00000000000..133c650529b --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Glob.pm @@ -0,0 +1,496 @@ +package File::Glob; + +use strict; +our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, + $AUTOLOAD, $DEFAULT_FLAGS); + +use XSLoader (); + +@ISA = qw(Exporter); + +# NOTE: The glob() export is only here for compatibility with 5.6.0. +# csh_glob() should not be used directly, unless you know what you're doing. + +@EXPORT_OK = qw( + csh_glob + bsd_glob + glob + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE +); + +%EXPORT_TAGS = ( + 'glob' => [ qw( + GLOB_ABEND + GLOB_ALPHASORT + GLOB_ALTDIRFUNC + GLOB_BRACE + GLOB_CSH + GLOB_ERR + GLOB_ERROR + GLOB_LIMIT + GLOB_MARK + GLOB_NOCASE + GLOB_NOCHECK + GLOB_NOMAGIC + GLOB_NOSORT + GLOB_NOSPACE + GLOB_QUOTE + GLOB_TILDE + glob + bsd_glob + ) ], +); + +$VERSION = '1.05'; + +sub import { + require Exporter; + my $i = 1; + while ($i < @_) { + if ($_[$i] =~ /^:(case|nocase|globally)$/) { + splice(@_, $i, 1); + $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case'; + $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase'; + if ($1 eq 'globally') { + local $^W; + *CORE::GLOBAL::glob = \&File::Glob::csh_glob; + } + next; + } + ++$i; + } + goto &Exporter::import; +} + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + my ($error, $val) = constant($constname); + if ($error) { + require Carp; + Carp::croak($error); + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +XSLoader::load 'File::Glob', $VERSION; + +# Preloaded methods go here. + +sub GLOB_ERROR { + return (constant('GLOB_ERROR'))[1]; +} + +sub GLOB_CSH () { + GLOB_BRACE() + | GLOB_NOMAGIC() + | GLOB_QUOTE() + | GLOB_TILDE() + | GLOB_ALPHASORT() +} + +$DEFAULT_FLAGS = GLOB_CSH(); +if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { + $DEFAULT_FLAGS |= GLOB_NOCASE(); +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +sub bsd_glob { + my ($pat,$flags) = @_; + $flags = $DEFAULT_FLAGS if @_ < 2; + return doglob($pat,$flags); +} + +# File::Glob::glob() is deprecated because its prototype is different from +# CORE::glob() (use bsd_glob() instead) +sub glob { + splice @_, 1; # don't pass PL_glob_index as flags! + goto &bsd_glob; +} + +## borrowed heavily from gsar's File::DosGlob +my %iter; +my %entries; + +sub csh_glob { + my $pat = shift; + my $cxix = shift; + my @pat; + + # glob without args defaults to $_ + $pat = $_ unless defined $pat; + + # extract patterns + $pat =~ s/^\s+//; # Protect against empty elements in + $pat =~ s/\s+$//; # things like < *.c> and <*.c >. + # These alone shouldn't trigger ParseWords. + if ($pat =~ /\s/) { + # XXX this is needed for compatibility with the csh + # implementation in Perl. Need to support a flag + # to disable this behavior. + require Text::ParseWords; + @pat = Text::ParseWords::parse_line('\s+',0,$pat); + } + + # assume global context if not provided one + $cxix = '_G_' unless defined $cxix; + $iter{$cxix} = 0 unless exists $iter{$cxix}; + + # if we're just beginning, do it all first + if ($iter{$cxix} == 0) { + if (@pat) { + $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ]; + } + else { + $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ]; + } + } + + # chuck it all out, quick or slow + if (wantarray) { + delete $iter{$cxix}; + return @{delete $entries{$cxix}}; + } + else { + if ($iter{$cxix} = scalar @{$entries{$cxix}}) { + return shift @{$entries{$cxix}}; + } + else { + # return undef for EOL + delete $iter{$cxix}; + delete $entries{$cxix}; + return undef; + } + } +} + +1; +__END__ + +=head1 NAME + +File::Glob - Perl extension for BSD glob routine + +=head1 SYNOPSIS + + use File::Glob ':glob'; + + @list = bsd_glob('*.[ch]'); + $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR); + + if (GLOB_ERROR) { + # an error occurred reading $homedir + } + + ## override the core glob (CORE::glob() does this automatically + ## by default anyway, since v5.6.0) + use File::Glob ':globally'; + my @sources = <*.{c,h,y}>; + + ## override the core glob, forcing case sensitivity + use File::Glob qw(:globally :case); + my @sources = <*.{c,h,y}>; + + ## override the core glob forcing case insensitivity + use File::Glob qw(:globally :nocase); + my @sources = <*.{c,h,y}>; + + ## glob on all files in home directory + use File::Glob ':globally'; + my @sources = <~gnat/*>; + +=head1 DESCRIPTION + +The glob angle-bracket operator C<< <> >> is a pathname generator that +implements the rules for file name pattern matching used by Unix-like shells +such as the Bourne shell or C shell. + +File::Glob::bsd_glob() implements the FreeBSD glob(3) routine, which is +a superset of the POSIX glob() (described in IEEE Std 1003.2 "POSIX.2"). +bsd_glob() takes a mandatory C<pattern> argument, and an optional +C<flags> argument, and returns a list of filenames matching the +pattern, with interpretation of the pattern modified by the C<flags> +variable. + +Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob(). +Note that they don't share the same prototype--CORE::glob() only accepts +a single argument. Due to historical reasons, CORE::glob() will also +split its argument on whitespace, treating it as multiple patterns, +whereas bsd_glob() considers them as one pattern. + +=head2 META CHARACTERS + + \ Quote the next metacharacter + [] Character class + {} Multiple pattern + * Match any string of characters + ? Match any single character + ~ User name home directory + +The metanotation C<a{b,c,d}e> is a shorthand for C<abe ace ade>. Left to +right order is preserved, with results of matches being sorted separately +at a low level to preserve this order. As a special case C<{>, C<}>, and +C<{}> are passed undisturbed. + +=head2 POSIX FLAGS + +The POSIX defined flags for bsd_glob() are: + +=over 4 + +=item C<GLOB_ERR> + +Force bsd_glob() to return an error when it encounters a directory it +cannot open or read. Ordinarily bsd_glob() continues to find matches. + +=item C<GLOB_LIMIT> + +Make bsd_glob() return an error (GLOB_NOSPACE) when the pattern expands +to a size bigger than the system constant C<ARG_MAX> (usually found in +limits.h). If your system does not define this constant, bsd_glob() uses +C<sysconf(_SC_ARG_MAX)> or C<_POSIX_ARG_MAX> where available (in that +order). You can inspect these values using the standard C<POSIX> +extension. + +=item C<GLOB_MARK> + +Each pathname that is a directory that matches the pattern has a slash +appended. + +=item C<GLOB_NOCASE> + +By default, file names are assumed to be case sensitive; this flag +makes bsd_glob() treat case differences as not significant. + +=item C<GLOB_NOCHECK> + +If the pattern does not match any pathname, then bsd_glob() returns a list +consisting of only the pattern. If C<GLOB_QUOTE> is set, its effect +is present in the pattern returned. + +=item C<GLOB_NOSORT> + +By default, the pathnames are sorted in ascending ASCII order; this +flag prevents that sorting (speeding up bsd_glob()). + +=back + +The FreeBSD extensions to the POSIX standard are the following flags: + +=over 4 + +=item C<GLOB_BRACE> + +Pre-process the string to expand C<{pat,pat,...}> strings like csh(1). +The pattern '{}' is left unexpanded for historical reasons (and csh(1) +does the same thing to ease typing of find(1) patterns). + +=item C<GLOB_NOMAGIC> + +Same as C<GLOB_NOCHECK> but it only returns the pattern if it does not +contain any of the special characters "*", "?" or "[". C<NOMAGIC> is +provided to simplify implementing the historic csh(1) globbing +behaviour and should probably not be used anywhere else. + +=item C<GLOB_QUOTE> + +Use the backslash ('\') character for quoting: every occurrence of a +backslash followed by a character in the pattern is replaced by that +character, avoiding any special interpretation of the character. +(But see below for exceptions on DOSISH systems). + +=item C<GLOB_TILDE> + +Expand patterns that start with '~' to user name home directories. + +=item C<GLOB_CSH> + +For convenience, C<GLOB_CSH> is a synonym for +C<GLOB_BRACE | GLOB_NOMAGIC | GLOB_QUOTE | GLOB_TILDE | GLOB_ALPHASORT>. + +=back + +The POSIX provided C<GLOB_APPEND>, C<GLOB_DOOFFS>, and the FreeBSD +extensions C<GLOB_ALTDIRFUNC>, and C<GLOB_MAGCHAR> flags have not been +implemented in the Perl version because they involve more complex +interaction with the underlying C structures. + +The following flag has been added in the Perl implementation for +csh compatibility: + +=over 4 + +=item C<GLOB_ALPHASORT> + +If C<GLOB_NOSORT> is not in effect, sort filenames is alphabetical +order (case does not matter) rather than in ASCII order. + +=back + +=head1 DIAGNOSTICS + +bsd_glob() returns a list of matching paths, possibly zero length. If an +error occurred, &File::Glob::GLOB_ERROR will be non-zero and C<$!> will be +set. &File::Glob::GLOB_ERROR is guaranteed to be zero if no error occurred, +or one of the following values otherwise: + +=over 4 + +=item C<GLOB_NOSPACE> + +An attempt to allocate memory failed. + +=item C<GLOB_ABEND> + +The glob was stopped because an error was encountered. + +=back + +In the case where bsd_glob() has found some matching paths, but is +interrupted by an error, it will return a list of filenames B<and> +set &File::Glob::ERROR. + +Note that bsd_glob() deviates from POSIX and FreeBSD glob(3) behaviour +by not considering C<ENOENT> and C<ENOTDIR> as errors - bsd_glob() will +continue processing despite those errors, unless the C<GLOB_ERR> flag is +set. + +Be aware that all filenames returned from File::Glob are tainted. + +=head1 NOTES + +=over 4 + +=item * + +If you want to use multiple patterns, e.g. C<bsd_glob("a* b*")>, you should +probably throw them in a set as in C<bsd_glob("{a*,b*}")>. This is because +the argument to bsd_glob() isn't subjected to parsing by the C shell. +Remember that you can use a backslash to escape things. + +=item * + +On DOSISH systems, backslash is a valid directory separator character. +In this case, use of backslash as a quoting character (via GLOB_QUOTE) +interferes with the use of backslash as a directory separator. The +best (simplest, most portable) solution is to use forward slashes for +directory separators, and backslashes for quoting. However, this does +not match "normal practice" on these systems. As a concession to user +expectation, therefore, backslashes (under GLOB_QUOTE) only quote the +glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself. +All other backslashes are passed through unchanged. + +=item * + +Win32 users should use the real slash. If you really want to use +backslashes, consider using Sarathy's File::DosGlob, which comes with +the standard Perl distribution. + +=item * + +Mac OS (Classic) users should note a few differences. Since +Mac OS is not Unix, when the glob code encounters a tilde glob (e.g. +~user) and the C<GLOB_TILDE> flag is used, it simply returns that +pattern without doing any expansion. + +Glob on Mac OS is case-insensitive by default (if you don't use any +flags). If you specify any flags at all and still want glob +to be case-insensitive, you must include C<GLOB_NOCASE> in the flags. + +The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users +should be careful about specifying relative pathnames. While a full path +always begins with a volume name, a relative pathname should always +begin with a ':'. If specifying a volume name only, a trailing ':' is +required. + +The specification of pathnames in glob patterns adheres to the usual Mac +OS conventions: The path separator is a colon ':', not a slash '/'. A +full path always begins with a volume name. A relative pathname on Mac +OS must always begin with a ':', except when specifying a file or +directory name in the current working directory, where the leading colon +is optional. If specifying a volume name only, a trailing ':' is +required. Due to these rules, a glob like E<lt>*:E<gt> will find all +mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find +all files and directories in the current directory. + +Note that updirs in the glob pattern are resolved before the matching begins, +i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also, +that a single trailing ':' in the pattern is ignored (unless it's a volume +name pattern like "*HD:"), i.e. a glob like E<lt>:*:E<gt> will find both +directories I<and> files (and not, as one might expect, only directories). +You can, however, use the C<GLOB_MARK> flag to distinguish (without a file +test) directory names from file names. + +If the C<GLOB_MARK> flag is set, all directory paths will have a ':' appended. +Since a directory like 'lib:' is I<not> a valid I<relative> path on Mac OS, +both a leading and a trailing colon will be added, when the directory name in +question doesn't contain any colons (e.g. 'lib' becomes ':lib:'). + +=back + +=head1 SEE ALSO + +L<perlfunc/glob>, glob(3) + +=head1 AUTHOR + +The Perl interface was written by Nathan Torkington E<lt>gnat@frii.comE<gt>, +and is released under the artistic license. Further modifications were +made by Greg Bacon E<lt>gbacon@cs.uah.eduE<gt>, Gurusamy Sarathy +E<lt>gsar@activestate.comE<gt>, and Thomas Wegner +E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the +following copyright: + + Copyright (c) 1989, 1993 The Regents of the University of California. + All rights reserved. + + This code is derived from software contributed to Berkeley by + Guido van Rossum. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND + ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE + FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS + OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) + HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT + LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY + OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF + SUCH DAMAGE. + +=cut diff --git a/Master/tlpkg/installer/perllib/File/Path.pm b/Master/tlpkg/installer/perllib/File/Path.pm new file mode 100644 index 00000000000..2e41ff3f77f --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Path.pm @@ -0,0 +1,285 @@ +package File::Path; + +=head1 NAME + +File::Path - create or remove directory trees + +=head1 SYNOPSIS + + use File::Path; + + mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); + rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); + +=head1 DESCRIPTION + +The C<mkpath> function provides a convenient way to create directories, even +if your C<mkdir> kernel call won't create more than one level of directory at +a time. C<mkpath> takes three arguments: + +=over 4 + +=item * + +the name of the path to create, or a reference +to a list of paths to create, + +=item * + +a boolean value, which if TRUE will cause C<mkpath> +to print the name of each directory as it is created +(defaults to FALSE), and + +=item * + +the numeric mode to use when creating the directories +(defaults to 0777), to be modified by the current umask. + +=back + +It returns a list of all directories (including intermediates, determined +using the Unix '/' separator) created. + +If a system error prevents a directory from being created, then the +C<mkpath> function throws a fatal error with C<Carp::croak>. This error +can be trapped with an C<eval> block: + + eval { mkpath($dir) }; + if ($@) { + print "Couldn't create $dir: $@"; + } + +Similarly, the C<rmtree> function provides a convenient way to delete a +subtree from the directory structure, much like the Unix command C<rm -r>. +C<rmtree> takes three arguments: + +=over 4 + +=item * + +the root of the subtree to delete, or a reference to +a list of roots. All of the files and directories +below each root, as well as the roots themselves, +will be deleted. + +=item * + +a boolean value, which if TRUE will cause C<rmtree> to +print a message each time it examines a file, giving the +name of the file, and indicating whether it's using C<rmdir> +or C<unlink> to remove it, or that it's skipping it. +(defaults to FALSE) + +=item * + +a boolean value, which if TRUE will cause C<rmtree> to +skip any files to which you do not have delete access +(if running under VMS) or write access (if running +under another OS). This will change in the future when +a criterion for 'delete permission' under OSs other +than VMS is settled. (defaults to FALSE) + +=back + +It returns the number of files successfully deleted. Symlinks are +simply deleted and not followed. + +B<NOTE:> There are race conditions internal to the implementation of +C<rmtree> making it unsafe to use on directory trees which may be +altered or moved while C<rmtree> is running, and in particular on any +directory trees with any path components or subdirectories potentially +writable by untrusted users. + +Additionally, if the third parameter is not TRUE and C<rmtree> is +interrupted, it may leave files and directories with permissions altered +to allow deletion (and older versions of this module would even set +files and directories to world-read/writable!) + +Note also that the occurrence of errors in C<rmtree> can be determined I<only> +by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent +from the return value. + +=head1 DIAGNOSTICS + +=over 4 + +=item * + +On Windows, if C<mkpath> gives you the warning: B<No such file or +directory>, this may mean that you've exceeded your filesystem's +maximum path length. + +=back + +=head1 AUTHORS + +Tim Bunce <F<Tim.Bunce@ig.co.uk>> and +Charles Bailey <F<bailey@newman.upenn.edu>> + +=cut + +use 5.006; +use Carp; +use File::Basename (); +use Exporter (); +use strict; +use warnings; + +our $VERSION = "1.08"; +our @ISA = qw( Exporter ); +our @EXPORT = qw( mkpath rmtree ); + +my $Is_VMS = $^O eq 'VMS'; +my $Is_MacOS = $^O eq 'MacOS'; + +# These OSes complain if you want to remove a file that you have no +# write permission to: +my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || + $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc'); + +sub mkpath { + my($paths, $verbose, $mode) = @_; + # $paths -- either a path string or ref to list of paths + # $verbose -- optional print "mkdir $path" for each directory created + # $mode -- optional permissions, defaults to 0777 + local($")=$Is_MacOS ? ":" : "/"; + $mode = 0777 unless defined($mode); + $paths = [$paths] unless ref $paths; + my(@created,$path); + foreach $path (@$paths) { + $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT + # Logic wants Unix paths, so go with the flow. + if ($Is_VMS) { + next if $path eq '/'; + $path = VMS::Filespec::unixify($path); + if ($path =~ m:^(/[^/]+)/?\z:) { + $path = $1.'/000000'; + } + } + next if -d $path; + my $parent = File::Basename::dirname($path); + unless (-d $parent or $path eq $parent) { + push(@created,mkpath($parent, $verbose, $mode)); + } + print "mkdir $path\n" if $verbose; + unless (mkdir($path,$mode)) { + my $e = $!; + # allow for another process to have created it meanwhile + $! = $e, croak ("mkdir $path: $e") unless -d $path; + } + push(@created, $path); + } + @created; +} + +sub rmtree { + my($roots, $verbose, $safe) = @_; + my(@files); + my($count) = 0; + $verbose ||= 0; + $safe ||= 0; + + if ( defined($roots) && length($roots) ) { + $roots = [$roots] unless ref $roots; + } + else { + carp "No root path(s) specified\n"; + return 0; + } + + my($root); + foreach $root (@{$roots}) { + if ($Is_MacOS) { + $root = ":$root" if $root !~ /:/; + $root =~ s#([^:])\z#$1:#; + } else { + $root =~ s#/\z##; + } + (undef, undef, my $rp) = lstat $root or next; + $rp &= 07777; # don't forget setuid, setgid, sticky bits + if ( -d _ ) { + # notabene: 0700 is for making readable in the first place, + # it's also intended to change it to writable in case we have + # to recurse in which case we are better than rm -rf for + # subtrees with strange permissions + chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or carp "Can't make directory $root read+writeable: $!" + unless $safe; + + if (opendir my $d, $root) { + no strict 'refs'; + if (!defined ${"\cTAINT"} or ${"\cTAINT"}) { + # Blindly untaint dir names + @files = map { /^(.*)$/s ; $1 } readdir $d; + } else { + @files = readdir $d; + } + closedir $d; + } + else { + carp "Can't read $root: $!"; + @files = (); + } + + # Deleting large numbers of files from VMS Files-11 filesystems + # is faster if done in reverse ASCIIbetical order + @files = reverse @files if $Is_VMS; + ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; + if ($Is_MacOS) { + @files = map("$root$_", @files); + } else { + @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); + } + $count += rmtree(\@files,$verbose,$safe); + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped $root\n" if $verbose; + next; + } + chmod $rp | 0700, $root + or carp "Can't make directory $root writeable: $!" + if $force_writeable; + print "rmdir $root\n" if $verbose; + if (rmdir $root) { + ++$count; + } + else { + carp "Can't remove directory $root: $!"; + chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or carp("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + } + else { + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) + : !(-l $root || -w $root))) + { + print "skipped $root\n" if $verbose; + next; + } + chmod $rp | 0600, $root + or carp "Can't make file $root writeable: $!" + if $force_writeable; + print "unlink $root\n" if $verbose; + # delete all versions under VMS + for (;;) { + unless (unlink $root) { + carp "Can't unlink file $root: $!"; + if ($force_writeable) { + chmod $rp, $root + or carp("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + last; + } + ++$count; + last unless $Is_VMS && lstat $root; + } + } + } + + $count; +} + +1; diff --git a/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm b/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm new file mode 100644 index 00000000000..19a2937c6b9 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Spec/Cygwin.pm @@ -0,0 +1,93 @@ +package File::Spec::Cygwin; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '1.1'; + +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Cygwin - methods for Cygwin file specs + +=head1 SYNOPSIS + + require File::Spec::Cygwin; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +This module is still in beta. Cygwin-knowledgeable folks are invited +to offer patches and suggestions. + +=cut + +=pod + +=over 4 + +=item canonpath + +Any C<\> (backslashes) are converted to C</> (forward slashes), +and then File::Spec::Unix canonpath() is called on the result. + +=cut + +sub canonpath { + my($self,$path) = @_; + $path =~ s|\\|/|g; + return $self->SUPER::canonpath($path); +} + +=pod + +=item file_name_is_absolute + +True is returned if the file name begins with C<drive_letter:>, +and if not, File::Spec::Unix file_name_is_absolute() is called. + +=cut + + +sub file_name_is_absolute { + my ($self,$file) = @_; + return 1 if $file =~ m{^([a-z]:)?[\\/]}is; # C:/test + return $self->SUPER::file_name_is_absolute($file); +} + +=item tmpdir (override) + +Returns a string representation of the first existing directory +from the following list: + + $ENV{TMPDIR} + /tmp + C:/temp + +Since Perl 5.8.0, if running under taint mode, and if the environment +variables are tainted, they are not used. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp", 'C:/temp' ); +} + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; diff --git a/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm b/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm new file mode 100644 index 00000000000..a7168f9e494 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Spec/Epoc.pm @@ -0,0 +1,77 @@ +package File::Spec::Epoc; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = '1.1'; + +require File::Spec::Unix; +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Epoc - methods for Epoc file specs + +=head1 SYNOPSIS + + require File::Spec::Epoc; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +This package is still work in progress ;-) + +=cut + +sub case_tolerant { + return 1; +} + +=pod + +=over 4 + +=item canonpath() + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=back + +=cut + +sub canonpath { + my ($self,$path) = @_; + + $path =~ s|/+|/|g; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx + $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx + return $path; +} + +=pod + +=head1 AUTHOR + +o.flebbe@gmx.de + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/Master/tlpkg/installer/perllib/File/Spec/Functions.pm b/Master/tlpkg/installer/perllib/File/Spec/Functions.pm new file mode 100644 index 00000000000..38c898c5d8f --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Spec/Functions.pm @@ -0,0 +1,109 @@ +package File::Spec::Functions; + +use File::Spec; +use strict; + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); + +$VERSION = '1.3'; + +require Exporter; + +@ISA = qw(Exporter); + +@EXPORT = qw( + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path +); + +@EXPORT_OK = qw( + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs + case_tolerant +); + +%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); + +foreach my $meth (@EXPORT, @EXPORT_OK) { + my $sub = File::Spec->can($meth); + no strict 'refs'; + *{$meth} = sub {&$sub('File::Spec', @_)}; +} + + +1; +__END__ + +=head1 NAME + +File::Spec::Functions - portably perform operations on file names + +=head1 SYNOPSIS + + use File::Spec::Functions; + $x = catfile('a','b'); + +=head1 DESCRIPTION + +This module exports convenience functions for all of the class methods +provided by File::Spec. + +For a reference of available functions, please consult L<File::Spec::Unix>, +which contains the entire set, and which is inherited by the modules for +other platforms. For further information, please see L<File::Spec::Mac>, +L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>. + +=head2 Exports + +The following functions are exported by default. + + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path + + +The following functions are exported only by request. + + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs + case_tolerant + +All the functions may be imported using the C<:ALL> tag. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, +File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker + +=cut + diff --git a/Master/tlpkg/installer/perllib/File/Spec/Mac.pm b/Master/tlpkg/installer/perllib/File/Spec/Mac.pm new file mode 100644 index 00000000000..8b51bd6c249 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Spec/Mac.pm @@ -0,0 +1,780 @@ +package File::Spec::Mac; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '1.4'; + +@ISA = qw(File::Spec::Unix); + +my $macfiles; +if ($^O eq 'MacOS') { + $macfiles = eval { require Mac::Files }; +} + +sub case_tolerant { 1 } + + +=head1 NAME + +File::Spec::Mac - File::Spec for Mac OS (Classic) + +=head1 SYNOPSIS + + require File::Spec::Mac; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +Methods for manipulating file specifications. + +=head1 METHODS + +=over 2 + +=item canonpath + +On Mac OS, there's nothing to be done. Returns what it's given. + +=cut + +sub canonpath { + my ($self,$path) = @_; + return $path; +} + +=item catdir() + +Concatenate two or more directory names to form a path separated by colons +(":") ending with a directory. Resulting paths are B<relative> by default, +but can be forced to be absolute (but avoid this, see below). Automatically +puts a trailing ":" on the end of the complete path, because that's what's +done in MacPerl's environment and helps to distinguish a file path from a +directory path. + +B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the resulting +path is relative by default and I<not> absolute. This decision was made due +to portability reasons. Since C<File::Spec-E<gt>catdir()> returns relative paths +on all other operating systems, it will now also follow this convention on Mac +OS. Note that this may break some existing scripts. + +The intended purpose of this routine is to concatenate I<directory names>. +But because of the nature of Macintosh paths, some additional possibilities +are allowed to make using this routine give reasonable results for some +common situations. In other words, you are also allowed to concatenate +I<paths> instead of directory names (strictly speaking, a string like ":a" +is a path, but not a name, since it contains a punctuation character ":"). + +So, beside calls like + + catdir("a") = ":a:" + catdir("a","b") = ":a:b:" + catdir() = "" (special case) + +calls like the following + + catdir(":a:") = ":a:" + catdir(":a","b") = ":a:b:" + catdir(":a:","b") = ":a:b:" + catdir(":a:",":b:") = ":a:b:" + catdir(":") = ":" + +are allowed. + +Here are the rules that are used in C<catdir()>; note that we try to be as +compatible as possible to Unix: + +=over 2 + +=item 1. + +The resulting path is relative by default, i.e. the resulting path will have a +leading colon. + +=item 2. + +A trailing colon is added automatically to the resulting path, to denote a +directory. + +=item 3. + +Generally, each argument has one leading ":" and one trailing ":" +removed (if any). They are then joined together by a ":". Special +treatment applies for arguments denoting updir paths like "::lib:", +see (4), or arguments consisting solely of colons ("colon paths"), +see (5). + +=item 4. + +When an updir path like ":::lib::" is passed as argument, the number +of directories to climb up is handled correctly, not removing leading +or trailing colons when necessary. E.g. + + catdir(":::a","::b","c") = ":::a::b:c:" + catdir(":::a::","::b","c") = ":::a:::b:c:" + +=item 5. + +Adding a colon ":" or empty string "" to a path at I<any> position +doesn't alter the path, i.e. these arguments are ignored. (When a "" +is passed as the first argument, it has a special meaning, see +(6)). This way, a colon ":" is handled like a "." (curdir) on Unix, +while an empty string "" is generally ignored (see +C<Unix-E<gt>canonpath()> ). Likewise, a "::" is handled like a ".." +(updir), and a ":::" is handled like a "../.." etc. E.g. + + catdir("a",":",":","b") = ":a:b:" + catdir("a",":","::",":b") = ":a::b:" + +=item 6. + +If the first argument is an empty string "" or is a volume name, i.e. matches +the pattern /^[^:]+:/, the resulting path is B<absolute>. + +=item 7. + +Passing an empty string "" as the first argument to C<catdir()> is +like passingC<File::Spec-E<gt>rootdir()> as the first argument, i.e. + + catdir("","a","b") is the same as + + catdir(rootdir(),"a","b"). + +This is true on Unix, where C<catdir("","a","b")> yields "/a/b" and +C<rootdir()> is "/". Note that C<rootdir()> on Mac OS is the startup +volume, which is the closest in concept to Unix' "/". This should help +to run existing scripts originally written for Unix. + +=item 8. + +For absolute paths, some cleanup is done, to ensure that the volume +name isn't immediately followed by updirs. This is invalid, because +this would go beyond "root". Generally, these cases are handled like +their Unix counterparts: + + Unix: + Unix->catdir("","") = "/" + Unix->catdir("",".") = "/" + Unix->catdir("","..") = "/" # can't go beyond root + Unix->catdir("",".","..","..","a") = "/a" + Mac: + Mac->catdir("","") = rootdir() # (e.g. "HD:") + Mac->catdir("",":") = rootdir() + Mac->catdir("","::") = rootdir() # can't go beyond root + Mac->catdir("",":","::","::","a") = rootdir() . "a:" # (e.g. "HD:a:") + +However, this approach is limited to the first arguments following +"root" (again, see C<Unix-E<gt>canonpath()> ). If there are more +arguments that move up the directory tree, an invalid path going +beyond root can be created. + +=back + +As you've seen, you can force C<catdir()> to create an absolute path +by passing either an empty string or a path that begins with a volume +name as the first argument. However, you are strongly encouraged not +to do so, since this is done only for backward compatibility. Newer +versions of File::Spec come with a method called C<catpath()> (see +below), that is designed to offer a portable solution for the creation +of absolute paths. It takes volume, directory and file portions and +returns an entire path. While C<catdir()> is still suitable for the +concatenation of I<directory names>, you are encouraged to use +C<catpath()> to concatenate I<volume names> and I<directory +paths>. E.g. + + $dir = File::Spec->catdir("tmp","sources"); + $abs_path = File::Spec->catpath("MacintoshHD:", $dir,""); + +yields + + "MacintoshHD:tmp:sources:" . + +=cut + +sub catdir { + my $self = shift; + return '' unless @_; + my @args = @_; + my $first_arg; + my $relative; + + # take care of the first argument + + if ($args[0] eq '') { # absolute path, rootdir + shift @args; + $relative = 0; + $first_arg = $self->rootdir; + + } elsif ($args[0] =~ /^[^:]+:/) { # absolute path, volume name + $relative = 0; + $first_arg = shift @args; + # add a trailing ':' if need be (may be it's a path like HD:dir) + $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/); + + } else { # relative path + $relative = 1; + if ( $args[0] =~ /^::+\Z(?!\n)/ ) { + # updir colon path ('::', ':::' etc.), don't shift + $first_arg = ':'; + } elsif ($args[0] eq ':') { + $first_arg = shift @args; + } else { + # add a trailing ':' if need be + $first_arg = shift @args; + $first_arg = "$first_arg:" unless ($first_arg =~ /:\Z(?!\n)/); + } + } + + # For all other arguments, + # (a) ignore arguments that equal ':' or '', + # (b) handle updir paths specially: + # '::' -> concatenate '::' + # '::' . '::' -> concatenate ':::' etc. + # (c) add a trailing ':' if need be + + my $result = $first_arg; + while (@args) { + my $arg = shift @args; + unless (($arg eq '') || ($arg eq ':')) { + if ($arg =~ /^::+\Z(?!\n)/ ) { # updir colon path like ':::' + my $updir_count = length($arg) - 1; + while ((@args) && ($args[0] =~ /^::+\Z(?!\n)/) ) { # while updir colon path + $arg = shift @args; + $updir_count += (length($arg) - 1); + } + $arg = (':' x $updir_count); + } else { + $arg =~ s/^://s; # remove a leading ':' if any + $arg = "$arg:" unless ($arg =~ /:\Z(?!\n)/); # ensure trailing ':' + } + $result .= $arg; + }#unless + } + + if ( ($relative) && ($result !~ /^:/) ) { + # add a leading colon if need be + $result = ":$result"; + } + + unless ($relative) { + # remove updirs immediately following the volume name + $result =~ s/([^:]+:)(:*)(.*)\Z(?!\n)/$1$3/; + } + + return $result; +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename. Resulting paths are B<relative> +by default, but can be forced to be absolute (but avoid this). + +B<IMPORTANT NOTE:> Beginning with version 1.3 of this module, the +resulting path is relative by default and I<not> absolute. This +decision was made due to portability reasons. Since +C<File::Spec-E<gt>catfile()> returns relative paths on all other +operating systems, it will now also follow this convention on Mac OS. +Note that this may break some existing scripts. + +The last argument is always considered to be the file portion. Since +C<catfile()> uses C<catdir()> (see above) for the concatenation of the +directory portions (if any), the following with regard to relative and +absolute paths is true: + + catfile("") = "" + catfile("file") = "file" + +but + + catfile("","") = rootdir() # (e.g. "HD:") + catfile("","file") = rootdir() . file # (e.g. "HD:file") + catfile("HD:","file") = "HD:file" + +This means that C<catdir()> is called only when there are two or more +arguments, as one might expect. + +Note that the leading ":" is removed from the filename, so that + + catfile("a","b","file") = ":a:b:file" and + + catfile("a","b",":file") = ":a:b:file" + +give the same answer. + +To concatenate I<volume names>, I<directory paths> and I<filenames>, +you are encouraged to use C<catpath()> (see below). + +=cut + +sub catfile { + my $self = shift; + return '' unless @_; + my $file = pop @_; + return $file unless @_; + my $dir = $self->catdir(@_); + $file =~ s/^://s; + return $dir.$file; +} + +=item curdir + +Returns a string representing the current directory. On Mac OS, this is ":". + +=cut + +sub curdir { + return ":"; +} + +=item devnull + +Returns a string representing the null device. On Mac OS, this is "Dev:Null". + +=cut + +sub devnull { + return "Dev:Null"; +} + +=item rootdir + +Returns a string representing the root directory. Under MacPerl, +returns the name of the startup volume, since that's the closest in +concept, although other volumes aren't rooted there. The name has a +trailing ":", because that's the correct specification for a volume +name on Mac OS. + +If Mac::Files could not be loaded, the empty string is returned. + +=cut + +sub rootdir { +# +# There's no real root directory on Mac OS. The name of the startup +# volume is returned, since that's the closest in concept. +# + return '' unless $macfiles; + my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, + &Mac::Files::kSystemFolderType); + $system =~ s/:.*\Z(?!\n)/:/s; + return $system; +} + +=item tmpdir + +Returns the contents of $ENV{TMPDIR}, if that directory exits or the +current working directory otherwise. Under MacPerl, $ENV{TMPDIR} will +contain a path like "MacintoshHD:Temporary Items:", which is a hidden +directory on your startup volume. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR} ); +} + +=item updir + +Returns a string representing the parent directory. On Mac OS, this is "::". + +=cut + +sub updir { + return "::"; +} + +=item file_name_is_absolute + +Takes as argument a path and returns true, if it is an absolute path. +If the path has a leading ":", it's a relative path. Otherwise, it's an +absolute path, unless the path doesn't contain any colons, i.e. it's a name +like "a". In this particular case, the path is considered to be relative +(i.e. it is considered to be a filename). Use ":" in the appropriate place +in the path if you want to distinguish unambiguously. As a special case, +the filename '' is always considered to be absolute. Note that with version +1.2 of File::Spec::Mac, this does no longer consult the local filesystem. + +E.g. + + File::Spec->file_name_is_absolute("a"); # false (relative) + File::Spec->file_name_is_absolute(":a:b:"); # false (relative) + File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute) + File::Spec->file_name_is_absolute(""); # true (absolute) + + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + if ($file =~ /:/) { + return (! ($file =~ m/^:/s) ); + } elsif ( $file eq '' ) { + return 1 ; + } else { + return 0; # i.e. a file like "a" + } +} + +=item path + +Returns the null list for the MacPerl application, since the concept is +usually meaningless under Mac OS. But if you're using the MacPerl tool under +MPW, it gives back $ENV{Commands} suitably split, as is done in +:lib:ExtUtils:MM_Mac.pm. + +=cut + +sub path { +# +# The concept is meaningless under the MacPerl application. +# Under MPW, it has a meaning. +# + return unless exists $ENV{Commands}; + return split(/,/, $ENV{Commands}); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path into volume, directory, and filename portions. + +On Mac OS, assumes that the last part of the path is a filename unless +$no_file is true or a trailing separator ":" is present. + +The volume portion is always returned with a trailing ":". The directory portion +is always returned with a leading (to denote a relative path) and a trailing ":" +(to denote a directory). The file portion is always returned I<without> a leading ":". +Empty portions are returned as empty string ''. + +The results can be passed to C<catpath()> to get back a path equivalent to +(usually identical to) the original path. + + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file); + + if ( $nofile ) { + ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s; + } + else { + $path =~ + m|^( (?: [^:]+: )? ) + ( (?: .*: )? ) + ( .* ) + |xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + $volume = '' unless defined($volume); + $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir" + if ($directory) { + # Make sure non-empty directories begin and end in ':' + $directory .= ':' unless (substr($directory,-1) eq ':'); + $directory = ":$directory" unless (substr($directory,0,1) eq ':'); + } else { + $directory = ''; + } + $file = '' unless defined($file); + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of C<catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories should be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. Consider using C<splitpath()> otherwise. + +Unlike just splitting the directories on the separator, empty directory names +(C<"">) can be returned. Since C<catdir()> on Mac OS always appends a trailing +colon to distinguish a directory path from a file path, a single trailing colon +will be ignored, i.e. there's no empty directory name after it. + +Hence, on Mac OS, both + + File::Spec->splitdir( ":a:b::c:" ); and + File::Spec->splitdir( ":a:b::c" ); + +yield: + + ( "a", "b", "::", "c") + +while + + File::Spec->splitdir( ":a:b::c::" ); + +yields: + + ( "a", "b", "::", "c", "::") + + +=cut + +sub splitdir { + my ($self, $path) = @_; + my @result = (); + my ($head, $sep, $tail, $volume, $directories); + + return ('') if ( (!defined($path)) || ($path eq '') ); + return (':') if ($path eq ':'); + + ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s; + + # deprecated, but handle it correctly + if ($volume) { + push (@result, $volume); + $sep .= ':'; + } + + while ($sep || $directories) { + if (length($sep) > 1) { + my $updir_count = length($sep) - 1; + for (my $i=0; $i<$updir_count; $i++) { + # push '::' updir_count times; + # simulate Unix '..' updirs + push (@result, '::'); + } + } + $sep = ''; + if ($directories) { + ( $head, $sep, $tail ) = $directories =~ m|^((?:[^:]+)?)(:*)(.*)|s; + push (@result, $head); + $directories = $tail; + } + } + return @result; +} + + +=item catpath + + $path = File::Spec->catpath($volume,$directory,$file); + +Takes volume, directory and file portions and returns an entire path. On Mac OS, +$volume, $directory and $file are concatenated. A ':' is inserted if need be. You +may pass an empty string for each portion. If all portions are empty, the empty +string is returned. If $volume is empty, the result will be a relative path, +beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any) +is removed form $file and the remainder is returned. If $file is empty, the +resulting path will have a trailing ':'. + + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( (! $volume) && (! $directory) ) { + $file =~ s/^:// if $file; + return $file ; + } + + # We look for a volume in $volume, then in $directory, but not both + + my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1); + + $volume = $dir_volume unless length $volume; + my $path = $volume; # may be '' + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' + + if ($directory) { + $directory = $dir_dirs if $volume; + $directory =~ s/^://; # remove leading ':' if any + $path .= $directory; + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' + } + + if ($file) { + $file =~ s/^://; # remove leading ':' if any + $path .= $file; + } + + return $path; +} + +=item abs2rel + +Takes a destination path and an optional base path and returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then the current working directory is used. +If $base is relative, then it is converted to absolute form using C<rel2abs()>. +This means that it is taken to be relative to the current working directory. + +If $path and $base appear to be on two different volumes, we will not +attempt to resolve the two paths, and we will instead simply return +$path. Note that previous versions of this module ignored the volume +of $base, which resulted in garbage results part of the time. + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored. Otherwise all path +components are assumed to be directories. + +If $path is relative, it is converted to absolute form using C<rel2abs()>. +This means that it is taken to be relative to the current working directory. + +Based on code written by Shigio Yamaguchi. + + +=cut + +# maybe this should be done in canonpath() ? +sub _resolve_updirs { + my $path = shift @_; + my $proceed; + + # resolve any updirs, e.g. "HD:tmp::file" -> "HD:file" + do { + $proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); + } while ($proceed); + + return $path; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + $base = _resolve_updirs( $base ); # resolve updirs in $base + } + else { + $base = _resolve_updirs( $base ); + } + + # Split up paths - ignore $base's file + my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path ); + my ( $base_vol, $base_dirs ) = $self->splitpath( $base ); + + return $path unless lc( $path_vol ) eq lc( $base_vol ); + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_dirs ); + my @basechunks = $self->splitdir( $base_dirs ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @pathchunks now has the directories to descend in to. + # ensure relative path, even if @pathchunks is empty + $path_dirs = $self->catdir( ':', @pathchunks ); + + # @basechunks now contains the number of directories to climb out of. + $base_dirs = (':' x @basechunks) . ':' ; + + return $self->catpath( '', $self->catdir( $base_dirs, $path_dirs ), $path_file ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path: + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then $base is set to the current working +directory. If $base is relative, then it is converted to absolute form +using C<rel2abs()>. This means that it is taken to be relative to the +current working directory. + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored. Otherwise all path +components are assumed to be directories. + +If $path is already absolute, it is returned and $base is ignored. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub rel2abs { + my ($self,$path,$base) = @_; + + if ( ! $self->file_name_is_absolute($path) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute($base) ) { + $base = $self->rel2abs($base) ; + } + + # Split up paths + + # igonore $path's volume + my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ; + + # ignore $base's file part + my ( $base_vol, $base_dirs ) = $self->splitpath($base) ; + + # Glom them together + $path_dirs = ':' if ($path_dirs eq ''); + $base_dirs =~ s/:$//; # remove trailing ':', if any + $base_dirs = $base_dirs . $path_dirs; + + $path = $self->catpath( $base_vol, $base_dirs, $path_file ); + } + return $path; +} + + +=back + +=head1 AUTHORS + +See the authors list in I<File::Spec>. Mac OS support by Paul Schinder +<schinder@pobox.com> and Thomas Wegner <wegner_thomas@yahoo.com>. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/Master/tlpkg/installer/perllib/File/Spec/OS2.pm b/Master/tlpkg/installer/perllib/File/Spec/OS2.pm new file mode 100644 index 00000000000..ec308f3b6f3 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Spec/OS2.pm @@ -0,0 +1,272 @@ +package File::Spec::OS2; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '1.2'; + +@ISA = qw(File::Spec::Unix); + +sub devnull { + return "/dev/nul"; +} + +sub case_tolerant { + return 1; +} + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}is); +} + +sub path { + my $path = $ENV{PATH}; + $path =~ s:\\:/:g; + my @path = split(';',$path); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +sub _cwd { + # In OS/2 the "require Cwd" is unnecessary bloat. + return Cwd::sys_cwd(); +} + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, + '/tmp', + '/' ); +} + +sub catdir { + my $self = shift; + my @args = @_; + foreach (@args) { + tr[\\][/]; + # append a backslash to each argument unless it has one there + $_ .= "/" unless m{/$}; + } + return $self->canonpath(join('', @args)); +} + +sub canonpath { + my ($self,$path) = @_; + $path =~ s/^([a-z]:)/\l$1/s; + $path =~ s|\\|/|g; + $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx + $path =~ s|/\Z(?!\n)|| + unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx + $path =~ s{^/\.\.$}{/}; # /.. -> / + 1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx + return $path; +} + + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( (?: [a-zA-Z]: | + (?:\\\\|//)[^\\/]+[\\/][^\\/]+ + )? + ) + ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +sub splitdir { + my ($self,$directories) = @_ ; + split m|[\\/]|, $directories, -1; +} + + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '/' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ; + my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ; + return $path unless $path_volume eq $base_volume; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # No need to catdir, we know these are well formed. + $path_directories = CORE::join( '/', @pathchunks ); + $base_directories = CORE::join( '/', @basechunks ); + + # $base_directories now contains the directories the resulting relative + # path must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + + #FA Need to replace between backslashes... + $base_directories =~ s|[^\\/]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + + #FA Must check that new directories are not empty. + if ( $path_directories ne '' && $base_directories ne '' ) { + $path_directories = "$base_directories/$path_directories" ; + } else { + $path_directories = "$base_directories$path_directories" ; + } + + return $self->canonpath( + $self->catpath( "", $path_directories, $path_file ) + ) ; +} + + +sub rel2abs { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} + +1; +__END__ + +=head1 NAME + +File::Spec::OS2 - methods for OS/2 file specs + +=head1 SYNOPSIS + + require File::Spec::OS2; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +Amongst the changes made for OS/2 are... + +=over 4 + +=item tmpdir + +Modifies the list of places temp directory information is looked for. + + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + /tmp + / + +=item splitpath + +Volumes can be drive letters or UNC sharenames (\\server\share). + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/File/Spec/VMS.pm b/Master/tlpkg/installer/perllib/File/Spec/VMS.pm new file mode 100644 index 00000000000..f8923f25fb2 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Spec/VMS.pm @@ -0,0 +1,521 @@ +package File::Spec::VMS; + +use strict; +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '1.4'; + +@ISA = qw(File::Spec::Unix); + +use File::Basename; +use VMS::Filespec; + +=head1 NAME + +File::Spec::VMS - methods for VMS file specs + +=head1 SYNOPSIS + + require File::Spec::VMS; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over 4 + +=item canonpath (override) + +Removes redundant portions of file specifications according to VMS syntax. + +=cut + +sub canonpath { + my($self,$path) = @_; + + if ($path =~ m|/|) { # Fake Unix + my $pathify = $path =~ m|/\Z(?!\n)|; + $path = $self->SUPER::canonpath($path); + if ($pathify) { return vmspath($path); } + else { return vmsify($path); } + } + else { + $path =~ tr/<>/[]/; # < and > ==> [ and ] + $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][ + $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $path =~ s/\[000000\./\[/g; # [000000. ==> [ + $path =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ] + $path =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar + 1 while ($path =~ s/([\[\.])(-+)\.(-+)([\.\]])/$1$2$3$4/); + # That loop does the following + # with any amount of dashes: + # .-.-. ==> .--. + # [-.-. ==> [--. + # .-.-] ==> .--] + # [-.-] ==> [--] + 1 while ($path =~ s/([\[\.])[^\]\.]+\.-(-+)([\]\.])/$1$2$3/); + # That loop does the following + # with any amount (minimum 2) + # of dashes: + # .foo.--. ==> .-. + # .foo.--] ==> .-] + # [foo.--. ==> [-. + # [foo.--] ==> [-] + # + # And then, the remaining cases + $path =~ s/\[\.-/[-/; # [.- ==> [- + $path =~ s/\.[^\]\.]+\.-\./\./g; # .foo.-. ==> . + $path =~ s/\[[^\]\.]+\.-\./\[/g; # [foo.-. ==> [ + $path =~ s/\.[^\]\.]+\.-\]/\]/g; # .foo.-] ==> ] + $path =~ s/\[[^\]\.]+\.-\]/\[000000\]/g;# [foo.-] ==> [000000] + $path =~ s/\[\]//; # [] ==> + return $path; + } +} + +=item catdir (override) + +Concatenates a list of file specifications, and returns the result as a +VMS-syntax directory specification. No check is made for "impossible" +cases (e.g. elements other than the first being absolute filespecs). + +=cut + +sub catdir { + my ($self,@dirs) = @_; + my $dir = pop @dirs; + @dirs = grep($_,@dirs); + my $rslt; + if (@dirs) { + my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); + my ($spath,$sdir) = ($path,$dir); + $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; + $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; + $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + + # Special case for VMS absolute directory specs: these will have had device + # prepended during trip through Unix syntax in eliminate_macros(), since + # Unix syntax has no way to express "absolute from the top of this device's + # directory tree". + if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } + } + else { + if (not defined $dir or not length $dir) { $rslt = ''; } + elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; } + else { $rslt = vmspath($dir); } + } + return $self->canonpath($rslt); +} + +=item catfile (override) + +Concatenates a list of file specifications, and returns the result as a +VMS-syntax file specification. + +=cut + +sub catfile { + my ($self,@files) = @_; + my $file = $self->canonpath(pop @files); + @files = grep($_,@files); + my $rslt; + if (@files) { + my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); + my $spath = $path; + $spath =~ s/\.dir\Z(?!\n)//; + if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { + $rslt = "$spath$file"; + } + else { + $rslt = $self->eliminate_macros($spath); + $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); + } + } + else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } + return $self->canonpath($rslt); +} + + +=item curdir (override) + +Returns a string representation of the current directory: '[]' + +=cut + +sub curdir { + return '[]'; +} + +=item devnull (override) + +Returns a string representation of the null device: '_NLA0:' + +=cut + +sub devnull { + return "_NLA0:"; +} + +=item rootdir (override) + +Returns a string representation of the root directory: 'SYS$DISK:[000000]' + +=cut + +sub rootdir { + return 'SYS$DISK:[000000]'; +} + +=item tmpdir (override) + +Returns a string representation of the first writable directory +from the following list or '' if none are writable: + + sys$scratch: + $ENV{TMPDIR} + +Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} +is tainted, it is not used. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); +} + +=item updir (override) + +Returns a string representation of the parent directory: '[-]' + +=cut + +sub updir { + return '[-]'; +} + +=item case_tolerant (override) + +VMS file specification syntax is case-tolerant. + +=cut + +sub case_tolerant { + return 1; +} + +=item path (override) + +Translate logical name DCL$PATH as a searchlist, rather than trying +to C<split> string value of C<$ENV{'PATH'}>. + +=cut + +sub path { + my (@dirs,$dir,$i); + while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } + return @dirs; +} + +=item file_name_is_absolute (override) + +Checks for VMS directory spec as well as Unix separators. + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + # If it's a logical name, expand it. + $file = $ENV{$file} while $file =~ /^[\w\$\-]+\Z(?!\n)/s && $ENV{$file}; + return scalar($file =~ m!^/!s || + $file =~ m![<\[][^.\-\]>]! || + $file =~ /:[^<\[]/); +} + +=item splitpath (override) + +Splits using VMS syntax. + +=cut + +sub splitpath { + my($self,$path) = @_; + my($dev,$dir,$file) = ('','',''); + + vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s; + return ($1 || '',$2 || '',$3); +} + +=item splitdir (override) + +Split dirspec using VMS syntax. + +=cut + +sub splitdir { + my($self,$dirspec) = @_; + $dirspec =~ tr/<>/[]/; # < and > ==> [ and ] + $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][ + $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [ + $dirspec =~ s/\[000000\./\[/g; # [000000. ==> [ + $dirspec =~ s/\.\]\[000000\]/\]/g; # .][000000] ==> ] + $dirspec =~ s/\.\]\[/\./g; # foo.][bar ==> foo.bar + while ($dirspec =~ s/(^|[\[\<\.])\-(\-+)($|[\]\>\.])/$1-.$2$3/g) {} + # That loop does the following + # with any amount of dashes: + # .--. ==> .-.-. + # [--. ==> [-.-. + # .--] ==> .-.-] + # [--] ==> [-.-] + $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal + my(@dirs) = split('\.', vmspath($dirspec)); + $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\Z(?!\n)//s; + @dirs; +} + + +=item catpath (override) + +Construct a complete filespec using VMS syntax + +=cut + +sub catpath { + my($self,$dev,$dir,$file) = @_; + + # We look for a volume in $dev, then in $dir, but not both + my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir); + $dev = $dir_volume unless length $dev; + $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir; + + if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } + else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } + if (length($dev) or length($dir)) { + $dir = "[$dir]" unless $dir =~ /[\[<\/]/; + $dir = vmspath($dir); + } + "$dev$dir$file"; +} + +=item abs2rel (override) + +Use VMS syntax when converting filespecs. + +=cut + +sub abs2rel { + my $self = shift; + return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) + if grep m{/}, @_; + + my($path,$base) = @_; + $base = $self->_cwd() unless defined $base and length $base; + + for ($path, $base) { $_ = $self->canonpath($_) } + + # Are we even starting $path on the same (node::)device as $base? Note that + # logical paths or nodename differences may be on the "same device" + # but the comparison that ignores device differences so as to concatenate + # [---] up directory specs is not even a good idea in cases where there is + # a logical path difference between $path and $base nodename and/or device. + # Hence we fall back to returning the absolute $path spec + # if there is a case blind device (or node) difference of any sort + # and we do not even try to call $parse() or consult %ENV for $trnlnm() + # (this module needs to run on non VMS platforms after all). + + my ($path_volume, $path_directories, $path_file) = $self->splitpath($path); + my ($base_volume, $base_directories, $base_file) = $self->splitpath($base); + return $path unless lc($path_volume) eq lc($base_volume); + + for ($path, $base) { $_ = $self->rel2abs($_) } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + unshift(@pathchunks,'000000') unless $pathchunks[0] eq '000000'; + my @basechunks = $self->splitdir( $base_directories ); + unshift(@basechunks,'000000') unless $basechunks[0] eq '000000'; + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @basechunks now contains the directories to climb out of, + # @pathchunks now has the directories to descend in to. + $path_directories = join '.', ('-' x @basechunks, @pathchunks) ; + return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; +} + + +=item rel2abs (override) + +Use VMS syntax when converting filespecs. + +=cut + +sub rel2abs { + my $self = shift ; + my ($path,$base ) = @_; + return undef unless defined $path; + if ($path =~ m/\//) { + $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about + ? vmspath($path) # whether it's a directory + : vmsify($path) ); + } + $base = vmspath($base) if defined $base && $base =~ m/\//; + # Clean up and split up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_directories, $path_file ) = + ($self->splitpath( $path ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base ) ; + + $path_directories = '' if $path_directories eq '[]' || + $path_directories eq '<>'; + my $sep = '' ; + $sep = '.' + if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && + $path_directories =~ m{^[^.\[<]}s + ) ; + $base_directories = "$base_directories$sep$path_directories"; + $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; + + $path = $self->catpath( $base_volume, $base_directories, $path_file ); + } + + return $self->canonpath( $path ) ; +} + + +# eliminate_macros() and fixpath() are MakeMaker-specific methods +# which are used inside catfile() and catdir(). MakeMaker has its own +# copies as of 6.06_03 which are the canonical ones. We leave these +# here, in peace, so that File::Spec continues to work with MakeMakers +# prior to 6.06_03. +# +# Please consider these two methods deprecated. Do not patch them, +# patch the ones in ExtUtils::MM_VMS instead. +sub eliminate_macros { + my($self,$path) = @_; + return '' unless $path; + $self = {} unless ref $self; + + if ($path =~ /\s/) { + return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; + } + + my($npath) = unixify($path); + my($complex) = 0; + my($head,$macro,$tail); + + # perform m##g in scalar context so it acts as an iterator + while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { + if ($self->{$2}) { + ($head,$macro,$tail) = ($1,$2,$3); + if (ref $self->{$macro}) { + if (ref $self->{$macro} eq 'ARRAY') { + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } + } + else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } + $npath = "$head$macro$tail"; + } + } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } + $npath; +} + +# Deprecated. See the note above for eliminate_macros(). +sub fixpath { + my($self,$path,$force_path) = @_; + return '' unless $path; + $self = bless {} unless ref $self; + my($fixedpath,$prefix,$name); + + if ($path =~ /\s/) { + return join ' ', + map { $self->fixpath($_,$force_path) } + split /\s+/, $path; + } + + if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { + $fixedpath = vmspath($self->eliminate_macros($path)); + } + else { + $fixedpath = vmsify($self->eliminate_macros($path)); + } + } + elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; + $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; + $fixedpath = vmspath($fixedpath) if $force_path; + } + else { + $fixedpath = $path; + $fixedpath = vmspath($fixedpath) if $force_path; + } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } + + # Trim off root dirname if it's had other dirs inserted in front of it. + $fixedpath =~ s/\.000000([\]>])/$1/; + # Special case for VMS absolute directory specs: these will have had device + # prepended during trip through Unix syntax in eliminate_macros(), since + # Unix syntax has no way to express "absolute from the top of this device's + # directory tree". + if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } + $fixedpath; +} + + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +An explanation of VMS file specs can be found at +L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">. + +=cut + +1; diff --git a/Master/tlpkg/installer/perllib/File/Temp.pm b/Master/tlpkg/installer/perllib/File/Temp.pm new file mode 100644 index 00000000000..6ddcb3619a7 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Temp.pm @@ -0,0 +1,2244 @@ +package File::Temp; + +=head1 NAME + +File::Temp - return name and handle of a temporary file safely + +=begin __INTERNALS + +=head1 PORTABILITY + +This section is at the top in order to provide easier access to +porters. It is not expected to be rendered by a standard pod +formatting tool. Please skip straight to the SYNOPSIS section if you +are not trying to port this module to a new platform. + +This module is designed to be portable across operating systems and it +currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS +(Classic). When porting to a new OS there are generally three main +issues that have to be solved: + +=over 4 + +=item * + +Can the OS unlink an open file? If it can not then the +C<_can_unlink_opened_file> method should be modified. + +=item * + +Are the return values from C<stat> reliable? By default all the +return values from C<stat> are compared when unlinking a temporary +file using the filename and the handle. Operating systems other than +unix do not always have valid entries in all fields. If C<unlink0> fails +then the C<stat> comparison should be modified accordingly. + +=item * + +Security. Systems that can not support a test for the sticky bit +on a directory can not use the MEDIUM and HIGH security tests. +The C<_can_do_level> method should be modified accordingly. + +=back + +=end __INTERNALS + +=head1 SYNOPSIS + + use File::Temp qw/ tempfile tempdir /; + + $fh = tempfile(); + ($fh, $filename) = tempfile(); + + ($fh, $filename) = tempfile( $template, DIR => $dir); + ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); + + + $dir = tempdir( CLEANUP => 1 ); + ($fh, $filename) = tempfile( DIR => $dir ); + +Object interface: + + require File::Temp; + use File::Temp (); + + $fh = new File::Temp($template); + $fname = $fh->filename; + + $tmp = new File::Temp( UNLINK => 0, SUFFIX => '.dat' ); + print $tmp "Some data\n"; + print "Filename is $tmp\n"; + +The following interfaces are provided for compatibility with +existing APIs. They should not be used in new code. + +MkTemp family: + + use File::Temp qw/ :mktemp /; + + ($fh, $file) = mkstemp( "tmpfileXXXXX" ); + ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); + + $tmpdir = mkdtemp( $template ); + + $unopened_file = mktemp( $template ); + +POSIX functions: + + use File::Temp qw/ :POSIX /; + + $file = tmpnam(); + $fh = tmpfile(); + + ($fh, $file) = tmpnam(); + +Compatibility functions: + + $unopened_file = File::Temp::tempnam( $dir, $pfx ); + +=head1 DESCRIPTION + +C<File::Temp> can be used to create and open temporary files in a safe +way. There is both a function interface and an object-oriented +interface. The File::Temp constructor or the tempfile() function can +be used to return the name and the open filehandle of a temporary +file. The tempdir() function can be used to create a temporary +directory. + +The security aspect of temporary file creation is emphasized such that +a filehandle and filename are returned together. This helps guarantee +that a race condition can not occur where the temporary file is +created by another process between checking for the existence of the +file and its opening. Additional security levels are provided to +check, for example, that the sticky bit is set on world writable +directories. See L<"safe_level"> for more information. + +For compatibility with popular C library functions, Perl implementations of +the mkstemp() family of functions are provided. These are, mkstemp(), +mkstemps(), mkdtemp() and mktemp(). + +Additionally, implementations of the standard L<POSIX|POSIX> +tmpnam() and tmpfile() functions are provided if required. + +Implementations of mktemp(), tmpnam(), and tempnam() are provided, +but should be used with caution since they return only a filename +that was valid when function was called, so cannot guarantee +that the file will not exist by the time the caller opens the filename. + +=cut + +# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls +# People would like a version on 5.005 so give them what they want :-) +use 5.005; +use strict; +use Carp; +use File::Spec 0.8; +use File::Path qw/ rmtree /; +use Fcntl 1.03; +use Errno; +require VMS::Stdio if $^O eq 'VMS'; + +# Need the Symbol package if we are running older perl +require Symbol if $] < 5.006; + +### For the OO interface +use base qw/ IO::Handle /; +use overload '""' => "STRINGIFY"; + + +# use 'our' on v5.6.0 +use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); + +$DEBUG = 0; +$KEEP_ALL = 0; + +# We are exporting functions + +use base qw/Exporter/; + +# Export list - to allow fine tuning of export table + +@EXPORT_OK = qw{ + tempfile + tempdir + tmpnam + tmpfile + mktemp + mkstemp + mkstemps + mkdtemp + unlink0 + cleanup + }; + +# Groups of functions for export + +%EXPORT_TAGS = ( + 'POSIX' => [qw/ tmpnam tmpfile /], + 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], + ); + +# add contents of these tags to @EXPORT +Exporter::export_tags('POSIX','mktemp'); + +# Version number + +$VERSION = '0.16'; + +# This is a list of characters that can be used in random filenames + +my @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 + 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 + 0 1 2 3 4 5 6 7 8 9 _ + /); + +# Maximum number of tries to make a temp file before failing + +use constant MAX_TRIES => 1000; + +# Minimum number of X characters that should be in a template +use constant MINX => 4; + +# Default template when no template supplied + +use constant TEMPXXX => 'X' x 10; + +# Constants for the security level + +use constant STANDARD => 0; +use constant MEDIUM => 1; +use constant HIGH => 2; + +# OPENFLAGS. If we defined the flag to use with Sysopen here this gives +# us an optimisation when many temporary files are requested + +my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; + +unless ($^O eq 'MacOS') { + for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # eg CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } +} + +# On some systems the O_TEMPORARY flag can be used to tell the OS +# to automatically remove the file when it is closed. This is fine +# in most cases but not if tempfile is called with UNLINK=>0 and +# the filename is requested -- in the case where the filename is to +# be passed to another routine. This happens on windows. We overcome +# this by using a second open flags variable + +my $OPENTEMPFLAGS = $OPENFLAGS; +unless ($^O eq 'MacOS') { + for my $oflag (qw/ TEMPORARY /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENTEMPFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # eg CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } +} + +# INTERNAL ROUTINES - not to be used outside of package + +# Generic routine for getting a temporary filename +# modelled on OpenBSD _gettemp() in mktemp.c + +# The template must contain X's that are to be replaced +# with the random values + +# Arguments: + +# TEMPLATE - string containing the XXXXX's that is converted +# to a random filename and opened if required + +# Optionally, a hash can also be supplied containing specific options +# "open" => if true open the temp file, else just return the name +# default is 0 +# "mkdir"=> if true, we are creating a temp directory rather than tempfile +# default is 0 +# "suffixlen" => number of characters at end of PATH to be ignored. +# default is 0. +# "unlink_on_close" => indicates that, if possible, the OS should remove +# the file as soon as it is closed. Usually indicates +# use of the O_TEMPORARY flag to sysopen. +# Usually irrelevant on unix + +# Optionally a reference to a scalar can be passed into the function +# On error this will be used to store the reason for the error +# "ErrStr" => \$errstr + +# "open" and "mkdir" can not both be true +# "unlink_on_close" is not used when "mkdir" is true. + +# The default options are equivalent to mktemp(). + +# Returns: +# filehandle - open file handle (if called with doopen=1, else undef) +# temp name - name of the temp file or directory + +# For example: +# ($fh, $name) = _gettemp($template, "open" => 1); + +# for the current version, failures are associated with +# stored in an error string and returned to give the reason whilst debugging +# This routine is not called by any external function +sub _gettemp { + + croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' + unless scalar(@_) >= 1; + + # the internal error string - expect it to be overridden + # Need this in case the caller decides not to supply us a value + # need an anonymous scalar + my $tempErrStr; + + # Default options + my %options = ( + "open" => 0, + "mkdir" => 0, + "suffixlen" => 0, + "unlink_on_close" => 0, + "ErrStr" => \$tempErrStr, + ); + + # Read the template + my $template = shift; + if (ref($template)) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: template must not be a reference"; + return (); + } + + # Check that the number of entries on stack are even + if (scalar(@_) % 2 != 0) { + # Use a warning here since we have not yet merged ErrStr + carp "File::Temp::_gettemp: Must have even number of options"; + return (); + } + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Make sure the error string is set to undef + ${$options{ErrStr}} = undef; + + # Can not open the file and make a directory in a single call + if ($options{"open"} && $options{"mkdir"}) { + ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; + return (); + } + + # Find the start of the end of the Xs (position of last X) + # Substr starts from 0 + my $start = length($template) - 1 - $options{"suffixlen"}; + + # Check that we have at least MINX x X (eg 'XXXX") at the end of the string + # (taking suffixlen into account). Any fewer is insecure. + + # Do it using substr - no reason to use a pattern match since + # we know where we are looking and what we are looking for + + if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { + ${$options{ErrStr}} = "The template must end with at least ". + MINX . " 'X' characters\n"; + return (); + } + + # Replace all the X at the end of the substring with a + # random character or just all the XX at the end of a full string. + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # and generate a full path from the template + + my $path = _replace_XX($template, $options{"suffixlen"}); + + + # Split the path into constituent parts - eventually we need to check + # whether the directory exists + # We need to know whether we are making a temp directory + # or a tempfile + + my ($volume, $directories, $file); + my $parent; # parent directory + if ($options{"mkdir"}) { + # There is no filename at the end + ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); + + # The parent is then $directories without the last directory + # Split the directory and put it back together again + my @dirs = File::Spec->splitdir($directories); + + # If @dirs only has one entry (i.e. the directory template) that means + # we are in the current directory + if ($#dirs == 0) { + $parent = File::Spec->curdir; + } else { + + if ($^O eq 'VMS') { # need volume to avoid relative dir spec + $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); + $parent = 'sys$disk:[]' if $parent eq ''; + } else { + + # Put it back together without the last one + $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + + # ...and attach the volume (no filename) + $parent = File::Spec->catpath($volume, $parent, ''); + } + + } + + } else { + + # Get rid of the last filename (use File::Basename for this?) + ($volume, $directories, $file) = File::Spec->splitpath( $path ); + + # Join up without the file part + $parent = File::Spec->catpath($volume,$directories,''); + + # If $parent is empty replace with curdir + $parent = File::Spec->curdir + unless $directories ne ''; + + } + + # Check that the parent directories exist + # Do this even for the case where we are simply returning a name + # not a file -- no point returning a name that includes a directory + # that does not exist or is not writable + + unless (-d $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; + return (); + } + unless (-w $parent) { + ${$options{ErrStr}} = "Parent directory ($parent) is not writable\n"; + return (); + } + + + # Check the stickiness of the directory and chown giveaway if required + # If the directory is world writable the sticky bit + # must be set + + if (File::Temp->safe_level == MEDIUM) { + my $safeerr; + unless (_is_safe($parent,\$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } elsif (File::Temp->safe_level == HIGH) { + my $safeerr; + unless (_is_verysafe($parent, \$safeerr)) { + ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; + return (); + } + } + + + # Now try MAX_TRIES time to open the file + for (my $i = 0; $i < MAX_TRIES; $i++) { + + # Try to open the file if requested + if ($options{"open"}) { + my $fh; + + # If we are running before perl5.6.0 we can not auto-vivify + if ($] < 5.006) { + $fh = &Symbol::gensym; + } + + # Try to make sure this will be marked close-on-exec + # XXX: Win32 doesn't respect this, nor the proper fcntl, + # but may have O_NOINHERIT. This may or may not be in Fcntl. + local $^F = 2; + + # Store callers umask + my $umask = umask(); + + # Set a known umask + umask(066); + + # Attempt to open the file + my $open_success = undef; + if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) { + # make it auto delete on close by setting FAB$V_DLT bit + $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); + $open_success = $fh; + } else { + my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ? + $OPENTEMPFLAGS : + $OPENFLAGS ); + $open_success = sysopen($fh, $path, $flags, 0600); + } + if ( $open_success ) { + + # Reset umask + umask($umask) if defined $umask; + + # Opened successfully - return file handle and name + return ($fh, $path); + + } else { + # Reset umask + umask($umask) if defined $umask; + + # Error opening file - abort with error + # if the reason was anything but EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create temp file $path: $!"; + return (); + } + + # Loop round for another try + + } + } elsif ($options{"mkdir"}) { + + # Store callers umask + my $umask = umask(); + + # Set a known umask + umask(066); + + # Open the temp directory + if (mkdir( $path, 0700)) { + # created okay + # Reset umask + umask($umask) if defined $umask; + + return undef, $path; + } else { + + # Reset umask + umask($umask) if defined $umask; + + # Abort with error if the reason for failure was anything + # except EEXIST + unless ($!{EEXIST}) { + ${$options{ErrStr}} = "Could not create directory $path: $!"; + return (); + } + + # Loop round for another try + + } + + } else { + + # Return true if the file can not be found + # Directory has been checked previously + + return (undef, $path) unless -e $path; + + # Try again until MAX_TRIES + + } + + # Did not successfully open the tempfile/dir + # so try again with a different set of random letters + # No point in trying to increment unless we have only + # 1 X say and the randomness could come up with the same + # file MAX_TRIES in a row. + + # Store current attempt - in principal this implies that the + # 3rd time around the open attempt that the first temp file + # name could be generated again. Probably should store each + # attempt and make sure that none are repeated + + my $original = $path; + my $counter = 0; # Stop infinite loop + my $MAX_GUESS = 50; + + do { + + # Generate new name from original template + $path = _replace_XX($template, $options{"suffixlen"}); + + $counter++; + + } until ($path ne $original || $counter > $MAX_GUESS); + + # Check for out of control looping + if ($counter > $MAX_GUESS) { + ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; + return (); + } + + } + + # If we get here, we have run out of tries + ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts (" + . MAX_TRIES . ") to open temp file/dir"; + + return (); + +} + +# Internal routine to return a random character from the +# character list. Does not do an srand() since rand() +# will do one automatically + +# No arguments. Return value is the random character + +# No longer called since _replace_XX runs a few percent faster if +# I inline the code. This is important if we are creating thousands of +# temporary files. + +sub _randchar { + + $CHARS[ int( rand( $#CHARS ) ) ]; + +} + +# Internal routine to replace the XXXX... with random characters +# This has to be done by _gettemp() every time it fails to +# open a temp file/dir + +# Arguments: $template (the template with XXX), +# $ignore (number of characters at end to ignore) + +# Returns: modified template + +sub _replace_XX { + + croak 'Usage: _replace_XX($template, $ignore)' + unless scalar(@_) == 2; + + my ($path, $ignore) = @_; + + # Do it as an if, since the suffix adjusts which section to replace + # and suffixlen=0 returns nothing if used in the substr directly + # Alternatively, could simply set $ignore to length($path)-1 + # Don't want to always use substr when not required though. + + if ($ignore) { + substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; + } else { + $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; + } + return $path; +} + +# Internal routine to force a temp file to be writable after +# it is created so that we can unlink it. Windows seems to occassionally +# force a file to be readonly when written to certain temp locations +sub _force_writable { + my $file = shift; + my $umask = umask(); + umask(066); + chmod 0600, $file; + umask($umask) if defined $umask; +} + + +# internal routine to check to see if the directory is safe +# First checks to see if the directory is not owned by the +# current user or root. Then checks to see if anyone else +# can write to the directory and if so, checks to see if +# it has the sticky bit set + +# Will not work on systems that do not support sticky bit + +#Args: directory path to check +# Optionally: reference to scalar to contain error message +# Returns true if the path is safe and false otherwise. +# Returns undef if can not even run stat() on the path + +# This routine based on version written by Tom Christiansen + +# Presumably, by the time we actually attempt to create the +# file or directory in this directory, it may not be safe +# anymore... Have to run _is_safe directly after the open. + +sub _is_safe { + + my $path = shift; + my $err_ref = shift; + + # Stat path + my @info = stat($path); + unless (scalar(@info)) { + $$err_ref = "stat(path) returned no values"; + return 0; + }; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + # Check to see whether owner is neither superuser (or a system uid) nor me + # Use the real uid from the $< variable + # UID is in [4] + if ($info[4] > File::Temp->top_system_uid() && $info[4] != $<) { + + Carp::cluck(sprintf "uid=$info[4] topuid=%s \$<=$< path='$path'", + File::Temp->top_system_uid()); + + $$err_ref = "Directory owned neither by root nor the current user" + if ref($err_ref); + return 0; + } + + # check whether group or other can write file + # use 066 to detect either reading or writing + # use 022 to check writability + # Do it with S_IWOTH and S_IWGRP for portability (maybe) + # mode is in info[2] + if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? + ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? + # Must be a directory + unless (-d $path) { + $$err_ref = "Path ($path) is not a directory" + if ref($err_ref); + return 0; + } + # Must have sticky bit set + unless (-k $path) { + $$err_ref = "Sticky bit not set on $path when dir is group|world writable" + if ref($err_ref); + return 0; + } + } + + return 1; +} + +# Internal routine to check whether a directory is safe +# for temp files. Safer than _is_safe since it checks for +# the possibility of chown giveaway and if that is a possibility +# checks each directory in the path to see if it is safe (with _is_safe) + +# If _PC_CHOWN_RESTRICTED is not set, does the full test of each +# directory anyway. + +# Takes optional second arg as scalar ref to error reason + +sub _is_verysafe { + + # Need POSIX - but only want to bother if really necessary due to overhead + require POSIX; + + my $path = shift; + print "_is_verysafe testing $path\n" if $DEBUG; + return 1 if $^O eq 'VMS'; # owner delete control at file level + + my $err_ref = shift; + + # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined + # and If it is not there do the extensive test + my $chown_restricted; + $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() + if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; + + # If chown_resticted is set to some value we should test it + if (defined $chown_restricted) { + + # Return if the current directory is safe + return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted ); + + } + + # To reach this point either, the _PC_CHOWN_RESTRICTED symbol + # was not avialable or the symbol was there but chown giveaway + # is allowed. Either way, we now have to test the entire tree for + # safety. + + # Convert path to an absolute directory if required + unless (File::Spec->file_name_is_absolute($path)) { + $path = File::Spec->rel2abs($path); + } + + # Split directory into components - assume no file + my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); + + # Slightly less efficient than having a function in File::Spec + # to chop off the end of a directory or even a function that + # can handle ../ in a directory tree + # Sometimes splitdir() returns a blank at the end + # so we will probably check the bottom directory twice in some cases + my @dirs = File::Spec->splitdir($directories); + + # Concatenate one less directory each time around + foreach my $pos (0.. $#dirs) { + # Get a directory name + my $dir = File::Spec->catpath($volume, + File::Spec->catdir(@dirs[0.. $#dirs - $pos]), + '' + ); + + print "TESTING DIR $dir\n" if $DEBUG; + + # Check the directory + return 0 unless _is_safe($dir,$err_ref); + + } + + return 1; +} + + + +# internal routine to determine whether unlink works on this +# platform for files that are currently open. +# Returns true if we can, false otherwise. + +# Currently WinNT, OS/2 and VMS can not unlink an opened file +# On VMS this is because the O_EXCL flag is used to open the +# temporary file. Currently I do not know enough about the issues +# on VMS to decide whether O_EXCL is a requirement. + +sub _can_unlink_opened_file { + + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') { + return 0; + } else { + return 1; + } + +} + +# internal routine to decide which security levels are allowed +# see safe_level() for more information on this + +# Controls whether the supplied security level is allowed + +# $cando = _can_do_level( $level ) + +sub _can_do_level { + + # Get security level + my $level = shift; + + # Always have to be able to do STANDARD + return 1 if $level == STANDARD; + + # Currently, the systems that can do HIGH or MEDIUM are identical + if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') { + return 0; + } else { + return 1; + } + +} + +# This routine sets up a deferred unlinking of a specified +# filename and filehandle. It is used in the following cases: +# - Called by unlink0 if an opened file can not be unlinked +# - Called by tempfile() if files are to be removed on shutdown +# - Called by tempdir() if directories are to be removed on shutdown + +# Arguments: +# _deferred_unlink( $fh, $fname, $isdir ); +# +# - filehandle (so that it can be expclicitly closed if open +# - filename (the thing we want to remove) +# - isdir (flag to indicate that we are being given a directory) +# [and hence no filehandle] + +# Status is not referred to since all the magic is done with an END block + +{ + # Will set up two lexical variables to contain all the files to be + # removed. One array for files, another for directories They will + # only exist in this block. + + # This means we only have to set up a single END block to remove + # all files. + + # in order to prevent child processes inadvertently deleting the parent + # temp files we use a hash to store the temp files and directories + # created by a particular process id. + + # %files_to_unlink contains values that are references to an array of + # array references containing the filehandle and filename associated with + # the temp file. + my (%files_to_unlink, %dirs_to_unlink); + + # Set up an end block to use these arrays + END { + cleanup(); + } + + # Cleanup function. Always triggered on END but can be invoked + # manually. + sub cleanup { + if (!$KEEP_ALL) { + # Files + my @files = (exists $files_to_unlink{$$} ? + @{ $files_to_unlink{$$} } : () ); + foreach my $file (@files) { + # close the filehandle without checking its state + # in order to make real sure that this is closed + # if its already closed then I dont care about the answer + # probably a better way to do this + close($file->[0]); # file handle is [0] + + if (-f $file->[1]) { # file name is [1] + _force_writable( $file->[1] ); # for windows + unlink $file->[1] or warn "Error removing ".$file->[1]; + } + } + # Dirs + my @dirs = (exists $dirs_to_unlink{$$} ? + @{ $dirs_to_unlink{$$} } : () ); + foreach my $dir (@dirs) { + if (-d $dir) { + rmtree($dir, $DEBUG, 0); + } + } + + # clear the arrays + @{ $files_to_unlink{$$} } = () + if exists $files_to_unlink{$$}; + @{ $dirs_to_unlink{$$} } = () + if exists $dirs_to_unlink{$$}; + } + } + + + # This is the sub called to register a file for deferred unlinking + # This could simply store the input parameters and defer everything + # until the END block. For now we do a bit of checking at this + # point in order to make sure that (1) we have a file/dir to delete + # and (2) we have been called with the correct arguments. + sub _deferred_unlink { + + croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' + unless scalar(@_) == 3; + + my ($fh, $fname, $isdir) = @_; + + warn "Setting up deferred removal of $fname\n" + if $DEBUG; + + # If we have a directory, check that it is a directory + if ($isdir) { + + if (-d $fname) { + + # Directory exists so store it + # first on VMS turn []foo into [.foo] for rmtree + $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS'; + $dirs_to_unlink{$$} = [] + unless exists $dirs_to_unlink{$$}; + push (@{ $dirs_to_unlink{$$} }, $fname); + + } else { + carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W; + } + + } else { + + if (-f $fname) { + + # file exists so store handle and name for later removal + $files_to_unlink{$$} = [] + unless exists $files_to_unlink{$$}; + push(@{ $files_to_unlink{$$} }, [$fh, $fname]); + + } else { + carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W; + } + + } + + } + + +} + +=head1 OBJECT-ORIENTED INTERFACE + +This is the primary interface for interacting with +C<File::Temp>. Using the OO interface a temporary file can be created +when the object is constructed and the file can be removed when the +object is no longer required. + +Note that there is no method to obtain the filehandle from the +C<File::Temp> object. The object itself acts as a filehandle. Also, +the object is configured such that it stringifies to the name of the +temporary file. + +=over 4 + +=item B<new> + +Create a temporary file object. + + my $tmp = new File::Temp(); + +by default the object is constructed as if C<tempfile> +was called without options, but with the additional behaviour +that the temporary file is removed by the object destructor +if UNLINK is set to true (the default). + +Supported arguments are the same as for C<tempfile>: UNLINK +(defaulting to true), DIR and SUFFIX. Additionally, the filename +template is specified using the TEMPLATE option. The OPEN option +is not supported (the file is always opened). + + $tmp = new File::Temp( TEMPLATE => 'tempXXXXX', + DIR => 'mydir', + SUFFIX => '.dat'); + +Arguments are case insensitive. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + # read arguments and convert keys to upper case + my %args = @_; + %args = map { uc($_), $args{$_} } keys %args; + + # see if they are unlinking (defaulting to yes) + my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 ); + delete $args{UNLINK}; + + # template (store it in an error so that it will + # disappear from the arg list of tempfile + my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () ); + delete $args{TEMPLATE}; + + # Protect OPEN + delete $args{OPEN}; + + # Open the file and retain file handle and file name + my ($fh, $path) = tempfile( @template, %args ); + + print "Tmp: $fh - $path\n" if $DEBUG; + + # Store the filename in the scalar slot + ${*$fh} = $path; + + # Store unlink information in hash slot (plus other constructor info) + %{*$fh} = %args; + + # create the object + bless $fh, $class; + + # final method-based configuration + $fh->unlink_on_destroy( $unlink ); + + return $fh; +} + +=item B<filename> + +Return the name of the temporary file associated with this object. + + $filename = $tmp->filename; + +This method is called automatically when the object is used as +a string. + +=cut + +sub filename { + my $self = shift; + return ${*$self}; +} + +sub STRINGIFY { + my $self = shift; + return $self->filename; +} + +=item B<unlink_on_destroy> + +Control whether the file is unlinked when the object goes out of scope. +The file is removed if this value is true and $KEEP_ALL is not. + + $fh->unlink_on_destroy( 1 ); + +Default is for the file to be removed. + +=cut + +sub unlink_on_destroy { + my $self = shift; + if (@_) { + ${*$self}{UNLINK} = shift; + } + return ${*$self}{UNLINK}; +} + +=item B<DESTROY> + +When the object goes out of scope, the destructor is called. This +destructor will attempt to unlink the file (using C<unlink1>) +if the constructor was called with UNLINK set to 1 (the default state +if UNLINK is not specified). + +No error is given if the unlink fails. + +If the global variable $KEEP_ALL is true, the file will not be removed. + +=cut + +sub DESTROY { + my $self = shift; + if (${*$self}{UNLINK} && !$KEEP_ALL) { + print "# ---------> Unlinking $self\n" if $DEBUG; + + # The unlink1 may fail if the file has been closed + # by the caller. This leaves us with the decision + # of whether to refuse to remove the file or simply + # do an unlink without test. Seems to be silly + # to do this when we are trying to be careful + # about security + _force_writable( $self->filename ); # for windows + unlink1( $self, $self->filename ) + or unlink($self->filename); + } +} + +=back + +=head1 FUNCTIONS + +This section describes the recommended interface for generating +temporary files and directories. + +=over 4 + +=item B<tempfile> + +This is the basic function to generate temporary files. +The behaviour of the file can be changed using various options: + + $fh = tempfile(); + ($fh, $filename) = tempfile(); + +Create a temporary file in the directory specified for temporary +files, as specified by the tmpdir() function in L<File::Spec>. + + ($fh, $filename) = tempfile($template); + +Create a temporary file in the current directory using the supplied +template. Trailing `X' characters are replaced with random letters to +generate the filename. At least four `X' characters must be present +at the end of the template. + + ($fh, $filename) = tempfile($template, SUFFIX => $suffix) + +Same as previously, except that a suffix is added to the template +after the `X' translation. Useful for ensuring that a temporary +filename has a particular extension when needed by other applications. +But see the WARNING at the end. + + ($fh, $filename) = tempfile($template, DIR => $dir); + +Translates the template as before except that a directory name +is specified. + + ($fh, $filename) = tempfile($template, UNLINK => 1); + +Return the filename and filehandle as before except that the file is +automatically removed when the program exits (dependent on +$KEEP_ALL). Default is for the file to be removed if a file handle is +requested and to be kept if the filename is requested. In a scalar +context (where no filename is returned) the file is always deleted +either (depending on the operating system) on exit or when it is +closed (unless $KEEP_ALL is true when the temp file is created). + +Use the object-oriented interface if fine-grained control of when +a file is removed is required. + +If the template is not specified, a template is always +automatically generated. This temporary file is placed in tmpdir() +(L<File::Spec>) unless a directory is specified explicitly with the +DIR option. + + $fh = tempfile( $template, DIR => $dir ); + +If called in scalar context, only the filehandle is returned and the +file will automatically be deleted when closed on operating systems +that support this (see the description of tmpfile() elsewhere in this +document). This is the preferred mode of operation, as if you only +have a filehandle, you can never create a race condition by fumbling +with the filename. On systems that can not unlink an open file or can +not mark a file as temporary when it is opened (for example, Windows +NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when +the program ends (equivalent to setting UNLINK to 1). The C<UNLINK> +flag is ignored if present. + + (undef, $filename) = tempfile($template, OPEN => 0); + +This will return the filename based on the template but +will not open this file. Cannot be used in conjunction with +UNLINK set to true. Default is to always open the file +to protect from possible race conditions. A warning is issued +if warnings are turned on. Consider using the tmpnam() +and mktemp() functions described elsewhere in this document +if opening the file is not required. + +Options can be combined as required. + +=cut + +sub tempfile { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "DIR" => undef, # Directory prefix + "SUFFIX" => '', # Template suffix + "UNLINK" => 0, # Do not unlink file on exit + "OPEN" => 1, # Open file + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # First decision is whether or not to open the file + if (! $options{"OPEN"}) { + + warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" + if $^W; + + } + + if ($options{"DIR"} and $^O eq 'VMS') { + + # on VMS turn []foo into [.foo] for concatenation + $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); + } + + # Construct the template + + # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc + # functions or simply constructing a template and using _gettemp() + # explicitly. Go for the latter + + # First generate a template if not defined and prefix the directory + # If no template must prefix the temp directory + if (defined $template) { + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, $template); + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Now add a suffix + $template .= $options{"SUFFIX"}; + + # Determine whether we should tell _gettemp to unlink the file + # On unix this is irrelevant and can be worked out after the file is + # opened (simply by unlinking the open filehandle). On Windows or VMS + # we have to indicate temporary-ness when we open the file. In general + # we only want a true temporary file if we are returning just the + # filehandle - if the user wants the filename they probably do not + # want the file to disappear as soon as they close it (which may be + # important if they want a child process to use the file) + # For this reason, tie unlink_on_close to the return context regardless + # of OS. + my $unlink_on_close = ( wantarray ? 0 : 1); + + # Create the file + my ($fh, $path, $errstr); + croak "Error in tempfile() using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => $options{'OPEN'}, + "mkdir"=> 0 , + "unlink_on_close" => $unlink_on_close, + "suffixlen" => length($options{'SUFFIX'}), + "ErrStr" => \$errstr, + ) ); + + # Set up an exit handler that can do whatever is right for the + # system. This removes files at exit when requested explicitly or when + # system is asked to unlink_on_close but is unable to do so because + # of OS limitations. + # The latter should be achieved by using a tied filehandle. + # Do not check return status since this is all done with END blocks. + _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; + + # Return + if (wantarray()) { + + if ($options{'OPEN'}) { + return ($fh, $path); + } else { + return (undef, $path); + } + + } else { + + # Unlink the file. It is up to unlink0 to decide what to do with + # this (whether to unlink now or to defer until later) + unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; + + # Return just the filehandle. + return $fh; + } + + +} + +=item B<tempdir> + +This is the recommended interface for creation of temporary directories. +The behaviour of the function depends on the arguments: + + $tempdir = tempdir(); + +Create a directory in tmpdir() (see L<File::Spec|File::Spec>). + + $tempdir = tempdir( $template ); + +Create a directory from the supplied template. This template is +similar to that described for tempfile(). `X' characters at the end +of the template are replaced with random letters to construct the +directory name. At least four `X' characters must be in the template. + + $tempdir = tempdir ( DIR => $dir ); + +Specifies the directory to use for the temporary directory. +The temporary directory name is derived from an internal template. + + $tempdir = tempdir ( $template, DIR => $dir ); + +Prepend the supplied directory name to the template. The template +should not include parent directory specifications itself. Any parent +directory specifications are removed from the template before +prepending the supplied directory. + + $tempdir = tempdir ( $template, TMPDIR => 1 ); + +Using the supplied template, create the temporary directory in +a standard location for temporary files. Equivalent to doing + + $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); + +but shorter. Parent directory specifications are stripped from the +template itself. The C<TMPDIR> option is ignored if C<DIR> is set +explicitly. Additionally, C<TMPDIR> is implied if neither a template +nor a directory are supplied. + + $tempdir = tempdir( $template, CLEANUP => 1); + +Create a temporary directory using the supplied template, but +attempt to remove it (and all files inside it) when the program +exits. Note that an attempt will be made to remove all files from +the directory even if they were not created by this module (otherwise +why ask to clean it up?). The directory removal is made with +the rmtree() function from the L<File::Path|File::Path> module. +Of course, if the template is not specified, the temporary directory +will be created in tmpdir() and will also be removed at program exit. + +=cut + +# ' + +sub tempdir { + + # Can not check for argument count since we can have any + # number of args + + # Default options + my %options = ( + "CLEANUP" => 0, # Remove directory on exit + "DIR" => '', # Root directory + "TMPDIR" => 0, # Use tempdir with template + ); + + # Check to see whether we have an odd or even number of arguments + my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + + # Read the options and merge with defaults + %options = (%options, @_) if @_; + + # Modify or generate the template + + # Deal with the DIR and TMPDIR options + if (defined $template) { + + # Need to strip directory path if using DIR or TMPDIR + if ($options{'TMPDIR'} || $options{'DIR'}) { + + # Strip parent directory from the filename + # + # There is no filename at the end + $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; + my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); + + # Last directory is then our template + $template = (File::Spec->splitdir($directories))[-1]; + + # Prepend the supplied directory or temp dir + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, $template); + + } elsif ($options{TMPDIR}) { + + # Prepend tmpdir + $template = File::Spec->catdir(File::Spec->tmpdir, $template); + + } + + } + + } else { + + if ($options{"DIR"}) { + + $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); + + } else { + + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); + + } + + } + + # Create the directory + my $tempdir; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } + + my $errstr; + croak "Error in tempdir() using $template: $errstr" + unless ((undef, $tempdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + # Install exit handler; must be dynamic to get lexical + if ( $options{'CLEANUP'} && -d $tempdir) { + _deferred_unlink(undef, $tempdir, 1); + } + + # Return the dir name + return $tempdir; + +} + +=back + +=head1 MKTEMP FUNCTIONS + +The following functions are Perl implementations of the +mktemp() family of temp file generation system calls. + +=over 4 + +=item B<mkstemp> + +Given a template, returns a filehandle to the temporary file and the name +of the file. + + ($fh, $name) = mkstemp( $template ); + +In scalar context, just the filehandle is returned. + +The template may be any filename with some number of X's appended +to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced +with unique alphanumeric combinations. + +=cut + + + +sub mkstemp { + + croak "Usage: mkstemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($fh, $path, $errstr); + croak "Error in mkstemp using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + + +=item B<mkstemps> + +Similar to mkstemp(), except that an extra argument can be supplied +with a suffix to be appended to the template. + + ($fh, $name) = mkstemps( $template, $suffix ); + +For example a template of C<testXXXXXX> and suffix of C<.dat> +would generate a file similar to F<testhGji_w.dat>. + +Returns just the filehandle alone when called in scalar context. + +=cut + +sub mkstemps { + + croak "Usage: mkstemps(template, suffix)" + if scalar(@_) != 2; + + + my $template = shift; + my $suffix = shift; + + $template .= $suffix; + + my ($fh, $path, $errstr); + croak "Error in mkstemps using $template: $errstr" + unless (($fh, $path) = _gettemp($template, + "open" => 1, + "mkdir"=> 0 , + "suffixlen" => length($suffix), + "ErrStr" => \$errstr, + ) ); + + if (wantarray()) { + return ($fh, $path); + } else { + return $fh; + } + +} + +=item B<mkdtemp> + +Create a directory from a template. The template must end in +X's that are replaced by the routine. + + $tmpdir_name = mkdtemp($template); + +Returns the name of the temporary directory created. +Returns undef on failure. + +Directory must be removed by the caller. + +=cut + +#' # for emacs + +sub mkdtemp { + + croak "Usage: mkdtemp(template)" + if scalar(@_) != 1; + + my $template = shift; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } + my ($junk, $tmpdir, $errstr); + croak "Error creating temp directory from template $template\: $errstr" + unless (($junk, $tmpdir) = _gettemp($template, + "open" => 0, + "mkdir"=> 1 , + "suffixlen" => $suffixlen, + "ErrStr" => \$errstr, + ) ); + + return $tmpdir; + +} + +=item B<mktemp> + +Returns a valid temporary filename but does not guarantee +that the file will not be opened by someone else. + + $unopened_file = mktemp($template); + +Template is the same as that required by mkstemp(). + +=cut + +sub mktemp { + + croak "Usage: mktemp(template)" + if scalar(@_) != 1; + + my $template = shift; + + my ($tmpname, $junk, $errstr); + croak "Error getting name to temp file from template $template: $errstr" + unless (($junk, $tmpname) = _gettemp($template, + "open" => 0, + "mkdir"=> 0 , + "suffixlen" => 0, + "ErrStr" => \$errstr, + ) ); + + return $tmpname; +} + +=back + +=head1 POSIX FUNCTIONS + +This section describes the re-implementation of the tmpnam() +and tmpfile() functions described in L<POSIX> +using the mkstemp() from this module. + +Unlike the L<POSIX|POSIX> implementations, the directory used +for the temporary file is not specified in a system include +file (C<P_tmpdir>) but simply depends on the choice of tmpdir() +returned by L<File::Spec|File::Spec>. On some implementations this +location can be set using the C<TMPDIR> environment variable, which +may not be secure. +If this is a problem, simply use mkstemp() and specify a template. + +=over 4 + +=item B<tmpnam> + +When called in scalar context, returns the full name (including path) +of a temporary file (uses mktemp()). The only check is that the file does +not already exist, but there is no guarantee that that condition will +continue to apply. + + $file = tmpnam(); + +When called in list context, a filehandle to the open file and +a filename are returned. This is achieved by calling mkstemp() +after constructing a suitable template. + + ($fh, $file) = tmpnam(); + +If possible, this form should be used to prevent possible +race conditions. + +See L<File::Spec/tmpdir> for information on the choice of temporary +directory for a particular operating system. + +=cut + +sub tmpnam { + + # Retrieve the temporary directory name + my $tmpdir = File::Spec->tmpdir; + + croak "Error temporary directory is not writable" + if $tmpdir eq ''; + + # Use a ten character template and append to tmpdir + my $template = File::Spec->catfile($tmpdir, TEMPXXX); + + if (wantarray() ) { + return mkstemp($template); + } else { + return mktemp($template); + } + +} + +=item B<tmpfile> + +Returns the filehandle of a temporary file. + + $fh = tmpfile(); + +The file is removed when the filehandle is closed or when the program +exits. No access to the filename is provided. + +If the temporary file can not be created undef is returned. +Currently this command will probably not work when the temporary +directory is on an NFS file system. + +=cut + +sub tmpfile { + + # Simply call tmpnam() in a list context + my ($fh, $file) = tmpnam(); + + # Make sure file is removed when filehandle is closed + # This will fail on NFS + unlink0($fh, $file) + or return undef; + + return $fh; + +} + +=back + +=head1 ADDITIONAL FUNCTIONS + +These functions are provided for backwards compatibility +with common tempfile generation C library functions. + +They are not exported and must be addressed using the full package +name. + +=over 4 + +=item B<tempnam> + +Return the name of a temporary file in the specified directory +using a prefix. The file is guaranteed not to exist at the time +the function was called, but such guarantees are good for one +clock tick only. Always use the proper form of C<sysopen> +with C<O_CREAT | O_EXCL> if you must open such a filename. + + $filename = File::Temp::tempnam( $dir, $prefix ); + +Equivalent to running mktemp() with $dir/$prefixXXXXXXXX +(using unix file convention as an example) + +Because this function uses mktemp(), it can suffer from race conditions. + +=cut + +sub tempnam { + + croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; + + my ($dir, $prefix) = @_; + + # Add a string to the prefix + $prefix .= 'XXXXXXXX'; + + # Concatenate the directory to the file + my $template = File::Spec->catfile($dir, $prefix); + + return mktemp($template); + +} + +=back + +=head1 UTILITY FUNCTIONS + +Useful functions for dealing with the filehandle and filename. + +=over 4 + +=item B<unlink0> + +Given an open filehandle and the associated filename, make a safe +unlink. This is achieved by first checking that the filename and +filehandle initially point to the same file and that the number of +links to the file is 1 (all fields returned by stat() are compared). +Then the filename is unlinked and the filehandle checked once again to +verify that the number of links on that file is now 0. This is the +closest you can come to making sure that the filename unlinked was the +same as the file whose descriptor you hold. + + unlink0($fh, $path) + or die "Error unlinking file $path safely"; + +Returns false on error. The filehandle is not closed since on some +occasions this is not required. + +On some platforms, for example Windows NT, it is not possible to +unlink an open file (the file must be closed first). On those +platforms, the actual unlinking is deferred until the program ends and +good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at +the time the end block is executed since the deferred removal may not +have access to the filehandle). + +Additionally, on Windows NT not all the fields returned by stat() can +be compared. For example, the C<dev> and C<rdev> fields seem to be +different. Also, it seems that the size of the file returned by stat() +does not always agree, with C<stat(FH)> being more accurate than +C<stat(filename)>, presumably because of caching issues even when +using autoflush (this is usually overcome by waiting a while after +writing to the tempfile before attempting to C<unlink0> it). + +Finally, on NFS file systems the link count of the file handle does +not always go to zero immediately after unlinking. Currently, this +command is expected to fail on NFS disks. + +This function is disabled if the global variable $KEEP_ALL is true +and an unlink on open file is supported. If the unlink is to be deferred +to the END block, the file is still registered for removal. + +=cut + +sub unlink0 { + + croak 'Usage: unlink0(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + cmpstat($fh, $path) or return 0; + + # attempt remove the file (does not work on some platforms) + if (_can_unlink_opened_file()) { + + # return early (Without unlink) if we have been instructed to retain files. + return 1 if $KEEP_ALL; + + # XXX: do *not* call this on a directory; possible race + # resulting in recursive removal + croak "unlink0: $path has become a directory!" if -d $path; + unlink($path) or return 0; + + # Stat the filehandle + my @fh = stat $fh; + + print "Link count = $fh[3] \n" if $DEBUG; + + # Make sure that the link count is zero + # - Cygwin provides deferred unlinking, however, + # on Win9x the link count remains 1 + # On NFS the link count may still be 1 but we cant know that + # we are on NFS + return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); + + } else { + _deferred_unlink($fh, $path, 0); + return 1; + } + +} + +=item B<cmpstat> + +Compare C<stat> of filehandle with C<stat> of provided filename. This +can be used to check that the filename and filehandle initially point +to the same file and that the number of links to the file is 1 (all +fields returned by stat() are compared). + + cmpstat($fh, $path) + or die "Error comparing handle with file"; + +Returns false if the stat information differs or if the link count is +greater than 1. + +On certain platofms, eg Windows, not all the fields returned by stat() +can be compared. For example, the C<dev> and C<rdev> fields seem to be +different in Windows. Also, it seems that the size of the file +returned by stat() does not always agree, with C<stat(FH)> being more +accurate than C<stat(filename)>, presumably because of caching issues +even when using autoflush (this is usually overcome by waiting a while +after writing to the tempfile before attempting to C<unlink0> it). + +Not exported by default. + +=cut + +sub cmpstat { + + croak 'Usage: cmpstat(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + warn "Comparing stat\n" + if $DEBUG; + + # Stat the filehandle - which may be closed if someone has manually + # closed the file. Can not turn off warnings without using $^W + # unless we upgrade to 5.006 minimum requirement + my @fh; + { + local ($^W) = 0; + @fh = stat $fh; + } + return unless @fh; + + if ($fh[3] > 1 && $^W) { + carp "unlink0: fstat found too many links; SB=@fh" if $^W; + } + + # Stat the path + my @path = stat $path; + + unless (@path) { + carp "unlink0: $path is gone already" if $^W; + return; + } + + # this is no longer a file, but may be a directory, or worse + unless (-f $path) { + confess "panic: $path is no longer a file: SB=@fh"; + } + + # Do comparison of each member of the array + # On WinNT dev and rdev seem to be different + # depending on whether it is a file or a handle. + # Cannot simply compare all members of the stat return + # Select the ones we can use + my @okstat = (0..$#fh); # Use all by default + if ($^O eq 'MSWin32') { + @okstat = (1,2,3,4,5,7,8,9,10); + } elsif ($^O eq 'os2') { + @okstat = (0, 2..$#fh); + } elsif ($^O eq 'VMS') { # device and file ID are sufficient + @okstat = (0, 1); + } elsif ($^O eq 'dos') { + @okstat = (0,2..7,11..$#fh); + } elsif ($^O eq 'mpeix') { + @okstat = (0..4,8..10); + } + + # Now compare each entry explicitly by number + for (@okstat) { + print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; + # Use eq rather than == since rdev, blksize, and blocks (6, 11, + # and 12) will be '' on platforms that do not support them. This + # is fine since we are only comparing integers. + unless ($fh[$_] eq $path[$_]) { + warn "Did not match $_ element of stat\n" if $DEBUG; + return 0; + } + } + + return 1; +} + +=item B<unlink1> + +Similar to C<unlink0> except after file comparison using cmpstat, the +filehandle is closed prior to attempting to unlink the file. This +allows the file to be removed without using an END block, but does +mean that the post-unlink comparison of the filehandle state provided +by C<unlink0> is not available. + + unlink1($fh, $path) + or die "Error closing and unlinking file"; + +Usually called from the object destructor when using the OO interface. + +Not exported by default. + +This function is disabled if the global variable $KEEP_ALL is true. + +=cut + +sub unlink1 { + croak 'Usage: unlink1(filehandle, filename)' + unless scalar(@_) == 2; + + # Read args + my ($fh, $path) = @_; + + cmpstat($fh, $path) or return 0; + + # Close the file + close( $fh ) or return 0; + + # Make sure the file is writable (for windows) + _force_writable( $path ); + + # return early (without unlink) if we have been instructed to retain files. + return 1 if $KEEP_ALL; + + # remove the file + return unlink($path); +} + +=item B<cleanup> + +Calling this function will cause any temp files or temp directories +that are registered for removal to be removed. This happens automatically +when the process exits but can be triggered manually if the caller is sure +that none of the temp files are required. This method can be registered as +an Apache callback. + +On OSes where temp files are automatically removed when the temp file +is closed, calling this function will have no effect other than to remove +temporary directories (which may include temporary files). + + File::Temp::cleanup(); + +Not exported by default. + +=back + +=head1 PACKAGE VARIABLES + +These functions control the global state of the package. + +=over 4 + +=item B<safe_level> + +Controls the lengths to which the module will go to check the safety of the +temporary file or directory before proceeding. +Options are: + +=over 8 + +=item STANDARD + +Do the basic security measures to ensure the directory exists and +is writable, that the umask() is fixed before opening of the file, +that temporary files are opened only if they do not already exist, and +that possible race conditions are avoided. Finally the L<unlink0|"unlink0"> +function is used to remove files safely. + +=item MEDIUM + +In addition to the STANDARD security, the output directory is checked +to make sure that it is owned either by root or the user running the +program. If the directory is writable by group or by other, it is then +checked to make sure that the sticky bit is set. + +Will not work on platforms that do not support the C<-k> test +for sticky bit. + +=item HIGH + +In addition to the MEDIUM security checks, also check for the +possibility of ``chown() giveaway'' using the L<POSIX|POSIX> +sysconf() function. If this is a possibility, each directory in the +path is checked in turn for safeness, recursively walking back to the +root directory. + +For platforms that do not support the L<POSIX|POSIX> +C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is +assumed that ``chown() giveaway'' is possible and the recursive test +is performed. + +=back + +The level can be changed as follows: + + File::Temp->safe_level( File::Temp::HIGH ); + +The level constants are not exported by the module. + +Currently, you must be running at least perl v5.6.0 in order to +run with MEDIUM or HIGH security. This is simply because the +safety tests use functions from L<Fcntl|Fcntl> that are not +available in older versions of perl. The problem is that the version +number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though +they are different versions. + +On systems that do not support the HIGH or MEDIUM safety levels +(for example Win NT or OS/2) any attempt to change the level will +be ignored. The decision to ignore rather than raise an exception +allows portable programs to be written with high security in mind +for the systems that can support this without those programs failing +on systems where the extra tests are irrelevant. + +If you really need to see whether the change has been accepted +simply examine the return value of C<safe_level>. + + $newlevel = File::Temp->safe_level( File::Temp::HIGH ); + die "Could not change to high security" + if $newlevel != File::Temp::HIGH; + +=cut + +{ + # protect from using the variable itself + my $LEVEL = STANDARD; + sub safe_level { + my $self = shift; + if (@_) { + my $level = shift; + if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { + carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; + } else { + # Dont allow this on perl 5.005 or earlier + if ($] < 5.006 && $level != STANDARD) { + # Cant do MEDIUM or HIGH checks + croak "Currently requires perl 5.006 or newer to do the safe checks"; + } + # Check that we are allowed to change level + # Silently ignore if we can not. + $LEVEL = $level if _can_do_level($level); + } + } + return $LEVEL; + } +} + +=item TopSystemUID + +This is the highest UID on the current system that refers to a root +UID. This is used to make sure that the temporary directory is +owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than +simply by root. + +This is required since on many unix systems C</tmp> is not owned +by root. + +Default is to assume that any UID less than or equal to 10 is a root +UID. + + File::Temp->top_system_uid(10); + my $topid = File::Temp->top_system_uid; + +This value can be adjusted to reduce security checking if required. +The value is only relevant when C<safe_level> is set to MEDIUM or higher. + +=cut + +{ + my $TopSystemUID = 10; + sub top_system_uid { + my $self = shift; + if (@_) { + my $newuid = shift; + croak "top_system_uid: UIDs should be numeric" + unless $newuid =~ /^\d+$/s; + $TopSystemUID = $newuid; + } + return $TopSystemUID; + } +} + +=item B<$KEEP_ALL> + +Controls whether temporary files and directories should be retained +regardless of any instructions in the program to remove them +automatically. This is useful for debugging but should not be used in +production code. + + $File::Temp::KEEP_ALL = 1; + +Default is for files to be removed as requested by the caller. + +In some cases, files will only be retained if this variable is true +when the file is created. This means that you can not create a temporary +file, set this variable and expect the temp file to still be around +when the program exits. + +=item B<$DEBUG> + +Controls whether debugging messages should be enabled. + + $File::Temp::DEBUG = 1; + +Default is for debugging mode to be disabled. + +=back + +=head1 WARNING + +For maximum security, endeavour always to avoid ever looking at, +touching, or even imputing the existence of the filename. You do not +know that that filename is connected to the same file as the handle +you have, and attempts to check this can only trigger more race +conditions. It's far more secure to use the filehandle alone and +dispense with the filename altogether. + +If you need to pass the handle to something that expects a filename +then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary +programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl +programs. You will have to clear the close-on-exec bit on that file +descriptor before passing it to another process. + + use Fcntl qw/F_SETFD F_GETFD/; + fcntl($tmpfh, F_SETFD, 0) + or die "Can't clear close-on-exec flag on temp fh: $!\n"; + +=head2 Temporary files and NFS + +Some problems are associated with using temporary files that reside +on NFS file systems and it is recommended that a local filesystem +is used whenever possible. Some of the security tests will most probably +fail when the temp file is not local. Additionally, be aware that +the performance of I/O operations over NFS will not be as good as for +a local disk. + +=head2 Forking + +In some cases files created by File::Temp are removed from within an +END block. Since END blocks are triggered when a child process exits +(unless C<POSIX::_exit()> is used by the child) File::Temp takes care +to only remove those temp files created by a particular process ID. This +means that a child will not attempt to remove temp files created by the +parent process. + +=head2 BINMODE + +The file returned by File::Temp will have been opened in binary mode +if such a mode is available. If that is not correct, use the binmode() +function to change the mode of the filehandle. + +=head1 HISTORY + +Originally began life in May 1999 as an XS interface to the system +mkstemp() function. In March 2000, the OpenBSD mkstemp() code was +translated to Perl for total control of the code's +security checking, to ensure the presence of the function regardless of +operating system and to help with portability. The module was shipped +as a standard part of perl from v5.6.1. + +=head1 SEE ALSO + +L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path> + +See L<IO::File> and L<File::MkTemp>, L<Apachae::TempFile> for +different implementations of temporary file handling. + +=head1 AUTHOR + +Tim Jenness E<lt>tjenness@cpan.orgE<gt> + +Copyright (C) 1999-2005 Tim Jenness and the UK Particle Physics and +Astronomy Research Council. All Rights Reserved. This program is free +software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +Original Perl implementation loosely based on the OpenBSD C code for +mkstemp(). Thanks to Tom Christiansen for suggesting that this module +should be written and providing ideas for code improvements and +security enhancements. + +=cut + +1; diff --git a/Master/tlpkg/installer/perllib/File/stat.pm b/Master/tlpkg/installer/perllib/File/stat.pm new file mode 100644 index 00000000000..132cbee27ad --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/stat.pm @@ -0,0 +1,139 @@ +package File::stat; +use 5.006; + +use strict; +use warnings; + +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); + +our $VERSION = '1.00'; + +BEGIN { + use Exporter (); + @EXPORT = qw(stat lstat); + @EXPORT_OK = qw( $st_dev $st_ino $st_mode + $st_nlink $st_uid $st_gid + $st_rdev $st_size + $st_atime $st_mtime $st_ctime + $st_blksize $st_blocks + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); +} +use vars @EXPORT_OK; + +# Class::Struct forbids use of @ISA +sub import { goto &Exporter::import } + +use Class::Struct qw(struct); +struct 'File::stat' => [ + map { $_ => '$' } qw{ + dev ino mode nlink uid gid rdev size + atime mtime ctime blksize blocks + } +]; + +sub populate (@) { + return unless @_; + my $stob = new(); + @$stob = ( + $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev, + $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) + = @_; + return $stob; +} + +sub lstat ($) { populate(CORE::lstat(shift)) } + +sub stat ($) { + my $arg = shift; + my $st = populate(CORE::stat $arg); + return $st if $st; + my $fh; + { + local $!; + no strict 'refs'; + require Symbol; + $fh = \*{ Symbol::qualify( $arg, caller() )}; + return unless defined fileno $fh; + } + return populate(CORE::stat $fh); +} + +1; +__END__ + +=head1 NAME + +File::stat - by-name interface to Perl's built-in stat() functions + +=head1 SYNOPSIS + + use File::stat; + $st = stat($file) or die "No $file: $!"; + if ( ($st->mode & 0111) && $st->nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + + use File::stat qw(:FIELDS); + stat($file) or die "No $file: $!"; + if ( ($st_mode & 0111) && $st_nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + +=head1 DESCRIPTION + +This module's default exports override the core stat() +and lstat() functions, replacing them with versions that return +"File::stat" objects. This object has methods that +return the similarly named structure field name from the +stat(2) function; namely, +dev, +ino, +mode, +nlink, +uid, +gid, +rdev, +size, +atime, +mtime, +ctime, +blksize, +and +blocks. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your stat() and lstat() functions.) Access these fields as +variables named with a preceding C<st_> in front their method names. +Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import +the fields. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 BUGS + +As of Perl 5.8.0 after using this module you cannot use the implicit +C<$_> or the special filehandle C<_> with stat() or lstat(), trying +to do so leads into strange errors. The workaround is for C<$_> to +be explicit + + my $stat_obj = stat $_; + +and for C<_> to explicitly populate the object using the unexported +and undocumented populate() function with CORE::stat(): + + my $stat_obj = File::stat::populate(CORE::stat(_)); + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/Master/tlpkg/installer/perllib/FileHandle.pm b/Master/tlpkg/installer/perllib/FileHandle.pm new file mode 100644 index 00000000000..6be22429440 --- /dev/null +++ b/Master/tlpkg/installer/perllib/FileHandle.pm @@ -0,0 +1,262 @@ +package FileHandle; + +use 5.006; +use strict; +our($VERSION, @ISA, @EXPORT, @EXPORT_OK); + +$VERSION = "2.01"; + +require IO::File; +@ISA = qw(IO::File); + +@EXPORT = qw(_IOFBF _IOLBF _IONBF); + +@EXPORT_OK = qw( + pipe + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + + print + printf + getline + getlines +); + +# +# Everything we're willing to export, we must first import. +# +import IO::Handle grep { !defined(&$_) } @EXPORT, @EXPORT_OK; + +# +# Some people call "FileHandle::function", so all the functions +# that were in the old FileHandle class must be imported, too. +# +{ + no strict 'refs'; + + my %import = ( + 'IO::Handle' => + [qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets + eof flush error clearerr setbuf setvbuf _open_mode_string)], + 'IO::Seekable' => + [qw(seek tell getpos setpos)], + 'IO::File' => + [qw(new new_tmpfile open)] + ); + for my $pkg (keys %import) { + for my $func (@{$import{$pkg}}) { + my $c = *{"${pkg}::$func"}{CODE} + or die "${pkg}::$func missing"; + *$func = $c; + } + } +} + +# +# Specialized importer for Fcntl magic. +# +sub import { + my $pkg = shift; + my $callpkg = caller; + require Exporter; + Exporter::export($pkg, $callpkg, @_); + + # + # If the Fcntl extension is available, + # export its constants. + # + eval { + require Fcntl; + Exporter::export('Fcntl', $callpkg); + }; +} + +################################################ +# This is the only exported function we define; +# the rest come from other classes. +# + +sub pipe { + my $r = new IO::Handle; + my $w = new IO::Handle; + CORE::pipe($r, $w) or return undef; + ($r, $w); +} + +# Rebless standard file handles +bless *STDIN{IO}, "FileHandle" if ref *STDIN{IO} eq "IO::Handle"; +bless *STDOUT{IO}, "FileHandle" if ref *STDOUT{IO} eq "IO::Handle"; +bless *STDERR{IO}, "FileHandle" if ref *STDERR{IO} eq "IO::Handle"; + +1; + +__END__ + +=head1 NAME + +FileHandle - supply object methods for filehandles + +=head1 SYNOPSIS + + use FileHandle; + + $fh = new FileHandle; + if ($fh->open("< file")) { + print <$fh>; + $fh->close; + } + + $fh = new FileHandle "> FOO"; + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = new FileHandle "file", "r"; + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $fh = new FileHandle "file", O_WRONLY|O_APPEND; + if (defined $fh) { + print $fh "corge\n"; + undef $fh; # automatically closes the file + } + + $pos = $fh->getpos; + $fh->setpos($pos); + + $fh->setvbuf($buffer_var, _IOLBF, 1024); + + ($readfh, $writefh) = FileHandle::pipe; + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +NOTE: This class is now a front-end to the IO::* classes. + +C<FileHandle::new> creates a C<FileHandle>, which is a reference to a +newly created symbol (see the C<Symbol> package). If it receives any +parameters, they are passed to C<FileHandle::open>; if the open fails, +the C<FileHandle> object is destroyed. Otherwise, it is returned to +the caller. + +C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does. +It requires two parameters, which are passed to C<FileHandle::fdopen>; +if the fdopen fails, the C<FileHandle> object is destroyed. +Otherwise, it is returned to the caller. + +C<FileHandle::open> accepts one parameter or two. With one parameter, +it is just a front end for the built-in C<open> function. With two +parameters, the first parameter is a filename that may include +whitespace or other special characters, and the second parameter is +the open mode, optionally followed by a file permission value. + +If C<FileHandle::open> receives a Perl mode string (">", "+<", etc.) +or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator. + +If C<FileHandle::open> is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C<sysopen> operator. +For convenience, C<FileHandle::import> tries to import the O_XXX +constants from the Fcntl module. If dynamic loading is not available, +this may fail, but the rest of FileHandle will still work. + +C<FileHandle::fdopen> is like C<open> except that its first parameter +is not a filename but rather a file handle name, a FileHandle object, +or a file descriptor number. + +If the C functions fgetpos() and fsetpos() are available, then +C<FileHandle::getpos> returns an opaque value that represents the +current position of the FileHandle, and C<FileHandle::setpos> uses +that value to return to a previously visited position. + +If the C function setvbuf() is available, then C<FileHandle::setvbuf> +sets the buffering policy for the FileHandle. The calling sequence +for the Perl function is the same as its C counterpart, including the +macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer +parameter specifies a scalar variable to use as a buffer. WARNING: A +variable used as a buffer by C<FileHandle::setvbuf> must not be +modified in any way until the FileHandle is closed or until +C<FileHandle::setvbuf> is called again, or memory corruption may +result! + +See L<perlfunc> for complete descriptions of each of the following +supported C<FileHandle> methods, which are just front ends for the +corresponding built-in functions: + + close + fileno + getc + gets + eof + clearerr + seek + tell + +See L<perlvar> for complete descriptions of each of the following +supported C<FileHandle> methods: + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + +Furthermore, for doing normal I/O you might need these: + +=over 4 + +=item $fh->print + +See L<perlfunc/print>. + +=item $fh->printf + +See L<perlfunc/printf>. + +=item $fh->getline + +This works like <$fh> described in L<perlop/"I/O Operators"> +except that it's more readable and can be safely called in a +list context but still returns just one line. + +=item $fh->getlines + +This works like <$fh> when called in a list context to +read all the remaining lines in a file, except that it's more readable. +It will also croak() if accidentally called in a scalar context. + +=back + +There are many other functions available since FileHandle is descended +from IO::File, IO::Seekable, and IO::Handle. Please see those +respective pages for documentation on more functions. + +=head1 SEE ALSO + +The B<IO> extension, +L<perlfunc>, +L<perlop/"I/O Operators">. + +=cut diff --git a/Master/tlpkg/installer/perllib/Getopt/Std.pm b/Master/tlpkg/installer/perllib/Getopt/Std.pm new file mode 100644 index 00000000000..99f93590622 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Getopt/Std.pm @@ -0,0 +1,294 @@ +package Getopt::Std; +require 5.000; +require Exporter; + +=head1 NAME + +getopt, getopts - Process single-character switches with switch clustering + +=head1 SYNOPSIS + + use Getopt::Std; + + getopt('oDI'); # -o, -D & -I take arg. Sets $opt_* as a side effect. + getopt('oDI', \%opts); # -o, -D & -I take arg. Values in %opts + getopts('oif:'); # -o & -i are boolean flags, -f takes an argument + # Sets $opt_* as a side effect. + getopts('oif:', \%opts); # options as above. Values in %opts + +=head1 DESCRIPTION + +The getopt() function processes single-character switches with switch +clustering. Pass one argument which is a string containing all switches +that take an argument. For each switch found, sets $opt_x (where x is the +switch name) to the value of the argument if an argument is expected, +or 1 otherwise. Switches which take an argument don't care whether +there is a space between the switch and the argument. + +The getopts() function is similar, but you should pass to it the list of all +switches to be recognized. If unspecified switches are found on the +command-line, the user will be warned that an unknown option was given. + +Note that, if your code is running under the recommended C<use strict +'vars'> pragma, you will need to declare these package variables +with "our": + + our($opt_x, $opt_y); + +For those of you who don't like additional global variables being created, getopt() +and getopts() will also accept a hash reference as an optional second argument. +Hash keys will be x (where x is the switch name) with key values the value of +the argument or 1 if no argument is specified. + +To allow programs to process arguments that look like switches, but aren't, +both functions will stop processing switches when they see the argument +C<-->. The C<--> will be removed from @ARGV. + +=head1 C<--help> and C<--version> + +If C<-> is not a recognized switch letter, getopts() supports arguments +C<--help> and C<--version>. If C<main::HELP_MESSAGE()> and/or +C<main::VERSION_MESSAGE()> are defined, they are called; the arguments are +the output file handle, the name of option-processing package, its version, +and the switches string. If the subroutines are not defined, an attempt is +made to generate intelligent messages; for best results, define $main::VERSION. + +If embedded documentation (in pod format, see L<perlpod>) is detected +in the script, C<--help> will also show how to access the documentation. + +Note that due to excessive paranoia, if $Getopt::Std::STANDARD_HELP_VERSION +isn't true (the default is false), then the messages are printed on STDERR, +and the processing continues after the messages are printed. This being +the opposite of the standard-conforming behaviour, it is strongly recommended +to set $Getopt::Std::STANDARD_HELP_VERSION to true. + +One can change the output file handle of the messages by setting +$Getopt::Std::OUTPUT_HELP_VERSION. One can print the messages of C<--help> +(without the C<Usage:> line) and C<--version> by calling functions help_mess() +and version_mess() with the switches string as an argument. + +=cut + +@ISA = qw(Exporter); +@EXPORT = qw(getopt getopts); +$VERSION = '1.05'; +# uncomment the next line to disable 1.03-backward compatibility paranoia +# $STANDARD_HELP_VERSION = 1; + +# Process single-character switches with switch clustering. Pass one argument +# which is a string containing all switches that take an argument. For each +# switch found, sets $opt_x (where x is the switch name) to the value of the +# argument, or 1 if no argument. Switches which take an argument don't care +# whether there is a space between the switch and the argument. + +# Usage: +# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect. + +sub getopt (;$$) { + my ($argumentative, $hash) = @_; + $argumentative = '' if !defined $argumentative; + my ($first,$rest); + local $_; + local @EXPORT; + + while (@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) { + ($first,$rest) = ($1,$2); + if (/^--$/) { # early exit if -- + shift @ARGV; + last; + } + if (index($argumentative,$first) >= 0) { + if ($rest ne '') { + shift(@ARGV); + } + else { + shift(@ARGV); + $rest = shift(@ARGV); + } + if (ref $hash) { + $$hash{$first} = $rest; + } + else { + ${"opt_$first"} = $rest; + push( @EXPORT, "\$opt_$first" ); + } + } + else { + if (ref $hash) { + $$hash{$first} = 1; + } + else { + ${"opt_$first"} = 1; + push( @EXPORT, "\$opt_$first" ); + } + if ($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift(@ARGV); + } + } + } + unless (ref $hash) { + local $Exporter::ExportLevel = 1; + import Getopt::Std; + } +} + +sub output_h () { + return $OUTPUT_HELP_VERSION if defined $OUTPUT_HELP_VERSION; + return \*STDOUT if $STANDARD_HELP_VERSION; + return \*STDERR; +} + +sub try_exit () { + exit 0 if $STANDARD_HELP_VERSION; + my $p = __PACKAGE__; + print {output_h()} <<EOM; + [Now continuing due to backward compatibility and excessive paranoia. + See ``perldoc $p'' about \$$p\::STANDARD_HELP_VERSION.] +EOM +} + +sub version_mess ($;$) { + my $args = shift; + my $h = output_h; + if (@_ and defined &main::VERSION_MESSAGE) { + main::VERSION_MESSAGE($h, __PACKAGE__, $VERSION, $args); + } else { + my $v = $main::VERSION; + $v = '[unknown]' unless defined $v; + my $myv = $VERSION; + $myv .= ' [paranoid]' unless $STANDARD_HELP_VERSION; + my $perlv = $]; + $perlv = sprintf "%vd", $^V if $] >= 5.006; + print $h <<EOH; +$0 version $v calling Getopt::Std::getopts (version $myv), +running under Perl version $perlv. +EOH + } +} + +sub help_mess ($;$) { + my $args = shift; + my $h = output_h; + if (@_ and defined &main::HELP_MESSAGE) { + main::HELP_MESSAGE($h, __PACKAGE__, $VERSION, $args); + } else { + my (@witharg) = ($args =~ /(\S)\s*:/g); + my (@rest) = ($args =~ /([^\s:])(?!\s*:)/g); + my ($help, $arg) = ('', ''); + if (@witharg) { + $help .= "\n\tWith arguments: -" . join " -", @witharg; + $arg = "\nSpace is not required between options and their arguments."; + } + if (@rest) { + $help .= "\n\tBoolean (without arguments): -" . join " -", @rest; + } + my ($scr) = ($0 =~ m,([^/\\]+)$,); + print $h <<EOH if @_; # Let the script override this + +Usage: $scr [-OPTIONS [-MORE_OPTIONS]] [--] [PROGRAM_ARG1 ...] +EOH + print $h <<EOH; + +The following single-character options are accepted:$help + +Options may be merged together. -- stops processing of options.$arg +EOH + my $has_pod; + if ( defined $0 and $0 ne '-e' and -f $0 and -r $0 + and open my $script, '<', $0 ) { + while (<$script>) { + $has_pod = 1, last if /^=(pod|head1)/; + } + } + print $h <<EOH if $has_pod; + +For more details run + perldoc -F $0 +EOH + } +} + +# Usage: +# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a +# # side effect. + +sub getopts ($;$) { + my ($argumentative, $hash) = @_; + my (@args,$first,$rest,$exit); + my $errs = 0; + local $_; + local @EXPORT; + + @args = split( / */, $argumentative ); + while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/s) { + ($first,$rest) = ($1,$2); + if (/^--$/) { # early exit if -- + shift @ARGV; + last; + } + my $pos = index($argumentative,$first); + if ($pos >= 0) { + if (defined($args[$pos+1]) and ($args[$pos+1] eq ':')) { + shift(@ARGV); + if ($rest eq '') { + ++$errs unless @ARGV; + $rest = shift(@ARGV); + } + if (ref $hash) { + $$hash{$first} = $rest; + } + else { + ${"opt_$first"} = $rest; + push( @EXPORT, "\$opt_$first" ); + } + } + else { + if (ref $hash) { + $$hash{$first} = 1; + } + else { + ${"opt_$first"} = 1; + push( @EXPORT, "\$opt_$first" ); + } + if ($rest eq '') { + shift(@ARGV); + } + else { + $ARGV[0] = "-$rest"; + } + } + } + else { + if ($first eq '-' and $rest eq 'help') { + version_mess($argumentative, 'main'); + help_mess($argumentative, 'main'); + try_exit(); + shift(@ARGV); + next; + } elsif ($first eq '-' and $rest eq 'version') { + version_mess($argumentative, 'main'); + try_exit(); + shift(@ARGV); + next; + } + warn "Unknown option: $first\n"; + ++$errs; + if ($rest ne '') { + $ARGV[0] = "-$rest"; + } + else { + shift(@ARGV); + } + } + } + unless (ref $hash) { + local $Exporter::ExportLevel = 1; + import Getopt::Std; + } + $errs == 0; +} + +1; diff --git a/Master/tlpkg/installer/perllib/IO.pm b/Master/tlpkg/installer/perllib/IO.pm new file mode 100644 index 00000000000..9fccc3a7356 --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO.pm @@ -0,0 +1,68 @@ +# + +package IO; + +use XSLoader (); +use Carp; +use strict; +use warnings; + +our $VERSION = "1.22"; +XSLoader::load 'IO', $VERSION; + +sub import { + shift; + + warnings::warnif('deprecated', qq{Parameterless "use IO" deprecated}) + if @_ == 0 ; + + my @l = @_ ? @_ : qw(Handle Seekable File Pipe Socket Dir); + + eval join("", map { "require IO::" . (/(\w+)/)[0] . ";\n" } @l) + or croak $@; +} + +1; + +__END__ + +=head1 NAME + +IO - load various IO modules + +=head1 SYNOPSIS + + use IO qw(Handle File); # loads IO modules, here IO::Handle, IO::File + use IO; # DEPRECATED + +=head1 DESCRIPTION + +C<IO> provides a simple mechanism to load several of the IO modules +in one go. The IO modules belonging to the core are: + + IO::Handle + IO::Seekable + IO::File + IO::Pipe + IO::Socket + IO::Dir + IO::Select + IO::Poll + +Some other IO modules don't belong to the perl core but can be loaded +as well if they have been installed from CPAN. You can discover which +ones exist by searching for "^IO::" on http://search.cpan.org. + +For more information on any of these modules, please see its respective +documentation. + +=head1 DEPRECATED + + use IO; # loads all the modules listed below + +The loaded modules are IO::Handle, IO::Seekable, IO::File, IO::Pipe, +IO::Socket, IO::Dir. You should instead explicitly import the IO +modules you want. + +=cut + diff --git a/Master/tlpkg/installer/perllib/IO/Dir.pm b/Master/tlpkg/installer/perllib/IO/Dir.pm new file mode 100644 index 00000000000..fccd02c088a --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/Dir.pm @@ -0,0 +1,246 @@ +# IO::Dir.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Dir; + +use 5.006; + +use strict; +use Carp; +use Symbol; +use Exporter; +use IO::File; +our(@ISA, $VERSION, @EXPORT_OK); +use Tie::Hash; +use File::stat; +use File::Spec; + +@ISA = qw(Tie::Hash Exporter); +$VERSION = "1.05"; +$VERSION = eval $VERSION; +@EXPORT_OK = qw(DIR_UNLINK); + +sub DIR_UNLINK () { 1 } + +sub new { + @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]'; + my $class = shift; + my $dh = gensym; + if (@_) { + IO::Dir::open($dh, $_[0]) + or return undef; + } + bless $dh, $class; +} + +sub DESTROY { + my ($dh) = @_; + closedir($dh); +} + +sub open { + @_ == 2 or croak 'usage: $dh->open(DIRNAME)'; + my ($dh, $dirname) = @_; + return undef + unless opendir($dh, $dirname); + # a dir name should always have a ":" in it; assume dirname is + # in current directory + $dirname = ':' . $dirname if ( ($^O eq 'MacOS') && ($dirname !~ /:/) ); + ${*$dh}{io_dir_path} = $dirname; + 1; +} + +sub close { + @_ == 1 or croak 'usage: $dh->close()'; + my ($dh) = @_; + closedir($dh); +} + +sub read { + @_ == 1 or croak 'usage: $dh->read()'; + my ($dh) = @_; + readdir($dh); +} + +sub seek { + @_ == 2 or croak 'usage: $dh->seek(POS)'; + my ($dh,$pos) = @_; + seekdir($dh,$pos); +} + +sub tell { + @_ == 1 or croak 'usage: $dh->tell()'; + my ($dh) = @_; + telldir($dh); +} + +sub rewind { + @_ == 1 or croak 'usage: $dh->rewind()'; + my ($dh) = @_; + rewinddir($dh); +} + +sub TIEHASH { + my($class,$dir,$options) = @_; + + my $dh = $class->new($dir) + or return undef; + + $options ||= 0; + + ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK; + $dh; +} + +sub FIRSTKEY { + my($dh) = @_; + $dh->rewind; + scalar $dh->read; +} + +sub NEXTKEY { + my($dh) = @_; + scalar $dh->read; +} + +sub EXISTS { + my($dh,$key) = @_; + -e File::Spec->catfile(${*$dh}{io_dir_path}, $key); +} + +sub FETCH { + my($dh,$key) = @_; + &lstat(File::Spec->catfile(${*$dh}{io_dir_path}, $key)); +} + +sub STORE { + my($dh,$key,$data) = @_; + my($atime,$mtime) = ref($data) ? @$data : ($data,$data); + my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key); + unless(-e $file) { + my $io = IO::File->new($file,O_CREAT | O_RDWR); + $io->close if $io; + } + utime($atime,$mtime, $file); +} + +sub DELETE { + my($dh,$key) = @_; + + # Only unlink if unlink-ing is enabled + return 0 + unless ${*$dh}{io_dir_unlink}; + + my $file = File::Spec->catfile(${*$dh}{io_dir_path}, $key); + + -d $file + ? rmdir($file) + : unlink($file); +} + +1; + +__END__ + +=head1 NAME + +IO::Dir - supply object methods for directory handles + +=head1 SYNOPSIS + + use IO::Dir; + $d = IO::Dir->new("."); + if (defined $d) { + while (defined($_ = $d->read)) { something($_); } + $d->rewind; + while (defined($_ = $d->read)) { something_else($_); } + undef $d; + } + + tie %dir, 'IO::Dir', "."; + foreach (keys %dir) { + print $_, " " , $dir{$_}->size,"\n"; + } + +=head1 DESCRIPTION + +The C<IO::Dir> package provides two interfaces to perl's directory reading +routines. + +The first interface is an object approach. C<IO::Dir> provides an object +constructor and methods, which are just wrappers around perl's built in +directory reading routines. + +=over 4 + +=item new ( [ DIRNAME ] ) + +C<new> is the constructor for C<IO::Dir> objects. It accepts one optional +argument which, if given, C<new> will pass to C<open> + +=back + +The following methods are wrappers for the directory related functions built +into perl (the trailing `dir' has been removed from the names). See L<perlfunc> +for details of these functions. + +=over 4 + +=item open ( DIRNAME ) + +=item read () + +=item seek ( POS ) + +=item tell () + +=item rewind () + +=item close () + +=back + +C<IO::Dir> also provides an interface to reading directories via a tied +hash. The tied hash extends the interface beyond just the directory +reading routines by the use of C<lstat>, from the C<File::stat> package, +C<unlink>, C<rmdir> and C<utime>. + +=over 4 + +=item tie %hash, 'IO::Dir', DIRNAME [, OPTIONS ] + +=back + +The keys of the hash will be the names of the entries in the directory. +Reading a value from the hash will be the result of calling +C<File::stat::lstat>. Deleting an element from the hash will +delete the corresponding file or subdirectory, +provided that C<DIR_UNLINK> is included in the C<OPTIONS>. + +Assigning to an entry in the hash will cause the time stamps of the file +to be modified. If the file does not exist then it will be created. Assigning +a single integer to a hash element will cause both the access and +modification times to be changed to that value. Alternatively a reference to +an array of two values can be passed. The first array element will be used to +set the access time and the second element will be used to set the modification +time. + +=head1 SEE ALSO + +L<File::stat> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-2003 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/IO/File.pm b/Master/tlpkg/installer/perllib/IO/File.pm new file mode 100644 index 00000000000..e7cdbbed6d7 --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/File.pm @@ -0,0 +1,208 @@ +# + +package IO::File; + +=head1 NAME + +IO::File - supply object methods for filehandles + +=head1 SYNOPSIS + + use IO::File; + + $fh = new IO::File; + if ($fh->open("< file")) { + print <$fh>; + $fh->close; + } + + $fh = new IO::File "> file"; + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = new IO::File "file", "r"; + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $fh = new IO::File "file", O_WRONLY|O_APPEND; + if (defined $fh) { + print $fh "corge\n"; + + $pos = $fh->getpos; + $fh->setpos($pos); + + undef $fh; # automatically closes the file + } + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends +these classes with methods that are specific to file handles. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( FILENAME [,MODE [,PERMS]] ) + +Creates an C<IO::File>. If it receives any parameters, they are passed to +the method C<open>; if the open fails, the object is destroyed. Otherwise, +it is returned to the caller. + +=item new_tmpfile + +Creates an C<IO::File> opened for read/write on a newly created temporary +file. On systems where this is possible, the temporary file is anonymous +(i.e. it is unlinked after creation, but held open). If the temporary +file cannot be created or opened, the C<IO::File> object is destroyed. +Otherwise, it is returned to the caller. + +=back + +=head1 METHODS + +=over 4 + +=item open( FILENAME [,MODE [,PERMS]] ) + +=item open( FILENAME, IOLAYERS ) + +C<open> accepts one, two or three parameters. With one parameter, +it is just a front end for the built-in C<open> function. With two or three +parameters, the first parameter is a filename that may include +whitespace or other special characters, and the second parameter is +the open mode, optionally followed by a file permission value. + +If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.) +or an ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator (but protects any special characters). + +If C<IO::File::open> is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C<sysopen> operator. +The permissions default to 0666. + +If C<IO::File::open> is given a mode that includes the C<:> character, +it passes all the three arguments to the three-argument C<open> operator. + +For convenience, C<IO::File> exports the O_XXX constants from the +Fcntl module, if this module is available. + +=item binmode( [LAYER] ) + +C<binmode> sets C<binmode> on the underlying C<IO> object, as documented +in C<perldoc -f binmode>. + +C<binmode> accepts one optional parameter, which is the layer to be +passed on to the C<binmode> call. + +=back + +=head1 NOTE + +Some operating systems may perform C<IO::File::new()> or C<IO::File::open()> +on a directory without errors. This behavior is not portable and not +suggested for use. Using C<opendir()> and C<readdir()> or C<IO::Dir> are +suggested instead. + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle>, +L<IO::Seekable>, +L<IO::Dir> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. + +=cut + +use 5.006_001; +use strict; +our($VERSION, @EXPORT, @EXPORT_OK, @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO::Seekable; +use File::Spec; + +require Exporter; + +@ISA = qw(IO::Handle IO::Seekable Exporter); + +$VERSION = "1.13"; + +@EXPORT = @IO::Seekable::EXPORT; + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + +################################################ +## Constructor +## + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::File"; + @_ >= 0 && @_ <= 3 + or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]"; + my $fh = $class->SUPER::new(); + if (@_) { + $fh->open(@_) + or return undef; + } + $fh; +} + +################################################ +## Open +## + +sub open { + @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; + my ($fh, $file) = @_; + if (@_ > 2) { + my ($mode, $perms) = @_[2, 3]; + if ($mode =~ /^\d+$/) { + defined $perms or $perms = 0666; + return sysopen($fh, $file, $mode, $perms); + } elsif ($mode =~ /:/) { + return open($fh, $mode, $file) if @_ == 3; + croak 'usage: $fh->open(FILENAME, IOLAYERS)'; + } + if (defined($file) && length($file) + && ! File::Spec->file_name_is_absolute($file)) + { + $file = File::Spec->rel2abs($file); + } + $file = IO::Handle::_open_mode_string($mode) . " $file\0"; + } + open($fh, $file); +} + +################################################ +## Binmode +## + +sub binmode { + ( @_ == 1 or @_ == 2 ) or croak 'usage $fh->binmode([LAYER])'; + + my($fh, $layer) = @_; + + return binmode $$fh unless $layer; + return binmode $$fh, $layer; +} + +1; diff --git a/Master/tlpkg/installer/perllib/IO/Handle.pm b/Master/tlpkg/installer/perllib/IO/Handle.pm new file mode 100644 index 00000000000..329d26ad198 --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/Handle.pm @@ -0,0 +1,625 @@ +package IO::Handle; + +=head1 NAME + +IO::Handle - supply object methods for I/O handles + +=head1 SYNOPSIS + + use IO::Handle; + + $io = new IO::Handle; + if ($io->fdopen(fileno(STDIN),"r")) { + print $io->getline; + $io->close; + } + + $io = new IO::Handle; + if ($io->fdopen(fileno(STDOUT),"w")) { + $io->print("Some text\n"); + } + + # setvbuf is not available by default on Perls 5.8.0 and later. + use IO::Handle '_IOLBF'; + $io->setvbuf($buffer_var, _IOLBF, 1024); + + undef $io; # automatically closes the file if it's open + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C<IO::Handle> is the base class for all other IO handle classes. It is +not intended that objects of C<IO::Handle> would be created directly, +but instead C<IO::Handle> is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C<FileHandle> package, then I suggest you read the documentation +for C<IO::File> too. + +=head1 CONSTRUCTOR + +=over 4 + +=item new () + +Creates a new C<IO::Handle> object. + +=item new_from_fd ( FD, MODE ) + +Creates an C<IO::Handle> like C<new> does. +It requires two parameters, which are passed to the method C<fdopen>; +if the fdopen fails, the object is destroyed. Otherwise, it is returned +to the caller. + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Handle> methods, which are just front ends for the +corresponding built-in functions: + + $io->close + $io->eof + $io->fileno + $io->format_write( [FORMAT_NAME] ) + $io->getc + $io->read ( BUF, LEN, [OFFSET] ) + $io->print ( ARGS ) + $io->printf ( FMT, [ARGS] ) + $io->stat + $io->sysread ( BUF, LEN, [OFFSET] ) + $io->syswrite ( BUF, [LEN, [OFFSET]] ) + $io->truncate ( LEN ) + +See L<perlvar> for complete descriptions of each of the following +supported C<IO::Handle> methods. All of them return the previous +value of the attribute and takes an optional single argument that when +given will set the value. If no argument is given the previous value +is unchanged (except for $io->autoflush will actually turn ON +autoflush by default). + + $io->autoflush ( [BOOL] ) $| + $io->format_page_number( [NUM] ) $% + $io->format_lines_per_page( [NUM] ) $= + $io->format_lines_left( [NUM] ) $- + $io->format_name( [STR] ) $~ + $io->format_top_name( [STR] ) $^ + $io->input_line_number( [NUM]) $. + +The following methods are not supported on a per-filehandle basis. + + IO::Handle->format_line_break_characters( [STR] ) $: + IO::Handle->format_formfeed( [STR]) $^L + IO::Handle->output_field_separator( [STR] ) $, + IO::Handle->output_record_separator( [STR] ) $\ + + IO::Handle->input_record_separator( [STR] ) $/ + +Furthermore, for doing normal I/O you might need these: + +=over 4 + +=item $io->fdopen ( FD, MODE ) + +C<fdopen> is like an ordinary C<open> except that its first parameter +is not a filename but rather a file handle name, an IO::Handle object, +or a file descriptor number. + +=item $io->opened + +Returns true if the object is currently a valid file descriptor, false +otherwise. + +=item $io->getline + +This works like <$io> described in L<perlop/"I/O Operators"> +except that it's more readable and can be safely called in a +list context but still returns just one line. If used as the conditional ++within a C<while> or C-style C<for> loop, however, you will need to ++emulate the functionality of <$io> with C<< defined($_ = $io->getline) >>. + +=item $io->getlines + +This works like <$io> when called in a list context to read all +the remaining lines in a file, except that it's more readable. +It will also croak() if accidentally called in a scalar context. + +=item $io->ungetc ( ORD ) + +Pushes a character with the given ordinal value back onto the given +handle's input stream. Only one character of pushback per handle is +guaranteed. + +=item $io->write ( BUF, LEN [, OFFSET ] ) + +This C<write> is like C<write> found in C, that is it is the +opposite of read. The wrapper for the perl C<write> function is +called C<format_write>. + +=item $io->error + +Returns a true value if the given handle has experienced any errors +since it was opened or since the last call to C<clearerr>, or if the +handle is invalid. It only returns false for a valid handle with no +outstanding errors. + +=item $io->clearerr + +Clear the given handle's error indicator. Returns -1 if the handle is +invalid, 0 otherwise. + +=item $io->sync + +C<sync> synchronizes a file's in-memory state with that on the +physical medium. C<sync> does not operate at the perlio api level, but +operates on the file descriptor (similar to sysread, sysseek and +systell). This means that any data held at the perlio api level will not +be synchronized. To synchronize data that is buffered at the perlio api +level you must use the flush method. C<sync> is not implemented on all +platforms. Returns "0 but true" on success, C<undef> on error, C<undef> +for an invalid handle. See L<fsync(3c)>. + +=item $io->flush + +C<flush> causes perl to flush any buffered data at the perlio api level. +Any unread data in the buffer will be discarded, and any unwritten data +will be written to the underlying file descriptor. Returns "0 but true" +on success, C<undef> on error. + +=item $io->printflush ( ARGS ) + +Turns on autoflush, print ARGS and then restores the autoflush status of the +C<IO::Handle> object. Returns the return value from print. + +=item $io->blocking ( [ BOOL ] ) + +If called with an argument C<blocking> will turn on non-blocking IO if +C<BOOL> is false, and turn it off if C<BOOL> is true. + +C<blocking> will return the value of the previous setting, or the +current setting if C<BOOL> is not given. + +If an error occurs C<blocking> will return undef and C<$!> will be set. + +=back + + +If the C functions setbuf() and/or setvbuf() are available, then +C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering +policy for an IO::Handle. The calling sequences for the Perl functions +are the same as their C counterparts--including the constants C<_IOFBF>, +C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter +specifies a scalar variable to use as a buffer. You should only +change the buffer before any I/O, or immediately after calling flush. + +WARNING: The IO::Handle::setvbuf() is not available by default on +Perls 5.8.0 and later because setvbuf() is rather specific to using +the stdio library, while Perl prefers the new perlio subsystem instead. + +WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<must not +be modified> in any way until the IO::Handle is closed or C<setbuf> or +C<setvbuf> is called again, or memory corruption may result! Remember that +the order of global destruction is undefined, so even if your buffer +variable remains in scope until program termination, it may be undefined +before the file IO::Handle is closed. Note that you need to import the +constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf +returns nothing. setvbuf returns "0 but true", on success, C<undef> on +failure. + +Lastly, there is a special method for working under B<-T> and setuid/gid +scripts: + +=over 4 + +=item $io->untaint + +Marks the object as taint-clean, and as such data read from it will also +be considered taint-clean. Note that this is a very trusting action to +take, and appropriate consideration for the data source and potential +vulnerability should be kept in mind. Returns 0 on success, -1 if setting +the taint-clean flag failed. (eg invalid handle) + +=back + +=head1 NOTE + +An C<IO::Handle> object is a reference to a symbol/GLOB reference (see +the C<Symbol> package). Some modules that +inherit from C<IO::Handle> may want to keep object related variables +in the hash table part of the GLOB. In an attempt to prevent modules +trampling on each other I propose the that any such module should prefix +its variables with its own name separated by _'s. For example the IO::Socket +module keeps a C<timeout> variable in 'io_socket_timeout'. + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::File> + +=head1 BUGS + +Due to backwards compatibility, all filehandles resemble objects +of class C<IO::Handle>, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C<IO::Handle> and inherit those methods. + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> + +=cut + +use 5.006_001; +use strict; +our($VERSION, @EXPORT_OK, @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO (); # Load the XS module + +require Exporter; +@ISA = qw(Exporter); + +$VERSION = "1.25"; +$VERSION = eval $VERSION; + +@EXPORT_OK = qw( + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + format_write + + print + printf + getline + getlines + + printflush + flush + + SEEK_SET + SEEK_CUR + SEEK_END + _IOFBF + _IOLBF + _IONBF +); + +################################################ +## Constructors, destructors. +## + +sub new { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 1 or croak "usage: new $class"; + my $io = gensym; + bless $io, $class; +} + +sub new_from_fd { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; + my $io = gensym; + shift; + IO::Handle::fdopen($io, @_) + or return undef; + bless $io, $class; +} + +# +# There is no need for DESTROY to do anything, because when the +# last reference to an IO object is gone, Perl automatically +# closes its associated files (if any). However, to avoid any +# attempts to autoload DESTROY, we here define it to do nothing. +# +sub DESTROY {} + + +################################################ +## Open and close. +## + +sub _open_mode_string { + my ($mode) = @_; + $mode =~ /^\+?(<|>>?)$/ + or $mode =~ s/^r(\+?)$/$1</ + or $mode =~ s/^w(\+?)$/$1>/ + or $mode =~ s/^a(\+?)$/$1>>/ + or croak "IO::Handle: bad open mode: $mode"; + $mode; +} + +sub fdopen { + @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)'; + my ($io, $fd, $mode) = @_; + local(*GLOB); + + if (ref($fd) && "".$fd =~ /GLOB\(/o) { + # It's a glob reference; Alias it as we cannot get name of anon GLOBs + my $n = qualify(*GLOB); + *GLOB = *{*$fd}; + $fd = $n; + } elsif ($fd =~ m#^\d+$#) { + # It's an FD number; prefix with "=". + $fd = "=$fd"; + } + + open($io, _open_mode_string($mode) . '&' . $fd) + ? $io : undef; +} + +sub close { + @_ == 1 or croak 'usage: $io->close()'; + my($io) = @_; + + close($io); +} + +################################################ +## Normal I/O functions. +## + +# flock +# select + +sub opened { + @_ == 1 or croak 'usage: $io->opened()'; + defined fileno($_[0]); +} + +sub fileno { + @_ == 1 or croak 'usage: $io->fileno()'; + fileno($_[0]); +} + +sub getc { + @_ == 1 or croak 'usage: $io->getc()'; + getc($_[0]); +} + +sub eof { + @_ == 1 or croak 'usage: $io->eof()'; + eof($_[0]); +} + +sub print { + @_ or croak 'usage: $io->print(ARGS)'; + my $this = shift; + print $this @_; +} + +sub printf { + @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])'; + my $this = shift; + printf $this @_; +} + +sub getline { + @_ == 1 or croak 'usage: $io->getline()'; + my $this = shift; + return scalar <$this>; +} + +*gets = \&getline; # deprecated + +sub getlines { + @_ == 1 or croak 'usage: $io->getlines()'; + wantarray or + croak 'Can\'t call $io->getlines in a scalar context, use $io->getline'; + my $this = shift; + return <$this>; +} + +sub truncate { + @_ == 2 or croak 'usage: $io->truncate(LEN)'; + truncate($_[0], $_[1]); +} + +sub read { + @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])'; + read($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub sysread { + @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])'; + sysread($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub write { + @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])'; + local($\) = ""; + $_[2] = length($_[1]) unless defined $_[2]; + print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); +} + +sub syswrite { + @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; + if (defined($_[2])) { + syswrite($_[0], $_[1], $_[2], $_[3] || 0); + } else { + syswrite($_[0], $_[1]); + } +} + +sub stat { + @_ == 1 or croak 'usage: $io->stat()'; + stat($_[0]); +} + +################################################ +## State modification functions. +## + +sub autoflush { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $|; + $| = @_ > 1 ? $_[1] : 1; + $prev; +} + +sub output_field_separator { + carp "output_field_separator is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $,; + $, = $_[1] if @_ > 1; + $prev; +} + +sub output_record_separator { + carp "output_record_separator is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $\; + $\ = $_[1] if @_ > 1; + $prev; +} + +sub input_record_separator { + carp "input_record_separator is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $/; + $/ = $_[1] if @_ > 1; + $prev; +} + +sub input_line_number { + local $.; + () = tell qualify($_[0], caller) if ref($_[0]); + my $prev = $.; + $. = $_[1] if @_ > 1; + $prev; +} + +sub format_page_number { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $%; + $% = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_per_page { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $=; + $= = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_left { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $-; + $- = $_[1] if @_ > 1; + $prev; +} + +sub format_name { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $~; + $~ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_top_name { + my $old; + $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $^; + $^ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_line_break_characters { + carp "format_line_break_characters is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $:; + $: = $_[1] if @_ > 1; + $prev; +} + +sub format_formfeed { + carp "format_formfeed is not supported on a per-handle basis" + if ref($_[0]); + my $prev = $^L; + $^L = $_[1] if @_ > 1; + $prev; +} + +sub formline { + my $io = shift; + my $picture = shift; + local($^A) = $^A; + local($\) = ""; + formline($picture, @_); + print $io $^A; +} + +sub format_write { + @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )'; + if (@_ == 2) { + my ($io, $fmt) = @_; + my $oldfmt = $io->format_name($fmt); + CORE::write($io); + $io->format_name($oldfmt); + } else { + CORE::write($_[0]); + } +} + +# XXX undocumented +sub fcntl { + @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );'; + my ($io, $op) = @_; + return fcntl($io, $op, $_[2]); +} + +# XXX undocumented +sub ioctl { + @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );'; + my ($io, $op) = @_; + return ioctl($io, $op, $_[2]); +} + +# this sub is for compatability with older releases of IO that used +# a sub called constant to detemine if a constant existed -- GMB +# +# The SEEK_* and _IO?BF constants were the only constants at that time +# any new code should just chech defined(&CONSTANT_NAME) + +sub constant { + no strict 'refs'; + my $name = shift; + (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name}) + ? &{$name}() : undef; +} + + +# so that flush.pl can be deprecated + +sub printflush { + my $io = shift; + my $old; + $old = new SelectSaver qualify($io, caller) if ref($io); + local $| = 1; + if(ref($io)) { + print $io @_; + } + else { + print @_; + } +} + +1; diff --git a/Master/tlpkg/installer/perllib/IO/Pipe.pm b/Master/tlpkg/installer/perllib/IO/Pipe.pm new file mode 100644 index 00000000000..827cc48bfcd --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/Pipe.pm @@ -0,0 +1,257 @@ +# IO::Pipe.pm +# +# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Pipe; + +use 5.006_001; + +use IO::Handle; +use strict; +our($VERSION); +use Carp; +use Symbol; + +$VERSION = "1.13"; + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::Pipe"; + @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; + + my $me = bless gensym(), $class; + + my($readfh,$writefh) = @_ ? @_ : $me->handles; + + pipe($readfh, $writefh) + or return undef; + + @{*$me} = ($readfh, $writefh); + + $me; +} + +sub handles { + @_ == 1 or croak 'usage: $pipe->handles()'; + (IO::Pipe::End->new(), IO::Pipe::End->new()); +} + +my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32'; + +sub _doit { + my $me = shift; + my $rw = shift; + + my $pid = $do_spawn ? 0 : fork(); + + if($pid) { # Parent + return $pid; + } + elsif(defined $pid) { # Child or spawn + my $fh; + my $io = $rw ? \*STDIN : \*STDOUT; + my ($mode, $save) = $rw ? "r" : "w"; + if ($do_spawn) { + require Fcntl; + $save = IO::Handle->new_from_fd($io, $mode); + my $handle = shift; + # Close in child: + unless ($^O eq 'MSWin32') { + fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; + } + $fh = $rw ? ${*$me}[0] : ${*$me}[1]; + } else { + shift; + $fh = $rw ? $me->reader() : $me->writer(); # close the other end + } + bless $io, "IO::Handle"; + $io->fdopen($fh, $mode); + $fh->close; + + if ($do_spawn) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + my $err = $!; + + $io->fdopen($save, $mode); + $save->close or croak "Cannot close $!"; + croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; + return $pid; + } else { + exec @_ or + croak "IO::Pipe: Cannot exec: $!"; + } + } + else { + croak "IO::Pipe: Cannot fork: $!"; + } + + # NOT Reached +} + +sub reader { + @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )'; + my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + + my $fh = ${*$me}[0]; + my $pid; + $pid = $me->_doit(0, $fh, @_) + if(@_); + + close ${*$me}[1]; + bless $me, ref($fh); + *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"r") + unless defined($me->fileno); + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +sub writer { + @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )'; + my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + + my $fh = ${*$me}[1]; + my $pid; + $pid = $me->_doit(1, $fh, @_) + if(@_); + + close ${*$me}[0]; + bless $me, ref($fh); + *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"w") + unless defined($me->fileno); + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +package IO::Pipe::End; + +our(@ISA); + +@ISA = qw(IO::Handle); + +sub close { + my $fh = shift; + my $r = $fh->SUPER::close(@_); + + waitpid(${*$fh}{'io_pipe_pid'},0) + if(defined ${*$fh}{'io_pipe_pid'}); + + $r; +} + +1; + +__END__ + +=head1 NAME + +IO::Pipe - supply object methods for pipes + +=head1 SYNOPSIS + + use IO::Pipe; + + $pipe = new IO::Pipe; + + if($pid = fork()) { # Parent + $pipe->reader(); + + while(<$pipe>) { + ... + } + + } + elsif(defined $pid) { # Child + $pipe->writer(); + + print $pipe ... + } + + or + + $pipe = new IO::Pipe; + + $pipe->reader(qw(ls -l)); + + while(<$pipe>) { + ... + } + +=head1 DESCRIPTION + +C<IO::Pipe> provides an interface to creating pipes between +processes. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [READER, WRITER] ) + +Creates an C<IO::Pipe>, which is a reference to a newly created symbol +(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two +arguments, which should be objects blessed into C<IO::Handle>, or a +subclass thereof. These two objects will be used for the system call +to C<pipe>. If no arguments are given then method C<handles> is called +on the new C<IO::Pipe> object. + +These two handles are held in the array part of the GLOB until either +C<reader> or C<writer> is called. + +=back + +=head1 METHODS + +=over 4 + +=item reader ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the reading end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item writer ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the writing end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item handles () + +This method is called during construction by C<IO::Pipe::new> +on the newly created C<IO::Pipe> object. It returns an array of two objects +blessed into C<IO::Pipe::End>, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L<IO::Handle> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/IO/Poll.pm b/Master/tlpkg/installer/perllib/IO/Poll.pm new file mode 100644 index 00000000000..e7fb0135069 --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/Poll.pm @@ -0,0 +1,209 @@ + +# IO::Poll.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Poll; + +use strict; +use IO::Handle; +use Exporter (); +our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); + +@ISA = qw(Exporter); +$VERSION = "0.07"; + +@EXPORT = qw( POLLIN + POLLOUT + POLLERR + POLLHUP + POLLNVAL + ); + +@EXPORT_OK = qw( + POLLPRI + POLLRDNORM + POLLWRNORM + POLLRDBAND + POLLWRBAND + POLLNORM + ); + +# [0] maps fd's to requested masks +# [1] maps fd's to returned masks +# [2] maps fd's to handles +sub new { + my $class = shift; + + my $self = bless [{},{},{}], $class; + + $self; +} + +sub mask { + my $self = shift; + my $io = shift; + my $fd = fileno($io); + return unless defined $fd; + if (@_) { + my $mask = shift; + if($mask) { + $self->[0]{$fd}{$io} = $mask; # the error events are always returned + $self->[1]{$fd} = 0; # output mask + $self->[2]{$io} = $io; # remember handle + } else { + delete $self->[0]{$fd}{$io}; + unless(%{$self->[0]{$fd}}) { + # We no longer have any handles for this FD + delete $self->[1]{$fd}; + delete $self->[0]{$fd}; + } + delete $self->[2]{$io}; + } + } + + return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; + return $self->[0]{$fd}{$io}; +} + + +sub poll { + my($self,$timeout) = @_; + + $self->[1] = {}; + + my($fd,$mask,$iom); + my @poll = (); + + while(($fd,$iom) = each %{$self->[0]}) { + $mask = 0; + $mask |= $_ for values(%$iom); + push(@poll,$fd => $mask); + } + + my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; + + return $ret + unless $ret > 0; + + while(@poll) { + my($fd,$got) = splice(@poll,0,2); + $self->[1]{$fd} = $got if $got; + } + + return $ret; +} + +sub events { + my $self = shift; + my $io = shift; + my $fd = fileno($io); + exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} + ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) + : 0; +} + +sub remove { + my $self = shift; + my $io = shift; + $self->mask($io,0); +} + +sub handles { + my $self = shift; + return values %{$self->[2]} unless @_; + + my $events = shift || 0; + my($fd,$ev,$io,$mask); + my @handles = (); + + while(($fd,$ev) = each %{$self->[1]}) { + while (($io,$mask) = each %{$self->[0]{$fd}}) { + $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these + push @handles,$self->[2]{$io} if ($ev & $mask) & $events; + } + } + return @handles; +} + +1; + +__END__ + +=head1 NAME + +IO::Poll - Object interface to system poll call + +=head1 SYNOPSIS + + use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP); + + $poll = new IO::Poll; + + $poll->mask($input_handle => POLLIN); + $poll->mask($output_handle => POLLOUT); + + $poll->poll($timeout); + + $ev = $poll->events($input); + +=head1 DESCRIPTION + +C<IO::Poll> is a simple interface to the system level poll routine. + +=head1 METHODS + +=over 4 + +=item mask ( IO [, EVENT_MASK ] ) + +If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the +list of file descriptors and the next call to poll will check for +any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be +removed from the list of file descriptors. + +If EVENT_MASK is not given then the return value will be the current +event mask value for IO. + +=item poll ( [ TIMEOUT ] ) + +Call the system level poll routine. If TIMEOUT is not specified then the +call will block. Returns the number of handles which had events +happen, or -1 on error. + +=item events ( IO ) + +Returns the event mask which represents the events that happened on IO +during the last call to C<poll>. + +=item remove ( IO ) + +Remove IO from the list of file descriptors for the next poll. + +=item handles( [ EVENT_MASK ] ) + +Returns a list of handles. If EVENT_MASK is not given then a list of all +handles known will be returned. If EVENT_MASK is given then a list +of handles will be returned which had one of the events specified by +EVENT_MASK happen during the last call ti C<poll> + +=back + +=head1 SEE ALSO + +L<poll(2)>, L<IO::Handle>, L<IO::Select> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/IO/Seekable.pm b/Master/tlpkg/installer/perllib/IO/Seekable.pm new file mode 100644 index 00000000000..db1effda287 --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/Seekable.pm @@ -0,0 +1,128 @@ +# + +package IO::Seekable; + +=head1 NAME + +IO::Seekable - supply seek based methods for I/O objects + +=head1 SYNOPSIS + + use IO::Seekable; + package IO::Something; + @ISA = qw(IO::Seekable); + +=head1 DESCRIPTION + +C<IO::Seekable> does not have a constructor of its own as it is intended to +be inherited by other C<IO::Handle> based objects. It provides methods +which allow seeking of the file descriptors. + +=over 4 + +=item $io->getpos + +Returns an opaque value that represents the current position of the +IO::File, or C<undef> if this is not possible (eg an unseekable stream such +as a terminal, pipe or socket). If the fgetpos() function is available in +your C library it is used to implements getpos, else perl emulates getpos +using C's ftell() function. + +=item $io->setpos + +Uses the value of a previous getpos call to return to a previously visited +position. Returns "0 but true" on success, C<undef> on failure. + +=back + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Seekable> methods, which are just front ends for the +corresponding built-in functions: + +=over 4 + +=item $io->seek ( POS, WHENCE ) + +Seek the IO::File to position POS, relative to WHENCE: + +=over 8 + +=item WHENCE=0 (SEEK_SET) + +POS is absolute position. (Seek relative to the start of the file) + +=item WHENCE=1 (SEEK_CUR) + +POS is an offset from the current position. (Seek relative to current) + +=item WHENCE=2 (SEEK_END) + +POS is an offset from the end of the file. (Seek relative to end) + +=back + +The SEEK_* constants can be imported from the C<Fcntl> module if you +don't wish to use the numbers C<0> C<1> or C<2> in your code. + +Returns C<1> upon success, C<0> otherwise. + +=item $io->sysseek( POS, WHENCE ) + +Similar to $io->seek, but sets the IO::File's position using the system +call lseek(2) directly, so will confuse most perl IO operators except +sysread and syswrite (see L<perlfunc> for full details) + +Returns the new position, or C<undef> on failure. A position +of zero is returned as the string C<"0 but true"> + +=item $io->tell + +Returns the IO::File's current position, or -1 on error. + +=back + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle> +L<IO::File> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt> + +=cut + +use 5.006_001; +use Carp; +use strict; +our($VERSION, @EXPORT, @ISA); +use IO::Handle (); +# XXX we can't get these from IO::Handle or we'll get prototype +# mismatch warnings on C<use POSIX; use IO::File;> :-( +use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); +require Exporter; + +@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); +@ISA = qw(Exporter); + +$VERSION = "1.10"; +$VERSION = eval $VERSION; + +sub seek { + @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; + seek($_[0], $_[1], $_[2]); +} + +sub sysseek { + @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)'; + sysseek($_[0], $_[1], $_[2]); +} + +sub tell { + @_ == 1 or croak 'usage: $io->tell()'; + tell($_[0]); +} + +1; diff --git a/Master/tlpkg/installer/perllib/IO/Select.pm b/Master/tlpkg/installer/perllib/IO/Select.pm new file mode 100644 index 00000000000..fc05fe70e9c --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/Select.pm @@ -0,0 +1,381 @@ +# IO::Select.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Select; + +use strict; +use warnings::register; +use vars qw($VERSION @ISA); +require Exporter; + +$VERSION = "1.17"; + +@ISA = qw(Exporter); # This is only so we can do version checking + +sub VEC_BITS () {0} +sub FD_COUNT () {1} +sub FIRST_FD () {2} + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + + my $vec = bless [undef,0], $type; + + $vec->add(@_) + if @_; + + $vec; +} + +sub add +{ + shift->_update('add', @_); +} + + +sub remove +{ + shift->_update('remove', @_); +} + + +sub exists +{ + my $vec = shift; + my $fno = $vec->_fileno(shift); + return undef unless defined $fno; + $vec->[$fno + FIRST_FD]; +} + + +sub _fileno +{ + my($self, $f) = @_; + return unless defined $f; + $f = $f->[0] if ref($f) eq 'ARRAY'; + ($f =~ /^\d+$/) ? $f : fileno($f); +} + +sub _update +{ + my $vec = shift; + my $add = shift eq 'add'; + + my $bits = $vec->[VEC_BITS]; + $bits = '' unless defined $bits; + + my $count = 0; + my $f; + foreach $f (@_) + { + my $fn = $vec->_fileno($f); + next unless defined $fn; + my $i = $fn + FIRST_FD; + if ($add) { + if (defined $vec->[$i]) { + $vec->[$i] = $f; # if array rest might be different, so we update + next; + } + $vec->[FD_COUNT]++; + vec($bits, $fn, 1) = 1; + $vec->[$i] = $f; + } else { # remove + next unless defined $vec->[$i]; + $vec->[FD_COUNT]--; + vec($bits, $fn, 1) = 0; + $vec->[$i] = undef; + } + $count++; + } + $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; + $count; +} + +sub can_read +{ + my $vec = shift; + my $timeout = shift; + my $r = $vec->[VEC_BITS]; + + defined($r) && (select($r,undef,undef,$timeout) > 0) + ? handles($vec, $r) + : (); +} + +sub can_write +{ + my $vec = shift; + my $timeout = shift; + my $w = $vec->[VEC_BITS]; + + defined($w) && (select(undef,$w,undef,$timeout) > 0) + ? handles($vec, $w) + : (); +} + +sub has_exception +{ + my $vec = shift; + my $timeout = shift; + my $e = $vec->[VEC_BITS]; + + defined($e) && (select(undef,undef,$e,$timeout) > 0) + ? handles($vec, $e) + : (); +} + +sub has_error +{ + warnings::warn("Call to deprecated method 'has_error', use 'has_exception'") + if warnings::enabled(); + goto &has_exception; +} + +sub count +{ + my $vec = shift; + $vec->[FD_COUNT]; +} + +sub bits +{ + my $vec = shift; + $vec->[VEC_BITS]; +} + +sub as_string # for debugging +{ + my $vec = shift; + my $str = ref($vec) . ": "; + my $bits = $vec->bits; + my $count = $vec->count; + $str .= defined($bits) ? unpack("b*", $bits) : "undef"; + $str .= " $count"; + my @handles = @$vec; + splice(@handles, 0, FIRST_FD); + for (@handles) { + $str .= " " . (defined($_) ? "$_" : "-"); + } + $str; +} + +sub _max +{ + my($a,$b,$c) = @_; + $a > $b + ? $a > $c + ? $a + : $c + : $b > $c + ? $b + : $c; +} + +sub select +{ + shift + if defined $_[0] && !ref($_[0]); + + my($r,$w,$e,$t) = @_; + my @result = (); + + my $rb = defined $r ? $r->[VEC_BITS] : undef; + my $wb = defined $w ? $w->[VEC_BITS] : undef; + my $eb = defined $e ? $e->[VEC_BITS] : undef; + + if(select($rb,$wb,$eb,$t) > 0) + { + my @r = (); + my @w = (); + my @e = (); + my $i = _max(defined $r ? scalar(@$r)-1 : 0, + defined $w ? scalar(@$w)-1 : 0, + defined $e ? scalar(@$e)-1 : 0); + + for( ; $i >= FIRST_FD ; $i--) + { + my $j = $i - FIRST_FD; + push(@r, $r->[$i]) + if defined $rb && defined $r->[$i] && vec($rb, $j, 1); + push(@w, $w->[$i]) + if defined $wb && defined $w->[$i] && vec($wb, $j, 1); + push(@e, $e->[$i]) + if defined $eb && defined $e->[$i] && vec($eb, $j, 1); + } + + @result = (\@r, \@w, \@e); + } + @result; +} + + +sub handles +{ + my $vec = shift; + my $bits = shift; + my @h = (); + my $i; + my $max = scalar(@$vec) - 1; + + for ($i = FIRST_FD; $i <= $max; $i++) + { + next unless defined $vec->[$i]; + push(@h, $vec->[$i]) + if !defined($bits) || vec($bits, $i - FIRST_FD, 1); + } + + @h; +} + +1; +__END__ + +=head1 NAME + +IO::Select - OO interface to the select system call + +=head1 SYNOPSIS + + use IO::Select; + + $s = IO::Select->new(); + + $s->add(\*STDIN); + $s->add($some_handle); + + @ready = $s->can_read($timeout); + + @ready = IO::Select->new(@handles)->can_read(0); + +=head1 DESCRIPTION + +The C<IO::Select> package implements an object approach to the system C<select> +function call. It allows the user to see what IO handles, see L<IO::Handle>, +are ready for reading, writing or have an exception pending. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ HANDLES ] ) + +The constructor creates a new object and optionally initialises it with a set +of handles. + +=back + +=head1 METHODS + +=over 4 + +=item add ( HANDLES ) + +Add the list of handles to the C<IO::Select> object. It is these values that +will be returned when an event occurs. C<IO::Select> keeps these values in a +cache which is indexed by the C<fileno> of the handle, so if more than one +handle with the same C<fileno> is specified then only the last one is cached. + +Each handle can be an C<IO::Handle> object, an integer or an array +reference where the first element is an C<IO::Handle> or an integer. + +=item remove ( HANDLES ) + +Remove all the given handles from the object. This method also works +by the C<fileno> of the handles. So the exact handles that were added +need not be passed, just handles that have an equivalent C<fileno> + +=item exists ( HANDLE ) + +Returns a true value (actually the handle itself) if it is present. +Returns undef otherwise. + +=item handles + +Return an array of all registered handles. + +=item can_read ( [ TIMEOUT ] ) + +Return an array of handles that are ready for reading. C<TIMEOUT> is +the maximum amount of time to wait before returning an empty list, in +seconds, possibly fractional. If C<TIMEOUT> is not given and any +handles are registered then the call will block. + +=item can_write ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that can be written to. + +=item has_exception ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that have an exception +condition, for example pending out-of-band data. + +=item count () + +Returns the number of handles that the object will check for when +one of the C<can_> methods is called or the object is passed to +the C<select> static method. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] ) + +C<select> is a static method, that is you call it with the package name +like C<new>. C<READ>, C<WRITE> and C<EXCEPTION> are either C<undef> or +C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as +for the core select call. + +The result will be an array of 3 elements, each a reference to an array +which will hold the handles that are ready for reading, writing and have +exceptions respectively. Upon error an empty list is returned. + +=back + +=head1 EXAMPLE + +Here is a short example which shows how C<IO::Select> could be used +to write a server which communicates with several sockets while also +listening for more connections on a listen socket + + use IO::Select; + use IO::Socket; + + $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); + $sel = new IO::Select( $lsn ); + + while(@ready = $sel->can_read) { + foreach $fh (@ready) { + if($fh == $lsn) { + # Create a new socket + $new = $lsn->accept; + $sel->add($new); + } + else { + # Process socket + + # Maybe we have finished with the socket + $sel->remove($fh); + $fh->close; + } + } + } + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut + diff --git a/Master/tlpkg/installer/perllib/IO/Socket.pm b/Master/tlpkg/installer/perllib/IO/Socket.pm new file mode 100644 index 00000000000..4429f2bb3e6 --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/Socket.pm @@ -0,0 +1,476 @@ +# IO::Socket.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket; + +require 5.006; + +use IO::Handle; +use Socket 1.3; +use Carp; +use strict; +our(@ISA, $VERSION, @EXPORT_OK); +use Exporter; +use Errno; + +# legacy + +require IO::Socket::INET; +require IO::Socket::UNIX if ($^O ne 'epoc' && $^O ne 'symbian'); + +@ISA = qw(IO::Handle); + +$VERSION = "1.29"; + +@EXPORT_OK = qw(sockatmark); + +sub import { + my $pkg = shift; + if (@_ && $_[0] eq 'sockatmark') { # not very extensible but for now, fast + Exporter::export_to_level('IO::Socket', 1, $pkg, 'sockatmark'); + } else { + my $callpkg = caller; + Exporter::export 'Socket', $callpkg, @_; + } +} + +sub new { + my($class,%arg) = @_; + my $sock = $class->SUPER::new(); + + $sock->autoflush(1); + + ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; + + return scalar(%arg) ? $sock->configure(\%arg) + : $sock; +} + +my @domain2pkg; + +sub register_domain { + my($p,$d) = @_; + $domain2pkg[$d] = $p; +} + +sub configure { + my($sock,$arg) = @_; + my $domain = delete $arg->{Domain}; + + croak 'IO::Socket: Cannot configure a generic socket' + unless defined $domain; + + croak "IO::Socket: Unsupported socket domain" + unless defined $domain2pkg[$domain]; + + croak "IO::Socket: Cannot configure socket in domain '$domain'" + unless ref($sock) eq "IO::Socket"; + + bless($sock, $domain2pkg[$domain]); + $sock->configure($arg); +} + +sub socket { + @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; + my($sock,$domain,$type,$protocol) = @_; + + socket($sock,$domain,$type,$protocol) or + return undef; + + ${*$sock}{'io_socket_domain'} = $domain; + ${*$sock}{'io_socket_type'} = $type; + ${*$sock}{'io_socket_proto'} = $protocol; + + $sock; +} + +sub socketpair { + @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)'; + my($class,$domain,$type,$protocol) = @_; + my $sock1 = $class->new(); + my $sock2 = $class->new(); + + socketpair($sock1,$sock2,$domain,$type,$protocol) or + return (); + + ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; + ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; + + ($sock1,$sock2); +} + +sub connect { + @_ == 2 or croak 'usage: $sock->connect(NAME)'; + my $sock = shift; + my $addr = shift; + my $timeout = ${*$sock}{'io_socket_timeout'}; + my $err; + my $blocking; + + $blocking = $sock->blocking(0) if $timeout; + if (!connect($sock, $addr)) { + if (defined $timeout && $!{EINPROGRESS}) { + require IO::Select; + + my $sel = new IO::Select $sock; + + if (!$sel->can_write($timeout)) { + $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + $@ = "connect: timeout"; + } + elsif (!connect($sock,$addr) && not $!{EISCONN}) { + # Some systems refuse to re-connect() to + # an already open socket and set errno to EISCONN. + $err = $!; + $@ = "connect: $!"; + } + } + elsif ($blocking || !$!{EINPROGRESS}) { + $err = $!; + $@ = "connect: $!"; + } + } + + $sock->blocking(1) if $blocking; + + $! = $err if $err; + + $err ? undef : $sock; +} + +sub bind { + @_ == 2 or croak 'usage: $sock->bind(NAME)'; + my $sock = shift; + my $addr = shift; + + return bind($sock, $addr) ? $sock + : undef; +} + +sub listen { + @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; + my($sock,$queue) = @_; + $queue = 5 + unless $queue && $queue > 0; + + return listen($sock, $queue) ? $sock + : undef; +} + +sub accept { + @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])'; + my $sock = shift; + my $pkg = shift || $sock; + my $timeout = ${*$sock}{'io_socket_timeout'}; + my $new = $pkg->new(Timeout => $timeout); + my $peer = undef; + + if(defined $timeout) { + require IO::Select; + + my $sel = new IO::Select $sock; + + unless ($sel->can_read($timeout)) { + $@ = 'accept: timeout'; + $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + return; + } + } + + $peer = accept($new,$sock) + or return; + + return wantarray ? ($new, $peer) + : $new; +} + +sub sockname { + @_ == 1 or croak 'usage: $sock->sockname()'; + getsockname($_[0]); +} + +sub peername { + @_ == 1 or croak 'usage: $sock->peername()'; + my($sock) = @_; + getpeername($sock) + || ${*$sock}{'io_socket_peername'} + || undef; +} + +sub connected { + @_ == 1 or croak 'usage: $sock->connected()'; + my($sock) = @_; + getpeername($sock); +} + +sub send { + @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; + my $sock = $_[0]; + my $flags = $_[2] || 0; + my $peer = $_[3] || $sock->peername; + + croak 'send: Cannot determine peer address' + unless($peer); + + my $r = defined(getpeername($sock)) + ? send($sock, $_[1], $flags) + : send($sock, $_[1], $flags, $peer); + + # remember who we send to, if it was successful + ${*$sock}{'io_socket_peername'} = $peer + if(@_ == 4 && defined $r); + + $r; +} + +sub recv { + @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; + my $sock = $_[0]; + my $len = $_[2]; + my $flags = $_[3] || 0; + + # remember who we recv'd from + ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); +} + +sub shutdown { + @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; + my($sock, $how) = @_; + shutdown($sock, $how); +} + +sub setsockopt { + @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)'; + setsockopt($_[0],$_[1],$_[2],$_[3]); +} + +my $intsize = length(pack("i",0)); + +sub getsockopt { + @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; + my $r = getsockopt($_[0],$_[1],$_[2]); + # Just a guess + $r = unpack("i", $r) + if(defined $r && length($r) == $intsize); + $r; +} + +sub sockopt { + my $sock = shift; + @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) + : $sock->setsockopt(SOL_SOCKET,@_); +} + +sub atmark { + @_ == 1 or croak 'usage: $sock->atmark()'; + my($sock) = @_; + sockatmark($sock); +} + +sub timeout { + @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; + my($sock,$val) = @_; + my $r = ${*$sock}{'io_socket_timeout'}; + + ${*$sock}{'io_socket_timeout'} = defined $val ? 0 + $val : $val + if(@_ == 2); + + $r; +} + +sub sockdomain { + @_ == 1 or croak 'usage: $sock->sockdomain()'; + my $sock = shift; + ${*$sock}{'io_socket_domain'}; +} + +sub socktype { + @_ == 1 or croak 'usage: $sock->socktype()'; + my $sock = shift; + ${*$sock}{'io_socket_type'} +} + +sub protocol { + @_ == 1 or croak 'usage: $sock->protocol()'; + my($sock) = @_; + ${*$sock}{'io_socket_proto'}; +} + +1; + +__END__ + +=head1 NAME + +IO::Socket - Object interface to socket communications + +=head1 SYNOPSIS + + use IO::Socket; + +=head1 DESCRIPTION + +C<IO::Socket> provides an object interface to creating and using sockets. It +is built upon the L<IO::Handle> interface and inherits all the methods defined +by L<IO::Handle>. + +C<IO::Socket> only defines methods for those operations which are common to all +types of socket. Operations which are specified to a socket in a particular +domain have methods defined in sub classes of C<IO::Socket> + +C<IO::Socket> will export all functions (and constants) defined by L<Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket>, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. +C<new> only looks for one key C<Domain> which tells new which domain +the socket will be in. All other arguments will be passed to the +configuration method of the package for that domain, See below. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Socket> methods, which are just front ends for the +corresponding built-in functions: + + socket + socketpair + bind + listen + accept + send + recv + peername (getpeername) + sockname (getsockname) + shutdown + +Some methods take slightly different arguments to those defined in L<perlfunc> +in attempt to make the interface more flexible. These are + +=over 4 + +=item accept([PKG]) + +perform the system call C<accept> on the socket and return a new +object. The new object will be created in the same class as the listen +socket, unless C<PKG> is specified. This object can be used to +communicate with the client that was trying to connect. + +In a scalar context the new socket is returned, or undef upon +failure. In a list context a two-element array is returned containing +the new socket and the peer address; the list will be empty upon +failure. + +The timeout in the [PKG] can be specified as zero to effect a "poll", +but you shouldn't do that because a new IO::Select object will be +created behind the scenes just to do the single poll. This is +horrendously inefficient. Use rather true select() with a zero +timeout on the handle, or non-blocking IO. + +=item socketpair(DOMAIN, TYPE, PROTOCOL) + +Call C<socketpair> and return a list of two sockets created, or an +empty list on failure. + +=back + +Additional methods that are provided are: + +=over 4 + +=item atmark + +True if the socket is currently positioned at the urgent data mark, +false otherwise. + + use IO::Socket; + + my $sock = IO::Socket::INET->new('some_server'); + $sock->read($data, 1024) until $sock->atmark; + +Note: this is a reasonably new addition to the family of socket +functions, so all systems may not support this yet. If it is +unsupported by the system, an attempt to use this method will +abort the program. + +The atmark() functionality is also exportable as sockatmark() function: + + use IO::Socket 'sockatmark'; + +This allows for a more traditional use of sockatmark() as a procedural +socket function. If your system does not support sockatmark(), the +C<use> declaration will fail at compile time. + +=item connected + +If the socket is in a connected state the peer address is returned. +If the socket is not in a connected state then undef will be returned. + +=item protocol + +Returns the numerical number for the protocol being used on the socket, if +known. If the protocol is unknown, as with an AF_UNIX socket, zero +is returned. + +=item sockdomain + +Returns the numerical number for the socket domain type. For example, for +an AF_INET socket the value of &AF_INET will be returned. + +=item sockopt(OPT [, VAL]) + +Unified method to both set and get options in the SOL_SOCKET level. If called +with one argument then getsockopt is called, otherwise setsockopt is called. + +=item socktype + +Returns the numerical number for the socket type. For example, for +a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. + +=item timeout([VAL]) + +Set or get the timeout value associated with this socket. If called without +any arguments then the current setting is returned. If called with an argument +the current setting is changed and the previous value returned. + +=back + +=head1 SEE ALSO + +L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> + +=head1 AUTHOR + +Graham Barr. atmark() by Lincoln Stein. Currently maintained by the +Perl Porters. Please report all bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +The atmark() implementation: Copyright 2001, Lincoln Stein <lstein@cshl.org>. +This module is distributed under the same terms as Perl itself. +Feel free to use, modify and redistribute it as long as you retain +the correct attribution. + +=cut diff --git a/Master/tlpkg/installer/perllib/IO/Socket/INET.pm b/Master/tlpkg/installer/perllib/IO/Socket/INET.pm new file mode 100644 index 00000000000..96b49911d81 --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/Socket/INET.pm @@ -0,0 +1,431 @@ +# IO::Socket::INET.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket::INET; + +use strict; +our(@ISA, $VERSION); +use IO::Socket; +use Socket; +use Carp; +use Exporter; +use Errno; + +@ISA = qw(IO::Socket); +$VERSION = "1.29"; + +my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1; + +IO::Socket::INET->register_domain( AF_INET ); + +my %socket_type = ( tcp => SOCK_STREAM, + udp => SOCK_DGRAM, + icmp => SOCK_RAW + ); + +sub new { + my $class = shift; + unshift(@_, "PeerAddr") if @_ == 1; + return $class->SUPER::new(@_); +} + +sub _sock_info { + my($addr,$port,$proto) = @_; + my $origport = $port; + my @proto = (); + my @serv = (); + + $port = $1 + if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); + + if(defined $proto && $proto =~ /\D/) { + if(@proto = getprotobyname($proto)) { + $proto = $proto[2] || undef; + } + else { + $@ = "Bad protocol '$proto'"; + return; + } + } + + if(defined $port) { + my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef; + my $pnum = ($port =~ m,^(\d+)$,)[0]; + + @serv = getservbyname($port, $proto[0] || "") + if ($port =~ m,\D,); + + $port = $serv[2] || $defport || $pnum; + unless (defined $port) { + $@ = "Bad service '$origport'"; + return; + } + + $proto = (getprotobyname($serv[3]))[2] || undef + if @serv && !$proto; + } + + return ($addr || undef, + $port || undef, + $proto || undef + ); +} + +sub _error { + my $sock = shift; + my $err = shift; + { + local($!); + my $title = ref($sock).": "; + $@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_); + close($sock) + if(defined fileno($sock)); + } + $! = $err; + return undef; +} + +sub _get_addr { + my($sock,$addr_str, $multi) = @_; + my @addr; + if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) { + (undef, undef, undef, undef, @addr) = gethostbyname($addr_str); + } else { + my $h = inet_aton($addr_str); + push(@addr, $h) if defined $h; + } + @addr; +} + +sub configure { + my($sock,$arg) = @_; + my($lport,$rport,$laddr,$raddr,$proto,$type); + + + $arg->{LocalAddr} = $arg->{LocalHost} + if exists $arg->{LocalHost} && !exists $arg->{LocalAddr}; + + ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, + $arg->{LocalPort}, + $arg->{Proto}) + or return _error($sock, $!, $@); + + $laddr = defined $laddr ? inet_aton($laddr) + : INADDR_ANY; + + return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'") + unless(defined $laddr); + + $arg->{PeerAddr} = $arg->{PeerHost} + if exists $arg->{PeerHost} && !exists $arg->{PeerAddr}; + + unless(exists $arg->{Listen}) { + ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, + $arg->{PeerPort}, + $proto) + or return _error($sock, $!, $@); + } + + $proto ||= (getprotobyname('tcp'))[2]; + + my $pname = (getprotobynumber($proto))[0]; + $type = $arg->{Type} || $socket_type{lc $pname}; + + my @raddr = (); + + if(defined $raddr) { + @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed}); + return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") + unless @raddr; + } + + while(1) { + + $sock->socket(AF_INET, $type, $proto) or + return _error($sock, $!, "$!"); + + if (defined $arg->{Blocking}) { + defined $sock->blocking($arg->{Blocking}) + or return _error($sock, $!, "$!"); + } + + if ($arg->{Reuse} || $arg->{ReuseAddr}) { + $sock->sockopt(SO_REUSEADDR,1) or + return _error($sock, $!, "$!"); + } + + if ($arg->{ReusePort}) { + $sock->sockopt(SO_REUSEPORT,1) or + return _error($sock, $!, "$!"); + } + + if ($arg->{Broadcast}) { + $sock->sockopt(SO_BROADCAST,1) or + return _error($sock, $!, "$!"); + } + + if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) { + $sock->bind($lport || 0, $laddr) or + return _error($sock, $!, "$!"); + } + + if(exists $arg->{Listen}) { + $sock->listen($arg->{Listen} || 5) or + return _error($sock, $!, "$!"); + last; + } + + # don't try to connect unless we're given a PeerAddr + last unless exists($arg->{PeerAddr}); + + $raddr = shift @raddr; + + return _error($sock, $EINVAL, 'Cannot determine remote port') + unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); + + last + unless($type == SOCK_STREAM || defined $raddr); + + return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") + unless defined $raddr; + +# my $timeout = ${*$sock}{'io_socket_timeout'}; +# my $before = time() if $timeout; + + undef $@; + if ($sock->connect(pack_sockaddr_in($rport, $raddr))) { +# ${*$sock}{'io_socket_timeout'} = $timeout; + return $sock; + } + + return _error($sock, $!, $@ || "Timeout") + unless @raddr; + +# if ($timeout) { +# my $new_timeout = $timeout - (time() - $before); +# return _error($sock, +# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL), +# "Timeout") if $new_timeout <= 0; +# ${*$sock}{'io_socket_timeout'} = $new_timeout; +# } + + } + + $sock; +} + +sub connect { + @_ == 2 || @_ == 3 or + croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)'; + my $sock = shift; + return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_)); +} + +sub bind { + @_ == 2 || @_ == 3 or + croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)'; + my $sock = shift; + return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_)) +} + +sub sockaddr { + @_ == 1 or croak 'usage: $sock->sockaddr()'; + my($sock) = @_; + my $name = $sock->sockname; + $name ? (sockaddr_in($name))[1] : undef; +} + +sub sockport { + @_ == 1 or croak 'usage: $sock->sockport()'; + my($sock) = @_; + my $name = $sock->sockname; + $name ? (sockaddr_in($name))[0] : undef; +} + +sub sockhost { + @_ == 1 or croak 'usage: $sock->sockhost()'; + my($sock) = @_; + my $addr = $sock->sockaddr; + $addr ? inet_ntoa($addr) : undef; +} + +sub peeraddr { + @_ == 1 or croak 'usage: $sock->peeraddr()'; + my($sock) = @_; + my $name = $sock->peername; + $name ? (sockaddr_in($name))[1] : undef; +} + +sub peerport { + @_ == 1 or croak 'usage: $sock->peerport()'; + my($sock) = @_; + my $name = $sock->peername; + $name ? (sockaddr_in($name))[0] : undef; +} + +sub peerhost { + @_ == 1 or croak 'usage: $sock->peerhost()'; + my($sock) = @_; + my $addr = $sock->peeraddr; + $addr ? inet_ntoa($addr) : undef; +} + +1; + +__END__ + +=head1 NAME + +IO::Socket::INET - Object interface for AF_INET domain sockets + +=head1 SYNOPSIS + + use IO::Socket::INET; + +=head1 DESCRIPTION + +C<IO::Socket::INET> provides an object interface to creating and using sockets +in the AF_INET domain. It is built upon the L<IO::Socket> interface and +inherits all the methods defined by L<IO::Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket::INET> object, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. + +In addition to the key-value pairs accepted by L<IO::Socket>, +C<IO::Socket::INET> provides. + + + PeerAddr Remote host address <hostname>[:<port>] + PeerHost Synonym for PeerAddr + PeerPort Remote port or service <service>[(<no>)] | <no> + LocalAddr Local host bind address hostname[:port] + LocalHost Synonym for LocalAddr + LocalPort Local host bind port <service>[(<no>)] | <no> + Proto Protocol name (or number) "tcp" | "udp" | ... + Type Socket type SOCK_STREAM | SOCK_DGRAM | ... + Listen Queue size for listen + ReuseAddr Set SO_REUSEADDR before binding + Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr) + ReusePort Set SO_REUSEPORT before binding + Broadcast Set SO_BROADCAST before binding + Timeout Timeout value for various operations + MultiHomed Try all addresses for multi-homed hosts + Blocking Determine if connection will be blocking mode + +If C<Listen> is defined then a listen socket is created, else if the +socket type, which is derived from the protocol, is SOCK_STREAM then +connect() is called. + +Although it is not illegal, the use of C<MultiHomed> on a socket +which is in non-blocking mode is of little use. This is because the +first connect will never fail with a timeout as the connect call +will not block. + +The C<PeerAddr> can be a hostname or the IP-address on the +"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic +service name. The service name might be followed by a number in +parenthesis which is used if the service is not known by the system. +The C<PeerPort> specification can also be embedded in the C<PeerAddr> +by preceding it with a ":". + +If C<Proto> is not given and you specify a symbolic C<PeerPort> port, +then the constructor will try to derive C<Proto> from the service +name. As a last resort C<Proto> "tcp" is assumed. The C<Type> +parameter will be deduced from C<Proto> if not specified. + +If the constructor is only passed a single argument, it is assumed to +be a C<PeerAddr> specification. + +If C<Blocking> is set to 0, the connection will be in nonblocking mode. +If not specified it defaults to 1 (blocking mode). + +Examples: + + $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', + PeerPort => 'http(80)', + Proto => 'tcp'); + + $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); + + $sock = IO::Socket::INET->new(Listen => 5, + LocalAddr => 'localhost', + LocalPort => 9000, + Proto => 'tcp'); + + $sock = IO::Socket::INET->new('127.0.0.1:25'); + + $sock = IO::Socket::INET->new(PeerPort => 9999, + PeerAddr => inet_ntoa(INADDR_BROADCAST), + Proto => udp, + LocalAddr => 'localhost', + Broadcast => 1 ) + or die "Can't bind : $@\n"; + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +=back + +=head2 METHODS + +=over 4 + +=item sockaddr () + +Return the address part of the sockaddr structure for the socket + +=item sockport () + +Return the port number that the socket is using on the local host + +=item sockhost () + +Return the address part of the sockaddr structure for the socket in a +text form xx.xx.xx.xx + +=item peeraddr () + +Return the address part of the sockaddr structure for the socket on +the peer host + +=item peerport () + +Return the port number for the socket on the peer host. + +=item peerhost () + +Return the address part of the sockaddr structure for the socket on the +peer host in a text form xx.xx.xx.xx + +=back + +=head1 SEE ALSO + +L<Socket>, L<IO::Socket> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/IO/Socket/UNIX.pm b/Master/tlpkg/installer/perllib/IO/Socket/UNIX.pm new file mode 100644 index 00000000000..952a0f41f0c --- /dev/null +++ b/Master/tlpkg/installer/perllib/IO/Socket/UNIX.pm @@ -0,0 +1,144 @@ +# IO::Socket::UNIX.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package IO::Socket::UNIX; + +use strict; +our(@ISA, $VERSION); +use IO::Socket; +use Socket; +use Carp; + +@ISA = qw(IO::Socket); +$VERSION = "1.22"; +$VERSION = eval $VERSION; + +IO::Socket::UNIX->register_domain( AF_UNIX ); + +sub new { + my $class = shift; + unshift(@_, "Peer") if @_ == 1; + return $class->SUPER::new(@_); +} + +sub configure { + my($sock,$arg) = @_; + my($bport,$cport); + + my $type = $arg->{Type} || SOCK_STREAM; + + $sock->socket(AF_UNIX, $type, 0) or + return undef; + + if(exists $arg->{Local}) { + my $addr = sockaddr_un($arg->{Local}); + $sock->bind($addr) or + return undef; + } + if(exists $arg->{Listen} && $type != SOCK_DGRAM) { + $sock->listen($arg->{Listen} || 5) or + return undef; + } + elsif(exists $arg->{Peer}) { + my $addr = sockaddr_un($arg->{Peer}); + $sock->connect($addr) or + return undef; + } + + $sock; +} + +sub hostpath { + @_ == 1 or croak 'usage: $sock->hostpath()'; + my $n = $_[0]->sockname || return undef; + (sockaddr_un($n))[0]; +} + +sub peerpath { + @_ == 1 or croak 'usage: $sock->peerpath()'; + my $n = $_[0]->peername || return undef; + (sockaddr_un($n))[0]; +} + +1; # Keep require happy + +__END__ + +=head1 NAME + +IO::Socket::UNIX - Object interface for AF_UNIX domain sockets + +=head1 SYNOPSIS + + use IO::Socket::UNIX; + +=head1 DESCRIPTION + +C<IO::Socket::UNIX> provides an object interface to creating and using sockets +in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and +inherits all the methods defined by L<IO::Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket::UNIX> object, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. + +In addition to the key-value pairs accepted by L<IO::Socket>, +C<IO::Socket::UNIX> provides. + + Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) + Local Path to local fifo + Peer Path to peer fifo + Listen Create a listen socket + +If the constructor is only passed a single argument, it is assumed to +be a C<Peer> specification. + + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +=back + +=head1 METHODS + +=over 4 + +=item hostpath() + +Returns the pathname to the fifo at the local end + +=item peerpath() + +Returns the pathanme to the fifo at the peer end + +=back + +=head1 SEE ALSO + +L<Socket>, L<IO::Socket> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Opcode.pm b/Master/tlpkg/installer/perllib/Opcode.pm new file mode 100644 index 00000000000..2987b9952e0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Opcode.pm @@ -0,0 +1,578 @@ +package Opcode; + +use 5.006_001; + +use strict; + +our($VERSION, $XS_VERSION, @ISA, @EXPORT_OK); + +$VERSION = "1.06"; +$XS_VERSION = "1.03"; + +use Carp; +use Exporter (); +use XSLoader (); + +BEGIN { + @ISA = qw(Exporter); + @EXPORT_OK = qw( + opset ops_to_opset + opset_to_ops opset_to_hex invert_opset + empty_opset full_opset + opdesc opcodes opmask define_optag + opmask_add verify_opset opdump + ); +} + +sub opset (;@); +sub opset_to_hex ($); +sub opdump (;$); +use subs @EXPORT_OK; + +XSLoader::load 'Opcode', $XS_VERSION; + +_init_optags(); + +sub ops_to_opset { opset @_ } # alias for old name + +sub opset_to_hex ($) { + return "(invalid opset)" unless verify_opset($_[0]); + unpack("h*",$_[0]); +} + +sub opdump (;$) { + my $pat = shift; + # handy utility: perl -MOpcode=opdump -e 'opdump File' + foreach(opset_to_ops(full_opset)) { + my $op = sprintf " %12s %s\n", $_, opdesc($_); + next if defined $pat and $op !~ m/$pat/i; + print $op; + } +} + + + +sub _init_optags { + my(%all, %seen); + @all{opset_to_ops(full_opset)} = (); # keys only + + local($_); + local($/) = "\n=cut"; # skip to optags definition section + <DATA>; + $/ = "\n="; # now read in 'pod section' chunks + while(<DATA>) { + next unless m/^item\s+(:\w+)/; + my $tag = $1; + + # Split into lines, keep only indented lines + my @lines = grep { m/^\s/ } split(/\n/); + foreach (@lines) { s/--.*// } # delete comments + my @ops = map { split ' ' } @lines; # get op words + + foreach(@ops) { + warn "$tag - $_ already tagged in $seen{$_}\n" if $seen{$_}; + $seen{$_} = $tag; + delete $all{$_}; + } + # opset will croak on invalid names + define_optag($tag, opset(@ops)); + } + close(DATA); + warn "Untagged opnames: ".join(' ',keys %all)."\n" if %all; +} + + +1; + +__DATA__ + +=head1 NAME + +Opcode - Disable named opcodes when compiling perl code + +=head1 SYNOPSIS + + use Opcode; + + +=head1 DESCRIPTION + +Perl code is always compiled into an internal format before execution. + +Evaluating perl code (e.g. via "eval" or "do 'file'") causes +the code to be compiled into an internal format and then, +provided there was no error in the compilation, executed. +The internal format is based on many distinct I<opcodes>. + +By default no opmask is in effect and any code can be compiled. + +The Opcode module allow you to define an I<operator mask> to be in +effect when perl I<next> compiles any code. Attempting to compile code +which contains a masked opcode will cause the compilation to fail +with an error. The code will not be executed. + +=head1 NOTE + +The Opcode module is not usually used directly. See the ops pragma and +Safe modules for more typical uses. + +=head1 WARNING + +The authors make B<no warranty>, implied or otherwise, about the +suitability of this software for safety or security purposes. + +The authors shall not in any case be liable for special, incidental, +consequential, indirect or other similar damages arising from the use +of this software. + +Your mileage will vary. If in any doubt B<do not use it>. + + +=head1 Operator Names and Operator Lists + +The canonical list of operator names is the contents of the array +PL_op_name defined and initialised in file F<opcode.h> of the Perl +source distribution (and installed into the perl library). + +Each operator has both a terse name (its opname) and a more verbose or +recognisable descriptive name. The opdesc function can be used to +return a list of descriptions for a list of operators. + +Many of the functions and methods listed below take a list of +operators as parameters. Most operator lists can be made up of several +types of element. Each element can be one of + +=over 8 + +=item an operator name (opname) + +Operator names are typically small lowercase words like enterloop, +leaveloop, last, next, redo etc. Sometimes they are rather cryptic +like gv2cv, i_ncmp and ftsvtx. + +=item an operator tag name (optag) + +Operator tags can be used to refer to groups (or sets) of operators. +Tag names always begin with a colon. The Opcode module defines several +optags and the user can define others using the define_optag function. + +=item a negated opname or optag + +An opname or optag can be prefixed with an exclamation mark, e.g., !mkdir. +Negating an opname or optag means remove the corresponding ops from the +accumulated set of ops at that point. + +=item an operator set (opset) + +An I<opset> as a binary string of approximately 44 bytes which holds a +set or zero or more operators. + +The opset and opset_to_ops functions can be used to convert from +a list of operators to an opset and I<vice versa>. + +Wherever a list of operators can be given you can use one or more opsets. +See also Manipulating Opsets below. + +=back + + +=head1 Opcode Functions + +The Opcode package contains functions for manipulating operator names +tags and sets. All are available for export by the package. + +=over 8 + +=item opcodes + +In a scalar context opcodes returns the number of opcodes in this +version of perl (around 350 for perl-5.7.0). + +In a list context it returns a list of all the operator names. +(Not yet implemented, use @names = opset_to_ops(full_opset).) + +=item opset (OP, ...) + +Returns an opset containing the listed operators. + +=item opset_to_ops (OPSET) + +Returns a list of operator names corresponding to those operators in +the set. + +=item opset_to_hex (OPSET) + +Returns a string representation of an opset. Can be handy for debugging. + +=item full_opset + +Returns an opset which includes all operators. + +=item empty_opset + +Returns an opset which contains no operators. + +=item invert_opset (OPSET) + +Returns an opset which is the inverse set of the one supplied. + +=item verify_opset (OPSET, ...) + +Returns true if the supplied opset looks like a valid opset (is the +right length etc) otherwise it returns false. If an optional second +parameter is true then verify_opset will croak on an invalid opset +instead of returning false. + +Most of the other Opcode functions call verify_opset automatically +and will croak if given an invalid opset. + +=item define_optag (OPTAG, OPSET) + +Define OPTAG as a symbolic name for OPSET. Optag names always start +with a colon C<:>. + +The optag name used must not be defined already (define_optag will +croak if it is already defined). Optag names are global to the perl +process and optag definitions cannot be altered or deleted once +defined. + +It is strongly recommended that applications using Opcode should use a +leading capital letter on their tag names since lowercase names are +reserved for use by the Opcode module. If using Opcode within a module +you should prefix your tags names with the name of your module to +ensure uniqueness and thus avoid clashes with other modules. + +=item opmask_add (OPSET) + +Adds the supplied opset to the current opmask. Note that there is +currently I<no> mechanism for unmasking ops once they have been masked. +This is intentional. + +=item opmask + +Returns an opset corresponding to the current opmask. + +=item opdesc (OP, ...) + +This takes a list of operator names and returns the corresponding list +of operator descriptions. + +=item opdump (PAT) + +Dumps to STDOUT a two column list of op names and op descriptions. +If an optional pattern is given then only lines which match the +(case insensitive) pattern will be output. + +It's designed to be used as a handy command line utility: + + perl -MOpcode=opdump -e opdump + perl -MOpcode=opdump -e 'opdump Eval' + +=back + +=head1 Manipulating Opsets + +Opsets may be manipulated using the perl bit vector operators & (and), | (or), +^ (xor) and ~ (negate/invert). + +However you should never rely on the numerical position of any opcode +within the opset. In other words both sides of a bit vector operator +should be opsets returned from Opcode functions. + +Also, since the number of opcodes in your current version of perl might +not be an exact multiple of eight, there may be unused bits in the last +byte of an upset. This should not cause any problems (Opcode functions +ignore those extra bits) but it does mean that using the ~ operator +will typically not produce the same 'physical' opset 'string' as the +invert_opset function. + + +=head1 TO DO (maybe) + + $bool = opset_eq($opset1, $opset2) true if opsets are logically eqiv + + $yes = opset_can($opset, @ops) true if $opset has all @ops set + + @diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...) + +=cut + +# the =cut above is used by _init_optags() to get here quickly + +=head1 Predefined Opcode Tags + +=over 5 + +=item :base_core + + null stub scalar pushmark wantarray const defined undef + + rv2sv sassign + + rv2av aassign aelem aelemfast aslice av2arylen + + rv2hv helem hslice each values keys exists delete + + preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec + int hex oct abs pow multiply i_multiply divide i_divide + modulo i_modulo add i_add subtract i_subtract + + left_shift right_shift bit_and bit_xor bit_or negate i_negate + not complement + + lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp + slt sgt sle sge seq sne scmp + + substr vec stringify study pos length index rindex ord chr + + ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp + + match split qr + + list lslice splice push pop shift unshift reverse + + cond_expr flip flop andassign orassign and or xor + + warn die lineseq nextstate scope enter leave setstate + + rv2cv anoncode prototype + + entersub leavesub leavesublv return method method_named -- XXX loops via recursion? + + leaveeval -- needed for Safe to operate, is safe without entereval + +=item :base_mem + +These memory related ops are not included in :base_core because they +can easily be used to implement a resource attack (e.g., consume all +available memory). + + concat repeat join range + + anonlist anonhash + +Note that despite the existence of this optag a memory resource attack +may still be possible using only :base_core ops. + +Disabling these ops is a I<very> heavy handed way to attempt to prevent +a memory resource attack. It's probable that a specific memory limit +mechanism will be added to perl in the near future. + +=item :base_loop + +These loop ops are not included in :base_core because they can easily be +used to implement a resource attack (e.g., consume all available CPU time). + + grepstart grepwhile + mapstart mapwhile + enteriter iter + enterloop leaveloop unstack + last next redo + goto + +=item :base_io + +These ops enable I<filehandle> (rather than filename) based input and +output. These are safe on the assumption that only pre-existing +filehandles are available for use. To create new filehandles other ops +such as open would need to be enabled. + + readline rcatline getc read + + formline enterwrite leavewrite + + print sysread syswrite send recv + + eof tell seek sysseek + + readdir telldir seekdir rewinddir + +=item :base_orig + +These are a hotchpotch of opcodes still waiting to be considered + + gvsv gv gelem + + padsv padav padhv padany + + rv2gv refgen srefgen ref + + bless -- could be used to change ownership of objects (reblessing) + + pushre regcmaybe regcreset regcomp subst substcont + + sprintf prtf -- can core dump + + crypt + + tie untie + + dbmopen dbmclose + sselect select + pipe_op sockpair + + getppid getpgrp setpgrp getpriority setpriority localtime gmtime + + entertry leavetry -- can be used to 'hide' fatal errors + + custom -- where should this go + +=item :base_math + +These ops are not included in :base_core because of the risk of them being +used to generate floating point exceptions (which would have to be caught +using a $SIG{FPE} handler). + + atan2 sin cos exp log sqrt + +These ops are not included in :base_core because they have an effect +beyond the scope of the compartment. + + rand srand + +=item :base_thread + +These ops are related to multi-threading. + + lock threadsv + +=item :default + +A handy tag name for a I<reasonable> default set of ops. (The current ops +allowed are unstable while development continues. It will change.) + + :base_core :base_mem :base_loop :base_io :base_orig :base_thread + +If safety matters to you (and why else would you be using the Opcode module?) +then you should not rely on the definition of this, or indeed any other, optag! + + +=item :filesys_read + + stat lstat readlink + + ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread + ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned + ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx + + fttext ftbinary + + fileno + +=item :sys_db + + ghbyname ghbyaddr ghostent shostent ehostent -- hosts + gnbyname gnbyaddr gnetent snetent enetent -- networks + gpbyname gpbynumber gprotoent sprotoent eprotoent -- protocols + gsbyname gsbyport gservent sservent eservent -- services + + gpwnam gpwuid gpwent spwent epwent getlogin -- users + ggrnam ggrgid ggrent sgrent egrent -- groups + +=item :browse + +A handy tag name for a I<reasonable> default set of ops beyond the +:default optag. Like :default (and indeed all the other optags) its +current definition is unstable while development continues. It will change. + +The :browse tag represents the next step beyond :default. It it a +superset of the :default ops and adds :filesys_read the :sys_db. +The intent being that scripts can access more (possibly sensitive) +information about your system but not be able to change it. + + :default :filesys_read :sys_db + +=item :filesys_open + + sysopen open close + umask binmode + + open_dir closedir -- other dir ops are in :base_io + +=item :filesys_write + + link unlink rename symlink truncate + + mkdir rmdir + + utime chmod chown + + fcntl -- not strictly filesys related, but possibly as dangerous? + +=item :subprocess + + backtick system + + fork + + wait waitpid + + glob -- access to Cshell via <`rm *`> + +=item :ownprocess + + exec exit kill + + time tms -- could be used for timing attacks (paranoid?) + +=item :others + +This tag holds groups of assorted specialist opcodes that don't warrant +having optags defined for them. + +SystemV Interprocess Communications: + + msgctl msgget msgrcv msgsnd + + semctl semget semop + + shmctl shmget shmread shmwrite + +=item :still_to_be_decided + + chdir + flock ioctl + + socket getpeername ssockopt + bind connect listen accept shutdown gsockopt getsockname + + sleep alarm -- changes global timer state and signal handling + sort -- assorted problems including core dumps + tied -- can be used to access object implementing a tie + pack unpack -- can be used to create/use memory pointers + + entereval -- can be used to hide code from initial compile + require dofile + + caller -- get info about calling environment and args + + reset + + dbstate -- perl -d version of nextstate(ment) opcode + +=item :dangerous + +This tag is simply a bucket for opcodes that are unlikely to be used via +a tag name but need to be tagged for completeness and documentation. + + syscall dump chroot + + +=back + +=head1 SEE ALSO + +ops(3) -- perl pragma interface to Opcode module. + +Safe(3) -- Opcode and namespace limited execution compartments + +=head1 AUTHORS + +Originally designed and implemented by Malcolm Beattie, +mbeattie@sable.ox.ac.uk as part of Safe version 1. + +Split out from Safe module version 1, named opcode tags and other +changes added by Tim Bunce. + +=cut + diff --git a/Master/tlpkg/installer/perllib/POSIX.pm b/Master/tlpkg/installer/perllib/POSIX.pm new file mode 100644 index 00000000000..87676215e73 --- /dev/null +++ b/Master/tlpkg/installer/perllib/POSIX.pm @@ -0,0 +1,965 @@ +package POSIX; + +our(@ISA, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD) = (); + +our $VERSION = "1.09"; + +use AutoLoader; + +use XSLoader (); + +# Grandfather old foo_h form to new :foo_h form +my $loaded; + +sub import { + load_imports() unless $loaded++; + my $this = shift; + my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_; + local $Exporter::ExportLevel = 1; + Exporter::import($this,@list); +} + +sub croak { require Carp; goto &Carp::croak } +# declare usage to assist AutoLoad +sub usage; + +XSLoader::load 'POSIX', $VERSION; + +my %NON_CONSTS = (map {($_,1)} + qw(S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG WEXITSTATUS + WIFEXITED WIFSIGNALED WIFSTOPPED WSTOPSIG WTERMSIG)); + +sub AUTOLOAD { + if ($AUTOLOAD =~ /::(_?[a-z])/) { + # require AutoLoader; + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD + } + local $! = 0; + my $constname = $AUTOLOAD; + $constname =~ s/.*:://; + if ($NON_CONSTS{$constname}) { + my ($val, $error) = &int_macro_int($constname, $_[0]); + croak $error if $error; + *$AUTOLOAD = sub { &int_macro_int($constname, $_[0]) }; + } else { + my ($error, $val) = constant($constname); + croak $error if $error; + *$AUTOLOAD = sub { $val }; + } + + goto &$AUTOLOAD; +} + +package POSIX::SigAction; + +use AutoLoader 'AUTOLOAD'; +sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] } + +package POSIX; + +1; +__END__ + +sub usage { + my ($mess) = @_; + croak "Usage: POSIX::$mess"; +} + +sub redef { + my ($mess) = @_; + croak "Use method $mess instead"; +} + +sub unimpl { + my ($mess) = @_; + $mess =~ s/xxx//; + croak "Unimplemented: POSIX::$mess"; +} + +sub assert { + usage "assert(expr)" if @_ != 1; + if (!$_[0]) { + croak "Assertion failed"; + } +} + +sub tolower { + usage "tolower(string)" if @_ != 1; + lc($_[0]); +} + +sub toupper { + usage "toupper(string)" if @_ != 1; + uc($_[0]); +} + +sub closedir { + usage "closedir(dirhandle)" if @_ != 1; + CORE::closedir($_[0]); +} + +sub opendir { + usage "opendir(directory)" if @_ != 1; + my $dirhandle; + CORE::opendir($dirhandle, $_[0]) + ? $dirhandle + : undef; +} + +sub readdir { + usage "readdir(dirhandle)" if @_ != 1; + CORE::readdir($_[0]); +} + +sub rewinddir { + usage "rewinddir(dirhandle)" if @_ != 1; + CORE::rewinddir($_[0]); +} + +sub errno { + usage "errno()" if @_ != 0; + $! + 0; +} + +sub creat { + usage "creat(filename, mode)" if @_ != 2; + &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1]); +} + +sub fcntl { + usage "fcntl(filehandle, cmd, arg)" if @_ != 3; + CORE::fcntl($_[0], $_[1], $_[2]); +} + +sub getgrgid { + usage "getgrgid(gid)" if @_ != 1; + CORE::getgrgid($_[0]); +} + +sub getgrnam { + usage "getgrnam(name)" if @_ != 1; + CORE::getgrnam($_[0]); +} + +sub atan2 { + usage "atan2(x,y)" if @_ != 2; + CORE::atan2($_[0], $_[1]); +} + +sub cos { + usage "cos(x)" if @_ != 1; + CORE::cos($_[0]); +} + +sub exp { + usage "exp(x)" if @_ != 1; + CORE::exp($_[0]); +} + +sub fabs { + usage "fabs(x)" if @_ != 1; + CORE::abs($_[0]); +} + +sub log { + usage "log(x)" if @_ != 1; + CORE::log($_[0]); +} + +sub pow { + usage "pow(x,exponent)" if @_ != 2; + $_[0] ** $_[1]; +} + +sub sin { + usage "sin(x)" if @_ != 1; + CORE::sin($_[0]); +} + +sub sqrt { + usage "sqrt(x)" if @_ != 1; + CORE::sqrt($_[0]); +} + +sub getpwnam { + usage "getpwnam(name)" if @_ != 1; + CORE::getpwnam($_[0]); +} + +sub getpwuid { + usage "getpwuid(uid)" if @_ != 1; + CORE::getpwuid($_[0]); +} + +sub longjmp { + unimpl "longjmp() is C-specific: use die instead"; +} + +sub setjmp { + unimpl "setjmp() is C-specific: use eval {} instead"; +} + +sub siglongjmp { + unimpl "siglongjmp() is C-specific: use die instead"; +} + +sub sigsetjmp { + unimpl "sigsetjmp() is C-specific: use eval {} instead"; +} + +sub kill { + usage "kill(pid, sig)" if @_ != 2; + CORE::kill $_[1], $_[0]; +} + +sub raise { + usage "raise(sig)" if @_ != 1; + CORE::kill $_[0], $$; # Is this good enough? +} + +sub offsetof { + unimpl "offsetof() is C-specific, stopped"; +} + +sub clearerr { + redef "IO::Handle::clearerr()"; +} + +sub fclose { + redef "IO::Handle::close()"; +} + +sub fdopen { + redef "IO::Handle::new_from_fd()"; +} + +sub feof { + redef "IO::Handle::eof()"; +} + +sub fgetc { + redef "IO::Handle::getc()"; +} + +sub fgets { + redef "IO::Handle::gets()"; +} + +sub fileno { + redef "IO::Handle::fileno()"; +} + +sub fopen { + redef "IO::File::open()"; +} + +sub fprintf { + unimpl "fprintf() is C-specific--use printf instead"; +} + +sub fputc { + unimpl "fputc() is C-specific--use print instead"; +} + +sub fputs { + unimpl "fputs() is C-specific--use print instead"; +} + +sub fread { + unimpl "fread() is C-specific--use read instead"; +} + +sub freopen { + unimpl "freopen() is C-specific--use open instead"; +} + +sub fscanf { + unimpl "fscanf() is C-specific--use <> and regular expressions instead"; +} + +sub fseek { + redef "IO::Seekable::seek()"; +} + +sub fsync { + redef "IO::Handle::sync()"; +} + +sub ferror { + redef "IO::Handle::error()"; +} + +sub fflush { + redef "IO::Handle::flush()"; +} + +sub fgetpos { + redef "IO::Seekable::getpos()"; +} + +sub fsetpos { + redef "IO::Seekable::setpos()"; +} + +sub ftell { + redef "IO::Seekable::tell()"; +} + +sub fwrite { + unimpl "fwrite() is C-specific--use print instead"; +} + +sub getc { + usage "getc(handle)" if @_ != 1; + CORE::getc($_[0]); +} + +sub getchar { + usage "getchar()" if @_ != 0; + CORE::getc(STDIN); +} + +sub gets { + usage "gets()" if @_ != 0; + scalar <STDIN>; +} + +sub perror { + print STDERR "@_: " if @_; + print STDERR $!,"\n"; +} + +sub printf { + usage "printf(pattern, args...)" if @_ < 1; + CORE::printf STDOUT @_; +} + +sub putc { + unimpl "putc() is C-specific--use print instead"; +} + +sub putchar { + unimpl "putchar() is C-specific--use print instead"; +} + +sub puts { + unimpl "puts() is C-specific--use print instead"; +} + +sub remove { + usage "remove(filename)" if @_ != 1; + CORE::unlink($_[0]); +} + +sub rename { + usage "rename(oldfilename, newfilename)" if @_ != 2; + CORE::rename($_[0], $_[1]); +} + +sub rewind { + usage "rewind(filehandle)" if @_ != 1; + CORE::seek($_[0],0,0); +} + +sub scanf { + unimpl "scanf() is C-specific--use <> and regular expressions instead"; +} + +sub sprintf { + usage "sprintf(pattern,args)" if @_ == 0; + CORE::sprintf(shift,@_); +} + +sub sscanf { + unimpl "sscanf() is C-specific--use regular expressions instead"; +} + +sub tmpfile { + redef "IO::File::new_tmpfile()"; +} + +sub ungetc { + redef "IO::Handle::ungetc()"; +} + +sub vfprintf { + unimpl "vfprintf() is C-specific"; +} + +sub vprintf { + unimpl "vprintf() is C-specific"; +} + +sub vsprintf { + unimpl "vsprintf() is C-specific"; +} + +sub abs { + usage "abs(x)" if @_ != 1; + CORE::abs($_[0]); +} + +sub atexit { + unimpl "atexit() is C-specific: use END {} instead"; +} + +sub atof { + unimpl "atof() is C-specific, stopped"; +} + +sub atoi { + unimpl "atoi() is C-specific, stopped"; +} + +sub atol { + unimpl "atol() is C-specific, stopped"; +} + +sub bsearch { + unimpl "bsearch() not supplied"; +} + +sub calloc { + unimpl "calloc() is C-specific, stopped"; +} + +sub div { + unimpl "div() is C-specific, use /, % and int instead"; +} + +sub exit { + usage "exit(status)" if @_ != 1; + CORE::exit($_[0]); +} + +sub free { + unimpl "free() is C-specific, stopped"; +} + +sub getenv { + usage "getenv(name)" if @_ != 1; + $ENV{$_[0]}; +} + +sub labs { + unimpl "labs() is C-specific, use abs instead"; +} + +sub ldiv { + unimpl "ldiv() is C-specific, use /, % and int instead"; +} + +sub malloc { + unimpl "malloc() is C-specific, stopped"; +} + +sub qsort { + unimpl "qsort() is C-specific, use sort instead"; +} + +sub rand { + unimpl "rand() is non-portable, use Perl's rand instead"; +} + +sub realloc { + unimpl "realloc() is C-specific, stopped"; +} + +sub srand { + unimpl "srand()"; +} + +sub system { + usage "system(command)" if @_ != 1; + CORE::system($_[0]); +} + +sub memchr { + unimpl "memchr() is C-specific, use index() instead"; +} + +sub memcmp { + unimpl "memcmp() is C-specific, use eq instead"; +} + +sub memcpy { + unimpl "memcpy() is C-specific, use = instead"; +} + +sub memmove { + unimpl "memmove() is C-specific, use = instead"; +} + +sub memset { + unimpl "memset() is C-specific, use x instead"; +} + +sub strcat { + unimpl "strcat() is C-specific, use .= instead"; +} + +sub strchr { + unimpl "strchr() is C-specific, use index() instead"; +} + +sub strcmp { + unimpl "strcmp() is C-specific, use eq instead"; +} + +sub strcpy { + unimpl "strcpy() is C-specific, use = instead"; +} + +sub strcspn { + unimpl "strcspn() is C-specific, use regular expressions instead"; +} + +sub strerror { + usage "strerror(errno)" if @_ != 1; + local $! = $_[0]; + $! . ""; +} + +sub strlen { + unimpl "strlen() is C-specific, use length instead"; +} + +sub strncat { + unimpl "strncat() is C-specific, use .= instead"; +} + +sub strncmp { + unimpl "strncmp() is C-specific, use eq instead"; +} + +sub strncpy { + unimpl "strncpy() is C-specific, use = instead"; +} + +sub strpbrk { + unimpl "strpbrk() is C-specific, stopped"; +} + +sub strrchr { + unimpl "strrchr() is C-specific, use rindex() instead"; +} + +sub strspn { + unimpl "strspn() is C-specific, stopped"; +} + +sub strstr { + usage "strstr(big, little)" if @_ != 2; + CORE::index($_[0], $_[1]); +} + +sub strtok { + unimpl "strtok() is C-specific, stopped"; +} + +sub chmod { + usage "chmod(mode, filename)" if @_ != 2; + CORE::chmod($_[0], $_[1]); +} + +sub fstat { + usage "fstat(fd)" if @_ != 1; + local *TMP; + CORE::open(TMP, "<&$_[0]"); # Gross. + my @l = CORE::stat(TMP); + CORE::close(TMP); + @l; +} + +sub mkdir { + usage "mkdir(directoryname, mode)" if @_ != 2; + CORE::mkdir($_[0], $_[1]); +} + +sub stat { + usage "stat(filename)" if @_ != 1; + CORE::stat($_[0]); +} + +sub umask { + usage "umask(mask)" if @_ != 1; + CORE::umask($_[0]); +} + +sub wait { + usage "wait()" if @_ != 0; + CORE::wait(); +} + +sub waitpid { + usage "waitpid(pid, options)" if @_ != 2; + CORE::waitpid($_[0], $_[1]); +} + +sub gmtime { + usage "gmtime(time)" if @_ != 1; + CORE::gmtime($_[0]); +} + +sub localtime { + usage "localtime(time)" if @_ != 1; + CORE::localtime($_[0]); +} + +sub time { + usage "time()" if @_ != 0; + CORE::time; +} + +sub alarm { + usage "alarm(seconds)" if @_ != 1; + CORE::alarm($_[0]); +} + +sub chdir { + usage "chdir(directory)" if @_ != 1; + CORE::chdir($_[0]); +} + +sub chown { + usage "chown(uid, gid, filename)" if @_ != 3; + CORE::chown($_[0], $_[1], $_[2]); +} + +sub execl { + unimpl "execl() is C-specific, stopped"; +} + +sub execle { + unimpl "execle() is C-specific, stopped"; +} + +sub execlp { + unimpl "execlp() is C-specific, stopped"; +} + +sub execv { + unimpl "execv() is C-specific, stopped"; +} + +sub execve { + unimpl "execve() is C-specific, stopped"; +} + +sub execvp { + unimpl "execvp() is C-specific, stopped"; +} + +sub fork { + usage "fork()" if @_ != 0; + CORE::fork; +} + +sub getegid { + usage "getegid()" if @_ != 0; + $) + 0; +} + +sub geteuid { + usage "geteuid()" if @_ != 0; + $> + 0; +} + +sub getgid { + usage "getgid()" if @_ != 0; + $( + 0; +} + +sub getgroups { + usage "getgroups()" if @_ != 0; + my %seen; + grep(!$seen{$_}++, split(' ', $) )); +} + +sub getlogin { + usage "getlogin()" if @_ != 0; + CORE::getlogin(); +} + +sub getpgrp { + usage "getpgrp()" if @_ != 0; + CORE::getpgrp; +} + +sub getpid { + usage "getpid()" if @_ != 0; + $$; +} + +sub getppid { + usage "getppid()" if @_ != 0; + CORE::getppid; +} + +sub getuid { + usage "getuid()" if @_ != 0; + $<; +} + +sub isatty { + usage "isatty(filehandle)" if @_ != 1; + -t $_[0]; +} + +sub link { + usage "link(oldfilename, newfilename)" if @_ != 2; + CORE::link($_[0], $_[1]); +} + +sub rmdir { + usage "rmdir(directoryname)" if @_ != 1; + CORE::rmdir($_[0]); +} + +sub setbuf { + redef "IO::Handle::setbuf()"; +} + +sub setvbuf { + redef "IO::Handle::setvbuf()"; +} + +sub sleep { + usage "sleep(seconds)" if @_ != 1; + $_[0] - CORE::sleep($_[0]); +} + +sub unlink { + usage "unlink(filename)" if @_ != 1; + CORE::unlink($_[0]); +} + +sub utime { + usage "utime(filename, atime, mtime)" if @_ != 3; + CORE::utime($_[1], $_[2], $_[0]); +} + +sub load_imports { +%EXPORT_TAGS = ( + + assert_h => [qw(assert NDEBUG)], + + ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower + isprint ispunct isspace isupper isxdigit tolower toupper)], + + dirent_h => [], + + errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT + EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED + ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT + EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS + EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH + ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM + ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR + ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE + ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT + ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY + EUSERS EWOULDBLOCK EXDEV errno)], + + fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK + F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK + O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK + O_RDONLY O_RDWR O_TRUNC O_WRONLY + creat + SEEK_CUR SEEK_END SEEK_SET + S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID + S_IWGRP S_IWOTH S_IWUSR)], + + float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG + DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP + DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP + FLT_DIG FLT_EPSILON FLT_MANT_DIG + FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP + FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP + FLT_RADIX FLT_ROUNDS + LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG + LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP + LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)], + + grp_h => [], + + limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX + INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON + MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX + PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN + SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX + ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX + _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT + _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX + _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX + _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], + + locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES + LC_MONETARY LC_NUMERIC LC_TIME NULL + localeconv setlocale)], + + math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod + frexp ldexp log10 modf pow sinh tan tanh)], + + pwd_h => [], + + setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], + + signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK + SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM + SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL + SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN + SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR + SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal + sigpending sigprocmask sigsuspend)], + + stdarg_h => [], + + stddef_h => [qw(NULL offsetof)], + + stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid + L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET + STREAM_MAX TMP_MAX stderr stdin stdout + clearerr fclose fdopen feof ferror fflush fgetc fgetpos + fgets fopen fprintf fputc fputs fread freopen + fscanf fseek fsetpos ftell fwrite getchar gets + perror putc putchar puts remove rewind + scanf setbuf setvbuf sscanf tmpfile tmpnam + ungetc vfprintf vprintf vsprintf)], + + stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX + abort atexit atof atoi atol bsearch calloc div + free getenv labs ldiv malloc mblen mbstowcs mbtowc + qsort realloc strtod strtol strtoul wcstombs wctomb)], + + string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat + strchr strcmp strcoll strcpy strcspn strerror strlen + strncat strncmp strncpy strpbrk strrchr strspn strstr + strtok strxfrm)], + + sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG + S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR + fstat mkfifo)], + + sys_times_h => [], + + sys_types_h => [], + + sys_utsname_h => [qw(uname)], + + sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED + WNOHANG WSTOPSIG WTERMSIG WUNTRACED)], + + termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 + B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL + CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK + ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR + INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST + PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION + TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW + TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART + VSTOP VSUSP VTIME + cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain + tcflow tcflush tcgetattr tcsendbreak tcsetattr )], + + time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime + difftime mktime strftime tzset tzname)], + + unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET + STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK + _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON + _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX + _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED + _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS + _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX + _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL + _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS + _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION + _exit access ctermid cuserid + dup2 dup execl execle execlp execv execve execvp + fpathconf fsync getcwd getegid geteuid getgid getgroups + getpid getuid isatty lseek pathconf pause setgid setpgid + setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)], + + utime_h => [], + +); + +# Exporter::export_tags(); +for (values %EXPORT_TAGS) { + push @EXPORT, @$_; +} + +@EXPORT_OK = qw( + abs + alarm + atan2 + chdir + chmod + chown + close + closedir + cos + exit + exp + fcntl + fileno + fork + getc + getgrgid + getgrnam + getlogin + getpgrp + getppid + getpwnam + getpwuid + gmtime + isatty + kill + lchown + link + localtime + log + mkdir + nice + open + opendir + pipe + printf + rand + read + readdir + rename + rewinddir + rmdir + sin + sleep + sprintf + sqrt + srand + stat + system + time + times + umask + unlink + utime + wait + waitpid + write +); + +require Exporter; +} + +package POSIX::SigAction; + +sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} }; +sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} }; +sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} }; +sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} }; diff --git a/Master/tlpkg/installer/perllib/Pod/Checker.pm b/Master/tlpkg/installer/perllib/Pod/Checker.pm new file mode 100644 index 00000000000..49162da4a27 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Checker.pm @@ -0,0 +1,1270 @@ +############################################################################# +# Pod/Checker.pm -- check pod documents for syntax errors +# +# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Checker; + +use vars qw($VERSION); +$VERSION = 1.43; ## Current version of this package +require 5.005; ## requires this Perl version or later + +use Pod::ParseUtils; ## for hyperlinks and lists + +=head1 NAME + +Pod::Checker, podchecker() - check pod documents for syntax errors + +=head1 SYNOPSIS + + use Pod::Checker; + + $syntax_okay = podchecker($filepath, $outputpath, %options); + + my $checker = new Pod::Checker %options; + $checker->parse_from_file($filepath, \*STDERR); + +=head1 OPTIONS/ARGUMENTS + +C<$filepath> is the input POD to read and C<$outputpath> is +where to write POD syntax error messages. Either argument may be a scalar +indicating a file-path, or else a reference to an open filehandle. +If unspecified, the input-file it defaults to C<\*STDIN>, and +the output-file defaults to C<\*STDERR>. + +=head2 podchecker() + +This function can take a hash of options: + +=over 4 + +=item B<-warnings> =E<gt> I<val> + +Turn warnings on/off. I<val> is usually 1 for on, but higher values +trigger additional warnings. See L<"Warnings">. + +=back + +=head1 DESCRIPTION + +B<podchecker> will perform syntax checking of Perl5 POD format documentation. + +Curious/ambitious users are welcome to propose additional features they wish +to see in B<Pod::Checker> and B<podchecker> and verify that the checks are +consistent with L<perlpod>. + +The following checks are currently performed: + +=over 4 + +=item * + +Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences, +and unterminated interior sequences. + +=item * + +Check for proper balancing of C<=begin> and C<=end>. The contents of such +a block are generally ignored, i.e. no syntax checks are performed. + +=item * + +Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>. + +=item * + +Check for same nested interior-sequences (e.g. +C<LE<lt>...LE<lt>...E<gt>...E<gt>>). + +=item * + +Check for malformed or nonexisting entities C<EE<lt>...E<gt>>. + +=item * + +Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod> +for details. + +=item * + +Check for unresolved document-internal links. This check may also reveal +misspelled links that seem to be internal links but should be links +to something else. + +=back + +=head1 DIAGNOSTICS + +=head2 Errors + +=over 4 + +=item * empty =headn + +A heading (C<=head1> or C<=head2>) without any text? That ain't no +heading! + +=item * =over on line I<N> without closing =back + +The C<=over> command does not have a corresponding C<=back> before the +next heading (C<=head1> or C<=head2>) or the end of the file. + +=item * =item without previous =over + +=item * =back without previous =over + +An C<=item> or C<=back> command has been found outside a +C<=over>/C<=back> block. + +=item * No argument for =begin + +A C<=begin> command was found that is not followed by the formatter +specification. + +=item * =end without =begin + +A standalone C<=end> command was found. + +=item * Nested =begin's + +There were at least two consecutive C<=begin> commands without +the corresponding C<=end>. Only one C<=begin> may be active at +a time. + +=item * =for without formatter specification + +There is no specification of the formatter after the C<=for> command. + +=item * unresolved internal link I<NAME> + +The given link to I<NAME> does not have a matching node in the current +POD. This also happend when a single word node name is not enclosed in +C<"">. + +=item * Unknown command "I<CMD>" + +An invalid POD command has been found. Valid are C<=head1>, C<=head2>, +C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>, +C<=for>, C<=pod>, C<=cut> + +=item * Unknown interior-sequence "I<SEQ>" + +An invalid markup command has been encountered. Valid are: +C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>, +C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>, +C<ZE<lt>E<gt>> + +=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt> + +Two nested identical markup commands have been found. Generally this +does not make sense. + +=item * garbled entity I<STRING> + +The I<STRING> found cannot be interpreted as a character entity. + +=item * Entity number out of range + +An entity specified by number (dec, hex, oct) is out of range (1-255). + +=item * malformed link LE<lt>E<gt> + +The link found cannot be parsed because it does not conform to the +syntax described in L<perlpod>. + +=item * nonempty ZE<lt>E<gt> + +The C<ZE<lt>E<gt>> sequence is supposed to be empty. + +=item * empty XE<lt>E<gt> + +The index entry specified contains nothing but whitespace. + +=item * Spurious text after =pod / =cut + +The commands C<=pod> and C<=cut> do not take any arguments. + +=item * Spurious character(s) after =back + +The C<=back> command does not take any arguments. + +=back + +=head2 Warnings + +These may not necessarily cause trouble, but indicate mediocre style. + +=over 4 + +=item * multiple occurrence of link target I<name> + +The POD file has some C<=item> and/or C<=head> commands that have +the same text. Potential hyperlinks to such a text cannot be unique then. +This warning is printed only with warning level greater than one. + +=item * line containing nothing but whitespace in paragraph + +There is some whitespace on a seemingly empty line. POD is very sensitive +to such things, so this is flagged. B<vi> users switch on the B<list> +option to avoid this problem. + +=begin _disabled_ + +=item * file does not start with =head + +The file starts with a different POD directive than head. +This is most probably something you do not want. + +=end _disabled_ + +=item * previous =item has no contents + +There is a list C<=item> right above the flagged line that has no +text contents. You probably want to delete empty items. + +=item * preceding non-item paragraph(s) + +A list introduced by C<=over> starts with a text or verbatim paragraph, +but continues with C<=item>s. Move the non-item paragraph out of the +C<=over>/C<=back> block. + +=item * =item type mismatch (I<one> vs. I<two>) + +A list started with e.g. a bulletted C<=item> and continued with a +numbered one. This is obviously inconsistent. For most translators the +type of the I<first> C<=item> determines the type of the list. + +=item * I<N> unescaped C<E<lt>E<gt>> in paragraph + +Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>> +can potentially cause errors as they could be misinterpreted as +markup commands. This is only printed when the -warnings level is +greater than 1. + +=item * Unknown entity + +A character entity was found that does not belong to the standard +ISO set or the POD specials C<verbar> and C<sol>. + +=item * No items in =over + +The list opened with C<=over> does not contain any items. + +=item * No argument for =item + +C<=item> without any parameters is deprecated. It should either be followed +by C<*> to indicate an unordered list, by a number (optionally followed +by a dot) to indicate an ordered (numbered) list or simple text for a +definition list. + +=item * empty section in previous paragraph + +The previous section (introduced by a C<=head> command) does not contain +any text. This usually indicates that something is missing. Note: A +C<=head1> followed immediately by C<=head2> does not trigger this warning. + +=item * Verbatim paragraph in NAME section + +The NAME section (C<=head1 NAME>) should consist of a single paragraph +with the script/module name, followed by a dash `-' and a very short +description of what the thing is good for. + +=item * =headI<n> without preceding higher level + +For example if there is a C<=head2> in the POD file prior to a +C<=head1>. + +=back + +=head2 Hyperlinks + +There are some warnings wrt. malformed hyperlinks. + +=over 4 + +=item * ignoring leading/trailing whitespace in link + +There is whitespace at the beginning or the end of the contents of +LE<lt>...E<gt>. + +=item * (section) in '$page' deprecated + +There is a section detected in the page name of LE<lt>...E<gt>, e.g. +C<LE<lt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only. +Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able +to expand this to appropriate code. For links to (builtin) functions, +please say C<LE<lt>perlfunc/mkdirE<gt>>, without (). + +=item * alternative text/node '%s' contains non-escaped | or / + +The characters C<|> and C</> are special in the LE<lt>...E<gt> context. +Although the hyperlink parser does its best to determine which "/" is +text and which is a delimiter in case of doubt, one ought to escape +these literal characters like this: + + / E<sol> + | E<verbar> + +=back + +=head1 RETURN VALUE + +B<podchecker> returns the number of POD syntax errors found or -1 if +there were no POD commands at all found in the file. + +=head1 EXAMPLES + +See L</SYNOPSIS> + +=head1 INTERFACE + +While checking, this module collects document properties, e.g. the nodes +for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>). +POD translators can use this feature to syntax-check and get the nodes in +a first pass before actually starting to convert. This is expensive in terms +of execution time, but allows for very robust conversions. + +Since PodParser-1.24 the B<Pod::Checker> module uses only the B<poderror> +method to print errors and warnings. The summary output (e.g. +"Pod syntax OK") has been dropped from the module and has been included in +B<podchecker> (the script). This allows users of B<Pod::Checker> to +control completely the output behaviour. Users of B<podchecker> (the script) +get the well-known behaviour. + +=cut + +############################################################################# + +use strict; +#use diagnostics; +use Carp; +use Exporter; +use Pod::Parser; + +use vars qw(@ISA @EXPORT); +@ISA = qw(Pod::Parser); +@EXPORT = qw(&podchecker); + +use vars qw(%VALID_COMMANDS %VALID_SEQUENCES); + +my %VALID_COMMANDS = ( + 'pod' => 1, + 'cut' => 1, + 'head1' => 1, + 'head2' => 1, + 'head3' => 1, + 'head4' => 1, + 'over' => 1, + 'back' => 1, + 'item' => 1, + 'for' => 1, + 'begin' => 1, + 'end' => 1, +); + +my %VALID_SEQUENCES = ( + 'I' => 1, + 'B' => 1, + 'S' => 1, + 'C' => 1, + 'L' => 1, + 'F' => 1, + 'X' => 1, + 'Z' => 1, + 'E' => 1, +); + +# stolen from HTML::Entities +my %ENTITIES = ( + # Some normal chars that have special meaning in SGML context + amp => '&', # ampersand +'gt' => '>', # greater than +'lt' => '<', # less than + quot => '"', # double quote + + # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML + AElig => 'Æ', # capital AE diphthong (ligature) + Aacute => 'Á', # capital A, acute accent + Acirc => 'Â', # capital A, circumflex accent + Agrave => 'À', # capital A, grave accent + Aring => 'Å', # capital A, ring + Atilde => 'Ã', # capital A, tilde + Auml => 'Ä', # capital A, dieresis or umlaut mark + Ccedil => 'Ç', # capital C, cedilla + ETH => 'Ð', # capital Eth, Icelandic + Eacute => 'É', # capital E, acute accent + Ecirc => 'Ê', # capital E, circumflex accent + Egrave => 'È', # capital E, grave accent + Euml => 'Ë', # capital E, dieresis or umlaut mark + Iacute => 'Í', # capital I, acute accent + Icirc => 'Î', # capital I, circumflex accent + Igrave => 'Ì', # capital I, grave accent + Iuml => 'Ï', # capital I, dieresis or umlaut mark + Ntilde => 'Ñ', # capital N, tilde + Oacute => 'Ó', # capital O, acute accent + Ocirc => 'Ô', # capital O, circumflex accent + Ograve => 'Ò', # capital O, grave accent + Oslash => 'Ø', # capital O, slash + Otilde => 'Õ', # capital O, tilde + Ouml => 'Ö', # capital O, dieresis or umlaut mark + THORN => 'Þ', # capital THORN, Icelandic + Uacute => 'Ú', # capital U, acute accent + Ucirc => 'Û', # capital U, circumflex accent + Ugrave => 'Ù', # capital U, grave accent + Uuml => 'Ü', # capital U, dieresis or umlaut mark + Yacute => 'Ý', # capital Y, acute accent + aacute => 'á', # small a, acute accent + acirc => 'â', # small a, circumflex accent + aelig => 'æ', # small ae diphthong (ligature) + agrave => 'à', # small a, grave accent + aring => 'å', # small a, ring + atilde => 'ã', # small a, tilde + auml => 'ä', # small a, dieresis or umlaut mark + ccedil => 'ç', # small c, cedilla + eacute => 'é', # small e, acute accent + ecirc => 'ê', # small e, circumflex accent + egrave => 'è', # small e, grave accent + eth => 'ð', # small eth, Icelandic + euml => 'ë', # small e, dieresis or umlaut mark + iacute => 'í', # small i, acute accent + icirc => 'î', # small i, circumflex accent + igrave => 'ì', # small i, grave accent + iuml => 'ï', # small i, dieresis or umlaut mark + ntilde => 'ñ', # small n, tilde + oacute => 'ó', # small o, acute accent + ocirc => 'ô', # small o, circumflex accent + ograve => 'ò', # small o, grave accent + oslash => 'ø', # small o, slash + otilde => 'õ', # small o, tilde + ouml => 'ö', # small o, dieresis or umlaut mark + szlig => 'ß', # small sharp s, German (sz ligature) + thorn => 'þ', # small thorn, Icelandic + uacute => 'ú', # small u, acute accent + ucirc => 'û', # small u, circumflex accent + ugrave => 'ù', # small u, grave accent + uuml => 'ü', # small u, dieresis or umlaut mark + yacute => 'ý', # small y, acute accent + yuml => 'ÿ', # small y, dieresis or umlaut mark + + # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96) + copy => '©', # copyright sign + reg => '®', # registered sign + nbsp => "\240", # non breaking space + + # Additional ISO-8859/1 entities listed in rfc1866 (section 14) + iexcl => '¡', + cent => '¢', + pound => '£', + curren => '¤', + yen => '¥', + brvbar => '¦', + sect => '§', + uml => '¨', + ordf => 'ª', + laquo => '«', +'not' => '¬', # not is a keyword in perl + shy => '', + macr => '¯', + deg => '°', + plusmn => '±', + sup1 => '¹', + sup2 => '²', + sup3 => '³', + acute => '´', + micro => 'µ', + para => '¶', + middot => '·', + cedil => '¸', + ordm => 'º', + raquo => '»', + frac14 => '¼', + frac12 => '½', + frac34 => '¾', + iquest => '¿', +'times' => '×', # times is a keyword in perl + divide => '÷', + +# some POD special entities + verbar => '|', + sol => '/' +); + +##--------------------------------------------------------------------------- + +##--------------------------------- +## Function definitions begin here +##--------------------------------- + +sub podchecker( $ ; $ % ) { + my ($infile, $outfile, %options) = @_; + local $_; + + ## Set defaults + $infile ||= \*STDIN; + $outfile ||= \*STDERR; + + ## Now create a pod checker + my $checker = new Pod::Checker(%options); + + ## Now check the pod document for errors + $checker->parse_from_file($infile, $outfile); + + ## Return the number of errors found + return $checker->num_errors(); +} + +##--------------------------------------------------------------------------- + +##------------------------------- +## Method definitions begin here +##------------------------------- + +################################## + +=over 4 + +=item C<Pod::Checker-E<gt>new( %options )> + +Return a reference to a new Pod::Checker object that inherits from +Pod::Parser and is used for calling the required methods later. The +following options are recognized: + +C<-warnings =E<gt> num> + Print warnings if C<num> is true. The higher the value of C<num>, +the more warnings are printed. Currently there are only levels 1 and 2. + +C<-quiet =E<gt> num> + If C<num> is true, do not print any errors/warnings. This is useful +when Pod::Checker is used to munge POD code into plain text from within +POD formatters. + +=cut + +## sub new { +## my $this = shift; +## my $class = ref($this) || $this; +## my %params = @_; +## my $self = {%params}; +## bless $self, $class; +## $self->initialize(); +## return $self; +## } + +sub initialize { + my $self = shift; + ## Initialize number of errors, and setup an error function to + ## increment this number and then print to the designated output. + $self->{_NUM_ERRORS} = 0; + $self->{_NUM_WARNINGS} = 0; + $self->{-quiet} ||= 0; + # set the error handling subroutine + $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror'); + $self->{_commands} = 0; # total number of POD commands encountered + $self->{_list_stack} = []; # stack for nested lists + $self->{_have_begin} = ''; # stores =begin + $self->{_links} = []; # stack for internal hyperlinks + $self->{_nodes} = []; # stack for =head/=item nodes + $self->{_index} = []; # text in X<> + # print warnings? + $self->{-warnings} = 1 unless(defined $self->{-warnings}); + $self->{_current_head1} = ''; # the current =head1 block + $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings}); +} + +################################## + +=item C<$checker-E<gt>poderror( @args )> + +=item C<$checker-E<gt>poderror( {%opts}, @args )> + +Internal method for printing errors and warnings. If no options are +given, simply prints "@_". The following options are recognized and used +to form the output: + + -msg + +A message to print prior to C<@args>. + + -line + +The line number the error occurred in. + + -file + +The file (name) the error occurred in. + + -severity + +The error level, should be 'WARNING' or 'ERROR'. + +=cut + +# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args ) +sub poderror { + my $self = shift; + my %opts = (ref $_[0]) ? %{shift()} : (); + + ## Retrieve options + chomp( my $msg = ($opts{-msg} || "")."@_" ); + my $line = (exists $opts{-line}) ? " at line $opts{-line}" : ""; + my $file = (exists $opts{-file}) ? " in file $opts{-file}" : ""; + unless (exists $opts{-severity}) { + ## See if can find severity in message prefix + $opts{-severity} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// ); + } + my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : ""; + + ## Increment error count and print message " + ++($self->{_NUM_ERRORS}) + if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR')); + ++($self->{_NUM_WARNINGS}) + if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING')); + unless($self->{-quiet}) { + my $out_fh = $self->output_handle() || \*STDERR; + print $out_fh ($severity, $msg, $line, $file, "\n") + if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING'); + } +} + +################################## + +=item C<$checker-E<gt>num_errors()> + +Set (if argument specified) and retrieve the number of errors found. + +=cut + +sub num_errors { + return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS}; +} + +################################## + +=item C<$checker-E<gt>num_warnings()> + +Set (if argument specified) and retrieve the number of warnings found. + +=cut + +sub num_warnings { + return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS}; +} + +################################## + +=item C<$checker-E<gt>name()> + +Set (if argument specified) and retrieve the canonical name of POD as +found in the C<=head1 NAME> section. + +=cut + +sub name { + return (@_ > 1 && $_[1]) ? + ($_[0]->{-name} = $_[1]) : $_[0]->{-name}; +} + +################################## + +=item C<$checker-E<gt>node()> + +Add (if argument specified) and retrieve the nodes (as defined by C<=headX> +and C<=item>) of the current POD. The nodes are returned in the order of +their occurrence. They consist of plain text, each piece of whitespace is +collapsed to a single blank. + +=cut + +sub node { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/\s+$//s; # strip trailing whitespace + $text =~ s/\s+/ /gs; # collapse whitespace + # add node, order important! + push(@{$self->{_nodes}}, $text); + # keep also a uniqueness counter + $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); + return $text; + } + @{$self->{_nodes}}; +} + +################################## + +=item C<$checker-E<gt>idx()> + +Add (if argument specified) and retrieve the index entries (as defined by +C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece +of whitespace is collapsed to a single blank. + +=cut + +# set/return index entries of current POD +sub idx { + my ($self,$text) = @_; + if(defined $text) { + $text =~ s/\s+$//s; # strip trailing whitespace + $text =~ s/\s+/ /gs; # collapse whitespace + # add node, order important! + push(@{$self->{_index}}, $text); + # keep also a uniqueness counter + $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s); + return $text; + } + @{$self->{_index}}; +} + +################################## + +=item C<$checker-E<gt>hyperlink()> + +Add (if argument specified) and retrieve the hyperlinks (as defined by +C<LE<lt>E<gt>>) of the current POD. They consist of a 2-item array: line +number and C<Pod::Hyperlink> object. + +=back + +=cut + +# set/return hyperlinks of the current POD +sub hyperlink { + my $self = shift; + if($_[0]) { + push(@{$self->{_links}}, $_[0]); + return $_[0]; + } + @{$self->{_links}}; +} + +## overrides for Pod::Parser + +sub end_pod { + ## Do some final checks and + ## print the number of errors found + my $self = shift; + my $infile = $self->input_file(); + + if(@{$self->{_list_stack}}) { + my $list; + while(($list = $self->_close_list('EOF',$infile)) && + $list->indent() ne 'auto') { + $self->poderror({ -line => 'EOF', -file => $infile, + -severity => 'ERROR', -msg => "=over on line " . + $list->start() . " without closing =back" }); #" + } + } + + # check validity of document internal hyperlinks + # first build the node names from the paragraph text + my %nodes; + foreach($self->node()) { + $nodes{$_} = 1; + if(/^(\S+)\s+\S/) { + # we have more than one word. Use the first as a node, too. + # This is used heavily in perlfunc.pod + $nodes{$1} ||= 2; # derived node + } + } + foreach($self->idx()) { + $nodes{$_} = 3; # index node + } + foreach($self->hyperlink()) { + my ($line,$link) = @$_; + # _TODO_ what if there is a link to the page itself by the name, + # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION"> + if($link->node() && !$link->page() && $link->type() ne 'hyperlink') { + my $node = $self->_check_ptree($self->parse_text($link->node(), + $line), $line, $infile, 'L'); + if($node && !$nodes{$node}) { + $self->poderror({ -line => $line || '', -file => $infile, + -severity => 'ERROR', + -msg => "unresolved internal link '$node'"}); + } + } + } + + # check the internal nodes for uniqueness. This pertains to + # =headX, =item and X<...> + if($self->{-warnings} && $self->{-warnings}>1) { + foreach(grep($self->{_unique_nodes}->{$_} > 1, + keys %{$self->{_unique_nodes}})) { + $self->poderror({ -line => '-', -file => $infile, + -severity => 'WARNING', + -msg => "multiple occurrence of link target '$_'"}); + } + } + + # no POD found here + $self->num_errors(-1) if($self->{_commands} == 0); +} + +# check a POD command directive +sub command { + my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_; + my ($file, $line) = $pod_para->file_line; + ## Check the command syntax + my $arg; # this will hold the command argument + if (! $VALID_COMMANDS{$cmd}) { + $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR', + -msg => "Unknown command '$cmd'" }); + } + else { # found a valid command + $self->{_commands}++; # delete this line if below is enabled again + + ##### following check disabled due to strong request + #if(!$self->{_commands}++ && $cmd !~ /^head/) { + # $self->poderror({ -line => $line, -file => $file, + # -severity => 'WARNING', + # -msg => "file does not start with =head" }); + #} + + # check syntax of particular command + if($cmd eq 'over') { + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line,$file); + my $indent = 4; # default + if($arg && $arg =~ /^\s*(\d+)\s*$/) { + $indent = $1; + } + # start a new list + $self->_open_list($indent,$line,$file); + } + elsif($cmd eq 'item') { + # are we in a list? + unless(@{$self->{_list_stack}}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "=item without previous =over" }); + # auto-open in case we encounter many more + $self->_open_list('auto',$line,$file); + } + my $list = $self->{_list_stack}->[0]; + # check whether the previous item had some contents + if(defined $self->{_list_item_contents} && + $self->{_list_item_contents} == 0) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "previous =item has no contents" }); + } + if($list->{_has_par}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "preceding non-item paragraph(s)" }); + delete $list->{_has_par}; + } + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line, $file); + if($arg && $arg =~ /(\S+)/) { + $arg =~ s/[\s\n]+$//; + my $type; + if($arg =~ /^[*]\s*(\S*.*)/) { + $type = 'bullet'; + $self->{_list_item_contents} = $1 ? 1 : 0; + $arg = $1; + } + elsif($arg =~ /^\d+\.?\s*(\S*)/) { + $type = 'number'; + $self->{_list_item_contents} = $1 ? 1 : 0; + $arg = $1; + } + else { + $type = 'definition'; + $self->{_list_item_contents} = 1; + } + my $first = $list->type(); + if($first && $first ne $type) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "=item type mismatch ('$first' vs. '$type')"}); + } + else { # first item + $list->type($type); + } + } + else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "No argument for =item" }); + $arg = ' '; # empty + $self->{_list_item_contents} = 0; + } + # add this item + $list->item($arg); + # remember this node + $self->node($arg); + } + elsif($cmd eq 'back') { + # check if we have an open list + unless(@{$self->{_list_stack}}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "=back without previous =over" }); + } + else { + # check for spurious characters + $arg = $self->interpolate_and_check($paragraph, $line,$file); + if($arg && $arg =~ /\S/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Spurious character(s) after =back" }); + } + # close list + my $list = $self->_close_list($line,$file); + # check for empty lists + if(!$list->item() && $self->{-warnings}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "No items in =over (at line " . + $list->start() . ") / =back list"}); #" + } + } + } + elsif($cmd =~ /^head(\d+)/) { + my $hnum = $1; + $self->{"_have_head_$hnum"}++; # count head types + if($hnum > 1 && !$self->{"_have_head_".($hnum -1)}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "=head$hnum without preceding higher level"}); + } + # check whether the previous =head section had some contents + if(defined $self->{_commands_in_head} && + $self->{_commands_in_head} == 0 && + defined $self->{_last_head} && + $self->{_last_head} >= $hnum) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "empty section in previous paragraph"}); + } + $self->{_commands_in_head} = -1; + $self->{_last_head} = $hnum; + # check if there is an open list + if(@{$self->{_list_stack}}) { + my $list; + while(($list = $self->_close_list($line,$file)) && + $list->indent() ne 'auto') { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "=over on line ". $list->start() . + " without closing =back (at $cmd)" }); + } + } + # remember this node + $arg = $self->interpolate_and_check($paragraph, $line,$file); + $arg =~ s/[\s\n]+$//s; + $self->node($arg); + unless(length($arg)) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "empty =$cmd"}); + } + if($cmd eq 'head1') { + $self->{_current_head1} = $arg; + } else { + $self->{_current_head1} = ''; + } + } + elsif($cmd eq 'begin') { + if($self->{_have_begin}) { + # already have a begin + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Nested =begin's (first at line " . + $self->{_have_begin} . ")"}); + } + else { + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line,$file); + unless($arg && $arg =~ /(\S+)/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "No argument for =begin"}); + } + # remember the =begin + $self->{_have_begin} = "$line:$1"; + } + } + elsif($cmd eq 'end') { + if($self->{_have_begin}) { + # close the existing =begin + $self->{_have_begin} = ''; + # check for spurious characters + $arg = $self->interpolate_and_check($paragraph, $line,$file); + # the closing argument is optional + #if($arg && $arg =~ /\S/) { + # $self->poderror({ -line => $line, -file => $file, + # -severity => 'WARNING', + # -msg => "Spurious character(s) after =end" }); + #} + } + else { + # don't have a matching =begin + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "=end without =begin" }); + } + } + elsif($cmd eq 'for') { + unless($paragraph =~ /\s*(\S+)\s*/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "=for without formatter specification" }); + } + $arg = ''; # do not expand paragraph below + } + elsif($cmd =~ /^(pod|cut)$/) { + # check for argument + $arg = $self->interpolate_and_check($paragraph, $line,$file); + if($arg && $arg =~ /(\S+)/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Spurious text after =$cmd"}); + } + } + $self->{_commands_in_head}++; + ## Check the interior sequences in the command-text + $self->interpolate_and_check($paragraph, $line,$file) + unless(defined $arg); + } +} + +sub _open_list +{ + my ($self,$indent,$line,$file) = @_; + my $list = Pod::List->new( + -indent => $indent, + -start => $line, + -file => $file); + unshift(@{$self->{_list_stack}}, $list); + undef $self->{_list_item_contents}; + $list; +} + +sub _close_list +{ + my ($self,$line,$file) = @_; + my $list = shift(@{$self->{_list_stack}}); + if(defined $self->{_list_item_contents} && + $self->{_list_item_contents} == 0) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "previous =item has no contents" }); + } + undef $self->{_list_item_contents}; + $list; +} + +# process a block of some text +sub interpolate_and_check { + my ($self, $paragraph, $line, $file) = @_; + ## Check the interior sequences in the command-text + # and return the text + $self->_check_ptree( + $self->parse_text($paragraph,$line), $line, $file, ''); +} + +sub _check_ptree { + my ($self,$ptree,$line,$file,$nestlist) = @_; + local($_); + my $text = ''; + # process each node in the parse tree + foreach(@$ptree) { + # regular text chunk + unless(ref) { + # count the unescaped angle brackets + # complain only when warning level is greater than 1 + if($self->{-warnings} && $self->{-warnings}>1) { + my $count; + if($count = tr/<>/<>/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "$count unescaped <> in paragraph" }); + } + } + $text .= $_; + next; + } + # have an interior sequence + my $cmd = $_->cmd_name(); + my $contents = $_->parse_tree(); + ($file,$line) = $_->file_line(); + # check for valid tag + if (! $VALID_SEQUENCES{$cmd}) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => qq(Unknown interior-sequence '$cmd')}); + # expand it anyway + $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); + next; + } + if($nestlist =~ /$cmd/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "nested commands $cmd<...$cmd<...>...>"}); + # _TODO_ should we add the contents anyway? + # expand it anyway, see below + } + if($cmd eq 'E') { + # preserve entities + if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "garbled entity " . $_->raw_text()}); + next; + } + my $ent = $$contents[0]; + my $val; + if($ent =~ /^0x[0-9a-f]+$/i) { + # hexadec entity + $val = hex($ent); + } + elsif($ent =~ /^0\d+$/) { + # octal + $val = oct($ent); + } + elsif($ent =~ /^\d+$/) { + # numeric entity + $val = $ent; + } + if(defined $val) { + if($val>0 && $val<256) { + $text .= chr($val); + } + else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Entity number out of range " . $_->raw_text()}); + } + } + elsif($ENTITIES{$ent}) { + # known ISO entity + $text .= $ENTITIES{$ent}; + } + else { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => "Unknown entity " . $_->raw_text()}); + $text .= "E<$ent>"; + } + } + elsif($cmd eq 'L') { + # try to parse the hyperlink + my $link = Pod::Hyperlink->new($contents->raw_text()); + unless(defined $link) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "malformed link " . $_->raw_text() ." : $@"}); + next; + } + $link->line($line); # remember line + if($self->{-warnings}) { + foreach my $w ($link->warning()) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => $w }); + } + } + # check the link text + $text .= $self->_check_ptree($self->parse_text($link->text(), + $line), $line, $file, "$nestlist$cmd"); + # remember link + $self->hyperlink([$line,$link]); + } + elsif($cmd =~ /[BCFIS]/) { + # add the guts + $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); + } + elsif($cmd eq 'Z') { + if(length($contents->raw_text())) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Nonempty Z<>"}); + } + } + elsif($cmd eq 'X') { + my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd"); + if($idx =~ /^\s*$/s) { + $self->poderror({ -line => $line, -file => $file, + -severity => 'ERROR', + -msg => "Empty X<>"}); + } + else { + # remember this node + $self->idx($idx); + } + } + else { + # not reached + die "internal error"; + } + } + $text; +} + +# process a block of verbatim text +sub verbatim { + ## Nothing particular to check + my ($self, $paragraph, $line_num, $pod_para) = @_; + + $self->_preproc_par($paragraph); + + if($self->{_current_head1} eq 'NAME') { + my ($file, $line) = $pod_para->file_line; + $self->poderror({ -line => $line, -file => $file, + -severity => 'WARNING', + -msg => 'Verbatim paragraph in NAME section' }); + } +} + +# process a block of regular text +sub textblock { + my ($self, $paragraph, $line_num, $pod_para) = @_; + my ($file, $line) = $pod_para->file_line; + + $self->_preproc_par($paragraph); + + # skip this paragraph if in a =begin block + unless($self->{_have_begin}) { + my $block = $self->interpolate_and_check($paragraph, $line,$file); + if($self->{_current_head1} eq 'NAME') { + if($block =~ /^\s*(\S+?)\s*[,-]/) { + # this is the canonical name + $self->{-name} = $1 unless(defined $self->{-name}); + } + } + } +} + +sub _preproc_par +{ + my $self = shift; + $_[0] =~ s/[\s\n]+$//; + if($_[0]) { + $self->{_commands_in_head}++; + $self->{_list_item_contents}++ if(defined $self->{_list_item_contents}); + if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) { + $self->{_list_stack}->[0]->{_has_par} = 1; + } + } +} + +1; + +__END__ + +=head1 AUTHOR + +Please report bugs using L<http://rt.cpan.org>. + +Brad Appleton E<lt>bradapp@enteract.comE<gt> (initial version), +Marek Rouchal E<lt>marekr@cpan.orgE<gt> + +Based on code for B<Pod::Text::pod2text()> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/Find.pm b/Master/tlpkg/installer/perllib/Pod/Find.pm new file mode 100644 index 00000000000..0b085b8c9e3 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Find.pm @@ -0,0 +1,523 @@ +############################################################################# +# Pod/Find.pm -- finds files containing POD documentation +# +# Author: Marek Rouchal <marekr@cpan.org> +# +# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code +# from Nick Ing-Simmon's PodToHtml). All rights reserved. +# This file is part of "PodParser". Pod::Find is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Find; + +use vars qw($VERSION); +$VERSION = 1.34; ## Current version of this package +require 5.005; ## requires this Perl version or later +use Carp; + +############################################################################# + +=head1 NAME + +Pod::Find - find POD documents in directory trees + +=head1 SYNOPSIS + + use Pod::Find qw(pod_find simplify_name); + my %pods = pod_find({ -verbose => 1, -inc => 1 }); + foreach(keys %pods) { + print "found library POD `$pods{$_}' in $_\n"; + } + + print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n"; + + $location = pod_where( { -inc => 1 }, "Pod::Find" ); + +=head1 DESCRIPTION + +B<Pod::Find> provides a set of functions to locate POD files. Note that +no function is exported by default to avoid pollution of your namespace, +so be sure to specify them in the B<use> statement if you need them: + + use Pod::Find qw(pod_find); + +From this version on the typical SCM (software configuration management) +files/directories like RCS, CVS, SCCS, .svn are ignored. + +=cut + +use strict; +#use diagnostics; +use Exporter; +use File::Spec; +use File::Find; +use Cwd; + +use vars qw(@ISA @EXPORT_OK $VERSION); +@ISA = qw(Exporter); +@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod); + +# package global variables +my $SIMPLIFY_RX; + +=head2 C<pod_find( { %opts } , @directories )> + +The function B<pod_find> searches for POD documents in a given set of +files and/or directories. It returns a hash with the file names as keys +and the POD name as value. The POD name is derived from the file name +and its position in the directory tree. + +E.g. when searching in F<$HOME/perl5lib>, the file +F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>, +whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be +I<Myclass::Subclass>. The name information can be used for POD +translators. + +Only text files containing at least one valid POD command are found. + +A warning is printed if more than one POD file with the same POD name +is found, e.g. F<CPAN.pm> in different directories. This usually +indicates duplicate occurrences of modules in the I<@INC> search path. + +B<OPTIONS> The first argument for B<pod_find> may be a hash reference +with options. The rest are either directories that are searched +recursively or files. The POD names of files are the plain basenames +with any Perl-like extension (.pm, .pl, .pod) stripped. + +=over 4 + +=item C<-verbose =E<gt> 1> + +Print progress information while scanning. + +=item C<-perl =E<gt> 1> + +Apply Perl-specific heuristics to find the correct PODs. This includes +stripping Perl-like extensions, omitting subdirectories that are numeric +but do I<not> match the current Perl interpreter's version id, suppressing +F<site_perl> as a module hierarchy name etc. + +=item C<-script =E<gt> 1> + +Search for PODs in the current Perl interpreter's installation +B<scriptdir>. This is taken from the local L<Config|Config> module. + +=item C<-inc =E<gt> 1> + +Search for PODs in the current Perl interpreter's I<@INC> paths. This +automatically considers paths specified in the C<PERL5LIB> environment +as this is prepended to I<@INC> by the Perl interpreter itself. + +=back + +=cut + +# return a hash of the POD files found +# first argument may be a hashref (options), +# rest is a list of directories to search recursively +sub pod_find +{ + my %opts; + if(ref $_[0]) { + %opts = %{shift()}; + } + + $opts{-verbose} ||= 0; + $opts{-perl} ||= 0; + + my (@search) = @_; + + if($opts{-script}) { + require Config; + push(@search, $Config::Config{scriptdir}) + if -d $Config::Config{scriptdir}; + $opts{-perl} = 1; + } + + if($opts{-inc}) { + if ($^O eq 'MacOS') { + # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS + my @new_INC = @INC; + for (@new_INC) { + if ( $_ eq '.' ) { + $_ = ':'; + } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) { + $_ = ':'. $_; + } else { + $_ =~ s|^\./|:|; + } + } + push(@search, grep($_ ne File::Spec->curdir, @new_INC)); + } else { + push(@search, grep($_ ne File::Spec->curdir, @INC)); + } + + $opts{-perl} = 1; + } + + if($opts{-perl}) { + require Config; + # this code simplifies the POD name for Perl modules: + # * remove "site_perl" + # * remove e.g. "i586-linux" (from 'archname') + # * remove e.g. 5.00503 + # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) + + # Mac OS: + # * remove ":?site_perl:" + # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod) + + if ($^O eq 'MacOS') { + $SIMPLIFY_RX = + qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!; + } else { + $SIMPLIFY_RX = + qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!; + } + } + + my %dirs_visited; + my %pods; + my %names; + my $pwd = cwd(); + + foreach my $try (@search) { + unless(File::Spec->file_name_is_absolute($try)) { + # make path absolute + $try = File::Spec->catfile($pwd,$try); + } + # simplify path + # on VMS canonpath will vmsify:[the.path], but File::Find::find + # wants /unixy/paths + $try = File::Spec->canonpath($try) if ($^O ne 'VMS'); + $try = VMS::Filespec::unixify($try) if ($^O eq 'VMS'); + my $name; + if(-f $try) { + if($name = _check_and_extract_name($try, $opts{-verbose})) { + _check_for_duplicates($try, $name, \%names, \%pods); + } + next; + } + my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!; + File::Find::find( sub { + my $item = $File::Find::name; + if(-d) { + if($item =~ m{/(?:RCS|CVS|SCCS|\.svn)$}) { + $File::Find::prune = 1; + return; + } + elsif($dirs_visited{$item}) { + warn "Directory '$item' already seen, skipping.\n" + if($opts{-verbose}); + $File::Find::prune = 1; + return; + } + else { + $dirs_visited{$item} = 1; + } + if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) { + $File::Find::prune = 1; + warn "Perl $] version mismatch on $_, skipping.\n" + if($opts{-verbose}); + } + return; + } + if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) { + _check_for_duplicates($item, $name, \%names, \%pods); + } + }, $try); # end of File::Find::find + } + chdir $pwd; + %pods; +} + +sub _check_for_duplicates { + my ($file, $name, $names_ref, $pods_ref) = @_; + if($$names_ref{$name}) { + warn "Duplicate POD found (shadowing?): $name ($file)\n"; + warn " Already seen in ", + join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; + } + else { + $$names_ref{$name} = 1; + } + $$pods_ref{$file} = $name; +} + +sub _check_and_extract_name { + my ($file, $verbose, $root_rx) = @_; + + # check extension or executable flag + # this involves testing the .bat extension on Win32! + unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) { + return undef; + } + + return undef unless contains_pod($file,$verbose); + + # strip non-significant path components + # TODO what happens on e.g. Win32? + my $name = $file; + if(defined $root_rx) { + $name =~ s!$root_rx!!s; + $name =~ s!$SIMPLIFY_RX!!os if(defined $SIMPLIFY_RX); + } + else { + if ($^O eq 'MacOS') { + $name =~ s/^.*://s; + } else { + $name =~ s:^.*/::s; + } + } + _simplify($name); + $name =~ s!/+!::!g; #/ + if ($^O eq 'MacOS') { + $name =~ s!:+!::!g; # : -> :: + } else { + $name =~ s!/+!::!g; # / -> :: + } + $name; +} + +=head2 C<simplify_name( $str )> + +The function B<simplify_name> is equivalent to B<basename>, but also +strips Perl-like extensions (.pm, .pl, .pod) and extensions like +F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively. + +=cut + +# basic simplification of the POD name: +# basename & strip extension +sub simplify_name { + my ($str) = @_; + # remove all path components + if ($^O eq 'MacOS') { + $str =~ s/^.*://s; + } else { + $str =~ s:^.*/::s; + } + _simplify($str); + $str; +} + +# internal sub only +sub _simplify { + # strip Perl's own extensions + $_[0] =~ s/\.(pod|pm|plx?)\z//i; + # strip meaningless extensions on Win32 and OS/2 + $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i); + # strip meaningless extensions on VMS + $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS'); +} + +# contribution from Tim Jenness <t.jenness@jach.hawaii.edu> + +=head2 C<pod_where( { %opts }, $pod )> + +Returns the location of a pod document given a search directory +and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name. + +Options: + +=over 4 + +=item C<-inc =E<gt> 1> + +Search @INC for the pod and also the C<scriptdir> defined in the +L<Config|Config> module. + +=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]> + +Reference to an array of search directories. These are searched in order +before looking in C<@INC> (if B<-inc>). Current directory is used if +none are specified. + +=item C<-verbose =E<gt> 1> + +List directories as they are searched + +=back + +Returns the full path of the first occurrence to the file. +Package names (eg 'A::B') are automatically converted to directory +names in the selected directory. (eg on unix 'A::B' is converted to +'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the +search automatically if required. + +A subdirectory F<pod/> is also checked if it exists in any of the given +search directories. This ensures that e.g. L<perlfunc|perlfunc> is +found. + +It is assumed that if a module name is supplied, that that name +matches the file name. Pods are not opened to check for the 'NAME' +entry. + +A check is made to make sure that the file that is found does +contain some pod documentation. + +=cut + +sub pod_where { + + # default options + my %options = ( + '-inc' => 0, + '-verbose' => 0, + '-dirs' => [ File::Spec->curdir ], + ); + + # Check for an options hash as first argument + if (defined $_[0] && ref($_[0]) eq 'HASH') { + my $opt = shift; + + # Merge default options with supplied options + %options = (%options, %$opt); + } + + # Check usage + carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_)); + + # Read argument + my $pod = shift; + + # Split on :: and then join the name together using File::Spec + my @parts = split (/::/, $pod); + + # Get full directory list + my @search_dirs = @{ $options{'-dirs'} }; + + if ($options{'-inc'}) { + + require Config; + + # Add @INC + if ($^O eq 'MacOS' && $options{'-inc'}) { + # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS + my @new_INC = @INC; + for (@new_INC) { + if ( $_ eq '.' ) { + $_ = ':'; + } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) { + $_ = ':'. $_; + } else { + $_ =~ s|^\./|:|; + } + } + push (@search_dirs, @new_INC); + } elsif ($options{'-inc'}) { + push (@search_dirs, @INC); + } + + # Add location of pod documentation for perl man pages (eg perlfunc) + # This is a pod directory in the private install tree + #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'}, + # 'pod'); + #push (@search_dirs, $perlpoddir) + # if -d $perlpoddir; + + # Add location of binaries such as pod2text + push (@search_dirs, $Config::Config{'scriptdir'}) + if -d $Config::Config{'scriptdir'}; + } + + warn "Search path is: ".join(' ', @search_dirs)."\n" + if $options{'-verbose'}; + + # Loop over directories + Dir: foreach my $dir ( @search_dirs ) { + + # Don't bother if can't find the directory + if (-d $dir) { + warn "Looking in directory $dir\n" + if $options{'-verbose'}; + + # Now concatenate this directory with the pod we are searching for + my $fullname = File::Spec->catfile($dir, @parts); + warn "Filename is now $fullname\n" + if $options{'-verbose'}; + + # Loop over possible extensions + foreach my $ext ('', '.pod', '.pm', '.pl') { + my $fullext = $fullname . $ext; + if (-f $fullext && + contains_pod($fullext, $options{'-verbose'}) ) { + warn "FOUND: $fullext\n" if $options{'-verbose'}; + return $fullext; + } + } + } else { + warn "Directory $dir does not exist\n" + if $options{'-verbose'}; + next Dir; + } + # for some strange reason the path on MacOS/darwin/cygwin is + # 'pods' not 'pod' + # this could be the case also for other systems that + # have a case-tolerant file system, but File::Spec + # does not recognize 'darwin' yet. And cygwin also has "pods", + # but is not case tolerant. Oh well... + if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i) + && -d File::Spec->catdir($dir,'pods')) { + $dir = File::Spec->catdir($dir,'pods'); + redo Dir; + } + if(-d File::Spec->catdir($dir,'pod')) { + $dir = File::Spec->catdir($dir,'pod'); + redo Dir; + } + } + # No match; + return undef; +} + +=head2 C<contains_pod( $file , $verbose )> + +Returns true if the supplied filename (not POD module) contains some pod +information. + +=cut + +sub contains_pod { + my $file = shift; + my $verbose = 0; + $verbose = shift if @_; + + # check for one line of POD + unless(open(POD,"<$file")) { + warn "Error: $file is unreadable: $!\n"; + return undef; + } + + local $/ = undef; + my $pod = <POD>; + close(POD) || die "Error closing $file: $!\n"; + unless($pod =~ /^=(head\d|pod|over|item)\b/m) { + warn "No POD in $file, skipping.\n" + if($verbose); + return 0; + } + + return 1; +} + +=head1 AUTHOR + +Please report bugs using L<http://rt.cpan.org>. + +Marek Rouchal E<lt>marekr@cpan.orgE<gt>, +heavily borrowing code from Nick Ing-Simmons' PodToHtml. + +Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided +C<pod_where> and C<contains_pod>. + +=head1 SEE ALSO + +L<Pod::Parser>, L<Pod::Checker>, L<perldoc> + +=cut + +1; + diff --git a/Master/tlpkg/installer/perllib/Pod/Functions.pm b/Master/tlpkg/installer/perllib/Pod/Functions.pm new file mode 100644 index 00000000000..0e250cf0b50 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Functions.pm @@ -0,0 +1,376 @@ +package Pod::Functions; +use strict; + +=head1 NAME + +Pod::Functions - Group Perl's functions a la perlfunc.pod + +=head1 SYNOPSIS + + use Pod::Functions; + + my @misc_ops = @{ $Kinds{ 'Misc' } }; + my $misc_dsc = $Type_Description{ 'Misc' }; + +or + + perl /path/to/lib/Pod/Functions.pm + +This will print a grouped list of Perl's functions, like the +L<perlfunc/"Perl Functions by Category"> section. + +=head1 DESCRIPTION + +It exports the following variables: + +=over 4 + +=item %Kinds + +This holds a hash-of-lists. Each list contains the functions in the category +the key denotes. + +=item %Type + +In this hash each key represents a function and the value is the category. +The category can be a comma separated list. + +=item %Flavor + +In this hash each key represents a function and the value is a short +description of that function. + +=item %Type_Description + +In this hash each key represents a category of functions and the value is +a short description of that category. + +=item @Type_Order + +This list of categories is used to produce the same order as the +L<perlfunc/"Perl Functions by Category"> section. + +=back + +=head1 CHANGES + +1.02 20020813 <abe@ztreet.demon.nl> + de-typo in the SYNOPSIS section (thanks Mike Castle for noticing) + +1.01 20011229 <abe@ztreet.demon.nl> + fixed some bugs that slipped in after 5.6.1 + added the pod + finished making it strict safe + +1.00 ?? + first numbered version + +=cut + +our $VERSION = '1.03'; + +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order); + +our(%Kinds, %Type, %Flavor); + +our %Type_Description = ( + 'ARRAY' => 'Functions for real @ARRAYs', + 'Binary' => 'Functions for fixed length data or records', + 'File' => 'Functions for filehandles, files, or directories', + 'Flow' => 'Keywords related to control flow of your perl program', + 'HASH' => 'Functions for real %HASHes', + 'I/O' => 'Input and output functions', + 'LIST' => 'Functions for list data', + 'Math' => 'Numeric functions', + 'Misc' => 'Miscellaneous functions', + 'Modules' => 'Keywords related to perl modules', + 'Network' => 'Fetching network info', + 'Objects' => 'Keywords related to classes and object-orientedness', + 'Process' => 'Functions for processes and process groups', + 'Regexp' => 'Regular expressions and pattern matching', + 'Socket' => 'Low-level socket functions', + 'String' => 'Functions for SCALARs or strings', + 'SysV' => 'System V interprocess communication functions', + 'Time' => 'Time-related functions', + 'User' => 'Fetching user and group info', + 'Namespace' => 'Keywords altering or affecting scoping of identifiers', +); + +our @Type_Order = qw{ + String + Regexp + Math + ARRAY + LIST + HASH + I/O + Binary + File + Flow + Namespace + Misc + Process + Modules + Objects + Socket + SysV + User + Network + Time +}; + +while (<DATA>) { + chomp; + s/#.*//; + next unless $_; + my($name, $type, $text) = split " ", $_, 3; + $Type{$name} = $type; + $Flavor{$name} = $text; + for my $t ( split /[,\s]+/, $type ) { + push @{$Kinds{$t}}, $name; + } +} + +close DATA; + +my( $typedesc, $list ); +unless (caller) { + foreach my $type ( @Type_Order ) { + $list = join(", ", sort @{$Kinds{$type}}); + $typedesc = $Type_Description{$type} . ":"; + write; + } +} + +format = + +^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $typedesc +~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $typedesc + ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + $list +. + +1; + +__DATA__ +-X File a file test (-r, -x, etc) +abs Math absolute value function +accept Socket accept an incoming socket connect +alarm Process schedule a SIGALRM +atan2 Math arctangent of Y/X in the range -PI to PI +bind Socket binds an address to a socket +binmode I/O prepare binary files for I/O +bless Objects create an object +caller Flow,Namespace get context of the current subroutine call +chdir File change your current working directory +chmod File changes the permissions on a list of files +chomp String remove a trailing record separator from a string +chop String remove the last character from a string +chown File change the owership on a list of files +chr String get character this number represents +chroot File make directory new root for path lookups +close I/O close file (or pipe or socket) handle +closedir I/O close directory handle +connect Socket connect to a remote socket +continue Flow optional trailing block in a while or foreach +cos Math cosine function +crypt String one-way passwd-style encryption +dbmclose Objects,I/O breaks binding on a tied dbm file +dbmopen Objects,I/O create binding on a tied dbm file +defined Misc test whether a value, variable, or function is defined +delete HASH deletes a value from a hash +die I/O,Flow raise an exception or bail out +do Flow,Modules turn a BLOCK into a TERM +dump Misc,Flow create an immediate core dump +each HASH retrieve the next key/value pair from a hash +endgrent User be done using group file +endhostent User be done using hosts file +endnetent User be done using networks file +endprotoent Network be done using protocols file +endpwent User be done using passwd file +endservent Network be done using services file +eof I/O test a filehandle for its end +eval Flow,Misc catch exceptions or compile and run code +exec Process abandon this program to run another +exists HASH test whether a hash key is present +exit Flow terminate this program +exp Math raise I<e> to a power +fcntl File file control system call +fileno I/O return file descriptor from filehandle +flock I/O lock an entire file with an advisory lock +fork Process create a new process just like this one +format I/O declare a picture format with use by the write() function +formline Misc internal function used for formats +getc I/O get the next character from the filehandle +getgrent User get next group record +getgrgid User get group record given group user ID +getgrnam User get group record given group name +gethostbyaddr Network get host record given its address +gethostbyname Network get host record given name +gethostent Network get next hosts record +getlogin User return who logged in at this tty +getnetbyaddr Network get network record given its address +getnetbyname Network get networks record given name +getnetent Network get next networks record +getpeername Socket find the other end of a socket connection +getpgrp Process get process group +getppid Process get parent process ID +getpriority Process get current nice value +getprotobyname Network get protocol record given name +getprotobynumber Network get protocol record numeric protocol +getprotoent Network get next protocols record +getpwent User get next passwd record +getpwnam User get passwd record given user login name +getpwuid User get passwd record given user ID +getservbyname Network get services record given its name +getservbyport Network get services record given numeric port +getservent Network get next services record +getsockname Socket retrieve the sockaddr for a given socket +getsockopt Socket get socket options on a given socket +glob File expand filenames using wildcards +gmtime Time convert UNIX time into record or string using Greenwich time +goto Flow create spaghetti code +grep LIST locate elements in a list test true against a given criterion +hex Math,String convert a string to a hexadecimal number +import Modules,Namespace patch a module's namespace into your own +index String find a substring within a string +int Math get the integer portion of a number +ioctl File system-dependent device control system call +join LIST join a list into a string using a separator +keys HASH retrieve list of indices from a hash +kill Process send a signal to a process or process group +last Flow exit a block prematurely +lc String return lower-case version of a string +lcfirst String return a string with just the next letter in lower case +length String return the number of bytes in a string +link File create a hard link in the filesytem +listen Socket register your socket as a server +local Misc,Namespace create a temporary value for a global variable (dynamic scoping) +localtime Time convert UNIX time into record or string using local time +lock Threads get a thread lock on a variable, subroutine, or method +log Math retrieve the natural logarithm for a number +lstat File stat a symbolic link +m// Regexp match a string with a regular expression pattern +map LIST apply a change to a list to get back a new list with the changes +mkdir File create a directory +msgctl SysV SysV IPC message control operations +msgget SysV get SysV IPC message queue +msgrcv SysV receive a SysV IPC message from a message queue +msgsnd SysV send a SysV IPC message to a message queue +my Misc,Namespace declare and assign a local variable (lexical scoping) +next Flow iterate a block prematurely +no Modules unimport some module symbols or semantics at compile time +package Modules,Objects,Namespace declare a separate global namespace +prototype Flow,Misc get the prototype (if any) of a subroutine +oct String,Math convert a string to an octal number +open File open a file, pipe, or descriptor +opendir File open a directory +ord String find a character's numeric representation +our Misc,Namespace declare and assign a package variable (lexical scoping) +pack Binary,String convert a list into a binary representation +pipe Process open a pair of connected filehandles +pop ARRAY remove the last element from an array and return it +pos Regexp find or set the offset for the last/next m//g search +print I/O output a list to a filehandle +printf I/O output a formatted list to a filehandle +push ARRAY append one or more elements to an array +q/STRING/ String singly quote a string +qq/STRING/ String doubly quote a string +quotemeta Regexp quote regular expression magic characters +qw/STRING/ LIST quote a list of words +qx/STRING/ Process backquote quote a string +qr/STRING/ Regexp Compile pattern +rand Math retrieve the next pseudorandom number +read I/O,Binary fixed-length buffered input from a filehandle +readdir I/O get a directory from a directory handle +readline I/O fetch a record from a file +readlink File determine where a symbolic link is pointing +readpipe Process execute a system command and collect standard output +recv Socket receive a message over a Socket +redo Flow start this loop iteration over again +ref Objects find out the type of thing being referenced +rename File change a filename +require Modules load in external functions from a library at runtime +reset Misc clear all variables of a given name +return Flow get out of a function early +reverse String,LIST flip a string or a list +rewinddir I/O reset directory handle +rindex String right-to-left substring search +rmdir File remove a directory +s/// Regexp replace a pattern with a string +scalar Misc force a scalar context +seek I/O reposition file pointer for random-access I/O +seekdir I/O reposition directory pointer +select I/O reset default output or do I/O multiplexing +semctl SysV SysV semaphore control operations +semget SysV get set of SysV semaphores +semop SysV SysV semaphore operations +send Socket send a message over a socket +setgrent User prepare group file for use +sethostent Network prepare hosts file for use +setnetent Network prepare networks file for use +setpgrp Process set the process group of a process +setpriority Process set a process's nice value +setprotoent Network prepare protocols file for use +setpwent User prepare passwd file for use +setservent Network prepare services file for use +setsockopt Socket set some socket options +shift ARRAY remove the first element of an array, and return it +shmctl SysV SysV shared memory operations +shmget SysV get SysV shared memory segment identifier +shmread SysV read SysV shared memory +shmwrite SysV write SysV shared memory +shutdown Socket close down just half of a socket connection +sin Math return the sine of a number +sleep Process block for some number of seconds +socket Socket create a socket +socketpair Socket create a pair of sockets +sort LIST sort a list of values +splice ARRAY add or remove elements anywhere in an array +split Regexp split up a string using a regexp delimiter +sprintf String formatted print into a string +sqrt Math square root function +srand Math seed the random number generator +stat File get a file's status information +study Regexp optimize input data for repeated searches +sub Flow declare a subroutine, possibly anonymously +substr String get or alter a portion of a stirng +symlink File create a symbolic link to a file +syscall I/O,Binary execute an arbitrary system call +sysopen File open a file, pipe, or descriptor +sysread I/O,Binary fixed-length unbuffered input from a filehandle +sysseek I/O,Binary position I/O pointer on handle used with sysread and syswrite +system Process run a separate program +syswrite I/O,Binary fixed-length unbuffered output to a filehandle +tell I/O get current seekpointer on a filehandle +telldir I/O get current seekpointer on a directory handle +tie Objects bind a variable to an object class +tied Objects get a reference to the object underlying a tied variable +time Time return number of seconds since 1970 +times Process,Time return elapsed time for self and child processes +tr/// String transliterate a string +truncate I/O shorten a file +uc String return upper-case version of a string +ucfirst String return a string with just the next letter in upper case +umask File set file creation mode mask +undef Misc remove a variable or function definition +unlink File remove one link to a file +unpack Binary,LIST convert binary structure into normal perl variables +unshift ARRAY prepend more elements to the beginning of a list +untie Objects break a tie binding to a variable +use Modules,Namespace load a module and import its namespace +use Objects load in a module at compile time +utime File set a file's last access and modify times +values HASH return a list of the values in a hash +vec Binary test or set particular bits in a string +wait Process wait for any child process to die +waitpid Process wait for a particular child process to die +wantarray Misc,Flow get void vs scalar vs list context of current subroutine call +warn I/O print debugging info +write I/O print a picture record +y/// String transliterate a string diff --git a/Master/tlpkg/installer/perllib/Pod/Html.pm b/Master/tlpkg/installer/perllib/Pod/Html.pm new file mode 100644 index 00000000000..4b9752bc6fc --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Html.pm @@ -0,0 +1,2123 @@ +package Pod::Html; +use strict; +require Exporter; + +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); +$VERSION = 1.0504; +@ISA = qw(Exporter); +@EXPORT = qw(pod2html htmlify); +@EXPORT_OK = qw(anchorify); + +use Carp; +use Config; +use Cwd; +use File::Spec; +use File::Spec::Unix; +use Getopt::Long; + +use locale; # make \w work right in non-ASCII lands + +=head1 NAME + +Pod::Html - module to convert pod files to HTML + +=head1 SYNOPSIS + + use Pod::Html; + pod2html([options]); + +=head1 DESCRIPTION + +Converts files from pod format (see L<perlpod>) to HTML format. It +can automatically generate indexes and cross-references, and it keeps +a cache of things it knows how to cross-reference. + +=head1 ARGUMENTS + +Pod::Html takes the following arguments: + +=over 4 + +=item backlink + + --backlink="Back to Top" + +Adds "Back to Top" links in front of every C<head1> heading (except for +the first). By default, no backlinks are generated. + +=item cachedir + + --cachedir=name + +Creates the item and directory caches in the given directory. + +=item css + + --css=stylesheet + +Specify the URL of a cascading style sheet. Also disables all HTML/CSS +C<style> attributes that are output by default (to avoid conflicts). + +=item flush + + --flush + +Flushes the item and directory caches. + +=item header + + --header + --noheader + +Creates header and footer blocks containing the text of the C<NAME> +section. By default, no headers are generated. + +=item help + + --help + +Displays the usage message. + +=item hiddendirs + + --hiddendirs + --nohiddendirs + +Include hidden directories in the search for POD's in podpath if recurse +is set. +The default is not to traverse any directory whose name begins with C<.>. +See L</"podpath"> and L</"recurse">. + +[This option is for backward compatibility only. +It's hard to imagine that one would usefully create a module with a +name component beginning with C<.>.] + +=item htmldir + + --htmldir=name + +Sets the directory in which the resulting HTML file is placed. This +is used to generate relative links to other files. Not passing this +causes all links to be absolute, since this is the value that tells +Pod::Html the root of the documentation tree. + +=item htmlroot + + --htmlroot=name + +Sets the base URL for the HTML files. When cross-references are made, +the HTML root is prepended to the URL. + +=item index + + --index + --noindex + +Generate an index at the top of the HTML file. This is the default +behaviour. + +=item infile + + --infile=name + +Specify the pod file to convert. Input is taken from STDIN if no +infile is specified. + +=item libpods + + --libpods=name:...:name + +List of page names (eg, "perlfunc") which contain linkable C<=item>s. + +=item netscape + + --netscape + --nonetscape + +B<Deprecated>, has no effect. For backwards compatibility only. + +=item outfile + + --outfile=name + +Specify the HTML file to create. Output goes to STDOUT if no outfile +is specified. + +=item podpath + + --podpath=name:...:name + +Specify which subdirectories of the podroot contain pod files whose +HTML converted forms can be linked to in cross references. + +=item podroot + + --podroot=name + +Specify the base directory for finding library pods. + +=item quiet + + --quiet + --noquiet + +Don't display I<mostly harmless> warning messages. These messages +will be displayed by default. But this is not the same as C<verbose> +mode. + +=item recurse + + --recurse + --norecurse + +Recurse into subdirectories specified in podpath (default behaviour). + +=item title + + --title=title + +Specify the title of the resulting HTML file. + +=item verbose + + --verbose + --noverbose + +Display progress messages. By default, they won't be displayed. + +=back + +=head1 EXAMPLE + + pod2html("pod2html", + "--podpath=lib:ext:pod:vms", + "--podroot=/usr/src/perl", + "--htmlroot=/perl/nmanual", + "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop", + "--recurse", + "--infile=foo.pod", + "--outfile=/perl/nmanual/foo.html"); + +=head1 ENVIRONMENT + +Uses C<$Config{pod2html}> to setup default options. + +=head1 AUTHOR + +Tom Christiansen, E<lt>tchrist@perl.comE<gt>. + +=head1 SEE ALSO + +L<perlpod> + +=head1 COPYRIGHT + +This program is distributed under the Artistic License. + +=cut + + +my($Cachedir); +my($Dircache, $Itemcache); +my @Begin_Stack; +my @Libpods; +my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl); +my($Podfile, @Podpath, $Podroot); +my $Css; + +my $Recurse; +my $Quiet; +my $HiddenDirs; +my $Verbose; +my $Doindex; + +my $Backlink; +my($Listlevel, @Listtype); +my $ListNewTerm; +use vars qw($Ignore); # need to localize it later. + +my(%Items_Named, @Items_Seen); +my($Title, $Header); + +my $Top; +my $Paragraph; + +my %Sections; + +# Caches +my %Pages = (); # associative array used to find the location + # of pages referenced by L<> links. +my %Items = (); # associative array used to find the location + # of =item directives referenced by C<> links + +my %Local_Items; +my $Is83; +my $PTQuote; + +my $Curdir = File::Spec->curdir; + +init_globals(); + +sub init_globals { + $Cachedir = "."; # The directory to which item and directory + # caches will be written. + + $Dircache = "pod2htmd.tmp"; + $Itemcache = "pod2htmi.tmp"; + + @Begin_Stack = (); # begin/end stack + + @Libpods = (); # files to search for links from C<> directives + $Htmlroot = "/"; # http-server base directory from which all + # relative paths in $podpath stem. + $Htmldir = ""; # The directory to which the html pages + # will (eventually) be written. + $Htmlfile = ""; # write to stdout by default + $Htmlfileurl = ""; # The url that other files would use to + # refer to this file. This is only used + # to make relative urls that point to + # other files. + + $Podfile = ""; # read from stdin by default + @Podpath = (); # list of directories containing library pods. + $Podroot = $Curdir; # filesystem base directory from which all + # relative paths in $podpath stem. + $Css = ''; # Cascading style sheet + $Recurse = 1; # recurse on subdirectories in $podpath. + $Quiet = 0; # not quiet by default + $Verbose = 0; # not verbose by default + $Doindex = 1; # non-zero if we should generate an index + $Backlink = ''; # text for "back to top" links + $Listlevel = 0; # current list depth + @Listtype = (); # list types for open lists + $ListNewTerm = 0; # indicates new term in definition list; used + # to correctly open/close <dd> tags + $Ignore = 1; # whether or not to format text. we don't + # format text until we hit our first pod + # directive. + + @Items_Seen = (); # for multiples of the same item in perlfunc + %Items_Named = (); + $Header = 0; # produce block header/footer + $Title = ''; # title to give the pod(s) + $Top = 1; # true if we are at the top of the doc. used + # to prevent the first <hr /> directive. + $Paragraph = ''; # which paragraph we're processing (used + # for error messages) + $PTQuote = 0; # status of double-quote conversion + %Sections = (); # sections within this page + + %Local_Items = (); + $Is83 = $^O eq 'dos'; # Is it an 8.3 filesystem? +} + +# +# clean_data: global clean-up of pod data +# +sub clean_data($){ + my( $dataref ) = @_; + for my $i ( 0..$#{$dataref} ) { + ${$dataref}[$i] =~ s/\s+\Z//; + + # have a look for all-space lines + if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){ + my @chunks = split( /^\s+$/m, ${$dataref}[$i] ); + splice( @$dataref, $i, 1, @chunks ); + } + } +} + + +sub pod2html { + local(@ARGV) = @_; + local($/); + local $_; + + init_globals(); + + $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN()); + + # cache of %Pages and %Items from last time we ran pod2html + + #undef $opt_help if defined $opt_help; + + # parse the command-line parameters + parse_command_line(); + + # escape the backlink argument (same goes for title but is done later...) + $Backlink = html_escape($Backlink) if defined $Backlink; + + # set some variables to their default values if necessary + local *POD; + unless (@ARGV && $ARGV[0]) { + $Podfile = "-" unless $Podfile; # stdin + open(POD, "<$Podfile") + || die "$0: cannot open $Podfile file for input: $!\n"; + } else { + $Podfile = $ARGV[0]; # XXX: might be more filenames + *POD = *ARGV; + } + $Htmlfile = "-" unless $Htmlfile; # stdout + $Htmlroot = "" if $Htmlroot eq "/"; # so we don't get a // + $Htmldir =~ s#/\z## ; # so we don't get a // + if ( $Htmlroot eq '' + && defined( $Htmldir ) + && $Htmldir ne '' + && substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir + ) + { + # Set the 'base' url for this file, so that we can use it + # as the location from which to calculate relative links + # to other files. If this is '', then absolute links will + # be used throughout. + $Htmlfileurl= "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1); + } + + # read the pod a paragraph at a time + warn "Scanning for sections in input file(s)\n" if $Verbose; + $/ = ""; + my @poddata = <POD>; + close(POD); + + # be eol agnostic + for (@poddata) { + if (/\r/) { + if (/\r\n/) { + @poddata = map { s/\r\n/\n/g; + /\n\n/ ? + map { "$_\n\n" } split /\n\n/ : + $_ } @poddata; + } else { + @poddata = map { s/\r/\n/g; + /\n\n/ ? + map { "$_\n\n" } split /\n\n/ : + $_ } @poddata; + } + last; + } + } + + clean_data( \@poddata ); + + # scan the pod for =head[1-6] directives and build an index + my $index = scan_headings(\%Sections, @poddata); + + unless($index) { + warn "No headings in $Podfile\n" if $Verbose; + } + + # open the output file + open(HTML, ">$Htmlfile") + || die "$0: cannot open $Htmlfile file for output: $!\n"; + + # put a title in the HTML file if one wasn't specified + if ($Title eq '') { + TITLE_SEARCH: { + for (my $i = 0; $i < @poddata; $i++) { + if ($poddata[$i] =~ /^=head1\s*NAME\b/m) { + for my $para ( @poddata[$i, $i+1] ) { + last TITLE_SEARCH + if ($Title) = $para =~ /(\S+\s+-+.*\S)/s; + } + } + + } + } + } + if (!$Title and $Podfile =~ /\.pod\z/) { + # probably a split pod so take first =head[12] as title + for (my $i = 0; $i < @poddata; $i++) { + last if ($Title) = $poddata[$i] =~ /^=head[12]\s*(.*)/; + } + warn "adopted '$Title' as title for $Podfile\n" + if $Verbose and $Title; + } + if ($Title) { + $Title =~ s/\s*\(.*\)//; + } else { + warn "$0: no title for $Podfile.\n" unless $Quiet; + $Podfile =~ /^(.*)(\.[^.\/]+)?\z/s; + $Title = ($Podfile eq "-" ? 'No Title' : $1); + warn "using $Title" if $Verbose; + } + $Title = html_escape($Title); + + my $csslink = ''; + my $bodystyle = ' style="background-color: white"'; + my $tdstyle = ' style="background-color: #cccccc"'; + + if ($Css) { + $csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />); + $csslink =~ s,\\,/,g; + $csslink =~ s,(/.):,$1|,; + $bodystyle = ''; + $tdstyle = ''; + } + + my $block = $Header ? <<END_OF_BLOCK : ''; +<table border="0" width="100%" cellspacing="0" cellpadding="3"> +<tr><td class="block"$tdstyle valign="middle"> +<big><strong><span class="block"> $Title</span></strong></big> +</td></tr> +</table> +END_OF_BLOCK + + print HTML <<END_OF_HEAD; +<?xml version="1.0" ?> +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<title>$Title</title>$csslink +<meta http-equiv="content-type" content="text/html; charset=utf-8" /> +<link rev="made" href="mailto:$Config{perladmin}" /> +</head> + +<body$bodystyle> +$block +END_OF_HEAD + + # load/reload/validate/cache %Pages and %Items + get_cache($Dircache, $Itemcache, \@Podpath, $Podroot, $Recurse); + + # scan the pod for =item directives + scan_items( \%Local_Items, "", @poddata); + + # put an index at the top of the file. note, if $Doindex is 0 we + # still generate an index, but surround it with an html comment. + # that way some other program can extract it if desired. + $index =~ s/--+/-/g; + print HTML "<p><a name=\"__index__\"></a></p>\n"; + print HTML "<!-- INDEX BEGIN -->\n"; + print HTML "<!--\n" unless $Doindex; + print HTML $index; + print HTML "-->\n" unless $Doindex; + print HTML "<!-- INDEX END -->\n\n"; + print HTML "<hr />\n" if $Doindex and $index; + + # now convert this file + my $after_item; # set to true after an =item + warn "Converting input file $Podfile\n" if $Verbose; + foreach my $i (0..$#poddata){ + $PTQuote = 0; # status of quote conversion + + $_ = $poddata[$i]; + $Paragraph = $i+1; + if (/^(=.*)/s) { # is it a pod directive? + $Ignore = 0; + $after_item = 0; + $_ = $1; + if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin + process_begin($1, $2); + } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end + process_end($1, $2); + } elsif (/^=cut/) { # =cut + process_cut(); + } elsif (/^=pod/) { # =pod + process_pod(); + } else { + next if @Begin_Stack && $Begin_Stack[-1] ne 'html'; + + if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading + process_head( $1, $2, $Doindex && $index ); + } elsif (/^=item\s*(.*\S)?/sm) { # =item text + process_item( $1 ); + $after_item = 1; + } elsif (/^=over\s*(.*)/) { # =over N + process_over(); + } elsif (/^=back/) { # =back + process_back(); + } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for + process_for($1,$2); + } else { + /^=(\S*)\s*/; + warn "$0: $Podfile: unknown pod directive '$1' in " + . "paragraph $Paragraph. ignoring.\n" unless $Quiet; + } + } + $Top = 0; + } + else { + next if $Ignore; + next if @Begin_Stack && $Begin_Stack[-1] ne 'html'; + print HTML and next if @Begin_Stack && $Begin_Stack[-1] eq 'html'; + my $text = $_; + + # Open tag for definition list as we have something to put in it + if( $ListNewTerm ){ + print HTML "<dd>\n"; + $ListNewTerm = 0; + } + + if( $text =~ /\A\s+/ ){ + process_pre( \$text ); + print HTML "<pre>\n$text</pre>\n"; + + } else { + process_text( \$text ); + + # experimental: check for a paragraph where all lines + # have some ...\t...\t...\n pattern + if( $text =~ /\t/ ){ + my @lines = split( "\n", $text ); + if( @lines > 1 ){ + my $all = 2; + foreach my $line ( @lines ){ + if( $line =~ /\S/ && $line !~ /\t/ ){ + $all--; + last if $all == 0; + } + } + if( $all > 0 ){ + $text =~ s/\t+/<td>/g; + $text =~ s/^/<tr><td>/gm; + $text = '<table cellspacing="0" cellpadding="0">' . + $text . '</table>'; + } + } + } + ## end of experimental + + print HTML "<p>$text</p>\n"; + } + $after_item = 0; + } + } + + # finish off any pending directives + finish_list(); + + # link to page index + print HTML "<p><a href=\"#__index__\"><small>$Backlink</small></a></p>\n" + if $Doindex and $index and $Backlink; + + print HTML <<END_OF_TAIL; +$block +</body> + +</html> +END_OF_TAIL + + # close the html file + close(HTML); + + warn "Finished\n" if $Verbose; +} + +############################################################################## + +sub usage { + my $podfile = shift; + warn "$0: $podfile: @_\n" if @_; + die <<END_OF_USAGE; +Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name> + --podpath=<name>:...:<name> --podroot=<name> + --libpods=<name>:...:<name> --recurse --verbose --index + --netscape --norecurse --noindex --cachedir=<name> + + --backlink - set text for "back to top" links (default: none). + --cachedir - directory for the item and directory cache files. + --css - stylesheet URL + --flush - flushes the item and directory caches. + --[no]header - produce block header/footer (default is no headers). + --help - prints this message. + --hiddendirs - search hidden directories in podpath + --htmldir - directory for resulting HTML files. + --htmlroot - http-server base directory from which all relative paths + in podpath stem (default is /). + --[no]index - generate an index at the top of the resulting html + (default behaviour). + --infile - filename for the pod to convert (input taken from stdin + by default). + --libpods - colon-separated list of pages to search for =item pod + directives in as targets of C<> and implicit links (empty + by default). note, these are not filenames, but rather + page names like those that appear in L<> links. + --outfile - filename for the resulting html file (output sent to + stdout by default). + --podpath - colon-separated list of directories containing library + pods (empty by default). + --podroot - filesystem base directory from which all relative paths + in podpath stem (default is .). + --[no]quiet - suppress some benign warning messages (default is off). + --[no]recurse - recurse on those subdirectories listed in podpath + (default behaviour). + --title - title that will appear in resulting html file. + --[no]verbose - self-explanatory (off by default). + --[no]netscape - deprecated, has no effect. for backwards compatibility only. + +END_OF_USAGE + +} + +sub parse_command_line { + my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help, + $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods, + $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet, + $opt_recurse,$opt_title,$opt_verbose,$opt_hiddendirs); + + unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html}; + my $result = GetOptions( + 'backlink=s' => \$opt_backlink, + 'cachedir=s' => \$opt_cachedir, + 'css=s' => \$opt_css, + 'flush' => \$opt_flush, + 'header!' => \$opt_header, + 'help' => \$opt_help, + 'hiddendirs!'=> \$opt_hiddendirs, + 'htmldir=s' => \$opt_htmldir, + 'htmlroot=s' => \$opt_htmlroot, + 'index!' => \$opt_index, + 'infile=s' => \$opt_infile, + 'libpods=s' => \$opt_libpods, + 'netscape!' => \$opt_netscape, + 'outfile=s' => \$opt_outfile, + 'podpath=s' => \$opt_podpath, + 'podroot=s' => \$opt_podroot, + 'quiet!' => \$opt_quiet, + 'recurse!' => \$opt_recurse, + 'title=s' => \$opt_title, + 'verbose!' => \$opt_verbose, + ); + usage("-", "invalid parameters") if not $result; + + usage("-") if defined $opt_help; # see if the user asked for help + $opt_help = ""; # just to make -w shut-up. + + @Podpath = split(":", $opt_podpath) if defined $opt_podpath; + @Libpods = split(":", $opt_libpods) if defined $opt_libpods; + + $Backlink = $opt_backlink if defined $opt_backlink; + $Cachedir = $opt_cachedir if defined $opt_cachedir; + $Css = $opt_css if defined $opt_css; + $Header = $opt_header if defined $opt_header; + $Htmldir = $opt_htmldir if defined $opt_htmldir; + $Htmlroot = $opt_htmlroot if defined $opt_htmlroot; + $Doindex = $opt_index if defined $opt_index; + $Podfile = $opt_infile if defined $opt_infile; + $HiddenDirs = $opt_hiddendirs if defined $opt_hiddendirs; + $Htmlfile = $opt_outfile if defined $opt_outfile; + $Podroot = $opt_podroot if defined $opt_podroot; + $Quiet = $opt_quiet if defined $opt_quiet; + $Recurse = $opt_recurse if defined $opt_recurse; + $Title = $opt_title if defined $opt_title; + $Verbose = $opt_verbose if defined $opt_verbose; + + warn "Flushing item and directory caches\n" + if $opt_verbose && defined $opt_flush; + $Dircache = "$Cachedir/pod2htmd.tmp"; + $Itemcache = "$Cachedir/pod2htmi.tmp"; + if (defined $opt_flush) { + 1 while unlink($Dircache, $Itemcache); + } +} + + +my $Saved_Cache_Key; + +sub get_cache { + my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_; + my @cache_key_args = @_; + + # A first-level cache: + # Don't bother reading the cache files if they still apply + # and haven't changed since we last read them. + + my $this_cache_key = cache_key(@cache_key_args); + + return if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key; + + # load the cache of %Pages and %Items if possible. $tests will be + # non-zero if successful. + my $tests = 0; + if (-f $dircache && -f $itemcache) { + warn "scanning for item cache\n" if $Verbose; + $tests = load_cache($dircache, $itemcache, $podpath, $podroot); + } + + # if we didn't succeed in loading the cache then we must (re)build + # %Pages and %Items. + if (!$tests) { + warn "scanning directories in pod-path\n" if $Verbose; + scan_podpath($podroot, $recurse, 0); + } + $Saved_Cache_Key = cache_key(@cache_key_args); +} + +sub cache_key { + my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_; + return join('!', $dircache, $itemcache, $recurse, + @$podpath, $podroot, stat($dircache), stat($itemcache)); +} + +# +# load_cache - tries to find if the caches stored in $dircache and $itemcache +# are valid caches of %Pages and %Items. if they are valid then it loads +# them and returns a non-zero value. +# +sub load_cache { + my($dircache, $itemcache, $podpath, $podroot) = @_; + my($tests); + local $_; + + $tests = 0; + + open(CACHE, "<$itemcache") || + die "$0: error opening $itemcache for reading: $!\n"; + $/ = "\n"; + + # is it the same podpath? + $_ = <CACHE>; + chomp($_); + $tests++ if (join(":", @$podpath) eq $_); + + # is it the same podroot? + $_ = <CACHE>; + chomp($_); + $tests++ if ($podroot eq $_); + + # load the cache if its good + if ($tests != 2) { + close(CACHE); + return 0; + } + + warn "loading item cache\n" if $Verbose; + while (<CACHE>) { + /(.*?) (.*)$/; + $Items{$1} = $2; + } + close(CACHE); + + warn "scanning for directory cache\n" if $Verbose; + open(CACHE, "<$dircache") || + die "$0: error opening $dircache for reading: $!\n"; + $/ = "\n"; + $tests = 0; + + # is it the same podpath? + $_ = <CACHE>; + chomp($_); + $tests++ if (join(":", @$podpath) eq $_); + + # is it the same podroot? + $_ = <CACHE>; + chomp($_); + $tests++ if ($podroot eq $_); + + # load the cache if its good + if ($tests != 2) { + close(CACHE); + return 0; + } + + warn "loading directory cache\n" if $Verbose; + while (<CACHE>) { + /(.*?) (.*)$/; + $Pages{$1} = $2; + } + + close(CACHE); + + return 1; +} + +# +# scan_podpath - scans the directories specified in @podpath for directories, +# .pod files, and .pm files. it also scans the pod files specified in +# @Libpods for =item directives. +# +sub scan_podpath { + my($podroot, $recurse, $append) = @_; + my($pwd, $dir); + my($libpod, $dirname, $pod, @files, @poddata); + + unless($append) { + %Items = (); + %Pages = (); + } + + # scan each directory listed in @Podpath + $pwd = getcwd(); + chdir($podroot) + || die "$0: error changing to directory $podroot: $!\n"; + foreach $dir (@Podpath) { + scan_dir($dir, $recurse); + } + + # scan the pods listed in @Libpods for =item directives + foreach $libpod (@Libpods) { + # if the page isn't defined then we won't know where to find it + # on the system. + next unless defined $Pages{$libpod} && $Pages{$libpod}; + + # if there is a directory then use the .pod and .pm files within it. + # NOTE: Only finds the first so-named directory in the tree. +# if ($Pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) { + if ($Pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) { + # find all the .pod and .pm files within the directory + $dirname = $1; + opendir(DIR, $dirname) || + die "$0: error opening directory $dirname: $!\n"; + @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR)); + closedir(DIR); + + # scan each .pod and .pm file for =item directives + foreach $pod (@files) { + open(POD, "<$dirname/$pod") || + die "$0: error opening $dirname/$pod for input: $!\n"; + @poddata = <POD>; + close(POD); + clean_data( \@poddata ); + + scan_items( \%Items, "$dirname/$pod", @poddata); + } + + # use the names of files as =item directives too. +### Don't think this should be done this way - confuses issues.(WL) +### foreach $pod (@files) { +### $pod =~ /^(.*)(\.pod|\.pm)$/; +### $Items{$1} = "$dirname/$1.html" if $1; +### } + } elsif ($Pages{$libpod} =~ /([^:]*\.pod):/ || + $Pages{$libpod} =~ /([^:]*\.pm):/) { + # scan the .pod or .pm file for =item directives + $pod = $1; + open(POD, "<$pod") || + die "$0: error opening $pod for input: $!\n"; + @poddata = <POD>; + close(POD); + clean_data( \@poddata ); + + scan_items( \%Items, "$pod", @poddata); + } else { + warn "$0: shouldn't be here (line ".__LINE__."\n" unless $Quiet; + } + } + @poddata = (); # clean-up a bit + + chdir($pwd) + || die "$0: error changing to directory $pwd: $!\n"; + + # cache the item list for later use + warn "caching items for later use\n" if $Verbose; + open(CACHE, ">$Itemcache") || + die "$0: error open $Itemcache for writing: $!\n"; + + print CACHE join(":", @Podpath) . "\n$podroot\n"; + foreach my $key (keys %Items) { + print CACHE "$key $Items{$key}\n"; + } + + close(CACHE); + + # cache the directory list for later use + warn "caching directories for later use\n" if $Verbose; + open(CACHE, ">$Dircache") || + die "$0: error open $Dircache for writing: $!\n"; + + print CACHE join(":", @Podpath) . "\n$podroot\n"; + foreach my $key (keys %Pages) { + print CACHE "$key $Pages{$key}\n"; + } + + close(CACHE); +} + +# +# scan_dir - scans the directory specified in $dir for subdirectories, .pod +# files, and .pm files. notes those that it finds. this information will +# be used later in order to figure out where the pages specified in L<> +# links are on the filesystem. +# +sub scan_dir { + my($dir, $recurse) = @_; + my($t, @subdirs, @pods, $pod, $dirname, @dirs); + local $_; + + @subdirs = (); + @pods = (); + + opendir(DIR, $dir) || + die "$0: error opening directory $dir: $!\n"; + while (defined($_ = readdir(DIR))) { + if (-d "$dir/$_" && $_ ne "." && $_ ne ".." + && ($HiddenDirs || !/^\./) + ) { # directory + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_:"; + push(@subdirs, $_); + } elsif (/\.pod\z/) { # .pod + s/\.pod\z//; + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_.pod:"; + push(@pods, "$dir/$_.pod"); + } elsif (/\.html\z/) { # .html + s/\.html\z//; + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_.pod:"; + } elsif (/\.pm\z/) { # .pm + s/\.pm\z//; + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_.pm:"; + push(@pods, "$dir/$_.pm"); + } elsif (-T "$dir/$_") { # script(?) + local *F; + if (open(F, "$dir/$_")) { + my $line; + while (defined($line = <F>)) { + if ($line =~ /^=(?:pod|head1)/) { + $Pages{$_} = "" unless defined $Pages{$_}; + $Pages{$_} .= "$dir/$_.pod:"; + last; + } + } + close(F); + } + } + } + closedir(DIR); + + # recurse on the subdirectories if necessary + if ($recurse) { + foreach my $subdir (@subdirs) { + scan_dir("$dir/$subdir", $recurse); + } + } +} + +# +# scan_headings - scan a pod file for head[1-6] tags, note the tags, and +# build an index. +# +sub scan_headings { + my($sections, @data) = @_; + my($tag, $which_head, $otitle, $listdepth, $index); + + local $Ignore = 0; + + $listdepth = 0; + $index = ""; + + # scan for =head directives, note their name, and build an index + # pointing to each of them. + foreach my $line (@data) { + if ($line =~ /^=(head)([1-6])\s+(.*)/) { + ($tag, $which_head, $otitle) = ($1,$2,$3); + + my $title = depod( $otitle ); + my $name = anchorify( $title ); + $$sections{$name} = 1; + $title = process_text( \$otitle ); + + while ($which_head != $listdepth) { + if ($which_head > $listdepth) { + $index .= "\n" . ("\t" x $listdepth) . "<ul>\n"; + $listdepth++; + } elsif ($which_head < $listdepth) { + $listdepth--; + $index .= "\n" . ("\t" x $listdepth) . "</ul>\n"; + } + } + + $index .= "\n" . ("\t" x $listdepth) . "<li>" . + "<a href=\"#" . $name . "\">" . + $title . "</a></li>"; + } + } + + # finish off the lists + while ($listdepth--) { + $index .= "\n" . ("\t" x $listdepth) . "</ul>\n"; + } + + # get rid of bogus lists + $index =~ s,\t*<ul>\s*</ul>\n,,g; + + return $index; +} + +# +# scan_items - scans the pod specified by $pod for =item directives. we +# will use this information later on in resolving C<> links. +# +sub scan_items { + my( $itemref, $pod, @poddata ) = @_; + my($i, $item); + local $_; + + $pod =~ s/\.pod\z//; + $pod .= ".html" if $pod; + + foreach $i (0..$#poddata) { + my $txt = depod( $poddata[$i] ); + + # figure out what kind of item it is. + # Build string for referencing this item. + if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bulleted list + next unless $1; + $item = $1; + } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list + $item = $1; + } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # definition list + $item = $1; + } else { + next; + } + my $fid = fragment_id( $item ); + $$itemref{$fid} = "$pod" if $fid; + } +} + +# +# process_head - convert a pod head[1-6] tag and convert it to HTML format. +# +sub process_head { + my($tag, $heading, $hasindex) = @_; + + # figure out the level of the =head + $tag =~ /head([1-6])/; + my $level = $1; + + finish_list(); + + print HTML "<p>\n"; + if( $level == 1 && ! $Top ){ + print HTML "<a href=\"#__index__\"><small>$Backlink</small></a>\n" + if $hasindex and $Backlink; + print HTML "</p>\n<hr />\n" + } else { + print HTML "</p>\n"; + } + + my $name = anchorify( depod( $heading ) ); + my $convert = process_text( \$heading ); + print HTML "<h$level><a name=\"$name\">$convert</a></h$level>\n"; +} + + +# +# emit_item_tag - print an =item's text +# Note: The global $EmittedItem is used for inhibiting self-references. +# +my $EmittedItem; + +sub emit_item_tag($$$){ + my( $otext, $text, $compact ) = @_; + my $item = fragment_id( $text ); + + $EmittedItem = $item; + ### print STDERR "emit_item_tag=$item ($text)\n"; + + print HTML '<strong>'; + if ($Items_Named{$item}++) { + print HTML process_text( \$otext ); + } else { + my $name = 'item_' . $item; + $name = anchorify($name); + print HTML qq{<a name="$name">}, process_text( \$otext ), '</a>'; + } + print HTML "</strong>"; + undef( $EmittedItem ); +} + +sub new_listitem { + my( $tag ) = @_; + # Open tag for definition list as we have something to put in it + if( ($tag ne 'dl') && ($ListNewTerm) ){ + print HTML "<dd>\n"; + $ListNewTerm = 0; + } + + if( $Items_Seen[$Listlevel]++ == 0 ){ + # start of new list + push( @Listtype, "$tag" ); + print HTML "<$tag>\n"; + } else { + # if this is not the first item, close the previous one + if ( $tag eq 'dl' ){ + print HTML "</dd>\n" unless $ListNewTerm; + } else { + print HTML "</li>\n"; + } + } + my $opentag = $tag eq 'dl' ? 'dt' : 'li'; + print HTML "<$opentag>"; +} + +# +# process_item - convert a pod item tag and convert it to HTML format. +# +sub process_item { + my( $otext ) = @_; + + # lots of documents start a list without doing an =over. this is + # bad! but, the proper thing to do seems to be to just assume + # they did do an =over. so warn them once and then continue. + if( $Listlevel == 0 ){ + warn "$0: $Podfile: unexpected =item directive in paragraph $Paragraph. ignoring.\n" unless $Quiet; + process_over(); + } + + # remove formatting instructions from the text + my $text = depod( $otext ); + + # all the list variants: + if( $text =~ /\A\*/ ){ # bullet + new_listitem( 'ul' ); + if ($text =~ /\A\*\s+(.+)\Z/s ) { # with additional text + my $tag = $1; + $otext =~ s/\A\*\s+//; + emit_item_tag( $otext, $tag, 1 ); + print HTML "\n"; + } + + } elsif( $text =~ /\A\d+/ ){ # numbered list + new_listitem( 'ol' ); + if ($text =~ /\A(?>\d+\.?)\s*(.+)\Z/s ) { # with additional text + my $tag = $1; + $otext =~ s/\A\d+\.?\s*//; + emit_item_tag( $otext, $tag, 1 ); + print HTML "\n"; + } + + } else { # definition list + # new_listitem takes care of opening the <dt> tag + new_listitem( 'dl' ); + if( $text =~ /\A(.+)\Z/s ){ # should have text + emit_item_tag( $otext, $text, 1 ); + } else { + warn "$0: $Podfile: no term text provided for definition list in paragraph $Paragraph. ignoring.\n" unless $Quiet; + } + # write the definition term and close <dt> tag + print HTML "</dt>\n"; + # trigger opening a <dd> tag for the actual definition; will not + # happen if next paragraph is also a definition term (=item) + $ListNewTerm = 1; + } + print HTML "\n"; +} + +# +# process_over - process a pod over tag and start a corresponding HTML list. +# +sub process_over { + # start a new list + $Listlevel++; + push( @Items_Seen, 0 ); +} + +# +# process_back - process a pod back tag and convert it to HTML format. +# +sub process_back { + if( $Listlevel == 0 ){ + warn "$0: $Podfile: unexpected =back directive in paragraph $Paragraph. ignoring.\n" unless $Quiet; + return; + } + + # close off the list. note, I check to see if $Listtype[$Listlevel] is + # defined because an =item directive may have never appeared and thus + # $Listtype[$Listlevel] may have never been initialized. + $Listlevel--; + if( defined $Listtype[$Listlevel] ){ + if ( $Listtype[$Listlevel] eq 'dl' ){ + print HTML "</dd>\n" unless $ListNewTerm; + } else { + print HTML "</li>\n"; + } + print HTML "</$Listtype[$Listlevel]>\n"; + pop( @Listtype ); + $ListNewTerm = 0; + } + + # clean up item count + pop( @Items_Seen ); +} + +# +# process_cut - process a pod cut tag, thus start ignoring pod directives. +# +sub process_cut { + $Ignore = 1; +} + +# +# process_pod - process a pod tag, thus stop ignoring pod directives +# until we see a corresponding cut. +# +sub process_pod { + # no need to set $Ignore to 0 cause the main loop did it +} + +# +# process_for - process a =for pod tag. if it's for html, spit +# it out verbatim, if illustration, center it, otherwise ignore it. +# +sub process_for { + my($whom, $text) = @_; + if ( $whom =~ /^(pod2)?html$/i) { + print HTML $text; + } elsif ($whom =~ /^illustration$/i) { + 1 while chomp $text; + for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) { + $text .= $ext, last if -r "$text$ext"; + } + print HTML qq{<p align="center"><img src="$text" alt="$text illustration" /></p>}; + } +} + +# +# process_begin - process a =begin pod tag. this pushes +# whom we're beginning on the begin stack. if there's a +# begin stack, we only print if it us. +# +sub process_begin { + my($whom, $text) = @_; + $whom = lc($whom); + push (@Begin_Stack, $whom); + if ( $whom =~ /^(pod2)?html$/) { + print HTML $text if $text; + } +} + +# +# process_end - process a =end pod tag. pop the +# begin stack. die if we're mismatched. +# +sub process_end { + my($whom, $text) = @_; + $whom = lc($whom); + if ($Begin_Stack[-1] ne $whom ) { + die "Unmatched begin/end at chunk $Paragraph\n" + } + pop( @Begin_Stack ); +} + +# +# process_pre - indented paragraph, made into <pre></pre> +# +sub process_pre { + my( $text ) = @_; + my( $rest ); + return if $Ignore; + + $rest = $$text; + + # insert spaces in place of tabs + $rest =~ s#(.+)# + my $line = $1; + 1 while $line =~ s/(\t+)/' ' x ((length($1) * 8) - $-[0] % 8)/e; + $line; + #eg; + + # convert some special chars to HTML escapes + $rest = html_escape($rest); + + # try and create links for all occurrences of perl.* within + # the preformatted text. + $rest =~ s{ + (\s*)(perl\w+) + }{ + if ( defined $Pages{$2} ){ # is a link + qq($1<a href="$Htmlroot/$Pages{$2}">$2</a>); + } elsif (defined $Pages{dosify($2)}) { # is a link + qq($1<a href="$Htmlroot/$Pages{dosify($2)}">$2</a>); + } else { + "$1$2"; + } + }xeg; + $rest =~ s{ + (<a\ href="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)? + }{ + my $url ; + if ( $Htmlfileurl ne '' ){ + # Here, we take advantage of the knowledge + # that $Htmlfileurl ne '' implies $Htmlroot eq ''. + # Since $Htmlroot eq '', we need to prepend $Htmldir + # on the fron of the link to get the absolute path + # of the link's target. We check for a leading '/' + # to avoid corrupting links that are #, file:, etc. + my $old_url = $3 ; + $old_url = "$Htmldir$old_url" if $old_url =~ m{^\/}; + $url = relativize_url( "$old_url.html", $Htmlfileurl ); + } else { + $url = "$3.html" ; + } + "$1$url" ; + }xeg; + + # Look for embedded URLs and make them into links. We don't + # relativize them since they are best left as the author intended. + + my $urls = '(' . join ('|', qw{ + http + telnet + mailto + news + gopher + file + wais + ftp + } ) + . ')'; + + my $ltrs = '\w'; + my $gunk = '/#~:.?+=&%@!\-'; + my $punc = '.:!?\-;'; + my $any = "${ltrs}${gunk}${punc}"; + + $rest =~ s{ + \b # start at word boundary + ( # begin $1 { + $urls : # need resource and a colon + (?!:) # Ignore File::, among others. + [$any] +? # followed by one or more of any valid + # character, but be conservative and + # take only what you need to.... + ) # end $1 } + (?= + " > # maybe pre-quoted '<a href="...">' + | # or: + [$punc]* # 0 or more punctuation + (?: # followed + [^$any] # by a non-url char + | # or + $ # end of the string + ) # + | # or else + $ # then end of the string + ) + }{<a href="$1">$1</a>}igox; + + # text should be as it is (verbatim) + $$text = $rest; +} + + +# +# pure text processing +# +# pure_text/inIS_text: differ with respect to automatic C<> recognition. +# we don't want this to happen within IS +# +sub pure_text($){ + my $text = shift(); + process_puretext( $text, \$PTQuote, 1 ); +} + +sub inIS_text($){ + my $text = shift(); + process_puretext( $text, \$PTQuote, 0 ); +} + +# +# process_puretext - process pure text (without pod-escapes) converting +# double-quotes and handling implicit C<> links. +# +sub process_puretext { + my($text, $quote, $notinIS) = @_; + + ## Guessing at func() or [\$\@%&]*var references in plain text is destined + ## to produce some strange looking ref's. uncomment to disable: + ## $notinIS = 0; + + my(@words, $lead, $trail); + + # convert double-quotes to single-quotes + if( $$quote && $text =~ s/"/''/s ){ + $$quote = 0; + } + while ($text =~ s/"([^"]*)"/``$1''/sg) {}; + $$quote = 1 if $text =~ s/"/``/s; + + # keep track of leading and trailing white-space + $lead = ($text =~ s/\A(\s+)//s ? $1 : ""); + $trail = ($text =~ s/(\s+)\Z//s ? $1 : ""); + + # split at space/non-space boundaries + @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text ); + + # process each word individually + foreach my $word (@words) { + # skip space runs + next if $word =~ /^\s*$/; + # see if we can infer a link + if( $notinIS && $word =~ /^(\w+)\((.*)\)$/ ) { + # has parenthesis so should have been a C<> ref + ## try for a pagename (perlXXX(1))? + my( $func, $args ) = ( $1, $2 ); + if( $args =~ /^\d+$/ ){ + my $url = page_sect( $word, '' ); + if( defined $url ){ + $word = "<a href=\"$url\">the $word manpage</a>"; + next; + } + } + ## try function name for a link, append tt'ed argument list + $word = emit_C( $func, '', "($args)"); + +#### disabled. either all (including $\W, $\w+{.*} etc.) or nothing. +## } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) { +## # perl variables, should be a C<> ref +## $word = emit_C( $word ); + + } elsif ($word =~ m,^\w+://\w,) { + # looks like a URL + # Don't relativize it: leave it as the author intended + $word = qq(<a href="$word">$word</a>); + } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) { + # looks like an e-mail address + my ($w1, $w2, $w3) = ("", $word, ""); + ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/; + ($w1, $w2, $w3) = ("<", $1, ">$2") if $word =~ /^<(.*?)>(,?)/; + $word = qq($w1<a href="mailto:$w2">$w2</a>$w3); + } else { + $word = html_escape($word) if $word =~ /["&<>]/; + } + } + + # put everything back together + return $lead . join( '', @words ) . $trail; +} + + +# +# process_text - handles plaintext that appears in the input pod file. +# there may be pod commands embedded within the text so those must be +# converted to html commands. +# + +sub process_text1($$;$$); +sub pattern ($) { $_[0] ? '[^\S\n]+'.('>' x ($_[0] + 1)) : '>' } +sub closing ($) { local($_) = shift; (defined && s/\s+$//) ? length : 0 } + +sub process_text { + return if $Ignore; + my( $tref ) = @_; + my $res = process_text1( 0, $tref ); + $$tref = $res; +} + +sub process_text1($$;$$){ + my( $lev, $rstr, $func, $closing ) = @_; + my $res = ''; + + unless (defined $func) { + $func = ''; + $lev++; + } + + if( $func eq 'B' ){ + # B<text> - boldface + $res = '<strong>' . process_text1( $lev, $rstr ) . '</strong>'; + + } elsif( $func eq 'C' ){ + # C<code> - can be a ref or <code></code> + # need to extract text + my $par = go_ahead( $rstr, 'C', $closing ); + + ## clean-up of the link target + my $text = depod( $par ); + + ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ; + ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n"; + + $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) ); + + } elsif( $func eq 'E' ){ + # E<x> - convert to character + $$rstr =~ s/^([^>]*)>//; + my $escape = $1; + $escape =~ s/^(\d+|X[\dA-F]+)$/#$1/i; + $res = "&$escape;"; + + } elsif( $func eq 'F' ){ + # F<filename> - italizice + $res = '<em>' . process_text1( $lev, $rstr ) . '</em>'; + + } elsif( $func eq 'I' ){ + # I<text> - italizice + $res = '<em>' . process_text1( $lev, $rstr ) . '</em>'; + + } elsif( $func eq 'L' ){ + # L<link> - link + ## L<text|cross-ref> => produce text, use cross-ref for linking + ## L<cross-ref> => make text from cross-ref + ## need to extract text + my $par = go_ahead( $rstr, 'L', $closing ); + + # some L<>'s that shouldn't be: + # a) full-blown URL's are emitted as-is + if( $par =~ m{^\w+://}s ){ + return make_URL_href( $par ); + } + # b) C<...> is stripped and treated as C<> + if( $par =~ /^C<(.*)>$/ ){ + my $text = depod( $1 ); + return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) ); + } + + # analyze the contents + $par =~ s/\n/ /g; # undo word-wrapped tags + my $opar = $par; + my $linktext; + if( $par =~ s{^([^|]+)\|}{} ){ + $linktext = $1; + } + + # make sure sections start with a / + $par =~ s{^"}{/"}; + + my( $page, $section, $ident ); + + # check for link patterns + if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){ # name/ident + # we've got a name/ident (no quotes) + ( $page, $ident ) = ( $1, $2 ); + ### print STDERR "--> L<$par> to page $page, ident $ident\n"; + + } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section" + # even though this should be a "section", we go for ident first + ( $page, $ident ) = ( $1, $2 ); + ### print STDERR "--> L<$par> to page $page, section $section\n"; + + } elsif( $par =~ /\s/ ){ # this must be a section with missing quotes + ( $page, $section ) = ( '', $par ); + ### print STDERR "--> L<$par> to void page, section $section\n"; + + } else { + ( $page, $section ) = ( $par, '' ); + ### print STDERR "--> L<$par> to page $par, void section\n"; + } + + # now, either $section or $ident is defined. the convoluted logic + # below tries to resolve L<> according to what the user specified. + # failing this, we try to find the next best thing... + my( $url, $ltext, $fid ); + + RESOLVE: { + if( defined $ident ){ + ## try to resolve $ident as an item + ( $url, $fid ) = coderef( $page, $ident ); + if( $url ){ + if( ! defined( $linktext ) ){ + $linktext = $ident; + $linktext .= " in " if $ident && $page; + $linktext .= "the $page manpage" if $page; + } + ### print STDERR "got coderef url=$url\n"; + last RESOLVE; + } + ## no luck: go for a section (auto-quoting!) + $section = $ident; + } + ## now go for a section + my $htmlsection = htmlify( $section ); + $url = page_sect( $page, $htmlsection ); + if( $url ){ + if( ! defined( $linktext ) ){ + $linktext = $section; + $linktext .= " in " if $section && $page; + $linktext .= "the $page manpage" if $page; + } + ### print STDERR "got page/section url=$url\n"; + last RESOLVE; + } + ## no luck: go for an ident + if( $section ){ + $ident = $section; + } else { + $ident = $page; + $page = undef(); + } + ( $url, $fid ) = coderef( $page, $ident ); + if( $url ){ + if( ! defined( $linktext ) ){ + $linktext = $ident; + $linktext .= " in " if $ident && $page; + $linktext .= "the $page manpage" if $page; + } + ### print STDERR "got section=>coderef url=$url\n"; + last RESOLVE; + } + + # warning; show some text. + $linktext = $opar unless defined $linktext; + warn "$0: $Podfile: cannot resolve L<$opar> in paragraph $Paragraph.\n" unless $Quiet; + } + + # now we have a URL or just plain code + $$rstr = $linktext . '>' . $$rstr; + if( defined( $url ) ){ + $res = "<a href=\"$url\">" . process_text1( $lev, $rstr ) . '</a>'; + } else { + $res = '<em>' . process_text1( $lev, $rstr ) . '</em>'; + } + + } elsif( $func eq 'S' ){ + # S<text> - non-breaking spaces + $res = process_text1( $lev, $rstr ); + $res =~ s/ / /g; + + } elsif( $func eq 'X' ){ + # X<> - ignore + $$rstr =~ s/^[^>]*>//; + + } elsif( $func eq 'Z' ){ + # Z<> - empty + warn "$0: $Podfile: invalid X<> in paragraph $Paragraph.\n" + unless $$rstr =~ s/^>// or $Quiet; + + } else { + my $term = pattern $closing; + while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){ + # all others: either recurse into new function or + # terminate at closing angle bracket(s) + my $pt = $1; + $pt .= $2 if !$3 && $lev == 1; + $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt ); + return $res if !$3 && $lev > 1; + if( $3 ){ + $res .= process_text1( $lev, $rstr, $3, closing $4 ); + } + } + if( $lev == 1 ){ + $res .= pure_text( $$rstr ); + } else { + warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph.\n" unless $Quiet; + } + } + return $res; +} + +# +# go_ahead: extract text of an IS (can be nested) +# +sub go_ahead($$$){ + my( $rstr, $func, $closing ) = @_; + my $res = ''; + my @closing = ($closing); + while( $$rstr =~ + s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|@{[pattern $closing[0]]})//s ){ + $res .= $1; + unless( $3 ){ + shift @closing; + return $res unless @closing; + } else { + unshift @closing, closing $4; + } + $res .= $2; + } + warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph.\n" unless $Quiet; + return $res; +} + +# +# emit_C - output result of C<text> +# $text is the depod-ed text +# +sub emit_C($;$$){ + my( $text, $nocode, $args ) = @_; + $args = '' unless defined $args; + my $res; + my( $url, $fid ) = coderef( undef(), $text ); + + # need HTML-safe text + my $linktext = html_escape( "$text$args" ); + + if( defined( $url ) && + (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){ + $res = "<a href=\"$url\"><code>$linktext</code></a>"; + } elsif( 0 && $nocode ){ + $res = $linktext; + } else { + $res = "<code>$linktext</code>"; + } + return $res; +} + +# +# html_escape: make text safe for HTML +# +sub html_escape { + my $rest = $_[0]; + $rest =~ s/&/&/g; + $rest =~ s/</</g; + $rest =~ s/>/>/g; + $rest =~ s/"/"/g; + # ' is only in XHTML, not HTML4. Be conservative + #$rest =~ s/'/'/g; + return $rest; +} + + +# +# dosify - convert filenames to 8.3 +# +sub dosify { + my($str) = @_; + return lc($str) if $^O eq 'VMS'; # VMS just needs casing + if ($Is83) { + $str = lc $str; + $str =~ s/(\.\w+)/substr ($1,0,4)/ge; + $str =~ s/(\w+)/substr ($1,0,8)/ge; + } + return $str; +} + +# +# page_sect - make a URL from the text of a L<> +# +sub page_sect($$) { + my( $page, $section ) = @_; + my( $linktext, $page83, $link); # work strings + + # check if we know that this is a section in this page + if (!defined $Pages{$page} && defined $Sections{$page}) { + $section = $page; + $page = ""; + ### print STDERR "reset page='', section=$section\n"; + } + + $page83=dosify($page); + $page=$page83 if (defined $Pages{$page83}); + if ($page eq "") { + $link = "#" . anchorify( $section ); + } elsif ( $page =~ /::/ ) { + $page =~ s,::,/,g; + # Search page cache for an entry keyed under the html page name, + # then look to see what directory that page might be in. NOTE: + # this will only find one page. A better solution might be to produce + # an intermediate page that is an index to all such pages. + my $page_name = $page ; + $page_name =~ s,^.*/,,s ; + if ( defined( $Pages{ $page_name } ) && + $Pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/ + ) { + $page = $1 ; + } + else { + # NOTE: This branch assumes that all A::B pages are located in + # $Htmlroot/A/B.html . This is often incorrect, since they are + # often in $Htmlroot/lib/A/B.html or such like. Perhaps we could + # analyze the contents of %Pages and figure out where any + # cousins of A::B are, then assume that. So, if A::B isn't found, + # but A::C is found in lib/A/C.pm, then A::B is assumed to be in + # lib/A/B.pm. This is also limited, but it's an improvement. + # Maybe a hints file so that the links point to the correct places + # nonetheless? + + } + $link = "$Htmlroot/$page.html"; + $link .= "#" . anchorify( $section ) if ($section); + } elsif (!defined $Pages{$page}) { + $link = ""; + } else { + $section = anchorify( $section ) if $section ne ""; + ### print STDERR "...section=$section\n"; + + # if there is a directory by the name of the page, then assume that an + # appropriate section will exist in the subdirectory +# if ($section ne "" && $Pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) { + if ($section ne "" && $Pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) { + $link = "$Htmlroot/$1/$section.html"; + ### print STDERR "...link=$link\n"; + + # since there is no directory by the name of the page, the section will + # have to exist within a .html of the same name. thus, make sure there + # is a .pod or .pm that might become that .html + } else { + $section = "#$section" if $section; + ### print STDERR "...section=$section\n"; + + # check if there is a .pod with the page name + if ($Pages{$page} =~ /([^:]*)\.pod:/) { + $link = "$Htmlroot/$1.html$section"; + } elsif ($Pages{$page} =~ /([^:]*)\.pm:/) { + $link = "$Htmlroot/$1.html$section"; + } else { + $link = ""; + } + } + } + + if ($link) { + # Here, we take advantage of the knowledge that $Htmlfileurl ne '' + # implies $Htmlroot eq ''. This means that the link in question + # needs a prefix of $Htmldir if it begins with '/'. The test for + # the initial '/' is done to avoid '#'-only links, and to allow + # for other kinds of links, like file:, ftp:, etc. + my $url ; + if ( $Htmlfileurl ne '' ) { + $link = "$Htmldir$link" if $link =~ m{^/}s; + $url = relativize_url( $link, $Htmlfileurl ); +# print( " b: [$link,$Htmlfileurl,$url]\n" ); + } + else { + $url = $link ; + } + return $url; + + } else { + return undef(); + } +} + +# +# relativize_url - convert an absolute URL to one relative to a base URL. +# Assumes both end in a filename. +# +sub relativize_url { + my ($dest,$source) = @_ ; + + my ($dest_volume,$dest_directory,$dest_file) = + File::Spec::Unix->splitpath( $dest ) ; + $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ; + + my ($source_volume,$source_directory,$source_file) = + File::Spec::Unix->splitpath( $source ) ; + $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ; + + my $rel_path = '' ; + if ( $dest ne '' ) { + $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ; + } + + if ( $rel_path ne '' && + substr( $rel_path, -1 ) ne '/' && + substr( $dest_file, 0, 1 ) ne '#' + ) { + $rel_path .= "/$dest_file" ; + } + else { + $rel_path .= "$dest_file" ; + } + + return $rel_path ; +} + + +# +# coderef - make URL from the text of a C<> +# +sub coderef($$){ + my( $page, $item ) = @_; + my( $url ); + + my $fid = fragment_id( $item ); + if( defined( $page ) && $page ne "" ){ + # we have been given a $page... + $page =~ s{::}{/}g; + + # Do we take it? Item could be a section! + my $base = $Items{$fid} || ""; + $base =~ s{[^/]*/}{}; + if( $base ne "$page.html" ){ + ### print STDERR "coderef( $page, $item ): items{$fid} = $Items{$fid} = $base => discard page!\n"; + $page = undef(); + } + + } else { + # no page - local items precede cached items + if( defined( $fid ) ){ + if( exists $Local_Items{$fid} ){ + $page = $Local_Items{$fid}; + } else { + $page = $Items{$fid}; + } + } + } + + # if there was a pod file that we found earlier with an appropriate + # =item directive, then create a link to that page. + if( defined $page ){ + if( $page ){ + if( exists $Pages{$page} and $Pages{$page} =~ /([^:.]*)\.[^:]*:/){ + $page = $1 . '.html'; + } + my $link = "$Htmlroot/$page#item_" . anchorify($fid); + + # Here, we take advantage of the knowledge that $Htmlfileurl + # ne '' implies $Htmlroot eq ''. + if ( $Htmlfileurl ne '' ) { + $link = "$Htmldir$link" ; + $url = relativize_url( $link, $Htmlfileurl ) ; + } else { + $url = $link ; + } + } else { + $url = "#item_" . anchorify($fid); + } + + confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/; + } + return( $url, $fid ); +} + + + +# +# Adapted from Nick Ing-Simmons' PodToHtml package. +sub relative_url { + my $source_file = shift ; + my $destination_file = shift; + + my $source = URI::file->new_abs($source_file); + my $uo = URI::file->new($destination_file,$source)->abs; + return $uo->rel->as_string; +} + + +# +# finish_list - finish off any pending HTML lists. this should be called +# after the entire pod file has been read and converted. +# +sub finish_list { + if( $Listlevel ){ + warn "$0: $Podfile: unterminated list(s) at =head in paragraph $Paragraph. ignoring.\n" unless $Quiet; + while( $Listlevel ){ + process_back(); + } + } +} + +# +# htmlify - converts a pod section specification to a suitable section +# specification for HTML. Note that we keep spaces and special characters +# except ", ? (Netscape problem) and the hyphen (writer's problem...). +# +sub htmlify { + my( $heading) = @_; + $heading =~ s/(\s+)/ /g; + $heading =~ s/\s+\Z//; + $heading =~ s/\A\s+//; + # The hyphen is a disgrace to the English language. + $heading =~ s/[-"?]//g; + $heading = lc( $heading ); + return $heading; +} + +# +# similar to htmlify, but turns non-alphanumerics into underscores +# +sub anchorify { + my ($anchor) = @_; + $anchor = htmlify($anchor); + $anchor =~ s/\W/_/g; + return $anchor; +} + +# +# depod - convert text by eliminating all interior sequences +# Note: can be called with copy or modify semantics +# +my %E2c; +$E2c{lt} = '<'; +$E2c{gt} = '>'; +$E2c{sol} = '/'; +$E2c{verbar} = '|'; +$E2c{amp} = '&'; # in Tk's pods + +sub depod1($;$$); + +sub depod($){ + my $string; + if( ref( $_[0] ) ){ + $string = ${$_[0]}; + ${$_[0]} = depod1( \$string ); + } else { + $string = $_[0]; + depod1( \$string ); + } +} + +sub depod1($;$$){ + my( $rstr, $func, $closing ) = @_; + my $res = ''; + return $res unless defined $$rstr; + if( ! defined( $func ) ){ + # skip to next begin of an interior sequence + while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?// ){ + # recurse into its text + $res .= $1 . depod1( $rstr, $2, closing $3); + } + $res .= $$rstr; + } elsif( $func eq 'E' ){ + # E<x> - convert to character + $$rstr =~ s/^([^>]*)>//; + $res .= $E2c{$1} || ""; + } elsif( $func eq 'X' ){ + # X<> - ignore + $$rstr =~ s/^[^>]*>//; + } elsif( $func eq 'Z' ){ + # Z<> - empty + $$rstr =~ s/^>//; + } else { + # all others: either recurse into new function or + # terminate at closing angle bracket + my $term = pattern $closing; + while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)// ){ + $res .= $1; + last unless $3; + $res .= depod1( $rstr, $3, closing $4 ); + } + ## If we're here and $2 ne '>': undelimited interior sequence. + ## Ignored, as this is called without proper indication of where we are. + ## Rely on process_text to produce diagnostics. + } + return $res; +} + +# +# fragment_id - construct a fragment identifier from: +# a) =item text +# b) contents of C<...> +# +my @HC; +sub fragment_id { + my $text = shift(); + $text =~ s/\s+\Z//s; + if( $text ){ + # a method or function? + return $1 if $text =~ /(\w+)\s*\(/; + return $1 if $text =~ /->\s*(\w+)\s*\(?/; + + # a variable name? + return $1 if $text =~ /^([\$\@%*]\S+)/; + + # some pattern matching operator? + return $1 if $text =~ m|^(\w+/).*/\w*$|; + + # fancy stuff... like "do { }" + return $1 if $text =~ m|^(\w+)\s*{.*}$|; + + # honour the perlfunc manpage: func [PAR[,[ ]PAR]...] + # and some funnies with ... Module ... + return $1 if $text =~ m{^([a-z\d_]+)(\s+[A-Z\d,/& ]+)?$}; + return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$}; + + # text? normalize! + $text =~ s/\s+/_/sg; + $text =~ s{(\W)}{ + defined( $HC[ord($1)] ) ? $HC[ord($1)] + : ( $HC[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe; + $text = substr( $text, 0, 50 ); + } else { + return undef(); + } +} + +# +# make_URL_href - generate HTML href from URL +# Special treatment for CGI queries. +# +sub make_URL_href($){ + my( $url ) = @_; + if( $url !~ + s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<a href="$1$2">$1</a>}i ){ + $url = "<a href=\"$url\">$url</a>"; + } + return $url; +} + +1; diff --git a/Master/tlpkg/installer/perllib/Pod/LaTeX.pm b/Master/tlpkg/installer/perllib/Pod/LaTeX.pm new file mode 100644 index 00000000000..9d3a905258f --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/LaTeX.pm @@ -0,0 +1,1876 @@ +package Pod::LaTeX; + +=head1 NAME + +Pod::LaTeX - Convert Pod data to formatted Latex + +=head1 SYNOPSIS + + use Pod::LaTeX; + my $parser = Pod::LaTeX->new ( ); + + $parser->parse_from_filehandle; + + $parser->parse_from_file ('file.pod', 'file.tex'); + +=head1 DESCRIPTION + +C<Pod::LaTeX> is a module to convert documentation in the Pod format +into Latex. The L<B<pod2latex>|pod2latex> X<pod2latex> command uses +this module for translation. + +C<Pod::LaTeX> is a derived class from L<Pod::Select|Pod::Select>. + +=cut + + +use strict; +require Pod::ParseUtils; +use base qw/ Pod::Select /; + +# use Data::Dumper; # for debugging +use Carp; + +use vars qw/ $VERSION %HTML_Escapes @LatexSections /; + +$VERSION = '0.58'; + +# Definitions of =headN -> latex mapping +@LatexSections = (qw/ + chapter + section + subsection + subsubsection + paragraph + subparagraph + /); + +# Standard escape sequences converted to Latex. +# The Unicode name of each character is given in the comments. +# Complete LaTeX set added by Peter Acklam. + +%HTML_Escapes = ( + 'sol' => '\textfractionsolidus{}', # xxx - or should it be just '/' + 'verbar' => '|', + + # The stuff below is based on the information available at + # http://www.w3.org/TR/html401/sgml/entities.html + + # All characters in the range 0xA0-0xFF of the ISO 8859-1 character set. + # Several of these characters require the `textcomp' LaTeX package. + 'nbsp' => q|~|, # 0xA0 - no-break space = non-breaking space + 'iexcl' => q|\textexclamdown{}|, # 0xA1 - inverted exclamation mark + 'cent' => q|\textcent{}|, # 0xA2 - cent sign + 'pound' => q|\textsterling{}|, # 0xA3 - pound sign + 'curren' => q|\textcurrency{}|, # 0xA4 - currency sign + 'yen' => q|\textyen{}|, # 0xA5 - yen sign = yuan sign + 'brvbar' => q|\textbrokenbar{}|, # 0xA6 - broken bar = broken vertical bar + 'sect' => q|\textsection{}|, # 0xA7 - section sign + 'uml' => q|\textasciidieresis{}|, # 0xA8 - diaeresis = spacing diaeresis + 'copy' => q|\textcopyright{}|, # 0xA9 - copyright sign + 'ordf' => q|\textordfeminine{}|, # 0xAA - feminine ordinal indicator + 'laquo' => q|\guillemotleft{}|, # 0xAB - left-pointing double angle quotation mark = left pointing guillemet + 'not' => q|\textlnot{}|, # 0xAC - not sign + 'shy' => q|\-|, # 0xAD - soft hyphen = discretionary hyphen + 'reg' => q|\textregistered{}|, # 0xAE - registered sign = registered trade mark sign + 'macr' => q|\textasciimacron{}|, # 0xAF - macron = spacing macron = overline = APL overbar + 'deg' => q|\textdegree{}|, # 0xB0 - degree sign + 'plusmn' => q|\textpm{}|, # 0xB1 - plus-minus sign = plus-or-minus sign + 'sup2' => q|\texttwosuperior{}|, # 0xB2 - superscript two = superscript digit two = squared + 'sup3' => q|\textthreesuperior{}|, # 0xB3 - superscript three = superscript digit three = cubed + 'acute' => q|\textasciiacute{}|, # 0xB4 - acute accent = spacing acute + 'micro' => q|\textmu{}|, # 0xB5 - micro sign + 'para' => q|\textparagraph{}|, # 0xB6 - pilcrow sign = paragraph sign + 'middot' => q|\textperiodcentered{}|, # 0xB7 - middle dot = Georgian comma = Greek middle dot + 'cedil' => q|\c{}|, # 0xB8 - cedilla = spacing cedilla + 'sup1' => q|\textonesuperior{}|, # 0xB9 - superscript one = superscript digit one + 'ordm' => q|\textordmasculine{}|, # 0xBA - masculine ordinal indicator + 'raquo' => q|\guillemotright{}|, # 0xBB - right-pointing double angle quotation mark = right pointing guillemet + 'frac14' => q|\textonequarter{}|, # 0xBC - vulgar fraction one quarter = fraction one quarter + 'frac12' => q|\textonehalf{}|, # 0xBD - vulgar fraction one half = fraction one half + 'frac34' => q|\textthreequarters{}|, # 0xBE - vulgar fraction three quarters = fraction three quarters + 'iquest' => q|\textquestiondown{}|, # 0xBF - inverted question mark = turned question mark + 'Agrave' => q|\`A|, # 0xC0 - latin capital letter A with grave = latin capital letter A grave + 'Aacute' => q|\'A|, # 0xC1 - latin capital letter A with acute + 'Acirc' => q|\^A|, # 0xC2 - latin capital letter A with circumflex + 'Atilde' => q|\~A|, # 0xC3 - latin capital letter A with tilde + 'Auml' => q|\"A|, # 0xC4 - latin capital letter A with diaeresis + 'Aring' => q|\AA{}|, # 0xC5 - latin capital letter A with ring above = latin capital letter A ring + 'AElig' => q|\AE{}|, # 0xC6 - latin capital letter AE = latin capital ligature AE + 'Ccedil' => q|\c{C}|, # 0xC7 - latin capital letter C with cedilla + 'Egrave' => q|\`E|, # 0xC8 - latin capital letter E with grave + 'Eacute' => q|\'E|, # 0xC9 - latin capital letter E with acute + 'Ecirc' => q|\^E|, # 0xCA - latin capital letter E with circumflex + 'Euml' => q|\"E|, # 0xCB - latin capital letter E with diaeresis + 'Igrave' => q|\`I|, # 0xCC - latin capital letter I with grave + 'Iacute' => q|\'I|, # 0xCD - latin capital letter I with acute + 'Icirc' => q|\^I|, # 0xCE - latin capital letter I with circumflex + 'Iuml' => q|\"I|, # 0xCF - latin capital letter I with diaeresis + 'ETH' => q|\DH{}|, # 0xD0 - latin capital letter ETH + 'Ntilde' => q|\~N|, # 0xD1 - latin capital letter N with tilde + 'Ograve' => q|\`O|, # 0xD2 - latin capital letter O with grave + 'Oacute' => q|\'O|, # 0xD3 - latin capital letter O with acute + 'Ocirc' => q|\^O|, # 0xD4 - latin capital letter O with circumflex + 'Otilde' => q|\~O|, # 0xD5 - latin capital letter O with tilde + 'Ouml' => q|\"O|, # 0xD6 - latin capital letter O with diaeresis + 'times' => q|\texttimes{}|, # 0xD7 - multiplication sign + 'Oslash' => q|\O{}|, # 0xD8 - latin capital letter O with stroke = latin capital letter O slash + 'Ugrave' => q|\`U|, # 0xD9 - latin capital letter U with grave + 'Uacute' => q|\'U|, # 0xDA - latin capital letter U with acute + 'Ucirc' => q|\^U|, # 0xDB - latin capital letter U with circumflex + 'Uuml' => q|\"U|, # 0xDC - latin capital letter U with diaeresis + 'Yacute' => q|\'Y|, # 0xDD - latin capital letter Y with acute + 'THORN' => q|\TH{}|, # 0xDE - latin capital letter THORN + 'szlig' => q|\ss{}|, # 0xDF - latin small letter sharp s = ess-zed + 'agrave' => q|\`a|, # 0xE0 - latin small letter a with grave = latin small letter a grave + 'aacute' => q|\'a|, # 0xE1 - latin small letter a with acute + 'acirc' => q|\^a|, # 0xE2 - latin small letter a with circumflex + 'atilde' => q|\~a|, # 0xE3 - latin small letter a with tilde + 'auml' => q|\"a|, # 0xE4 - latin small letter a with diaeresis + 'aring' => q|\aa{}|, # 0xE5 - latin small letter a with ring above = latin small letter a ring + 'aelig' => q|\ae{}|, # 0xE6 - latin small letter ae = latin small ligature ae + 'ccedil' => q|\c{c}|, # 0xE7 - latin small letter c with cedilla + 'egrave' => q|\`e|, # 0xE8 - latin small letter e with grave + 'eacute' => q|\'e|, # 0xE9 - latin small letter e with acute + 'ecirc' => q|\^e|, # 0xEA - latin small letter e with circumflex + 'euml' => q|\"e|, # 0xEB - latin small letter e with diaeresis + 'igrave' => q|\`i|, # 0xEC - latin small letter i with grave + 'iacute' => q|\'i|, # 0xED - latin small letter i with acute + 'icirc' => q|\^i|, # 0xEE - latin small letter i with circumflex + 'iuml' => q|\"i|, # 0xEF - latin small letter i with diaeresis + 'eth' => q|\dh{}|, # 0xF0 - latin small letter eth + 'ntilde' => q|\~n|, # 0xF1 - latin small letter n with tilde + 'ograve' => q|\`o|, # 0xF2 - latin small letter o with grave + 'oacute' => q|\'o|, # 0xF3 - latin small letter o with acute + 'ocirc' => q|\^o|, # 0xF4 - latin small letter o with circumflex + 'otilde' => q|\~o|, # 0xF5 - latin small letter o with tilde + 'ouml' => q|\"o|, # 0xF6 - latin small letter o with diaeresis + 'divide' => q|\textdiv{}|, # 0xF7 - division sign + 'oslash' => q|\o{}|, # 0xF8 - latin small letter o with stroke, = latin small letter o slash + 'ugrave' => q|\`u|, # 0xF9 - latin small letter u with grave + 'uacute' => q|\'u|, # 0xFA - latin small letter u with acute + 'ucirc' => q|\^u|, # 0xFB - latin small letter u with circumflex + 'uuml' => q|\"u|, # 0xFC - latin small letter u with diaeresis + 'yacute' => q|\'y|, # 0xFD - latin small letter y with acute + 'thorn' => q|\th{}|, # 0xFE - latin small letter thorn + 'yuml' => q|\"y|, # 0xFF - latin small letter y with diaeresis + + # Latin Extended-B + 'fnof' => q|\textflorin{}|, # latin small f with hook = function = florin + + # Greek + 'Alpha' => q|$\mathrm{A}$|, # greek capital letter alpha + 'Beta' => q|$\mathrm{B}$|, # greek capital letter beta + 'Gamma' => q|$\Gamma$|, # greek capital letter gamma + 'Delta' => q|$\Delta$|, # greek capital letter delta + 'Epsilon' => q|$\mathrm{E}$|, # greek capital letter epsilon + 'Zeta' => q|$\mathrm{Z}$|, # greek capital letter zeta + 'Eta' => q|$\mathrm{H}$|, # greek capital letter eta + 'Theta' => q|$\Theta$|, # greek capital letter theta + 'Iota' => q|$\mathrm{I}$|, # greek capital letter iota + 'Kappa' => q|$\mathrm{K}$|, # greek capital letter kappa + 'Lambda' => q|$\Lambda$|, # greek capital letter lambda + 'Mu' => q|$\mathrm{M}$|, # greek capital letter mu + 'Nu' => q|$\mathrm{N}$|, # greek capital letter nu + 'Xi' => q|$\Xi$|, # greek capital letter xi + 'Omicron' => q|$\mathrm{O}$|, # greek capital letter omicron + 'Pi' => q|$\Pi$|, # greek capital letter pi + 'Rho' => q|$\mathrm{R}$|, # greek capital letter rho + 'Sigma' => q|$\Sigma$|, # greek capital letter sigma + 'Tau' => q|$\mathrm{T}$|, # greek capital letter tau + 'Upsilon' => q|$\Upsilon$|, # greek capital letter upsilon + 'Phi' => q|$\Phi$|, # greek capital letter phi + 'Chi' => q|$\mathrm{X}$|, # greek capital letter chi + 'Psi' => q|$\Psi$|, # greek capital letter psi + 'Omega' => q|$\Omega$|, # greek capital letter omega + + 'alpha' => q|$\alpha$|, # greek small letter alpha + 'beta' => q|$\beta$|, # greek small letter beta + 'gamma' => q|$\gamma$|, # greek small letter gamma + 'delta' => q|$\delta$|, # greek small letter delta + 'epsilon' => q|$\epsilon$|, # greek small letter epsilon + 'zeta' => q|$\zeta$|, # greek small letter zeta + 'eta' => q|$\eta$|, # greek small letter eta + 'theta' => q|$\theta$|, # greek small letter theta + 'iota' => q|$\iota$|, # greek small letter iota + 'kappa' => q|$\kappa$|, # greek small letter kappa + 'lambda' => q|$\lambda$|, # greek small letter lambda + 'mu' => q|$\mu$|, # greek small letter mu + 'nu' => q|$\nu$|, # greek small letter nu + 'xi' => q|$\xi$|, # greek small letter xi + 'omicron' => q|$o$|, # greek small letter omicron + 'pi' => q|$\pi$|, # greek small letter pi + 'rho' => q|$\rho$|, # greek small letter rho +# 'sigmaf' => q||, # greek small letter final sigma + 'sigma' => q|$\sigma$|, # greek small letter sigma + 'tau' => q|$\tau$|, # greek small letter tau + 'upsilon' => q|$\upsilon$|, # greek small letter upsilon + 'phi' => q|$\phi$|, # greek small letter phi + 'chi' => q|$\chi$|, # greek small letter chi + 'psi' => q|$\psi$|, # greek small letter psi + 'omega' => q|$\omega$|, # greek small letter omega +# 'thetasym' => q||, # greek small letter theta symbol +# 'upsih' => q||, # greek upsilon with hook symbol +# 'piv' => q||, # greek pi symbol + + # General Punctuation + 'bull' => q|\textbullet{}|, # bullet = black small circle + # bullet is NOT the same as bullet operator + 'hellip' => q|\textellipsis{}|, # horizontal ellipsis = three dot leader + 'prime' => q|\textquotesingle{}|, # prime = minutes = feet + 'Prime' => q|\textquotedbl{}|, # double prime = seconds = inches + 'oline' => q|\textasciimacron{}|, # overline = spacing overscore + 'frasl' => q|\textfractionsolidus{}|, # fraction slash + + # Letterlike Symbols + 'weierp' => q|$\wp$|, # script capital P = power set = Weierstrass p + 'image' => q|$\Re$|, # blackletter capital I = imaginary part + 'real' => q|$\Im$|, # blackletter capital R = real part symbol + 'trade' => q|\texttrademark{}|, # trade mark sign +# 'alefsym' => q||, # alef symbol = first transfinite cardinal + # alef symbol is NOT the same as hebrew letter alef, although the same + # glyph could be used to depict both characters + + # Arrows + 'larr' => q|\textleftarrow{}|, # leftwards arrow + 'uarr' => q|\textuparrow{}|, # upwards arrow + 'rarr' => q|\textrightarrow{}|, # rightwards arrow + 'darr' => q|\textdownarrow{}|, # downwards arrow + 'harr' => q|$\leftrightarrow$|, # left right arrow +# 'crarr' => q||, # downwards arrow with corner leftwards = carriage return + 'lArr' => q|$\Leftarrow$|, # leftwards double arrow + # ISO 10646 does not say that lArr is the same as the 'is implied by' + # arrow but also does not have any other character for that function. So + # lArr can be used for 'is implied by' as ISOtech suggests + 'uArr' => q|$\Uparrow$|, # upwards double arrow + 'rArr' => q|$\Rightarrow$|, # rightwards double arrow + # ISO 10646 does not say this is the 'implies' character but does not + # have another character with this function so ? rArr can be used for + # 'implies' as ISOtech suggests + 'dArr' => q|$\Downarrow$|, # downwards double arrow + 'hArr' => q|$\Leftrightarrow$|, # left right double arrow + + # Mathematical Operators. + # Some of these require the `amssymb' package. + 'forall' => q|$\forall$|, # for all + 'part' => q|$\partial$|, # partial differential + 'exist' => q|$\exists$|, # there exists + 'empty' => q|$\emptyset$|, # empty set = null set = diameter + 'nabla' => q|$\nabla$|, # nabla = backward difference + 'isin' => q|$\in$|, # element of + 'notin' => q|$\notin$|, # not an element of + 'ni' => q|$\ni$|, # contains as member + 'prod' => q|$\prod$|, # n-ary product = product sign + # prod is NOT the same character as 'greek capital letter pi' though the + # same glyph might be used for both + 'sum' => q|$\sum$|, # n-ary sumation + # sum is NOT the same character as 'greek capital letter sigma' though + # the same glyph might be used for both + 'minus' => q|$-$|, # minus sign + 'lowast' => q|$\ast$|, # asterisk operator + 'radic' => q|$\surd$|, # square root = radical sign + 'prop' => q|$\propto$|, # proportional to + 'infin' => q|$\infty$|, # infinity + 'ang' => q|$\angle$|, # angle + 'and' => q|$\wedge$|, # logical and = wedge + 'or' => q|$\vee$|, # logical or = vee + 'cap' => q|$\cap$|, # intersection = cap + 'cup' => q|$\cup$|, # union = cup + 'int' => q|$\int$|, # integral + 'there4' => q|$\therefore$|, # therefore + 'sim' => q|$\sim$|, # tilde operator = varies with = similar to + # tilde operator is NOT the same character as the tilde + 'cong' => q|$\cong$|, # approximately equal to + 'asymp' => q|$\asymp$|, # almost equal to = asymptotic to + 'ne' => q|$\neq$|, # not equal to + 'equiv' => q|$\equiv$|, # identical to + 'le' => q|$\leq$|, # less-than or equal to + 'ge' => q|$\geq$|, # greater-than or equal to + 'sub' => q|$\subset$|, # subset of + 'sup' => q|$\supset$|, # superset of + # note that nsup, 'not a superset of' is not covered by the Symbol font + # encoding and is not included. + 'nsub' => q|$\not\subset$|, # not a subset of + 'sube' => q|$\subseteq$|, # subset of or equal to + 'supe' => q|$\supseteq$|, # superset of or equal to + 'oplus' => q|$\oplus$|, # circled plus = direct sum + 'otimes' => q|$\otimes$|, # circled times = vector product + 'perp' => q|$\perp$|, # up tack = orthogonal to = perpendicular + 'sdot' => q|$\cdot$|, # dot operator + # dot operator is NOT the same character as middle dot + + # Miscellaneous Technical + 'lceil' => q|$\lceil$|, # left ceiling = apl upstile + 'rceil' => q|$\rceil$|, # right ceiling + 'lfloor' => q|$\lfloor$|, # left floor = apl downstile + 'rfloor' => q|$\rfloor$|, # right floor + 'lang' => q|$\langle$|, # left-pointing angle bracket = bra + # lang is NOT the same character as 'less than' or 'single left-pointing + # angle quotation mark' + 'rang' => q|$\rangle$|, # right-pointing angle bracket = ket + # rang is NOT the same character as 'greater than' or 'single + # right-pointing angle quotation mark' + + # Geometric Shapes + 'loz' => q|$\lozenge$|, # lozenge + + # Miscellaneous Symbols + 'spades' => q|$\spadesuit$|, # black spade suit + 'clubs' => q|$\clubsuit$|, # black club suit = shamrock + 'hearts' => q|$\heartsuit$|, # black heart suit = valentine + 'diams' => q|$\diamondsuit$|, # black diamond suit + + # C0 Controls and Basic Latin + 'quot' => q|"|, # quotation mark = APL quote ["] + 'amp' => q|\&|, # ampersand + 'lt' => q|<|, # less-than sign + 'gt' => q|>|, # greater-than sign + 'OElig' => q|\OE{}|, # latin capital ligature OE + 'oelig' => q|\oe{}|, # latin small ligature oe + 'Scaron' => q|\v{S}|, # latin capital letter S with caron + 'scaron' => q|\v{s}|, # latin small letter s with caron + 'Yuml' => q|\"Y|, # latin capital letter Y with diaeresis + 'circ' => q|\textasciicircum{}|, # modifier letter circumflex accent + 'tilde' => q|\textasciitilde{}|, # small tilde + 'ensp' => q|\phantom{n}|, # en space + 'emsp' => q|\hspace{1em}|, # em space + 'thinsp' => q|\,|, # thin space + 'zwnj' => q|{}|, # zero width non-joiner +# 'zwj' => q||, # zero width joiner +# 'lrm' => q||, # left-to-right mark +# 'rlm' => q||, # right-to-left mark + 'ndash' => q|--|, # en dash + 'mdash' => q|---|, # em dash + 'lsquo' => q|\textquoteleft{}|, # left single quotation mark + 'rsquo' => q|\textquoteright{}|, # right single quotation mark + 'sbquo' => q|\quotesinglbase{}|, # single low-9 quotation mark + 'ldquo' => q|\textquotedblleft{}|, # left double quotation mark + 'rdquo' => q|\textquotedblright{}|, # right double quotation mark + 'bdquo' => q|\quotedblbase{}|, # double low-9 quotation mark + 'dagger' => q|\textdagger{}|, # dagger + 'Dagger' => q|\textdaggerdbl{}|, # double dagger + 'permil' => q|\textperthousand{}|, # per mille sign + 'lsaquo' => q|\guilsinglleft{}|, # single left-pointing angle quotation mark + 'rsaquo' => q|\guilsinglright{}|, # single right-pointing angle quotation mark + 'euro' => q|\texteuro{}|, # euro sign +); + +=head1 OBJECT METHODS + +The following methods are provided in this module. Methods inherited +from C<Pod::Select> are not described in the public interface. + +=over 4 + +=begin __PRIVATE__ + +=item C<initialize> + +Initialise the object. This method is subclassed from C<Pod::Parser>. +The base class method is invoked. This method defines the default +behaviour of the object unless overridden by supplying arguments to +the constructor. + +Internal settings are defaulted as well as the public instance data. +Internal hash values are accessed directly (rather than through +a method) and start with an underscore. + +This method should not be invoked by the user directly. + +=end __PRIVATE__ + +=cut + + + +# - An array for nested lists + +# Arguments have already been read by this point + +sub initialize { + my $self = shift; + + # print Dumper($self); + + # Internals + $self->{_Lists} = []; # For nested lists + $self->{_suppress_all_para} = 0; # For =begin blocks + $self->{_dont_modify_any_para}=0; # For =begin blocks + $self->{_CURRENT_HEAD1} = ''; # Name of current HEAD1 section + + # Options - only initialise if not already set + + # Cause the '=head1 NAME' field to be treated specially + # The contents of the NAME paragraph will be converted + # to a section title. All subsequent =head1 will be converted + # to =head2 and down. Will not affect =head1's prior to NAME + # Assumes: 'Module - purpose' format + # Also creates a purpose field + # The name is used for Labeling of the subsequent subsections + $self->{ReplaceNAMEwithSection} = 0 + unless exists $self->{ReplaceNAMEwithSection}; + $self->{AddPreamble} = 1 # make full latex document + unless exists $self->{AddPreamble}; + $self->{StartWithNewPage} = 0 # Start new page for pod section + unless exists $self->{StartWithNewPage}; + $self->{TableOfContents} = 0 # Add table of contents + unless exists $self->{TableOfContents}; # only relevent if AddPreamble=1 + $self->{AddPostamble} = 1 # Add closing latex code at end + unless exists $self->{AddPostamble}; # effectively end{document} and index + $self->{MakeIndex} = 1 # Add index (only relevant AddPostamble + unless exists $self->{MakeIndex}; # and AddPreamble) + + $self->{UniqueLabels} = 1 # Use label unique for each pod + unless exists $self->{UniqueLabels}; # either based on the filename + # or supplied + + # Control the level of =head1. default is \section + # + $self->{Head1Level} = 1 # Offset in latex sections + unless exists $self->{Head1Level}; # 0 is chapter, 2 is subsection + + # Control at which level numbering of sections is turned off + # ie subsection becomes subsection* + # The numbering is relative to the latex sectioning commands + # and is independent of Pod heading level + # default is to number \section but not \subsection + $self->{LevelNoNum} = 2 + unless exists $self->{LevelNoNum}; + + # Label to be used as prefix to all internal section names + # If not defined will attempt to derive it from the filename + # This can not happen when running parse_from_filehandle though + # hence the ability to set the label externally + # The label could then be Pod::Parser_DESCRIPTION or somesuch + + $self->{Label} = undef # label to be used as prefix + unless exists $self->{Label}; # to all internal section names + + # These allow the caller to add arbritrary latex code to + # start and end of document. AddPreamble and AddPostamble are ignored + # if these are set. + # Also MakeIndex and TableOfContents are also ignored. + $self->{UserPreamble} = undef # User supplied start (AddPreamble =1) + unless exists $self->{Label}; + $self->{UserPostamble} = undef # Use supplied end (AddPostamble=1) + unless exists $self->{Label}; + + # Run base initialize + $self->SUPER::initialize; + +} + +=back + +=head2 Data Accessors + +The following methods are provided for accessing instance data. These +methods should be used for accessing configuration parameters rather +than assuming the object is a hash. + +Default values can be supplied by using these names as keys to a hash +of arguments when using the C<new()> constructor. + +=over 4 + +=item B<AddPreamble> + +Logical to control whether a C<latex> preamble is to be written. +If true, a valid C<latex> preamble is written before the pod data is written. +This is similar to: + + \documentclass{article} + \usepackage[T1]{fontenc} + \usepackage{textcomp} + \begin{document} + +but will be more complicated if table of contents and indexing are required. +Can be used to set or retrieve the current value. + + $add = $parser->AddPreamble(); + $parser->AddPreamble(1); + +If used in conjunction with C<AddPostamble> a full latex document will +be written that could be immediately processed by C<latex>. + +For some pod escapes it may be necessary to include the amsmath +package. This is not yet added to the preamble automaatically. + +=cut + +sub AddPreamble { + my $self = shift; + if (@_) { + $self->{AddPreamble} = shift; + } + return $self->{AddPreamble}; +} + +=item B<AddPostamble> + +Logical to control whether a standard C<latex> ending is written to the output +file after the document has been processed. +In its simplest form this is simply: + + \end{document} + +but can be more complicated if a index is required. +Can be used to set or retrieve the current value. + + $add = $parser->AddPostamble(); + $parser->AddPostamble(1); + +If used in conjunction with C<AddPreaamble> a full latex document will +be written that could be immediately processed by C<latex>. + +=cut + +sub AddPostamble { + my $self = shift; + if (@_) { + $self->{AddPostamble} = shift; + } + return $self->{AddPostamble}; +} + +=item B<Head1Level> + +The C<latex> sectioning level that should be used to correspond to +a pod C<=head1> directive. This can be used, for example, to turn +a C<=head1> into a C<latex> C<subsection>. This should hold a number +corresponding to the required position in an array containing the +following elements: + + [0] chapter + [1] section + [2] subsection + [3] subsubsection + [4] paragraph + [5] subparagraph + +Can be used to set or retrieve the current value: + + $parser->Head1Level(2); + $sect = $parser->Head1Level; + +Setting this number too high can result in sections that may not be reproducible +in the expected way. For example, setting this to 4 would imply that C<=head3> +do not have a corresponding C<latex> section (C<=head1> would correspond to +a C<paragraph>). + +A check is made to ensure that the supplied value is an integer in the +range 0 to 5. + +Default is for a value of 1 (i.e. a C<section>). + +=cut + +sub Head1Level { + my $self = shift; + if (@_) { + my $arg = shift; + if ($arg =~ /^\d$/ && $arg <= $#LatexSections) { + $self->{Head1Level} = $arg; + } else { + carp "Head1Level supplied ($arg) must be integer in range 0 to ".$#LatexSections . "- Ignoring\n"; + } + } + return $self->{Head1Level}; +} + +=item B<Label> + +This is the label that is prefixed to all C<latex> label and index +entries to make them unique. In general, pods have similarly titled +sections (NAME, DESCRIPTION etc) and a C<latex> label will be multiply +defined if more than one pod document is to be included in a single +C<latex> file. To overcome this, this label is prefixed to a label +whenever a label is required (joined with an underscore) or to an +index entry (joined by an exclamation mark which is the normal index +separator). For example, C<\label{text}> becomes C<\label{Label_text}>. + +Can be used to set or retrieve the current value: + + $label = $parser->Label; + $parser->Label($label); + +This label is only used if C<UniqueLabels> is true. +Its value is set automatically from the C<NAME> field +if C<ReplaceNAMEwithSection> is true. If this is not the case +it must be set manually before starting the parse. + +Default value is C<undef>. + +=cut + +sub Label { + my $self = shift; + if (@_) { + $self->{Label} = shift; + } + return $self->{Label}; +} + +=item B<LevelNoNum> + +Control the point at which C<latex> section numbering is turned off. +For example, this can be used to make sure that C<latex> sections +are numbered but subsections are not. + +Can be used to set or retrieve the current value: + + $lev = $parser->LevelNoNum; + $parser->LevelNoNum(2); + +The argument must be an integer between 0 and 5 and is the same as the +number described in C<Head1Level> method description. The number has +nothing to do with the pod heading number, only the C<latex> sectioning. + +Default is 2. (i.e. C<latex> subsections are written as C<subsection*> +but sections are numbered). + +=cut + +sub LevelNoNum { + my $self = shift; + if (@_) { + $self->{LevelNoNum} = shift; + } + return $self->{LevelNoNum}; +} + +=item B<MakeIndex> + +Controls whether C<latex> commands for creating an index are to be inserted +into the preamble and postamble + + $makeindex = $parser->MakeIndex; + $parser->MakeIndex(0); + +Irrelevant if both C<AddPreamble> and C<AddPostamble> are false (or equivalently, +C<UserPreamble> and C<UserPostamble> are set). + +Default is for an index to be created. + +=cut + +sub MakeIndex { + my $self = shift; + if (@_) { + $self->{MakeIndex} = shift; + } + return $self->{MakeIndex}; +} + +=item B<ReplaceNAMEwithSection> + +This controls whether the C<NAME> section in the pod is to be translated +literally or converted to a slightly modified output where the section +name is the pod name rather than "NAME". + +If true, the pod segment + + =head1 NAME + + pod::name - purpose + + =head1 SYNOPSIS + +is converted to the C<latex> + + \section{pod::name\label{pod_name}\index{pod::name}} + + Purpose + + \subsection*{SYNOPSIS\label{pod_name_SYNOPSIS}% + \index{pod::name!SYNOPSIS}} + +(dependent on the value of C<Head1Level> and C<LevelNoNum>). Note that +subsequent C<head1> directives translate to subsections rather than +sections and that the labels and index now include the pod name (dependent +on the value of C<UniqueLabels>). + +The C<Label> is set from the pod name regardless of any current value +of C<Label>. + + $mod = $parser->ReplaceNAMEwithSection; + $parser->ReplaceNAMEwithSection(0); + +Default is to translate the pod literally. + +=cut + +sub ReplaceNAMEwithSection { + my $self = shift; + if (@_) { + $self->{ReplaceNAMEwithSection} = shift; + } + return $self->{ReplaceNAMEwithSection}; +} + +=item B<StartWithNewPage> + +If true, each pod translation will begin with a C<latex> +C<\clearpage>. + + $parser->StartWithNewPage(1); + $newpage = $parser->StartWithNewPage; + +Default is false. + +=cut + +sub StartWithNewPage { + my $self = shift; + if (@_) { + $self->{StartWithNewPage} = shift; + } + return $self->{StartWithNewPage}; +} + +=item B<TableOfContents> + +If true, a table of contents will be created. +Irrelevant if C<AddPreamble> is false or C<UserPreamble> +is set. + + $toc = $parser->TableOfContents; + $parser->TableOfContents(1); + +Default is false. + +=cut + +sub TableOfContents { + my $self = shift; + if (@_) { + $self->{TableOfContents} = shift; + } + return $self->{TableOfContents}; +} + +=item B<UniqueLabels> + +If true, the translator will attempt to make sure that +each C<latex> label or index entry will be uniquely identified +by prefixing the contents of C<Label>. This allows +multiple documents to be combined without clashing +common labels such as C<DESCRIPTION> and C<SYNOPSIS> + + $parser->UniqueLabels(1); + $unq = $parser->UniqueLabels; + +Default is true. + +=cut + +sub UniqueLabels { + my $self = shift; + if (@_) { + $self->{UniqueLabels} = shift; + } + return $self->{UniqueLabels}; +} + +=item B<UserPreamble> + +User supplied C<latex> preamble. Added before the pod translation +data. + +If set, the contents will be prepended to the output file before the translated +data regardless of the value of C<AddPreamble>. +C<MakeIndex> and C<TableOfContents> will also be ignored. + +=cut + +sub UserPreamble { + my $self = shift; + if (@_) { + $self->{UserPreamble} = shift; + } + return $self->{UserPreamble}; +} + +=item B<UserPostamble> + +User supplied C<latex> postamble. Added after the pod translation +data. + +If set, the contents will be prepended to the output file after the translated +data regardless of the value of C<AddPostamble>. +C<MakeIndex> will also be ignored. + +=cut + +sub UserPostamble { + my $self = shift; + if (@_) { + $self->{UserPostamble} = shift; + } + return $self->{UserPostamble}; +} + +=begin __PRIVATE__ + +=item B<Lists> + +Contains details of the currently active lists. + The array contains C<Pod::List> objects. A new C<Pod::List> +object is created each time a list is encountered and it is +pushed onto this stack. When the list context ends, it +is popped from the stack. The array will be empty if no +lists are active. + +Returns array of list information in list context +Returns array ref in scalar context + +=cut + + + +sub lists { + my $self = shift; + return @{ $self->{_Lists} } if wantarray(); + return $self->{_Lists}; +} + +=end __PRIVATE__ + +=back + +=begin __PRIVATE__ + +=head2 Subclassed methods + +The following methods override methods provided in the C<Pod::Select> +base class. See C<Pod::Parser> and C<Pod::Select> for more information +on what these methods require. + +=over 4 + +=cut + +######### END ACCESSORS ################### + +# Opening pod + +=item B<begin_pod> + +Writes the C<latex> preamble if requested. Only writes something +if AddPreamble is true. Writes a standard header unless a UserPreamble +is defined. + +=cut + +sub begin_pod { + my $self = shift; + + # Get the pod identification + # This should really come from the '=head1 NAME' paragraph + + my $infile = $self->input_file; + my $class = ref($self); + my $date = gmtime(time); + + # Comment message to say where this came from + my $comment = << "__TEX_COMMENT__"; +%% Latex generated from POD in document $infile +%% Using the perl module $class +%% Converted on $date +__TEX_COMMENT__ + + # Write the preamble + # If the caller has supplied one then we just use that + + my $preamble = ''; + + if ($self->AddPreamble) { + + if (defined $self->UserPreamble) { + + $preamble = $self->UserPreamble; + + # Add the description of where this came from + $preamble .= "\n$comment\n%% Preamble supplied by user.\n\n"; + + } else { + + # Write our own preamble + + # Code to initialise index making + # Use an array so that we can prepend comment if required + my @makeidx = ( + '\usepackage{makeidx}', + '\makeindex', + ); + + unless ($self->MakeIndex) { + foreach (@makeidx) { + $_ = '%% ' . $_; + } + } + my $makeindex = join("\n",@makeidx) . "\n"; + + # Table of contents + my $tableofcontents = '\tableofcontents'; + + $tableofcontents = '%% ' . $tableofcontents + unless $self->TableOfContents; + + # Roll our own + $preamble = << "__TEX_HEADER__"; +\\documentclass{article} +\\usepackage[T1]{fontenc} +\\usepackage{textcomp} + +$comment + +$makeindex + +\\begin{document} + +$tableofcontents + +__TEX_HEADER__ + + } + } + + # Write the header (blank if none) + $self->_output($preamble); + + # Start on new page if requested + $self->_output("\\clearpage\n") if $self->StartWithNewPage; + +} + + +=item B<end_pod> + +Write the closing C<latex> code. Only writes something if AddPostamble +is true. Writes a standard header unless a UserPostamble is defined. + +=cut + +sub end_pod { + my $self = shift; + + # End string + my $end = ''; + + # Use the user version of the postamble if defined + if ($self->AddPostamble) { + + if (defined $self->UserPostamble) { + $end = $self->UserPostamble; + + } else { + + # Check for index + my $makeindex = '\printindex'; + + $makeindex = '%% '. $makeindex unless $self->MakeIndex; + + $end = "$makeindex\n\n\\end{document}\n"; + } + } + + $self->_output($end); + +} + +=item B<command> + +Process basic pod commands. + +=cut + +sub command { + my $self = shift; + my ($command, $paragraph, $line_num, $parobj) = @_; + + # return if we dont care + return if $command eq 'pod'; + + # Store a copy of the raw text in case we are in a =for + # block and need to preserve the existing latex + my $rawpara = $paragraph; + + # Do the latex escapes + $paragraph = $self->_replace_special_chars($paragraph); + + # Interpolate pod sequences in paragraph + $paragraph = $self->interpolate($paragraph, $line_num); + $paragraph =~ s/\s+$//; + + # Replace characters that can only be done after + # interpolation of interior sequences + $paragraph = $self->_replace_special_chars_late($paragraph); + + # Now run the command + if ($command eq 'over') { + + $self->begin_list($paragraph, $line_num); + + } elsif ($command eq 'item') { + + $self->add_item($paragraph, $line_num); + + } elsif ($command eq 'back') { + + $self->end_list($line_num); + + } elsif ($command eq 'head1') { + + # Store the name of the section + $self->{_CURRENT_HEAD1} = $paragraph; + + # Print it + $self->head(1, $paragraph, $parobj); + + } elsif ($command eq 'head2') { + + $self->head(2, $paragraph, $parobj); + + } elsif ($command eq 'head3') { + + $self->head(3, $paragraph, $parobj); + + } elsif ($command eq 'head4') { + + $self->head(4, $paragraph, $parobj); + + } elsif ($command eq 'head5') { + + $self->head(5, $paragraph, $parobj); + + } elsif ($command eq 'head6') { + + $self->head(6, $paragraph, $parobj); + + } elsif ($command eq 'begin') { + + # pass through if latex + if ($paragraph =~ /^latex/i) { + # Make sure that subsequent paragraphs are not modfied before printing + $self->{_dont_modify_any_para} = 1; + + } else { + # Suppress all subsequent paragraphs unless + # it is explcitly intended for latex + $self->{_suppress_all_para} = 1; + } + + } elsif ($command eq 'for') { + + # =for latex + # some latex + + # With =for we will get the text for the full paragraph + # as well as the format name. + # We do not get an additional paragraph later on. The next + # paragraph is not governed by the =for + + # The first line contains the format and the rest is the + # raw code. + my ($format, $chunk) = split(/\n/, $rawpara, 2); + + # If we have got some latex code print it out immediately + # unmodified. Else do nothing. + if ($format =~ /^latex/i) { + # Make sure that next paragraph is not modfied before printing + $self->_output( $chunk ); + + } + + } elsif ($command eq 'end') { + + # Reset suppression + $self->{_suppress_all_para} = 0; + $self->{_dont_modify_any_para} = 0; + + } elsif ($command eq 'pod') { + + # Do nothing + + } else { + carp "Command $command not recognised at line $line_num\n"; + } + +} + +=item B<verbatim> + +Verbatim text + +=cut + +sub verbatim { + my $self = shift; + my ($paragraph, $line_num, $parobj) = @_; + + # Expand paragraph unless in =begin block + if ($self->{_dont_modify_any_para}) { + # Just print as is + $self->_output($paragraph); + + } else { + + return if $paragraph =~ /^\s+$/; + + # Clean trailing space + $paragraph =~ s/\s+$//; + + # Clean tabs. Routine taken from Tabs.pm + # by David Muir Sharnoff muir@idiom.com, + # slightly modified by hsmyers@sdragons.com 10/22/01 + my @l = split("\n",$paragraph); + foreach (@l) { + 1 while s/(^|\n)([^\t\n]*)(\t+)/ + $1. $2 . (" " x + (8 * length($3) + - (length($2) % 8))) + /sex; + } + $paragraph = join("\n",@l); + # End of change. + + + + $self->_output('\begin{verbatim}' . "\n$paragraph\n". '\end{verbatim}'."\n"); + } +} + +=item B<textblock> + +Plain text paragraph. + +=cut + +sub textblock { + my $self = shift; + my ($paragraph, $line_num, $parobj) = @_; + + # print Dumper($self); + + # Expand paragraph unless in =begin block + if ($self->{_dont_modify_any_para}) { + # Just print as is + $self->_output($paragraph); + + return; + } + + + # Escape latex special characters + $paragraph = $self->_replace_special_chars($paragraph); + + # Interpolate interior sequences + my $expansion = $self->interpolate($paragraph, $line_num); + $expansion =~ s/\s+$//; + + # Escape special characters that can not be done earlier + $expansion = $self->_replace_special_chars_late($expansion); + + # If we are replacing 'head1 NAME' with a section + # we need to look in the paragraph and rewrite things + # Need to make sure this is called only on the first paragraph + # following 'head1 NAME' and not on subsequent paragraphs that may be + # present. + if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection()) { + + # Strip white space from start and end + $paragraph =~ s/^\s+//; + $paragraph =~ s/\s$//; + + # Split the string into 2 parts + my ($name, $purpose) = split(/\s+-\s+/, $expansion,2); + + # Now prevent this from triggering until a new head1 NAME is set + $self->{_CURRENT_HEAD1} = '_NAME'; + + # Might want to clear the Label() before doing this (CHECK) + + # Print the heading + $self->head(1, $name, $parobj); + + # Set the labeling in case we want unique names later + $self->Label( $self->_create_label( $name, 1 ) ); + + # Raise the Head1Level by one so that subsequent =head1 appear + # as subsections of the main name section unless we are already + # at maximum [Head1Level() could check this itself - CHECK] + $self->Head1Level( $self->Head1Level() + 1) + unless $self->Head1Level == $#LatexSections; + + # Now write out the new latex paragraph + $purpose = ucfirst($purpose); + $self->_output("\n\n$purpose\n\n"); + + } else { + # Just write the output + $self->_output("\n\n$expansion\n\n"); + } + +} + +=item B<interior_sequence> + +Interior sequence expansion + +=cut + +sub interior_sequence { + my $self = shift; + + my ($seq_command, $seq_argument, $pod_seq) = @_; + + if ($seq_command eq 'B') { + return "\\textbf{$seq_argument}"; + + } elsif ($seq_command eq 'I') { + return "\\textit{$seq_argument}"; + + } elsif ($seq_command eq 'E') { + + # If it is simply a number + if ($seq_argument =~ /^\d+$/) { + return chr($seq_argument); + # Look up escape in hash table + } elsif (exists $HTML_Escapes{$seq_argument}) { + return $HTML_Escapes{$seq_argument}; + + } else { + my ($file, $line) = $pod_seq->file_line(); + warn "Escape sequence $seq_argument not recognised at line $line of file $file\n"; + return; + } + + } elsif ($seq_command eq 'Z') { + + # Zero width space + return '{}'; + + } elsif ($seq_command eq 'C') { + return "\\texttt{$seq_argument}"; + + } elsif ($seq_command eq 'F') { + return "\\emph{$seq_argument}"; + + } elsif ($seq_command eq 'S') { + # non breakable spaces + my $nbsp = '~'; + + $seq_argument =~ s/\s/$nbsp/g; + return $seq_argument; + + } elsif ($seq_command eq 'L') { + my $link = new Pod::Hyperlink($seq_argument); + + # undef on failure + unless (defined $link) { + carp $@; + return; + } + + # Handle internal links differently + my $type = $link->type; + my $page = $link->page; + + if ($type eq 'section' && $page eq '') { + # Use internal latex reference + my $node = $link->node; + + # Convert to a label + $node = $self->_create_label($node); + + return "\\S\\ref{$node}"; + + } else { + # Use default markup for external references + # (although Starlink would use \xlabel) + my $markup = $link->markup; + my ($file, $line) = $pod_seq->file_line(); + + return $self->interpolate($link->markup, $line); + } + + + + } elsif ($seq_command eq 'P') { + # Special markup for Pod::Hyperlink + # Replace :: with / - but not sure if I want to do this + # any more. + my $link = $seq_argument; + $link =~ s|::|/|g; + + my $ref = "\\emph{$seq_argument}"; + return $ref; + + } elsif ($seq_command eq 'Q') { + # Special markup for Pod::Hyperlink + return "\\textsf{$seq_argument}"; + + } elsif ($seq_command eq 'X') { + # Index entries + + # use \index command + # I will let '!' go through for now + # not sure how sub categories are handled in X<> + my $index = $self->_create_index($seq_argument); + return "\\index{$index}\n"; + + } else { + carp "Unknown sequence $seq_command<$seq_argument>"; + } + +} + +=back + +=head2 List Methods + +Methods used to handle lists. + +=over 4 + +=item B<begin_list> + +Called when a new list is found (via the C<over> directive). +Creates a new C<Pod::List> object and stores it on the +list stack. + + $parser->begin_list($indent, $line_num); + +=cut + +sub begin_list { + my $self = shift; + my $indent = shift; + my $line_num = shift; + + # Indicate that a list should be started for the next item + # need to do this to work out the type of list + push ( @{$self->lists}, new Pod::List(-indent => $indent, + -start => $line_num, + -file => $self->input_file, + ) + ); + +} + +=item B<end_list> + +Called when the end of a list is found (the C<back> directive). +Pops the C<Pod::List> object off the stack of lists and writes +the C<latex> code required to close a list. + + $parser->end_list($line_num); + +=cut + +sub end_list { + my $self = shift; + my $line_num = shift; + + unless (defined $self->lists->[-1]) { + my $file = $self->input_file; + warn "No list is active at line $line_num (file=$file). Missing =over?\n"; + return; + } + + # What to write depends on list type + my $type = $self->lists->[-1]->type; + + # Dont write anything if the list type is not set + # iomplying that a list was created but no entries were + # placed in it (eg because of a =begin/=end combination) + $self->_output("\\end{$type}\n") + if (defined $type && length($type) > 0); + + # Clear list + pop(@{ $self->lists}); + +} + +=item B<add_item> + +Add items to the list. The first time an item is encountered +(determined from the state of the current C<Pod::List> object) +the type of list is determined (ordered, unnumbered or description) +and the relevant latex code issued. + + $parser->add_item($paragraph, $line_num); + +=cut + +sub add_item { + my $self = shift; + my $paragraph = shift; + my $line_num = shift; + + unless (defined $self->lists->[-1]) { + my $file = $self->input_file; + warn "List has already ended by line $line_num of file $file. Missing =over?\n"; + # Replace special chars +# $paragraph = $self->_replace_special_chars($paragraph); + $self->_output("$paragraph\n\n"); + return; + } + + # If paragraphs printing is turned off via =begin/=end or whatver + # simply return immediately + return if $self->{_suppress_all_para}; + + # Check to see whether we are starting a new lists + if (scalar($self->lists->[-1]->item) == 0) { + + # Examine the paragraph to determine what type of list + # we have + $paragraph =~ s/\s+$//; + $paragraph =~ s/^\s+//; + + my $type; + if (substr($paragraph, 0,1) eq '*') { + $type = 'itemize'; + } elsif ($paragraph =~ /^\d/) { + $type = 'enumerate'; + } else { + $type = 'description'; + } + $self->lists->[-1]->type($type); + + $self->_output("\\begin{$type}\n"); + + } + + my $type = $self->lists->[-1]->type; + + if ($type eq 'description') { + # Handle long items - long items do not wrap + # If the string is longer than 40 characters we split + # it into a real item header and some bold text. + my $maxlen = 40; + my ($hunk1, $hunk2) = $self->_split_delimited( $paragraph, $maxlen ); + + # Print the first hunk + $self->_output("\n\\item[{$hunk1}] "); + + # and the second hunk if it is defined + if ($hunk2) { + $self->_output("\\textbf{$hunk2}"); + } else { + # Not there so make sure we have a new line + $self->_output("\\mbox{}"); + } + + } else { + # If the item was '* Something' or '\d+ something' we still need to write + # out the something. Also allow 1) and 1. + my $extra_info = $paragraph; + $extra_info =~ s/^(\*|\d+[\.\)]?)\s*//; + $self->_output("\n\\item $extra_info"); + } + + # Store the item name in the object. Required so that + # we can tell if the list is new or not + $self->lists->[-1]->item($paragraph); + +} + +=back + +=head2 Methods for headings + +=over 4 + +=item B<head> + +Print a heading of the required level. + + $parser->head($level, $paragraph, $parobj); + +The first argument is the pod heading level. The second argument +is the contents of the heading. The 3rd argument is a Pod::Paragraph +object so that the line number can be extracted. + +=cut + +sub head { + my $self = shift; + my $num = shift; + my $paragraph = shift; + my $parobj = shift; + + # If we are replace 'head1 NAME' with a section + # we return immediately if we get it + return + if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection()); + + # Create a label + my $label = $self->_create_label($paragraph); + + # Create an index entry + my $index = $self->_create_index($paragraph); + + # Work out position in the above array taking into account + # that =head1 is equivalent to $self->Head1Level + + my $level = $self->Head1Level() - 1 + $num; + + # Warn if heading to large + if ($num > $#LatexSections) { + my $line = $parobj->file_line; + my $file = $self->input_file; + warn "Heading level too large ($level) for LaTeX at line $line of file $file\n"; + $level = $#LatexSections; + } + + # Check to see whether section should be unnumbered + my $star = ($level >= $self->LevelNoNum ? '*' : ''); + + # Section + $self->_output("\\" .$LatexSections[$level] .$star ."{$paragraph\\label{".$label ."}\\index{".$index."}}\n"); + +} + + +=back + +=end __PRIVATE__ + +=begin __PRIVATE__ + +=head2 Internal methods + +Internal routines are described in this section. They do not form part of the +public interface. All private methods start with an underscore. + +=over 4 + +=item B<_output> + +Output text to the output filehandle. This method must be always be called +to output parsed text. + + $parser->_output($text); + +Does not write anything if a =begin is active that should be +ignored. + +=cut + +sub _output { + my $self = shift; + my $text = shift; + + print { $self->output_handle } $text + unless $self->{_suppress_all_para}; + +} + + +=item B<_replace_special_chars> + +Subroutine to replace characters that are special in C<latex> +with the escaped forms + + $escaped = $parser->_replace_special_chars($paragraph); + +Need to call this routine before interior_sequences are munged but not +if verbatim. It must be called before interpolation of interior +sequences so that curly brackets and special latex characters inserted +during interpolation are not themselves escaped. This means that < and +> can not be modified here since the text still contains interior +sequences. + +Special characters and the C<latex> equivalents are: + + } \} + { \{ + _ \_ + $ \$ + % \% + & \& + \ $\backslash$ + ^ \^{} + ~ \~{} + # \# + +=cut + +sub _replace_special_chars { + my $self = shift; + my $paragraph = shift; + + # Replace a \ with $\backslash$ + # This is made more complicated because the dollars will be escaped + # by the subsequent replacement. Easiest to add \backslash + # now and then add the dollars + $paragraph =~ s/\\/\\backslash/g; + + # Must be done after escape of \ since this command adds latex escapes + # Replace characters that can be escaped + $paragraph =~ s/([\$\#&%_{}])/\\$1/g; + + # Replace ^ characters with \^{} so that $^F works okay + $paragraph =~ s/(\^)/\\$1\{\}/g; + + # Replace tilde (~) with \texttt{\~{}} + $paragraph =~ s/~/\\texttt\{\\~\{\}\}/g; + + # Now add the dollars around each \backslash + $paragraph =~ s/(\\backslash)/\$$1\$/g; + return $paragraph; +} + +=item B<_replace_special_chars_late> + +Replace special characters that can not be replaced before interior +sequence interpolation. See C<_replace_special_chars> for a routine +to replace special characters prior to interpolation of interior +sequences. + +Does the following transformation: + + < $<$ + > $>$ + | $|$ + + +=cut + +sub _replace_special_chars_late { + my $self = shift; + my $paragraph = shift; + + # < and > + $paragraph =~ s/(<|>)/\$$1\$/g; + + # Replace | with $|$ + $paragraph =~ s'\|'$|$'g; + + + return $paragraph; +} + + +=item B<_create_label> + +Return a string that can be used as an internal reference +in a C<latex> document (i.e. accepted by the C<\label> command) + + $label = $parser->_create_label($string) + +If UniqueLabels is true returns a label prefixed by Label() +This can be suppressed with an optional second argument. + + $label = $parser->_create_label($string, $suppress); + +If a second argument is supplied (of any value including undef) +the Label() is never prefixed. This means that this routine can +be called to create a Label() without prefixing a previous setting. + +=cut + +sub _create_label { + my $self = shift; + my $paragraph = shift; + my $suppress = (@_ ? 1 : 0 ); + + # Remove latex commands + $paragraph = $self->_clean_latex_commands($paragraph); + + # Remove non alphanumerics from the label and replace with underscores + # want to protect '-' though so use negated character classes + $paragraph =~ s/[^-:\w]/_/g; + + # Multiple underscores will look unsightly so remove repeats + # This will also have the advantage of tidying up the end and + # start of string + $paragraph =~ s/_+/_/g; + + # If required need to make sure that the label is unique + # since it is possible to have multiple pods in a single + # document + if (!$suppress && $self->UniqueLabels() && defined $self->Label) { + $paragraph = $self->Label() .'_'. $paragraph; + } + + return $paragraph; +} + + +=item B<_create_index> + +Similar to C<_create_label> except an index entry is created. +If C<UniqueLabels> is true, the index entry is prefixed by +the current C<Label> and an exclamation mark. + + $ind = $parser->_create_index($paragraph); + +An exclamation mark is used by C<makeindex> to generate +sub-entries in an index. + +=cut + +sub _create_index { + my $self = shift; + my $paragraph = shift; + my $suppress = (@_ ? 1 : 0 ); + + # Remove latex commands + $paragraph = $self->_clean_latex_commands($paragraph); + + # If required need to make sure that the index entry is unique + # since it is possible to have multiple pods in a single + # document + if (!$suppress && $self->UniqueLabels() && defined $self->Label) { + $paragraph = $self->Label() .'!'. $paragraph; + } + + # Need to replace _ with space + $paragraph =~ s/_/ /g; + + return $paragraph; + +} + +=item B<_clean_latex_commands> + +Removes latex commands from text. The latex command is assumed to be of the +form C<\command{ text }>. "C<text>" is retained + + $clean = $parser->_clean_latex_commands($text); + +=cut + +sub _clean_latex_commands { + my $self = shift; + my $paragraph = shift; + + # Remove latex commands of the form \text{ } + # and replace with the contents of the { } + # need to make this non-greedy so that it can handle + # "\text{a} and \text2{b}" + # without converting it to + # "a} and \text2{b" + # This match will still get into trouble if \} is present + # This is not vital since the subsequent replacement of non-alphanumeric + # characters will tidy it up anyway + $paragraph =~ s/\\\w+{(.*?)}/$1/g; + + return $paragraph +} + +=item B<_split_delimited> + +Split the supplied string into two parts at approximately the +specified word boundary. Special care is made to make sure that it +does not split in the middle of some curly brackets. + +e.g. "this text is \textbf{very bold}" would not be split into +"this text is \textbf{very" and " bold". + + ($hunk1, $hunk2) = $self->_split_delimited( $para, $length); + +The length indicates the maximum length of hunk1. + +=cut + +# initially Supplied by hsmyers@sdragons.com +# 10/25/01, utility to split \hbox +# busting lines. Reformatted by TimJ to match module style. +sub _split_delimited { + my $self = shift; + my $input = shift; + my $limit = shift; + + # Return immediately if already small + return ($input, '') if length($input) < $limit; + + my @output; + my $s = ''; + my $t = ''; + my $depth = 0; + my $token; + + $input =~ s/\n/ /gm; + $input .= ' '; + foreach ( split ( //, $input ) ) { + $token .= $_; + if (/\{/) { + $depth++; + } elsif ( /}/ ) { + $depth--; + } elsif ( / / and $depth == 0) { + push @output, $token if ( $token and $token ne ' ' ); + $token = ''; + } + } + + foreach (@output) { + if (length($s) < $limit) { + $s .= $_; + } else { + $t .= $_; + } + } + + # Tidy up + $s =~ s/\s+$//; + $t =~ s/\s+$//; + return ($s,$t); +} + +=back + +=end __PRIVATE__ + +=head1 NOTES + +Compatible with C<latex2e> only. Can not be used with C<latex> v2.09 +or earlier. + +A subclass of C<Pod::Select> so that specific pod sections can be +converted to C<latex> by using the C<select> method. + +Some HTML escapes are missing and many have not been tested. + +=head1 SEE ALSO + +L<Pod::Parser>, L<Pod::Select>, L<pod2latex> + +=head1 AUTHORS + +Tim Jenness E<lt>tjenness@cpan.orgE<gt> + +Bug fixes and improvements have been received from: Simon Cozens +E<lt>simon@cozens.netE<gt>, Mark A. Hershberger +E<lt>mah@everybody.orgE<gt>, Marcel Grunauer +E<lt>marcel@codewerk.comE<gt>, Hugh S Myers +E<lt>hsmyers@sdragons.comE<gt>, Peter J Acklam +E<lt>jacklam@math.uio.noE<gt>, Sudhi Herle E<lt>sudhi@herle.netE<gt>, +Ariel Scolnicov E<lt>ariels@compugen.co.ilE<gt>, +Adriano Rodrigues Ferreira E<lt>ferreira@triang.com.brE<gt> and +R. de Vries E<lt>r.de.vries@dutchspace.nlE<gt>. + + +=head1 COPYRIGHT + +Copyright (C) 2000-2004 Tim Jenness. All Rights Reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=begin __PRIVATE__ + +=head1 REVISION + +$Id: LaTeX.pm,v 1.19 2004/12/30 01:40:44 timj Exp $ + +=end __PRIVATE__ + +=cut + +1; diff --git a/Master/tlpkg/installer/perllib/Pod/Man.pm b/Master/tlpkg/installer/perllib/Pod/Man.pm new file mode 100644 index 00000000000..693e4c46896 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Man.pm @@ -0,0 +1,1413 @@ +# Pod::Man -- Convert POD data to formatted *roff input. +# $Id: Man.pm,v 1.37 2003/03/30 22:34:11 eagle Exp $ +# +# Copyright 1999, 2000, 2001, 2002, 2003 by Russ Allbery <rra@stanford.edu> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module translates POD documentation into *roff markup using the man +# macro set, and is intended for converting POD documents written as Unix +# manual pages to manual pages that can be read by the man(1) command. It is +# a replacement for the pod2man command distributed with versions of Perl +# prior to 5.6. +# +# Perl core hackers, please note that this module is also separately +# maintained outside of the Perl core as part of the podlators. Please send +# me any patches at the address above in addition to sending them to the +# standard Perl mailing lists. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Man; + +require 5.005; + +use Carp qw(carp croak); +use Pod::ParseLink qw(parselink); +use Pod::Parser (); + +use strict; +use subs qw(makespace); +use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); + +@ISA = qw(Pod::Parser); + +# Don't use the CVS revision as the version, since this module is also in Perl +# core and too many things could munge CVS magic revision strings. This +# number should ideally be the same as the CVS revision in podlators, however. +$VERSION = 1.37; + + +############################################################################## +# Preamble and *roff output tables +############################################################################## + +# The following is the static preamble which starts all *roff output we +# generate. It's completely static except for the font to use as a +# fixed-width font, which is designed by @CFONT@, and the left and right +# quotes to use for C<> text, designated by @LQOUTE@ and @RQUOTE@. $PREAMBLE +# should therefore be run through s/\@CFONT\@/<font>/g before output. +$PREAMBLE = <<'----END OF PREAMBLE----'; +.de Sh \" Subsection heading +.br +.if t .Sp +.ne 5 +.PP +\fB\\$1\fR +.PP +.. +.de Sp \" Vertical space (when we can't use .PP) +.if t .sp .5v +.if n .sp +.. +.de Vb \" Begin verbatim text +.ft @CFONT@ +.nf +.ne \\$1 +.. +.de Ve \" End verbatim text +.ft R +.fi +.. +.\" Set up some character translations and predefined strings. \*(-- will +.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left +.\" double quote, and \*(R" will give a right double quote. \*(C+ will +.\" give a nicer C++. Capital omega is used to do unbreakable dashes and +.\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff, +.\" nothing in troff, for use with C<>. +.tr \(*W- +.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' +.ie n \{\ +. ds -- \(*W- +. ds PI pi +. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch +. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch +. ds L" "" +. ds R" "" +. ds C` @LQUOTE@ +. ds C' @RQUOTE@ +'br\} +.el\{\ +. ds -- \|\(em\| +. ds PI \(*p +. ds L" `` +. ds R" '' +'br\} +.\" +.\" If the F register is turned on, we'll generate index entries on stderr for +.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index +.\" entries marked with X<> in POD. Of course, you'll have to process the +.\" output yourself in some meaningful fashion. +.if \nF \{\ +. de IX +. tm Index:\\$1\t\\n%\t"\\$2" +.. +. nr % 0 +. rr F +.\} +.\" +.\" For nroff, turn off justification. Always turn off hyphenation; it makes +.\" way too many mistakes in technical documents. +.hy 0 +.if n .na +.\" +.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). +.\" Fear. Run. Save yourself. No user-serviceable parts. +. \" fudge factors for nroff and troff +.if n \{\ +. ds #H 0 +. ds #V .8m +. ds #F .3m +. ds #[ \f1 +. ds #] \fP +.\} +.if t \{\ +. ds #H ((1u-(\\\\n(.fu%2u))*.13m) +. ds #V .6m +. ds #F 0 +. ds #[ \& +. ds #] \& +.\} +. \" simple accents for nroff and troff +.if n \{\ +. ds ' \& +. ds ` \& +. ds ^ \& +. ds , \& +. ds ~ ~ +. ds / +.\} +.if t \{\ +. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" +. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' +. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' +. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' +. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' +. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' +.\} +. \" troff and (daisy-wheel) nroff accents +.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' +.ds 8 \h'\*(#H'\(*b\h'-\*(#H' +.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] +.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' +.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' +.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] +.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] +.ds ae a\h'-(\w'a'u*4/10)'e +.ds Ae A\h'-(\w'A'u*4/10)'E +. \" corrections for vroff +.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' +.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' +. \" for low resolution devices (crt and lpr) +.if \n(.H>23 .if \n(.V>19 \ +\{\ +. ds : e +. ds 8 ss +. ds o a +. ds d- d\h'-1'\(ga +. ds D- D\h'-1'\(hy +. ds th \o'bp' +. ds Th \o'LP' +. ds ae ae +. ds Ae AE +.\} +.rm #[ #] #H #V #F C +----END OF PREAMBLE---- +#`# for cperl-mode + +# This table is taken nearly verbatim from Tom Christiansen's pod2man. It +# assumes that the standard preamble has already been printed, since that's +# what defines all of the accent marks. Note that some of these are quoted +# with double quotes since they contain embedded single quotes, so use \\ +# uniformly for backslash for readability. +%ESCAPES = ( + 'amp' => '&', # ampersand + 'apos' => "'", # apostrophe + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + 'sol' => '/', # solidus (forward slash) + 'verbar' => '|', # vertical bar + + 'Aacute' => "A\\*'", # capital A, acute accent + 'aacute' => "a\\*'", # small a, acute accent + 'Acirc' => 'A\\*^', # capital A, circumflex accent + 'acirc' => 'a\\*^', # small a, circumflex accent + 'AElig' => '\*(AE', # capital AE diphthong (ligature) + 'aelig' => '\*(ae', # small ae diphthong (ligature) + 'Agrave' => "A\\*`", # capital A, grave accent + 'agrave' => "A\\*`", # small a, grave accent + 'Aring' => 'A\\*o', # capital A, ring + 'aring' => 'a\\*o', # small a, ring + 'Atilde' => 'A\\*~', # capital A, tilde + 'atilde' => 'a\\*~', # small a, tilde + 'Auml' => 'A\\*:', # capital A, dieresis or umlaut mark + 'auml' => 'a\\*:', # small a, dieresis or umlaut mark + 'Ccedil' => 'C\\*,', # capital C, cedilla + 'ccedil' => 'c\\*,', # small c, cedilla + 'Eacute' => "E\\*'", # capital E, acute accent + 'eacute' => "e\\*'", # small e, acute accent + 'Ecirc' => 'E\\*^', # capital E, circumflex accent + 'ecirc' => 'e\\*^', # small e, circumflex accent + 'Egrave' => 'E\\*`', # capital E, grave accent + 'egrave' => 'e\\*`', # small e, grave accent + 'ETH' => '\\*(D-', # capital Eth, Icelandic + 'eth' => '\\*(d-', # small eth, Icelandic + 'Euml' => 'E\\*:', # capital E, dieresis or umlaut mark + 'euml' => 'e\\*:', # small e, dieresis or umlaut mark + 'Iacute' => "I\\*'", # capital I, acute accent + 'iacute' => "i\\*'", # small i, acute accent + 'Icirc' => 'I\\*^', # capital I, circumflex accent + 'icirc' => 'i\\*^', # small i, circumflex accent + 'Igrave' => 'I\\*`', # capital I, grave accent + 'igrave' => 'i\\*`', # small i, grave accent + 'Iuml' => 'I\\*:', # capital I, dieresis or umlaut mark + 'iuml' => 'i\\*:', # small i, dieresis or umlaut mark + 'Ntilde' => 'N\*~', # capital N, tilde + 'ntilde' => 'n\*~', # small n, tilde + 'Oacute' => "O\\*'", # capital O, acute accent + 'oacute' => "o\\*'", # small o, acute accent + 'Ocirc' => 'O\\*^', # capital O, circumflex accent + 'ocirc' => 'o\\*^', # small o, circumflex accent + 'Ograve' => 'O\\*`', # capital O, grave accent + 'ograve' => 'o\\*`', # small o, grave accent + 'Oslash' => 'O\\*/', # capital O, slash + 'oslash' => 'o\\*/', # small o, slash + 'Otilde' => 'O\\*~', # capital O, tilde + 'otilde' => 'o\\*~', # small o, tilde + 'Ouml' => 'O\\*:', # capital O, dieresis or umlaut mark + 'ouml' => 'o\\*:', # small o, dieresis or umlaut mark + 'szlig' => '\*8', # small sharp s, German (sz ligature) + 'THORN' => '\\*(Th', # capital THORN, Icelandic + 'thorn' => '\\*(th', # small thorn, Icelandic + 'Uacute' => "U\\*'", # capital U, acute accent + 'uacute' => "u\\*'", # small u, acute accent + 'Ucirc' => 'U\\*^', # capital U, circumflex accent + 'ucirc' => 'u\\*^', # small u, circumflex accent + 'Ugrave' => 'U\\*`', # capital U, grave accent + 'ugrave' => 'u\\*`', # small u, grave accent + 'Uuml' => 'U\\*:', # capital U, dieresis or umlaut mark + 'uuml' => 'u\\*:', # small u, dieresis or umlaut mark + 'Yacute' => "Y\\*'", # capital Y, acute accent + 'yacute' => "y\\*'", # small y, acute accent + 'yuml' => 'y\\*:', # small y, dieresis or umlaut mark + + 'nbsp' => '\\ ', # non-breaking space + 'shy' => '', # soft (discretionary) hyphen +); + + +############################################################################## +# Static helper functions +############################################################################## + +# Protect leading quotes and periods against interpretation as commands. Also +# protect anything starting with a backslash, since it could expand or hide +# something that *roff would interpret as a command. This is overkill, but +# it's much simpler than trying to parse *roff here. +sub protect { + local $_ = shift; + s/^([.\'\\])/\\&$1/mg; + $_; +} + +# Translate a font string into an escape. +sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] } + + +############################################################################## +# Initialization +############################################################################## + +# Initialize the object. Here, we also process any additional options passed +# to the constructor or set up defaults if none were given. center is the +# centered title, release is the version number, and date is the date for the +# documentation. Note that we can't know what file name we're processing due +# to the architecture of Pod::Parser, so that *has* to either be passed to the +# constructor or set separately with Pod::Man::name(). +sub initialize { + my $self = shift; + + # Figure out the fixed-width font. If user-supplied, make sure that they + # are the right length. + for (qw/fixed fixedbold fixeditalic fixedbolditalic/) { + if (defined $$self{$_}) { + if (length ($$self{$_}) < 1 || length ($$self{$_}) > 2) { + croak qq(roff font should be 1 or 2 chars,) + . qq( not "$$self{$_}"); + } + } else { + $$self{$_} = ''; + } + } + + # Set the default fonts. We can't be sure what fixed bold-italic is going + # to be called, so default to just bold. + $$self{fixed} ||= 'CW'; + $$self{fixedbold} ||= 'CB'; + $$self{fixeditalic} ||= 'CI'; + $$self{fixedbolditalic} ||= 'CB'; + + # Set up a table of font escapes. First number is fixed-width, second is + # bold, third is italic. + $$self{FONTS} = { '000' => '\fR', '001' => '\fI', + '010' => '\fB', '011' => '\f(BI', + '100' => toescape ($$self{fixed}), + '101' => toescape ($$self{fixeditalic}), + '110' => toescape ($$self{fixedbold}), + '111' => toescape ($$self{fixedbolditalic})}; + + # Extra stuff for page titles. + $$self{center} = 'User Contributed Perl Documentation' + unless defined $$self{center}; + $$self{indent} = 4 unless defined $$self{indent}; + + # We used to try first to get the version number from a local binary, but + # we shouldn't need that any more. Get the version from the running Perl. + # Work a little magic to handle subversions correctly under both the + # pre-5.6 and the post-5.6 version numbering schemes. + if (!defined $$self{release}) { + my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/); + $version[2] ||= 0; + $version[2] *= 10 ** (3 - length $version[2]); + for (@version) { $_ += 0 } + $$self{release} = 'perl v' . join ('.', @version); + } + + # Double quotes in things that will be quoted. + for (qw/center date release/) { + $$self{$_} =~ s/\"/\"\"/g if $$self{$_}; + } + + # Figure out what quotes we'll be using for C<> text. + $$self{quotes} ||= '"'; + if ($$self{quotes} eq 'none') { + $$self{LQUOTE} = $$self{RQUOTE} = ''; + } elsif (length ($$self{quotes}) == 1) { + $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes}; + } elsif ($$self{quotes} =~ /^(.)(.)$/ + || $$self{quotes} =~ /^(..)(..)$/) { + $$self{LQUOTE} = $1; + $$self{RQUOTE} = $2; + } else { + croak qq(Invalid quote specification "$$self{quotes}"); + } + + # Double the first quote; note that this should not be s///g as two double + # quotes is represented in *roff as three double quotes, not four. Weird, + # I know. + $$self{LQUOTE} =~ s/\"/\"\"/; + $$self{RQUOTE} =~ s/\"/\"\"/; + + $self->SUPER::initialize; +} + +# For each document we process, output the preamble first. +sub begin_pod { + my $self = shift; + + # Try to figure out the name and section from the file name. + my $section = $$self{section} || 1; + my $name = $$self{name}; + if (!defined $name) { + $name = $self->input_file; + $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i); + $name =~ s/\.p(od|[lm])\z//i; + if ($section !~ /^3/) { + require File::Basename; + $name = uc File::Basename::basename ($name); + } else { + # Assume that we're dealing with a module. We want to figure out + # the full module name from the path to the file, but we don't + # want to include too much of the path into the module name. Lose + # everything up to the first of: + # + # */lib/*perl*/ standard or site_perl module + # */*perl*/lib/ from -Dprefix=/opt/perl + # */*perl*/ random module hierarchy + # + # which works. Also strip off a leading site or site_perl + # component, any OS-specific component, and any version number + # component, and strip off an initial component of "lib" or + # "blib/lib" since that's what ExtUtils::MakeMaker creates. + # splitdir requires at least File::Spec 0.8. + require File::Spec; + my ($volume, $dirs, $file) = File::Spec->splitpath ($name); + my @dirs = File::Spec->splitdir ($dirs); + my $cut = 0; + my $i; + for ($i = 0; $i < scalar @dirs; $i++) { + if ($dirs[$i] eq 'lib' && $dirs[$i + 1] =~ /perl/) { + $cut = $i + 2; + last; + } elsif ($dirs[$i] =~ /perl/) { + $cut = $i + 1; + $cut++ if $dirs[$i + 1] eq 'lib'; + last; + } + } + if ($cut > 0) { + splice (@dirs, 0, $cut); + shift @dirs if ($dirs[0] =~ /^site(_perl)?$/); + shift @dirs if ($dirs[0] =~ /^[\d.]+$/); + shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/); + } + shift @dirs if $dirs[0] eq 'lib'; + splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib'); + + # Remove empty directories when building the module name; they + # occur too easily on Unix by doubling slashes. + $name = join ('::', (grep { $_ ? $_ : () } @dirs), $file); + } + } + + # If $name contains spaces, quote it; this mostly comes up in the case of + # input from stdin. + $name = '"' . $name . '"' if ($name =~ /\s/); + + # Modification date header. Try to use the modification time of our + # input. + if (!defined $$self{date}) { + my $time = (stat $self->input_file)[9] || time; + my ($day, $month, $year) = (localtime $time)[3,4,5]; + $month++; + $year += 1900; + $$self{date} = sprintf ('%4d-%02d-%02d', $year, $month, $day); + } + + # Now, print out the preamble and the title. The meaning of the arguments + # to .TH unfortunately vary by system; some systems consider the fourth + # argument to be a "source" and others use it as a version number. + # Generally it's just presented as the left-side footer, though, so it + # doesn't matter too much if a particular system gives it another + # interpretation. + # + # The order of date and release used to be reversed in older versions of + # this module, but this order is correct for both Solaris and Linux. + local $_ = $PREAMBLE; + s/\@CFONT\@/$$self{fixed}/; + s/\@LQUOTE\@/$$self{LQUOTE}/; + s/\@RQUOTE\@/$$self{RQUOTE}/; + chomp $_; + my $pversion = $Pod::Parser::VERSION; + print { $self->output_handle } <<"----END OF HEADER----"; +.\\" Automatically generated by Pod::Man v$VERSION, Pod::Parser v$pversion +.\\" +.\\" Standard preamble: +.\\" ======================================================================== +$_ +.\\" ======================================================================== +.\\" +.IX Title "$name $section" +.TH $name $section "$$self{date}" "$$self{release}" "$$self{center}" +----END OF HEADER---- + + # Initialize a few per-file variables. + $$self{INDENT} = 0; # Current indentation level. + $$self{INDENTS} = []; # Stack of indentations. + $$self{INDEX} = []; # Index keys waiting to be printed. + $$self{IN_NAME} = 0; # Whether processing the NAME section. + $$self{ITEMS} = 0; # The number of consecutive =items. + $$self{ITEMTYPES} = []; # Stack of =item types, one per list. + $$self{SHIFTWAIT} = 0; # Whether there is a shift waiting. + $$self{SHIFTS} = []; # Stack of .RS shifts. +} + + +############################################################################## +# Core overrides +############################################################################## + +# Called for each command paragraph. Gets the command, the associated +# paragraph, the line number, and a Pod::Paragraph object. Just dispatches +# the command to a method named the same as the command. =cut is handled +# internally by Pod::Parser. +sub command { + my $self = shift; + my $command = shift; + return if $command eq 'pod'; + return if ($$self{EXCLUDE} && $command ne 'end'); + if ($self->can ('cmd_' . $command)) { + $command = 'cmd_' . $command; + $self->$command (@_); + } else { + my ($text, $line, $paragraph) = @_; + my $file; + ($file, $line) = $paragraph->file_line; + $text =~ s/\n+\z//; + $text = " $text" if ($text =~ /^\S/); + warn qq($file:$line: Unknown command paragraph "=$command$text"\n); + return; + } +} + +# Called for a verbatim paragraph. Gets the paragraph, the line number, and a +# Pod::Paragraph object. Rofficate backslashes, untabify, put a zero-width +# character at the beginning of each line to protect against commands, and +# wrap in .Vb/.Ve. +sub verbatim { + my $self = shift; + return if $$self{EXCLUDE}; + local $_ = shift; + return if /^\s+$/; + s/\s+$/\n/; + my $lines = tr/\n/\n/; + 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; + s/\\/\\e/g; + s/-/\\-/g; + s/'/\\(aq/g; + s/^(\s*\S)/'\&' . $1/gme; + $self->makespace; + $self->output (".Vb $lines\n$_.Ve\n"); + $$self{NEEDSPACE} = 1; +} + +# Called for a regular text block. Gets the paragraph, the line number, and a +# Pod::Paragraph object. Perform interpolation and output the results. +sub textblock { + my $self = shift; + return if $$self{EXCLUDE}; + $self->output ($_[0]), return if $$self{VERBATIM}; + + # Parse the tree. collapse knows about references to scalars as well as + # scalars and does the right thing with them. Tidy up any trailing + # whitespace. + my $text = shift; + $text = $self->parse ($text, @_); + $text =~ s/\n\s*$/\n/; + + # Output the paragraph. We also have to handle =over without =item. If + # there's an =over without =item, SHIFTWAIT will be set, and we need to + # handle creation of the indent here. Add the shift to SHIFTS so that it + # will be cleaned up on =back. + $self->makespace; + if ($$self{SHIFTWAIT}) { + $self->output (".RS $$self{INDENT}\n"); + push (@{ $$self{SHIFTS} }, $$self{INDENT}); + $$self{SHIFTWAIT} = 0; + } + $self->output (protect $self->textmapfonts ($text)); + $self->outindex; + $$self{NEEDSPACE} = 1; +} + +# Called for a formatting code. Takes a Pod::InteriorSequence object and +# returns a reference to a scalar. This scalar is the final formatted text. +# It's returned as a reference to an array so that other formatting codes +# above us know that the text has already been processed. +sub sequence { + my ($self, $seq) = @_; + my $command = $seq->cmd_name; + + # We have to defer processing of the inside of an L<> formatting code. If + # this code is nested inside an L<> code, return the literal raw text of + # it. + my $parent = $seq->nested; + while (defined $parent) { + return $seq->raw_text if ($parent->cmd_name eq 'L'); + $parent = $parent->nested; + } + + # Zero-width characters. + return [ '\&' ] if ($command eq 'Z'); + + # C<>, L<>, X<>, and E<> don't apply guesswork to their contents. C<> + # needs some additional special handling. + my $literal = ($command =~ /^[CELX]$/); + local $_ = $self->collapse ($seq->parse_tree, $literal, $command eq 'C'); + + # Handle E<> escapes. Numeric escapes that match one of the supported ISO + # 8859-1 characters don't work at present. + if ($command eq 'E') { + if (/^\d+$/) { + return [ chr ($_) ]; + } elsif (exists $ESCAPES{$_}) { + return [ $ESCAPES{$_} ]; + } else { + my ($file, $line) = $seq->file_line; + warn "$file:$line: Unknown escape E<$_>\n"; + return [ "E<$_>" ]; + } + } + + # For all the other codes, empty content produces no output. + return '' if $_ eq ''; + + # Handle simple formatting codes. + if ($command eq 'B') { + return [ '\f(BS' . $_ . '\f(BE' ]; + } elsif ($command eq 'F' || $command eq 'I') { + return [ '\f(IS' . $_ . '\f(IE' ]; + } elsif ($command eq 'C') { + return [ $self->quote_literal ($_) ]; + } + + # Handle links. + if ($command eq 'L') { + my ($text, $type) = (parselink ($_))[1,4]; + return '' unless $text; + my ($file, $line) = $seq->file_line; + $text = $self->parse ($text, $line); + $text = '<' . $text . '>' if $type eq 'url'; + return [ $text ]; + } + + # Whitespace protection replaces whitespace with "\ ". + if ($command eq 'S') { + s/\s+/\\ /g; + return [ $_ ]; + } + + # Add an index entry to the list of ones waiting to be output. + if ($command eq 'X') { + push (@{ $$self{INDEX} }, $_); + return ''; + } + + # Anything else is unknown. + my ($file, $line) = $seq->file_line; + warn "$file:$line: Unknown formatting code $command<$_>\n"; +} + + +############################################################################## +# Command paragraphs +############################################################################## + +# All command paragraphs take the paragraph and the line number. + +# First level heading. We can't output .IX in the NAME section due to a bug +# in some versions of catman, so don't output a .IX for that section. .SH +# already uses small caps, so remove \s1 and \s-1. Maintain IN_NAME as +# appropriate, but don't leave it set while calling parse() so as to not +# override guesswork on section headings after NAME. +sub cmd_head1 { + my $self = shift; + $$self{IN_NAME} = 0; + local $_ = $self->parse (@_); + s/\s+$//; + s/\\s-?\d//g; + s/\s*\n\s*/ /g; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $self->output ($self->switchquotes ('.SH', $self->mapfonts ($_))); + $self->outindex (($_ eq 'NAME') ? () : ('Header', $_)); + $$self{NEEDSPACE} = 0; + $$self{IN_NAME} = ($_ eq 'NAME'); +} + +# Second level heading. +sub cmd_head2 { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + s/\s*\n\s*/ /g; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $self->output ($self->switchquotes ('.Sh', $self->mapfonts ($_))); + $self->outindex ('Subsection', $_); + $$self{NEEDSPACE} = 0; +} + +# Third level heading. +sub cmd_head3 { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + s/\s*\n\s*/ /g; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $self->makespace; + $self->output ($self->textmapfonts ('\f(IS' . $_ . '\f(IE') . "\n"); + $self->outindex ('Subsection', $_); + $$self{NEEDSPACE} = 1; +} + +# Fourth level heading. +sub cmd_head4 { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + s/\s*\n\s*/ /g; + if ($$self{ITEMS} > 1) { + $$self{ITEMS} = 0; + $self->output (".PD\n"); + } + $self->makespace; + $self->output ($self->textmapfonts ($_) . "\n"); + $self->outindex ('Subsection', $_); + $$self{NEEDSPACE} = 1; +} + +# Start a list. For indents after the first, wrap the outside indent in .RS +# so that hanging paragraph tags will be correct. +sub cmd_over { + my $self = shift; + local $_ = shift; + unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } + if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) { + $self->output (".RS $$self{INDENT}\n"); + push (@{ $$self{SHIFTS} }, $$self{INDENT}); + } + push (@{ $$self{INDENTS} }, $$self{INDENT}); + push (@{ $$self{ITEMTYPES} }, 'unknown'); + $$self{INDENT} = ($_ + 0); + $$self{SHIFTWAIT} = 1; +} + +# End a list. If we've closed an embedded indent, we've mangled the hanging +# paragraph indent, so temporarily replace it with .RS and set WEIRDINDENT. +# We'll close that .RS at the next =back or =item. +sub cmd_back { + my $self = shift; + $$self{INDENT} = pop @{ $$self{INDENTS} }; + if (defined $$self{INDENT}) { + pop @{ $$self{ITEMTYPES} }; + } else { + my ($file, $line, $paragraph) = @_; + ($file, $line) = $paragraph->file_line; + warn "$file:$line: Unmatched =back\n"; + $$self{INDENT} = 0; + } + if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) { + $self->output (".RE\n"); + pop @{ $$self{SHIFTS} }; + } + if (@{ $$self{INDENTS} } > 0) { + $self->output (".RE\n"); + $self->output (".RS $$self{INDENT}\n"); + } + $$self{NEEDSPACE} = 1; + $$self{SHIFTWAIT} = 0; +} + +# An individual list item. Emit an index entry for anything that's +# interesting, but don't emit index entries for things like bullets and +# numbers. rofficate bullets too while we're at it (so for nice output, use * +# for your lists rather than o or . or - or some other thing). Newlines in an +# item title are turned into spaces since *roff can't handle them embedded. +sub cmd_item { + my $self = shift; + local $_ = $self->parse (@_); + s/\s+$//; + s/\s*\n\s*/ /g; + my $index; + if (/\w/ && !/^\w[.\)]\s*$/) { + $index = $_; + $index =~ s/^\s*[-*+o.]?(?:\s+|\Z)//; + } + $_ = '*' unless length ($_) > 0; + my $type = $$self{ITEMTYPES}[0]; + unless (defined $type) { + my ($file, $line, $paragraph) = @_; + ($file, $line) = $paragraph->file_line; + $type = 'unknown'; + } + if ($type eq 'unknown') { + $type = /^\*\s*\Z/ ? 'bullet' : 'text'; + $$self{ITEMTYPES}[0] = $type if $$self{ITEMTYPES}[0]; + } + s/^\*\s*\Z/\\\(bu/ if $type eq 'bullet'; + if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) { + $self->output (".RE\n"); + pop @{ $$self{SHIFTS} }; + } + $_ = $self->textmapfonts ($_); + $self->output (".PD 0\n") if ($$self{ITEMS} == 1); + $self->output ($self->switchquotes ('.IP', $_, $$self{INDENT})); + $self->outindex ($index ? ('Item', $index) : ()); + $$self{NEEDSPACE} = 0; + $$self{ITEMS}++; + $$self{SHIFTWAIT} = 0; +} + +# Begin a block for a particular translator. Setting VERBATIM triggers +# special handling in textblock(). +sub cmd_begin { + my $self = shift; + local $_ = shift; + my ($kind) = /^(\S+)/ or return; + if ($kind eq 'man' || $kind eq 'roff') { + $$self{VERBATIM} = 1; + } else { + $$self{EXCLUDE} = 1; + } +} + +# End a block for a particular translator. We assume that all =begin/=end +# pairs are properly closed. +sub cmd_end { + my $self = shift; + $$self{EXCLUDE} = 0; + $$self{VERBATIM} = 0; +} + +# One paragraph for a particular translator. Ignore it unless it's intended +# for man or roff, in which case we output it verbatim. +sub cmd_for { + my $self = shift; + local $_ = shift; + return unless s/^(?:man|roff)\b[ \t]*\n?//; + $self->output ($_); +} + + +############################################################################## +# Escaping and fontification +############################################################################## + +# At this point, we'll have embedded font codes of the form \f(<font>[SE] +# where <font> is one of B, I, or F. Turn those into the right font start or +# end codes. The old pod2man didn't get B<someI<thing> else> right; after I<> +# it switched back to normal text rather than bold. We take care of this by +# using variables as a combined pointer to our current font sequence, and set +# each to the number of current nestings of start tags for that font. Use +# them as a vector to look up what font sequence to use. +# +# \fP changes to the previous font, but only one previous font is kept. We +# don't know what the outside level font is; normally it's R, but if we're +# inside a heading it could be something else. So arrange things so that the +# outside font is always the "previous" font and end with \fP instead of \fR. +# Idea from Zack Weinberg. +sub mapfonts { + my $self = shift; + local $_ = shift; + + my ($fixed, $bold, $italic) = (0, 0, 0); + my %magic = (F => \$fixed, B => \$bold, I => \$italic); + my $last = '\fR'; + s { \\f\((.)(.) } { + my $sequence = ''; + my $f; + if ($last ne '\fR') { $sequence = '\fP' } + ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; + $f = $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)}; + if ($f eq $last) { + ''; + } else { + if ($f ne '\fR') { $sequence .= $f } + $last = $f; + $sequence; + } + }gxe; + $_; +} + +# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU +# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather +# than R, presumably because \f(CW doesn't actually do a font change. To work +# around this, use a separate textmapfonts for text blocks where the default +# font is always R and only use the smart mapfonts for headings. +sub textmapfonts { + my $self = shift; + local $_ = shift; + + my ($fixed, $bold, $italic) = (0, 0, 0); + my %magic = (F => \$fixed, B => \$bold, I => \$italic); + s { \\f\((.)(.) } { + ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1; + $$self{FONTS}{($fixed && 1) . ($bold && 1) . ($italic && 1)}; + }gxe; + $_; +} + + +############################################################################## +# *roff-specific parsing and magic +############################################################################## + +# Called instead of parse_text, calls parse_text with the right flags. +sub parse { + my $self = shift; + $self->parse_text ({ -expand_seq => 'sequence', + -expand_ptree => 'collapse' }, @_); +} + +# Takes a parse tree, a flag saying whether or not to treat it as literal text +# (not call guesswork on it), and a flag saying whether or not to clean some +# things up for *roff, and returns the concatenation of all of the text +# strings in that parse tree. If the literal flag isn't true, guesswork() +# will be called on all plain scalars in the parse tree. Otherwise, if +# collapse is being called on a C<> code, $cleanup should be set to true and +# some additional cleanup will be done. Assumes that everything in the parse +# tree is either a scalar or a reference to a scalar. +sub collapse { + my ($self, $ptree, $literal, $cleanup) = @_; + + # If we're processing the NAME section, don't do normal guesswork. This + # is because NAME lines are often extracted by utilities like catman that + # require plain text and don't understand *roff markup. We still need to + # escape backslashes and hyphens for *roff (and catman expects \- instead + # of -). + if ($$self{IN_NAME}) { + $literal = 1; + $cleanup = 1; + } + + # Do the collapse of the parse tree as described above. + return join ('', map { + if (ref $_) { + join ('', @$_); + } elsif ($literal) { + if ($cleanup) { + s/\\/\\e/g; + s/-/\\-/g; + s/__/_\\|_/g; + } + $_; + } else { + $self->guesswork ($_); + } + } $ptree->children); +} + +# Takes a text block to perform guesswork on; this is guaranteed not to +# contain any formatting codes. Returns the text block with remapping done. +sub guesswork { + my $self = shift; + local $_ = shift; + + # rofficate backslashes. + s/\\/\\e/g; + + # Ensure double underbars have a tiny space between them. + s/__/_\\|_/g; + + # Leave hyphens only if they're part of regular words and there is only + # one dash at a time. Leave a dash after the first character as a regular + # non-breaking dash, but don't let it mark the rest of the word invalid + # for hyphenation. + s/-/\\-/g; + s{ + ( (?:\G|^|\s) [a-zA-Z] ) ( \\- )? + ( (?: [a-zA-Z]+ \\-)+ ) + ( [a-zA-Z]+ ) (?=\s|\Z) + \b + } { + my ($prefix, $hyphen, $main, $suffix) = ($1, $2, $3, $4); + $hyphen ||= ''; + $main =~ s/\\-/-/g; + $prefix . $hyphen . $main . $suffix; + }egx; + + # Translate -- into a real em dash if it's used like one. + s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx; + s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx; + + # Make all caps a little smaller. Be careful here, since we don't want to + # make @ARGV into small caps, nor do we want to fix the MIME in + # MIME-Version, since it looks weird with the full-height V. + s{ + ( ^ | [\s\(\"\'\`\[\{<>] ) + ( [A-Z] [A-Z] (?: [/A-Z+:\d_\$&] | \\- )* ) + (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | $ ) + } { $1 . '\s-1' . $2 . '\s0' }egx; + + # Italize functions in the form func(). + s{ + ( \b | \\s-1 ) + ( + [A-Za-z_] ([:\w]|\\s-?[01])+ \(\) + ) + } { $1 . '\f(IS' . $2 . '\f(IE' }egx; + + # func(n) is a reference to a manual page. Make it \fIfunc\fR\|(n). + s{ + ( \b | \\s-1 ) + ( [A-Za-z_] (?:[.:\w]|\\-|\\s-?[01])+ ) + ( + \( \d [a-z]* \) + ) + } { $1 . '\f(IS' . $2 . '\f(IE\|' . $3 }egx; + + # Convert simple Perl variable references to a fixed-width font. + s{ + ( \s+ ) + ( [\$\@%] [\w:]+ ) + (?! \( ) + } { $1 . '\f(FS' . $2 . '\f(FE'}egx; + + # Fix up double quotes. + s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx; + + # Make C++ into \*(C+, which is a squinched version. + s{ \b C\+\+ } {\\*\(C+}gx; + + # All done. + $_; +} + +# Handles C<> text, deciding whether to put \*C` around it or not. This is a +# whole bunch of messy heuristics to try to avoid overquoting, originally from +# Barrie Slaymaker. This largely duplicates similar code in Pod::Text. +sub quote_literal { + my $self = shift; + local $_ = shift; + + # A regex that matches the portion of a variable reference that's the + # array or hash index, separated out just because we want to use it in + # several places in the following regex. + my $index = '(?: \[.*\] | \{.*\} )?'; + + # Check for things that we don't want to quote, and if we find any of + # them, return the string with just a font change and no quoting. + m{ + ^\s* + (?: + ( [\'\`\"] ) .* \1 # already quoted + | \` .* \' # `quoted' + | \$+ [\#^]? \S $index # special ($^Foo, $") + | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func + | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call + | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number + | 0x [a-fA-F\d]+ # a hex constant + ) + \s*\z + }xo && return '\f(FS' . $_ . '\f(FE'; + + # If we didn't return, go ahead and quote the text. + return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE"; +} + + +############################################################################## +# Output formatting +############################################################################## + +# Make vertical whitespace. +sub makespace { + my $self = shift; + $self->output (".PD\n") if ($$self{ITEMS} > 1); + $$self{ITEMS} = 0; + $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n") + if $$self{NEEDSPACE}; +} + +# Output any pending index entries, and optionally an index entry given as an +# argument. Support multiple index entries in X<> separated by slashes, and +# strip special escapes from index entries. +sub outindex { + my ($self, $section, $index) = @_; + my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} }; + return unless ($section || @entries); + $$self{INDEX} = []; + my @output; + if (@entries) { + push (@output, [ 'Xref', join (' ', @entries) ]); + } + if ($section) { + $index =~ s/\\-/-/g; + $index =~ s/\\(?:s-?\d|.\(..|.)//g; + push (@output, [ $section, $index ]); + } + for (@output) { + my ($type, $entry) = @$_; + $entry =~ s/\"/\"\"/g; + $entry =~ s/\\/\\e/g; + $self->output (".IX $type " . '"' . $entry . '"' . "\n"); + } +} + +# Output text to the output device. +sub output { print { $_[0]->output_handle } $_[1] } + +# Given a command and a single argument that may or may not contain double +# quotes, handle double-quote formatting for it. If there are no double +# quotes, just return the command followed by the argument in double quotes. +# If there are double quotes, use an if statement to test for nroff, and for +# nroff output the command followed by the argument in double quotes with +# embedded double quotes doubled. For other formatters, remap paired double +# quotes to LQUOTE and RQUOTE. +sub switchquotes { + my $self = shift; + my $command = shift; + local $_ = shift; + my $extra = shift; + s/\\\*\([LR]\"/\"/g; + + # We also have to deal with \*C` and \*C', which are used to add the + # quotes around C<> text, since they may expand to " and if they do this + # confuses the .SH macros and the like no end. Expand them ourselves. + # Also separate troff from nroff if there are any fixed-width fonts in use + # to work around problems with Solaris nroff. + my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/); + my $fixedpat = join ('|', @{ $$self{FONTS} }{'100', '101', '110', '111'}); + $fixedpat =~ s/\\/\\\\/g; + $fixedpat =~ s/\(/\\\(/g; + if (/\"/ || /$fixedpat/) { + s/\"/\"\"/g; + my $nroff = $_; + my $troff = $_; + $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g; + if ($c_is_quote && /\\\*\(C[\'\`]/) { + $nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g; + $nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g; + $troff =~ s/\\\*\(C[\'\`]//g; + } + $nroff = qq("$nroff") . ($extra ? " $extra" : ''); + $troff = qq("$troff") . ($extra ? " $extra" : ''); + + # Work around the Solaris nroff bug where \f(CW\fP leaves the font set + # to Roman rather than the actual previous font when used in headings. + # troff output may still be broken, but at least we can fix nroff by + # just switching the font changes to the non-fixed versions. + $nroff =~ s/\Q$$self{FONTS}{100}\E(.*)\\f[PR]/$1/g; + $nroff =~ s/\Q$$self{FONTS}{101}\E(.*)\\f([PR])/\\fI$1\\f$2/g; + $nroff =~ s/\Q$$self{FONTS}{110}\E(.*)\\f([PR])/\\fB$1\\f$2/g; + $nroff =~ s/\Q$$self{FONTS}{111}\E(.*)\\f([PR])/\\f\(BI$1\\f$2/g; + + # Now finally output the command. Only bother with .ie if the nroff + # and troff output isn't the same. + if ($nroff ne $troff) { + return ".ie n $command $nroff\n.el $command $troff\n"; + } else { + return "$command $nroff\n"; + } + } else { + $_ = qq("$_") . ($extra ? " $extra" : ''); + return "$command $_\n"; + } +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +Pod::Man - Convert POD data to formatted *roff input + +=head1 SYNOPSIS + + use Pod::Man; + my $parser = Pod::Man->new (release => $VERSION, section => 8); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_from_filehandle; + + # Read POD from file.pod and write to file.1. + $parser->parse_from_file ('file.pod', 'file.1'); + +=head1 DESCRIPTION + +Pod::Man is a module to convert documentation in the POD format (the +preferred language for documenting Perl) into *roff input using the man +macro set. The resulting *roff code is suitable for display on a terminal +using L<nroff(1)>, normally via L<man(1)>, or printing using L<troff(1)>. +It is conventionally invoked using the driver script B<pod2man>, but it can +also be used directly. + +As a derived class from Pod::Parser, Pod::Man supports the same methods and +interfaces. See L<Pod::Parser> for all the details; briefly, one creates a +new parser with C<< Pod::Man->new() >> and then calls either +parse_from_filehandle() or parse_from_file(). + +new() can take options, in the form of key/value pairs that control the +behavior of the parser. See below for details. + +If no options are given, Pod::Man uses the name of the input file with any +trailing C<.pod>, C<.pm>, or C<.pl> stripped as the man page title, to +section 1 unless the file ended in C<.pm> in which case it defaults to +section 3, to a centered title of "User Contributed Perl Documentation", to +a centered footer of the Perl version it is run with, and to a left-hand +footer of the modification date of its input (or the current date if given +STDIN for input). + +Pod::Man assumes that your *roff formatters have a fixed-width font named +CW. If yours is called something else (like CR), use the C<fixed> option to +specify it. This generally only matters for troff output for printing. +Similarly, you can set the fonts used for bold, italic, and bold italic +fixed-width output. + +Besides the obvious pod conversions, Pod::Man also takes care of formatting +func(), func(3), and simple variable references like $foo or @bar so you +don't have to use code escapes for them; complex expressions like +C<$fred{'stuff'}> will still need to be escaped, though. It also translates +dashes that aren't used as hyphens into en dashes, makes long dashes--like +this--into proper em dashes, fixes "paired quotes," makes C++ look right, +puts a little space between double underbars, makes ALLCAPS a teeny bit +smaller in B<troff>, and escapes stuff that *roff treats as special so that +you don't have to. + +The recognized options to new() are as follows. All options take a single +argument. + +=over 4 + +=item center + +Sets the centered page header to use instead of "User Contributed Perl +Documentation". + +=item date + +Sets the left-hand footer. By default, the modification date of the input +file will be used, or the current date if stat() can't find that file (the +case if the input is from STDIN), and the date will be formatted as +YYYY-MM-DD. + +=item fixed + +The fixed-width font to use for vertabim text and code. Defaults to CW. +Some systems may want CR instead. Only matters for B<troff> output. + +=item fixedbold + +Bold version of the fixed-width font. Defaults to CB. Only matters for +B<troff> output. + +=item fixeditalic + +Italic version of the fixed-width font (actually, something of a misnomer, +since most fixed-width fonts only have an oblique version, not an italic +version). Defaults to CI. Only matters for B<troff> output. + +=item fixedbolditalic + +Bold italic (probably actually oblique) version of the fixed-width font. +Pod::Man doesn't assume you have this, and defaults to CB. Some systems +(such as Solaris) have this font available as CX. Only matters for B<troff> +output. + +=item name + +Set the name of the manual page. Without this option, the manual name is +set to the uppercased base name of the file being converted unless the +manual section is 3, in which case the path is parsed to see if it is a Perl +module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted into +a name like C<Pod::Man>. This option, if given, overrides any automatic +determination of the name. + +=item quotes + +Sets the quote marks used to surround CE<lt>> text. If the value is a +single character, it is used as both the left and right quote; if it is two +characters, the first character is used as the left quote and the second as +the right quoted; and if it is four characters, the first two are used as +the left quote and the second two as the right quote. + +This may also be set to the special value C<none>, in which case no quote +marks are added around CE<lt>> text (but the font is still changed for troff +output). + +=item release + +Set the centered footer. By default, this is the version of Perl you run +Pod::Man under. Note that some system an macro sets assume that the +centered footer will be a modification date and will prepend something like +"Last modified: "; if this is the case, you may want to set C<release> to +the last modified date and C<date> to the version number. + +=item section + +Set the section for the C<.TH> macro. The standard section numbering +convention is to use 1 for user commands, 2 for system calls, 3 for +functions, 4 for devices, 5 for file formats, 6 for games, 7 for +miscellaneous information, and 8 for administrator commands. There is a lot +of variation here, however; some systems (like Solaris) use 4 for file +formats, 5 for miscellaneous information, and 7 for devices. Still others +use 1m instead of 8, or some mix of both. About the only section numbers +that are reliably consistent are 1, 2, and 3. + +By default, section 1 will be used unless the file ends in .pm in which case +section 3 will be selected. + +=back + +The standard Pod::Parser method parse_from_filehandle() takes up to two +arguments, the first being the file handle to read POD from and the second +being the file handle to write the formatted output to. The first defaults +to STDIN if not given, and the second defaults to STDOUT. The method +parse_from_file() is almost identical, except that its two arguments are the +input and output disk files instead. See L<Pod::Parser> for the specific +details. + +=head1 DIAGNOSTICS + +=over 4 + +=item roff font should be 1 or 2 chars, not "%s" + +(F) You specified a *roff font (using C<fixed>, C<fixedbold>, etc.) that +wasn't either one or two characters. Pod::Man doesn't support *roff fonts +longer than two characters, although some *roff extensions do (the canonical +versions of B<nroff> and B<troff> don't either). + +=item Invalid link %s + +(W) The POD source contained a C<LE<lt>E<gt>> formatting code that +Pod::Man was unable to parse. You should never see this error message; it +probably indicates a bug in Pod::Man. + +=item Invalid quote specification "%s" + +(F) The quote specification given (the quotes option to the constructor) was +invalid. A quote specification must be one, two, or four characters long. + +=item %s:%d: Unknown command paragraph "%s". + +(W) The POD source contained a non-standard command paragraph (something of +the form C<=command args>) that Pod::Man didn't know about. It was ignored. + +=item %s:%d: Unknown escape EE<lt>%sE<gt> + +(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::Man didn't +know about. C<EE<lt>%sE<gt>> was printed verbatim in the output. + +=item %s:%d: Unknown formatting code %s + +(W) The POD source contained a non-standard formatting code (something of +the form C<XE<lt>E<gt>>) that Pod::Man didn't know about. It was ignored. + +=item %s:%d: Unmatched =back + +(W) Pod::Man encountered a C<=back> command that didn't correspond to an +C<=over> command. + +=back + +=head1 BUGS + +Eight-bit input data isn't handled at all well at present. The correct +approach would be to map EE<lt>E<gt> escapes to the appropriate UTF-8 +characters and then do a translation pass on the output according to the +user-specified output character set. Unfortunately, we can't send eight-bit +data directly to the output unless the user says this is okay, since some +vendor *roff implementations can't handle eight-bit data. If the *roff +implementation can, however, that's far superior to the current hacked +characters that only work under troff. + +There is currently no way to turn off the guesswork that tries to format +unmarked text appropriately, and sometimes it isn't wanted (particularly +when using POD to document something other than Perl). + +The NAME section should be recognized specially and index entries emitted +for everything in that section. This would have to be deferred until the +next section, since extraneous things in NAME tends to confuse various man +page processors. + +Pod::Man doesn't handle font names longer than two characters. Neither do +most B<troff> implementations, but GNU troff does as an extension. It would +be nice to support as an option for those who want to use it. + +The preamble added to each output file is rather verbose, and most of it is +only necessary in the presence of EE<lt>E<gt> escapes for non-ASCII +characters. It would ideally be nice if all of those definitions were only +output if needed, perhaps on the fly as the characters are used. + +Pod::Man is excessively slow. + +=head1 CAVEATS + +The handling of hyphens and em dashes is somewhat fragile, and one may get +the wrong one under some circumstances. This should only matter for +B<troff> output. + +When and whether to use small caps is somewhat tricky, and Pod::Man doesn't +necessarily get it right. + +=head1 SEE ALSO + +L<Pod::Parser>, L<perlpod(1)>, L<pod2man(1)>, L<nroff(1)>, L<troff(1)>, +L<man(1)>, L<man(7)> + +Ossanna, Joseph F., and Brian W. Kernighan. "Troff User's Manual," +Computing Science Technical Report No. 54, AT&T Bell Laboratories. This is +the best documentation of standard B<nroff> and B<troff>. At the time of +this writing, it's available at +L<http://www.cs.bell-labs.com/cm/cs/cstr.html>. + +The man page documenting the man macro set may be L<man(5)> instead of +L<man(7)> on your system. Also, please see L<pod2man(1)> for extensive +documentation on writing manual pages if you've not done it before and +aren't familiar with the conventions. + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original +B<pod2man> by Tom Christiansen <tchrist@mox.perl.com>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 1999, 2000, 2001, 2002, 2003 by Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Pod/ParseUtils.pm b/Master/tlpkg/installer/perllib/Pod/ParseUtils.pm new file mode 100644 index 00000000000..878860121d3 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/ParseUtils.pm @@ -0,0 +1,852 @@ +############################################################################# +# Pod/ParseUtils.pm -- helpers for POD parsing and conversion +# +# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::ParseUtils; + +use vars qw($VERSION); +$VERSION = 1.33; ## Current version of this package +require 5.005; ## requires this Perl version or later + +=head1 NAME + +Pod::ParseUtils - helpers for POD parsing and conversion + +=head1 SYNOPSIS + + use Pod::ParseUtils; + + my $list = new Pod::List; + my $link = Pod::Hyperlink->new('Pod::Parser'); + +=head1 DESCRIPTION + +B<Pod::ParseUtils> contains a few object-oriented helper packages for +POD parsing and processing (i.e. in POD formatters and translators). + +=cut + +#----------------------------------------------------------------------------- +# Pod::List +# +# class to hold POD list info (=over, =item, =back) +#----------------------------------------------------------------------------- + +package Pod::List; + +use Carp; + +=head2 Pod::List + +B<Pod::List> can be used to hold information about POD lists +(written as =over ... =item ... =back) for further processing. +The following methods are available: + +=over 4 + +=item Pod::List-E<gt>new() + +Create a new list object. Properties may be specified through a hash +reference like this: + + my $list = Pod::List->new({ -start => $., -indent => 4 }); + +See the individual methods/properties for details. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->{-file} ||= 'unknown'; + $self->{-start} ||= 'unknown'; + $self->{-indent} ||= 4; # perlpod: "should be the default" + $self->{_items} = []; + $self->{-type} ||= ''; +} + +=item $list-E<gt>file() + +Without argument, retrieves the file name the list is in. This must +have been set before by either specifying B<-file> in the B<new()> +method or by calling the B<file()> method with a scalar argument. + +=cut + +# The POD file name the list appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item $list-E<gt>start() + +Without argument, retrieves the line number where the list started. +This must have been set before by either specifying B<-start> in the +B<new()> method or by calling the B<start()> method with a scalar +argument. + +=cut + +# The line in the file the node appears +sub start { + return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; +} + +=item $list-E<gt>indent() + +Without argument, retrieves the indent level of the list as specified +in C<=over n>. This must have been set before by either specifying +B<-indent> in the B<new()> method or by calling the B<indent()> method +with a scalar argument. + +=cut + +# indent level +sub indent { + return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; +} + +=item $list-E<gt>type() + +Without argument, retrieves the list type, which can be an arbitrary value, +e.g. C<OL>, C<UL>, ... when thinking the HTML way. +This must have been set before by either specifying +B<-type> in the B<new()> method or by calling the B<type()> method +with a scalar argument. + +=cut + +# The type of the list (UL, OL, ...) +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item $list-E<gt>rx() + +Without argument, retrieves a regular expression for simplifying the +individual item strings once the list type has been determined. Usage: +E.g. when converting to HTML, one might strip the leading number in +an ordered list as C<E<lt>OLE<gt>> already prints numbers itself. +This must have been set before by either specifying +B<-rx> in the B<new()> method or by calling the B<rx()> method +with a scalar argument. + +=cut + +# The regular expression to simplify the items +sub rx { + return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; +} + +=item $list-E<gt>item() + +Without argument, retrieves the array of the items in this list. +The items may be represented by any scalar. +If an argument has been given, it is pushed on the list of items. + +=cut + +# The individual =items of this list +sub item { + my ($self,$item) = @_; + if(defined $item) { + push(@{$self->{_items}}, $item); + return $item; + } + else { + return @{$self->{_items}}; + } +} + +=item $list-E<gt>parent() + +Without argument, retrieves information about the parent holding this +list, which is represented as an arbitrary scalar. +This must have been set before by either specifying +B<-parent> in the B<new()> method or by calling the B<parent()> method +with a scalar argument. + +=cut + +# possibility for parsers/translators to store information about the +# lists's parent object +sub parent { + return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent}; +} + +=item $list-E<gt>tag() + +Without argument, retrieves information about the list tag, which can be +any scalar. +This must have been set before by either specifying +B<-tag> in the B<new()> method or by calling the B<tag()> method +with a scalar argument. + +=back + +=cut + +# possibility for parsers/translators to store information about the +# list's object +sub tag { + return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag}; +} + +#----------------------------------------------------------------------------- +# Pod::Hyperlink +# +# class to manipulate POD hyperlinks (L<>) +#----------------------------------------------------------------------------- + +package Pod::Hyperlink; + +=head2 Pod::Hyperlink + +B<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage: + + my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); + +The B<Pod::Hyperlink> class is mainly designed to parse the contents of the +C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the +different parts of a POD hyperlink for further processing. It can also be +used to construct hyperlinks. + +=over 4 + +=item Pod::Hyperlink-E<gt>new() + +The B<new()> method can either be passed a set of key/value pairs or a single +scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object +of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a +failure, the error message is stored in C<$@>. + +=cut + +use Carp; + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = +{}; + bless $self, $class; + $self->initialize(); + if(defined $_[0]) { + if(ref($_[0])) { + # called with a list of parameters + %$self = %{$_[0]}; + $self->_construct_text(); + } + else { + # called with L<> contents + return undef unless($self->parse($_[0])); + } + } + return $self; +} + +sub initialize { + my $self = shift; + $self->{-line} ||= 'undef'; + $self->{-file} ||= 'undef'; + $self->{-page} ||= ''; + $self->{-node} ||= ''; + $self->{-alttext} ||= ''; + $self->{-type} ||= 'undef'; + $self->{_warnings} = []; +} + +=item $link-E<gt>parse($string) + +This method can be used to (re)parse a (new) hyperlink, i.e. the contents +of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object. +Warnings are stored in the B<warnings> property. +E.g. sections like C<LE<lt>open(2)E<gt>> are deprecated, as they do not point +to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> is wrong as well, the manpage +section can simply be dropped. + +=cut + +sub parse { + my $self = shift; + local($_) = $_[0]; + # syntax check the link and extract destination + my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0); + + $self->{_warnings} = []; + + # collapse newlines with whitespace + s/\s*\n+\s*/ /g; + + # strip leading/trailing whitespace + if(s/^[\s\n]+//) { + $self->warning("ignoring leading whitespace in link"); + } + if(s/[\s\n]+$//) { + $self->warning("ignoring trailing whitespace in link"); + } + unless(length($_)) { + _invalid_link("empty link"); + return undef; + } + + ## Check for different possibilities. This is tedious and error-prone + # we match all possibilities (alttext, page, section/item) + #warn "DEBUG: link=$_\n"; + + # only page + # problem: a lot of people use (), or (1) or the like to indicate + # man page sections. But this collides with L<func()> that is supposed + # to point to an internal funtion... + my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)'; + # page name only + if(m!^($page_rx)$!o) { + $page = $1; + $type = 'page'; + } + # alttext, page and "section" + elsif(m!^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$!o) { + ($alttext, $page, $node) = ($1, $2, $3); + $type = 'section'; + $quoted = 1; #... therefore | and / are allowed + } + # alttext and page + elsif(m!^(.*?)\s*[|]\s*($page_rx)$!o) { + ($alttext, $page) = ($1, $2); + $type = 'page'; + } + # alttext and "section" + elsif(m!^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$!) { + ($alttext, $node) = ($1,$2); + $type = 'section'; + $quoted = 1; + } + # page and "section" + elsif(m!^($page_rx)\s*/\s*"(.+)"$!o) { + ($page, $node) = ($1, $2); + $type = 'section'; + $quoted = 1; + } + # page and item + elsif(m!^($page_rx)\s*/\s*(.+)$!o) { + ($page, $node) = ($1, $2); + $type = 'item'; + } + # only "section" + elsif(m!^/?"(.+)"$!) { + $node = $1; + $type = 'section'; + $quoted = 1; + } + # only item + elsif(m!^\s*/(.+)$!) { + $node = $1; + $type = 'item'; + } + # non-standard: Hyperlink + elsif(m!^(\w+:[^:\s]\S*)$!i) { + $node = $1; + $type = 'hyperlink'; + } + # alttext, page and item + elsif(m!^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$!o) { + ($alttext, $page, $node) = ($1, $2, $3); + $type = 'item'; + } + # alttext and item + elsif(m!^(.*?)\s*[|]\s*/(.+)$!) { + ($alttext, $node) = ($1,$2); + } + # nonstandard: alttext and hyperlink + elsif(m!^(.*?)\s*[|]\s*(\w+:[^:\s]\S*)$!) { + ($alttext, $node) = ($1,$2); + $type = 'hyperlink'; + } + # must be an item or a "malformed" section (without "") + else { + $node = $_; + $type = 'item'; + } + # collapse whitespace in nodes + $node =~ s/\s+/ /gs; + + # empty alternative text expands to node name + if(defined $alttext) { + if(!length($alttext)) { + $alttext = $node | $page; + } + } + else { + $alttext = ''; + } + + if($page =~ /[(]\w*[)]$/) { + $self->warning("(section) in '$page' deprecated"); + } + if(!$quoted && $node =~ m:[|/]: && $type ne 'hyperlink') { + $self->warning("node '$node' contains non-escaped | or /"); + } + if($alttext =~ m:[|/]:) { + $self->warning("alternative text '$node' contains non-escaped | or /"); + } + $self->{-page} = $page; + $self->{-node} = $node; + $self->{-alttext} = $alttext; + #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n"; + $self->{-type} = $type; + $self->_construct_text(); + 1; +} + +sub _construct_text { + my $self = shift; + my $alttext = $self->alttext(); + my $type = $self->type(); + my $section = $self->node(); + my $page = $self->page(); + my $page_ext = ''; + $page =~ s/([(]\w*[)])$// && ($page_ext = $1); + if($alttext) { + $self->{_text} = $alttext; + } + elsif($type eq 'hyperlink') { + $self->{_text} = $section; + } + else { + $self->{_text} = ($section || '') . + (($page && $section) ? ' in ' : '') . + "$page$page_ext"; + } + # for being marked up later + # use the non-standard markers P<> and Q<>, so that the resulting + # text can be parsed by the translators. It's their job to put + # the correct hypertext around the linktext + if($alttext) { + $self->{_markup} = "Q<$alttext>"; + } + elsif($type eq 'hyperlink') { + $self->{_markup} = "Q<$section>"; + } + else { + $self->{_markup} = (!$section ? '' : "Q<$section>") . + ($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : ''); + } +} + +=item $link-E<gt>markup($string) + +Set/retrieve the textual value of the link. This string contains special +markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the +translator's interior sequence expansion engine to the +formatter-specific code to highlight/activate the hyperlink. The details +have to be implemented in the translator. + +=cut + +#' retrieve/set markuped text +sub markup { + return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup}; +} + +=item $link-E<gt>text() + +This method returns the textual representation of the hyperlink as above, +but without markers (read only). Depending on the link type this is one of +the following alternatives (the + and * denote the portions of the text +that are marked up): + + +perl+ L<perl> + *$|* in +perlvar+ L<perlvar/$|> + *OPTIONS* in +perldoc+ L<perldoc/"OPTIONS"> + *DESCRIPTION* L<"DESCRIPTION"> + +=cut + +# The complete link's text +sub text { + $_[0]->{_text}; +} + +=item $link-E<gt>warning() + +After parsing, this method returns any warnings encountered during the +parsing process. + +=cut + +# Set/retrieve warnings +sub warning { + my $self = shift; + if(@_) { + push(@{$self->{_warnings}}, @_); + return @_; + } + return @{$self->{_warnings}}; +} + +=item $link-E<gt>file() + +=item $link-E<gt>line() + +Just simple slots for storing information about the line and the file +the link was encountered in. Has to be filled in manually. + +=cut + +# The line in the file the link appears +sub line { + return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; +} + +# The POD file name the link appears in +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item $link-E<gt>page() + +This method sets or returns the POD page this link points to. + +=cut + +# The POD page the link appears on +sub page { + if (@_ > 1) { + $_[0]->{-page} = $_[1]; + $_[0]->_construct_text(); + } + $_[0]->{-page}; +} + +=item $link-E<gt>node() + +As above, but the destination node text of the link. + +=cut + +# The link destination +sub node { + if (@_ > 1) { + $_[0]->{-node} = $_[1]; + $_[0]->_construct_text(); + } + $_[0]->{-node}; +} + +=item $link-E<gt>alttext() + +Sets or returns an alternative text specified in the link. + +=cut + +# Potential alternative text +sub alttext { + if (@_ > 1) { + $_[0]->{-alttext} = $_[1]; + $_[0]->_construct_text(); + } + $_[0]->{-alttext}; +} + +=item $link-E<gt>type() + +The node type, either C<section> or C<item>. As an unofficial type, +there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>> + +=cut + +# The type: item or headn +sub type { + return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; +} + +=item $link-E<gt>link() + +Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>. + +=back + +=cut + +# The link itself +sub link { + my $self = shift; + my $link = $self->page() || ''; + if($self->node()) { + my $node = $self->node(); + $text =~ s/\|/E<verbar>/g; + $text =~ s:/:E<sol>:g; + if($self->type() eq 'section') { + $link .= ($link ? '/' : '') . '"' . $node . '"'; + } + elsif($self->type() eq 'hyperlink') { + $link = $self->node(); + } + else { # item + $link .= '/' . $node; + } + } + if($self->alttext()) { + my $text = $self->alttext(); + $text =~ s/\|/E<verbar>/g; + $text =~ s:/:E<sol>:g; + $link = "$text|$link"; + } + $link; +} + +sub _invalid_link { + my ($msg) = @_; + # this sets @_ + #eval { die "$msg\n" }; + #chomp $@; + $@ = $msg; # this seems to work, too! + undef; +} + +#----------------------------------------------------------------------------- +# Pod::Cache +# +# class to hold POD page details +#----------------------------------------------------------------------------- + +package Pod::Cache; + +=head2 Pod::Cache + +B<Pod::Cache> holds information about a set of POD documents, +especially the nodes for hyperlinks. +The following methods are available: + +=over 4 + +=item Pod::Cache-E<gt>new() + +Create a new cache object. This object can hold an arbitrary number of +POD documents of class Pod::Cache::Item. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my $self = []; + bless $self, $class; + return $self; +} + +=item $cache-E<gt>item() + +Add a new item to the cache. Without arguments, this method returns a +list of all cache elements. + +=cut + +sub item { + my ($self,%param) = @_; + if(%param) { + my $item = Pod::Cache::Item->new(%param); + push(@$self, $item); + return $item; + } + else { + return @{$self}; + } +} + +=item $cache-E<gt>find_page($name) + +Look for a POD document named C<$name> in the cache. Returns the +reference to the corresponding Pod::Cache::Item object or undef if +not found. + +=back + +=cut + +sub find_page { + my ($self,$page) = @_; + foreach(@$self) { + if($_->page() eq $page) { + return $_; + } + } + undef; +} + +package Pod::Cache::Item; + +=head2 Pod::Cache::Item + +B<Pod::Cache::Item> holds information about individual POD documents, +that can be grouped in a Pod::Cache object. +It is intended to hold information about the hyperlink nodes of POD +documents. +The following methods are available: + +=over 4 + +=item Pod::Cache::Item-E<gt>new() + +Create a new object. + +=cut + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + $self->initialize(); + return $self; +} + +sub initialize { + my $self = shift; + $self->{-nodes} = [] unless(defined $self->{-nodes}); +} + +=item $cacheitem-E<gt>page() + +Set/retrieve the POD document name (e.g. "Pod::Parser"). + +=cut + +# The POD page +sub page { + return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; +} + +=item $cacheitem-E<gt>description() + +Set/retrieve the POD short description as found in the C<=head1 NAME> +section. + +=cut + +# The POD description, taken out of NAME if present +sub description { + return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description}; +} + +=item $cacheitem-E<gt>path() + +Set/retrieve the POD file storage path. + +=cut + +# The file path +sub path { + return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; +} + +=item $cacheitem-E<gt>file() + +Set/retrieve the POD file name. + +=cut + +# The POD file name +sub file { + return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; +} + +=item $cacheitem-E<gt>nodes() + +Add a node (or a list of nodes) to the document's node list. Note that +the order is kept, i.e. start with the first node and end with the last. +If no argument is given, the current list of nodes is returned in the +same order the nodes have been added. +A node can be any scalar, but usually is a pair of node string and +unique id for the C<find_node> method to work correctly. + +=cut + +# The POD nodes +sub nodes { + my ($self,@nodes) = @_; + if(@nodes) { + push(@{$self->{-nodes}}, @nodes); + return @nodes; + } + else { + return @{$self->{-nodes}}; + } +} + +=item $cacheitem-E<gt>find_node($name) + +Look for a node or index entry named C<$name> in the object. +Returns the unique id of the node (i.e. the second element of the array +stored in the node arry) or undef if not found. + +=cut + +sub find_node { + my ($self,$node) = @_; + my @search; + push(@search, @{$self->{-nodes}}) if($self->{-nodes}); + push(@search, @{$self->{-idx}}) if($self->{-idx}); + foreach(@search) { + if($_->[0] eq $node) { + return $_->[1]; # id + } + } + undef; +} + +=item $cacheitem-E<gt>idx() + +Add an index entry (or a list of them) to the document's index list. Note that +the order is kept, i.e. start with the first node and end with the last. +If no argument is given, the current list of index entries is returned in the +same order the entries have been added. +An index entry can be any scalar, but usually is a pair of string and +unique id. + +=back + +=cut + +# The POD index entries +sub idx { + my ($self,@idx) = @_; + if(@idx) { + push(@{$self->{-idx}}, @idx); + return @idx; + } + else { + return @{$self->{-idx}}; + } +} + +=head1 AUTHOR + +Please report bugs using L<http://rt.cpan.org>. + +Marek Rouchal E<lt>marekr@cpan.orgE<gt>, borrowing +a lot of things from L<pod2man> and L<pod2roff> as well as other POD +processing tools by Tom Christiansen, Brad Appleton and Russ Allbery. + +=head1 SEE ALSO + +L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>, +L<pod2html> + +=cut + +1; diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc.pm new file mode 100644 index 00000000000..8f9614838fb --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc.pm @@ -0,0 +1,1762 @@ + +require 5; +use 5.006; # we use some open(X, "<", $y) syntax +package Pod::Perldoc; +use strict; +use warnings; +use Config '%Config'; + +use Fcntl; # for sysopen +use File::Spec::Functions qw(catfile catdir splitdir); + +use vars qw($VERSION @Pagers $Bindir $Pod2man + $Temp_Files_Created $Temp_File_Lifetime +); +$VERSION = '3.14'; +#.......................................................................... + +BEGIN { # Make a DEBUG constant very first thing... + unless(defined &DEBUG) { + if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint + eval("sub DEBUG () {$1}"); + die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@; + } else { + *DEBUG = sub () {0}; + } + } +} + +use Pod::Perldoc::GetOptsOO; # uses the DEBUG. + +#.......................................................................... + +sub TRUE () {1} +sub FALSE () {return} + +BEGIN { + *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS; + *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32; + *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos; + *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2; + *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin; + *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux; + *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX; +} + +$Temp_File_Lifetime ||= 60 * 60 * 24 * 5; + # If it's older than five days, it's quite unlikely + # that anyone's still looking at it!! + # (Currently used only by the MSWin cleanup routine) + + +#.......................................................................... +{ my $pager = $Config{'pager'}; + push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS; +} +$Bindir = $Config{'scriptdirexp'}; +$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); + +# End of class-init stuff +# +########################################################################### +# +# Option accessors... + +foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdU}) { + no strict 'refs'; + *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; +} + +# And these are so that GetOptsOO knows they take options: +sub opt_f_with { shift->_elem('opt_f', @_) } +sub opt_q_with { shift->_elem('opt_q', @_) } +sub opt_d_with { shift->_elem('opt_d', @_) } + +sub opt_w_with { # Specify an option for the formatter subclass + my($self, $value) = @_; + if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) { + my $option = $1; + my $option_value = defined($2) ? $2 : "TRUE"; + $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar" + $self->add_formatter_option( $option, $option_value ); + } else { + warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n"; + } + return; +} + +sub opt_M_with { # specify formatter class name(s) + my($self, $classes) = @_; + return unless defined $classes and length $classes; + DEBUG > 4 and print "Considering new formatter classes -M$classes\n"; + my @classes_to_add; + foreach my $classname (split m/[,;]+/s, $classes) { + next unless $classname =~ m/\S/; + if( $classname =~ m/^(\w+(::\w+)+)$/s ) { + # A mildly restrictive concept of what modulenames are valid. + push @classes_to_add, $1; # untaint + } else { + warn "\"$classname\" isn't a valid classname. Ignoring.\n"; + } + } + + unshift @{ $self->{'formatter_classes'} }, @classes_to_add; + + DEBUG > 3 and print( + "Adding @classes_to_add to the list of formatter classes, " + . "making them @{ $self->{'formatter_classes'} }.\n" + ); + + return; +} + +sub opt_V { # report version and exit + print join '', + "Perldoc v$VERSION, under perl v$] for $^O", + + (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) + ? (" (win32 build ", &Win32::BuildNumber(), ")") : (), + + (chr(65) eq 'A') ? () : " (non-ASCII)", + + "\n", + ; + exit; +} + +sub opt_t { # choose plaintext as output format + my $self = shift; + $self->opt_o_with('text') if @_ and $_[0]; + return $self->_elem('opt_t', @_); +} + +sub opt_u { # choose raw pod as output format + my $self = shift; + $self->opt_o_with('pod') if @_ and $_[0]; + return $self->_elem('opt_u', @_); +} + +sub opt_n_with { + # choose man as the output format, and specify the proggy to run + my $self = shift; + $self->opt_o_with('man') if @_ and $_[0]; + $self->_elem('opt_n', @_); +} + +sub opt_o_with { # "o" for output format + my($self, $rest) = @_; + return unless defined $rest and length $rest; + if($rest =~ m/^(\w+)$/s) { + $rest = $1; #untaint + } else { + warn "\"$rest\" isn't a valid output format. Skipping.\n"; + return; + } + + $self->aside("Noting \"$rest\" as desired output format...\n"); + + # Figure out what class(es) that could actually mean... + + my @classes; + foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") { + # Messy but smart: + foreach my $stem ( + $rest, # Yes, try it first with the given capitalization + "\L$rest", "\L\u$rest", "\U$rest" # And then try variations + + ) { + push @classes, $prefix . $stem; + #print "Considering $prefix$stem\n"; + } + + # Tidier, but misses too much: + #push @classes, $prefix . ucfirst(lc($rest)); + } + $self->opt_M_with( join ";", @classes ); + return; +} + +########################################################################### +# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % + +sub run { # to be called by the "perldoc" executable + my $class = shift; + if(DEBUG > 3) { + print "Parameters to $class\->run:\n"; + my @x = @_; + while(@x) { + $x[1] = '<undef>' unless defined $x[1]; + $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; + print " [$x[0]] => [$x[1]]\n"; + splice @x,0,2; + } + print "\n"; + } + return $class -> new(@_) -> process() || 0; +} + +# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % +########################################################################### + +sub new { # yeah, nothing fancy + my $class = shift; + my $new = bless {@_}, (ref($class) || $class); + DEBUG > 1 and print "New $class object $new\n"; + $new->init(); + $new; +} + +#.......................................................................... + +sub aside { # If we're in -v or DEBUG mode, say this. + my $self = shift; + if( DEBUG or $self->opt_v ) { + my $out = join( '', + DEBUG ? do { + my $callsub = (caller(1))[3]; + my $package = quotemeta(__PACKAGE__ . '::'); + $callsub =~ s/^$package/'/os; + # the o is justified, as $package really won't change. + $callsub . ": "; + } : '', + @_, + ); + if(DEBUG) { print $out } else { print STDERR $out } + } + return; +} + +#.......................................................................... + +sub usage { + my $self = shift; + warn "@_\n" if @_; + + # Erase evidence of previous errors (if any), so exit status is simple. + $! = 0; + + die <<EOF; +perldoc [options] PageName|ModuleName|ProgramName... +perldoc [options] -f BuiltinFunction +perldoc [options] -q FAQRegex + +Options: + -h Display this help message + -V report version + -r Recursive search (slow) + -i Ignore case + -t Display pod using pod2text instead of pod2man and nroff + (-t is the default on win32 unless -n is specified) + -u Display unformatted pod text + -m Display module's file in its entirety + -n Specify replacement for nroff + -l Display the module's file name + -F Arguments are file names, not modules + -v Verbosely describe what's going on + -T Send output to STDOUT without any pager + -d output_filename_to_send_to + -o output_format_name + -M FormatterModuleNameToUse + -w formatter_option:option_value + -X use index if present (looks for pod.idx at $Config{archlib}) + -q Search the text of questions (not answers) in perlfaq[1-9] + +PageName|ModuleName... + is the name of a piece of documentation that you want to look at. You + may either give a descriptive name of the page (as in the case of + `perlfunc') the name of a module, either like `Term::Info' or like + `Term/Info', or the name of a program, like `perldoc'. + +BuiltinFunction + is the name of a perl function. Will extract documentation from + `perlfunc'. + +FAQRegex + is a regex. Will search perlfaq[1-9] for and extract any + questions that match. + +Any switches in the PERLDOC environment variable will be used before the +command line arguments. The optional pod index file contains a list of +filenames, one per line. + [Perldoc v$VERSION] +EOF + +} + +#.......................................................................... + +sub usage_brief { + my $me = $0; # Editing $0 is unportable + + $me =~ s,.*[/\\],,; # get basename + + die <<"EOUSAGE"; +Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-F] [-X] PageName|ModuleName|ProgramName + $me -f PerlFunc + $me -q FAQKeywords + +The -h option prints more help. Also try "perldoc perldoc" to get +acquainted with the system. [Perldoc v$VERSION] +EOUSAGE + +} + +#.......................................................................... + +sub pagers { @{ shift->{'pagers'} } } + +#.......................................................................... + +sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_) + if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] } + else { return $_[0]{ $_[1] } } +} +#.......................................................................... +########################################################################### +# +# Init formatter switches, and start it off with __bindir and all that +# other stuff that ToMan.pm needs. +# + +sub init { + my $self = shift; + + # Make sure creat()s are neither too much nor too little + eval { umask(0077) }; # doubtless someone has no mask + + $self->{'args'} ||= \@ARGV; + $self->{'found'} ||= []; + $self->{'temp_file_list'} ||= []; + + + $self->{'target'} = undef; + + $self->init_formatter_class_list; + + $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; + $self->{'bindir' } = $Bindir unless exists $self->{'bindir'}; + $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'}; + + push @{ $self->{'formatter_switches'} = [] }, ( + # Yeah, we could use a hashref, but maybe there's some class where options + # have to be ordered; so we'll use an arrayref. + + [ '__bindir' => $self->{'bindir' } ], + [ '__pod2man' => $self->{'pod2man'} ], + ); + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + return; +} + +#.......................................................................... + +sub init_formatter_class_list { + my $self = shift; + $self->{'formatter_classes'} ||= []; + + # Remember, no switches have been read yet, when + # we've started this routine. + + $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru + $self->opt_o_with('text'); + $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos + || !($ENV{TERM} && ( + ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i + )); + + return; +} + +#.......................................................................... + +sub process { + # if this ever returns, its retval will be used for exit(RETVAL) + + my $self = shift; + DEBUG > 1 and print " Beginning process.\n"; + DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n"; + if(DEBUG > 3) { + print "Object contents:\n"; + my @x = %$self; + while(@x) { + $x[1] = '<undef>' unless defined $x[1]; + $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; + print " [$x[0]] => [$x[1]]\n"; + splice @x,0,2; + } + print "\n"; + } + + # TODO: make it deal with being invoked as various different things + # such as perlfaq". + + return $self->usage_brief unless @{ $self->{'args'} }; + $self->pagers_guessing; + $self->options_reading; + $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); + $self->drop_privs_maybe; + $self->options_processing; + + # Hm, we have @pages and @found, but we only really act on one + # file per call, with the exception of the opt_q hack, and with + # -l things + + $self->aside("\n"); + + my @pages; + $self->{'pages'} = \@pages; + if( $self->opt_f) { @pages = ("perlfunc") } + elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } + else { @pages = @{$self->{'args'}}; + # @pages = __FILE__ + # if @pages == 1 and $pages[0] eq 'perldoc'; + } + + return $self->usage_brief unless @pages; + + $self->find_good_formatter_class(); + $self->formatter_sanity_check(); + + $self->maybe_diddle_INC(); + # for when we're apparently in a module or extension directory + + my @found = $self->grand_search_init(\@pages); + exit (IS_VMS ? 98962 : 1) unless @found; + + if ($self->opt_l) { + DEBUG and print "We're in -l mode, so byebye after this:\n"; + print join("\n", @found), "\n"; + return; + } + + $self->tweak_found_pathnames(\@found); + $self->assert_closing_stdout; + return $self->page_module_file(@found) if $self->opt_m; + DEBUG > 2 and print "Found: [@found]\n"; + + return $self->render_and_page(\@found); +} + +#.......................................................................... +{ + +my( %class_seen, %class_loaded ); +sub find_good_formatter_class { + my $self = $_[0]; + my @class_list = @{ $self->{'formatter_classes'} || [] }; + die "WHAT? Nothing in the formatter class list!?" unless @class_list; + + my $good_class_found; + foreach my $c (@class_list) { + DEBUG > 4 and print "Trying to load $c...\n"; + if($class_loaded{$c}) { + DEBUG > 4 and print "OK, the already-loaded $c it is!\n"; + $good_class_found = $c; + last; + } + + if($class_seen{$c}) { + DEBUG > 4 and print + "I've tried $c before, and it's no good. Skipping.\n"; + next; + } + + $class_seen{$c} = 1; + + if( $c->can('parse_from_file') ) { + DEBUG > 4 and print + "Interesting, the formatter class $c is already loaded!\n"; + + } elsif( + (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2) + # the alway case-insensitive fs's + and $class_seen{lc("~$c")}++ + ) { + DEBUG > 4 and print + "We already used something quite like \"\L$c\E\", so no point using $c\n"; + # This avoids redefining the package. + } else { + DEBUG > 4 and print "Trying to eval 'require $c'...\n"; + + local $^W = $^W; + if(DEBUG() or $self->opt_v) { + # feh, let 'em see it + } else { + $^W = 0; + # The average user just has no reason to be seeing + # $^W-suppressable warnings from the the require! + } + + eval "require $c"; + if($@) { + DEBUG > 4 and print "Couldn't load $c: $!\n"; + next; + } + } + + if( $c->can('parse_from_file') ) { + DEBUG > 4 and print "Settling on $c\n"; + my $v = $c->VERSION; + $v = ( defined $v and length $v ) ? " version $v" : ''; + $self->aside("Formatter class $c$v successfully loaded!\n"); + $good_class_found = $c; + last; + } else { + DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n"; + } + } + + die "Can't find any loadable formatter class in @class_list?!\nAborting" + unless $good_class_found; + + $self->{'formatter_class'} = $good_class_found; + $self->aside("Will format with the class $good_class_found\n"); + + return; +} + +} +#.......................................................................... + +sub formatter_sanity_check { + my $self = shift; + my $formatter_class = $self->{'formatter_class'} + || die "NO FORMATTER CLASS YET!?"; + + if(!$self->opt_T # so -T can FORCE sending to STDOUT + and $formatter_class->can('is_pageable') + and !$formatter_class->is_pageable + and !$formatter_class->can('page_for_perldoc') + ) { + my $ext = + ($formatter_class->can('output_extension') + && $formatter_class->output_extension + ) || ''; + $ext = ".$ext" if length $ext; + + die + "When using Perldoc to format with $formatter_class, you have to\n" + . "specify -T or -dsomefile$ext\n" + . "See `perldoc perldoc' for more information on those switches.\n" + ; + } +} + +#.......................................................................... + +sub render_and_page { + my($self, $found_list) = @_; + + $self->maybe_generate_dynamic_pod($found_list); + + my($out, $formatter) = $self->render_findings($found_list); + + if($self->opt_d) { + printf "Perldoc (%s) output saved to %s\n", + $self->{'formatter_class'} || ref($self), + $out; + print "But notice that it's 0 bytes long!\n" unless -s $out; + + + } elsif( # Allow the formatter to "page" itself, if it wants. + $formatter->can('page_for_perldoc') + and do { + $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n"); + if( $formatter->page_for_perldoc($out, $self) ) { + $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n"); + 1; + } else { + $self->aside("page_for_perldoc returned false, so paging with $self instead.\n"); + ''; + } + } + ) { + # Do nothing, since the formatter has "paged" it for itself. + + } else { + # Page it normally (internally) + + if( -s $out ) { # Usual case: + $self->page($out, $self->{'output_to_stdout'}, $self->pagers); + + } else { + # Odd case: + $self->aside("Skipping $out (from $$found_list[0] " + . "via $$self{'formatter_class'}) as it is 0-length.\n"); + + push @{ $self->{'temp_file_list'} }, $out; + $self->unlink_if_temp_file($out); + } + } + + $self->after_rendering(); # any extra cleanup or whatever + + return; +} + +#.......................................................................... + +sub options_reading { + my $self = shift; + + if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) { + require Text::ParseWords; + $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n"); + # Yes, appends to the beginning + unshift @{ $self->{'args'} }, + Text::ParseWords::shellwords( $ENV{"PERLDOC"} ) + ; + DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n"; + } else { + DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n"; + } + + DEBUG > 1 + and print " Args right before switch processing: @{$self->{'args'}}\n"; + + Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' ) + or return $self->usage; + + DEBUG > 1 + and print " Args after switch processing: @{$self->{'args'}}\n"; + + return $self->usage if $self->opt_h; + + return; +} + +#.......................................................................... + +sub options_processing { + my $self = shift; + + if ($self->opt_X) { + my $podidx = "$Config{'archlib'}/pod.idx"; + $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; + $self->{'podidx'} = $podidx; + } + + $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT; + + $self->options_sanity; + + $self->opt_n("nroff") unless $self->opt_n; + $self->add_formatter_option( '__nroffer' => $self->opt_n ); + + return; +} + +#.......................................................................... + +sub options_sanity { + my $self = shift; + + # The opts-counting stuff interacts quite badly with + # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"} + # set to -t, and I specify -u on the command line, I don't want + # to be hectored at that -u and -t don't make sense together. + + #my $opts = grep $_ && 1, # yes, the count of the set ones + # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l + #; + # + #$self->usage("only one of -t, -u, -m or -l") if $opts > 1; + + + # Any sanity-checking need doing here? + + return; +} + +#.......................................................................... + +sub grand_search_init { + my($self, $pages, @found) = @_; + + foreach (@$pages) { + if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) { + my $searchfor = catfile split '::', $_; + $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" ); + local $_; + while (<PODIDX>) { + chomp; + push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; + } + close(PODIDX) or die "Can't close $$self{'podidx'}: $!"; + next; + } + + $self->aside( "Searching for $_\n" ); + + if ($self->opt_F) { + next unless -r; + push @found, $_ if $self->opt_m or $self->containspod($_); + next; + } + + # We must look both in @INC for library modules and in $bindir + # for executables, like h2xs or perldoc itself. + + my @searchdirs = ($self->{'bindir'}, @INC); + unless ($self->opt_m) { + if (IS_VMS) { + my($i,$trn); + for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { + push(@searchdirs,$trn); + } + push(@searchdirs,'perl_root:[lib.pod]') # installed pods + } + else { + push(@searchdirs, grep(-d, split($Config{path_sep}, + $ENV{'PATH'}))); + } + } + my @files = $self->searchfor(0,$_,@searchdirs); + if (@files) { + $self->aside( "Found as @files\n" ); + } + else { + # no match, try recursive search + @searchdirs = grep(!/^\.\z/s,@INC); + @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r; + if (@files) { + $self->aside( "Loosely found as @files\n" ); + } + else { + print STDERR "No " . + ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; + if ( @{ $self->{'found'} } ) { + print STDERR "However, try\n"; + for my $dir (@{ $self->{'found'} }) { + opendir(DIR, $dir) or die "opendir $dir: $!"; + while (my $file = readdir(DIR)) { + next if ($file =~ /^\./s); + $file =~ s/\.(pm|pod)\z//; # XXX: badfs + print STDERR "\tperldoc $_\::$file\n"; + } + closedir(DIR) or die "closedir $dir: $!"; + } + } + } + } + push(@found,@files); + } + return @found; +} + +#.......................................................................... + +sub maybe_generate_dynamic_pod { + my($self, $found_things) = @_; + my @dynamic_pod; + + $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f; + + $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q; + + if( ! $self->opt_f and ! $self->opt_q ) { + DEBUG > 4 and print "That's a non-dynamic pod search.\n"; + } elsif ( @dynamic_pod ) { + $self->aside("Hm, I found some Pod from that search!\n"); + my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); + + push @{ $self->{'temp_file_list'} }, $buffer; + # I.e., it MIGHT be deleted at the end. + + my $in_list = $self->opt_f; + + print $buffd "=over 8\n\n" if $in_list; + print $buffd @dynamic_pod or die "Can't print $buffer: $!"; + print $buffd "=back\n" if $in_list; + + close $buffd or die "Can't close $buffer: $!"; + + @$found_things = $buffer; + # Yes, so found_things never has more than one thing in + # it, by time we leave here + + $self->add_formatter_option('__filter_nroff' => 1); + + } else { + @$found_things = (); + $self->aside("I found no Pod from that search!\n"); + } + + return; +} + +#.......................................................................... + +sub add_formatter_option { # $self->add_formatter_option('key' => 'value'); + my $self = shift; + push @{ $self->{'formatter_switches'} }, [ @_ ] if @_; + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + return; +} + +#.......................................................................... + +sub search_perlfunc { + my($self, $found_things, $pod) = @_; + + DEBUG > 2 and print "Search: @$found_things\n"; + + my $perlfunc = shift @$found_things; + open(PFUNC, "<", $perlfunc) # "Funk is its own reward" + or die("Can't open $perlfunc: $!"); + + # Functions like -r, -e, etc. are listed under `-X'. + my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) + ? '(?:I<)?-X' : quotemeta($self->opt_f) ; + + DEBUG > 2 and + print "Going to perlfunc-scan for $search_re in $perlfunc\n"; + + # Skip introduction + local $_; + while (<PFUNC>) { + last if /^=head2 Alphabetical Listing of Perl Functions/; + } + + # Look for our function + my $found = 0; + my $inlist = 0; + while (<PFUNC>) { # "The Mothership Connection is here!" + if ( m/^=item\s+$search_re\b/ ) { + $found = 1; + } + elsif (/^=item/) { + last if $found > 1 and not $inlist; + } + next unless $found; + if (/^=over/) { + ++$inlist; + } + elsif (/^=back/) { + --$inlist; + } + push @$pod, $_; + ++$found if /^\w/; # found descriptive text + } + if (!@$pod) { + die sprintf + "No documentation for perl function `%s' found\n", + $self->opt_f + ; + } + close PFUNC or die "Can't open $perlfunc: $!"; + + return; +} + +#.......................................................................... + +sub search_perlfaqs { + my( $self, $found_things, $pod) = @_; + + my $found = 0; + my %found_in; + my $search_key = $self->opt_q; + + my $rx = eval { qr/$search_key/ } + or die <<EOD; +Invalid regular expression '$search_key' given as -q pattern: +$@ +Did you mean \\Q$search_key ? + +EOD + + local $_; + foreach my $file (@$found_things) { + die "invalid file spec: $!" if $file =~ /[<>|]/; + open(INFAQ, "<", $file) # XXX 5.6ism + or die "Can't read-open $file: $!\nAborting"; + while (<INFAQ>) { + if ( m/^=head2\s+.*(?:$search_key)/i ) { + $found = 1; + push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++; + } + elsif (/^=head[12]/) { + $found = 0; + } + next unless $found; + push @$pod, $_; + } + close(INFAQ); + } + die("No documentation for perl FAQ keyword `$search_key' found\n") + unless @$pod; + + return; +} + + +#.......................................................................... + +sub render_findings { + # Return the filename to open + + my($self, $found_things) = @_; + + my $formatter_class = $self->{'formatter_class'} + || die "No formatter class set!?"; + my $formatter = $formatter_class->can('new') + ? $formatter_class->new + : $formatter_class + ; + + if(! @$found_things) { + die "Nothing found?!"; + # should have been caught before here + } elsif(@$found_things > 1) { + warn join '', + "Perldoc is only really meant for reading one document at a time.\n", + "So these parameters are being ignored: ", + join(' ', @$found_things[1 .. $#$found_things] ), + "\n" + } + + my $file = $found_things->[0]; + + DEBUG > 3 and printf "Formatter switches now: [%s]\n", + join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; + + # Set formatter options: + if( ref $formatter ) { + foreach my $f (@{ $self->{'formatter_switches'} || [] }) { + my($switch, $value, $silent_fail) = @$f; + if( $formatter->can($switch) ) { + eval { $formatter->$switch( defined($value) ? $value : () ) }; + warn "Got an error when setting $formatter_class\->$switch:\n$@\n" + if $@; + } else { + if( $silent_fail or $switch =~ m/^__/s ) { + DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n"; + } else { + warn "$formatter_class doesn't recognize the $switch switch.\n"; + } + } + } + } + + $self->{'output_is_binary'} = + $formatter->can('write_with_binmode') && $formatter->write_with_binmode; + + my ($out_fh, $out) = $self->new_output_file( + ( $formatter->can('output_extension') && $formatter->output_extension ) + || undef, + $self->useful_filename_bit, + ); + + # Now, finally, do the formatting! + { + local $^W = $^W; + if(DEBUG() or $self->opt_v) { + # feh, let 'em see it + } else { + $^W = 0; + # The average user just has no reason to be seeing + # $^W-suppressable warnings from the formatting! + } + + eval { $formatter->parse_from_file( $file, $out_fh ) }; + } + + warn "Error while formatting with $formatter_class:\n $@\n" if $@; + DEBUG > 2 and print "Back from formatting with $formatter_class\n"; + + close $out_fh + or warn "Can't close $out: $!\n(Did $formatter already close it?)"; + sleep 0; sleep 0; sleep 0; + # Give the system a few timeslices to meditate on the fact + # that the output file does in fact exist and is closed. + + $self->unlink_if_temp_file($file); + + unless( -s $out ) { + if( $formatter->can( 'if_zero_length' ) ) { + # Basically this is just a hook for Pod::Simple::Checker; since + # what other class could /happily/ format an input file with Pod + # as a 0-length output file? + $formatter->if_zero_length( $file, $out, $out_fh ); + } else { + warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" + } + } + + DEBUG and print "Finished writing to $out.\n"; + return($out, $formatter) if wantarray; + return $out; +} + +#.......................................................................... + +sub unlink_if_temp_file { + # Unlink the specified file IFF it's in the list of temp files. + # Really only used in the case of -f / -q things when we can + # throw away the dynamically generated source pod file once + # we've formatted it. + # + my($self, $file) = @_; + return unless defined $file and length $file; + + my $temp_file_list = $self->{'temp_file_list'} || return; + if(grep $_ eq $file, @$temp_file_list) { + $self->aside("Unlinking $file\n"); + unlink($file) or warn "Odd, couldn't unlink $file: $!"; + } else { + DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; + } + return; +} + +#.......................................................................... + +sub MSWin_temp_cleanup { + + # Nothing particularly MSWin-specific in here, but I don't know if any + # other OS needs its temp dir policed like MSWin does! + + my $self = shift; + + my $tempdir = $ENV{'TEMP'}; + return unless defined $tempdir and length $tempdir + and -e $tempdir and -d _ and -w _; + + $self->aside( + "Considering whether any old files of mine in $tempdir need unlinking.\n" + ); + + opendir(TMPDIR, $tempdir) || return; + my @to_unlink; + + my $limit = time() - $Temp_File_Lifetime; + + DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n", + ($limit) x 2; + + my $filespec; + + while(defined($filespec = readdir(TMPDIR))) { + if( + $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s + ) { + if( hex($1) < $limit ) { + push @to_unlink, "$tempdir/$filespec"; + $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" ); + } else { + DEBUG > 5 and + printf " $tempdir/$filespec is too recent (after %x)\n", $limit; + } + } else { + DEBUG > 5 and + print " $tempdir/$filespec doesn't look like a perldoc temp file.\n"; + } + } + closedir(TMPDIR); + $self->aside(sprintf "Unlinked %s items of mine in %s\n", + scalar(unlink(@to_unlink)), + $tempdir + ); + return; +} + +# . . . . . . . . . . . . . . . . . . . . . . . . . + +sub MSWin_perldoc_tempfile { + my($self, $suffix, $infix) = @_; + + my $tempdir = $ENV{'TEMP'}; + return unless defined $tempdir and length $tempdir + and -e $tempdir and -d _ and -w _; + + my $spec; + + do { + $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup + # Yes, we embed the create-time in the filename! + $tempdir, + $infix || 'x', + time(), + $$, + defined( &Win32::GetTickCount ) + ? (Win32::GetTickCount() & 0xff) + : int(rand 256) + # Under MSWin, $$ values get reused quickly! So if we ran + # perldoc foo and then perldoc bar before there was time for + # time() to increment time."_$$" would likely be the same + # for each process! So we tack on the tick count's lower + # bits (or, in a pinch, rand) + , + $suffix || 'txt'; + ; + } while( -e $spec ); + + my $counter = 0; + + while($counter < 50) { + my $fh; + # If we are running before perl5.6.0, we can't autovivify + if ($] < 5.006) { + require Symbol; + $fh = Symbol::gensym(); + } + DEBUG > 3 and print "About to try making temp file $spec\n"; + return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism + $self->aside("Can't create temp file $spec: $!\n"); + } + + $self->aside("Giving up on making a temp file!\n"); + die "Can't make a tempfile!?"; +} + +#.......................................................................... + + +sub after_rendering { + my $self = $_[0]; + $self->after_rendering_VMS if IS_VMS; + $self->after_rendering_MSWin32 if IS_MSWin32; + $self->after_rendering_Dos if IS_Dos; + $self->after_rendering_OS2 if IS_OS2; + return; +} + +sub after_rendering_VMS { return } +sub after_rendering_Dos { return } +sub after_rendering_OS2 { return } + +sub after_rendering_MSWin32 { + shift->MSWin_temp_cleanup() if $Temp_Files_Created; +} + +#.......................................................................... +# : : : : : : : : : +#.......................................................................... + + +sub minus_f_nocase { # i.e., do like -f, but without regard to case + + my($self, $dir, $file) = @_; + my $path = catfile($dir,$file); + return $path if -f $path and -r _; + + if(!$self->opt_i + or IS_VMS or IS_MSWin32 + or IS_Dos or IS_OS2 + ) { + # On a case-forgiving file system, or if case is important, + # that is it, all we can do. + warn "Ignored $path: unreadable\n" if -f _; + return ''; + } + + local *DIR; + my @p = ($dir); + my($p,$cip); + foreach $p (splitdir $file){ + my $try = catfile @p, $p; + $self->aside("Scrutinizing $try...\n"); + stat $try; + if (-d _) { + push @p, $p; + if ( $p eq $self->{'target'} ) { + my $tmp_path = catfile @p; + my $path_f = 0; + for (@{ $self->{'found'} }) { + $path_f = 1 if $_ eq $tmp_path; + } + push (@{ $self->{'found'} }, $tmp_path) unless $path_f; + $self->aside( "Found as $tmp_path but directory\n" ); + } + } + elsif (-f _ && -r _) { + return $try; + } + elsif (-f _) { + warn "Ignored $try: unreadable\n"; + } + elsif (-d catdir(@p)) { # at least we see the containing directory! + my $found = 0; + my $lcp = lc $p; + my $p_dirspec = catdir(@p); + opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!"; + while(defined( $cip = readdir(DIR) )) { + if (lc $cip eq $lcp){ + $found++; + last; # XXX stop at the first? what if there's others? + } + } + closedir DIR or die "closedir $p_dirspec: $!"; + return "" unless $found; + + push @p, $cip; + my $p_filespec = catfile(@p); + return $p_filespec if -f $p_filespec and -r _; + warn "Ignored $p_filespec: unreadable\n" if -f _; + } + } + return ""; +} + +#.......................................................................... + +sub pagers_guessing { + my $self = shift; + + my @pagers; + push @pagers, $self->pagers; + $self->{'pagers'} = \@pagers; + + if (IS_MSWin32) { + push @pagers, qw( more< less notepad ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + elsif (IS_VMS) { + push @pagers, qw( most more less type/page ); + } + elsif (IS_Dos) { + push @pagers, qw( less.exe more.com< ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + else { + if (IS_OS2) { + unshift @pagers, 'less', 'cmd /c more <'; + } + push @pagers, qw( more less pg view cat ); + unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; + } + + if (IS_Cygwin) { + if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) { + unshift @pagers, '/usr/bin/less -isrR'; + } + } + + unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; + + return; +} + +#.......................................................................... + +sub page_module_file { + my($self, @found) = @_; + + # Security note: + # Don't ever just pass this off to anything like MSWin's "start.exe", + # since we might be calling on a .pl file, and we wouldn't want that + # to actually /execute/ the file that we just want to page thru! + # Also a consideration if one were to use a web browser as a pager; + # doing so could trigger the browser's MIME mapping for whatever + # it thinks .pm/.pl/whatever is. Probably just a (useless and + # annoying) "Save as..." dialog, but potentially executing the file + # in question -- particularly in the case of MSIE and it's, ahem, + # occasionally hazy distinction between OS-local extension + # associations, and browser-specific MIME mappings. + + if ($self->{'output_to_stdout'}) { + $self->aside("Sending unpaged output to STDOUT.\n"); + local $_; + my $any_error = 0; + foreach my $output (@found) { + unless( open(TMP, "<", $output) ) { # XXX 5.6ism + warn("Can't open $output: $!"); + $any_error = 1; + next; + } + while (<TMP>) { + print or die "Can't print to stdout: $!"; + } + close TMP or die "Can't close while $output: $!"; + $self->unlink_if_temp_file($output); + } + return $any_error; # successful + } + + foreach my $pager ( $self->pagers ) { + $self->aside("About to try calling $pager @found\n"); + if (system($pager, @found) == 0) { + $self->aside("Yay, it worked.\n"); + return 0; + } + $self->aside("That didn't work.\n"); + + # Odd -- when it fails, under Win32, this seems to neither + # return with a fail nor return with a success!! + # That's discouraging! + } + + $self->aside( + sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n", + join(' ', @found), + join(' ', $self->pagers), + ); + + if (IS_VMS) { + DEBUG > 1 and print "Bailing out in a VMSish way.\n"; + eval q{ + use vmsish qw(status exit); + exit $?; + 1; + } or die; + } + + return 1; + # i.e., an UNSUCCESSFUL return value! +} + +#.......................................................................... + +sub check_file { + my($self, $dir, $file) = @_; + + unless( ref $self ) { + # Should never get called: + $Carp::Verbose = 1; + require Carp; + Carp::croak( join '', + "Crazy ", __PACKAGE__, " error:\n", + "check_file must be an object_method!\n", + "Aborting" + ); + } + + if(length $dir and not -d $dir) { + DEBUG > 3 and print " No dir $dir -- skipping.\n"; + return ""; + } + + if ($self->opt_m) { + return $self->minus_f_nocase($dir,$file); + } + + else { + my $path = $self->minus_f_nocase($dir,$file); + if( length $path and $self->containspod($path) ) { + DEBUG > 3 and print + " The file $path indeed looks promising!\n"; + return $path; + } + } + DEBUG > 3 and print " No good: $file in $dir\n"; + + return ""; +} + +#.......................................................................... + +sub containspod { + my($self, $file, $readit) = @_; + return 1 if !$readit && $file =~ /\.pod\z/i; + + + # Under cygwin the /usr/bin/perl is legal executable, but + # you cannot open a file with that name. It must be spelled + # out as "/usr/bin/perl.exe". + # + # The following if-case under cygwin prevents error + # + # $ perldoc perl + # Cannot open /usr/bin/perl: no such file or directory + # + # This would work though + # + # $ perldoc perl.pod + + if ( IS_Cygwin and -x $file and -f "$file.exe" ) + { + warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_v; + return 0; + } + + local($_); + open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism + while (<TEST>) { + if (/^=head/) { + close(TEST) or die "Can't close $file: $!"; + return 1; + } + } + close(TEST) or die "Can't close $file: $!"; + return 0; +} + +#.......................................................................... + +sub maybe_diddle_INC { + my $self = shift; + + # Does this look like a module or extension directory? + + if (-f "Makefile.PL") { + + # Add "." and "lib" to @INC (if they exist) + eval q{ use lib qw(. lib); 1; } or die; + + # don't add if superuser + if ($< && $> && -f "blib") { # don't be looking too hard now! + eval q{ use blib; 1 }; + warn $@ if $@ && $self->opt_v; + } + } + + return; +} + +#.......................................................................... + +sub new_output_file { + my $self = shift; + my $outspec = $self->opt_d; # Yes, -d overrides all else! + # So don't call this twice per format-job! + + return $self->new_tempfile(@_) unless defined $outspec and length $outspec; + + # Otherwise open a write-handle on opt_d!f + + my $fh; + # If we are running before perl5.6.0, we can't autovivify + if ($] < 5.006) { + require Symbol; + $fh = Symbol::gensym(); + } + DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; + die "Can't write-open $outspec: $!" + unless open($fh, ">", $outspec); # XXX 5.6ism + + DEBUG > 3 and print "Successfully opened $outspec\n"; + binmode($fh) if $self->{'output_is_binary'}; + return($fh, $outspec); +} + +#.......................................................................... + +sub useful_filename_bit { + # This tries to provide a meaningful bit of text to do with the query, + # such as can be used in naming the file -- since if we're going to be + # opening windows on temp files (as a "pager" may well do!) then it's + # better if the temp file's name (which may well be used as the window + # title) isn't ALL just random garbage! + # In other words "perldoc_LWPSimple_2371981429" is a better temp file + # name than "perldoc_2371981429". So this routine is what tries to + # provide the "LWPSimple" bit. + # + my $self = shift; + my $pages = $self->{'pages'} || return undef; + return undef unless @$pages; + + my $chunk = $pages->[0]; + return undef unless defined $chunk; + $chunk =~ s/:://g; + $chunk =~ s/\.\w+$//g; # strip any extension + if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file + $chunk = $1; + } else { + return undef; + } + $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things! + $chunk = substr($chunk, -10) if length($chunk) > 10; + return $chunk; +} + +#.......................................................................... + +sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] ) + my $self = shift; + + ++$Temp_Files_Created; + + if( IS_MSWin32 ) { + my @out = $self->MSWin_perldoc_tempfile(@_); + return @out if @out; + # otherwise fall thru to the normal stuff below... + } + + require File::Temp; + return File::Temp::tempfile(UNLINK => 1); +} + +#.......................................................................... + +sub page { # apply a pager to the output file + my ($self, $output, $output_to_stdout, @pagers) = @_; + if ($output_to_stdout) { + $self->aside("Sending unpaged output to STDOUT.\n"); + open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism + local $_; + while (<TMP>) { + print or die "Can't print to stdout: $!"; + } + close TMP or die "Can't close while $output: $!"; + $self->unlink_if_temp_file($output); + } else { + # On VMS, quoting prevents logical expansion, and temp files with no + # extension get the wrong default extension (such as .LIS for TYPE) + + $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS; + + $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos; + # Altho "/" under MSWin is in theory good as a pathsep, + # many many corners of the OS don't like it. So we + # have to force it to be "\" to make everyone happy. + + foreach my $pager (@pagers) { + $self->aside("About to try calling $pager $output\n"); + if (IS_VMS) { + last if system("$pager $output") == 0; + } else { + last if system("$pager \"$output\"") == 0; + } + } + } + return; +} + +#.......................................................................... + +sub searchfor { + my($self, $recurse,$s,@dirs) = @_; + $s =~ s!::!/!g; + $s = VMS::Filespec::unixify($s) if IS_VMS; + return $s if -f $s && $self->containspod($s); + $self->aside( "Looking for $s in @dirs\n" ); + my $ret; + my $i; + my $dir; + $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename? + for ($i=0; $i<@dirs; $i++) { + $dir = $dirs[$i]; + next unless -d $dir; # some dirs in @INC are optional + ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS; + if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) + or ( $ret = $self->check_file($dir,"$s.pm")) + or ( $ret = $self->check_file($dir,$s)) + or ( IS_VMS and + $ret = $self->check_file($dir,"$s.com")) + or ( IS_OS2 and + $ret = $self->check_file($dir,"$s.cmd")) + or ( (IS_MSWin32 or IS_Dos or IS_OS2) and + $ret = $self->check_file($dir,"$s.bat")) + or ( $ret = $self->check_file("$dir/pod","$s.pod")) + or ( $ret = $self->check_file("$dir/pod",$s)) + or ( $ret = $self->check_file("$dir/pods","$s.pod")) + or ( $ret = $self->check_file("$dir/pods",$s)) + ) { + DEBUG > 1 and print " Found $ret\n"; + return $ret; + } + + if ($recurse) { + opendir(D,$dir) or die "Can't opendir $dir: $!"; + my @newdirs = map catfile($dir, $_), grep { + not /^\.\.?\z/s and + not /^auto\z/s and # save time! don't search auto dirs + -d catfile($dir, $_) + } readdir D; + closedir(D) or die "Can't closedir $dir: $!"; + next unless @newdirs; + # what a wicked map! + @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS; + $self->aside( "Also looking in @newdirs\n" ); + push(@dirs,@newdirs); + } + } + return (); +} + +#.......................................................................... +{ + my $already_asserted; + sub assert_closing_stdout { + my $self = shift; + + return if $already_asserted; + + eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~; + # What for? to let the pager know that nothing more will come? + + die $@ if $@; + $already_asserted = 1; + return; + } +} + +#.......................................................................... + +sub tweak_found_pathnames { + my($self, $found) = @_; + if (IS_MSWin32) { + foreach (@$found) { s,/,\\,g } + } + return; +} + +#.......................................................................... +# : : : : : : : : : +#.......................................................................... + +sub am_taint_checking { + my $self = shift; + die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way + my($k,$v) = each %ENV; + return is_tainted($v); +} + +#.......................................................................... + +sub is_tainted { # just a function + my $arg = shift; + my $nada = substr($arg, 0, 0); # zero-length! + local $@; # preserve the caller's version of $@ + eval { eval "# $nada" }; + return length($@) != 0; +} + +#.......................................................................... + +sub drop_privs_maybe { + my $self = shift; + + # Attempt to drop privs if we should be tainting and aren't + if (!(IS_VMS || IS_MSWin32 || IS_Dos + || IS_OS2 + ) + && ($> == 0 || $< == 0) + && !$self->am_taint_checking() + ) { + my $id = eval { getpwnam("nobody") }; + $id = eval { getpwnam("nouser") } unless defined $id; + $id = -2 unless defined $id; + # + # According to Stevens' APUE and various + # (BSD, Solaris, HP-UX) man pages, setting + # the real uid first and effective uid second + # is the way to go if one wants to drop privileges, + # because if one changes into an effective uid of + # non-zero, one cannot change the real uid any more. + # + # Actually, it gets even messier. There is + # a third uid, called the saved uid, and as + # long as that is zero, one can get back to + # uid of zero. Setting the real-effective *twice* + # helps in *most* systems (FreeBSD and Solaris) + # but apparently in HP-UX even this doesn't help: + # the saved uid stays zero (apparently the only way + # in HP-UX to change saved uid is to call setuid() + # when the effective uid is zero). + # + eval { + $< = $id; # real uid + $> = $id; # effective uid + $< = $id; # real uid + $> = $id; # effective uid + }; + if( !$@ && $< && $> ) { + DEBUG and print "OK, I dropped privileges.\n"; + } elsif( $self->opt_U ) { + DEBUG and print "Couldn't drop privileges, but in -U mode, so feh." + } else { + DEBUG and print "Hm, couldn't drop privileges. Ah well.\n"; + # We used to die here; but that seemed pointless. + } + } + return; +} + +#.......................................................................... + +1; + +__END__ + +# See "perldoc perldoc" for basic details. +# +# Perldoc -- look up a piece of documentation in .pod format that +# is embedded in the perl installation tree. +# +#~~~~~~ +# +# See ChangeLog in CPAN dist for Pod::Perldoc for later notes. +# +# Version 3.01: Sun Nov 10 21:38:09 MST 2002 +# Sean M. Burke <sburke@cpan.org> +# Massive refactoring and code-tidying. +# Now it's a module(-family)! +# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm +# Added -T, -d, -o, -M, -w. +# Added some improved MSWin funk. +# +#~~~~~~ +# +# Version 2.05: Sat Oct 12 16:09:00 CEST 2002 +# Hugo van der Sanden <hv@crypt.org> +# Made -U the default, based on patch from Simon Cozens +# Version 2.04: Sun Aug 18 13:27:12 BST 2002 +# Randy W. Sims <RandyS@ThePierianSpring.org> +# allow -n to enable nroff under Win32 +# Version 2.03: Sun Apr 23 16:56:34 BST 2000 +# Hugo van der Sanden <hv@crypt.org> +# don't die when 'use blib' fails +# Version 2.02: Mon Mar 13 18:03:04 MST 2000 +# Tom Christiansen <tchrist@perl.com> +# Added -U insecurity option +# Version 2.01: Sat Mar 11 15:22:33 MST 2000 +# Tom Christiansen <tchrist@perl.com>, querulously. +# Security and correctness patches. +# What a twisted bit of distasteful spaghetti code. +# Version 2.0: ???? +# +#~~~~~~ +# +# Version 1.15: Tue Aug 24 01:50:20 EST 1999 +# Charles Wilson <cwilson@ece.gatech.edu> +# changed /pod/ directory to /pods/ for cygwin +# to support cygwin/win32 +# Version 1.14: Wed Jul 15 01:50:20 EST 1998 +# Robin Barker <rmb1@cise.npl.co.uk> +# -strict, -w cleanups +# Version 1.13: Fri Feb 27 16:20:50 EST 1997 +# Gurusamy Sarathy <gsar@activestate.com> +# -doc tweaks for -F and -X options +# Version 1.12: Sat Apr 12 22:41:09 EST 1997 +# Gurusamy Sarathy <gsar@activestate.com> +# -various fixes for win32 +# Version 1.11: Tue Dec 26 09:54:33 EST 1995 +# Kenneth Albanowski <kjahds@kjahds.com> +# -added Charles Bailey's further VMS patches, and -u switch +# -added -t switch, with pod2text support +# +# Version 1.10: Thu Nov 9 07:23:47 EST 1995 +# Kenneth Albanowski <kjahds@kjahds.com> +# -added VMS support +# -added better error recognition (on no found pages, just exit. On +# missing nroff/pod2man, just display raw pod.) +# -added recursive/case-insensitive matching (thanks, Andreas). This +# slows things down a bit, unfortunately. Give a precise name, and +# it'll run faster. +# +# Version 1.01: Tue May 30 14:47:34 EDT 1995 +# Andy Dougherty <doughera@lafcol.lafayette.edu> +# -added pod documentation. +# -added PATH searching. +# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod +# and friends. +# +#~~~~~~~ +# +# TODO: +# +# Cache the directories read during sloppy match +# (To disk, or just in-memory?) +# +# Backport this to perl 5.005? +# +# Implement at least part of the "perlman" interface described +# in Programming Perl 3e? diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/BaseTo.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/BaseTo.pm new file mode 100644 index 00000000000..6ca2a8c7e54 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/BaseTo.pm @@ -0,0 +1,28 @@ + +require 5; +package Pod::Perldoc::BaseTo; +use strict; +use warnings; + +sub is_pageable { '' } +sub write_with_binmode { 1 } + +sub output_extension { 'txt' } # override in subclass! + +# sub new { my $self = shift; ... } +# sub parse_from_file( my($class, $in, $out) = ...; ... } + +#sub new { return bless {}, ref($_[0]) || $_[0] } + +sub _perldoc_elem { + my($self, $name) = splice @_,0,2; + if(@_) { + $self->{$name} = $_[0]; + } else { + $self->{$name}; + } +} + + +1; + diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/GetOptsOO.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/GetOptsOO.pm new file mode 100644 index 00000000000..b29aeb10906 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/GetOptsOO.pm @@ -0,0 +1,106 @@ + +require 5; +package Pod::Perldoc::GetOptsOO; +use strict; + +# Rather like Getopt::Std's getopts +# Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth) +# Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT ) +# (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo") +# Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth) +# (Truth defaults to 1) +# Otherwise we try calling $object->handle_unknown_option('n') +# (and we increment the error count by the return value of it) +# If there's no handle_unknown_option, then we just warn, and then increment +# the error counter +# +# The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors, +# otherwise it's false. +# +## sburke@cpan.org 2002-10-31 + +BEGIN { # Make a DEBUG constant ASAP + *DEBUG = defined( &Pod::Perldoc::DEBUG ) + ? \&Pod::Perldoc::DEBUG + : sub(){10}; +} + + +sub getopts { + my($target, $args, $truth) = @_; + + $args ||= \@ARGV; + + $target->aside( + "Starting switch processing. Scanning arguments [@$args]\n" + ) if $target->can('aside'); + + return unless @$args; + + $truth = 1 unless @_ > 2; + + DEBUG > 3 and print " Truth is $truth\n"; + + + my $error_count = 0; + + while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) { + my($first,$rest) = ($1,$2); + if ($_ eq '--') { # early exit if "--" + shift @$args; + last; + } + my $method = "opt_${first}_with"; + if( $target->can($method) ) { # it's argumental + if($rest eq '') { # like -f bar + shift @$args; + warn "Option $first needs a following argument!\n" unless @$args; + $rest = shift @$args; + } else { # like -fbar (== -f bar) + shift @$args; + } + + DEBUG > 3 and print " $method => $rest\n"; + $target->$method( $rest ); + + # Otherwise, it's not argumental... + } else { + + if( $target->can( $method = "opt_$first" ) ) { + DEBUG > 3 and print " $method is true ($truth)\n"; + $target->$method( $truth ); + + # Otherwise it's an unknown option... + + } elsif( $target->can('handle_unknown_option') ) { + DEBUG > 3 + and print " calling handle_unknown_option('$first')\n"; + + $error_count += ( + $target->handle_unknown_option( $first ) || 0 + ); + + } else { + ++$error_count; + warn "Unknown option: $first\n"; + } + + if($rest eq '') { # like -f + shift @$args + } else { # like -fbar (== -f -bar ) + DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n"; + $args->[0] = "-$rest"; + } + } + } + + + $target->aside( + "Ending switch processing. Args are [@$args] with $error_count errors.\n" + ) if $target->can('aside'); + + $error_count == 0; +} + +1; + diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToChecker.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToChecker.pm new file mode 100644 index 00000000000..c60290d6502 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToChecker.pm @@ -0,0 +1,72 @@ + +require 5; +package Pod::Perldoc::ToChecker; +use strict; +use warnings; +use vars qw(@ISA); + +# Pick our superclass... +# +eval 'require Pod::Simple::Checker'; +if($@) { + require Pod::Checker; + @ISA = ('Pod::Checker'); +} else { + @ISA = ('Pod::Simple::Checker'); +} + +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } + +sub if_zero_length { + my( $self, $file, $tmp, $tmpfd ) = @_; + print "No Pod errors in $file\n"; +} + + +1; + +__END__ + +=head1 NAME + +Pod::Perldoc::ToChecker - let Perldoc check Pod for errors + +=head1 SYNOPSIS + + % perldoc -o checker SomeFile.pod + No Pod errors in SomeFile.pod + (or an error report) + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Simple::Checker as a "formatter" class (or if that is +not available, then Pod::Checker), to check for errors in a given +Pod file. + +This is actually a Pod::Simple::Checker (or Pod::Checker) subclass, and +inherits all its options. + +=head1 SEE ALSO + +L<Pod::Simple::Checker>, L<Pod::Simple>, L<Pod::Checker>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToMan.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToMan.pm new file mode 100644 index 00000000000..43191222376 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToMan.pm @@ -0,0 +1,187 @@ + +require 5; +package Pod::Perldoc::ToMan; +use strict; +use warnings; + +# This class is unlike ToText.pm et al, because we're NOT paging thru +# the output in our particular format -- we make the output and +# then we run nroff (or whatever) on it, and then page thru the +# (plaintext) output of THAT! + +use base qw(Pod::Perldoc::BaseTo); +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } + +sub __filter_nroff { shift->_perldoc_elem('__filter_nroff' , @_) } +sub __nroffer { shift->_perldoc_elem('__nroffer' , @_) } +sub __bindir { shift->_perldoc_elem('__bindir' , @_) } +sub __pod2man { shift->_perldoc_elem('__pod2man' , @_) } +sub __output_file { shift->_perldoc_elem('__output_file' , @_) } + +sub center { shift->_perldoc_elem('center' , @_) } +sub date { shift->_perldoc_elem('date' , @_) } +sub fixed { shift->_perldoc_elem('fixed' , @_) } +sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) } +sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) } +sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) } +sub quotes { shift->_perldoc_elem('quotes' , @_) } +sub release { shift->_perldoc_elem('release' , @_) } +sub section { shift->_perldoc_elem('section' , @_) } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +use File::Spec::Functions qw(catfile); + +sub parse_from_file { + my $self = shift; + my($file, $outfh) = @_; + + my $render = $self->{'__nroffer'} || die "no nroffer set!?"; + + # turn the switches into CLIs + my $switches = join ' ', + map qq{"--$_=$self->{$_}"}, + grep !m/^_/s, + keys %$self + ; + + my $pod2man = + catfile( + ($self->{'__bindir'} || die "no bindir set?!" ), + ($self->{'__pod2man'} || die "no pod2man set?!" ), + ) + ; + unless(-e $pod2man) { + # This is rarely needed, I think. + $pod2man = $self->{'__pod2man'} || die "no pod2man set?!"; + die "Can't find a pod2man?! (". $self->{'__pod2man'} .")\nAborting" + unless -e $pod2man; + } + + my $command = "$pod2man $switches --lax $file | $render -man"; + # no temp file, just a pipe! + + # Thanks to Brendan O'Dea for contributing the following block + if(Pod::Perldoc::IS_Linux and -t STDOUT + and my ($cols) = `stty -a` =~ m/\bcolumns\s+(\d+)/ + ) { + my $c = $cols * 39 / 40; + $cols = $c > $cols - 2 ? $c : $cols -2; + $command .= ' -rLL=' . (int $c) . 'n' if $cols > 80; + } + + if(Pod::Perldoc::IS_Cygwin) { + $command .= ' -c'; + } + + # I hear persistent reports that adding a -c switch to $render + # solves many people's problems. But I also hear that some mans + # don't have a -c switch, so that unconditionally adding it here + # would presumably be a Bad Thing -- sburke@cpan.org + + $command .= " | col -x" if Pod::Perldoc::IS_HPUX; + + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "About to run $command\n"; + ; + + my $rslt = `$command`; + + my $err; + + if( $self->{'__filter_nroff'} ) { + defined(&Pod::Perldoc::DEBUG) + and &Pod::Perldoc::DEBUG() + and print "filter_nroff is set, so filtering...\n"; + $rslt = $self->___Do_filter_nroff($rslt); + } else { + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "filter_nroff isn't set, so not filtering.\n"; + } + + if (($err = $?)) { + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "Nonzero exit ($?) while running $command.\n", + "Falling back to Pod::Perldoc::ToPod\n ", + ; + # A desperate fallthru: + require Pod::Perldoc::ToPod; + return Pod::Perldoc::ToPod->new->parse_from_file(@_); + + } else { + print $outfh $rslt + or die "Can't print to $$self{__output_file}: $!"; + } + + return; +} + + +sub ___Do_filter_nroff { + my $self = shift; + my @data = split /\n{2,}/, shift; + + shift @data while @data and $data[0] !~ /\S/; # Go to header + shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header + pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like + # 28/Jan/99 perl 5.005, patch 53 1 + join "\n\n", @data; +} + +1; + +__END__ + +=head1 NAME + +Pod::Perldoc::ToMan - let Perldoc render Pod as man pages + +=head1 SYNOPSIS + + perldoc -o man Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Man and C<nroff> for reading Pod pages. + +The following options are supported: center, date, fixed, fixedbold, +fixeditalic, fixedbolditalic, quotes, release, section + +(Those options are explained in L<Pod::Man>.) + +For example: + + perldoc -o man -w center:Pod Some::Modulename + +=head1 CAVEAT + +This module may change to use a different pod-to-nroff formatter class +in the future, and this may change what options are supported. + +=head1 SEE ALSO + +L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToNroff> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002,3,4 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToNroff.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToNroff.pm new file mode 100644 index 00000000000..d0568605068 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToNroff.pm @@ -0,0 +1,100 @@ + +require 5; +package Pod::Perldoc::ToNroff; +use strict; +use warnings; + +# This is unlike ToMan.pm in that it emits the raw nroff source! + +use base qw(Pod::Perldoc::BaseTo); + +sub is_pageable { 1 } # well, if you ask for it... +sub write_with_binmode { 0 } +sub output_extension { 'man' } + +use Pod::Man (); + +sub center { shift->_perldoc_elem('center' , @_) } +sub date { shift->_perldoc_elem('date' , @_) } +sub fixed { shift->_perldoc_elem('fixed' , @_) } +sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) } +sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) } +sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) } +sub quotes { shift->_perldoc_elem('quotes' , @_) } +sub release { shift->_perldoc_elem('release' , @_) } +sub section { shift->_perldoc_elem('section' , @_) } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +sub parse_from_file { + my $self = shift; + my $file = $_[0]; + + my @options = + map {; $_, $self->{$_} } + grep !m/^_/s, + keys %$self + ; + + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "About to call new Pod::Man ", + $Pod::Man::VERSION ? "(v$Pod::Man::VERSION) " : '', + "with options: ", + @options ? "[@options]" : "(nil)", "\n"; + ; + + Pod::Man->new(@options)->parse_from_file(@_); +} + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToNroff - let Perldoc convert Pod to nroff + +=head1 SYNOPSIS + + perldoc -o nroff -d something.3 Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Man as a formatter class. + +The following options are supported: center, date, fixed, fixedbold, +fixeditalic, fixedbolditalic, quotes, release, section + +Those options are explained in L<Pod::Man>. + +For example: + + perldoc -o nroff -w center:Pod -d something.3 Some::Modulename + +=head1 CAVEAT + +This module may change to use a different pod-to-nroff formatter class +in the future, and this may change what options are supported. + +=head1 SEE ALSO + +L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToMan> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToPod.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToPod.pm new file mode 100644 index 00000000000..bccbfcadbd6 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToPod.pm @@ -0,0 +1,90 @@ + +# This class is just a hack to act as a "formatter" for +# actually unformatted Pod. +# +# Note that this isn't the same as just passing thru whatever +# we're given -- we pass thru only the pod source, and suppress +# the Perl code (or whatever non-pod stuff is in the source file). + + +require 5; +package Pod::Perldoc::ToPod; +use strict; +use warnings; + +use base qw(Pod::Perldoc::BaseTo); +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'pod' } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +sub parse_from_file { + my( $self, $in, $outfh ) = @_; + + open(IN, "<", $in) or die "Can't read-open $in: $!\nAborting"; + + my $cut_mode = 1; + + # A hack for finding things between =foo and =cut, inclusive + local $_; + while (<IN>) { + if( m/^=(\w+)/s ) { + if($cut_mode = ($1 eq 'cut')) { + print $outfh "\n=cut\n\n"; + # Pass thru the =cut line with some harmless + # (and occasionally helpful) padding + } + } + next if $cut_mode; + print $outfh $_ or die "Can't print to $outfh: $!"; + } + + close IN or die "Can't close $in: $!"; + return; +} + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToPod - let Perldoc render Pod as ... Pod! + +=head1 SYNOPSIS + + perldoc -opod Some::Modulename + +(That's currently the same as the following:) + + perldoc -u Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to display Pod source as +itself! Pretty Zen, huh? + +Currently this class works by just filtering out the non-Pod stuff from +a given input file. + +=head1 SEE ALSO + +L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToRtf.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToRtf.pm new file mode 100644 index 00000000000..25e609e313a --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToRtf.pm @@ -0,0 +1,85 @@ + +require 5; +package Pod::Perldoc::ToRtf; +use strict; +use warnings; +use vars qw($VERSION); + +use base qw( Pod::Simple::RTF ); + +$VERSION # so that ->VERSION is happy +# stop CPAN from seeing this + = +$Pod::Simple::RTF::VERSION; + + +sub is_pageable { 0 } +sub write_with_binmode { 0 } +sub output_extension { 'rtf' } + +sub page_for_perldoc { + my($self, $tempfile, $perldoc) = @_; + return unless $perldoc->IS_MSWin32; + + my $rtf_pager = $ENV{'RTFREADER'} || 'write.exe'; + + $perldoc->aside( "About to launch <\"$rtf_pager\" \"$tempfile\">\n" ); + + return 1 if system( qq{"$rtf_pager"}, qq{"$tempfile"} ) == 0; + return 0; +} + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToRtf - let Perldoc render Pod as RTF + +=head1 SYNOPSIS + + perldoc -o rtf Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Simple::RTF as a formatter class. + +This is actually a Pod::Simple::RTF subclass, and inherits +all its options. + +You have to have Pod::Simple::RTF installed (from the Pod::Simple dist), +or this module won't work. + +If Perldoc is running under MSWin and uses this class as a formatter, +the output will be opened with F<write.exe> or whatever program is +specified in the environment variable C<RTFREADER>. For example, to +specify that RTF files should be opened the same as they are when you +double-click them, you would do C<set RTFREADER=start.exe> in your +F<autoexec.bat>. + +Handy tip: put C<set PERLDOC=-ortf> in your F<autoexec.bat> +and that will set this class as the default formatter to run when +you do C<perldoc whatever>. + +=head1 SEE ALSO + +L<Pod::Simple::RTF>, L<Pod::Simple>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToText.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToText.pm new file mode 100644 index 00000000000..2eb9e0644ac --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToText.pm @@ -0,0 +1,91 @@ + +require 5; +package Pod::Perldoc::ToText; +use strict; +use warnings; + +use base qw(Pod::Perldoc::BaseTo); + +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } + +use Pod::Text (); + +sub alt { shift->_perldoc_elem('alt' , @_) } +sub indent { shift->_perldoc_elem('indent' , @_) } +sub loose { shift->_perldoc_elem('loose' , @_) } +sub quotes { shift->_perldoc_elem('quotes' , @_) } +sub sentence { shift->_perldoc_elem('sentence', @_) } +sub width { shift->_perldoc_elem('width' , @_) } + +sub new { return bless {}, ref($_[0]) || $_[0] } + +sub parse_from_file { + my $self = shift; + + my @options = + map {; $_, $self->{$_} } + grep !m/^_/s, + keys %$self + ; + + defined(&Pod::Perldoc::DEBUG) + and Pod::Perldoc::DEBUG() + and print "About to call new Pod::Text ", + $Pod::Text::VERSION ? "(v$Pod::Text::VERSION) " : '', + "with options: ", + @options ? "[@options]" : "(nil)", "\n"; + ; + + Pod::Text->new(@options)->parse_from_file(@_); +} + +1; + +=head1 NAME + +Pod::Perldoc::ToText - let Perldoc render Pod as plaintext + +=head1 SYNOPSIS + + perldoc -o text Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Text as a formatter class. + +It supports the following options, which are explained in +L<Pod::Text>: alt, indent, loose, quotes, sentence, width + +For example: + + perldoc -o text -w indent:5 Some::Modulename + +=head1 CAVEAT + +This module may change to use a different text formatter class in the +future, and this may change what options are supported. + +=head1 SEE ALSO + +L<Pod::Text>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToTk.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToTk.pm new file mode 100644 index 00000000000..39459629503 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToTk.pm @@ -0,0 +1,129 @@ + +require 5; +package Pod::Perldoc::ToTk; +use strict; +use warnings; + +use base qw(Pod::Perldoc::BaseTo); + +sub is_pageable { 1 } +sub write_with_binmode { 0 } +sub output_extension { 'txt' } # doesn't matter +sub if_zero_length { } # because it will be 0-length! +sub new { return bless {}, ref($_[0]) || $_[0] } + +# TODO: document these and their meanings... +sub tree { shift->_perldoc_elem('tree' , @_) } +sub tk_opt { shift->_perldoc_elem('tk_opt' , @_) } +sub forky { shift->_perldoc_elem('forky' , @_) } + +use Pod::Perldoc (); +use File::Spec::Functions qw(catfile); + +use Tk; +die join '', __PACKAGE__, " doesn't work nice with Tk.pm verison $Tk::VERSION" + if $Tk::VERSION eq '800.003'; + +BEGIN { eval { require Tk::FcyEntry; }; }; +use Tk::Pod; + +# The following was adapted from "tkpod" in the Tk-Pod dist. + +sub parse_from_file { + + my($self, $Input_File) = @_; + if($self->{'forky'}) { + return if fork; # i.e., parent process returns + } + + $Input_File =~ s{\\}{/}g + if Pod::Perldoc::IS_MSWin32 or Pod::Perldoc::IS_Dos + # and maybe OS/2 + ; + + my($tk_opt, $tree); + $tree = $self->{'tree' }; + $tk_opt = $self->{'tk_opt'}; + + #require Tk::ErrorDialog; + + # Add 'Tk' subdirectories to search path so, e.g., + # 'Scrolled' will find doc in 'Tk/Scrolled' + + if( $tk_opt ) { + push @INC, grep -d $_, map catfile($_,'Tk'), @INC; + } + + my $mw = MainWindow->new(); + #eval 'use blib "/home/e/eserte/src/perl/Tk-App";require Tk::App::Debug'; + $mw->withdraw; + + # CDE use Font Settings if available + my $ufont = $mw->optionGet('userFont','UserFont'); # fixed width + my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional + if (defined($ufont) and defined($sfont)) { + foreach ($ufont, $sfont) { s/:$//; }; + $mw->optionAdd('*Font', $sfont); + $mw->optionAdd('*Entry.Font', $ufont); + $mw->optionAdd('*Text.Font', $ufont); + } + + $mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0); + + $mw->Pod( + '-file' => $Input_File, + (($Tk::Pod::VERSION >= 4) ? ('-tree' => $tree) : ()) + )->focusNext; + + # xxx dirty but it works. A simple $mw->destroy if $mw->children + # does not work because Tk::ErrorDialogs could be created. + # (they are withdrawn after Ok instead of destory'ed I guess) + + if ($mw->children) { + $mw->repeat(1000, sub { + # ErrorDialog is withdrawn not deleted :-( + foreach ($mw->children) { + return if "$_" =~ /^Tk::Pod/ # ->isa('Tk::Pod') + } + $mw->destroy; + }); + } else { + $mw->destroy; + } + #$mw->WidgetDump; + MainLoop(); + + exit if $self->{'forky'}; # we were the child! so exit now! + return; +} + +1; +__END__ + + +=head1 NAME + +Pod::Perldoc::ToTk - let Perldoc use Tk::Pod to render Pod + +=head1 SYNOPSIS + + perldoc -o tk Some::Modulename & + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Tk::Pod as a formatter class. + +You have to have installed Tk::Pod first, or this class won't load. + +=head1 SEE ALSO + +L<Tk::Pod>, L<Pod::Perldoc> + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org>, with significant portions copied from +F<tkpod> in the Tk::Pod dist, by Nick Ing-Simmons, Slaven Rezic, et al. + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/Perldoc/ToXml.pm b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToXml.pm new file mode 100644 index 00000000000..dd0d15cc10b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Perldoc/ToXml.pm @@ -0,0 +1,63 @@ + +require 5; +package Pod::Perldoc::ToXml; +use strict; +use warnings; +use vars qw($VERSION); + +use base qw( Pod::Simple::XMLOutStream ); + +$VERSION # so that ->VERSION is happy +# stop CPAN from seeing this + = +$Pod::Simple::XMLOutStream::VERSION; + + +sub is_pageable { 0 } +sub write_with_binmode { 0 } +sub output_extension { 'xml' } + +1; +__END__ + +=head1 NAME + +Pod::Perldoc::ToXml - let Perldoc render Pod as XML + +=head1 SYNOPSIS + + perldoc -o xml -d out.xml Some::Modulename + +=head1 DESCRIPTION + +This is a "plug-in" class that allows Perldoc to use +Pod::Simple::XMLOutStream as a formatter class. + +This is actually a Pod::Simple::XMLOutStream subclass, and inherits +all its options. + +You have to have installed Pod::Simple::XMLOutStream (from the Pod::Simple +dist), or this class won't work. + + +=head1 SEE ALSO + +L<Pod::Simple::XMLOutStream>, L<Pod::Simple>, L<Pod::Perldoc> + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Sean M. Burke C<sburke@cpan.org> + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/PlainText.pm b/Master/tlpkg/installer/perllib/Pod/PlainText.pm new file mode 100644 index 00000000000..3f5ce90d2ba --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/PlainText.pm @@ -0,0 +1,705 @@ +# Pod::PlainText -- Convert POD data to formatted ASCII text. +# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $ +# +# Copyright 1999-2000 by Russ Allbery <rra@stanford.edu> +# +# This program is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module is intended to be a replacement for Pod::Text, and attempts to +# match its output except for some specific circumstances where other +# decisions seemed to produce better output. It uses Pod::Parser and is +# designed to be very easy to subclass. + +############################################################################ +# Modules and declarations +############################################################################ + +package Pod::PlainText; + +require 5.005; + +use Carp qw(carp croak); +use Pod::Select (); + +use strict; +use vars qw(@ISA %ESCAPES $VERSION); + +# We inherit from Pod::Select instead of Pod::Parser so that we can be used +# by Pod::Usage. +@ISA = qw(Pod::Select); + +$VERSION = '2.02'; + + +############################################################################ +# Table of supported E<> escapes +############################################################################ + +# This table is taken near verbatim from Pod::PlainText in Pod::Parser, +# which got it near verbatim from the original Pod::Text. It is therefore +# credited to Tom Christiansen, and I'm glad I didn't have to write it. :) +%ESCAPES = ( + 'amp' => '&', # ampersand + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "\xC1", # capital A, acute accent + "aacute" => "\xE1", # small a, acute accent + "Acirc" => "\xC2", # capital A, circumflex accent + "acirc" => "\xE2", # small a, circumflex accent + "AElig" => "\xC6", # capital AE diphthong (ligature) + "aelig" => "\xE6", # small ae diphthong (ligature) + "Agrave" => "\xC0", # capital A, grave accent + "agrave" => "\xE0", # small a, grave accent + "Aring" => "\xC5", # capital A, ring + "aring" => "\xE5", # small a, ring + "Atilde" => "\xC3", # capital A, tilde + "atilde" => "\xE3", # small a, tilde + "Auml" => "\xC4", # capital A, dieresis or umlaut mark + "auml" => "\xE4", # small a, dieresis or umlaut mark + "Ccedil" => "\xC7", # capital C, cedilla + "ccedil" => "\xE7", # small c, cedilla + "Eacute" => "\xC9", # capital E, acute accent + "eacute" => "\xE9", # small e, acute accent + "Ecirc" => "\xCA", # capital E, circumflex accent + "ecirc" => "\xEA", # small e, circumflex accent + "Egrave" => "\xC8", # capital E, grave accent + "egrave" => "\xE8", # small e, grave accent + "ETH" => "\xD0", # capital Eth, Icelandic + "eth" => "\xF0", # small eth, Icelandic + "Euml" => "\xCB", # capital E, dieresis or umlaut mark + "euml" => "\xEB", # small e, dieresis or umlaut mark + "Iacute" => "\xCD", # capital I, acute accent + "iacute" => "\xED", # small i, acute accent + "Icirc" => "\xCE", # capital I, circumflex accent + "icirc" => "\xEE", # small i, circumflex accent + "Igrave" => "\xCD", # capital I, grave accent + "igrave" => "\xED", # small i, grave accent + "Iuml" => "\xCF", # capital I, dieresis or umlaut mark + "iuml" => "\xEF", # small i, dieresis or umlaut mark + "Ntilde" => "\xD1", # capital N, tilde + "ntilde" => "\xF1", # small n, tilde + "Oacute" => "\xD3", # capital O, acute accent + "oacute" => "\xF3", # small o, acute accent + "Ocirc" => "\xD4", # capital O, circumflex accent + "ocirc" => "\xF4", # small o, circumflex accent + "Ograve" => "\xD2", # capital O, grave accent + "ograve" => "\xF2", # small o, grave accent + "Oslash" => "\xD8", # capital O, slash + "oslash" => "\xF8", # small o, slash + "Otilde" => "\xD5", # capital O, tilde + "otilde" => "\xF5", # small o, tilde + "Ouml" => "\xD6", # capital O, dieresis or umlaut mark + "ouml" => "\xF6", # small o, dieresis or umlaut mark + "szlig" => "\xDF", # small sharp s, German (sz ligature) + "THORN" => "\xDE", # capital THORN, Icelandic + "thorn" => "\xFE", # small thorn, Icelandic + "Uacute" => "\xDA", # capital U, acute accent + "uacute" => "\xFA", # small u, acute accent + "Ucirc" => "\xDB", # capital U, circumflex accent + "ucirc" => "\xFB", # small u, circumflex accent + "Ugrave" => "\xD9", # capital U, grave accent + "ugrave" => "\xF9", # small u, grave accent + "Uuml" => "\xDC", # capital U, dieresis or umlaut mark + "uuml" => "\xFC", # small u, dieresis or umlaut mark + "Yacute" => "\xDD", # capital Y, acute accent + "yacute" => "\xFD", # small y, acute accent + "yuml" => "\xFF", # small y, dieresis or umlaut mark + + "lchevron" => "\xAB", # left chevron (double less than) + "rchevron" => "\xBB", # right chevron (double greater than) +); + + +############################################################################ +# Initialization +############################################################################ + +# Initialize the object. Must be sure to call our parent initializer. +sub initialize { + my $self = shift; + + $$self{alt} = 0 unless defined $$self{alt}; + $$self{indent} = 4 unless defined $$self{indent}; + $$self{loose} = 0 unless defined $$self{loose}; + $$self{sentence} = 0 unless defined $$self{sentence}; + $$self{width} = 76 unless defined $$self{width}; + + $$self{INDENTS} = []; # Stack of indentations. + $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. + + $self->SUPER::initialize; +} + + +############################################################################ +# Core overrides +############################################################################ + +# Called for each command paragraph. Gets the command, the associated +# paragraph, the line number, and a Pod::Paragraph object. Just dispatches +# the command to a method named the same as the command. =cut is handled +# internally by Pod::Parser. +sub command { + my $self = shift; + my $command = shift; + return if $command eq 'pod'; + return if ($$self{EXCLUDE} && $command ne 'end'); + $self->item ("\n") if defined $$self{ITEM}; + $command = 'cmd_' . $command; + $self->$command (@_); +} + +# Called for a verbatim paragraph. Gets the paragraph, the line number, and +# a Pod::Paragraph object. Just output it verbatim, but with tabs converted +# to spaces. +sub verbatim { + my $self = shift; + return if $$self{EXCLUDE}; + $self->item if defined $$self{ITEM}; + local $_ = shift; + return if /^\s*$/; + s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme; + $self->output ($_); +} + +# Called for a regular text block. Gets the paragraph, the line number, and +# a Pod::Paragraph object. Perform interpolation and output the results. +sub textblock { + my $self = shift; + return if $$self{EXCLUDE}; + $self->output ($_[0]), return if $$self{VERBATIM}; + local $_ = shift; + my $line = shift; + + # Perform a little magic to collapse multiple L<> references. This is + # here mostly for backwards-compatibility. We'll just rewrite the whole + # thing into actual text at this part, bypassing the whole internal + # sequence parsing thing. + s{ + ( + L< # A link of the form L</something>. + / + ( + [:\w]+ # The item has to be a simple word... + (\(\))? # ...or simple function. + ) + > + ( + ,?\s+(and\s+)? # Allow lots of them, conjuncted. + L< + / + ( + [:\w]+ + (\(\))? + ) + > + )+ + ) + } { + local $_ = $1; + s%L</([^>]+)>%$1%g; + my @items = split /(?:,?\s+(?:and\s+)?)/; + my $string = "the "; + my $i; + for ($i = 0; $i < @items; $i++) { + $string .= $items[$i]; + $string .= ", " if @items > 2 && $i != $#items; + $string .= " and " if ($i == $#items - 1); + } + $string .= " entries elsewhere in this document"; + $string; + }gex; + + # Now actually interpolate and output the paragraph. + $_ = $self->interpolate ($_, $line); + s/\s+$/\n/; + if (defined $$self{ITEM}) { + $self->item ($_ . "\n"); + } else { + $self->output ($self->reformat ($_ . "\n")); + } +} + +# Called for an interior sequence. Gets the command, argument, and a +# Pod::InteriorSequence object and is expected to return the resulting text. +# Calls code, bold, italic, file, and link to handle those types of +# sequences, and handles S<>, E<>, X<>, and Z<> directly. +sub interior_sequence { + my $self = shift; + my $command = shift; + local $_ = shift; + return '' if ($command eq 'X' || $command eq 'Z'); + + # Expand escapes into the actual character now, carping if invalid. + if ($command eq 'E') { + return $ESCAPES{$_} if defined $ESCAPES{$_}; + carp "Unknown escape: E<$_>"; + return "E<$_>"; + } + + # For all the other sequences, empty content produces no output. + return if $_ eq ''; + + # For S<>, compress all internal whitespace and then map spaces to \01. + # When we output the text, we'll map this back. + if ($command eq 'S') { + s/\s{2,}/ /g; + tr/ /\01/; + return $_; + } + + # Anything else needs to get dispatched to another method. + if ($command eq 'B') { return $self->seq_b ($_) } + elsif ($command eq 'C') { return $self->seq_c ($_) } + elsif ($command eq 'F') { return $self->seq_f ($_) } + elsif ($command eq 'I') { return $self->seq_i ($_) } + elsif ($command eq 'L') { return $self->seq_l ($_) } + else { carp "Unknown sequence $command<$_>" } +} + +# Called for each paragraph that's actually part of the POD. We take +# advantage of this opportunity to untabify the input. +sub preprocess_paragraph { + my $self = shift; + local $_ = shift; + 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; + $_; +} + + +############################################################################ +# Command paragraphs +############################################################################ + +# All command paragraphs take the paragraph and the line number. + +# First level heading. +sub cmd_head1 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n==== $_ ====\n\n"); + } else { + $_ .= "\n" if $$self{loose}; + $self->output ($_ . "\n"); + } +} + +# Second level heading. +sub cmd_head2 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $_ = $self->interpolate ($_, shift); + if ($$self{alt}) { + $self->output ("\n== $_ ==\n\n"); + } else { + $self->output (' ' x ($$self{indent} / 2) . $_ . "\n\n"); + } +} + +# Start a list. +sub cmd_over { + my $self = shift; + local $_ = shift; + unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } + push (@{ $$self{INDENTS} }, $$self{MARGIN}); + $$self{MARGIN} += ($_ + 0); +} + +# End a list. +sub cmd_back { + my $self = shift; + $$self{MARGIN} = pop @{ $$self{INDENTS} }; + unless (defined $$self{MARGIN}) { + carp "Unmatched =back"; + $$self{MARGIN} = $$self{indent}; + } +} + +# An individual list item. +sub cmd_item { + my $self = shift; + if (defined $$self{ITEM}) { $self->item } + local $_ = shift; + s/\s+$//; + $$self{ITEM} = $self->interpolate ($_); +} + +# Begin a block for a particular translator. Setting VERBATIM triggers +# special handling in textblock(). +sub cmd_begin { + my $self = shift; + local $_ = shift; + my ($kind) = /^(\S+)/ or return; + if ($kind eq 'text') { + $$self{VERBATIM} = 1; + } else { + $$self{EXCLUDE} = 1; + } +} + +# End a block for a particular translator. We assume that all =begin/=end +# pairs are properly closed. +sub cmd_end { + my $self = shift; + $$self{EXCLUDE} = 0; + $$self{VERBATIM} = 0; +} + +# One paragraph for a particular translator. Ignore it unless it's intended +# for text, in which case we treat it as a verbatim text block. +sub cmd_for { + my $self = shift; + local $_ = shift; + my $line = shift; + return unless s/^text\b[ \t]*\n?//; + $self->verbatim ($_, $line); +} + + +############################################################################ +# Interior sequences +############################################################################ + +# The simple formatting ones. These are here mostly so that subclasses can +# override them and do more complicated things. +sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] } +sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" } +sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] } +sub seq_i { return '*' . $_[1] . '*' } + +# The complicated one. Handle links. Since this is plain text, we can't +# actually make any real links, so this is all to figure out what text we +# print out. +sub seq_l { + my $self = shift; + local $_ = shift; + + # Smash whitespace in case we were split across multiple lines. + s/\s+/ /g; + + # If we were given any explicit text, just output it. + if (/^([^|]+)\|/) { return $1 } + + # Okay, leading and trailing whitespace isn't important; get rid of it. + s/^\s+//; + s/\s+$//; + + # Default to using the whole content of the link entry as a section + # name. Note that L<manpage/> forces a manpage interpretation, as does + # something looking like L<manpage(section)>. The latter is an + # enhancement over the original Pod::Text. + my ($manpage, $section) = ('', $_); + if (/^(?:https?|ftp|news):/) { + # a URL + return $_; + } elsif (/^"\s*(.*?)\s*"$/) { + $section = '"' . $1 . '"'; + } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) { + ($manpage, $section) = ($_, ''); + } elsif (m%/%) { + ($manpage, $section) = split (/\s*\/\s*/, $_, 2); + } + + my $text = ''; + # Now build the actual output text. + if (!length $section) { + $text = "the $manpage manpage" if length $manpage; + } elsif ($section =~ /^[:\w]+(?:\(\))?/) { + $text .= 'the ' . $section . ' entry'; + $text .= (length $manpage) ? " in the $manpage manpage" + : " elsewhere in this document"; + } else { + $section =~ s/^\"\s*//; + $section =~ s/\s*\"$//; + $text .= 'the section on "' . $section . '"'; + $text .= " in the $manpage manpage" if length $manpage; + } + $text; +} + + +############################################################################ +# List handling +############################################################################ + +# This method is called whenever an =item command is complete (in other +# words, we've seen its associated paragraph or know for certain that it +# doesn't have one). It gets the paragraph associated with the item as an +# argument. If that argument is empty, just output the item tag; if it +# contains a newline, output the item tag followed by the newline. +# Otherwise, see if there's enough room for us to output the item tag in the +# margin of the text or if we have to put it on a separate line. +sub item { + my $self = shift; + local $_ = shift; + my $tag = $$self{ITEM}; + unless (defined $tag) { + carp "item called without tag"; + return; + } + undef $$self{ITEM}; + my $indent = $$self{INDENTS}[-1]; + unless (defined $indent) { $indent = $$self{indent} } + my $space = ' ' x $indent; + $space =~ s/^ /:/ if $$self{alt}; + if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) { + my $margin = $$self{MARGIN}; + $$self{MARGIN} = $indent; + my $output = $self->reformat ($tag); + $output =~ s/\n*$/\n/; + $self->output ($output); + $$self{MARGIN} = $margin; + $self->output ($self->reformat ($_)) if /\S/; + } else { + $_ = $self->reformat ($_); + s/^ /:/ if ($$self{alt} && $indent > 0); + my $tagspace = ' ' x length $tag; + s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item"; + $self->output ($_); + } +} + + +############################################################################ +# Output formatting +############################################################################ + +# Wrap a line, indenting by the current left margin. We can't use +# Text::Wrap because it plays games with tabs. We can't use formline, even +# though we'd really like to, because it screws up non-printing characters. +# So we have to do the wrapping ourselves. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{width} - $$self{MARGIN}; + while (length > $width) { + if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + $output; +} + +# Reformat a paragraph of text for the current margin. Takes the text to +# reformat and returns the formatted text. +sub reformat { + my $self = shift; + local $_ = shift; + + # If we're trying to preserve two spaces after sentences, do some + # munging to support that. Otherwise, smash all repeated whitespace. + if ($$self{sentence}) { + s/ +$//mg; + s/\.\n/. \n/g; + s/\n/ /g; + s/ +/ /g; + } else { + s/\s+/ /g; + } + $self->wrap ($_); +} + +# Output text to the output device. +sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] } + + +############################################################################ +# Backwards compatibility +############################################################################ + +# The old Pod::Text module did everything in a pod2text() function. This +# tries to provide the same interface for legacy applications. +sub pod2text { + my @args; + + # This is really ugly; I hate doing option parsing in the middle of a + # module. But the old Pod::Text module supported passing flags to its + # entry function, so handle -a and -<number>. + while ($_[0] =~ /^-/) { + my $flag = shift; + if ($flag eq '-a') { push (@args, alt => 1) } + elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) } + else { + unshift (@_, $flag); + last; + } + } + + # Now that we know what arguments we're using, create the parser. + my $parser = Pod::PlainText->new (@args); + + # If two arguments were given, the second argument is going to be a file + # handle. That means we want to call parse_from_filehandle(), which + # means we need to turn the first argument into a file handle. Magic + # open will handle the <&STDIN case automagically. + if (defined $_[1]) { + local *IN; + unless (open (IN, $_[0])) { + croak ("Can't open $_[0] for reading: $!\n"); + return; + } + $_[0] = \*IN; + return $parser->parse_from_filehandle (@_); + } else { + return $parser->parse_from_file (@_); + } +} + + +############################################################################ +# Module return value and documentation +############################################################################ + +1; +__END__ + +=head1 NAME + +Pod::PlainText - Convert POD data to formatted ASCII text + +=head1 SYNOPSIS + + use Pod::PlainText; + my $parser = Pod::PlainText->new (sentence => 0, width => 78); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_from_filehandle; + + # Read POD from file.pod and write to file.txt. + $parser->parse_from_file ('file.pod', 'file.txt'); + +=head1 DESCRIPTION + +Pod::PlainText is a module that can convert documentation in the POD format (the +preferred language for documenting Perl) into formatted ASCII. It uses no +special formatting controls or codes whatsoever, and its output is therefore +suitable for nearly any device. + +As a derived class from Pod::Parser, Pod::PlainText supports the same methods and +interfaces. See L<Pod::Parser> for all the details; briefly, one creates a +new parser with C<Pod::PlainText-E<gt>new()> and then calls either +parse_from_filehandle() or parse_from_file(). + +new() can take options, in the form of key/value pairs, that control the +behavior of the parser. The currently recognized options are: + +=over 4 + +=item alt + +If set to a true value, selects an alternate output format that, among other +things, uses a different heading style and marks C<=item> entries with a +colon in the left margin. Defaults to false. + +=item indent + +The number of spaces to indent regular text, and the default indentation for +C<=over> blocks. Defaults to 4. + +=item loose + +If set to a true value, a blank line is printed after a C<=head1> heading. +If set to false (the default), no blank line is printed after C<=head1>, +although one is still printed after C<=head2>. This is the default because +it's the expected formatting for manual pages; if you're formatting +arbitrary text documents, setting this to true may result in more pleasing +output. + +=item sentence + +If set to a true value, Pod::PlainText will assume that each sentence ends in two +spaces, and will try to preserve that spacing. If set to false, all +consecutive whitespace in non-verbatim paragraphs is compressed into a +single space. Defaults to true. + +=item width + +The column at which to wrap text on the right-hand side. Defaults to 76. + +=back + +The standard Pod::Parser method parse_from_filehandle() takes up to two +arguments, the first being the file handle to read POD from and the second +being the file handle to write the formatted output to. The first defaults +to STDIN if not given, and the second defaults to STDOUT. The method +parse_from_file() is almost identical, except that its two arguments are the +input and output disk files instead. See L<Pod::Parser> for the specific +details. + +=head1 DIAGNOSTICS + +=over 4 + +=item Bizarre space in item + +(W) Something has gone wrong in internal C<=item> processing. This message +indicates a bug in Pod::PlainText; you should never see it. + +=item Can't open %s for reading: %s + +(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface +and the input file it was given could not be opened. + +=item Unknown escape: %s + +(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::PlainText didn't +know about. + +=item Unknown sequence: %s + +(W) The POD source contained a non-standard internal sequence (something of +the form C<XE<lt>E<gt>>) that Pod::PlainText didn't know about. + +=item Unmatched =back + +(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an +C<=over> command. + +=back + +=head1 RESTRICTIONS + +Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on +output, due to an internal implementation detail. + +=head1 NOTES + +This is a replacement for an earlier Pod::Text module written by Tom +Christiansen. It has a revamped interface, since it now uses Pod::Parser, +but an interface roughly compatible with the old Pod::Text::pod2text() +function is still available. Please change to the new calling convention, +though. + +The original Pod::Text contained code to do formatting via termcap +sequences, although it wasn't turned on by default and it was problematic to +get it to work at all. This rewrite doesn't even try to do that, but a +subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>. + +=head1 SEE ALSO + +L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>, +pod2text(1) + +=head1 AUTHOR + +Please report bugs using L<http://rt.cpan.org>. + +Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the +original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and +its conversion to Pod::Parser by Brad Appleton +E<lt>bradapp@enteract.comE<gt>. + +=cut diff --git a/Master/tlpkg/installer/perllib/Pod/Plainer.pm b/Master/tlpkg/installer/perllib/Pod/Plainer.pm new file mode 100644 index 00000000000..373e8d090af --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Plainer.pm @@ -0,0 +1,69 @@ +package Pod::Plainer; +use strict; +use Pod::Parser; +our @ISA = qw(Pod::Parser); +our $VERSION = '0.01'; + +our %E = qw( < lt > gt ); + +sub escape_ltgt { + (undef, my $text) = @_; + $text =~ s/([<>])/E<$E{$1}>/g; + $text +} + +sub simple_delimiters { + (undef, my $seq) = @_; + $seq -> left_delimiter( '<' ); + $seq -> right_delimiter( '>' ); + $seq; +} + +sub textblock { + my($parser,$text,$line) = @_; + print {$parser->output_handle()} + $parser->parse_text( + { -expand_text => q(escape_ltgt), + -expand_seq => q(simple_delimiters) }, + $text, $line ) -> raw_text(); +} + +1; + +__END__ + +=head1 NAME + +Pod::Plainer - Perl extension for converting Pod to old style Pod. + +=head1 SYNOPSIS + + use Pod::Plainer; + + my $parser = Pod::Plainer -> new (); + $parser -> parse_from_filehandle(\*STDIN); + +=head1 DESCRIPTION + +Pod::Plainer uses Pod::Parser which takes Pod with the (new) +'CE<lt>E<lt> .. E<gt>E<gt>' constructs +and returns the old(er) style with just 'CE<lt>E<gt>'; +'<' and '>' are replaced by 'EE<lt>ltE<gt>' and 'EE<lt>gtE<gt>'. + +This can be used to pre-process Pod before using tools which do not +recognise the new style Pods. + +=head2 EXPORT + +None by default. + +=head1 AUTHOR + +Robin Barker, rmb1@cise.npl.co.uk + +=head1 SEE ALSO + +See L<Pod::Parser>. + +=cut + diff --git a/Master/tlpkg/installer/perllib/Pod/Text/Color.pm b/Master/tlpkg/installer/perllib/Pod/Text/Color.pm new file mode 100644 index 00000000000..2ba31369b96 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Text/Color.pm @@ -0,0 +1,145 @@ +# Pod::Text::Color -- Convert POD data to formatted color ASCII text +# $Id: Color.pm,v 1.4 2002/07/15 05:46:00 eagle Exp $ +# +# Copyright 1999, 2001 by Russ Allbery <rra@stanford.edu> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This is just a basic proof of concept. It should later be modified to make +# better use of color, take options changing what colors are used for what +# text, and the like. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text::Color; + +require 5.004; + +use Pod::Text (); +use Term::ANSIColor qw(colored); + +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +# Don't use the CVS revision as the version, since this module is also in Perl +# core and too many things could munge CVS magic revision strings. This +# number should ideally be the same as the CVS revision in podlators, however. +$VERSION = 1.04; + + +############################################################################## +# Overrides +############################################################################## + +# Make level one headings bold. +sub cmd_head1 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $self->SUPER::cmd_head1 (colored ($_, 'bold')); +} + +# Make level two headings bold. +sub cmd_head2 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $self->SUPER::cmd_head2 (colored ($_, 'bold')); +} + +# Fix the various formatting codes. +sub seq_b { return colored ($_[1], 'bold') } +sub seq_f { return colored ($_[1], 'cyan') } +sub seq_i { return colored ($_[1], 'yellow') } + +# Output any included code in green. +sub output_code { + my ($self, $code) = @_; + $code = colored ($code, 'green'); + $self->output ($code); +} + +# We unfortunately have to override the wrapping code here, since the normal +# wrapping code gets really confused by all the escape sequences. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{width} - $$self{MARGIN}; + while (length > $width) { + if (s/^((?:(?:\e\[[\d;]+m)?[^\n]){0,$width})\s+// + || s/^((?:(?:\e\[[\d;]+m)?[^\n]){$width})//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + $output; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +Pod::Text::Color - Convert POD data to formatted color ASCII text + +=head1 SYNOPSIS + + use Pod::Text::Color; + my $parser = Pod::Text::Color->new (sentence => 0, width => 78); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_from_filehandle; + + # Read POD from file.pod and write to file.txt. + $parser->parse_from_file ('file.pod', 'file.txt'); + +=head1 DESCRIPTION + +Pod::Text::Color is a simple subclass of Pod::Text that highlights output +text using ANSI color escape sequences. Apart from the color, it in all +ways functions like Pod::Text. See L<Pod::Text> for details and available +options. + +Term::ANSIColor is used to get colors and therefore must be installed to use +this module. + +=head1 BUGS + +This is just a basic proof of concept. It should be seriously expanded to +support configurable coloration via options passed to the constructor, and +B<pod2text> should be taught about those. + +=head1 SEE ALSO + +L<Pod::Text>, L<Pod::Parser> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 1999, 2001 by Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Pod/Text/Overstrike.pm b/Master/tlpkg/installer/perllib/Pod/Text/Overstrike.pm new file mode 100644 index 00000000000..8ba918396c1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Text/Overstrike.pm @@ -0,0 +1,208 @@ +# Pod::Text::Overstrike -- Convert POD data to formatted overstrike text +# $Id: Overstrike.pm,v 1.10 2002/08/04 03:35:01 eagle Exp $ +# +# Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000 +# (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>) +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This was written because the output from: +# +# pod2text Text.pm > plain.txt; less plain.txt +# +# is not as rich as the output from +# +# pod2man Text.pm | nroff -man > fancy.txt; less fancy.txt +# +# and because both Pod::Text::Color and Pod::Text::Termcap are not device +# independent. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text::Overstrike; + +require 5.004; + +use Pod::Text (); + +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +# Don't use the CVS revision as the version, since this module is also in Perl +# core and too many things could munge CVS magic revision strings. This +# number should ideally be the same as the CVS revision in podlators, however. +$VERSION = 1.10; + + +############################################################################## +# Overrides +############################################################################## + +# Make level one headings bold, overridding any existing formatting. +sub cmd_head1 { + my ($self, $text, $line) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($self->interpolate ($text, $line)); + $text =~ s/(.)/$1\b$1/g; + $self->SUPER::cmd_head1 ($text); +} + +# Make level two headings bold, overriding any existing formatting. +sub cmd_head2 { + my ($self, $text, $line) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($self->interpolate ($text, $line)); + $text =~ s/(.)/$1\b$1/g; + $self->SUPER::cmd_head2 ($text); +} + +# Make level three headings underscored, overriding any existing formatting. +sub cmd_head3 { + my ($self, $text, $line) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($self->interpolate ($text, $line)); + $text =~ s/(.)/_\b$1/g; + $self->SUPER::cmd_head3 ($text); +} + +# Level four headings look like level three headings. +sub cmd_head4 { + my ($self, $text, $line) = @_; + $text =~ s/\s+$//; + $text = $self->strip_format ($self->interpolate ($text, $line)); + $text =~ s/(.)/_\b$1/g; + $self->SUPER::cmd_head4 ($text); +} + +# The common code for handling all headers. We have to override to avoid +# interpolating twice and because we don't want to honor alt. +sub heading { + my ($self, $text, $line, $indent, $marker) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + $text .= "\n" if $$self{loose}; + my $margin = ' ' x ($$self{margin} + $indent); + $self->output ($margin . $text . "\n"); +} + +# Fix the various formatting codes. +sub seq_b { local $_ = strip_format (@_); s/(.)/$1\b$1/g; $_ } +sub seq_f { local $_ = strip_format (@_); s/(.)/_\b$1/g; $_ } +sub seq_i { local $_ = strip_format (@_); s/(.)/_\b$1/g; $_ } + +# Output any included code in bold. +sub output_code { + my ($self, $code) = @_; + $code =~ s/(.)/$1\b$1/g; + $self->output ($code); +} + +# We unfortunately have to override the wrapping code here, since the normal +# wrapping code gets really confused by all the backspaces. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{width} - $$self{MARGIN}; + while (length > $width) { + # This regex represents a single character, that's possibly underlined + # or in bold (in which case, it's three characters; the character, a + # backspace, and a character). Use [^\n] rather than . to protect + # against odd settings of $*. + my $char = '(?:[^\n][\b])?[^\n]'; + if (s/^((?>$char){0,$width})(?:\Z|\s+)//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + $output; +} + +############################################################################## +# Utility functions +############################################################################## + +# Strip all of the formatting from a provided string, returning the stripped +# version. +sub strip_format { + my ($self, $text) = @_; + $text =~ s/(.)[\b]\1/$1/g; + $text =~ s/_[\b]//g; + return $text; +} + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +Pod::Text::Overstrike - Convert POD data to formatted overstrike text + +=head1 SYNOPSIS + + use Pod::Text::Overstrike; + my $parser = Pod::Text::Overstrike->new (sentence => 0, width => 78); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_from_filehandle; + + # Read POD from file.pod and write to file.txt. + $parser->parse_from_file ('file.pod', 'file.txt'); + +=head1 DESCRIPTION + +Pod::Text::Overstrike is a simple subclass of Pod::Text that highlights +output text using overstrike sequences, in a manner similar to nroff. +Characters in bold text are overstruck (character, backspace, character) and +characters in underlined text are converted to overstruck underscores +(underscore, backspace, character). This format was originally designed for +hardcopy terminals and/or lineprinters, yet is readable on softcopy (CRT) +terminals. + +Overstruck text is best viewed by page-at-a-time programs that take +advantage of the terminal's B<stand-out> and I<underline> capabilities, such +as the less program on Unix. + +Apart from the overstrike, it in all ways functions like Pod::Text. See +L<Pod::Text> for details and available options. + +=head1 BUGS + +Currently, the outermost formatting instruction wins, so for example +underlined text inside a region of bold text is displayed as simply bold. +There may be some better approach possible. + +=head1 SEE ALSO + +L<Pod::Text>, L<Pod::Parser> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Joe Smith <Joe.Smith@inwap.com>, using the framework created by Russ Allbery +<rra@stanford.edu>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 2000 by Joe Smith <Joe.Smith@inwap.com>. +Copyright 2001 by Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Pod/Text/Termcap.pm b/Master/tlpkg/installer/perllib/Pod/Text/Termcap.pm new file mode 100644 index 00000000000..02a7fb9842a --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Text/Termcap.pm @@ -0,0 +1,180 @@ +# Pod::Text::Termcap -- Convert POD data to ASCII text with format escapes. +# $Id: Termcap.pm,v 1.11 2003/07/09 21:52:30 eagle Exp $ +# +# Copyright 1999, 2001, 2002 by Russ Allbery <rra@stanford.edu> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This is a simple subclass of Pod::Text that overrides a few key methods to +# output the right termcap escape sequences for formatted text on the current +# terminal type. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text::Termcap; + +require 5.004; + +use Pod::Text (); +use POSIX (); +use Term::Cap; + +use strict; +use vars qw(@ISA $VERSION); + +@ISA = qw(Pod::Text); + +# Don't use the CVS revision as the version, since this module is also in Perl +# core and too many things could munge CVS magic revision strings. This +# number should ideally be the same as the CVS revision in podlators, however. +$VERSION = 1.11; + + +############################################################################## +# Overrides +############################################################################## + +# In the initialization method, grab our terminal characteristics as well as +# do all the stuff we normally do. +sub initialize { + my $self = shift; + my ($ospeed, $term, $termios); + + # $ENV{HOME} is usually not set on Windows. The default Term::Cap path + # may not work on Solaris. + my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : ''; + $ENV{TERMPATH} = $home . '/etc/termcap:/usr/share/misc/termcap' + . ':/usr/share/lib/termcap'; + + # Fall back on a hard-coded terminal speed if POSIX::Termios isn't + # available (such as on VMS). + eval { $termios = POSIX::Termios->new }; + if ($@) { + $ospeed = 9600; + } else { + $termios->getattr; + $ospeed = $termios->getospeed || 9600; + } + + # Fall back on the ANSI escape sequences if Term::Cap doesn't work. + eval { $term = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed } }; + $$self{BOLD} = $$term{_md} || "\e[1m"; + $$self{UNDL} = $$term{_us} || "\e[4m"; + $$self{NORM} = $$term{_me} || "\e[m"; + + unless (defined $$self{width}) { + $$self{width} = $ENV{COLUMNS} || $$term{_co} || 80; + $$self{width} -= 2; + } + + $self->SUPER::initialize; +} + +# Make level one headings bold. +sub cmd_head1 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $self->SUPER::cmd_head1 ("$$self{BOLD}$_$$self{NORM}"); +} + +# Make level two headings bold. +sub cmd_head2 { + my $self = shift; + local $_ = shift; + s/\s+$//; + $self->SUPER::cmd_head2 ("$$self{BOLD}$_$$self{NORM}"); +} + +# Fix up B<> and I<>. Note that we intentionally don't do F<>. +sub seq_b { my $self = shift; return "$$self{BOLD}$_[0]$$self{NORM}" } +sub seq_i { my $self = shift; return "$$self{UNDL}$_[0]$$self{NORM}" } + +# Output any included code in bold. +sub output_code { + my ($self, $code) = @_; + $self->output ($$self{BOLD} . $code . $$self{NORM}); +} + +# Override the wrapping code to igore the special sequences. +sub wrap { + my $self = shift; + local $_ = shift; + my $output = ''; + my $spaces = ' ' x $$self{MARGIN}; + my $width = $$self{width} - $$self{MARGIN}; + my $code = "(?:\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)"; + while (length > $width) { + if (s/^((?:$code?[^\n]){0,$width})\s+// + || s/^((?:$code?[^\n]){$width})//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + $output; +} + + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +Pod::Text::Termcap - Convert POD data to ASCII text with format escapes + +=head1 SYNOPSIS + + use Pod::Text::Termcap; + my $parser = Pod::Text::Termcap->new (sentence => 0, width => 78); + + # Read POD from STDIN and write to STDOUT. + $parser->parse_from_filehandle; + + # Read POD from file.pod and write to file.txt. + $parser->parse_from_file ('file.pod', 'file.txt'); + +=head1 DESCRIPTION + +Pod::Text::Termcap is a simple subclass of Pod::Text that highlights output +text using the correct termcap escape sequences for the current terminal. +Apart from the format codes, it in all ways functions like Pod::Text. See +L<Pod::Text> for details and available options. + +=head1 NOTES + +This module uses Term::Cap to retrieve the formatting escape sequences for +the current terminal, and falls back on the ECMA-48 (the same in this +regard as ANSI X3.64 and ISO 6429, the escape codes also used by DEC VT100 +terminals) if the bold, underline, and reset codes aren't set in the +termcap information. + +=head1 SEE ALSO + +L<Pod::Text>, L<Pod::Parser>, L<Term::Cap> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 1999, 2001, 2002 by Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Safe.pm b/Master/tlpkg/installer/perllib/Safe.pm new file mode 100644 index 00000000000..e2a608023ca --- /dev/null +++ b/Master/tlpkg/installer/perllib/Safe.pm @@ -0,0 +1,576 @@ +package Safe; + +use 5.003_11; +use strict; + +$Safe::VERSION = "2.12"; + +# *** Don't declare any lexicals above this point *** +# +# This function should return a closure which contains an eval that can't +# see any lexicals in scope (apart from __ExPr__ which is unavoidable) + +sub lexless_anon_sub { + # $_[0] is package; + # $_[1] is strict flag; + my $__ExPr__ = $_[2]; # must be a lexical to create the closure that + # can be used to pass the value into the safe + # world + + # Create anon sub ref in root of compartment. + # Uses a closure (on $__ExPr__) to pass in the code to be executed. + # (eval on one line to keep line numbers as expected by caller) + eval sprintf + 'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }', + $_[0], $_[1] ? 'use' : 'no'; +} + +use Carp; +use Carp::Heavy; + +use Opcode 1.01, qw( + opset opset_to_ops opmask_add + empty_opset full_opset invert_opset verify_opset + opdesc opcodes opmask define_optag opset_to_hex +); + +*ops_to_opset = \&opset; # Temporary alias for old Penguins + + +my $default_root = 0; +my $default_share = ['*_']; #, '*main::']; + +sub new { + my($class, $root, $mask) = @_; + my $obj = {}; + bless $obj, $class; + + if (defined($root)) { + croak "Can't use \"$root\" as root name" + if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/; + $obj->{Root} = $root; + $obj->{Erase} = 0; + } + else { + $obj->{Root} = "Safe::Root".$default_root++; + $obj->{Erase} = 1; + } + + # use permit/deny methods instead till interface issues resolved + # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...; + croak "Mask parameter to new no longer supported" if defined $mask; + $obj->permit_only(':default'); + + # We must share $_ and @_ with the compartment or else ops such + # as split, length and so on won't default to $_ properly, nor + # will passing argument to subroutines work (via @_). In fact, + # for reasons I don't completely understand, we need to share + # the whole glob *_ rather than $_ and @_ separately, otherwise + # @_ in non default packages within the compartment don't work. + $obj->share_from('main', $default_share); + Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04); + return $obj; +} + +sub DESTROY { + my $obj = shift; + $obj->erase('DESTROY') if $obj->{Erase}; +} + +sub erase { + my ($obj, $action) = @_; + my $pkg = $obj->root(); + my ($stem, $leaf); + + no strict 'refs'; + $pkg = "main::$pkg\::"; # expand to full symbol table name + ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; + + # The 'my $foo' is needed! Without it you get an + # 'Attempt to free unreferenced scalar' warning! + my $stem_symtab = *{$stem}{HASH}; + + #warn "erase($pkg) stem=$stem, leaf=$leaf"; + #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n"; + # ", join(', ', %$stem_symtab),"\n"; + +# delete $stem_symtab->{$leaf}; + + my $leaf_glob = $stem_symtab->{$leaf}; + my $leaf_symtab = *{$leaf_glob}{HASH}; +# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n"; + %$leaf_symtab = (); + #delete $leaf_symtab->{'__ANON__'}; + #delete $leaf_symtab->{'foo'}; + #delete $leaf_symtab->{'main::'}; +# my $foo = undef ${"$stem\::"}{"$leaf\::"}; + + if ($action and $action eq 'DESTROY') { + delete $stem_symtab->{$leaf}; + } else { + $obj->share_from('main', $default_share); + } + 1; +} + + +sub reinit { + my $obj= shift; + $obj->erase; + $obj->share_redo; +} + +sub root { + my $obj = shift; + croak("Safe root method now read-only") if @_; + return $obj->{Root}; +} + + +sub mask { + my $obj = shift; + return $obj->{Mask} unless @_; + $obj->deny_only(@_); +} + +# v1 compatibility methods +sub trap { shift->deny(@_) } +sub untrap { shift->permit(@_) } + +sub deny { + my $obj = shift; + $obj->{Mask} |= opset(@_); +} +sub deny_only { + my $obj = shift; + $obj->{Mask} = opset(@_); +} + +sub permit { + my $obj = shift; + # XXX needs testing + $obj->{Mask} &= invert_opset opset(@_); +} +sub permit_only { + my $obj = shift; + $obj->{Mask} = invert_opset opset(@_); +} + + +sub dump_mask { + my $obj = shift; + print opset_to_hex($obj->{Mask}),"\n"; +} + + + +sub share { + my($obj, @vars) = @_; + $obj->share_from(scalar(caller), \@vars); +} + +sub share_from { + my $obj = shift; + my $pkg = shift; + my $vars = shift; + my $no_record = shift || 0; + my $root = $obj->root(); + croak("vars not an array ref") unless ref $vars eq 'ARRAY'; + no strict 'refs'; + # Check that 'from' package actually exists + croak("Package \"$pkg\" does not exist") + unless keys %{"$pkg\::"}; + my $arg; + foreach $arg (@$vars) { + # catch some $safe->share($var) errors: + croak("'$arg' not a valid symbol table name") + unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/ + or $arg =~ /^\$\W$/; + my ($var, $type); + $type = $1 if ($var = $arg) =~ s/^(\W)//; + # warn "share_from $pkg $type $var"; + *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"} + : ($type eq '&') ? \&{$pkg."::$var"} + : ($type eq '$') ? \${$pkg."::$var"} + : ($type eq '@') ? \@{$pkg."::$var"} + : ($type eq '%') ? \%{$pkg."::$var"} + : ($type eq '*') ? *{$pkg."::$var"} + : croak(qq(Can't share "$type$var" of unknown type)); + } + $obj->share_record($pkg, $vars) unless $no_record or !$vars; +} + +sub share_record { + my $obj = shift; + my $pkg = shift; + my $vars = shift; + my $shares = \%{$obj->{Shares} ||= {}}; + # Record shares using keys of $obj->{Shares}. See reinit. + @{$shares}{@$vars} = ($pkg) x @$vars if @$vars; +} +sub share_redo { + my $obj = shift; + my $shares = \%{$obj->{Shares} ||= {}}; + my($var, $pkg); + while(($var, $pkg) = each %$shares) { + # warn "share_redo $pkg\:: $var"; + $obj->share_from($pkg, [ $var ], 1); + } +} +sub share_forget { + delete shift->{Shares}; +} + +sub varglob { + my ($obj, $var) = @_; + no strict 'refs'; + return *{$obj->root()."::$var"}; +} + + +sub reval { + my ($obj, $expr, $strict) = @_; + my $root = $obj->{Root}; + + my $evalsub = lexless_anon_sub($root,$strict, $expr); + return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); +} + +sub rdo { + my ($obj, $file) = @_; + my $root = $obj->{Root}; + + my $evalsub = eval + sprintf('package %s; sub { @_ = (); do $file }', $root); + return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub); +} + + +1; + +__END__ + +=head1 NAME + +Safe - Compile and execute code in restricted compartments + +=head1 SYNOPSIS + + use Safe; + + $compartment = new Safe; + + $compartment->permit(qw(time sort :browse)); + + $result = $compartment->reval($unsafe_code); + +=head1 DESCRIPTION + +The Safe extension module allows the creation of compartments +in which perl code can be evaluated. Each compartment has + +=over 8 + +=item a new namespace + +The "root" of the namespace (i.e. "main::") is changed to a +different package and code evaluated in the compartment cannot +refer to variables outside this namespace, even with run-time +glob lookups and other tricks. + +Code which is compiled outside the compartment can choose to place +variables into (or I<share> variables with) the compartment's namespace +and only that data will be visible to code evaluated in the +compartment. + +By default, the only variables shared with compartments are the +"underscore" variables $_ and @_ (and, technically, the less frequently +used %_, the _ filehandle and so on). This is because otherwise perl +operators which default to $_ will not work and neither will the +assignment of arguments to @_ on subroutine entry. + +=item an operator mask + +Each compartment has an associated "operator mask". Recall that +perl code is compiled into an internal format before execution. +Evaluating perl code (e.g. via "eval" or "do 'file'") causes +the code to be compiled into an internal format and then, +provided there was no error in the compilation, executed. +Code evaluated in a compartment compiles subject to the +compartment's operator mask. Attempting to evaluate code in a +compartment which contains a masked operator will cause the +compilation to fail with an error. The code will not be executed. + +The default operator mask for a newly created compartment is +the ':default' optag. + +It is important that you read the Opcode(3) module documentation +for more information, especially for detailed definitions of opnames, +optags and opsets. + +Since it is only at the compilation stage that the operator mask +applies, controlled access to potentially unsafe operations can +be achieved by having a handle to a wrapper subroutine (written +outside the compartment) placed into the compartment. For example, + + $cpt = new Safe; + sub wrapper { + # vet arguments and perform potentially unsafe operations + } + $cpt->share('&wrapper'); + +=back + + +=head1 WARNING + +The authors make B<no warranty>, implied or otherwise, about the +suitability of this software for safety or security purposes. + +The authors shall not in any case be liable for special, incidental, +consequential, indirect or other similar damages arising from the use +of this software. + +Your mileage will vary. If in any doubt B<do not use it>. + + +=head2 RECENT CHANGES + +The interface to the Safe module has changed quite dramatically since +version 1 (as supplied with Perl5.002). Study these pages carefully if +you have code written to use Safe version 1 because you will need to +makes changes. + + +=head2 Methods in class Safe + +To create a new compartment, use + + $cpt = new Safe; + +Optional argument is (NAMESPACE), where NAMESPACE is the root namespace +to use for the compartment (defaults to "Safe::Root0", incremented for +each new compartment). + +Note that version 1.00 of the Safe module supported a second optional +parameter, MASK. That functionality has been withdrawn pending deeper +consideration. Use the permit and deny methods described below. + +The following methods can then be used on the compartment +object returned by the above constructor. The object argument +is implicit in each case. + + +=over 8 + +=item permit (OP, ...) + +Permit the listed operators to be used when compiling code in the +compartment (in I<addition> to any operators already permitted). + +You can list opcodes by names, or use a tag name; see +L<Opcode/"Predefined Opcode Tags">. + +=item permit_only (OP, ...) + +Permit I<only> the listed operators to be used when compiling code in +the compartment (I<no> other operators are permitted). + +=item deny (OP, ...) + +Deny the listed operators from being used when compiling code in the +compartment (other operators may still be permitted). + +=item deny_only (OP, ...) + +Deny I<only> the listed operators from being used when compiling code +in the compartment (I<all> other operators will be permitted). + +=item trap (OP, ...) + +=item untrap (OP, ...) + +The trap and untrap methods are synonyms for deny and permit +respectfully. + +=item share (NAME, ...) + +This shares the variable(s) in the argument list with the compartment. +This is almost identical to exporting variables using the L<Exporter> +module. + +Each NAME must be the B<name> of a non-lexical variable, typically +with the leading type identifier included. A bareword is treated as a +function name. + +Examples of legal names are '$foo' for a scalar, '@foo' for an +array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo' +for a glob (i.e. all symbol table entries associated with "foo", +including scalar, array, hash, sub and filehandle). + +Each NAME is assumed to be in the calling package. See share_from +for an alternative method (which share uses). + +=item share_from (PACKAGE, ARRAYREF) + +This method is similar to share() but allows you to explicitly name the +package that symbols should be shared from. The symbol names (including +type characters) are supplied as an array reference. + + $safe->share_from('main', [ '$foo', '%bar', 'func' ]); + + +=item varglob (VARNAME) + +This returns a glob reference for the symbol table entry of VARNAME in +the package of the compartment. VARNAME must be the B<name> of a +variable without any leading type marker. For example, + + $cpt = new Safe 'Root'; + $Root::foo = "Hello world"; + # Equivalent version which doesn't need to know $cpt's package name: + ${$cpt->varglob('foo')} = "Hello world"; + + +=item reval (STRING) + +This evaluates STRING as perl code inside the compartment. + +The code can only see the compartment's namespace (as returned by the +B<root> method). The compartment's root package appears to be the +C<main::> package to the code inside the compartment. + +Any attempt by the code in STRING to use an operator which is not permitted +by the compartment will cause an error (at run-time of the main program +but at compile-time for the code in STRING). The error is of the form +"'%s' trapped by operation mask...". + +If an operation is trapped in this way, then the code in STRING will +not be executed. If such a trapped operation occurs or any other +compile-time or return error, then $@ is set to the error message, just +as with an eval(). + +If there is no error, then the method returns the value of the last +expression evaluated, or a return statement may be used, just as with +subroutines and B<eval()>. The context (list or scalar) is determined +by the caller as usual. + +This behaviour differs from the beta distribution of the Safe extension +where earlier versions of perl made it hard to mimic the return +behaviour of the eval() command and the context was always scalar. + +Some points to note: + +If the entereval op is permitted then the code can use eval "..." to +'hide' code which might use denied ops. This is not a major problem +since when the code tries to execute the eval it will fail because the +opmask is still in effect. However this technique would allow clever, +and possibly harmful, code to 'probe' the boundaries of what is +possible. + +Any string eval which is executed by code executing in a compartment, +or by code called from code executing in a compartment, will be eval'd +in the namespace of the compartment. This is potentially a serious +problem. + +Consider a function foo() in package pkg compiled outside a compartment +but shared with it. Assume the compartment has a root package called +'Root'. If foo() contains an eval statement like eval '$foo = 1' then, +normally, $pkg::foo will be set to 1. If foo() is called from the +compartment (by whatever means) then instead of setting $pkg::foo, the +eval will actually set $Root::pkg::foo. + +This can easily be demonstrated by using a module, such as the Socket +module, which uses eval "..." as part of an AUTOLOAD function. You can +'use' the module outside the compartment and share an (autoloaded) +function with the compartment. If an autoload is triggered by code in +the compartment, or by any code anywhere that is called by any means +from the compartment, then the eval in the Socket module's AUTOLOAD +function happens in the namespace of the compartment. Any variables +created or used by the eval'd code are now under the control of +the code in the compartment. + +A similar effect applies to I<all> runtime symbol lookups in code +called from a compartment but not compiled within it. + + + +=item rdo (FILENAME) + +This evaluates the contents of file FILENAME inside the compartment. +See above documentation on the B<reval> method for further details. + +=item root (NAMESPACE) + +This method returns the name of the package that is the root of the +compartment's namespace. + +Note that this behaviour differs from version 1.00 of the Safe module +where the root module could be used to change the namespace. That +functionality has been withdrawn pending deeper consideration. + +=item mask (MASK) + +This is a get-or-set method for the compartment's operator mask. + +With no MASK argument present, it returns the current operator mask of +the compartment. + +With the MASK argument present, it sets the operator mask for the +compartment (equivalent to calling the deny_only method). + +=back + + +=head2 Some Safety Issues + +This section is currently just an outline of some of the things code in +a compartment might do (intentionally or unintentionally) which can +have an effect outside the compartment. + +=over 8 + +=item Memory + +Consuming all (or nearly all) available memory. + +=item CPU + +Causing infinite loops etc. + +=item Snooping + +Copying private information out of your system. Even something as +simple as your user name is of value to others. Much useful information +could be gleaned from your environment variables for example. + +=item Signals + +Causing signals (especially SIGFPE and SIGALARM) to affect your process. + +Setting up a signal handler will need to be carefully considered +and controlled. What mask is in effect when a signal handler +gets called? If a user can get an imported function to get an +exception and call the user's signal handler, does that user's +restricted mask get re-instated before the handler is called? +Does an imported handler get called with its original mask or +the user's one? + +=item State Changes + +Ops such as chdir obviously effect the process as a whole and not just +the code in the compartment. Ops such as rand and srand have a similar +but more subtle effect. + +=back + +=head2 AUTHOR + +Originally designed and implemented by Malcolm Beattie, +mbeattie@sable.ox.ac.uk. + +Reworked to use the Opcode module and other changes added by Tim Bunce +E<lt>F<Tim.Bunce@ig.co.uk>E<gt>. + +=cut + diff --git a/Master/tlpkg/installer/perllib/SelectSaver.pm b/Master/tlpkg/installer/perllib/SelectSaver.pm new file mode 100644 index 00000000000..1207b88a4a2 --- /dev/null +++ b/Master/tlpkg/installer/perllib/SelectSaver.pm @@ -0,0 +1,54 @@ +package SelectSaver; + +our $VERSION = '1.01'; + +=head1 NAME + +SelectSaver - save and restore selected file handle + +=head1 SYNOPSIS + + use SelectSaver; + + { + my $saver = new SelectSaver(FILEHANDLE); + # FILEHANDLE is selected + } + # previous handle is selected + + { + my $saver = new SelectSaver; + # new handle may be selected, or not + } + # previous handle is selected + +=head1 DESCRIPTION + +A C<SelectSaver> object contains a reference to the file handle that +was selected when it was created. If its C<new> method gets an extra +parameter, then that parameter is selected; otherwise, the selected +file handle remains unchanged. + +When a C<SelectSaver> is destroyed, it re-selects the file handle +that was selected when it was created. + +=cut + +require 5.000; +use Carp; +use Symbol; + +sub new { + @_ >= 1 && @_ <= 2 or croak 'usage: new SelectSaver [FILEHANDLE]'; + my $fh = select; + my $self = bless \$fh, $_[0]; + select qualify($_[1], caller) if @_ > 1; + $self; +} + +sub DESTROY { + my $self = $_[0]; + select $$self; +} + +1; diff --git a/Master/tlpkg/installer/perllib/Term/ANSIColor.pm b/Master/tlpkg/installer/perllib/Term/ANSIColor.pm new file mode 100644 index 00000000000..9320fa06b23 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Term/ANSIColor.pm @@ -0,0 +1,472 @@ +# Term::ANSIColor -- Color screen output using ANSI escape sequences. +# $Id: ANSIColor.pm,v 1.10 2005/08/21 18:31:58 eagle Exp $ +# +# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005 +# by Russ Allbery <rra@stanford.edu> and Zenin +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# Ah, September, when the sysadmins turn colors and fall off the trees.... +# -- Dave Van Domelen + +############################################################################## +# Modules and declarations +############################################################################## + +package Term::ANSIColor; +require 5.001; + +use strict; +use vars qw($AUTOLOAD $AUTORESET $EACHLINE @ISA @EXPORT @EXPORT_OK + %EXPORT_TAGS $VERSION %attributes %attributes_r); + +use Exporter (); +@ISA = qw(Exporter); +@EXPORT = qw(color colored); +@EXPORT_OK = qw(uncolor); +%EXPORT_TAGS = (constants => [qw(CLEAR RESET BOLD DARK UNDERLINE UNDERSCORE + BLINK REVERSE CONCEALED BLACK RED GREEN + YELLOW BLUE MAGENTA CYAN WHITE ON_BLACK + ON_RED ON_GREEN ON_YELLOW ON_BLUE ON_MAGENTA + ON_CYAN ON_WHITE)]); +Exporter::export_ok_tags ('constants'); + +# Don't use the CVS revision as the version, since this module is also in Perl +# core and too many things could munge CVS magic revision strings. +$VERSION = '1.10'; + +############################################################################## +# Internal data structures +############################################################################## + +%attributes = ('clear' => 0, + 'reset' => 0, + 'bold' => 1, + 'dark' => 2, + 'underline' => 4, + 'underscore' => 4, + 'blink' => 5, + 'reverse' => 7, + 'concealed' => 8, + + 'black' => 30, 'on_black' => 40, + 'red' => 31, 'on_red' => 41, + 'green' => 32, 'on_green' => 42, + 'yellow' => 33, 'on_yellow' => 43, + 'blue' => 34, 'on_blue' => 44, + 'magenta' => 35, 'on_magenta' => 45, + 'cyan' => 36, 'on_cyan' => 46, + 'white' => 37, 'on_white' => 47); + +# Reverse lookup. Alphabetically first name for a sequence is preferred. +for (reverse sort keys %attributes) { + $attributes_r{$attributes{$_}} = $_; +} + +############################################################################## +# Implementation (constant form) +############################################################################## + +# Time to have fun! We now want to define the constant subs, which are named +# the same as the attributes above but in all caps. Each constant sub needs +# to act differently depending on whether $AUTORESET is set. Without +# autoreset: +# +# BLUE "text\n" ==> "\e[34mtext\n" +# +# If $AUTORESET is set, we should instead get: +# +# BLUE "text\n" ==> "\e[34mtext\n\e[0m" +# +# The sub also needs to handle the case where it has no arguments correctly. +# Maintaining all of this as separate subs would be a major nightmare, as well +# as duplicate the %attributes hash, so instead we define an AUTOLOAD sub to +# define the constant subs on demand. To do that, we check the name of the +# called sub against the list of attributes, and if it's an all-caps version +# of one of them, we define the sub on the fly and then run it. +# +# If the environment variable ANSI_COLORS_DISABLED is set, turn all of the +# generated subs into pass-through functions that don't add any escape +# sequences. This is to make it easier to write scripts that also work on +# systems without any ANSI support, like Windows consoles. +sub AUTOLOAD { + my $enable_colors = !defined $ENV{ANSI_COLORS_DISABLED}; + my $sub; + ($sub = $AUTOLOAD) =~ s/^.*:://; + my $attr = $attributes{lc $sub}; + if ($sub =~ /^[A-Z_]+$/ && defined $attr) { + $attr = $enable_colors ? "\e[" . $attr . 'm' : ''; + eval qq { + sub $AUTOLOAD { + if (\$AUTORESET && \@_) { + '$attr' . "\@_" . "\e[0m"; + } else { + ('$attr' . "\@_"); + } + } + }; + goto &$AUTOLOAD; + } else { + require Carp; + Carp::croak ("undefined subroutine &$AUTOLOAD called"); + } +} + +############################################################################## +# Implementation (attribute string form) +############################################################################## + +# Return the escape code for a given set of color attributes. +sub color { + return '' if defined $ENV{ANSI_COLORS_DISABLED}; + my @codes = map { split } @_; + my $attribute = ''; + foreach (@codes) { + $_ = lc $_; + unless (defined $attributes{$_}) { + require Carp; + Carp::croak ("Invalid attribute name $_"); + } + $attribute .= $attributes{$_} . ';'; + } + chop $attribute; + ($attribute ne '') ? "\e[${attribute}m" : undef; +} + +# Return a list of named color attributes for a given set of escape codes. +# Escape sequences can be given with or without enclosing "\e[" and "m". The +# empty escape sequence '' or "\e[m" gives an empty list of attrs. +sub uncolor { + my (@nums, @result); + for (@_) { + my $escape = $_; + $escape =~ s/^\e\[//; + $escape =~ s/m$//; + unless ($escape =~ /^((?:\d+;)*\d*)$/) { + require Carp; + Carp::croak ("Bad escape sequence $_"); + } + push (@nums, split (/;/, $1)); + } + for (@nums) { + $_ += 0; # Strip leading zeroes + my $name = $attributes_r{$_}; + if (!defined $name) { + require Carp; + Carp::croak ("No name for escape sequence $_" ); + } + push (@result, $name); + } + @result; +} + +# Given a string and a set of attributes, returns the string surrounded by +# escape codes to set those attributes and then clear them at the end of the +# string. The attributes can be given either as an array ref as the first +# argument or as a list as the second and subsequent arguments. If $EACHLINE +# is set, insert a reset before each occurrence of the string $EACHLINE and +# the starting attribute code after the string $EACHLINE, so that no attribute +# crosses line delimiters (this is often desirable if the output is to be +# piped to a pager or some other program). +sub colored { + my ($string, @codes); + if (ref $_[0]) { + @codes = @{+shift}; + $string = join ('', @_); + } else { + $string = shift; + @codes = @_; + } + return $string if defined $ENV{ANSI_COLORS_DISABLED}; + if (defined $EACHLINE) { + my $attr = color (@codes); + join '', + map { $_ ne $EACHLINE ? $attr . $_ . "\e[0m" : $_ } + grep { length ($_) > 0 } + split (/(\Q$EACHLINE\E)/, $string); + } else { + color (@codes) . $string . "\e[0m"; + } +} + +############################################################################## +# Module return value and documentation +############################################################################## + +# Ensure we evaluate to true. +1; +__END__ + +=head1 NAME + +Term::ANSIColor - Color screen output using ANSI escape sequences + +=head1 SYNOPSIS + + use Term::ANSIColor; + print color 'bold blue'; + print "This text is bold blue.\n"; + print color 'reset'; + print "This text is normal.\n"; + print colored ("Yellow on magenta.\n", 'yellow on_magenta'); + print "This text is normal.\n"; + print colored ['yellow on_magenta'], "Yellow on magenta.\n"; + + use Term::ANSIColor qw(uncolor); + print uncolor '01;31', "\n"; + + use Term::ANSIColor qw(:constants); + print BOLD, BLUE, "This text is in bold blue.\n", RESET; + + use Term::ANSIColor qw(:constants); + $Term::ANSIColor::AUTORESET = 1; + print BOLD BLUE "This text is in bold blue.\n"; + print "This text is normal.\n"; + +=head1 DESCRIPTION + +This module has two interfaces, one through color() and colored() and the +other through constants. It also offers the utility function uncolor(), +which has to be explicitly imported to be used (see L<SYNOPSIS>). + +color() takes any number of strings as arguments and considers them to be +space-separated lists of attributes. It then forms and returns the escape +sequence to set those attributes. It doesn't print it out, just returns it, +so you'll have to print it yourself if you want to (this is so that you can +save it as a string, pass it to something else, send it to a file handle, or +do anything else with it that you might care to). + +uncolor() performs the opposite translation, turning escape sequences +into a list of strings. + +The recognized attributes (all of which should be fairly intuitive) are +clear, reset, dark, bold, underline, underscore, blink, reverse, concealed, +black, red, green, yellow, blue, magenta, on_black, on_red, on_green, +on_yellow, on_blue, on_magenta, on_cyan, and on_white. Case is not +significant. Underline and underscore are equivalent, as are clear and +reset, so use whichever is the most intuitive to you. The color alone sets +the foreground color, and on_color sets the background color. + +Note that not all attributes are supported by all terminal types, and some +terminals may not support any of these sequences. Dark, blink, and +concealed in particular are frequently not implemented. + +Attributes, once set, last until they are unset (by sending the attribute +"reset"). Be careful to do this, or otherwise your attribute will last +after your script is done running, and people get very annoyed at having +their prompt and typing changed to weird colors. + +As an aid to help with this, colored() takes a scalar as the first argument +and any number of attribute strings as the second argument and returns the +scalar wrapped in escape codes so that the attributes will be set as +requested before the string and reset to normal after the string. +Alternately, you can pass a reference to an array as the first argument, and +then the contents of that array will be taken as attributes and color codes +and the remainder of the arguments as text to colorize. + +Normally, colored() just puts attribute codes at the beginning and end of +the string, but if you set $Term::ANSIColor::EACHLINE to some string, that +string will be considered the line delimiter and the attribute will be set +at the beginning of each line of the passed string and reset at the end of +each line. This is often desirable if the output is being sent to a program +like a pager that can be confused by attributes that span lines. Normally +you'll want to set $Term::ANSIColor::EACHLINE to C<"\n"> to use this +feature. + +Alternately, if you import C<:constants>, you can use the constants CLEAR, +RESET, BOLD, DARK, UNDERLINE, UNDERSCORE, BLINK, REVERSE, CONCEALED, BLACK, +RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE, ON_BLACK, ON_RED, ON_GREEN, +ON_YELLOW, ON_BLUE, ON_MAGENTA, ON_CYAN, and ON_WHITE directly. These are +the same as color('attribute') and can be used if you prefer typing: + + print BOLD BLUE ON_WHITE "Text\n", RESET; + +to + + print colored ("Text\n", 'bold blue on_white'); + +When using the constants, if you don't want to have to remember to add the +C<, RESET> at the end of each print line, you can set +$Term::ANSIColor::AUTORESET to a true value. Then, the display mode will +automatically be reset if there is no comma after the constant. In other +words, with that variable set: + + print BOLD BLUE "Text\n"; + +will reset the display mode afterwards, whereas: + + print BOLD, BLUE, "Text\n"; + +will not. + +The subroutine interface has the advantage over the constants interface in +that only two subroutines are exported into your namespace, versus +twenty-two in the constants interface. On the flip side, the constants +interface has the advantage of better compile time error checking, since +misspelled names of colors or attributes in calls to color() and colored() +won't be caught until runtime whereas misspelled names of constants will be +caught at compile time. So, polute your namespace with almost two dozen +subroutines that you may not even use that often, or risk a silly bug by +mistyping an attribute. Your choice, TMTOWTDI after all. + +=head1 DIAGNOSTICS + +=over 4 + +=item Bad escape sequence %s + +(F) You passed an invalid ANSI escape sequence to uncolor(). + +=item Bareword "%s" not allowed while "strict subs" in use + +(F) You probably mistyped a constant color name such as: + + $Foobar = FOOBAR . "This line should be blue\n"; + +or: + + @Foobar = FOOBAR, "This line should be blue\n"; + +This will only show up under use strict (another good reason to run under +use strict). + +=item Invalid attribute name %s + +(F) You passed an invalid attribute name to either color() or colored(). + +=item Name "%s" used only once: possible typo + +(W) You probably mistyped a constant color name such as: + + print FOOBAR "This text is color FOOBAR\n"; + +It's probably better to always use commas after constant names in order to +force the next error. + +=item No comma allowed after filehandle + +(F) You probably mistyped a constant color name such as: + + print FOOBAR, "This text is color FOOBAR\n"; + +Generating this fatal compile error is one of the main advantages of using +the constants interface, since you'll immediately know if you mistype a +color name. + +=item No name for escape sequence %s + +(F) The ANSI escape sequence passed to uncolor() contains escapes which +aren't recognized and can't be translated to names. + +=back + +=head1 ENVIRONMENT + +=over 4 + +=item ANSI_COLORS_DISABLED + +If this environment variable is set, all of the functions defined by this +module (color(), colored(), and all of the constants not previously used in +the program) will not output any escape sequences and instead will just +return the empty string or pass through the original text as appropriate. +This is intended to support easy use of scripts using this module on +platforms that don't support ANSI escape sequences. + +For it to have its proper effect, this environment variable must be set +before any color constants are used in the program. + +=back + +=head1 RESTRICTIONS + +It would be nice if one could leave off the commas around the constants +entirely and just say: + + print BOLD BLUE ON_WHITE "Text\n" RESET; + +but the syntax of Perl doesn't allow this. You need a comma after the +string. (Of course, you may consider it a bug that commas between all the +constants aren't required, in which case you may feel free to insert commas +unless you're using $Term::ANSIColor::AUTORESET.) + +For easier debuging, you may prefer to always use the commas when not +setting $Term::ANSIColor::AUTORESET so that you'll get a fatal compile error +rather than a warning. + +=head1 NOTES + +The codes generated by this module are standard terminal control codes, +complying with ECMA-48 and ISO 6429 (generally referred to as "ANSI color" +for the color codes). The non-color control codes (bold, dark, italic, +underline, and reverse) are part of the earlier ANSI X3.64 standard for +control sequences for video terminals and peripherals. + +Note that not all displays are ISO 6429-compliant, or even X3.64-compliant +(or are even attempting to be so). This module will not work as expected on +displays that do not honor these escape sequences, such as cmd.exe, 4nt.exe, +and command.com under either Windows NT or Windows 2000. They may just be +ignored, or they may display as an ESC character followed by some apparent +garbage. + +Jean Delvare provided the following table of different common terminal +emulators and their support for the various attributes and others have helped +me flesh it out: + + clear bold dark under blink reverse conceal + ------------------------------------------------------------------------ + xterm yes yes no yes bold yes yes + linux yes yes yes bold yes yes no + rxvt yes yes no yes bold/black yes no + dtterm yes yes yes yes reverse yes yes + teraterm yes reverse no yes rev/red yes no + aixterm kinda normal no yes no yes yes + PuTTY yes color no yes no yes no + Windows yes no no no no yes no + Cygwin SSH yes yes no color color color yes + Mac Terminal yes yes no yes yes yes yes + +Windows is Windows telnet, Cygwin SSH is the OpenSSH implementation under +Cygwin on Windows NT, and Mac Terminal is the Terminal application in Mac OS +X. Where the entry is other than yes or no, that emulator displays the +given attribute as something else instead. Note that on an aixterm, clear +doesn't reset colors; you have to explicitly set the colors back to what you +want. More entries in this table are welcome. + +Note that codes 3 (italic), 6 (rapid blink), and 9 (strikethrough) are +specified in ANSI X3.64 and ECMA-048 but are not commonly supported by most +displays and emulators and therefore aren't supported by this module at the +present time. ECMA-048 also specifies a large number of other attributes, +including a sequence of attributes for font changes, Fraktur characters, +double-underlining, framing, circling, and overlining. As none of these +attributes are widely supported or useful, they also aren't currently +supported by this module. + +=head1 SEE ALSO + +ECMA-048 is available on-line (at least at the time of this writing) at +L<http://www.ecma-international.org/publications/standards/ECMA-048.HTM>. + +ISO 6429 is available from ISO for a charge; the author of this module does +not own a copy of it. Since the source material for ISO 6429 was ECMA-048 +and the latter is available for free, there seems little reason to obtain +the ISO standard. + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/ansicolor/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHORS + +Original idea (using constants) by Zenin, reimplemented using subs by Russ +Allbery <rra@stanford.edu>, and then combined with the original idea by Russ +with input from Zenin. Russ Allbery now maintains this module. + +=head1 COPYRIGHT AND LICENSE + +Copyright 1996, 1997, 1998, 2000, 2001, 2002 Russ Allbery <rra@stanford.edu> +and Zenin. This program is free software; you may redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Term/Cap.pm b/Master/tlpkg/installer/perllib/Term/Cap.pm new file mode 100644 index 00000000000..b71c51ceba4 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Term/Cap.pm @@ -0,0 +1,669 @@ +package Term::Cap; + +# Since the debugger uses Term::ReadLine which uses Term::Cap, we want +# to load as few modules as possible. This includes Carp.pm. +sub carp { + require Carp; + goto &Carp::carp; +} + +sub croak { + require Carp; + goto &Carp::croak; +} + +use strict; + +use vars qw($VERSION $VMS_TERMCAP); +use vars qw($termpat $state $first $entry); + +$VERSION = '1.09'; + +# Version undef: Thu Dec 14 20:02:42 CST 1995 by sanders@bsdi.com +# Version 1.00: Thu Nov 30 23:34:29 EST 2000 by schwern@pobox.com +# [PATCH] $VERSION crusade, strict, tests, etc... all over lib/ +# Version 1.01: Wed May 23 00:00:00 CST 2001 by d-lewart@uiuc.edu +# Avoid warnings in Tgetent and Tputs +# Version 1.02: Sat Nov 17 13:50:39 GMT 2001 by jns@gellyfish.com +# Altered layout of the POD +# Added Test::More to PREREQ_PM in Makefile.PL +# Fixed no argument Tgetent() +# Version 1.03: Wed Nov 28 10:09:38 GMT 2001 +# VMS Support from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu> +# Version 1.04: Thu Nov 29 16:22:03 GMT 2001 +# Fixed warnings in test +# Version 1.05: Mon Dec 3 15:33:49 GMT 2001 +# Don't try to fall back on infocmp if it's not there. From chromatic. +# Version 1.06: Thu Dec 6 18:43:22 GMT 2001 +# Preload the default VMS termcap from Charles Lane +# Don't carp at setting OSPEED unless warnings are on. +# Version 1.07: Wed Jan 2 21:35:09 GMT 2002 +# Sanity check on infocmp output from Norton Allen +# Repaired INSTALLDIRS thanks to Michael Schwern +# Version 1.08: Sat Sep 28 11:33:15 BST 2002 +# Late loading of 'Carp' as per Michael Schwern +# Version 1.09: Tue Apr 20 12:06:51 BST 2004 +# Merged in changes from and to Core +# Core (Fri Aug 30 14:15:55 CEST 2002): +# Cope with comments lines from 'infocmp' from Brendan O'Dea +# Allow for EBCDIC in Tgoto magic test. + +# TODO: +# support Berkeley DB termcaps +# should probably be a .xs module +# force $FH into callers package? +# keep $FH in object at Tgetent time? + +=head1 NAME + +Term::Cap - Perl termcap interface + +=head1 SYNOPSIS + + require Term::Cap; + $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; + $terminal->Trequire(qw/ce ku kd/); + $terminal->Tgoto('cm', $col, $row, $FH); + $terminal->Tputs('dl', $count, $FH); + $terminal->Tpad($string, $count, $FH); + +=head1 DESCRIPTION + +These are low-level functions to extract and use capabilities from +a terminal capability (termcap) database. + +More information on the terminal capabilities will be found in the +termcap manpage on most Unix-like systems. + +=head2 METHODS + +=over 4 + +The output strings for B<Tputs> are cached for counts of 1 for performance. +B<Tgoto> and B<Tpad> do not cache. C<$self-E<gt>{_xx}> is the raw termcap +data and C<$self-E<gt>{xx}> is the cached version. + + print $terminal->Tpad($self->{_xx}, 1); + +B<Tgoto>, B<Tputs>, and B<Tpad> return the string and will also +output the string to $FH if specified. + + +=cut + +# Preload the default VMS termcap. +# If a different termcap is required then the text of one can be supplied +# in $Term::Cap::VMS_TERMCAP before Tgetent is called. + +if ( $^O eq 'VMS') { + chomp (my @entry = <DATA>); + $VMS_TERMCAP = join '', @entry; +} + +# Returns a list of termcap files to check. + +sub termcap_path { ## private + my @termcap_path; + # $TERMCAP, if it's a filespec + push(@termcap_path, $ENV{TERMCAP}) + if ((exists $ENV{TERMCAP}) && + (($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') + ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/is + : $ENV{TERMCAP} =~ /^\//s)); + if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) { + # Add the users $TERMPATH + push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH})) + } + else { + # Defaults + push(@termcap_path, + $ENV{'HOME'} . '/.termcap', + '/etc/termcap', + '/usr/share/misc/termcap', + ); + } + + # return the list of those termcaps that exist + return grep(-f, @termcap_path); +} + +=item B<Tgetent> + +Returns a blessed object reference which the user can +then use to send the control strings to the terminal using B<Tputs> +and B<Tgoto>. + +The function extracts the entry of the specified terminal +type I<TERM> (defaults to the environment variable I<TERM>) from the +database. + +It will look in the environment for a I<TERMCAP> variable. If +found, and the value does not begin with a slash, and the terminal +type name is the same as the environment string I<TERM>, the +I<TERMCAP> string is used instead of reading a termcap file. If +it does begin with a slash, the string is used as a path name of +the termcap file to search. If I<TERMCAP> does not begin with a +slash and name is different from I<TERM>, B<Tgetent> searches the +files F<$HOME/.termcap>, F</etc/termcap>, and F</usr/share/misc/termcap>, +in that order, unless the environment variable I<TERMPATH> exists, +in which case it specifies a list of file pathnames (separated by +spaces or colons) to be searched B<instead>. Whenever multiple +files are searched and a tc field occurs in the requested entry, +the entry it names must be found in the same file or one of the +succeeding files. If there is a C<:tc=...:> in the I<TERMCAP> +environment variable string it will continue the search in the +files as above. + +The extracted termcap entry is available in the object +as C<$self-E<gt>{TERMCAP}>. + +It takes a hash reference as an argument with two optional keys: + +=over 2 + +=item OSPEED + +The terminal output bit rate (often mistakenly called the baud rate) +for this terminal - if not set a warning will be generated +and it will be defaulted to 9600. I<OSPEED> can be be specified as +either a POSIX termios/SYSV termio speeds (where 9600 equals 9600) or +an old DSD-style speed ( where 13 equals 9600). + + +=item TERM + +The terminal type whose termcap entry will be used - if not supplied it will +default to $ENV{TERM}: if that is not set then B<Tgetent> will croak. + +=back + +It calls C<croak> on failure. + +=cut + +sub Tgetent { ## public -- static method + my $class = shift; + my ($self) = @_; + + $self = {} unless defined $self; + bless $self, $class; + + my($term,$cap,$search,$field,$max,$tmp_term,$TERMCAP); + local($termpat,$state,$first,$entry); # used inside eval + local $_; + + # Compute PADDING factor from OSPEED (to be used by Tpad) + if (! $self->{OSPEED}) { + if ( $^W ) { + carp "OSPEED was not set, defaulting to 9600"; + } + $self->{OSPEED} = 9600; + } + if ($self->{OSPEED} < 16) { + # delays for old style speeds + my @pad = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2); + $self->{PADDING} = $pad[$self->{OSPEED}]; + } + else { + $self->{PADDING} = 10000 / $self->{OSPEED}; + } + + $self->{TERM} = ($self->{TERM} || $ENV{TERM} || croak "TERM not set"); + $term = $self->{TERM}; # $term is the term type we are looking for + + # $tmp_term is always the next term (possibly :tc=...:) we are looking for + $tmp_term = $self->{TERM}; + # protect any pattern metacharacters in $tmp_term + $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g; + + my $foo = (exists $ENV{TERMCAP} ? $ENV{TERMCAP} : ''); + + # $entry is the extracted termcap entry + if (($foo !~ m:^/:s) && ($foo =~ m/(^|\|)${termpat}[:|]/s)) { + $entry = $foo; + } + + my @termcap_path = termcap_path(); + + unless (@termcap_path || $entry) + { + # last resort--fake up a termcap from terminfo + local $ENV{TERM} = $term; + + if ( $^O eq 'VMS' ) { + $entry = $VMS_TERMCAP; + } + else { + if ( grep { -x "$_/infocmp" } split /:/, $ENV{PATH} ) { + eval + { + my $tmp = `infocmp -C 2>/dev/null`; + $tmp =~ s/^#.*\n//gm; # remove comments + if (( $tmp !~ m%^/%s ) && ( $tmp =~ /(^|\|)${termpat}[:|]/s)) { + $entry = $tmp; + } + }; + } + } + } + + croak "Can't find a valid termcap file" unless @termcap_path || $entry; + + $state = 1; # 0 == finished + # 1 == next file + # 2 == search again + + $first = 0; # first entry (keeps term name) + + $max = 32; # max :tc=...:'s + + if ($entry) { + # ok, we're starting with $TERMCAP + $first++; # we're the first entry + # do we need to continue? + if ($entry =~ s/:tc=([^:]+):/:/) { + $tmp_term = $1; + # protect any pattern metacharacters in $tmp_term + $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g; + } + else { + $state = 0; # we're already finished + } + } + + # This is eval'ed inside the while loop for each file + $search = q{ + while (<TERMCAP>) { + next if /^\\t/ || /^#/; + if ($_ =~ m/(^|\\|)${termpat}[:|]/o) { + chomp; + s/^[^:]*:// if $first++; + $state = 0; + while ($_ =~ s/\\\\$//) { + defined(my $x = <TERMCAP>) or last; + $_ .= $x; chomp; + } + last; + } + } + defined $entry or $entry = ''; + $entry .= $_ if $_; + }; + + while ($state != 0) { + if ($state == 1) { + # get the next TERMCAP + $TERMCAP = shift @termcap_path + || croak "failed termcap lookup on $tmp_term"; + } + else { + # do the same file again + # prevent endless recursion + $max-- || croak "failed termcap loop at $tmp_term"; + $state = 1; # ok, maybe do a new file next time + } + + open(TERMCAP,"< $TERMCAP\0") || croak "open $TERMCAP: $!"; + eval $search; + die $@ if $@; + close TERMCAP; + + # If :tc=...: found then search this file again + $entry =~ s/:tc=([^:]+):/:/ && ($tmp_term = $1, $state = 2); + # protect any pattern metacharacters in $tmp_term + $termpat = $tmp_term; $termpat =~ s/(\W)/\\$1/g; + } + + croak "Can't find $term" if $entry eq ''; + $entry =~ s/:+\s*:+/:/g; # cleanup $entry + $entry =~ s/:+/:/g; # cleanup $entry + $self->{TERMCAP} = $entry; # save it + # print STDERR "DEBUG: $entry = ", $entry, "\n"; + + # Precompile $entry into the object + $entry =~ s/^[^:]*://; + foreach $field (split(/:[\s:\\]*/,$entry)) { + if (defined $field && $field =~ /^(\w\w)$/) { + $self->{'_' . $field} = 1 unless defined $self->{'_' . $1}; + # print STDERR "DEBUG: flag $1\n"; + } + elsif (defined $field && $field =~ /^(\w\w)\@/) { + $self->{'_' . $1} = ""; + # print STDERR "DEBUG: unset $1\n"; + } + elsif (defined $field && $field =~ /^(\w\w)#(.*)/) { + $self->{'_' . $1} = $2 unless defined $self->{'_' . $1}; + # print STDERR "DEBUG: numeric $1 = $2\n"; + } + elsif (defined $field && $field =~ /^(\w\w)=(.*)/) { + # print STDERR "DEBUG: string $1 = $2\n"; + next if defined $self->{'_' . ($cap = $1)}; + $_ = $2; + s/\\E/\033/g; + s/\\(\d\d\d)/pack('c',oct($1) & 0177)/eg; + s/\\n/\n/g; + s/\\r/\r/g; + s/\\t/\t/g; + s/\\b/\b/g; + s/\\f/\f/g; + s/\\\^/\377/g; + s/\^\?/\177/g; + s/\^(.)/pack('c',ord($1) & 31)/eg; + s/\\(.)/$1/g; + s/\377/^/g; + $self->{'_' . $cap} = $_; + } + # else { carp "junk in $term ignored: $field"; } + } + $self->{'_pc'} = "\0" unless defined $self->{'_pc'}; + $self->{'_bc'} = "\b" unless defined $self->{'_bc'}; + $self; +} + +# $terminal->Tpad($string, $cnt, $FH); + +=item B<Tpad> + +Outputs a literal string with appropriate padding for the current terminal. + +It takes three arguments: + +=over 2 + +=item B<$string> + +The literal string to be output. If it starts with a number and an optional +'*' then the padding will be increased by an amount relative to this number, +if the '*' is present then this amount will me multiplied by $cnt. This part +of $string is removed before output/ + +=item B<$cnt> + +Will be used to modify the padding applied to string as described above. + +=item B<$FH> + +An optional filehandle (or IO::Handle ) that output will be printed to. + +=back + +The padded $string is returned. + +=cut + +sub Tpad { ## public + my $self = shift; + my($string, $cnt, $FH) = @_; + my($decr, $ms); + + if (defined $string && $string =~ /(^[\d.]+)(\*?)(.*)$/) { + $ms = $1; + $ms *= $cnt if $2; + $string = $3; + $decr = $self->{PADDING}; + if ($decr > .1) { + $ms += $decr / 2; + $string .= $self->{'_pc'} x ($ms / $decr); + } + } + print $FH $string if $FH; + $string; +} + +# $terminal->Tputs($cap, $cnt, $FH); + +=item B<Tputs> + +Output the string for the given capability padded as appropriate without +any parameter substitution. + +It takes three arguments: + +=over 2 + +=item B<$cap> + +The capability whose string is to be output. + +=item B<$cnt> + +A count passed to Tpad to modify the padding applied to the output string. +If $cnt is zero or one then the resulting string will be cached. + +=item B<$FH> + +An optional filehandle (or IO::Handle ) that output will be printed to. + +=back + +The appropriate string for the capability will be returned. + +=cut + +sub Tputs { ## public + my $self = shift; + my($cap, $cnt, $FH) = @_; + my $string; + + $cnt = 0 unless $cnt; + + if ($cnt > 1) { + $string = Tpad($self, $self->{'_' . $cap}, $cnt); + } else { + # cache result because Tpad can be slow + unless (exists $self->{$cap}) { + $self->{$cap} = exists $self->{"_$cap"} ? + Tpad($self, $self->{"_$cap"}, 1) : undef; + } + $string = $self->{$cap}; + } + print $FH $string if $FH; + $string; +} + +# $terminal->Tgoto($cap, $col, $row, $FH); + +=item B<Tgoto> + +B<Tgoto> decodes a cursor addressing string with the given parameters. + +There are four arguments: + +=over 2 + +=item B<$cap> + +The name of the capability to be output. + +=item B<$col> + +The first value to be substituted in the output string ( usually the column +in a cursor addressing capability ) + +=item B<$row> + +The second value to be substituted in the output string (usually the row +in cursor addressing capabilities) + +=item B<$FH> + +An optional filehandle (or IO::Handle ) to which the output string will be +printed. + +=back + +Substitutions are made with $col and $row in the output string with the +following sprintf() line formats: + + %% output `%' + %d output value as in printf %d + %2 output value as in printf %2d + %3 output value as in printf %3d + %. output value as in printf %c + %+x add x to value, then do %. + + %>xy if value > x then add y, no output + %r reverse order of two parameters, no output + %i increment by one, no output + %B BCD (16*(value/10)) + (value%10), no output + + %n exclusive-or all parameters with 0140 (Datamedia 2500) + %D Reverse coding (value - 2*(value%16)), no output (Delta Data) + +The output string will be returned. + +=cut + +sub Tgoto { ## public + my $self = shift; + my($cap, $code, $tmp, $FH) = @_; + my $string = $self->{'_' . $cap}; + my $result = ''; + my $after = ''; + my $online = 0; + my @tmp = ($tmp,$code); + my $cnt = $code; + + while ($string =~ /^([^%]*)%(.)(.*)/) { + $result .= $1; + $code = $2; + $string = $3; + if ($code eq 'd') { + $result .= sprintf("%d",shift(@tmp)); + } + elsif ($code eq '.') { + $tmp = shift(@tmp); + if ($tmp == 0 || $tmp == 4 || $tmp == 10) { + if ($online) { + ++$tmp, $after .= $self->{'_up'} if $self->{'_up'}; + } + else { + ++$tmp, $after .= $self->{'_bc'}; + } + } + $result .= sprintf("%c",$tmp); + $online = !$online; + } + elsif ($code eq '+') { + $result .= sprintf("%c",shift(@tmp)+ord($string)); + $string = substr($string,1,99); + $online = !$online; + } + elsif ($code eq 'r') { + ($code,$tmp) = @tmp; + @tmp = ($tmp,$code); + $online = !$online; + } + elsif ($code eq '>') { + ($code,$tmp,$string) = unpack("CCa99",$string); + if ($tmp[$[] > $code) { + $tmp[$[] += $tmp; + } + } + elsif ($code eq '2') { + $result .= sprintf("%02d",shift(@tmp)); + $online = !$online; + } + elsif ($code eq '3') { + $result .= sprintf("%03d",shift(@tmp)); + $online = !$online; + } + elsif ($code eq 'i') { + ($code,$tmp) = @tmp; + @tmp = ($code+1,$tmp+1); + } + else { + return "OOPS"; + } + } + $string = Tpad($self, $result . $string . $after, $cnt); + print $FH $string if $FH; + $string; +} + +# $terminal->Trequire(qw/ce ku kd/); + +=item B<Trequire> + +Takes a list of capabilities as an argument and will croak if one is not +found. + +=cut + +sub Trequire { ## public + my $self = shift; + my($cap,@undefined); + foreach $cap (@_) { + push(@undefined, $cap) + unless defined $self->{'_' . $cap} && $self->{'_' . $cap}; + } + croak "Terminal does not support: (@undefined)" if @undefined; +} + +=back + +=head1 EXAMPLES + + use Term::Cap; + + # Get terminal output speed + require POSIX; + my $termios = new POSIX::Termios; + $termios->getattr; + my $ospeed = $termios->getospeed; + + # Old-style ioctl code to get ospeed: + # require 'ioctl.pl'; + # ioctl(TTY,$TIOCGETP,$sgtty); + # ($ispeed,$ospeed) = unpack('cc',$sgtty); + + # allocate and initialize a terminal structure + $terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed }; + + # require certain capabilities to be available + $terminal->Trequire(qw/ce ku kd/); + + # Output Routines, if $FH is undefined these just return the string + + # Tgoto does the % expansion stuff with the given args + $terminal->Tgoto('cm', $col, $row, $FH); + + # Tputs doesn't do any % expansion. + $terminal->Tputs('dl', $count = 1, $FH); + +=head1 COPYRIGHT AND LICENSE + +Please see the README file in distribution. + +=head1 AUTHOR + +This module is part of the core Perl distribution and is also maintained +for CPAN by Jonathan Stowe <jns@gellyfish.com>. + +=head1 SEE ALSO + +termcap(5) + +=cut + +# Below is a default entry for systems where there are terminals but no +# termcap +1; +__DATA__ +vt220|vt200|DEC VT220 in vt100 emulation mode: +am:mi:xn:xo: +co#80:li#24: +RA=\E[?7l:SA=\E[?7h: +ac=kkllmmjjnnwwqquuttvvxx:ae=\E(B:al=\E[L:as=\E(0: +bl=^G:cd=\E[J:ce=\E[K:cl=\E[H\E[2J:cm=\E[%i%d;%dH: +cr=^M:cs=\E[%i%d;%dr:dc=\E[P:dl=\E[M:do=\E[B: +ei=\E[4l:ho=\E[H:im=\E[4h: +is=\E[1;24r\E[24;1H: +nd=\E[C: +kd=\E[B::kl=\E[D:kr=\E[C:ku=\E[A:le=^H: +mb=\E[5m:md=\E[1m:me=\E[m:mr=\E[7m: +kb=\0177: +r2=\E>\E[24;1H\E[?3l\E[?4l\E[?5l\E[?7h\E[?8h\E=:rc=\E8: +sc=\E7:se=\E[27m:sf=\ED:so=\E[7m:sr=\EM:ta=^I: +ue=\E[24m:up=\E[A:us=\E[4m:ve=\E[?25h:vi=\E[?25l: + diff --git a/Master/tlpkg/installer/perllib/Term/Complete.pm b/Master/tlpkg/installer/perllib/Term/Complete.pm new file mode 100644 index 00000000000..601e4956430 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Term/Complete.pm @@ -0,0 +1,188 @@ +package Term::Complete; +require 5.000; +require Exporter; + +use strict; +our @ISA = qw(Exporter); +our @EXPORT = qw(Complete); +our $VERSION = '1.402'; + +# @(#)complete.pl,v1.2 (me@anywhere.EBay.Sun.COM) 09/23/91 + +=head1 NAME + +Term::Complete - Perl word completion module + +=head1 SYNOPSIS + + $input = Complete('prompt_string', \@completion_list); + $input = Complete('prompt_string', @completion_list); + +=head1 DESCRIPTION + +This routine provides word completion on the list of words in +the array (or array ref). + +The tty driver is put into raw mode and restored using an operating +system specific command, in UNIX-like environments C<stty>. + +The following command characters are defined: + +=over 4 + +=item E<lt>tabE<gt> + +Attempts word completion. +Cannot be changed. + +=item ^D + +Prints completion list. +Defined by I<$Term::Complete::complete>. + +=item ^U + +Erases the current input. +Defined by I<$Term::Complete::kill>. + +=item E<lt>delE<gt>, E<lt>bsE<gt> + +Erases one character. +Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>. + +=back + +=head1 DIAGNOSTICS + +Bell sounds when word completion fails. + +=head1 BUGS + +The completion character E<lt>tabE<gt> cannot be changed. + +=head1 AUTHOR + +Wayne Thompson + +=cut + +our($complete, $kill, $erase1, $erase2, $tty_raw_noecho, $tty_restore, $stty, $tty_safe_restore); +our($tty_saved_state) = ''; +CONFIG: { + $complete = "\004"; + $kill = "\025"; + $erase1 = "\177"; + $erase2 = "\010"; + foreach my $s (qw(/bin/stty /usr/bin/stty)) { + if (-x $s) { + $tty_raw_noecho = "$s raw -echo"; + $tty_restore = "$s -raw echo"; + $tty_safe_restore = $tty_restore; + $stty = $s; + last; + } + } +} + +sub Complete { + my($prompt, @cmp_lst, $cmp, $test, $l, @match); + my ($return, $r) = ("", 0); + + $return = ""; + $r = 0; + + $prompt = shift; + if (ref $_[0] || $_[0] =~ /^\*/) { + @cmp_lst = sort @{$_[0]}; + } + else { + @cmp_lst = sort(@_); + } + + # Attempt to save the current stty state, to be restored later + if (defined $stty && defined $tty_saved_state && $tty_saved_state eq '') { + $tty_saved_state = qx($stty -g 2>/dev/null); + if ($?) { + # stty -g not supported + $tty_saved_state = undef; + } + else { + $tty_saved_state =~ s/\s+$//g; + $tty_restore = qq($stty "$tty_saved_state" 2>/dev/null); + } + } + system $tty_raw_noecho if defined $tty_raw_noecho; + LOOP: { + local $_; + print($prompt, $return); + while (($_ = getc(STDIN)) ne "\r") { + CASE: { + # (TAB) attempt completion + $_ eq "\t" && do { + @match = grep(/^\Q$return/, @cmp_lst); + unless ($#match < 0) { + $l = length($test = shift(@match)); + foreach $cmp (@match) { + until (substr($cmp, 0, $l) eq substr($test, 0, $l)) { + $l--; + } + } + print("\a"); + print($test = substr($test, $r, $l - $r)); + $r = length($return .= $test); + } + last CASE; + }; + + # (^D) completion list + $_ eq $complete && do { + print(join("\r\n", '', grep(/^\Q$return/, @cmp_lst)), "\r\n"); + redo LOOP; + }; + + # (^U) kill + $_ eq $kill && do { + if ($r) { + $r = 0; + $return = ""; + print("\r\n"); + redo LOOP; + } + last CASE; + }; + + # (DEL) || (BS) erase + ($_ eq $erase1 || $_ eq $erase2) && do { + if($r) { + print("\b \b"); + chop($return); + $r--; + } + last CASE; + }; + + # printable char + ord >= 32 && do { + $return .= $_; + $r++; + print; + last CASE; + }; + } + } + } + + # system $tty_restore if defined $tty_restore; + if (defined $tty_saved_state && defined $tty_restore && defined $tty_safe_restore) + { + system $tty_restore; + if ($?) { + # tty_restore caused error + system $tty_safe_restore; + } + } + print("\n"); + $return; +} + +1; diff --git a/Master/tlpkg/installer/perllib/Term/ReadLine.pm b/Master/tlpkg/installer/perllib/Term/ReadLine.pm new file mode 100644 index 00000000000..48eb9911a6f --- /dev/null +++ b/Master/tlpkg/installer/perllib/Term/ReadLine.pm @@ -0,0 +1,399 @@ +=head1 NAME + +Term::ReadLine - Perl interface to various C<readline> packages. +If no real package is found, substitutes stubs instead of basic functions. + +=head1 SYNOPSIS + + use Term::ReadLine; + my $term = new Term::ReadLine 'Simple Perl calc'; + my $prompt = "Enter your arithmetic expression: "; + my $OUT = $term->OUT || \*STDOUT; + while ( defined ($_ = $term->readline($prompt)) ) { + my $res = eval($_); + warn $@ if $@; + print $OUT $res, "\n" unless $@; + $term->addhistory($_) if /\S/; + } + +=head1 DESCRIPTION + +This package is just a front end to some other packages. It's a stub to +set up a common interface to the various ReadLine implementations found on +CPAN (under the C<Term::ReadLine::*> namespace). + +=head1 Minimal set of supported functions + +All the supported functions should be called as methods, i.e., either as + + $term = new Term::ReadLine 'name'; + +or as + + $term->addhistory('row'); + +where $term is a return value of Term::ReadLine-E<gt>new(). + +=over 12 + +=item C<ReadLine> + +returns the actual package that executes the commands. Among possible +values are C<Term::ReadLine::Gnu>, C<Term::ReadLine::Perl>, +C<Term::ReadLine::Stub>. + +=item C<new> + +returns the handle for subsequent calls to following +functions. Argument is the name of the application. Optionally can be +followed by two arguments for C<IN> and C<OUT> filehandles. These +arguments should be globs. + +=item C<readline> + +gets an input line, I<possibly> with actual C<readline> +support. Trailing newline is removed. Returns C<undef> on C<EOF>. + +=item C<addhistory> + +adds the line to the history of input, from where it can be used if +the actual C<readline> is present. + +=item C<IN>, C<OUT> + +return the filehandles for input and output or C<undef> if C<readline> +input and output cannot be used for Perl. + +=item C<MinLine> + +If argument is specified, it is an advice on minimal size of line to +be included into history. C<undef> means do not include anything into +history. Returns the old value. + +=item C<findConsole> + +returns an array with two strings that give most appropriate names for +files for input and output using conventions C<"E<lt>$in">, C<"E<gt>out">. + +=item Attribs + +returns a reference to a hash which describes internal configuration +of the package. Names of keys in this hash conform to standard +conventions with the leading C<rl_> stripped. + +=item C<Features> + +Returns a reference to a hash with keys being features present in +current implementation. Several optional features are used in the +minimal interface: C<appname> should be present if the first argument +to C<new> is recognized, and C<minline> should be present if +C<MinLine> method is not dummy. C<autohistory> should be present if +lines are put into history automatically (maybe subject to +C<MinLine>), and C<addhistory> if C<addhistory> method is not dummy. + +If C<Features> method reports a feature C<attribs> as present, the +method C<Attribs> is not dummy. + +=back + +=head1 Additional supported functions + +Actually C<Term::ReadLine> can use some other package, that will +support a richer set of commands. + +All these commands are callable via method interface and have names +which conform to standard conventions with the leading C<rl_> stripped. + +The stub package included with the perl distribution allows some +additional methods: + +=over 12 + +=item C<tkRunning> + +makes Tk event loop run when waiting for user input (i.e., during +C<readline> method). + +=item C<ornaments> + +makes the command line stand out by using termcap data. The argument +to C<ornaments> should be 0, 1, or a string of a form +C<"aa,bb,cc,dd">. Four components of this string should be names of +I<terminal capacities>, first two will be issued to make the prompt +standout, last two to make the input line standout. + +=item C<newTTY> + +takes two arguments which are input filehandle and output filehandle. +Switches to use these filehandles. + +=back + +One can check whether the currently loaded ReadLine package supports +these methods by checking for corresponding C<Features>. + +=head1 EXPORTS + +None + +=head1 ENVIRONMENT + +The environment variable C<PERL_RL> governs which ReadLine clone is +loaded. If the value is false, a dummy interface is used. If the value +is true, it should be tail of the name of the package to use, such as +C<Perl> or C<Gnu>. + +As a special case, if the value of this variable is space-separated, +the tail might be used to disable the ornaments by setting the tail to +be C<o=0> or C<ornaments=0>. The head should be as described above, say + +If the variable is not set, or if the head of space-separated list is +empty, the best available package is loaded. + + export "PERL_RL=Perl o=0" # Use Perl ReadLine without ornaments + export "PERL_RL= o=0" # Use best available ReadLine without ornaments + +(Note that processing of C<PERL_RL> for ornaments is in the discretion of the +particular used C<Term::ReadLine::*> package). + +=head1 CAVEATS + +It seems that using Term::ReadLine from Emacs minibuffer doesn't work +quite right and one will get an error message like + + Cannot open /dev/tty for read at ... + +One possible workaround for this is to explicitly open /dev/tty like this + + open (FH, "/dev/tty" ) + or eval 'sub Term::ReadLine::findConsole { ("&STDIN", "&STDERR") }'; + die $@ if $@; + close (FH); + +or you can try using the 4-argument form of Term::ReadLine->new(). + +=cut + +use strict; + +package Term::ReadLine::Stub; +our @ISA = qw'Term::ReadLine::Tk Term::ReadLine::TermCap'; + +$DB::emacs = $DB::emacs; # To peacify -w +our @rl_term_set; +*rl_term_set = \@Term::ReadLine::TermCap::rl_term_set; + +sub PERL_UNICODE_STDIN () { 0x0001 } + +sub ReadLine {'Term::ReadLine::Stub'} +sub readline { + my $self = shift; + my ($in,$out,$str) = @$self; + my $prompt = shift; + print $out $rl_term_set[0], $prompt, $rl_term_set[1], $rl_term_set[2]; + $self->register_Tk + if not $Term::ReadLine::registered and $Term::ReadLine::toloop + and defined &Tk::DoOneEvent; + #$str = scalar <$in>; + $str = $self->get_line; + $str =~ s/^\s*\Q$prompt\E// if ($^O eq 'MacOS'); + utf8::upgrade($str) + if (${^UNICODE} & PERL_UNICODE_STDIN || defined ${^ENCODING}) && + utf8::valid($str); + print $out $rl_term_set[3]; + # bug in 5.000: chomping empty string creats length -1: + chomp $str if defined $str; + $str; +} +sub addhistory {} + +sub findConsole { + my $console; + + if ($^O eq 'MacOS') { + $console = "Dev:Console"; + } elsif (-e "/dev/tty") { + $console = "/dev/tty"; + } elsif (-e "con" or $^O eq 'MSWin32') { + $console = "con"; + } else { + $console = "sys\$command"; + } + + if (($^O eq 'amigaos') || ($^O eq 'beos') || ($^O eq 'epoc')) { + $console = undef; + } + elsif ($^O eq 'os2') { + if ($DB::emacs) { + $console = undef; + } else { + $console = "/dev/con"; + } + } + + my $consoleOUT = $console; + $console = "&STDIN" unless defined $console; + if (!defined $consoleOUT) { + $consoleOUT = defined fileno(STDERR) ? "&STDERR" : "&STDOUT"; + } + ($console,$consoleOUT); +} + +sub new { + die "method new called with wrong number of arguments" + unless @_==2 or @_==4; + #local (*FIN, *FOUT); + my ($FIN, $FOUT, $ret); + if (@_==2) { + my($console, $consoleOUT) = $_[0]->findConsole; + + open(FIN, "<$console"); + open(FOUT,">$consoleOUT"); + #OUT->autoflush(1); # Conflicts with debugger? + my $sel = select(FOUT); + $| = 1; # for DB::OUT + select($sel); + $ret = bless [\*FIN, \*FOUT]; + } else { # Filehandles supplied + $FIN = $_[2]; $FOUT = $_[3]; + #OUT->autoflush(1); # Conflicts with debugger? + my $sel = select($FOUT); + $| = 1; # for DB::OUT + select($sel); + $ret = bless [$FIN, $FOUT]; + } + if ($ret->Features->{ornaments} + and not ($ENV{PERL_RL} and $ENV{PERL_RL} =~ /\bo\w*=0/)) { + local $Term::ReadLine::termcap_nowarn = 1; + $ret->ornaments(1); + } + return $ret; +} + +sub newTTY { + my ($self, $in, $out) = @_; + $self->[0] = $in; + $self->[1] = $out; + my $sel = select($out); + $| = 1; # for DB::OUT + select($sel); +} + +sub IN { shift->[0] } +sub OUT { shift->[1] } +sub MinLine { undef } +sub Attribs { {} } + +my %features = (tkRunning => 1, ornaments => 1, 'newTTY' => 1); +sub Features { \%features } + +package Term::ReadLine; # So late to allow the above code be defined? + +our $VERSION = '1.02'; + +my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; +if ($which) { + if ($which =~ /\bgnu\b/i){ + eval "use Term::ReadLine::Gnu;"; + } elsif ($which =~ /\bperl\b/i) { + eval "use Term::ReadLine::Perl;"; + } else { + eval "use Term::ReadLine::$which;"; + } +} elsif (defined $which and $which ne '') { # Defined but false + # Do nothing fancy +} else { + eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1"; +} + +#require FileHandle; + +# To make possible switch off RL in debugger: (Not needed, work done +# in debugger). +our @ISA; +if (defined &Term::ReadLine::Gnu::readline) { + @ISA = qw(Term::ReadLine::Gnu Term::ReadLine::Stub); +} elsif (defined &Term::ReadLine::Perl::readline) { + @ISA = qw(Term::ReadLine::Perl Term::ReadLine::Stub); +} elsif (defined $which && defined &{"Term::ReadLine::$which\::readline"}) { + @ISA = "Term::ReadLine::$which"; +} else { + @ISA = qw(Term::ReadLine::Stub); +} + +package Term::ReadLine::TermCap; + +# Prompt-start, prompt-end, command-line-start, command-line-end +# -- zero-width beautifies to emit around prompt and the command line. +our @rl_term_set = ("","","",""); +# string encoded: +our $rl_term_set = ',,,'; + +our $terminal; +sub LoadTermCap { + return if defined $terminal; + + require Term::Cap; + $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. +} + +sub ornaments { + shift; + return $rl_term_set unless @_; + $rl_term_set = shift; + $rl_term_set ||= ',,,'; + $rl_term_set = 'us,ue,md,me' if $rl_term_set eq '1'; + my @ts = split /,/, $rl_term_set, 4; + eval { LoadTermCap }; + unless (defined $terminal) { + warn("Cannot find termcap: $@\n") unless $Term::ReadLine::termcap_nowarn; + $rl_term_set = ',,,'; + return; + } + @rl_term_set = map {$_ ? $terminal->Tputs($_,1) || '' : ''} @ts; + return $rl_term_set; +} + + +package Term::ReadLine::Tk; + +our($count_handle, $count_DoOne, $count_loop); +$count_handle = $count_DoOne = $count_loop = 0; + +our($giveup); +sub handle {$giveup = 1; $count_handle++} + +sub Tk_loop { + # Tk->tkwait('variable',\$giveup); # needs Widget + $count_DoOne++, Tk::DoOneEvent(0) until $giveup; + $count_loop++; + $giveup = 0; +} + +sub register_Tk { + my $self = shift; + $Term::ReadLine::registered++ + or Tk->fileevent($self->IN,'readable',\&handle); +} + +sub tkRunning { + $Term::ReadLine::toloop = $_[1] if @_ > 1; + $Term::ReadLine::toloop; +} + +sub get_c { + my $self = shift; + $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; + return getc $self->IN; +} + +sub get_line { + my $self = shift; + $self->Tk_loop if $Term::ReadLine::toloop && defined &Tk::DoOneEvent; + my $in = $self->IN; + local ($/) = "\n"; + return scalar <$in>; +} + +1; + diff --git a/Master/tlpkg/installer/perllib/Text/Abbrev.pm b/Master/tlpkg/installer/perllib/Text/Abbrev.pm new file mode 100644 index 00000000000..c6be63bcc60 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Text/Abbrev.pm @@ -0,0 +1,84 @@ +package Text::Abbrev; +require 5.005; # Probably works on earlier versions too. +require Exporter; + +our $VERSION = '1.01'; + +=head1 NAME + +abbrev - create an abbreviation table from a list + +=head1 SYNOPSIS + + use Text::Abbrev; + abbrev $hashref, LIST + + +=head1 DESCRIPTION + +Stores all unambiguous truncations of each element of LIST +as keys in the associative array referenced by C<$hashref>. +The values are the original list elements. + +=head1 EXAMPLE + + $hashref = abbrev qw(list edit send abort gripe); + + %hash = abbrev qw(list edit send abort gripe); + + abbrev $hashref, qw(list edit send abort gripe); + + abbrev(*hash, qw(list edit send abort gripe)); + +=cut + +@ISA = qw(Exporter); +@EXPORT = qw(abbrev); + +# Usage: +# abbrev \%foo, LIST; +# ... +# $long = $foo{$short}; + +sub abbrev { + my ($word, $hashref, $glob, %table, $returnvoid); + + @_ or return; # So we don't autovivify onto @_ and trigger warning + if (ref($_[0])) { # hash reference preferably + $hashref = shift; + $returnvoid = 1; + } elsif (ref \$_[0] eq 'GLOB') { # is actually a glob (deprecated) + $hashref = \%{shift()}; + $returnvoid = 1; + } + %{$hashref} = (); + + WORD: foreach $word (@_) { + for (my $len = (length $word) - 1; $len > 0; --$len) { + my $abbrev = substr($word,0,$len); + my $seen = ++$table{$abbrev}; + if ($seen == 1) { # We're the first word so far to have + # this abbreviation. + $hashref->{$abbrev} = $word; + } elsif ($seen == 2) { # We're the second word to have this + # abbreviation, so we can't use it. + delete $hashref->{$abbrev}; + } else { # We're the third word to have this + # abbreviation, so skip to the next word. + next WORD; + } + } + } + # Non-abbreviations always get entered, even if they aren't unique + foreach $word (@_) { + $hashref->{$word} = $word; + } + return if $returnvoid; + if (wantarray) { + %{$hashref}; + } else { + $hashref; + } +} + +1; diff --git a/Master/tlpkg/installer/perllib/Text/Balanced.pm b/Master/tlpkg/installer/perllib/Text/Balanced.pm new file mode 100644 index 00000000000..820ae255a71 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Text/Balanced.pm @@ -0,0 +1,2302 @@ +# EXTRACT VARIOUSLY DELIMITED TEXT SEQUENCES FROM STRINGS. +# FOR FULL DOCUMENTATION SEE Balanced.pod + +use 5.005; +use strict; + +package Text::Balanced; + +use Exporter; +use SelfLoader; +use vars qw { $VERSION @ISA %EXPORT_TAGS }; + +$VERSION = '1.95'; +@ISA = qw ( Exporter ); + +%EXPORT_TAGS = ( ALL => [ qw( + &extract_delimited + &extract_bracketed + &extract_quotelike + &extract_codeblock + &extract_variable + &extract_tagged + &extract_multiple + + &gen_delimited_pat + &gen_extract_tagged + + &delimited_pat + ) ] ); + +Exporter::export_ok_tags('ALL'); + +# PROTOTYPES + +sub _match_bracketed($$$$$$); +sub _match_variable($$); +sub _match_codeblock($$$$$$$); +sub _match_quotelike($$$$); + +# HANDLE RETURN VALUES IN VARIOUS CONTEXTS + +sub _failmsg { + my ($message, $pos) = @_; + $@ = bless { error=>$message, pos=>$pos }, "Text::Balanced::ErrorMsg"; +} + +sub _fail +{ + my ($wantarray, $textref, $message, $pos) = @_; + _failmsg $message, $pos if $message; + return ("",$$textref,"") if $wantarray; + return undef; +} + +sub _succeed +{ + $@ = undef; + my ($wantarray,$textref) = splice @_, 0, 2; + my ($extrapos, $extralen) = @_>18 ? splice(@_, -2, 2) : (0,0); + my ($startlen) = $_[5]; + my $remainderpos = $_[2]; + if ($wantarray) + { + my @res; + while (my ($from, $len) = splice @_, 0, 2) + { + push @res, substr($$textref,$from,$len); + } + if ($extralen) { # CORRECT FILLET + my $extra = substr($res[0], $extrapos-$startlen, $extralen, "\n"); + $res[1] = "$extra$res[1]"; + eval { substr($$textref,$remainderpos,0) = $extra; + substr($$textref,$extrapos,$extralen,"\n")} ; + #REARRANGE HERE DOC AND FILLET IF POSSIBLE + pos($$textref) = $remainderpos-$extralen+1; # RESET \G + } + else { + pos($$textref) = $remainderpos; # RESET \G + } + return @res; + } + else + { + my $match = substr($$textref,$_[0],$_[1]); + substr($match,$extrapos-$_[0]-$startlen,$extralen,"") if $extralen; + my $extra = $extralen + ? substr($$textref, $extrapos, $extralen)."\n" : ""; + eval {substr($$textref,$_[4],$_[1]+$_[5])=$extra} ; #CHOP OUT PREFIX & MATCH, IF POSSIBLE + pos($$textref) = $_[4]; # RESET \G + return $match; + } +} + +# BUILD A PATTERN MATCHING A SIMPLE DELIMITED STRING + +sub gen_delimited_pat($;$) # ($delimiters;$escapes) +{ + my ($dels, $escs) = @_; + return "" unless $dels =~ /\S/; + $escs = '\\' unless $escs; + $escs .= substr($escs,-1) x (length($dels)-length($escs)); + my @pat = (); + my $i; + for ($i=0; $i<length $dels; $i++) + { + my $del = quotemeta substr($dels,$i,1); + my $esc = quotemeta substr($escs,$i,1); + if ($del eq $esc) + { + push @pat, "$del(?:[^$del]*(?:(?:$del$del)[^$del]*)*)$del"; + } + else + { + push @pat, "$del(?:[^$esc$del]*(?:$esc.[^$esc$del]*)*)$del"; + } + } + my $pat = join '|', @pat; + return "(?:$pat)"; +} + +*delimited_pat = \&gen_delimited_pat; + + +# THE EXTRACTION FUNCTIONS + +sub extract_delimited (;$$$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $del = defined $_[1] ? $_[1] : qq{\'\"\`}; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $esc = defined $_[3] ? $_[3] : qq{\\}; + my $pat = gen_delimited_pat($del, $esc); + my $startpos = pos $$textref || 0; + return _fail($wantarray, $textref, "Not a delimited pattern", 0) + unless $$textref =~ m/\G($pre)($pat)/gc; + my $prelen = length($1); + my $matchpos = $startpos+$prelen; + my $endpos = pos $$textref; + return _succeed $wantarray, $textref, + $matchpos, $endpos-$matchpos, # MATCH + $endpos, length($$textref)-$endpos, # REMAINDER + $startpos, $prelen; # PREFIX +} + +sub extract_bracketed (;$$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + my $ldel = defined $_[1] ? $_[1] : '{([<'; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $wantarray = wantarray; + my $qdel = ""; + my $quotelike; + $ldel =~ s/'//g and $qdel .= q{'}; + $ldel =~ s/"//g and $qdel .= q{"}; + $ldel =~ s/`//g and $qdel .= q{`}; + $ldel =~ s/q//g and $quotelike = 1; + $ldel =~ tr/[](){}<>\0-\377/[[(({{<</ds; + my $rdel = $ldel; + unless ($rdel =~ tr/[({</])}>/) + { + return _fail $wantarray, $textref, + "Did not find a suitable bracket in delimiter: \"$_[1]\"", + 0; + } + my $posbug = pos; + $ldel = join('|', map { quotemeta $_ } split('', $ldel)); + $rdel = join('|', map { quotemeta $_ } split('', $rdel)); + pos = $posbug; + + my $startpos = pos $$textref || 0; + my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel); + + return _fail ($wantarray, $textref) unless @match; + + return _succeed ( $wantarray, $textref, + $match[2], $match[5]+2, # MATCH + @match[8,9], # REMAINDER + @match[0,1], # PREFIX + ); +} + +sub _match_bracketed($$$$$$) # $textref, $pre, $ldel, $qdel, $quotelike, $rdel +{ + my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_; + my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0); + unless ($$textref =~ m/\G$pre/gc) + { + _failmsg "Did not find prefix: /$pre/", $startpos; + return; + } + + $ldelpos = pos $$textref; + + unless ($$textref =~ m/\G($ldel)/gc) + { + _failmsg "Did not find opening bracket after prefix: \"$pre\"", + pos $$textref; + pos $$textref = $startpos; + return; + } + + my @nesting = ( $1 ); + my $textlen = length $$textref; + while (pos $$textref < $textlen) + { + next if $$textref =~ m/\G\\./gcs; + + if ($$textref =~ m/\G($ldel)/gc) + { + push @nesting, $1; + } + elsif ($$textref =~ m/\G($rdel)/gc) + { + my ($found, $brackettype) = ($1, $1); + if ($#nesting < 0) + { + _failmsg "Unmatched closing bracket: \"$found\"", + pos $$textref; + pos $$textref = $startpos; + return; + } + my $expected = pop(@nesting); + $expected =~ tr/({[</)}]>/; + if ($expected ne $brackettype) + { + _failmsg qq{Mismatched closing bracket: expected "$expected" but found "$found"}, + pos $$textref; + pos $$textref = $startpos; + return; + } + last if $#nesting < 0; + } + elsif ($qdel && $$textref =~ m/\G([$qdel])/gc) + { + $$textref =~ m/\G[^\\$1]*(?:\\.[^\\$1]*)*(\Q$1\E)/gsc and next; + _failmsg "Unmatched embedded quote ($1)", + pos $$textref; + pos $$textref = $startpos; + return; + } + elsif ($quotelike && _match_quotelike($textref,"",1,0)) + { + next; + } + + else { $$textref =~ m/\G(?:[a-zA-Z0-9]+|.)/gcs } + } + if ($#nesting>=0) + { + _failmsg "Unmatched opening bracket(s): " + . join("..",@nesting)."..", + pos $$textref; + pos $$textref = $startpos; + return; + } + + $endpos = pos $$textref; + + return ( + $startpos, $ldelpos-$startpos, # PREFIX + $ldelpos, 1, # OPENING BRACKET + $ldelpos+1, $endpos-$ldelpos-2, # CONTENTS + $endpos-1, 1, # CLOSING BRACKET + $endpos, length($$textref)-$endpos, # REMAINDER + ); +} + +sub revbracket($) +{ + my $brack = reverse $_[0]; + $brack =~ tr/[({</])}>/; + return $brack; +} + +my $XMLNAME = q{[a-zA-Z_:][a-zA-Z0-9_:.-]*}; + +sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + my $ldel = $_[1]; + my $rdel = $_[2]; + my $pre = defined $_[3] ? $_[3] : '\s*'; + my %options = defined $_[4] ? %{$_[4]} : (); + my $omode = defined $options{fail} ? $options{fail} : ''; + my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) + : defined($options{reject}) ? $options{reject} + : '' + ; + my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) + : defined($options{ignore}) ? $options{ignore} + : '' + ; + + if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + $@ = undef; + + my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); + + return _fail(wantarray, $textref) unless @match; + return _succeed wantarray, $textref, + $match[2], $match[3]+$match[5]+$match[7], # MATCH + @match[8..9,0..1,2..7]; # REM, PRE, BITS +} + +sub _match_tagged # ($$$$$$$) +{ + my ($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore) = @_; + my $rdelspec; + + my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 ); + + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg "Did not find prefix: /$pre/", pos $$textref; + goto failed; + } + + $opentagpos = pos($$textref); + + unless ($$textref =~ m/\G$ldel/gc) + { + _failmsg "Did not find opening tag: /$ldel/", pos $$textref; + goto failed; + } + + $textpos = pos($$textref); + + if (!defined $rdel) + { + $rdelspec = $&; + unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2". revbracket($1) /oes) + { + _failmsg "Unable to construct closing tag to match: $rdel", + pos $$textref; + goto failed; + } + } + else + { + $rdelspec = eval "qq{$rdel}" || do { + my $del; + for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',) + { next if $rdel =~ /\Q$_/; $del = $_; last } + unless ($del) { + use Carp; + croak "Can't interpolate right delimiter $rdel" + } + eval "qq$del$rdel$del"; + }; + } + + while (pos($$textref) < length($$textref)) + { + next if $$textref =~ m/\G\\./gc; + + if ($$textref =~ m/\G(\n[ \t]*\n)/gc ) + { + $parapos = pos($$textref) - length($1) + unless defined $parapos; + } + elsif ($$textref =~ m/\G($rdelspec)/gc ) + { + $closetagpos = pos($$textref)-length($1); + goto matched; + } + elsif ($ignore && $$textref =~ m/\G(?:$ignore)/gc) + { + next; + } + elsif ($bad && $$textref =~ m/\G($bad)/gcs) + { + pos($$textref) -= length($1); # CUT OFF WHATEVER CAUSED THE SHORTNESS + goto short if ($omode eq 'PARA' || $omode eq 'MAX'); + _failmsg "Found invalid nested tag: $1", pos $$textref; + goto failed; + } + elsif ($$textref =~ m/\G($ldel)/gc) + { + my $tag = $1; + pos($$textref) -= length($tag); # REWIND TO NESTED TAG + unless (_match_tagged(@_)) # MATCH NESTED TAG + { + goto short if $omode eq 'PARA' || $omode eq 'MAX'; + _failmsg "Found unbalanced nested tag: $tag", + pos $$textref; + goto failed; + } + } + else { $$textref =~ m/./gcs } + } + +short: + $closetagpos = pos($$textref); + goto matched if $omode eq 'MAX'; + goto failed unless $omode eq 'PARA'; + + if (defined $parapos) { pos($$textref) = $parapos } + else { $parapos = pos($$textref) } + + return ( + $startpos, $opentagpos-$startpos, # PREFIX + $opentagpos, $textpos-$opentagpos, # OPENING TAG + $textpos, $parapos-$textpos, # TEXT + $parapos, 0, # NO CLOSING TAG + $parapos, length($$textref)-$parapos, # REMAINDER + ); + +matched: + $endpos = pos($$textref); + return ( + $startpos, $opentagpos-$startpos, # PREFIX + $opentagpos, $textpos-$opentagpos, # OPENING TAG + $textpos, $closetagpos-$textpos, # TEXT + $closetagpos, $endpos-$closetagpos, # CLOSING TAG + $endpos, length($$textref)-$endpos, # REMAINDER + ); + +failed: + _failmsg "Did not find closing tag", pos $$textref unless $@; + pos($$textref) = $startpos; + return; +} + +sub extract_variable (;$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + return ("","","") unless defined $$textref; + my $pre = defined $_[1] ? $_[1] : '\s*'; + + my @match = _match_variable($textref,$pre); + + return _fail wantarray, $textref unless @match; + + return _succeed wantarray, $textref, + @match[2..3,4..5,0..1]; # MATCH, REMAINDER, PREFIX +} + +sub _match_variable($$) +{ +# $# +# $^ +# $$ + my ($textref, $pre) = @_; + my $startpos = pos($$textref) = pos($$textref)||0; + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg "Did not find prefix: /$pre/", pos $$textref; + return; + } + my $varpos = pos($$textref); + unless ($$textref =~ m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci) + { + unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc) + { + _failmsg "Did not find leading dereferencer", pos $$textref; + pos $$textref = $startpos; + return; + } + my $deref = $1; + + unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci + or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0) + or $deref eq '$#' or $deref eq '$$' ) + { + _failmsg "Bad identifier after dereferencer", pos $$textref; + pos $$textref = $startpos; + return; + } + } + + while (1) + { + next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc; + next if _match_codeblock($textref, + qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/, + qr/[({[]/, qr/[)}\]]/, + qr/[({[]/, qr/[)}\]]/, 0); + next if _match_codeblock($textref, + qr/\s*/, qr/[{[]/, qr/[}\]]/, + qr/[{[]/, qr/[}\]]/, 0); + next if _match_variable($textref,'\s*->\s*'); + next if $$textref =~ m/\G\s*->\s*\w+(?![{([])/gc; + last; + } + + my $endpos = pos($$textref); + return ($startpos, $varpos-$startpos, + $varpos, $endpos-$varpos, + $endpos, length($$textref)-$endpos + ); +} + +sub extract_codeblock (;$$$$$) +{ + my $textref = defined $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $ldel_inner = defined $_[1] ? $_[1] : '{'; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my $ldel_outer = defined $_[3] ? $_[3] : $ldel_inner; + my $rd = $_[4]; + my $rdel_inner = $ldel_inner; + my $rdel_outer = $ldel_outer; + my $posbug = pos; + for ($ldel_inner, $ldel_outer) { tr/[]()<>{}\0-\377/[[((<<{{/ds } + for ($rdel_inner, $rdel_outer) { tr/[]()<>{}\0-\377/]]))>>}}/ds } + for ($ldel_inner, $ldel_outer, $rdel_inner, $rdel_outer) + { + $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')' + } + pos = $posbug; + + my @match = _match_codeblock($textref, $pre, + $ldel_outer, $rdel_outer, + $ldel_inner, $rdel_inner, + $rd); + return _fail($wantarray, $textref) unless @match; + return _succeed($wantarray, $textref, + @match[2..3,4..5,0..1] # MATCH, REMAINDER, PREFIX + ); + +} + +sub _match_codeblock($$$$$$$) +{ + my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_; + my $startpos = pos($$textref) = pos($$textref) || 0; + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg qq{Did not match prefix /$pre/ at"} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + return; + } + my $codepos = pos($$textref); + unless ($$textref =~ m/\G($ldel_outer)/gc) # OUTERMOST DELIMITER + { + _failmsg qq{Did not find expected opening bracket at "} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + my $closing = $1; + $closing =~ tr/([<{/)]>}/; + my $matched; + my $patvalid = 1; + while (pos($$textref) < length($$textref)) + { + $matched = ''; + if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc) + { + $patvalid = 0; + next; + } + + if ($$textref =~ m/\G\s*#.*/gc) + { + next; + } + + if ($$textref =~ m/\G\s*($rdel_outer)/gc) + { + unless ($matched = ($closing && $1 eq $closing) ) + { + next if $1 eq '>'; # MIGHT BE A "LESS THAN" + _failmsg q{Mismatched closing bracket at "} . + substr($$textref,pos($$textref),20) . + qq{...". Expected '$closing'}, + pos $$textref; + } + last; + } + + if (_match_variable($textref,'\s*') || + _match_quotelike($textref,'\s*',$patvalid,$patvalid) ) + { + $patvalid = 0; + next; + } + + + # NEED TO COVER MANY MORE CASES HERE!!! + if ($$textref =~ m#\G\s*(?!$ldel_inner) + ( [-+*x/%^&|.]=? + | [!=]~ + | =(?!>) + | (\*\*|&&|\|\||<<|>>)=? + | split|grep|map|return + | [([] + )#gcx) + { + $patvalid = 1; + next; + } + + if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) ) + { + $patvalid = 1; + next; + } + + if ($$textref =~ m/\G\s*$ldel_outer/gc) + { + _failmsg q{Improperly nested codeblock at "} . + substr($$textref,pos($$textref),20) . + q{..."}, + pos $$textref; + last; + } + + $patvalid = 0; + $$textref =~ m/\G\s*(\w+|[-=>]>|.|\Z)/gc; + } + continue { $@ = undef } + + unless ($matched) + { + _failmsg 'No match found for opening bracket', pos $$textref + unless $@; + return; + } + + my $endpos = pos($$textref); + return ( $startpos, $codepos-$startpos, + $codepos, $endpos-$codepos, + $endpos, length($$textref)-$endpos, + ); +} + + +my %mods = ( + 'none' => '[cgimsox]*', + 'm' => '[cgimsox]*', + 's' => '[cegimsox]*', + 'tr' => '[cds]*', + 'y' => '[cds]*', + 'qq' => '', + 'qx' => '', + 'qw' => '', + 'qr' => '[imsx]*', + 'q' => '', + ); + +sub extract_quotelike (;$$) +{ + my $textref = $_[0] ? \$_[0] : \$_; + my $wantarray = wantarray; + my $pre = defined $_[1] ? $_[1] : '\s*'; + + my @match = _match_quotelike($textref,$pre,1,0); + return _fail($wantarray, $textref) unless @match; + return _succeed($wantarray, $textref, + $match[2], $match[18]-$match[2], # MATCH + @match[18,19], # REMAINDER + @match[0,1], # PREFIX + @match[2..17], # THE BITS + @match[20,21], # ANY FILLET? + ); +}; + +sub _match_quotelike($$$$) # ($textref, $prepat, $allow_raw_match) +{ + my ($textref, $pre, $rawmatch, $qmark) = @_; + + my ($textlen,$startpos, + $oppos, + $preld1pos,$ld1pos,$str1pos,$rd1pos, + $preld2pos,$ld2pos,$str2pos,$rd2pos, + $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 ); + + unless ($$textref =~ m/\G($pre)/gc) + { + _failmsg qq{Did not find prefix /$pre/ at "} . + substr($$textref, pos($$textref), 20) . + q{..."}, + pos $$textref; + return; + } + $oppos = pos($$textref); + + my $initial = substr($$textref,$oppos,1); + + if ($initial && $initial =~ m|^[\"\'\`]| + || $rawmatch && $initial =~ m|^/| + || $qmark && $initial =~ m|^\?|) + { + unless ($$textref =~ m/ \Q$initial\E [^\\$initial]* (\\.[^\\$initial]*)* \Q$initial\E /gcsx) + { + _failmsg qq{Did not find closing delimiter to match '$initial' at "} . + substr($$textref, $oppos, 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + $modpos= pos($$textref); + $rd1pos = $modpos-1; + + if ($initial eq '/' || $initial eq '?') + { + $$textref =~ m/\G$mods{none}/gc + } + + my $endpos = pos($$textref); + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, 0, # NO OPERATOR + $oppos, 1, # LEFT DEL + $oppos+1, $rd1pos-$oppos-1, # STR/PAT + $rd1pos, 1, # RIGHT DEL + $modpos, 0, # NO 2ND LDEL + $modpos, 0, # NO 2ND STR + $modpos, 0, # NO 2ND RDEL + $modpos, $endpos-$modpos, # MODIFIERS + $endpos, $textlen-$endpos, # REMAINDER + ); + } + + unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc) + { + _failmsg q{No quotelike operator found after prefix at "} . + substr($$textref, pos($$textref), 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + + my $op = $1; + $preld1pos = pos($$textref); + if ($op eq '<<') { + $ld1pos = pos($$textref); + my $label; + if ($$textref =~ m{\G([A-Za-z_]\w*)}gc) { + $label = $1; + } + elsif ($$textref =~ m{ \G ' ([^'\\]* (?:\\.[^'\\]*)*) ' + | \G " ([^"\\]* (?:\\.[^"\\]*)*) " + | \G ` ([^`\\]* (?:\\.[^`\\]*)*) ` + }gcsx) { + $label = $+; + } + else { + $label = ""; + } + my $extrapos = pos($$textref); + $$textref =~ m{.*\n}gc; + $str1pos = pos($$textref); + unless ($$textref =~ m{.*?\n(?=$label\n)}gc) { + _failmsg qq{Missing here doc terminator ('$label') after "} . + substr($$textref, $startpos, 20) . + q{..."}, + pos $$textref; + pos $$textref = $startpos; + return; + } + $rd1pos = pos($$textref); + $$textref =~ m{$label\n}gc; + $ld2pos = pos($$textref); + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, length($op), # OPERATOR + $ld1pos, $extrapos-$ld1pos, # LEFT DEL + $str1pos, $rd1pos-$str1pos, # STR/PAT + $rd1pos, $ld2pos-$rd1pos, # RIGHT DEL + $ld2pos, 0, # NO 2ND LDEL + $ld2pos, 0, # NO 2ND STR + $ld2pos, 0, # NO 2ND RDEL + $ld2pos, 0, # NO MODIFIERS + $ld2pos, $textlen-$ld2pos, # REMAINDER + $extrapos, $str1pos-$extrapos, # FILLETED BIT + ); + } + + $$textref =~ m/\G\s*/gc; + $ld1pos = pos($$textref); + $str1pos = $ld1pos+1; + + unless ($$textref =~ m/\G(\S)/gc) # SHOULD USE LOOKAHEAD + { + _failmsg "No block delimiter found after quotelike $op", + pos $$textref; + pos $$textref = $startpos; + return; + } + pos($$textref) = $ld1pos; # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN + my ($ldel1, $rdel1) = ("\Q$1","\Q$1"); + if ($ldel1 =~ /[[(<{]/) + { + $rdel1 =~ tr/[({</])}>/; + _match_bracketed($textref,"",$ldel1,"","",$rdel1) + || do { pos $$textref = $startpos; return }; + } + else + { + $$textref =~ /$ldel1[^\\$ldel1]*(\\.[^\\$ldel1]*)*$ldel1/gcs + || do { pos $$textref = $startpos; return }; + } + $ld2pos = $rd1pos = pos($$textref)-1; + + my $second_arg = $op =~ /s|tr|y/ ? 1 : 0; + if ($second_arg) + { + my ($ldel2, $rdel2); + if ($ldel1 =~ /[[(<{]/) + { + unless ($$textref =~ /\G\s*(\S)/gc) # SHOULD USE LOOKAHEAD + { + _failmsg "Missing second block for quotelike $op", + pos $$textref; + pos $$textref = $startpos; + return; + } + $ldel2 = $rdel2 = "\Q$1"; + $rdel2 =~ tr/[({</])}>/; + } + else + { + $ldel2 = $rdel2 = $ldel1; + } + $str2pos = $ld2pos+1; + + if ($ldel2 =~ /[[(<{]/) + { + pos($$textref)--; # OVERCOME BROKEN LOOKAHEAD + _match_bracketed($textref,"",$ldel2,"","",$rdel2) + || do { pos $$textref = $startpos; return }; + } + else + { + $$textref =~ /[^\\$ldel2]*(\\.[^\\$ldel2]*)*$ldel2/gcs + || do { pos $$textref = $startpos; return }; + } + $rd2pos = pos($$textref)-1; + } + else + { + $ld2pos = $str2pos = $rd2pos = $rd1pos; + } + + $modpos = pos $$textref; + + $$textref =~ m/\G($mods{$op})/gc; + my $endpos = pos $$textref; + + return ( + $startpos, $oppos-$startpos, # PREFIX + $oppos, length($op), # OPERATOR + $ld1pos, 1, # LEFT DEL + $str1pos, $rd1pos-$str1pos, # STR/PAT + $rd1pos, 1, # RIGHT DEL + $ld2pos, $second_arg, # 2ND LDEL (MAYBE) + $str2pos, $rd2pos-$str2pos, # 2ND STR (MAYBE) + $rd2pos, $second_arg, # 2ND RDEL (MAYBE) + $modpos, $endpos-$modpos, # MODIFIERS + $endpos, $textlen-$endpos, # REMAINDER + ); +} + +my $def_func = +[ + sub { extract_variable($_[0], '') }, + sub { extract_quotelike($_[0],'') }, + sub { extract_codeblock($_[0],'{}','') }, +]; + +sub extract_multiple (;$$$$) # ($text, $functions_ref, $max_fields, $ignoreunknown) +{ + my $textref = defined($_[0]) ? \$_[0] : \$_; + my $posbug = pos; + my ($lastpos, $firstpos); + my @fields = (); + + #for ($$textref) + { + my @func = defined $_[1] ? @{$_[1]} : @{$def_func}; + my $max = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000; + my $igunk = $_[3]; + + pos $$textref ||= 0; + + unless (wantarray) + { + use Carp; + carp "extract_multiple reset maximal count to 1 in scalar context" + if $^W && defined($_[2]) && $max > 1; + $max = 1 + } + + my $unkpos; + my $func; + my $class; + + my @class; + foreach $func ( @func ) + { + if (ref($func) eq 'HASH') + { + push @class, (keys %$func)[0]; + $func = (values %$func)[0]; + } + else + { + push @class, undef; + } + } + + FIELD: while (pos($$textref) < length($$textref)) + { + my ($field, $rem); + my @bits; + foreach my $i ( 0..$#func ) + { + my $pref; + $func = $func[$i]; + $class = $class[$i]; + $lastpos = pos $$textref; + if (ref($func) eq 'CODE') + { ($field,$rem,$pref) = @bits = $func->($$textref); + # print "[$field|$rem]" if $field; + } + elsif (ref($func) eq 'Text::Balanced::Extractor') + { @bits = $field = $func->extract($$textref) } + elsif( $$textref =~ m/\G$func/gc ) + { @bits = $field = defined($1) ? $1 : $& } + $pref ||= ""; + if (defined($field) && length($field)) + { + if (!$igunk) { + $unkpos = pos $$textref + if length($pref) && !defined($unkpos); + if (defined $unkpos) + { + push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref; + $firstpos = $unkpos unless defined $firstpos; + undef $unkpos; + last FIELD if @fields == $max; + } + } + push @fields, $class + ? bless (\$field, $class) + : $field; + $firstpos = $lastpos unless defined $firstpos; + $lastpos = pos $$textref; + last FIELD if @fields == $max; + next FIELD; + } + } + if ($$textref =~ /\G(.)/gcs) + { + $unkpos = pos($$textref)-1 + unless $igunk || defined $unkpos; + } + } + + if (defined $unkpos) + { + push @fields, substr($$textref, $unkpos); + $firstpos = $unkpos unless defined $firstpos; + $lastpos = length $$textref; + } + last; + } + + pos $$textref = $lastpos; + return @fields if wantarray; + + $firstpos ||= 0; + eval { substr($$textref,$firstpos,$lastpos-$firstpos)=""; + pos $$textref = $firstpos }; + return $fields[0]; +} + + +sub gen_extract_tagged # ($opentag, $closetag, $pre, \%options) +{ + my $ldel = $_[0]; + my $rdel = $_[1]; + my $pre = defined $_[2] ? $_[2] : '\s*'; + my %options = defined $_[3] ? %{$_[3]} : (); + my $omode = defined $options{fail} ? $options{fail} : ''; + my $bad = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}}) + : defined($options{reject}) ? $options{reject} + : '' + ; + my $ignore = ref($options{ignore}) eq 'ARRAY' ? join('|', @{$options{ignore}}) + : defined($options{ignore}) ? $options{ignore} + : '' + ; + + if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|[^>])*>'; } + + my $posbug = pos; + for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ } + pos = $posbug; + + my $closure = sub + { + my $textref = defined $_[0] ? \$_[0] : \$_; + my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore); + + return _fail(wantarray, $textref) unless @match; + return _succeed wantarray, $textref, + $match[2], $match[3]+$match[5]+$match[7], # MATCH + @match[8..9,0..1,2..7]; # REM, PRE, BITS + }; + + bless $closure, 'Text::Balanced::Extractor'; +} + +package Text::Balanced::Extractor; + +sub extract($$) # ($self, $text) +{ + &{$_[0]}($_[1]); +} + +package Text::Balanced::ErrorMsg; + +use overload '""' => sub { "$_[0]->{error}, detected at offset $_[0]->{pos}" }; + +1; + +__END__ + +=head1 NAME + +Text::Balanced - Extract delimited text sequences from strings. + + +=head1 SYNOPSIS + + use Text::Balanced qw ( + extract_delimited + extract_bracketed + extract_quotelike + extract_codeblock + extract_variable + extract_tagged + extract_multiple + + gen_delimited_pat + gen_extract_tagged + ); + + # Extract the initial substring of $text that is delimited by + # two (unescaped) instances of the first character in $delim. + + ($extracted, $remainder) = extract_delimited($text,$delim); + + + # Extract the initial substring of $text that is bracketed + # with a delimiter(s) specified by $delim (where the string + # in $delim contains one or more of '(){}[]<>'). + + ($extracted, $remainder) = extract_bracketed($text,$delim); + + + # Extract the initial substring of $text that is bounded by + # an XML tag. + + ($extracted, $remainder) = extract_tagged($text); + + + # Extract the initial substring of $text that is bounded by + # a C<BEGIN>...C<END> pair. Don't allow nested C<BEGIN> tags + + ($extracted, $remainder) = + extract_tagged($text,"BEGIN","END",undef,{bad=>["BEGIN"]}); + + + # Extract the initial substring of $text that represents a + # Perl "quote or quote-like operation" + + ($extracted, $remainder) = extract_quotelike($text); + + + # Extract the initial substring of $text that represents a block + # of Perl code, bracketed by any of character(s) specified by $delim + # (where the string $delim contains one or more of '(){}[]<>'). + + ($extracted, $remainder) = extract_codeblock($text,$delim); + + + # Extract the initial substrings of $text that would be extracted by + # one or more sequential applications of the specified functions + # or regular expressions + + @extracted = extract_multiple($text, + [ \&extract_bracketed, + \&extract_quotelike, + \&some_other_extractor_sub, + qr/[xyz]*/, + 'literal', + ]); + +# Create a string representing an optimized pattern (a la Friedl) +# that matches a substring delimited by any of the specified characters +# (in this case: any type of quote or a slash) + + $patstring = gen_delimited_pat(q{'"`/}); + + +# Generate a reference to an anonymous sub that is just like extract_tagged +# but pre-compiled and optimized for a specific pair of tags, and consequently +# much faster (i.e. 3 times faster). It uses qr// for better performance on +# repeated calls, so it only works under Perl 5.005 or later. + + $extract_head = gen_extract_tagged('<HEAD>','</HEAD>'); + + ($extracted, $remainder) = $extract_head->($text); + + +=head1 DESCRIPTION + +The various C<extract_...> subroutines may be used to +extract a delimited substring, possibly after skipping a +specified prefix string. By default, that prefix is +optional whitespace (C</\s*/>), but you can change it to whatever +you wish (see below). + +The substring to be extracted must appear at the +current C<pos> location of the string's variable +(or at index zero, if no C<pos> position is defined). +In other words, the C<extract_...> subroutines I<don't> +extract the first occurance of a substring anywhere +in a string (like an unanchored regex would). Rather, +they extract an occurance of the substring appearing +immediately at the current matching position in the +string (like a C<\G>-anchored regex would). + + + +=head2 General behaviour in list contexts + +In a list context, all the subroutines return a list, the first three +elements of which are always: + +=over 4 + +=item [0] + +The extracted string, including the specified delimiters. +If the extraction fails an empty string is returned. + +=item [1] + +The remainder of the input string (i.e. the characters after the +extracted string). On failure, the entire string is returned. + +=item [2] + +The skipped prefix (i.e. the characters before the extracted string). +On failure, the empty string is returned. + +=back + +Note that in a list context, the contents of the original input text (the first +argument) are not modified in any way. + +However, if the input text was passed in a variable, that variable's +C<pos> value is updated to point at the first character after the +extracted text. That means that in a list context the various +subroutines can be used much like regular expressions. For example: + + while ( $next = (extract_quotelike($text))[0] ) + { + # process next quote-like (in $next) + } + + +=head2 General behaviour in scalar and void contexts + +In a scalar context, the extracted string is returned, having first been +removed from the input text. Thus, the following code also processes +each quote-like operation, but actually removes them from $text: + + while ( $next = extract_quotelike($text) ) + { + # process next quote-like (in $next) + } + +Note that if the input text is a read-only string (i.e. a literal), +no attempt is made to remove the extracted text. + +In a void context the behaviour of the extraction subroutines is +exactly the same as in a scalar context, except (of course) that the +extracted substring is not returned. + +=head2 A note about prefixes + +Prefix patterns are matched without any trailing modifiers (C</gimsox> etc.) +This can bite you if you're expecting a prefix specification like +'.*?(?=<H1>)' to skip everything up to the first <H1> tag. Such a prefix +pattern will only succeed if the <H1> tag is on the current line, since +. normally doesn't match newlines. + +To overcome this limitation, you need to turn on /s matching within +the prefix pattern, using the C<(?s)> directive: '(?s).*?(?=<H1>)' + + +=head2 C<extract_delimited> + +The C<extract_delimited> function formalizes the common idiom +of extracting a single-character-delimited substring from the start of +a string. For example, to extract a single-quote delimited string, the +following code is typically used: + + ($remainder = $text) =~ s/\A('(\\.|[^'])*')//s; + $extracted = $1; + +but with C<extract_delimited> it can be simplified to: + + ($extracted,$remainder) = extract_delimited($text, "'"); + +C<extract_delimited> takes up to four scalars (the input text, the +delimiters, a prefix pattern to be skipped, and any escape characters) +and extracts the initial substring of the text that +is appropriately delimited. If the delimiter string has multiple +characters, the first one encountered in the text is taken to delimit +the substring. +The third argument specifies a prefix pattern that is to be skipped +(but must be present!) before the substring is extracted. +The final argument specifies the escape character to be used for each +delimiter. + +All arguments are optional. If the escape characters are not specified, +every delimiter is escaped with a backslash (C<\>). +If the prefix is not specified, the +pattern C<'\s*'> - optional whitespace - is used. If the delimiter set +is also not specified, the set C</["'`]/> is used. If the text to be processed +is not specified either, C<$_> is used. + +In list context, C<extract_delimited> returns a array of three +elements, the extracted substring (I<including the surrounding +delimiters>), the remainder of the text, and the skipped prefix (if +any). If a suitable delimited substring is not found, the first +element of the array is the empty string, the second is the complete +original text, and the prefix returned in the third element is an +empty string. + +In a scalar context, just the extracted substring is returned. In +a void context, the extracted substring (and any prefix) are simply +removed from the beginning of the first argument. + +Examples: + + # Remove a single-quoted substring from the very beginning of $text: + + $substring = extract_delimited($text, "'", ''); + + # Remove a single-quoted Pascalish substring (i.e. one in which + # doubling the quote character escapes it) from the very + # beginning of $text: + + $substring = extract_delimited($text, "'", '', "'"); + + # Extract a single- or double- quoted substring from the + # beginning of $text, optionally after some whitespace + # (note the list context to protect $text from modification): + + ($substring) = extract_delimited $text, q{"'}; + + + # Delete the substring delimited by the first '/' in $text: + + $text = join '', (extract_delimited($text,'/','[^/]*')[2,1]; + +Note that this last example is I<not> the same as deleting the first +quote-like pattern. For instance, if C<$text> contained the string: + + "if ('./cmd' =~ m/$UNIXCMD/s) { $cmd = $1; }" + +then after the deletion it would contain: + + "if ('.$UNIXCMD/s) { $cmd = $1; }" + +not: + + "if ('./cmd' =~ ms) { $cmd = $1; }" + + +See L<"extract_quotelike"> for a (partial) solution to this problem. + + +=head2 C<extract_bracketed> + +Like C<"extract_delimited">, the C<extract_bracketed> function takes +up to three optional scalar arguments: a string to extract from, a delimiter +specifier, and a prefix pattern. As before, a missing prefix defaults to +optional whitespace and a missing text defaults to C<$_>. However, a missing +delimiter specifier defaults to C<'{}()[]E<lt>E<gt>'> (see below). + +C<extract_bracketed> extracts a balanced-bracket-delimited +substring (using any one (or more) of the user-specified delimiter +brackets: '(..)', '{..}', '[..]', or '<..>'). Optionally it will also +respect quoted unbalanced brackets (see below). + +A "delimiter bracket" is a bracket in list of delimiters passed as +C<extract_bracketed>'s second argument. Delimiter brackets are +specified by giving either the left or right (or both!) versions +of the required bracket(s). Note that the order in which +two or more delimiter brackets are specified is not significant. + +A "balanced-bracket-delimited substring" is a substring bounded by +matched brackets, such that any other (left or right) delimiter +bracket I<within> the substring is also matched by an opposite +(right or left) delimiter bracket I<at the same level of nesting>. Any +type of bracket not in the delimiter list is treated as an ordinary +character. + +In other words, each type of bracket specified as a delimiter must be +balanced and correctly nested within the substring, and any other kind of +("non-delimiter") bracket in the substring is ignored. + +For example, given the string: + + $text = "{ an '[irregularly :-(] {} parenthesized >:-)' string }"; + +then a call to C<extract_bracketed> in a list context: + + @result = extract_bracketed( $text, '{}' ); + +would return: + + ( "{ an '[irregularly :-(] {} parenthesized >:-)' string }" , "" , "" ) + +since both sets of C<'{..}'> brackets are properly nested and evenly balanced. +(In a scalar context just the first element of the array would be returned. In +a void context, C<$text> would be replaced by an empty string.) + +Likewise the call in: + + @result = extract_bracketed( $text, '{[' ); + +would return the same result, since all sets of both types of specified +delimiter brackets are correctly nested and balanced. + +However, the call in: + + @result = extract_bracketed( $text, '{([<' ); + +would fail, returning: + + ( undef , "{ an '[irregularly :-(] {} parenthesized >:-)' string }" ); + +because the embedded pairs of C<'(..)'>s and C<'[..]'>s are "cross-nested" and +the embedded C<'E<gt>'> is unbalanced. (In a scalar context, this call would +return an empty string. In a void context, C<$text> would be unchanged.) + +Note that the embedded single-quotes in the string don't help in this +case, since they have not been specified as acceptable delimiters and are +therefore treated as non-delimiter characters (and ignored). + +However, if a particular species of quote character is included in the +delimiter specification, then that type of quote will be correctly handled. +for example, if C<$text> is: + + $text = '<A HREF=">>>>">link</A>'; + +then + + @result = extract_bracketed( $text, '<">' ); + +returns: + + ( '<A HREF=">>>>">', 'link</A>', "" ) + +as expected. Without the specification of C<"> as an embedded quoter: + + @result = extract_bracketed( $text, '<>' ); + +the result would be: + + ( '<A HREF=">', '>>>">link</A>', "" ) + +In addition to the quote delimiters C<'>, C<">, and C<`>, full Perl quote-like +quoting (i.e. q{string}, qq{string}, etc) can be specified by including the +letter 'q' as a delimiter. Hence: + + @result = extract_bracketed( $text, '<q>' ); + +would correctly match something like this: + + $text = '<leftop: conj /and/ conj>'; + +See also: C<"extract_quotelike"> and C<"extract_codeblock">. + + +=head2 C<extract_variable> + +C<extract_variable> extracts any valid Perl variable or +variable-involved expression, including scalars, arrays, hashes, array +accesses, hash look-ups, method calls through objects, subroutine calles +through subroutine references, etc. + +The subroutine takes up to two optional arguments: + +=over 4 + +=item 1. + +A string to be processed (C<$_> if the string is omitted or C<undef>) + +=item 2. + +A string specifying a pattern to be matched as a prefix (which is to be +skipped). If omitted, optional whitespace is skipped. + +=back + +On success in a list context, an array of 3 elements is returned. The +elements are: + +=over 4 + +=item [0] + +the extracted variable, or variablish expression + +=item [1] + +the remainder of the input text, + +=item [2] + +the prefix substring (if any), + +=back + +On failure, all of these values (except the remaining text) are C<undef>. + +In a scalar context, C<extract_variable> returns just the complete +substring that matched a variablish expression. C<undef> is returned on +failure. In addition, the original input text has the returned substring +(and any prefix) removed from it. + +In a void context, the input text just has the matched substring (and +any specified prefix) removed. + + +=head2 C<extract_tagged> + +C<extract_tagged> extracts and segments text between (balanced) +specified tags. + +The subroutine takes up to five optional arguments: + +=over 4 + +=item 1. + +A string to be processed (C<$_> if the string is omitted or C<undef>) + +=item 2. + +A string specifying a pattern to be matched as the opening tag. +If the pattern string is omitted (or C<undef>) then a pattern +that matches any standard XML tag is used. + +=item 3. + +A string specifying a pattern to be matched at the closing tag. +If the pattern string is omitted (or C<undef>) then the closing +tag is constructed by inserting a C</> after any leading bracket +characters in the actual opening tag that was matched (I<not> the pattern +that matched the tag). For example, if the opening tag pattern +is specified as C<'{{\w+}}'> and actually matched the opening tag +C<"{{DATA}}">, then the constructed closing tag would be C<"{{/DATA}}">. + +=item 4. + +A string specifying a pattern to be matched as a prefix (which is to be +skipped). If omitted, optional whitespace is skipped. + +=item 5. + +A hash reference containing various parsing options (see below) + +=back + +The various options that can be specified are: + +=over 4 + +=item C<reject =E<gt> $listref> + +The list reference contains one or more strings specifying patterns +that must I<not> appear within the tagged text. + +For example, to extract +an HTML link (which should not contain nested links) use: + + extract_tagged($text, '<A>', '</A>', undef, {reject => ['<A>']} ); + +=item C<ignore =E<gt> $listref> + +The list reference contains one or more strings specifying patterns +that are I<not> be be treated as nested tags within the tagged text +(even if they would match the start tag pattern). + +For example, to extract an arbitrary XML tag, but ignore "empty" elements: + + extract_tagged($text, undef, undef, undef, {ignore => ['<[^>]*/>']} ); + +(also see L<"gen_delimited_pat"> below). + + +=item C<fail =E<gt> $str> + +The C<fail> option indicates the action to be taken if a matching end +tag is not encountered (i.e. before the end of the string or some +C<reject> pattern matches). By default, a failure to match a closing +tag causes C<extract_tagged> to immediately fail. + +However, if the string value associated with <reject> is "MAX", then +C<extract_tagged> returns the complete text up to the point of failure. +If the string is "PARA", C<extract_tagged> returns only the first paragraph +after the tag (up to the first line that is either empty or contains +only whitespace characters). +If the string is "", the the default behaviour (i.e. failure) is reinstated. + +For example, suppose the start tag "/para" introduces a paragraph, which then +continues until the next "/endpara" tag or until another "/para" tag is +encountered: + + $text = "/para line 1\n\nline 3\n/para line 4"; + + extract_tagged($text, '/para', '/endpara', undef, + {reject => '/para', fail => MAX ); + + # EXTRACTED: "/para line 1\n\nline 3\n" + +Suppose instead, that if no matching "/endpara" tag is found, the "/para" +tag refers only to the immediately following paragraph: + + $text = "/para line 1\n\nline 3\n/para line 4"; + + extract_tagged($text, '/para', '/endpara', undef, + {reject => '/para', fail => MAX ); + + # EXTRACTED: "/para line 1\n" + +Note that the specified C<fail> behaviour applies to nested tags as well. + +=back + +On success in a list context, an array of 6 elements is returned. The elements are: + +=over 4 + +=item [0] + +the extracted tagged substring (including the outermost tags), + +=item [1] + +the remainder of the input text, + +=item [2] + +the prefix substring (if any), + +=item [3] + +the opening tag + +=item [4] + +the text between the opening and closing tags + +=item [5] + +the closing tag (or "" if no closing tag was found) + +=back + +On failure, all of these values (except the remaining text) are C<undef>. + +In a scalar context, C<extract_tagged> returns just the complete +substring that matched a tagged text (including the start and end +tags). C<undef> is returned on failure. In addition, the original input +text has the returned substring (and any prefix) removed from it. + +In a void context, the input text just has the matched substring (and +any specified prefix) removed. + + +=head2 C<gen_extract_tagged> + +(Note: This subroutine is only available under Perl5.005) + +C<gen_extract_tagged> generates a new anonymous subroutine which +extracts text between (balanced) specified tags. In other words, +it generates a function identical in function to C<extract_tagged>. + +The difference between C<extract_tagged> and the anonymous +subroutines generated by +C<gen_extract_tagged>, is that those generated subroutines: + +=over 4 + +=item * + +do not have to reparse tag specification or parsing options every time +they are called (whereas C<extract_tagged> has to effectively rebuild +its tag parser on every call); + +=item * + +make use of the new qr// construct to pre-compile the regexes they use +(whereas C<extract_tagged> uses standard string variable interpolation +to create tag-matching patterns). + +=back + +The subroutine takes up to four optional arguments (the same set as +C<extract_tagged> except for the string to be processed). It returns +a reference to a subroutine which in turn takes a single argument (the text to +be extracted from). + +In other words, the implementation of C<extract_tagged> is exactly +equivalent to: + + sub extract_tagged + { + my $text = shift; + $extractor = gen_extract_tagged(@_); + return $extractor->($text); + } + +(although C<extract_tagged> is not currently implemented that way, in order +to preserve pre-5.005 compatibility). + +Using C<gen_extract_tagged> to create extraction functions for specific tags +is a good idea if those functions are going to be called more than once, since +their performance is typically twice as good as the more general-purpose +C<extract_tagged>. + + +=head2 C<extract_quotelike> + +C<extract_quotelike> attempts to recognize, extract, and segment any +one of the various Perl quotes and quotelike operators (see +L<perlop(3)>) Nested backslashed delimiters, embedded balanced bracket +delimiters (for the quotelike operators), and trailing modifiers are +all caught. For example, in: + + extract_quotelike 'q # an octothorpe: \# (not the end of the q!) #' + + extract_quotelike ' "You said, \"Use sed\"." ' + + extract_quotelike ' s{([A-Z]{1,8}\.[A-Z]{3})} /\L$1\E/; ' + + extract_quotelike ' tr/\\\/\\\\/\\\//ds; ' + +the full Perl quotelike operations are all extracted correctly. + +Note too that, when using the /x modifier on a regex, any comment +containing the current pattern delimiter will cause the regex to be +immediately terminated. In other words: + + 'm / + (?i) # CASE INSENSITIVE + [a-z_] # LEADING ALPHABETIC/UNDERSCORE + [a-z0-9]* # FOLLOWED BY ANY NUMBER OF ALPHANUMERICS + /x' + +will be extracted as if it were: + + 'm / + (?i) # CASE INSENSITIVE + [a-z_] # LEADING ALPHABETIC/' + +This behaviour is identical to that of the actual compiler. + +C<extract_quotelike> takes two arguments: the text to be processed and +a prefix to be matched at the very beginning of the text. If no prefix +is specified, optional whitespace is the default. If no text is given, +C<$_> is used. + +In a list context, an array of 11 elements is returned. The elements are: + +=over 4 + +=item [0] + +the extracted quotelike substring (including trailing modifiers), + +=item [1] + +the remainder of the input text, + +=item [2] + +the prefix substring (if any), + +=item [3] + +the name of the quotelike operator (if any), + +=item [4] + +the left delimiter of the first block of the operation, + +=item [5] + +the text of the first block of the operation +(that is, the contents of +a quote, the regex of a match or substitution or the target list of a +translation), + +=item [6] + +the right delimiter of the first block of the operation, + +=item [7] + +the left delimiter of the second block of the operation +(that is, if it is a C<s>, C<tr>, or C<y>), + +=item [8] + +the text of the second block of the operation +(that is, the replacement of a substitution or the translation list +of a translation), + +=item [9] + +the right delimiter of the second block of the operation (if any), + +=item [10] + +the trailing modifiers on the operation (if any). + +=back + +For each of the fields marked "(if any)" the default value on success is +an empty string. +On failure, all of these values (except the remaining text) are C<undef>. + + +In a scalar context, C<extract_quotelike> returns just the complete substring +that matched a quotelike operation (or C<undef> on failure). In a scalar or +void context, the input text has the same substring (and any specified +prefix) removed. + +Examples: + + # Remove the first quotelike literal that appears in text + + $quotelike = extract_quotelike($text,'.*?'); + + # Replace one or more leading whitespace-separated quotelike + # literals in $_ with "<QLL>" + + do { $_ = join '<QLL>', (extract_quotelike)[2,1] } until $@; + + + # Isolate the search pattern in a quotelike operation from $text + + ($op,$pat) = (extract_quotelike $text)[3,5]; + if ($op =~ /[ms]/) + { + print "search pattern: $pat\n"; + } + else + { + print "$op is not a pattern matching operation\n"; + } + + +=head2 C<extract_quotelike> and "here documents" + +C<extract_quotelike> can successfully extract "here documents" from an input +string, but with an important caveat in list contexts. + +Unlike other types of quote-like literals, a here document is rarely +a contiguous substring. For example, a typical piece of code using +here document might look like this: + + <<'EOMSG' || die; + This is the message. + EOMSG + exit; + +Given this as an input string in a scalar context, C<extract_quotelike> +would correctly return the string "<<'EOMSG'\nThis is the message.\nEOMSG", +leaving the string " || die;\nexit;" in the original variable. In other words, +the two separate pieces of the here document are successfully extracted and +concatenated. + +In a list context, C<extract_quotelike> would return the list + +=over 4 + +=item [0] + +"<<'EOMSG'\nThis is the message.\nEOMSG\n" (i.e. the full extracted here document, +including fore and aft delimiters), + +=item [1] + +" || die;\nexit;" (i.e. the remainder of the input text, concatenated), + +=item [2] + +"" (i.e. the prefix substring -- trivial in this case), + +=item [3] + +"<<" (i.e. the "name" of the quotelike operator) + +=item [4] + +"'EOMSG'" (i.e. the left delimiter of the here document, including any quotes), + +=item [5] + +"This is the message.\n" (i.e. the text of the here document), + +=item [6] + +"EOMSG" (i.e. the right delimiter of the here document), + +=item [7..10] + +"" (a here document has no second left delimiter, second text, second right +delimiter, or trailing modifiers). + +=back + +However, the matching position of the input variable would be set to +"exit;" (i.e. I<after> the closing delimiter of the here document), +which would cause the earlier " || die;\nexit;" to be skipped in any +sequence of code fragment extractions. + +To avoid this problem, when it encounters a here document whilst +extracting from a modifiable string, C<extract_quotelike> silently +rearranges the string to an equivalent piece of Perl: + + <<'EOMSG' + This is the message. + EOMSG + || die; + exit; + +in which the here document I<is> contiguous. It still leaves the +matching position after the here document, but now the rest of the line +on which the here document starts is not skipped. + +To prevent <extract_quotelike> from mucking about with the input in this way +(this is the only case where a list-context C<extract_quotelike> does so), +you can pass the input variable as an interpolated literal: + + $quotelike = extract_quotelike("$var"); + + +=head2 C<extract_codeblock> + +C<extract_codeblock> attempts to recognize and extract a balanced +bracket delimited substring that may contain unbalanced brackets +inside Perl quotes or quotelike operations. That is, C<extract_codeblock> +is like a combination of C<"extract_bracketed"> and +C<"extract_quotelike">. + +C<extract_codeblock> takes the same initial three parameters as C<extract_bracketed>: +a text to process, a set of delimiter brackets to look for, and a prefix to +match first. It also takes an optional fourth parameter, which allows the +outermost delimiter brackets to be specified separately (see below). + +Omitting the first argument (input text) means process C<$_> instead. +Omitting the second argument (delimiter brackets) indicates that only C<'{'> is to be used. +Omitting the third argument (prefix argument) implies optional whitespace at the start. +Omitting the fourth argument (outermost delimiter brackets) indicates that the +value of the second argument is to be used for the outermost delimiters. + +Once the prefix an dthe outermost opening delimiter bracket have been +recognized, code blocks are extracted by stepping through the input text and +trying the following alternatives in sequence: + +=over 4 + +=item 1. + +Try and match a closing delimiter bracket. If the bracket was the same +species as the last opening bracket, return the substring to that +point. If the bracket was mismatched, return an error. + +=item 2. + +Try to match a quote or quotelike operator. If found, call +C<extract_quotelike> to eat it. If C<extract_quotelike> fails, return +the error it returned. Otherwise go back to step 1. + +=item 3. + +Try to match an opening delimiter bracket. If found, call +C<extract_codeblock> recursively to eat the embedded block. If the +recursive call fails, return an error. Otherwise, go back to step 1. + +=item 4. + +Unconditionally match a bareword or any other single character, and +then go back to step 1. + +=back + + +Examples: + + # Find a while loop in the text + + if ($text =~ s/.*?while\s*\{/{/) + { + $loop = "while " . extract_codeblock($text); + } + + # Remove the first round-bracketed list (which may include + # round- or curly-bracketed code blocks or quotelike operators) + + extract_codeblock $text, "(){}", '[^(]*'; + + +The ability to specify a different outermost delimiter bracket is useful +in some circumstances. For example, in the Parse::RecDescent module, +parser actions which are to be performed only on a successful parse +are specified using a C<E<lt>defer:...E<gt>> directive. For example: + + sentence: subject verb object + <defer: {$::theVerb = $item{verb}} > + +Parse::RecDescent uses C<extract_codeblock($text, '{}E<lt>E<gt>')> to extract the code +within the C<E<lt>defer:...E<gt>> directive, but there's a problem. + +A deferred action like this: + + <defer: {if ($count>10) {$count--}} > + +will be incorrectly parsed as: + + <defer: {if ($count> + +because the "less than" operator is interpreted as a closing delimiter. + +But, by extracting the directive using +S<C<extract_codeblock($text, '{}', undef, 'E<lt>E<gt>')>> +the '>' character is only treated as a delimited at the outermost +level of the code block, so the directive is parsed correctly. + +=head2 C<extract_multiple> + +The C<extract_multiple> subroutine takes a string to be processed and a +list of extractors (subroutines or regular expressions) to apply to that string. + +In an array context C<extract_multiple> returns an array of substrings +of the original string, as extracted by the specified extractors. +In a scalar context, C<extract_multiple> returns the first +substring successfully extracted from the original string. In both +scalar and void contexts the original string has the first successfully +extracted substring removed from it. In all contexts +C<extract_multiple> starts at the current C<pos> of the string, and +sets that C<pos> appropriately after it matches. + +Hence, the aim of of a call to C<extract_multiple> in a list context +is to split the processed string into as many non-overlapping fields as +possible, by repeatedly applying each of the specified extractors +to the remainder of the string. Thus C<extract_multiple> is +a generalized form of Perl's C<split> subroutine. + +The subroutine takes up to four optional arguments: + +=over 4 + +=item 1. + +A string to be processed (C<$_> if the string is omitted or C<undef>) + +=item 2. + +A reference to a list of subroutine references and/or qr// objects and/or +literal strings and/or hash references, specifying the extractors +to be used to split the string. If this argument is omitted (or +C<undef>) the list: + + [ + sub { extract_variable($_[0], '') }, + sub { extract_quotelike($_[0],'') }, + sub { extract_codeblock($_[0],'{}','') }, + ] + +is used. + + +=item 3. + +An number specifying the maximum number of fields to return. If this +argument is omitted (or C<undef>), split continues as long as possible. + +If the third argument is I<N>, then extraction continues until I<N> fields +have been successfully extracted, or until the string has been completely +processed. + +Note that in scalar and void contexts the value of this argument is +automatically reset to 1 (under C<-w>, a warning is issued if the argument +has to be reset). + +=item 4. + +A value indicating whether unmatched substrings (see below) within the +text should be skipped or returned as fields. If the value is true, +such substrings are skipped. Otherwise, they are returned. + +=back + +The extraction process works by applying each extractor in +sequence to the text string. + +If the extractor is a subroutine it is called in a list context and is +expected to return a list of a single element, namely the extracted +text. It may optionally also return two further arguments: a string +representing the text left after extraction (like $' for a pattern +match), and a string representing any prefix skipped before the +extraction (like $` in a pattern match). Note that this is designed +to facilitate the use of other Text::Balanced subroutines with +C<extract_multiple>. Note too that the value returned by an extractor +subroutine need not bear any relationship to the corresponding substring +of the original text (see examples below). + +If the extractor is a precompiled regular expression or a string, +it is matched against the text in a scalar context with a leading +'\G' and the gc modifiers enabled. The extracted value is either +$1 if that variable is defined after the match, or else the +complete match (i.e. $&). + +If the extractor is a hash reference, it must contain exactly one element. +The value of that element is one of the +above extractor types (subroutine reference, regular expression, or string). +The key of that element is the name of a class into which the successful +return value of the extractor will be blessed. + +If an extractor returns a defined value, that value is immediately +treated as the next extracted field and pushed onto the list of fields. +If the extractor was specified in a hash reference, the field is also +blessed into the appropriate class, + +If the extractor fails to match (in the case of a regex extractor), or returns an empty list or an undefined value (in the case of a subroutine extractor), it is +assumed to have failed to extract. +If none of the extractor subroutines succeeds, then one +character is extracted from the start of the text and the extraction +subroutines reapplied. Characters which are thus removed are accumulated and +eventually become the next field (unless the fourth argument is true, in which +case they are disgarded). + +For example, the following extracts substrings that are valid Perl variables: + + @fields = extract_multiple($text, + [ sub { extract_variable($_[0]) } ], + undef, 1); + +This example separates a text into fields which are quote delimited, +curly bracketed, and anything else. The delimited and bracketed +parts are also blessed to identify them (the "anything else" is unblessed): + + @fields = extract_multiple($text, + [ + { Delim => sub { extract_delimited($_[0],q{'"}) } }, + { Brack => sub { extract_bracketed($_[0],'{}') } }, + ]); + +This call extracts the next single substring that is a valid Perl quotelike +operator (and removes it from $text): + + $quotelike = extract_multiple($text, + [ + sub { extract_quotelike($_[0]) }, + ], undef, 1); + +Finally, here is yet another way to do comma-separated value parsing: + + @fields = extract_multiple($csv_text, + [ + sub { extract_delimited($_[0],q{'"}) }, + qr/([^,]+)(.*)/, + ], + undef,1); + +The list in the second argument means: +I<"Try and extract a ' or " delimited string, otherwise extract anything up to a comma...">. +The undef third argument means: +I<"...as many times as possible...">, +and the true value in the fourth argument means +I<"...discarding anything else that appears (i.e. the commas)">. + +If you wanted the commas preserved as separate fields (i.e. like split +does if your split pattern has capturing parentheses), you would +just make the last parameter undefined (or remove it). + + +=head2 C<gen_delimited_pat> + +The C<gen_delimited_pat> subroutine takes a single (string) argument and + > builds a Friedl-style optimized regex that matches a string delimited +by any one of the characters in the single argument. For example: + + gen_delimited_pat(q{'"}) + +returns the regex: + + (?:\"(?:\\\"|(?!\").)*\"|\'(?:\\\'|(?!\').)*\') + +Note that the specified delimiters are automatically quotemeta'd. + +A typical use of C<gen_delimited_pat> would be to build special purpose tags +for C<extract_tagged>. For example, to properly ignore "empty" XML elements +(which might contain quoted strings): + + my $empty_tag = '<(' . gen_delimited_pat(q{'"}) . '|.)+/>'; + + extract_tagged($text, undef, undef, undef, {ignore => [$empty_tag]} ); + + +C<gen_delimited_pat> may also be called with an optional second argument, +which specifies the "escape" character(s) to be used for each delimiter. +For example to match a Pascal-style string (where ' is the delimiter +and '' is a literal ' within the string): + + gen_delimited_pat(q{'},q{'}); + +Different escape characters can be specified for different delimiters. +For example, to specify that '/' is the escape for single quotes +and '%' is the escape for double quotes: + + gen_delimited_pat(q{'"},q{/%}); + +If more delimiters than escape chars are specified, the last escape char +is used for the remaining delimiters. +If no escape char is specified for a given specified delimiter, '\' is used. + +Note that +C<gen_delimited_pat> was previously called +C<delimited_pat>. That name may still be used, but is now deprecated. + + +=head1 DIAGNOSTICS + +In a list context, all the functions return C<(undef,$original_text)> +on failure. In a scalar context, failure is indicated by returning C<undef> +(in this case the input text is not modified in any way). + +In addition, on failure in I<any> context, the C<$@> variable is set. +Accessing C<$@-E<gt>{error}> returns one of the error diagnostics listed +below. +Accessing C<$@-E<gt>{pos}> returns the offset into the original string at +which the error was detected (although not necessarily where it occurred!) +Printing C<$@> directly produces the error message, with the offset appended. +On success, the C<$@> variable is guaranteed to be C<undef>. + +The available diagnostics are: + +=over 4 + +=item C<Did not find a suitable bracket: "%s"> + +The delimiter provided to C<extract_bracketed> was not one of +C<'()[]E<lt>E<gt>{}'>. + +=item C<Did not find prefix: /%s/> + +A non-optional prefix was specified but wasn't found at the start of the text. + +=item C<Did not find opening bracket after prefix: "%s"> + +C<extract_bracketed> or C<extract_codeblock> was expecting a +particular kind of bracket at the start of the text, and didn't find it. + +=item C<No quotelike operator found after prefix: "%s"> + +C<extract_quotelike> didn't find one of the quotelike operators C<q>, +C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y> at the start of the substring +it was extracting. + +=item C<Unmatched closing bracket: "%c"> + +C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> encountered +a closing bracket where none was expected. + +=item C<Unmatched opening bracket(s): "%s"> + +C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> ran +out of characters in the text before closing one or more levels of nested +brackets. + +=item C<Unmatched embedded quote (%s)> + +C<extract_bracketed> attempted to match an embedded quoted substring, but +failed to find a closing quote to match it. + +=item C<Did not find closing delimiter to match '%s'> + +C<extract_quotelike> was unable to find a closing delimiter to match the +one that opened the quote-like operation. + +=item C<Mismatched closing bracket: expected "%c" but found "%s"> + +C<extract_bracketed>, C<extract_quotelike> or C<extract_codeblock> found +a valid bracket delimiter, but it was the wrong species. This usually +indicates a nesting error, but may indicate incorrect quoting or escaping. + +=item C<No block delimiter found after quotelike "%s"> + +C<extract_quotelike> or C<extract_codeblock> found one of the +quotelike operators C<q>, C<qq>, C<qw>, C<qx>, C<s>, C<tr> or C<y> +without a suitable block after it. + +=item C<Did not find leading dereferencer> + +C<extract_variable> was expecting one of '$', '@', or '%' at the start of +a variable, but didn't find any of them. + +=item C<Bad identifier after dereferencer> + +C<extract_variable> found a '$', '@', or '%' indicating a variable, but that +character was not followed by a legal Perl identifier. + +=item C<Did not find expected opening bracket at %s> + +C<extract_codeblock> failed to find any of the outermost opening brackets +that were specified. + +=item C<Improperly nested codeblock at %s> + +A nested code block was found that started with a delimiter that was specified +as being only to be used as an outermost bracket. + +=item C<Missing second block for quotelike "%s"> + +C<extract_codeblock> or C<extract_quotelike> found one of the +quotelike operators C<s>, C<tr> or C<y> followed by only one block. + +=item C<No match found for opening bracket> + +C<extract_codeblock> failed to find a closing bracket to match the outermost +opening bracket. + +=item C<Did not find opening tag: /%s/> + +C<extract_tagged> did not find a suitable opening tag (after any specified +prefix was removed). + +=item C<Unable to construct closing tag to match: /%s/> + +C<extract_tagged> matched the specified opening tag and tried to +modify the matched text to produce a matching closing tag (because +none was specified). It failed to generate the closing tag, almost +certainly because the opening tag did not start with a +bracket of some kind. + +=item C<Found invalid nested tag: %s> + +C<extract_tagged> found a nested tag that appeared in the "reject" list +(and the failure mode was not "MAX" or "PARA"). + +=item C<Found unbalanced nested tag: %s> + +C<extract_tagged> found a nested opening tag that was not matched by a +corresponding nested closing tag (and the failure mode was not "MAX" or "PARA"). + +=item C<Did not find closing tag> + +C<extract_tagged> reached the end of the text without finding a closing tag +to match the original opening tag (and the failure mode was not +"MAX" or "PARA"). + + + + +=back + + +=head1 AUTHOR + +Damian Conway (damian@conway.org) + + +=head1 BUGS AND IRRITATIONS + +There are undoubtedly serious bugs lurking somewhere in this code, if +only because parts of it give the impression of understanding a great deal +more about Perl than they really do. + +Bug reports and other feedback are most welcome. + + +=head1 COPYRIGHT + + Copyright (c) 1997-2001, Damian Conway. All Rights Reserved. + This module is free software. It may be used, redistributed + and/or modified under the same terms as Perl itself. diff --git a/Master/tlpkg/installer/perllib/Text/ParseWords.pm b/Master/tlpkg/installer/perllib/Text/ParseWords.pm new file mode 100644 index 00000000000..2f6812ade80 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Text/ParseWords.pm @@ -0,0 +1,263 @@ +package Text::ParseWords; + +use vars qw($VERSION @ISA @EXPORT $PERL_SINGLE_QUOTE); +$VERSION = "3.24"; + +require 5.000; + +use Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(shellwords quotewords nested_quotewords parse_line); +@EXPORT_OK = qw(old_shellwords); + + +sub shellwords { + my(@lines) = @_; + $lines[$#lines] =~ s/\s+$//; + return(quotewords('\s+', 0, @lines)); +} + + + +sub quotewords { + my($delim, $keep, @lines) = @_; + my($line, @words, @allwords); + + foreach $line (@lines) { + @words = parse_line($delim, $keep, $line); + return() unless (@words || !length($line)); + push(@allwords, @words); + } + return(@allwords); +} + + + +sub nested_quotewords { + my($delim, $keep, @lines) = @_; + my($i, @allwords); + + for ($i = 0; $i < @lines; $i++) { + @{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]); + return() unless (@{$allwords[$i]} || !length($lines[$i])); + } + return(@allwords); +} + + + +sub parse_line { + my($delimiter, $keep, $line) = @_; + my($word, @pieces); + + no warnings 'uninitialized'; # we will be testing undef strings + + while (length($line)) { + $line =~ s/^(["']) # a $quote + ((?:\\.|(?!\1)[^\\])*) # and $quoted text + \1 # followed by the same quote + | # --OR-- + ^((?:\\.|[^\\"'])*?) # an $unquoted text + (\Z(?!\n)|(?-x:$delimiter)|(?!^)(?=["'])) + # plus EOL, delimiter, or quote + //xs or return; # extended layout + my($quote, $quoted, $unquoted, $delim) = ($1, $2, $3, $4); + return() unless( defined($quote) || length($unquoted) || length($delim)); + + if ($keep) { + $quoted = "$quote$quoted$quote"; + } + else { + $unquoted =~ s/\\(.)/$1/sg; + if (defined $quote) { + $quoted =~ s/\\(.)/$1/sg if ($quote eq '"'); + $quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'"); + } + } + $word .= substr($line, 0, 0); # leave results tainted + $word .= defined $quote ? $quoted : $unquoted; + + if (length($delim)) { + push(@pieces, $word); + push(@pieces, $delim) if ($keep eq 'delimiters'); + undef $word; + } + if (!length($line)) { + push(@pieces, $word); + } + } + return(@pieces); +} + + + +sub old_shellwords { + + # Usage: + # use ParseWords; + # @words = old_shellwords($line); + # or + # @words = old_shellwords(@lines); + # or + # @words = old_shellwords(); # defaults to $_ (and clobbers it) + + no warnings 'uninitialized'; # we will be testing undef strings + local *_ = \join('', @_) if @_; + my (@words, $snippet); + + s/\A\s+//; + while ($_ ne '') { + my $field = substr($_, 0, 0); # leave results tainted + for (;;) { + if (s/\A"(([^"\\]|\\.)*)"//s) { + ($snippet = $1) =~ s#\\(.)#$1#sg; + } + elsif (/\A"/) { + require Carp; + Carp::carp("Unmatched double quote: $_"); + return(); + } + elsif (s/\A'(([^'\\]|\\.)*)'//s) { + ($snippet = $1) =~ s#\\(.)#$1#sg; + } + elsif (/\A'/) { + require Carp; + Carp::carp("Unmatched single quote: $_"); + return(); + } + elsif (s/\A\\(.)//s) { + $snippet = $1; + } + elsif (s/\A([^\s\\'"]+)//) { + $snippet = $1; + } + else { + s/\A\s+//; + last; + } + $field .= $snippet; + } + push(@words, $field); + } + return @words; +} + +1; + +__END__ + +=head1 NAME + +Text::ParseWords - parse text into an array of tokens or array of arrays + +=head1 SYNOPSIS + + use Text::ParseWords; + @lists = &nested_quotewords($delim, $keep, @lines); + @words = "ewords($delim, $keep, @lines); + @words = &shellwords(@lines); + @words = &parse_line($delim, $keep, $line); + @words = &old_shellwords(@lines); # DEPRECATED! + +=head1 DESCRIPTION + +The &nested_quotewords() and "ewords() functions accept a delimiter +(which can be a regular expression) +and a list of lines and then breaks those lines up into a list of +words ignoring delimiters that appear inside quotes. "ewords() +returns all of the tokens in a single long list, while &nested_quotewords() +returns a list of token lists corresponding to the elements of @lines. +&parse_line() does tokenizing on a single string. The &*quotewords() +functions simply call &parse_line(), so if you're only splitting +one line you can call &parse_line() directly and save a function +call. + +The $keep argument is a boolean flag. If true, then the tokens are +split on the specified delimiter, but all other characters (quotes, +backslashes, etc.) are kept in the tokens. If $keep is false then the +&*quotewords() functions remove all quotes and backslashes that are +not themselves backslash-escaped or inside of single quotes (i.e., +"ewords() tries to interpret these characters just like the Bourne +shell). NB: these semantics are significantly different from the +original version of this module shipped with Perl 5.000 through 5.004. +As an additional feature, $keep may be the keyword "delimiters" which +causes the functions to preserve the delimiters in each string as +tokens in the token lists, in addition to preserving quote and +backslash characters. + +&shellwords() is written as a special case of "ewords(), and it +does token parsing with whitespace as a delimiter-- similar to most +Unix shells. + +=head1 EXAMPLES + +The sample program: + + use Text::ParseWords; + @words = "ewords('\s+', 0, q{this is "a test" of\ quotewords \"for you}); + $i = 0; + foreach (@words) { + print "$i: <$_>\n"; + $i++; + } + +produces: + + 0: <this> + 1: <is> + 2: <a test> + 3: <of quotewords> + 4: <"for> + 5: <you> + +demonstrating: + +=over 4 + +=item 0 + +a simple word + +=item 1 + +multiple spaces are skipped because of our $delim + +=item 2 + +use of quotes to include a space in a word + +=item 3 + +use of a backslash to include a space in a word + +=item 4 + +use of a backslash to remove the special meaning of a double-quote + +=item 5 + +another simple word (note the lack of effect of the +backslashed double-quote) + +=back + +Replacing C<"ewords('\s+', 0, q{this is...})> +with C<&shellwords(q{this is...})> +is a simpler way to accomplish the same thing. + +=head1 AUTHORS + +Maintainer is Hal Pomeranz <pomeranz@netcom.com>, 1994-1997 (Original +author unknown). Much of the code for &parse_line() (including the +primary regexp) from Joerk Behrends <jbehrends@multimediaproduzenten.de>. + +Examples section another documentation provided by John Heidemann +<johnh@ISI.EDU> + +Bug reports, patches, and nagging provided by lots of folks-- thanks +everybody! Special thanks to Michael Schwern <schwern@envirolink.org> +for assuring me that a &nested_quotewords() would be useful, and to +Jeff Friedl <jfriedl@yahoo-inc.com> for telling me not to worry about +error-checking (sort of-- you had to be there). + +=cut diff --git a/Master/tlpkg/installer/perllib/Text/Soundex.pm b/Master/tlpkg/installer/perllib/Text/Soundex.pm new file mode 100644 index 00000000000..64a9e6507d5 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Text/Soundex.pm @@ -0,0 +1,150 @@ +package Text::Soundex; +require 5.000; +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(&soundex $soundex_nocode); + +$VERSION = '1.01'; + +# $Id: soundex.pl,v 1.2 1994/03/24 00:30:27 mike Exp $ +# +# Implementation of soundex algorithm as described by Knuth in volume +# 3 of The Art of Computer Programming, with ideas stolen from Ian +# Phillipps <ian@pipex.net>. +# +# Mike Stok <Mike.Stok@meiko.concord.ma.us>, 2 March 1994. +# +# Knuth's test cases are: +# +# Euler, Ellery -> E460 +# Gauss, Ghosh -> G200 +# Hilbert, Heilbronn -> H416 +# Knuth, Kant -> K530 +# Lloyd, Ladd -> L300 +# Lukasiewicz, Lissajous -> L222 +# +# $Log: soundex.pl,v $ +# Revision 1.2 1994/03/24 00:30:27 mike +# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu> +# in the way I handles leasing characters which were different but had +# the same soundex code. This showed up comparing it with Oracle's +# soundex output. +# +# Revision 1.1 1994/03/02 13:01:30 mike +# Initial revision +# +# +############################################################################## + +# $soundex_nocode is used to indicate a string doesn't have a soundex +# code, I like undef other people may want to set it to 'Z000'. + +$soundex_nocode = undef; + +sub soundex +{ + local (@s, $f, $fc, $_) = @_; + + push @s, '' unless @s; # handle no args as a single empty string + + foreach (@s) + { + $_ = uc $_; + tr/A-Z//cd; + + if ($_ eq '') + { + $_ = $soundex_nocode; + } + else + { + ($f) = /^(.)/; + tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/; + ($fc) = /^(.)/; + s/^$fc+//; + tr///cs; + tr/0//d; + $_ = $f . $_ . '000'; + s/^(.{4}).*/$1/; + } + } + + wantarray ? @s : shift @s; +} + +1; + +__END__ + +=head1 NAME + +Text::Soundex - Implementation of the Soundex Algorithm as Described by Knuth + +=head1 SYNOPSIS + + use Text::Soundex; + + $code = soundex $string; # get soundex code for a string + @codes = soundex @list; # get list of codes for list of strings + + # set value to be returned for strings without soundex code + + $soundex_nocode = 'Z000'; + +=head1 DESCRIPTION + +This module implements the soundex algorithm as described by Donald Knuth +in Volume 3 of B<The Art of Computer Programming>. The algorithm is +intended to hash words (in particular surnames) into a small space using a +simple model which approximates the sound of the word when spoken by an English +speaker. Each word is reduced to a four character string, the first +character being an upper case letter and the remaining three being digits. + +If there is no soundex code representation for a string then the value of +C<$soundex_nocode> is returned. This is initially set to C<undef>, but +many people seem to prefer an I<unlikely> value like C<Z000> +(how unlikely this is depends on the data set being dealt with.) Any value +can be assigned to C<$soundex_nocode>. + +In scalar context C<soundex> returns the soundex code of its first +argument, and in list context a list is returned in which each element is the +soundex code for the corresponding argument passed to C<soundex> e.g. + + @codes = soundex qw(Mike Stok); + +leaves C<@codes> containing C<('M200', 'S320')>. + +=head1 EXAMPLES + +Knuth's examples of various names and the soundex codes they map to +are listed below: + + Euler, Ellery -> E460 + Gauss, Ghosh -> G200 + Hilbert, Heilbronn -> H416 + Knuth, Kant -> K530 + Lloyd, Ladd -> L300 + Lukasiewicz, Lissajous -> L222 + +so: + + $code = soundex 'Knuth'; # $code contains 'K530' + @list = soundex qw(Lloyd Gauss); # @list contains 'L300', 'G200' + +=head1 LIMITATIONS + +As the soundex algorithm was originally used a B<long> time ago in the US +it considers only the English alphabet and pronunciation. + +As it is mapping a large space (arbitrary length strings) onto a small +space (single letter plus 3 digits) no inference can be made about the +similarity of two strings which end up with the same soundex code. For +example, both C<Hilbert> and C<Heilbronn> end up with a soundex code +of C<H416>. + +=head1 AUTHOR + +This code was implemented by Mike Stok (C<stok@cybercom.net>) from the +description given by Knuth. Ian Phillipps (C<ian@pipex.net>) and Rich Pinder +(C<rpinder@hsc.usc.edu>) supplied ideas and spotted mistakes. diff --git a/Master/tlpkg/installer/perllib/Text/Wrap.pm b/Master/tlpkg/installer/perllib/Text/Wrap.pm new file mode 100644 index 00000000000..d364cfc1195 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Text/Wrap.pm @@ -0,0 +1,223 @@ +package Text::Wrap; + +require Exporter; + +@ISA = qw(Exporter); +@EXPORT = qw(wrap fill); +@EXPORT_OK = qw($columns $break $huge); + +$VERSION = 2005.0824_01; + +use vars qw($VERSION $columns $debug $break $huge $unexpand $tabstop + $separator $separator2); +use strict; + +BEGIN { + $columns = 76; # <= screen width + $debug = 0; + $break = '\s'; + $huge = 'wrap'; # alternatively: 'die' or 'overflow' + $unexpand = 1; + $tabstop = 8; + $separator = "\n"; + $separator2 = undef; +} + +use Text::Tabs qw(expand unexpand); + +sub wrap +{ + my ($ip, $xp, @t) = @_; + + local($Text::Tabs::tabstop) = $tabstop; + my $r = ""; + my $tail = pop(@t); + my $t = expand(join("", (map { /\s+\z/ ? ( $_ ) : ($_, ' ') } @t), $tail)); + my $lead = $ip; + my $ll = $columns - length(expand($ip)) - 1; + $ll = 0 if $ll < 0; + my $nll = $columns - length(expand($xp)) - 1; + my $nl = ""; + my $remainder = ""; + + use re 'taint'; + + pos($t) = 0; + while ($t !~ /\G\s*\Z/gc) { + if ($t =~ /\G([^\n]{0,$ll})($break|\n*\z)/xmgc) { + $r .= $unexpand + ? unexpand($nl . $lead . $1) + : $nl . $lead . $1; + $remainder = $2; + } elsif ($huge eq 'wrap' && $t =~ /\G([^\n]{$ll})/gc) { + $r .= $unexpand + ? unexpand($nl . $lead . $1) + : $nl . $lead . $1; + $remainder = defined($separator2) ? $separator2 : $separator; + } elsif ($huge eq 'overflow' && $t =~ /\G([^\n]*?)($break|\z)/xmgc) { + $r .= $unexpand + ? unexpand($nl . $lead . $1) + : $nl . $lead . $1; + $remainder = $2; + } elsif ($huge eq 'die') { + die "couldn't wrap '$t'"; + } else { + die "This shouldn't happen"; + } + + $lead = $xp; + $ll = $nll; + $nl = defined($separator2) + ? ($remainder eq "\n" + ? "\n" + : $separator2) + : $separator; + } + $r .= $remainder; + + print "-----------$r---------\n" if $debug; + + print "Finish up with '$lead'\n" if $debug; + + $r .= $lead . substr($t, pos($t), length($t)-pos($t)) + if pos($t) ne length($t); + + print "-----------$r---------\n" if $debug;; + + return $r; +} + +sub fill +{ + my ($ip, $xp, @raw) = @_; + my @para; + my $pp; + + for $pp (split(/\n\s+/, join("\n",@raw))) { + $pp =~ s/\s+/ /g; + my $x = wrap($ip, $xp, $pp); + push(@para, $x); + } + + # if paragraph_indent is the same as line_indent, + # separate paragraphs with blank lines + + my $ps = ($ip eq $xp) ? "\n\n" : "\n"; + return join ($ps, @para); +} + +1; +__END__ + +=head1 NAME + +Text::Wrap - line wrapping to form simple paragraphs + +=head1 SYNOPSIS + +B<Example 1> + + use Text::Wrap + + $initial_tab = "\t"; # Tab before first line + $subsequent_tab = ""; # All other lines flush left + + print wrap($initial_tab, $subsequent_tab, @text); + print fill($initial_tab, $subsequent_tab, @text); + + $lines = wrap($initial_tab, $subsequent_tab, @text); + + @paragraphs = fill($initial_tab, $subsequent_tab, @text); + +B<Example 2> + + use Text::Wrap qw(wrap $columns $huge); + + $columns = 132; # Wrap at 132 characters + $huge = 'die'; + $huge = 'wrap'; + $huge = 'overflow'; + +B<Example 3> + + use Text::Wrap + + $Text::Wrap::columns = 72; + print wrap('', '', @text); + +=head1 DESCRIPTION + +C<Text::Wrap::wrap()> is a very simple paragraph formatter. It formats a +single paragraph at a time by breaking lines at word boundries. +Indentation is controlled for the first line (C<$initial_tab>) and +all subsequent lines (C<$subsequent_tab>) independently. Please note: +C<$initial_tab> and C<$subsequent_tab> are the literal strings that will +be used: it is unlikley you would want to pass in a number. + +Text::Wrap::fill() is a simple multi-paragraph formatter. It formats +each paragraph separately and then joins them together when it's done. It +will destroy any whitespace in the original text. It breaks text into +paragraphs by looking for whitespace after a newline. In other respects +it acts like wrap(). + +=head1 OVERRIDES + +C<Text::Wrap::wrap()> has a number of variables that control its behavior. +Because other modules might be using C<Text::Wrap::wrap()> it is suggested +that you leave these variables alone! If you can't do that, then +use C<local($Text::Wrap::VARIABLE) = YOURVALUE> when you change the +values so that the original value is restored. This C<local()> trick +will not work if you import the variable into your own namespace. + +Lines are wrapped at C<$Text::Wrap::columns> columns. C<$Text::Wrap::columns> +should be set to the full width of your output device. In fact, +every resulting line will have length of no more than C<$columns - 1>. + +It is possible to control which characters terminate words by +modifying C<$Text::Wrap::break>. Set this to a string such as +C<'[\s:]'> (to break before spaces or colons) or a pre-compiled regexp +such as C<qr/[\s']/> (to break before spaces or apostrophes). The +default is simply C<'\s'>; that is, words are terminated by spaces. +(This means, among other things, that trailing punctuation such as +full stops or commas stay with the word they are "attached" to.) + +Beginner note: In example 2, above C<$columns> is imported into +the local namespace, and set locally. In example 3, +C<$Text::Wrap::columns> is set in its own namespace without importing it. + +C<Text::Wrap::wrap()> starts its work by expanding all the tabs in its +input into spaces. The last thing it does it to turn spaces back +into tabs. If you do not want tabs in your results, set +C<$Text::Wrap::unexpand> to a false value. Likewise if you do not +want to use 8-character tabstops, set C<$Text::Wrap::tabstop> to +the number of characters you do want for your tabstops. + +If you want to separate your lines with something other than C<\n> +then set C<$Text::Wrap::separator> to your preference. This replaces +all newlines with C<$Text::Wrap::separator>. If you just to preserve +existing newlines but add new breaks with something else, set +C<$Text::Wrap::separator2> instead. + +When words that are longer than C<$columns> are encountered, they +are broken up. C<wrap()> adds a C<"\n"> at column C<$columns>. +This behavior can be overridden by setting C<$huge> to +'die' or to 'overflow'. When set to 'die', large words will cause +C<die()> to be called. When set to 'overflow', large words will be +left intact. + +Historical notes: 'die' used to be the default value of +C<$huge>. Now, 'wrap' is the default value. + +=head1 EXAMPLE + + print wrap("\t","","This is a bit of text that forms + a normal book-style paragraph"); + +=head1 LICENSE + +David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and +many many others. Copyright (C) 1996-2002 David Muir Sharnoff. +This module may be modified, used, copied, and redistributed at +your own risk. Publicly redistributed modified versions must use +a different name. + diff --git a/Master/tlpkg/installer/perllib/Tie/Array.pm b/Master/tlpkg/installer/perllib/Tie/Array.pm new file mode 100644 index 00000000000..af8f51e9f51 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tie/Array.pm @@ -0,0 +1,287 @@ +package Tie::Array; + +use 5.006_001; +use strict; +use Carp; +our $VERSION = '1.03'; + +# Pod documentation after __END__ below. + +sub DESTROY { } +sub EXTEND { } +sub UNSHIFT { scalar shift->SPLICE(0,0,@_) } +sub SHIFT { shift->SPLICE(0,1) } +sub CLEAR { shift->STORESIZE(0) } + +sub PUSH +{ + my $obj = shift; + my $i = $obj->FETCHSIZE; + $obj->STORE($i++, shift) while (@_); +} + +sub POP +{ + my $obj = shift; + my $newsize = $obj->FETCHSIZE - 1; + my $val; + if ($newsize >= 0) + { + $val = $obj->FETCH($newsize); + $obj->STORESIZE($newsize); + } + $val; +} + +sub SPLICE { + my $obj = shift; + my $sz = $obj->FETCHSIZE; + my $off = (@_) ? shift : 0; + $off += $sz if ($off < 0); + my $len = (@_) ? shift : $sz - $off; + $len += $sz - $off if $len < 0; + my @result; + for (my $i = 0; $i < $len; $i++) { + push(@result,$obj->FETCH($off+$i)); + } + $off = $sz if $off > $sz; + $len -= $off + $len - $sz if $off + $len > $sz; + if (@_ > $len) { + # Move items up to make room + my $d = @_ - $len; + my $e = $off+$len; + $obj->EXTEND($sz+$d); + for (my $i=$sz-1; $i >= $e; $i--) { + my $val = $obj->FETCH($i); + $obj->STORE($i+$d,$val); + } + } + elsif (@_ < $len) { + # Move items down to close the gap + my $d = $len - @_; + my $e = $off+$len; + for (my $i=$off+$len; $i < $sz; $i++) { + my $val = $obj->FETCH($i); + $obj->STORE($i-$d,$val); + } + $obj->STORESIZE($sz-$d); + } + for (my $i=0; $i < @_; $i++) { + $obj->STORE($off+$i,$_[$i]); + } + return wantarray ? @result : pop @result; +} + +sub EXISTS { + my $pkg = ref $_[0]; + croak "$pkg doesn't define an EXISTS method"; +} + +sub DELETE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a DELETE method"; +} + +package Tie::StdArray; +use vars qw(@ISA); +@ISA = 'Tie::Array'; + +sub TIEARRAY { bless [], $_[0] } +sub FETCHSIZE { scalar @{$_[0]} } +sub STORESIZE { $#{$_[0]} = $_[1]-1 } +sub STORE { $_[0]->[$_[1]] = $_[2] } +sub FETCH { $_[0]->[$_[1]] } +sub CLEAR { @{$_[0]} = () } +sub POP { pop(@{$_[0]}) } +sub PUSH { my $o = shift; push(@$o,@_) } +sub SHIFT { shift(@{$_[0]}) } +sub UNSHIFT { my $o = shift; unshift(@$o,@_) } +sub EXISTS { exists $_[0]->[$_[1]] } +sub DELETE { delete $_[0]->[$_[1]] } + +sub SPLICE +{ + my $ob = shift; + my $sz = $ob->FETCHSIZE; + my $off = @_ ? shift : 0; + $off += $sz if $off < 0; + my $len = @_ ? shift : $sz-$off; + return splice(@$ob,$off,$len,@_); +} + +1; + +__END__ + +=head1 NAME + +Tie::Array - base class for tied arrays + +=head1 SYNOPSIS + + package Tie::NewArray; + use Tie::Array; + @ISA = ('Tie::Array'); + + # mandatory methods + sub TIEARRAY { ... } + sub FETCH { ... } + sub FETCHSIZE { ... } + + sub STORE { ... } # mandatory if elements writeable + sub STORESIZE { ... } # mandatory if elements can be added/deleted + sub EXISTS { ... } # mandatory if exists() expected to work + sub DELETE { ... } # mandatory if delete() expected to work + + # optional methods - for efficiency + sub CLEAR { ... } + sub PUSH { ... } + sub POP { ... } + sub SHIFT { ... } + sub UNSHIFT { ... } + sub SPLICE { ... } + sub EXTEND { ... } + sub DESTROY { ... } + + package Tie::NewStdArray; + use Tie::Array; + + @ISA = ('Tie::StdArray'); + + # all methods provided by default + + package main; + + $object = tie @somearray,Tie::NewArray; + $object = tie @somearray,Tie::StdArray; + $object = tie @somearray,Tie::NewStdArray; + + + +=head1 DESCRIPTION + +This module provides methods for array-tying classes. See +L<perltie> for a list of the functions required in order to tie an array +to a package. The basic B<Tie::Array> package provides stub C<DESTROY>, +and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS> +methods that croak() if the delete() or exists() builtins are ever called +on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>, +C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, +C<FETCHSIZE>, C<STORESIZE>. + +The B<Tie::StdArray> package provides efficient methods required for tied arrays +which are implemented as blessed references to an "inner" perl array. +It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly +like standard arrays, allowing for selective overloading of methods. + +For developers wishing to write their own tied arrays, the required methods +are briefly defined below. See the L<perltie> section for more detailed +descriptive, as well as example code: + +=over 4 + +=item TIEARRAY classname, LIST + +The class method is invoked by the command C<tie @array, classname>. Associates +an array instance with the specified class. C<LIST> would represent +additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed +to complete the association. The method should return an object of a class which +provides the methods below. + +=item STORE this, index, value + +Store datum I<value> into I<index> for the tied array associated with +object I<this>. If this makes the array larger then +class's mapping of C<undef> should be returned for new positions. + +=item FETCH this, index + +Retrieve the datum in I<index> for the tied array associated with +object I<this>. + +=item FETCHSIZE this + +Returns the total number of items in the tied array associated with +object I<this>. (Equivalent to C<scalar(@array)>). + +=item STORESIZE this, count + +Sets the total number of items in the tied array associated with +object I<this> to be I<count>. If this makes the array larger then +class's mapping of C<undef> should be returned for new positions. +If the array becomes smaller then entries beyond count should be +deleted. + +=item EXTEND this, count + +Informative call that array is likely to grow to have I<count> entries. +Can be used to optimize allocation. This method need do nothing. + +=item EXISTS this, key + +Verify that the element at index I<key> exists in the tied array I<this>. + +The B<Tie::Array> implementation is a stub that simply croaks. + +=item DELETE this, key + +Delete the element at index I<key> from the tied array I<this>. + +The B<Tie::Array> implementation is a stub that simply croaks. + +=item CLEAR this + +Clear (remove, delete, ...) all values from the tied array associated with +object I<this>. + +=item DESTROY this + +Normal object destructor method. + +=item PUSH this, LIST + +Append elements of LIST to the array. + +=item POP this + +Remove last element of the array and return it. + +=item SHIFT this + +Remove the first element of the array (shifting other elements down) +and return it. + +=item UNSHIFT this, LIST + +Insert LIST elements at the beginning of the array, moving existing elements +up to make room. + +=item SPLICE this, offset, length, LIST + +Perform the equivalent of C<splice> on the array. + +I<offset> is optional and defaults to zero, negative values count back +from the end of the array. + +I<length> is optional and defaults to rest of the array. + +I<LIST> may be empty. + +Returns a list of the original I<length> elements at I<offset>. + +=back + +=head1 CAVEATS + +There is no support at present for tied @ISA. There is a potential conflict +between magic entries needed to notice setting of @ISA, and those needed to +implement 'tie'. + +Very little consideration has been given to the behaviour of tied arrays +when C<$[> is not default value of zero. + +=head1 AUTHOR + +Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt> + +=cut diff --git a/Master/tlpkg/installer/perllib/Tie/File.pm b/Master/tlpkg/installer/perllib/Tie/File.pm new file mode 100644 index 00000000000..a1f40afe199 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tie/File.pm @@ -0,0 +1,2632 @@ + +package Tie::File; +require 5.005; +use Carp ':DEFAULT', 'confess'; +use POSIX 'SEEK_SET'; +use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY'; +sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY } + + +$VERSION = "0.97"; +my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes +my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records +my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful + +my %good_opt = map {$_ => 1, "-$_" => 1} + qw(memory dw_size mode recsep discipline + autodefer autochomp autodefer_threshhold concurrent); + +sub TIEARRAY { + if (@_ % 2 != 0) { + croak "usage: tie \@array, $_[0], filename, [option => value]..."; + } + my ($pack, $file, %opts) = @_; + + # transform '-foo' keys into 'foo' keys + for my $key (keys %opts) { + unless ($good_opt{$key}) { + croak("$pack: Unrecognized option '$key'\n"); + } + my $okey = $key; + if ($key =~ s/^-+//) { + $opts{$key} = delete $opts{$okey}; + } + } + + if ($opts{concurrent}) { + croak("$pack: concurrent access not supported yet\n"); + } + + unless (defined $opts{memory}) { + # default is the larger of the default cache size and the + # deferred-write buffer size (if specified) + $opts{memory} = $DEFAULT_MEMORY_SIZE; + $opts{memory} = $opts{dw_size} + if defined $opts{dw_size} && $opts{dw_size} > $DEFAULT_MEMORY_SIZE; + # Dora Winifred Read + } + $opts{dw_size} = $opts{memory} unless defined $opts{dw_size}; + if ($opts{dw_size} > $opts{memory}) { + croak("$pack: dw_size may not be larger than total memory allocation\n"); + } + # are we in deferred-write mode? + $opts{defer} = 0 unless defined $opts{defer}; + $opts{deferred} = {}; # no records are presently deferred + $opts{deferred_s} = 0; # count of total bytes in ->{deferred} + $opts{deferred_max} = -1; # empty + + # What's a good way to arrange that this class can be overridden? + $opts{cache} = Tie::File::Cache->new($opts{memory}); + + # autodeferment is enabled by default + $opts{autodefer} = 1 unless defined $opts{autodefer}; + $opts{autodeferring} = 0; # but is not initially active + $opts{ad_history} = []; + $opts{autodefer_threshhold} = $DEFAULT_AUTODEFER_THRESHHOLD + unless defined $opts{autodefer_threshhold}; + $opts{autodefer_filelen_threshhold} = $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD + unless defined $opts{autodefer_filelen_threshhold}; + + $opts{offsets} = [0]; + $opts{filename} = $file; + unless (defined $opts{recsep}) { + $opts{recsep} = _default_recsep(); + } + $opts{recseplen} = length($opts{recsep}); + if ($opts{recseplen} == 0) { + croak "Empty record separator not supported by $pack"; + } + + $opts{autochomp} = 1 unless defined $opts{autochomp}; + + $opts{mode} = O_CREAT|O_RDWR unless defined $opts{mode}; + $opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY); + $opts{sawlastrec} = undef; + + my $fh; + + if (UNIVERSAL::isa($file, 'GLOB')) { + # We use 1 here on the theory that some systems + # may not indicate failure if we use 0. + # MSWin32 does not indicate failure with 0, but I don't know if + # it will indicate failure with 1 or not. + unless (seek $file, 1, SEEK_SET) { + croak "$pack: your filehandle does not appear to be seekable"; + } + seek $file, 0, SEEK_SET # put it back + $fh = $file; # setting binmode is the user's problem + } elsif (ref $file) { + croak "usage: tie \@array, $pack, filename, [option => value]..."; + } else { + # $fh = \do { local *FH }; # XXX this is buggy + if ($] < 5.006) { + # perl 5.005 and earlier don't autovivify filehandles + require Symbol; + $fh = Symbol::gensym(); + } + sysopen $fh, $file, $opts{mode}, 0666 or return; + binmode $fh; + ++$opts{ourfh}; + } + { my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write + if (defined $opts{discipline} && $] >= 5.006) { + # This avoids a compile-time warning under 5.005 + eval 'binmode($fh, $opts{discipline})'; + croak $@ if $@ =~ /unknown discipline/i; + die if $@; + } + $opts{fh} = $fh; + + bless \%opts => $pack; +} + +sub FETCH { + my ($self, $n) = @_; + my $rec; + + # check the defer buffer + $rec = $self->{deferred}{$n} if exists $self->{deferred}{$n}; + $rec = $self->_fetch($n) unless defined $rec; + + # inlined _chomp1 + substr($rec, - $self->{recseplen}) = "" + if defined $rec && $self->{autochomp}; + $rec; +} + +# Chomp many records in-place; return nothing useful +sub _chomp { + my $self = shift; + return unless $self->{autochomp}; + if ($self->{autochomp}) { + for (@_) { + next unless defined; + substr($_, - $self->{recseplen}) = ""; + } + } +} + +# Chomp one record in-place; return modified record +sub _chomp1 { + my ($self, $rec) = @_; + return $rec unless $self->{autochomp}; + return unless defined $rec; + substr($rec, - $self->{recseplen}) = ""; + $rec; +} + +sub _fetch { + my ($self, $n) = @_; + + # check the record cache + { my $cached = $self->{cache}->lookup($n); + return $cached if defined $cached; + } + + if ($#{$self->{offsets}} < $n) { + return if $self->{eof}; # request for record beyond end of file + my $o = $self->_fill_offsets_to($n); + # If it's still undefined, there is no such record, so return 'undef' + return unless defined $o; + } + + my $fh = $self->{FH}; + $self->_seek($n); # we can do this now that offsets is populated + my $rec = $self->_read_record; + +# If we happen to have just read the first record, check to see if +# the length of the record matches what 'tell' says. If not, Tie::File +# won't work, and should drop dead. +# +# if ($n == 0 && defined($rec) && tell($self->{fh}) != length($rec)) { +# if (defined $self->{discipline}) { +# croak "I/O discipline $self->{discipline} not supported"; +# } else { +# croak "File encoding not supported"; +# } +# } + + $self->{cache}->insert($n, $rec) if defined $rec && not $self->{flushing}; + $rec; +} + +sub STORE { + my ($self, $n, $rec) = @_; + die "STORE called from _check_integrity!" if $DIAGNOSTIC; + + $self->_fixrecs($rec); + + if ($self->{autodefer}) { + $self->_annotate_ad_history($n); + } + + return $self->_store_deferred($n, $rec) if $self->_is_deferring; + + + # We need this to decide whether the new record will fit + # It incidentally populates the offsets table + # Note we have to do this before we alter the cache + # 20020324 Wait, but this DOES alter the cache. TODO BUG? + my $oldrec = $self->_fetch($n); + + if (not defined $oldrec) { + # We're storing a record beyond the end of the file + $self->_extend_file_to($n+1); + $oldrec = $self->{recsep}; + } +# return if $oldrec eq $rec; # don't bother + my $len_diff = length($rec) - length($oldrec); + + # length($oldrec) here is not consistent with text mode TODO XXX BUG + $self->_mtwrite($rec, $self->{offsets}[$n], length($oldrec)); + $self->_oadjust([$n, 1, $rec]); + $self->{cache}->update($n, $rec); +} + +sub _store_deferred { + my ($self, $n, $rec) = @_; + $self->{cache}->remove($n); + my $old_deferred = $self->{deferred}{$n}; + + if (defined $self->{deferred_max} && $n > $self->{deferred_max}) { + $self->{deferred_max} = $n; + } + $self->{deferred}{$n} = $rec; + + my $len_diff = length($rec); + $len_diff -= length($old_deferred) if defined $old_deferred; + $self->{deferred_s} += $len_diff; + $self->{cache}->adj_limit(-$len_diff); + if ($self->{deferred_s} > $self->{dw_size}) { + $self->_flush; + } elsif ($self->_cache_too_full) { + $self->_cache_flush; + } +} + +# Remove a single record from the deferred-write buffer without writing it +# The record need not be present +sub _delete_deferred { + my ($self, $n) = @_; + my $rec = delete $self->{deferred}{$n}; + return unless defined $rec; + + if (defined $self->{deferred_max} + && $n == $self->{deferred_max}) { + undef $self->{deferred_max}; + } + + $self->{deferred_s} -= length $rec; + $self->{cache}->adj_limit(length $rec); +} + +sub FETCHSIZE { + my $self = shift; + my $n = $self->{eof} ? $#{$self->{offsets}} : $self->_fill_offsets; + + my $top_deferred = $self->_defer_max; + $n = $top_deferred+1 if defined $top_deferred && $n < $top_deferred+1; + $n; +} + +sub STORESIZE { + my ($self, $len) = @_; + + if ($self->{autodefer}) { + $self->_annotate_ad_history('STORESIZE'); + } + + my $olen = $self->FETCHSIZE; + return if $len == $olen; # Woo-hoo! + + # file gets longer + if ($len > $olen) { + if ($self->_is_deferring) { + for ($olen .. $len-1) { + $self->_store_deferred($_, $self->{recsep}); + } + } else { + $self->_extend_file_to($len); + } + return; + } + + # file gets shorter + if ($self->_is_deferring) { + # TODO maybe replace this with map-plus-assignment? + for (grep $_ >= $len, keys %{$self->{deferred}}) { + $self->_delete_deferred($_); + } + $self->{deferred_max} = $len-1; + } + + $self->_seek($len); + $self->_chop_file; + $#{$self->{offsets}} = $len; +# $self->{offsets}[0] = 0; # in case we just chopped this + + $self->{cache}->remove(grep $_ >= $len, $self->{cache}->ckeys); +} + +### OPTIMIZE ME +### It should not be necessary to do FETCHSIZE +### Just seek to the end of the file. +sub PUSH { + my $self = shift; + $self->SPLICE($self->FETCHSIZE, scalar(@_), @_); + + # No need to return: + # $self->FETCHSIZE; # because av.c takes care of this for me +} + +sub POP { + my $self = shift; + my $size = $self->FETCHSIZE; + return if $size == 0; +# print STDERR "# POPPITY POP POP POP\n"; + scalar $self->SPLICE($size-1, 1); +} + +sub SHIFT { + my $self = shift; + scalar $self->SPLICE(0, 1); +} + +sub UNSHIFT { + my $self = shift; + $self->SPLICE(0, 0, @_); + # $self->FETCHSIZE; # av.c takes care of this for me +} + +sub CLEAR { + my $self = shift; + + if ($self->{autodefer}) { + $self->_annotate_ad_history('CLEAR'); + } + + $self->_seekb(0); + $self->_chop_file; + $self->{cache}->set_limit($self->{memory}); + $self->{cache}->empty; + @{$self->{offsets}} = (0); + %{$self->{deferred}}= (); + $self->{deferred_s} = 0; + $self->{deferred_max} = -1; +} + +sub EXTEND { + my ($self, $n) = @_; + + # No need to pre-extend anything in this case + return if $self->_is_deferring; + + $self->_fill_offsets_to($n); + $self->_extend_file_to($n); +} + +sub DELETE { + my ($self, $n) = @_; + + if ($self->{autodefer}) { + $self->_annotate_ad_history('DELETE'); + } + + my $lastrec = $self->FETCHSIZE-1; + my $rec = $self->FETCH($n); + $self->_delete_deferred($n) if $self->_is_deferring; + if ($n == $lastrec) { + $self->_seek($n); + $self->_chop_file; + $#{$self->{offsets}}--; + $self->{cache}->remove($n); + # perhaps in this case I should also remove trailing null records? + # 20020316 + # Note that delete @a[-3..-1] deletes the records in the wrong order, + # so we only chop the very last one out of the file. We could repair this + # by tracking deleted records inside the object. + } elsif ($n < $lastrec) { + $self->STORE($n, ""); + } + $rec; +} + +sub EXISTS { + my ($self, $n) = @_; + return 1 if exists $self->{deferred}{$n}; + $n < $self->FETCHSIZE; +} + +sub SPLICE { + my $self = shift; + + if ($self->{autodefer}) { + $self->_annotate_ad_history('SPLICE'); + } + + $self->_flush if $self->_is_deferring; # move this up? + if (wantarray) { + $self->_chomp(my @a = $self->_splice(@_)); + @a; + } else { + $self->_chomp1(scalar $self->_splice(@_)); + } +} + +sub DESTROY { + my $self = shift; + $self->flush if $self->_is_deferring; + $self->{cache}->delink if defined $self->{cache}; # break circular link + if ($self->{fh} and $self->{ourfh}) { + delete $self->{ourfh}; + close delete $self->{fh}; + } +} + +sub _splice { + my ($self, $pos, $nrecs, @data) = @_; + my @result; + + $pos = 0 unless defined $pos; + + # Deal with negative and other out-of-range positions + # Also set default for $nrecs + { + my $oldsize = $self->FETCHSIZE; + $nrecs = $oldsize unless defined $nrecs; + my $oldpos = $pos; + + if ($pos < 0) { + $pos += $oldsize; + if ($pos < 0) { + croak "Modification of non-creatable array value attempted, subscript $oldpos"; + } + } + + if ($pos > $oldsize) { + return unless @data; + $pos = $oldsize; # This is what perl does for normal arrays + } + + # The manual is very unclear here + if ($nrecs < 0) { + $nrecs = $oldsize - $pos + $nrecs; + $nrecs = 0 if $nrecs < 0; + } + + # nrecs is too big---it really means "until the end" + # 20030507 + if ($nrecs + $pos > $oldsize) { + $nrecs = $oldsize - $pos; + } + } + + $self->_fixrecs(@data); + my $data = join '', @data; + my $datalen = length $data; + my $oldlen = 0; + + # compute length of data being removed + for ($pos .. $pos+$nrecs-1) { + last unless defined $self->_fill_offsets_to($_); + my $rec = $self->_fetch($_); + last unless defined $rec; + push @result, $rec; + + # Why don't we just use length($rec) here? + # Because that record might have come from the cache. _splice + # might have been called to flush out the deferred-write records, + # and in this case length($rec) is the length of the record to be + # *written*, not the length of the actual record in the file. But + # the offsets are still true. 20020322 + $oldlen += $self->{offsets}[$_+1] - $self->{offsets}[$_] + if defined $self->{offsets}[$_+1]; + } + $self->_fill_offsets_to($pos+$nrecs); + + # Modify the file + $self->_mtwrite($data, $self->{offsets}[$pos], $oldlen); + # Adjust the offsets table + $self->_oadjust([$pos, $nrecs, @data]); + + { # Take this read cache stuff out into a separate function + # You made a half-attempt to put it into _oadjust. + # Finish something like that up eventually. + # STORE also needs to do something similarish + + # update the read cache, part 1 + # modified records + for ($pos .. $pos+$nrecs-1) { + my $new = $data[$_-$pos]; + if (defined $new) { + $self->{cache}->update($_, $new); + } else { + $self->{cache}->remove($_); + } + } + + # update the read cache, part 2 + # moved records - records past the site of the change + # need to be renumbered + # Maybe merge this with the previous block? + { + my @oldkeys = grep $_ >= $pos + $nrecs, $self->{cache}->ckeys; + my @newkeys = map $_-$nrecs+@data, @oldkeys; + $self->{cache}->rekey(\@oldkeys, \@newkeys); + } + + # Now there might be too much data in the cache, if we spliced out + # some short records and spliced in some long ones. If so, flush + # the cache. + $self->_cache_flush; + } + + # Yes, the return value of 'splice' *is* actually this complicated + wantarray ? @result : @result ? $result[-1] : undef; +} + + +# write data into the file +# $data is the data to be written. +# it should be written at position $pos, and should overwrite +# exactly $len of the following bytes. +# Note that if length($data) > $len, the subsequent bytes will have to +# be moved up, and if length($data) < $len, they will have to +# be moved down +sub _twrite { + my ($self, $data, $pos, $len) = @_; + + unless (defined $pos) { + die "\$pos was undefined in _twrite"; + } + + my $len_diff = length($data) - $len; + + if ($len_diff == 0) { # Woo-hoo! + my $fh = $self->{fh}; + $self->_seekb($pos); + $self->_write_record($data); + return; # well, that was easy. + } + + # the two records are of different lengths + # our strategy here: rewrite the tail of the file, + # reading ahead one buffer at a time + # $bufsize is required to be at least as large as the data we're overwriting + my $bufsize = _bufsize($len_diff); + my ($writepos, $readpos) = ($pos, $pos+$len); + my $next_block; + my $more_data; + + # Seems like there ought to be a way to avoid the repeated code + # and the special case here. The read(1) is also a little weird. + # Think about this. + do { + $self->_seekb($readpos); + my $br = read $self->{fh}, $next_block, $bufsize; + $more_data = read $self->{fh}, my($dummy), 1; + $self->_seekb($writepos); + $self->_write_record($data); + $readpos += $br; + $writepos += length $data; + $data = $next_block; + } while $more_data; + $self->_seekb($writepos); + $self->_write_record($next_block); + + # There might be leftover data at the end of the file + $self->_chop_file if $len_diff < 0; +} + +# _iwrite(D, S, E) +# Insert text D at position S. +# Let C = E-S-|D|. If C < 0; die. +# Data in [S,S+C) is copied to [S+D,S+D+C) = [S+D,E). +# Data in [S+C = E-D, E) is returned. Data in [E, oo) is untouched. +# +# In a later version, don't read the entire intervening area into +# memory at once; do the copying block by block. +sub _iwrite { + my $self = shift; + my ($D, $s, $e) = @_; + my $d = length $D; + my $c = $e-$s-$d; + local *FH = $self->{fh}; + confess "Not enough space to insert $d bytes between $s and $e" + if $c < 0; + confess "[$s,$e) is an invalid insertion range" if $e < $s; + + $self->_seekb($s); + read FH, my $buf, $e-$s; + + $D .= substr($buf, 0, $c, ""); + + $self->_seekb($s); + $self->_write_record($D); + + return $buf; +} + +# Like _twrite, but the data-pos-len triple may be repeated; you may +# write several chunks. All the writing will be done in +# one pass. Chunks SHALL be in ascending order and SHALL NOT overlap. +sub _mtwrite { + my $self = shift; + my $unwritten = ""; + my $delta = 0; + + @_ % 3 == 0 + or die "Arguments to _mtwrite did not come in groups of three"; + + while (@_) { + my ($data, $pos, $len) = splice @_, 0, 3; + my $end = $pos + $len; # The OLD end of the segment to be replaced + $data = $unwritten . $data; + $delta -= length($unwritten); + $unwritten = ""; + $pos += $delta; # This is where the data goes now + my $dlen = length $data; + $self->_seekb($pos); + if ($len >= $dlen) { # the data will fit + $self->_write_record($data); + $delta += ($dlen - $len); # everything following moves down by this much + $data = ""; # All the data in the buffer has been written + } else { # won't fit + my $writable = substr($data, 0, $len - $delta, ""); + $self->_write_record($writable); + $delta += ($dlen - $len); # everything following moves down by this much + } + + # At this point we've written some but maybe not all of the data. + # There might be a gap to close up, or $data might still contain a + # bunch of unwritten data that didn't fit. + my $ndlen = length $data; + if ($delta == 0) { + $self->_write_record($data); + } elsif ($delta < 0) { + # upcopy (close up gap) + if (@_) { + $self->_upcopy($end, $end + $delta, $_[1] - $end); + } else { + $self->_upcopy($end, $end + $delta); + } + } else { + # downcopy (insert data that didn't fit; replace this data in memory + # with _later_ data that doesn't fit) + if (@_) { + $unwritten = $self->_downcopy($data, $end, $_[1] - $end); + } else { + # Make the file longer to accomodate the last segment that doesn' + $unwritten = $self->_downcopy($data, $end); + } + } + } +} + +# Copy block of data of length $len from position $spos to position $dpos +# $dpos must be <= $spos +# +# If $len is undefined, go all the way to the end of the file +# and then truncate it ($spos - $dpos bytes will be removed) +sub _upcopy { + my $blocksize = 8192; + my ($self, $spos, $dpos, $len) = @_; + if ($dpos > $spos) { + die "source ($spos) was upstream of destination ($dpos) in _upcopy"; + } elsif ($dpos == $spos) { + return; + } + + while (! defined ($len) || $len > 0) { + my $readsize = ! defined($len) ? $blocksize + : $len > $blocksize ? $blocksize + : $len; + + my $fh = $self->{fh}; + $self->_seekb($spos); + my $bytes_read = read $fh, my($data), $readsize; + $self->_seekb($dpos); + if ($data eq "") { + $self->_chop_file; + last; + } + $self->_write_record($data); + $spos += $bytes_read; + $dpos += $bytes_read; + $len -= $bytes_read if defined $len; + } +} + +# Write $data into a block of length $len at position $pos, +# moving everything in the block forwards to make room. +# Instead of writing the last length($data) bytes from the block +# (because there isn't room for them any longer) return them. +# +# Undefined $len means 'until the end of the file' +sub _downcopy { + my $blocksize = 8192; + my ($self, $data, $pos, $len) = @_; + my $fh = $self->{fh}; + + while (! defined $len || $len > 0) { + my $readsize = ! defined($len) ? $blocksize + : $len > $blocksize? $blocksize : $len; + $self->_seekb($pos); + read $fh, my($old), $readsize; + my $last_read_was_short = length($old) < $readsize; + $data .= $old; + my $writable; + if ($last_read_was_short) { + # If last read was short, then $data now contains the entire rest + # of the file, so there's no need to write only one block of it + $writable = $data; + $data = ""; + } else { + $writable = substr($data, 0, $readsize, ""); + } + last if $writable eq ""; + $self->_seekb($pos); + $self->_write_record($writable); + last if $last_read_was_short && $data eq ""; + $len -= $readsize if defined $len; + $pos += $readsize; + } + return $data; +} + +# Adjust the object data structures following an '_mtwrite' +# Arguments are +# [$pos, $nrecs, @length] items +# indicating that $nrecs records were removed at $recpos (a record offset) +# and replaced with records of length @length... +# Arguments guarantee that $recpos is strictly increasing. +# No return value +sub _oadjust { + my $self = shift; + my $delta = 0; + my $delta_recs = 0; + my $prev_end = -1; + my %newkeys; + + for (@_) { + my ($pos, $nrecs, @data) = @$_; + $pos += $delta_recs; + + # Adjust the offsets of the records after the previous batch up + # to the first new one of this batch + for my $i ($prev_end+2 .. $pos - 1) { + $self->{offsets}[$i] += $delta; + $newkey{$i} = $i + $delta_recs; + } + + $prev_end = $pos + @data - 1; # last record moved on this pass + + # Remove the offsets for the removed records; + # replace with the offsets for the inserted records + my @newoff = ($self->{offsets}[$pos] + $delta); + for my $i (0 .. $#data) { + my $newlen = length $data[$i]; + push @newoff, $newoff[$i] + $newlen; + $delta += $newlen; + } + + for my $i ($pos .. $pos+$nrecs-1) { + last if $i+1 > $#{$self->{offsets}}; + my $oldlen = $self->{offsets}[$i+1] - $self->{offsets}[$i]; + $delta -= $oldlen; + } + +# # also this data has changed, so update it in the cache +# for (0 .. $#data) { +# $self->{cache}->update($pos + $_, $data[$_]); +# } +# if ($delta_recs) { +# my @oldkeys = grep $_ >= $pos + @data, $self->{cache}->ckeys; +# my @newkeys = map $_ + $delta_recs, @oldkeys; +# $self->{cache}->rekey(\@oldkeys, \@newkeys); +# } + + # replace old offsets with new + splice @{$self->{offsets}}, $pos, $nrecs+1, @newoff; + # What if we just spliced out the end of the offsets table? + # shouldn't we clear $self->{eof}? Test for this XXX BUG TODO + + $delta_recs += @data - $nrecs; # net change in total number of records + } + + # The trailing records at the very end of the file + if ($delta) { + for my $i ($prev_end+2 .. $#{$self->{offsets}}) { + $self->{offsets}[$i] += $delta; + } + } + + # If we scrubbed out all known offsets, regenerate the trivial table + # that knows that the file does indeed start at 0. + $self->{offsets}[0] = 0 unless @{$self->{offsets}}; + # If the file got longer, the offsets table is no longer complete + # $self->{eof} = 0 if $delta_recs > 0; + + # Now there might be too much data in the cache, if we spliced out + # some short records and spliced in some long ones. If so, flush + # the cache. + $self->_cache_flush; +} + +# If a record does not already end with the appropriate terminator +# string, append one. +sub _fixrecs { + my $self = shift; + for (@_) { + $_ = "" unless defined $_; + $_ .= $self->{recsep} + unless substr($_, - $self->{recseplen}) eq $self->{recsep}; + } +} + + +################################################################ +# +# Basic read, write, and seek +# + +# seek to the beginning of record #$n +# Assumes that the offsets table is already correctly populated +# +# Note that $n=-1 has a special meaning here: It means the start of +# the last known record; this may or may not be the very last record +# in the file, depending on whether the offsets table is fully populated. +# +sub _seek { + my ($self, $n) = @_; + my $o = $self->{offsets}[$n]; + defined($o) + or confess("logic error: undefined offset for record $n"); + seek $self->{fh}, $o, SEEK_SET + or confess "Couldn't seek filehandle: $!"; # "Should never happen." +} + +# seek to byte $b in the file +sub _seekb { + my ($self, $b) = @_; + seek $self->{fh}, $b, SEEK_SET + or die "Couldn't seek filehandle: $!"; # "Should never happen." +} + +# populate the offsets table up to the beginning of record $n +# return the offset of record $n +sub _fill_offsets_to { + my ($self, $n) = @_; + + return $self->{offsets}[$n] if $self->{eof}; + + my $fh = $self->{fh}; + local *OFF = $self->{offsets}; + my $rec; + + until ($#OFF >= $n) { + $self->_seek(-1); # tricky -- see comment at _seek + $rec = $self->_read_record; + if (defined $rec) { + push @OFF, int(tell $fh); # Tels says that int() saves memory here + } else { + $self->{eof} = 1; + return; # It turns out there is no such record + } + } + + # we have now read all the records up to record n-1, + # so we can return the offset of record n + $OFF[$n]; +} + +sub _fill_offsets { + my ($self) = @_; + + my $fh = $self->{fh}; + local *OFF = $self->{offsets}; + + $self->_seek(-1); # tricky -- see comment at _seek + + # Tels says that inlining read_record() would make this loop + # five times faster. 20030508 + while ( defined $self->_read_record()) { + # int() saves us memory here + push @OFF, int(tell $fh); + } + + $self->{eof} = 1; + $#OFF; +} + +# assumes that $rec is already suitably terminated +sub _write_record { + my ($self, $rec) = @_; + my $fh = $self->{fh}; + local $\ = ""; + print $fh $rec + or die "Couldn't write record: $!"; # "Should never happen." +# $self->{_written} += length($rec); +} + +sub _read_record { + my $self = shift; + my $rec; + { local $/ = $self->{recsep}; + my $fh = $self->{fh}; + $rec = <$fh>; + } + return unless defined $rec; + if (substr($rec, -$self->{recseplen}) ne $self->{recsep}) { + # improperly terminated final record --- quietly fix it. +# my $ac = substr($rec, -$self->{recseplen}); +# $ac =~ s/\n/\\n/g; + $self->{sawlastrec} = 1; + unless ($self->{rdonly}) { + local $\ = ""; + my $fh = $self->{fh}; + print $fh $self->{recsep}; + } + $rec .= $self->{recsep}; + } +# $self->{_read} += length($rec) if defined $rec; + $rec; +} + +sub _rw_stats { + my $self = shift; + @{$self}{'_read', '_written'}; +} + +################################################################ +# +# Read cache management + +sub _cache_flush { + my ($self) = @_; + $self->{cache}->reduce_size_to($self->{memory} - $self->{deferred_s}); +} + +sub _cache_too_full { + my $self = shift; + $self->{cache}->bytes + $self->{deferred_s} >= $self->{memory}; +} + +################################################################ +# +# File custodial services +# + + +# We have read to the end of the file and have the offsets table +# entirely populated. Now we need to write a new record beyond +# the end of the file. We prepare for this by writing +# empty records into the file up to the position we want +# +# assumes that the offsets table already contains the offset of record $n, +# if it exists, and extends to the end of the file if not. +sub _extend_file_to { + my ($self, $n) = @_; + $self->_seek(-1); # position after the end of the last record + my $pos = $self->{offsets}[-1]; + + # the offsets table has one entry more than the total number of records + my $extras = $n - $#{$self->{offsets}}; + + # Todo : just use $self->{recsep} x $extras here? + while ($extras-- > 0) { + $self->_write_record($self->{recsep}); + push @{$self->{offsets}}, int(tell $self->{fh}); + } +} + +# Truncate the file at the current position +sub _chop_file { + my $self = shift; + truncate $self->{fh}, tell($self->{fh}); +} + + +# compute the size of a buffer suitable for moving +# all the data in a file forward $n bytes +# ($n may be negative) +# The result should be at least $n. +sub _bufsize { + my $n = shift; + return 8192 if $n <= 0; + my $b = $n & ~8191; + $b += 8192 if $n & 8191; + $b; +} + +################################################################ +# +# Miscellaneous public methods +# + +# Lock the file +sub flock { + my ($self, $op) = @_; + unless (@_ <= 3) { + my $pack = ref $self; + croak "Usage: $pack\->flock([OPERATION])"; + } + my $fh = $self->{fh}; + $op = LOCK_EX unless defined $op; + my $locked = flock $fh, $op; + + if ($locked && ($op & (LOCK_EX | LOCK_SH))) { + # If you're locking the file, then presumably it's because + # there might have been a write access by another process. + # In that case, the read cache contents and the offsets table + # might be invalid, so discard them. 20030508 + $self->{offsets} = [0]; + $self->{cache}->empty; + } + + $locked; +} + +# Get/set autochomp option +sub autochomp { + my $self = shift; + if (@_) { + my $old = $self->{autochomp}; + $self->{autochomp} = shift; + $old; + } else { + $self->{autochomp}; + } +} + +# Get offset table entries; returns offset of nth record +sub offset { + my ($self, $n) = @_; + + if ($#{$self->{offsets}} < $n) { + return if $self->{eof}; # request for record beyond the end of file + my $o = $self->_fill_offsets_to($n); + # If it's still undefined, there is no such record, so return 'undef' + return unless defined $o; + } + + $self->{offsets}[$n]; +} + +sub discard_offsets { + my $self = shift; + $self->{offsets} = [0]; +} + +################################################################ +# +# Matters related to deferred writing +# + +# Defer writes +sub defer { + my $self = shift; + $self->_stop_autodeferring; + @{$self->{ad_history}} = (); + $self->{defer} = 1; +} + +# Flush deferred writes +# +# This could be better optimized to write the file in one pass, instead +# of one pass per block of records. But that will require modifications +# to _twrite, so I should have a good _twrite test suite first. +sub flush { + my $self = shift; + + $self->_flush; + $self->{defer} = 0; +} + +sub _old_flush { + my $self = shift; + my @writable = sort {$a<=>$b} (keys %{$self->{deferred}}); + + while (@writable) { + # gather all consecutive records from the front of @writable + my $first_rec = shift @writable; + my $last_rec = $first_rec+1; + ++$last_rec, shift @writable while @writable && $last_rec == $writable[0]; + --$last_rec; + $self->_fill_offsets_to($last_rec); + $self->_extend_file_to($last_rec); + $self->_splice($first_rec, $last_rec-$first_rec+1, + @{$self->{deferred}}{$first_rec .. $last_rec}); + } + + $self->_discard; # clear out defered-write-cache +} + +sub _flush { + my $self = shift; + my @writable = sort {$a<=>$b} (keys %{$self->{deferred}}); + my @args; + my @adjust; + + while (@writable) { + # gather all consecutive records from the front of @writable + my $first_rec = shift @writable; + my $last_rec = $first_rec+1; + ++$last_rec, shift @writable while @writable && $last_rec == $writable[0]; + --$last_rec; + my $end = $self->_fill_offsets_to($last_rec+1); + if (not defined $end) { + $self->_extend_file_to($last_rec); + $end = $self->{offsets}[$last_rec]; + } + my ($start) = $self->{offsets}[$first_rec]; + push @args, + join("", @{$self->{deferred}}{$first_rec .. $last_rec}), # data + $start, # position + $end-$start; # length + push @adjust, [$first_rec, # starting at this position... + $last_rec-$first_rec+1, # this many records... + # are replaced with these... + @{$self->{deferred}}{$first_rec .. $last_rec}, + ]; + } + + $self->_mtwrite(@args); # write multiple record groups + $self->_discard; # clear out defered-write-cache + $self->_oadjust(@adjust); +} + +# Discard deferred writes and disable future deferred writes +sub discard { + my $self = shift; + $self->_discard; + $self->{defer} = 0; +} + +# Discard deferred writes, but retain old deferred writing mode +sub _discard { + my $self = shift; + %{$self->{deferred}} = (); + $self->{deferred_s} = 0; + $self->{deferred_max} = -1; + $self->{cache}->set_limit($self->{memory}); +} + +# Deferred writing is enabled, either explicitly ($self->{defer}) +# or automatically ($self->{autodeferring}) +sub _is_deferring { + my $self = shift; + $self->{defer} || $self->{autodeferring}; +} + +# The largest record number of any deferred record +sub _defer_max { + my $self = shift; + return $self->{deferred_max} if defined $self->{deferred_max}; + my $max = -1; + for my $key (keys %{$self->{deferred}}) { + $max = $key if $key > $max; + } + $self->{deferred_max} = $max; + $max; +} + +################################################################ +# +# Matters related to autodeferment +# + +# Get/set autodefer option +sub autodefer { + my $self = shift; + if (@_) { + my $old = $self->{autodefer}; + $self->{autodefer} = shift; + if ($old) { + $self->_stop_autodeferring; + @{$self->{ad_history}} = (); + } + $old; + } else { + $self->{autodefer}; + } +} + +# The user is trying to store record #$n Record that in the history, +# and then enable (or disable) autodeferment if that seems useful. +# Note that it's OK for $n to be a non-number, as long as the function +# is prepared to deal with that. Nobody else looks at the ad_history. +# +# Now, what does the ad_history mean, and what is this function doing? +# Essentially, the idea is to enable autodeferring when we see that the +# user has made three consecutive STORE calls to three consecutive records. +# ("Three" is actually ->{autodefer_threshhold}.) +# A STORE call for record #$n inserts $n into the autodefer history, +# and if the history contains three consecutive records, we enable +# autodeferment. An ad_history of [X, Y] means that the most recent +# STOREs were for records X, X+1, ..., Y, in that order. +# +# Inserting a nonconsecutive number erases the history and starts over. +# +# Performing a special operation like SPLICE erases the history. +# +# There's one special case: CLEAR means that CLEAR was just called. +# In this case, we prime the history with [-2, -1] so that if the next +# write is for record 0, autodeferring goes on immediately. This is for +# the common special case of "@a = (...)". +# +sub _annotate_ad_history { + my ($self, $n) = @_; + return unless $self->{autodefer}; # feature is disabled + return if $self->{defer}; # already in explicit defer mode + return unless $self->{offsets}[-1] >= $self->{autodefer_filelen_threshhold}; + + local *H = $self->{ad_history}; + if ($n eq 'CLEAR') { + @H = (-2, -1); # prime the history with fake records + $self->_stop_autodeferring; + } elsif ($n =~ /^\d+$/) { + if (@H == 0) { + @H = ($n, $n); + } else { # @H == 2 + if ($H[1] == $n-1) { # another consecutive record + $H[1]++; + if ($H[1] - $H[0] + 1 >= $self->{autodefer_threshhold}) { + $self->{autodeferring} = 1; + } + } else { # nonconsecutive- erase and start over + @H = ($n, $n); + $self->_stop_autodeferring; + } + } + } else { # SPLICE or STORESIZE or some such + @H = (); + $self->_stop_autodeferring; + } +} + +# If autodeferring was enabled, cut it out and discard the history +sub _stop_autodeferring { + my $self = shift; + if ($self->{autodeferring}) { + $self->_flush; + } + $self->{autodeferring} = 0; +} + +################################################################ + + +# This is NOT a method. It is here for two reasons: +# 1. To factor a fairly complicated block out of the constructor +# 2. To provide access for the test suite, which need to be sure +# files are being written properly. +sub _default_recsep { + my $recsep = $/; + if ($^O eq 'MSWin32') { # Dos too? + # Windows users expect files to be terminated with \r\n + # But $/ is set to \n instead + # Note that this also transforms \n\n into \r\n\r\n. + # That is a feature. + $recsep =~ s/\n/\r\n/g; + } + $recsep; +} + +# Utility function for _check_integrity +sub _ci_warn { + my $msg = shift; + $msg =~ s/\n/\\n/g; + $msg =~ s/\r/\\r/g; + print "# $msg\n"; +} + +# Given a file, make sure the cache is consistent with the +# file contents and the internal data structures are consistent with +# each other. Returns true if everything checks out, false if not +# +# The $file argument is no longer used. It is retained for compatibility +# with the existing test suite. +sub _check_integrity { + my ($self, $file, $warn) = @_; + my $rsl = $self->{recseplen}; + my $rs = $self->{recsep}; + my $good = 1; + local *_; # local $_ does not work here + local $DIAGNOSTIC = 1; + + if (not defined $rs) { + _ci_warn("recsep is undef!"); + $good = 0; + } elsif ($rs eq "") { + _ci_warn("recsep is empty!"); + $good = 0; + } elsif ($rsl != length $rs) { + my $ln = length $rs; + _ci_warn("recsep <$rs> has length $ln, should be $rsl"); + $good = 0; + } + + if (not defined $self->{offsets}[0]) { + _ci_warn("offset 0 is missing!"); + $good = 0; + + } elsif ($self->{offsets}[0] != 0) { + _ci_warn("rec 0: offset <$self->{offsets}[0]> s/b 0!"); + $good = 0; + } + + my $cached = 0; + { + local *F = $self->{fh}; + seek F, 0, SEEK_SET; + local $. = 0; + local $/ = $rs; + + while (<F>) { + my $n = $. - 1; + my $cached = $self->{cache}->_produce($n); + my $offset = $self->{offsets}[$.]; + my $ao = tell F; + if (defined $offset && $offset != $ao) { + _ci_warn("rec $n: offset <$offset> actual <$ao>"); + $good = 0; + } + if (defined $cached && $_ ne $cached && ! $self->{deferred}{$n}) { + $good = 0; + _ci_warn("rec $n: cached <$cached> actual <$_>"); + } + if (defined $cached && substr($cached, -$rsl) ne $rs) { + $good = 0; + _ci_warn("rec $n in the cache is missing the record separator"); + } + if (! defined $offset && $self->{eof}) { + $good = 0; + _ci_warn("The offset table was marked complete, but it is missing element $."); + } + } + if (@{$self->{offsets}} > $.+1) { + $good = 0; + my $n = @{$self->{offsets}}; + _ci_warn("The offset table has $n items, but the file has only $."); + } + + my $deferring = $self->_is_deferring; + for my $n ($self->{cache}->ckeys) { + my $r = $self->{cache}->_produce($n); + $cached += length($r); + next if $n+1 <= $.; # checked this already + _ci_warn("spurious caching of record $n"); + $good = 0; + } + my $b = $self->{cache}->bytes; + if ($cached != $b) { + _ci_warn("cache size is $b, should be $cached"); + $good = 0; + } + } + + # That cache has its own set of tests + $good = 0 unless $self->{cache}->_check_integrity; + + # Now let's check the deferbuffer + # Unless deferred writing is enabled, it should be empty + if (! $self->_is_deferring && %{$self->{deferred}}) { + _ci_warn("deferred writing disabled, but deferbuffer nonempty"); + $good = 0; + } + + # Any record in the deferbuffer should *not* be present in the readcache + my $deferred_s = 0; + while (my ($n, $r) = each %{$self->{deferred}}) { + $deferred_s += length($r); + if (defined $self->{cache}->_produce($n)) { + _ci_warn("record $n is in the deferbuffer *and* the readcache"); + $good = 0; + } + if (substr($r, -$rsl) ne $rs) { + _ci_warn("rec $n in the deferbuffer is missing the record separator"); + $good = 0; + } + } + + # Total size of deferbuffer should match internal total + if ($deferred_s != $self->{deferred_s}) { + _ci_warn("buffer size is $self->{deferred_s}, should be $deferred_s"); + $good = 0; + } + + # Total size of deferbuffer should not exceed the specified limit + if ($deferred_s > $self->{dw_size}) { + _ci_warn("buffer size is $self->{deferred_s} which exceeds the limit of $self->{dw_size}"); + $good = 0; + } + + # Total size of cached data should not exceed the specified limit + if ($deferred_s + $cached > $self->{memory}) { + my $total = $deferred_s + $cached; + _ci_warn("total stored data size is $total which exceeds the limit of $self->{memory}"); + $good = 0; + } + + # Stuff related to autodeferment + if (!$self->{autodefer} && @{$self->{ad_history}}) { + _ci_warn("autodefer is disabled, but ad_history is nonempty"); + $good = 0; + } + if ($self->{autodeferring} && $self->{defer}) { + _ci_warn("both autodeferring and explicit deferring are active"); + $good = 0; + } + if (@{$self->{ad_history}} == 0) { + # That's OK, no additional tests required + } elsif (@{$self->{ad_history}} == 2) { + my @non_number = grep !/^-?\d+$/, @{$self->{ad_history}}; + if (@non_number) { + my $msg; + { local $" = ')('; + $msg = "ad_history contains non-numbers (@{$self->{ad_history}})"; + } + _ci_warn($msg); + $good = 0; + } elsif ($self->{ad_history}[1] < $self->{ad_history}[0]) { + _ci_warn("ad_history has nonsensical values @{$self->{ad_history}}"); + $good = 0; + } + } else { + _ci_warn("ad_history has bad length <@{$self->{ad_history}}>"); + $good = 0; + } + + $good; +} + +################################################################ +# +# Tie::File::Cache +# +# Read cache + +package Tie::File::Cache; +$Tie::File::Cache::VERSION = $Tie::File::VERSION; +use Carp ':DEFAULT', 'confess'; + +sub HEAP () { 0 } +sub HASH () { 1 } +sub MAX () { 2 } +sub BYTES() { 3 } +#sub STAT () { 4 } # Array with request statistics for each record +#sub MISS () { 5 } # Total number of cache misses +#sub REQ () { 6 } # Total number of cache requests +use strict 'vars'; + +sub new { + my ($pack, $max) = @_; + local *_; + croak "missing argument to ->new" unless defined $max; + my $self = []; + bless $self => $pack; + @$self = (Tie::File::Heap->new($self), {}, $max, 0); + $self; +} + +sub adj_limit { + my ($self, $n) = @_; + $self->[MAX] += $n; +} + +sub set_limit { + my ($self, $n) = @_; + $self->[MAX] = $n; +} + +# For internal use only +# Will be called by the heap structure to notify us that a certain +# piece of data has moved from one heap element to another. +# $k is the hash key of the item +# $n is the new index into the heap at which it is stored +# If $n is undefined, the item has been removed from the heap. +sub _heap_move { + my ($self, $k, $n) = @_; + if (defined $n) { + $self->[HASH]{$k} = $n; + } else { + delete $self->[HASH]{$k}; + } +} + +sub insert { + my ($self, $key, $val) = @_; + local *_; + croak "missing argument to ->insert" unless defined $key; + unless (defined $self->[MAX]) { + confess "undefined max" ; + } + confess "undefined val" unless defined $val; + return if length($val) > $self->[MAX]; + +# if ($self->[STAT]) { +# $self->[STAT][$key] = 1; +# return; +# } + + my $oldnode = $self->[HASH]{$key}; + if (defined $oldnode) { + my $oldval = $self->[HEAP]->set_val($oldnode, $val); + $self->[BYTES] -= length($oldval); + } else { + $self->[HEAP]->insert($key, $val); + } + $self->[BYTES] += length($val); + $self->flush if $self->[BYTES] > $self->[MAX]; +} + +sub expire { + my $self = shift; + my $old_data = $self->[HEAP]->popheap; + return unless defined $old_data; + $self->[BYTES] -= length $old_data; + $old_data; +} + +sub remove { + my ($self, @keys) = @_; + my @result; + +# if ($self->[STAT]) { +# for my $key (@keys) { +# $self->[STAT][$key] = 0; +# } +# return; +# } + + for my $key (@keys) { + next unless exists $self->[HASH]{$key}; + my $old_data = $self->[HEAP]->remove($self->[HASH]{$key}); + $self->[BYTES] -= length $old_data; + push @result, $old_data; + } + @result; +} + +sub lookup { + my ($self, $key) = @_; + local *_; + croak "missing argument to ->lookup" unless defined $key; + +# if ($self->[STAT]) { +# $self->[MISS]++ if $self->[STAT][$key]++ == 0; +# $self->[REQ]++; +# my $hit_rate = 1 - $self->[MISS] / $self->[REQ]; +# # Do some testing to determine this threshhold +# $#$self = STAT - 1 if $hit_rate > 0.20; +# } + + if (exists $self->[HASH]{$key}) { + $self->[HEAP]->lookup($self->[HASH]{$key}); + } else { + return; + } +} + +# For internal use only +sub _produce { + my ($self, $key) = @_; + my $loc = $self->[HASH]{$key}; + return unless defined $loc; + $self->[HEAP][$loc][2]; +} + +# For internal use only +sub _promote { + my ($self, $key) = @_; + $self->[HEAP]->promote($self->[HASH]{$key}); +} + +sub empty { + my ($self) = @_; + %{$self->[HASH]} = (); + $self->[BYTES] = 0; + $self->[HEAP]->empty; +# @{$self->[STAT]} = (); +# $self->[MISS] = 0; +# $self->[REQ] = 0; +} + +sub is_empty { + my ($self) = @_; + keys %{$self->[HASH]} == 0; +} + +sub update { + my ($self, $key, $val) = @_; + local *_; + croak "missing argument to ->update" unless defined $key; + if (length($val) > $self->[MAX]) { + my ($oldval) = $self->remove($key); + $self->[BYTES] -= length($oldval) if defined $oldval; + } elsif (exists $self->[HASH]{$key}) { + my $oldval = $self->[HEAP]->set_val($self->[HASH]{$key}, $val); + $self->[BYTES] += length($val); + $self->[BYTES] -= length($oldval) if defined $oldval; + } else { + $self->[HEAP]->insert($key, $val); + $self->[BYTES] += length($val); + } + $self->flush; +} + +sub rekey { + my ($self, $okeys, $nkeys) = @_; + local *_; + my %map; + @map{@$okeys} = @$nkeys; + croak "missing argument to ->rekey" unless defined $nkeys; + croak "length mismatch in ->rekey arguments" unless @$nkeys == @$okeys; + my %adjusted; # map new keys to heap indices + # You should be able to cut this to one loop TODO XXX + for (0 .. $#$okeys) { + $adjusted{$nkeys->[$_]} = delete $self->[HASH]{$okeys->[$_]}; + } + while (my ($nk, $ix) = each %adjusted) { + # @{$self->[HASH]}{keys %adjusted} = values %adjusted; + $self->[HEAP]->rekey($ix, $nk); + $self->[HASH]{$nk} = $ix; + } +} + +sub ckeys { + my $self = shift; + my @a = keys %{$self->[HASH]}; + @a; +} + +# Return total amount of cached data +sub bytes { + my $self = shift; + $self->[BYTES]; +} + +# Expire oldest item from cache until cache size is smaller than $max +sub reduce_size_to { + my ($self, $max) = @_; + until ($self->[BYTES] <= $max) { + # Note that Tie::File::Cache::expire has been inlined here + my $old_data = $self->[HEAP]->popheap; + return unless defined $old_data; + $self->[BYTES] -= length $old_data; + } +} + +# Why not just $self->reduce_size_to($self->[MAX])? +# Try this when things stabilize TODO XXX +# If the cache is too full, expire the oldest records +sub flush { + my $self = shift; + $self->reduce_size_to($self->[MAX]) if $self->[BYTES] > $self->[MAX]; +} + +# For internal use only +sub _produce_lru { + my $self = shift; + $self->[HEAP]->expire_order; +} + +BEGIN { *_ci_warn = \&Tie::File::_ci_warn } + +sub _check_integrity { # For CACHE + my $self = shift; + my $good = 1; + + # Test HEAP + $self->[HEAP]->_check_integrity or $good = 0; + + # Test HASH + my $bytes = 0; + for my $k (keys %{$self->[HASH]}) { + if ($k ne '0' && $k !~ /^[1-9][0-9]*$/) { + $good = 0; + _ci_warn "Cache hash key <$k> is non-numeric"; + } + + my $h = $self->[HASH]{$k}; + if (! defined $h) { + $good = 0; + _ci_warn "Heap index number for key $k is undefined"; + } elsif ($h == 0) { + $good = 0; + _ci_warn "Heap index number for key $k is zero"; + } else { + my $j = $self->[HEAP][$h]; + if (! defined $j) { + $good = 0; + _ci_warn "Heap contents key $k (=> $h) are undefined"; + } else { + $bytes += length($j->[2]); + if ($k ne $j->[1]) { + $good = 0; + _ci_warn "Heap contents key $k (=> $h) is $j->[1], should be $k"; + } + } + } + } + + # Test BYTES + if ($bytes != $self->[BYTES]) { + $good = 0; + _ci_warn "Total data in cache is $bytes, expected $self->[BYTES]"; + } + + # Test MAX + if ($bytes > $self->[MAX]) { + $good = 0; + _ci_warn "Total data in cache is $bytes, exceeds maximum $self->[MAX]"; + } + + return $good; +} + +sub delink { + my $self = shift; + $self->[HEAP] = undef; # Bye bye heap +} + +################################################################ +# +# Tie::File::Heap +# +# Heap data structure for use by cache LRU routines + +package Tie::File::Heap; +use Carp ':DEFAULT', 'confess'; +$Tie::File::Heap::VERSION = $Tie::File::Cache::VERSION; +sub SEQ () { 0 }; +sub KEY () { 1 }; +sub DAT () { 2 }; + +sub new { + my ($pack, $cache) = @_; + die "$pack: Parent cache object $cache does not support _heap_move method" + unless eval { $cache->can('_heap_move') }; + my $self = [[0,$cache,0]]; + bless $self => $pack; +} + +# Allocate a new sequence number, larger than all previously allocated numbers +sub _nseq { + my $self = shift; + $self->[0][0]++; +} + +sub _cache { + my $self = shift; + $self->[0][1]; +} + +sub _nelts { + my $self = shift; + $self->[0][2]; +} + +sub _nelts_inc { + my $self = shift; + ++$self->[0][2]; +} + +sub _nelts_dec { + my $self = shift; + --$self->[0][2]; +} + +sub is_empty { + my $self = shift; + $self->_nelts == 0; +} + +sub empty { + my $self = shift; + $#$self = 0; + $self->[0][2] = 0; + $self->[0][0] = 0; # might as well reset the sequence numbers +} + +# notify the parent cache object that we moved something +sub _heap_move { + my $self = shift; + $self->_cache->_heap_move(@_); +} + +# Insert a piece of data into the heap with the indicated sequence number. +# The item with the smallest sequence number is always at the top. +# If no sequence number is specified, allocate a new one and insert the +# item at the bottom. +sub insert { + my ($self, $key, $data, $seq) = @_; + $seq = $self->_nseq unless defined $seq; + $self->_insert_new([$seq, $key, $data]); +} + +# Insert a new, fresh item at the bottom of the heap +sub _insert_new { + my ($self, $item) = @_; + my $i = @$self; + $i = int($i/2) until defined $self->[$i/2]; + $self->[$i] = $item; + $self->[0][1]->_heap_move($self->[$i][KEY], $i); + $self->_nelts_inc; +} + +# Insert [$data, $seq] pair at or below item $i in the heap. +# If $i is omitted, default to 1 (the top element.) +sub _insert { + my ($self, $item, $i) = @_; +# $self->_check_loc($i) if defined $i; + $i = 1 unless defined $i; + until (! defined $self->[$i]) { + if ($self->[$i][SEQ] > $item->[SEQ]) { # inserted item is older + ($self->[$i], $item) = ($item, $self->[$i]); + $self->[0][1]->_heap_move($self->[$i][KEY], $i); + } + # If either is undefined, go that way. Otherwise, choose at random + my $dir; + $dir = 0 if !defined $self->[2*$i]; + $dir = 1 if !defined $self->[2*$i+1]; + $dir = int(rand(2)) unless defined $dir; + $i = 2*$i + $dir; + } + $self->[$i] = $item; + $self->[0][1]->_heap_move($self->[$i][KEY], $i); + $self->_nelts_inc; +} + +# Remove the item at node $i from the heap, moving child items upwards. +# The item with the smallest sequence number is always at the top. +# Moving items upwards maintains this condition. +# Return the removed item. Return undef if there was no item at node $i. +sub remove { + my ($self, $i) = @_; + $i = 1 unless defined $i; + my $top = $self->[$i]; + return unless defined $top; + while (1) { + my $ii; + my ($L, $R) = (2*$i, 2*$i+1); + + # If either is undefined, go the other way. + # Otherwise, go towards the smallest. + last unless defined $self->[$L] || defined $self->[$R]; + $ii = $R if not defined $self->[$L]; + $ii = $L if not defined $self->[$R]; + unless (defined $ii) { + $ii = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R; + } + + $self->[$i] = $self->[$ii]; # Promote child to fill vacated spot + $self->[0][1]->_heap_move($self->[$i][KEY], $i); + $i = $ii; # Fill new vacated spot + } + $self->[0][1]->_heap_move($top->[KEY], undef); + undef $self->[$i]; + $self->_nelts_dec; + return $top->[DAT]; +} + +sub popheap { + my $self = shift; + $self->remove(1); +} + +# set the sequence number of the indicated item to a higher number +# than any other item in the heap, and bubble the item down to the +# bottom. +sub promote { + my ($self, $n) = @_; +# $self->_check_loc($n); + $self->[$n][SEQ] = $self->_nseq; + my $i = $n; + while (1) { + my ($L, $R) = (2*$i, 2*$i+1); + my $dir; + last unless defined $self->[$L] || defined $self->[$R]; + $dir = $R unless defined $self->[$L]; + $dir = $L unless defined $self->[$R]; + unless (defined $dir) { + $dir = $self->[$L][SEQ] < $self->[$R][SEQ] ? $L : $R; + } + @{$self}[$i, $dir] = @{$self}[$dir, $i]; + for ($i, $dir) { + $self->[0][1]->_heap_move($self->[$_][KEY], $_) if defined $self->[$_]; + } + $i = $dir; + } +} + +# Return item $n from the heap, promoting its LRU status +sub lookup { + my ($self, $n) = @_; +# $self->_check_loc($n); + my $val = $self->[$n]; + $self->promote($n); + $val->[DAT]; +} + + +# Assign a new value for node $n, promoting it to the bottom of the heap +sub set_val { + my ($self, $n, $val) = @_; +# $self->_check_loc($n); + my $oval = $self->[$n][DAT]; + $self->[$n][DAT] = $val; + $self->promote($n); + return $oval; +} + +# The hask key has changed for an item; +# alter the heap's record of the hash key +sub rekey { + my ($self, $n, $new_key) = @_; +# $self->_check_loc($n); + $self->[$n][KEY] = $new_key; +} + +sub _check_loc { + my ($self, $n) = @_; + unless (1 || defined $self->[$n]) { + confess "_check_loc($n) failed"; + } +} + +BEGIN { *_ci_warn = \&Tie::File::_ci_warn } + +sub _check_integrity { + my $self = shift; + my $good = 1; + my %seq; + + unless (eval {$self->[0][1]->isa("Tie::File::Cache")}) { + _ci_warn "Element 0 of heap corrupt"; + $good = 0; + } + $good = 0 unless $self->_satisfies_heap_condition(1); + for my $i (2 .. $#{$self}) { + my $p = int($i/2); # index of parent node + if (defined $self->[$i] && ! defined $self->[$p]) { + _ci_warn "Element $i of heap defined, but parent $p isn't"; + $good = 0; + } + + if (defined $self->[$i]) { + if ($seq{$self->[$i][SEQ]}) { + my $seq = $self->[$i][SEQ]; + _ci_warn "Nodes $i and $seq{$seq} both have SEQ=$seq"; + $good = 0; + } else { + $seq{$self->[$i][SEQ]} = $i; + } + } + } + + return $good; +} + +sub _satisfies_heap_condition { + my $self = shift; + my $n = shift || 1; + my $good = 1; + for (0, 1) { + my $c = $n*2 + $_; + next unless defined $self->[$c]; + if ($self->[$n][SEQ] >= $self->[$c]) { + _ci_warn "Node $n of heap does not predate node $c"; + $good = 0 ; + } + $good = 0 unless $self->_satisfies_heap_condition($c); + } + return $good; +} + +# Return a list of all the values, sorted by expiration order +sub expire_order { + my $self = shift; + my @nodes = sort {$a->[SEQ] <=> $b->[SEQ]} $self->_nodes; + map { $_->[KEY] } @nodes; +} + +sub _nodes { + my $self = shift; + my $i = shift || 1; + return unless defined $self->[$i]; + ($self->[$i], $self->_nodes($i*2), $self->_nodes($i*2+1)); +} + +"Cogito, ergo sum."; # don't forget to return a true value from the file + +__END__ + +=head1 NAME + +Tie::File - Access the lines of a disk file via a Perl array + +=head1 SYNOPSIS + + # This file documents Tie::File version 0.97 + use Tie::File; + + tie @array, 'Tie::File', filename or die ...; + + $array[13] = 'blah'; # line 13 of the file is now 'blah' + print $array[42]; # display line 42 of the file + + $n_recs = @array; # how many records are in the file? + $#array -= 2; # chop two records off the end + + + for (@array) { + s/PERL/Perl/g; # Replace PERL with Perl everywhere in the file + } + + # These are just like regular push, pop, unshift, shift, and splice + # Except that they modify the file in the way you would expect + + push @array, new recs...; + my $r1 = pop @array; + unshift @array, new recs...; + my $r2 = shift @array; + @old_recs = splice @array, 3, 7, new recs...; + + untie @array; # all finished + + +=head1 DESCRIPTION + +C<Tie::File> represents a regular text file as a Perl array. Each +element in the array corresponds to a record in the file. The first +line of the file is element 0 of the array; the second line is element +1, and so on. + +The file is I<not> loaded into memory, so this will work even for +gigantic files. + +Changes to the array are reflected in the file immediately. + +Lazy people and beginners may now stop reading the manual. + +=head2 C<recsep> + +What is a 'record'? By default, the meaning is the same as for the +C<E<lt>...E<gt>> operator: It's a string terminated by C<$/>, which is +probably C<"\n">. (Minor exception: on DOS and Win32 systems, a +'record' is a string terminated by C<"\r\n">.) You may change the +definition of "record" by supplying the C<recsep> option in the C<tie> +call: + + tie @array, 'Tie::File', $file, recsep => 'es'; + +This says that records are delimited by the string C<es>. If the file +contained the following data: + + Curse these pesky flies!\n + +then the C<@array> would appear to have four elements: + + "Curse th" + "e p" + "ky fli" + "!\n" + +An undefined value is not permitted as a record separator. Perl's +special "paragraph mode" semantics (E<agrave> la C<$/ = "">) are not +emulated. + +Records read from the tied array do not have the record separator +string on the end; this is to allow + + $array[17] .= "extra"; + +to work as expected. + +(See L<"autochomp">, below.) Records stored into the array will have +the record separator string appended before they are written to the +file, if they don't have one already. For example, if the record +separator string is C<"\n">, then the following two lines do exactly +the same thing: + + $array[17] = "Cherry pie"; + $array[17] = "Cherry pie\n"; + +The result is that the contents of line 17 of the file will be +replaced with "Cherry pie"; a newline character will separate line 17 +from line 18. This means that this code will do nothing: + + chomp $array[17]; + +Because the C<chomp>ed value will have the separator reattached when +it is written back to the file. There is no way to create a file +whose trailing record separator string is missing. + +Inserting records that I<contain> the record separator string is not +supported by this module. It will probably produce a reasonable +result, but what this result will be may change in a future version. +Use 'splice' to insert records or to replace one record with several. + +=head2 C<autochomp> + +Normally, array elements have the record separator removed, so that if +the file contains the text + + Gold + Frankincense + Myrrh + +the tied array will appear to contain C<("Gold", "Frankincense", +"Myrrh")>. If you set C<autochomp> to a false value, the record +separator will not be removed. If the file above was tied with + + tie @gifts, "Tie::File", $gifts, autochomp => 0; + +then the array C<@gifts> would appear to contain C<("Gold\n", +"Frankincense\n", "Myrrh\n")>, or (on Win32 systems) C<("Gold\r\n", +"Frankincense\r\n", "Myrrh\r\n")>. + +=head2 C<mode> + +Normally, the specified file will be opened for read and write access, +and will be created if it does not exist. (That is, the flags +C<O_RDWR | O_CREAT> are supplied in the C<open> call.) If you want to +change this, you may supply alternative flags in the C<mode> option. +See L<Fcntl> for a listing of available flags. +For example: + + # open the file if it exists, but fail if it does not exist + use Fcntl 'O_RDWR'; + tie @array, 'Tie::File', $file, mode => O_RDWR; + + # create the file if it does not exist + use Fcntl 'O_RDWR', 'O_CREAT'; + tie @array, 'Tie::File', $file, mode => O_RDWR | O_CREAT; + + # open an existing file in read-only mode + use Fcntl 'O_RDONLY'; + tie @array, 'Tie::File', $file, mode => O_RDONLY; + +Opening the data file in write-only or append mode is not supported. + +=head2 C<memory> + +This is an upper limit on the amount of memory that C<Tie::File> will +consume at any time while managing the file. This is used for two +things: managing the I<read cache> and managing the I<deferred write +buffer>. + +Records read in from the file are cached, to avoid having to re-read +them repeatedly. If you read the same record twice, the first time it +will be stored in memory, and the second time it will be fetched from +the I<read cache>. The amount of data in the read cache will not +exceed the value you specified for C<memory>. If C<Tie::File> wants +to cache a new record, but the read cache is full, it will make room +by expiring the least-recently visited records from the read cache. + +The default memory limit is 2Mib. You can adjust the maximum read +cache size by supplying the C<memory> option. The argument is the +desired cache size, in bytes. + + # I have a lot of memory, so use a large cache to speed up access + tie @array, 'Tie::File', $file, memory => 20_000_000; + +Setting the memory limit to 0 will inhibit caching; records will be +fetched from disk every time you examine them. + +The C<memory> value is not an absolute or exact limit on the memory +used. C<Tie::File> objects contains some structures besides the read +cache and the deferred write buffer, whose sizes are not charged +against C<memory>. + +The cache itself consumes about 310 bytes per cached record, so if +your file has many short records, you may want to decrease the cache +memory limit, or else the cache overhead may exceed the size of the +cached data. + + +=head2 C<dw_size> + +(This is an advanced feature. Skip this section on first reading.) + +If you use deferred writing (See L<"Deferred Writing">, below) then +data you write into the array will not be written directly to the +file; instead, it will be saved in the I<deferred write buffer> to be +written out later. Data in the deferred write buffer is also charged +against the memory limit you set with the C<memory> option. + +You may set the C<dw_size> option to limit the amount of data that can +be saved in the deferred write buffer. This limit may not exceed the +total memory limit. For example, if you set C<dw_size> to 1000 and +C<memory> to 2500, that means that no more than 1000 bytes of deferred +writes will be saved up. The space available for the read cache will +vary, but it will always be at least 1500 bytes (if the deferred write +buffer is full) and it could grow as large as 2500 bytes (if the +deferred write buffer is empty.) + +If you don't specify a C<dw_size>, it defaults to the entire memory +limit. + +=head2 Option Format + +C<-mode> is a synonym for C<mode>. C<-recsep> is a synonym for +C<recsep>. C<-memory> is a synonym for C<memory>. You get the +idea. + +=head1 Public Methods + +The C<tie> call returns an object, say C<$o>. You may call + + $rec = $o->FETCH($n); + $o->STORE($n, $rec); + +to fetch or store the record at line C<$n>, respectively; similarly +the other tied array methods. (See L<perltie> for details.) You may +also call the following methods on this object: + +=head2 C<flock> + + $o->flock(MODE) + +will lock the tied file. C<MODE> has the same meaning as the second +argument to the Perl built-in C<flock> function; for example +C<LOCK_SH> or C<LOCK_EX | LOCK_NB>. (These constants are provided by +the C<use Fcntl ':flock'> declaration.) + +C<MODE> is optional; the default is C<LOCK_EX>. + +C<Tie::File> maintains an internal table of the byte offset of each +record it has seen in the file. + +When you use C<flock> to lock the file, C<Tie::File> assumes that the +read cache is no longer trustworthy, because another process might +have modified the file since the last time it was read. Therefore, a +successful call to C<flock> discards the contents of the read cache +and the internal record offset table. + +C<Tie::File> promises that the following sequence of operations will +be safe: + + my $o = tie @array, "Tie::File", $filename; + $o->flock; + +In particular, C<Tie::File> will I<not> read or write the file during +the C<tie> call. (Exception: Using C<mode =E<gt> O_TRUNC> will, of +course, erase the file during the C<tie> call. If you want to do this +safely, then open the file without C<O_TRUNC>, lock the file, and use +C<@array = ()>.) + +The best way to unlock a file is to discard the object and untie the +array. It is probably unsafe to unlock the file without also untying +it, because if you do, changes may remain unwritten inside the object. +That is why there is no shortcut for unlocking. If you really want to +unlock the file prematurely, you know what to do; if you don't know +what to do, then don't do it. + +All the usual warnings about file locking apply here. In particular, +note that file locking in Perl is B<advisory>, which means that +holding a lock will not prevent anyone else from reading, writing, or +erasing the file; it only prevents them from getting another lock at +the same time. Locks are analogous to green traffic lights: If you +have a green light, that does not prevent the idiot coming the other +way from plowing into you sideways; it merely guarantees to you that +the idiot does not also have a green light at the same time. + +=head2 C<autochomp> + + my $old_value = $o->autochomp(0); # disable autochomp option + my $old_value = $o->autochomp(1); # enable autochomp option + + my $ac = $o->autochomp(); # recover current value + +See L<"autochomp">, above. + +=head2 C<defer>, C<flush>, C<discard>, and C<autodefer> + +See L<"Deferred Writing">, below. + +=head2 C<offset> + + $off = $o->offset($n); + +This method returns the byte offset of the start of the C<$n>th record +in the file. If there is no such record, it returns an undefined +value. + +=head1 Tying to an already-opened filehandle + +If C<$fh> is a filehandle, such as is returned by C<IO::File> or one +of the other C<IO> modules, you may use: + + tie @array, 'Tie::File', $fh, ...; + +Similarly if you opened that handle C<FH> with regular C<open> or +C<sysopen>, you may use: + + tie @array, 'Tie::File', \*FH, ...; + +Handles that were opened write-only won't work. Handles that were +opened read-only will work as long as you don't try to modify the +array. Handles must be attached to seekable sources of data---that +means no pipes or sockets. If C<Tie::File> can detect that you +supplied a non-seekable handle, the C<tie> call will throw an +exception. (On Unix systems, it can detect this.) + +Note that Tie::File will only close any filehandles that it opened +internally. If you passed it a filehandle as above, you "own" the +filehandle, and are responsible for closing it after you have untied +the @array. + +=head1 Deferred Writing + +(This is an advanced feature. Skip this section on first reading.) + +Normally, modifying a C<Tie::File> array writes to the underlying file +immediately. Every assignment like C<$a[3] = ...> rewrites as much of +the file as is necessary; typically, everything from line 3 through +the end will need to be rewritten. This is the simplest and most +transparent behavior. Performance even for large files is reasonably +good. + +However, under some circumstances, this behavior may be excessively +slow. For example, suppose you have a million-record file, and you +want to do: + + for (@FILE) { + $_ = "> $_"; + } + +The first time through the loop, you will rewrite the entire file, +from line 0 through the end. The second time through the loop, you +will rewrite the entire file from line 1 through the end. The third +time through the loop, you will rewrite the entire file from line 2 to +the end. And so on. + +If the performance in such cases is unacceptable, you may defer the +actual writing, and then have it done all at once. The following loop +will perform much better for large files: + + (tied @a)->defer; + for (@a) { + $_ = "> $_"; + } + (tied @a)->flush; + +If C<Tie::File>'s memory limit is large enough, all the writing will +done in memory. Then, when you call C<-E<gt>flush>, the entire file +will be rewritten in a single pass. + +(Actually, the preceding discussion is something of a fib. You don't +need to enable deferred writing to get good performance for this +common case, because C<Tie::File> will do it for you automatically +unless you specifically tell it not to. See L<"autodeferring">, +below.) + +Calling C<-E<gt>flush> returns the array to immediate-write mode. If +you wish to discard the deferred writes, you may call C<-E<gt>discard> +instead of C<-E<gt>flush>. Note that in some cases, some of the data +will have been written already, and it will be too late for +C<-E<gt>discard> to discard all the changes. Support for +C<-E<gt>discard> may be withdrawn in a future version of C<Tie::File>. + +Deferred writes are cached in memory up to the limit specified by the +C<dw_size> option (see above). If the deferred-write buffer is full +and you try to write still more deferred data, the buffer will be +flushed. All buffered data will be written immediately, the buffer +will be emptied, and the now-empty space will be used for future +deferred writes. + +If the deferred-write buffer isn't yet full, but the total size of the +buffer and the read cache would exceed the C<memory> limit, the oldest +records will be expired from the read cache until the total size is +under the limit. + +C<push>, C<pop>, C<shift>, C<unshift>, and C<splice> cannot be +deferred. When you perform one of these operations, any deferred data +is written to the file and the operation is performed immediately. +This may change in a future version. + +If you resize the array with deferred writing enabled, the file will +be resized immediately, but deferred records will not be written. +This has a surprising consequence: C<@a = (...)> erases the file +immediately, but the writing of the actual data is deferred. This +might be a bug. If it is a bug, it will be fixed in a future version. + +=head2 Autodeferring + +C<Tie::File> tries to guess when deferred writing might be helpful, +and to turn it on and off automatically. + + for (@a) { + $_ = "> $_"; + } + +In this example, only the first two assignments will be done +immediately; after this, all the changes to the file will be deferred +up to the user-specified memory limit. + +You should usually be able to ignore this and just use the module +without thinking about deferring. However, special applications may +require fine control over which writes are deferred, or may require +that all writes be immediate. To disable the autodeferment feature, +use + + (tied @o)->autodefer(0); + +or + + tie @array, 'Tie::File', $file, autodefer => 0; + + +Similarly, C<-E<gt>autodefer(1)> re-enables autodeferment, and +C<-E<gt>autodefer()> recovers the current value of the autodefer setting. + + +=head1 CONCURRENT ACCESS TO FILES + +Caching and deferred writing are inappropriate if you want the same +file to be accessed simultaneously from more than one process. Other +optimizations performed internally by this module are also +incompatible with concurrent access. A future version of this module will +support a C<concurrent =E<gt> 1> option that enables safe concurrent access. + +Previous versions of this documentation suggested using C<memory +=E<gt> 0> for safe concurrent access. This was mistaken. Tie::File +will not support safe concurrent access before version 0.98. + +=head1 CAVEATS + +(That's Latin for 'warnings'.) + +=over 4 + +=item * + +Reasonable effort was made to make this module efficient. Nevertheless, +changing the size of a record in the middle of a large file will +always be fairly slow, because everything after the new record must be +moved. + +=item * + +The behavior of tied arrays is not precisely the same as for regular +arrays. For example: + + # This DOES print "How unusual!" + undef $a[10]; print "How unusual!\n" if defined $a[10]; + +C<undef>-ing a C<Tie::File> array element just blanks out the +corresponding record in the file. When you read it back again, you'll +get the empty string, so the supposedly-C<undef>'ed value will be +defined. Similarly, if you have C<autochomp> disabled, then + + # This DOES print "How unusual!" if 'autochomp' is disabled + undef $a[10]; + print "How unusual!\n" if $a[10]; + +Because when C<autochomp> is disabled, C<$a[10]> will read back as +C<"\n"> (or whatever the record separator string is.) + +There are other minor differences, particularly regarding C<exists> +and C<delete>, but in general, the correspondence is extremely close. + +=item * + +I have supposed that since this module is concerned with file I/O, +almost all normal use of it will be heavily I/O bound. This means +that the time to maintain complicated data structures inside the +module will be dominated by the time to actually perform the I/O. +When there was an opportunity to spend CPU time to avoid doing I/O, I +usually tried to take it. + +=item * + +You might be tempted to think that deferred writing is like +transactions, with C<flush> as C<commit> and C<discard> as +C<rollback>, but it isn't, so don't. + +=item * + +There is a large memory overhead for each record offset and for each +cache entry: about 310 bytes per cached data record, and about 21 bytes per offset table entry. + +The per-record overhead will limit the maximum number of records you +can access per file. Note that I<accessing> the length of the array +via C<$x = scalar @tied_file> accesses B<all> records and stores their +offsets. The same for C<foreach (@tied_file)>, even if you exit the +loop early. + +=back + +=head1 SUBCLASSING + +This version promises absolutely nothing about the internals, which +may change without notice. A future version of the module will have a +well-defined and stable subclassing API. + +=head1 WHAT ABOUT C<DB_File>? + +People sometimes point out that L<DB_File> will do something similar, +and ask why C<Tie::File> module is necessary. + +There are a number of reasons that you might prefer C<Tie::File>. +A list is available at C<http://perl.plover.com/TieFile/why-not-DB_File>. + +=head1 AUTHOR + +Mark Jason Dominus + +To contact the author, send email to: C<mjd-perl-tiefile+@plover.com> + +To receive an announcement whenever a new version of this module is +released, send a blank email message to +C<mjd-perl-tiefile-subscribe@plover.com>. + +The most recent version of this module, including documentation and +any news of importance, will be available at + + http://perl.plover.com/TieFile/ + + +=head1 LICENSE + +C<Tie::File> version 0.97 is copyright (C) 2003 Mark Jason Dominus. + +This library is free software; you may redistribute it and/or modify +it under the same terms as Perl itself. + +These terms are your choice of any of (1) the Perl Artistic Licence, +or (2) version 2 of the GNU General Public License as published by the +Free Software Foundation, or (3) any later version of the GNU General +Public License. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this library program; it should be in the file C<COPYING>. +If not, write to the Free Software Foundation, Inc., 59 Temple Place, +Suite 330, Boston, MA 02111 USA + +For licensing inquiries, contact the author at: + + Mark Jason Dominus + 255 S. Warnock St. + Philadelphia, PA 19107 + +=head1 WARRANTY + +C<Tie::File> version 0.97 comes with ABSOLUTELY NO WARRANTY. +For details, see the license. + +=head1 THANKS + +Gigantic thanks to Jarkko Hietaniemi, for agreeing to put this in the +core when I hadn't written it yet, and for generally being helpful, +supportive, and competent. (Usually the rule is "choose any one.") +Also big thanks to Abhijit Menon-Sen for all of the same things. + +Special thanks to Craig Berry and Peter Prymmer (for VMS portability +help), Randy Kobes (for Win32 portability help), Clinton Pierce and +Autrijus Tang (for heroic eleventh-hour Win32 testing above and beyond +the call of duty), Michael G Schwern (for testing advice), and the +rest of the CPAN testers (for testing generally). + +Special thanks to Tels for suggesting several speed and memory +optimizations. + +Additional thanks to: +Edward Avis / +Mattia Barbon / +Tom Christiansen / +Gerrit Haase / +Gurusamy Sarathy / +Jarkko Hietaniemi (again) / +Nikola Knezevic / +John Kominetz / +Nick Ing-Simmons / +Tassilo von Parseval / +H. Dieter Pearcey / +Slaven Rezic / +Eric Roode / +Peter Scott / +Peter Somu / +Autrijus Tang (again) / +Tels (again) / +Juerd Waalboer + +=head1 TODO + +More tests. (Stuff I didn't think of yet.) + +Paragraph mode? + +Fixed-length mode. Leave-blanks mode. + +Maybe an autolocking mode? + +For many common uses of the module, the read cache is a liability. +For example, a program that inserts a single record, or that scans the +file once, will have a cache hit rate of zero. This suggests a major +optimization: The cache should be initially disabled. Here's a hybrid +approach: Initially, the cache is disabled, but the cache code +maintains statistics about how high the hit rate would be *if* it were +enabled. When it sees the hit rate get high enough, it enables +itself. The STAT comments in this code are the beginning of an +implementation of this. + +Record locking with fcntl()? Then the module might support an undo +log and get real transactions. What a tour de force that would be. + +Keeping track of the highest cached record. This would allow reads-in-a-row +to skip the cache lookup faster (if reading from 1..N with empty cache at +start, the last cached value will be always N-1). + +More tests. + +=cut + diff --git a/Master/tlpkg/installer/perllib/Tie/Handle.pm b/Master/tlpkg/installer/perllib/Tie/Handle.pm new file mode 100644 index 00000000000..d8747f12af1 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tie/Handle.pm @@ -0,0 +1,234 @@ +package Tie::Handle; + +use 5.006_001; +our $VERSION = '4.1'; + +=head1 NAME + +Tie::Handle, Tie::StdHandle - base class definitions for tied handles + +=head1 SYNOPSIS + + package NewHandle; + require Tie::Handle; + + @ISA = qw(Tie::Handle); + + sub READ { ... } # Provide a needed method + sub TIEHANDLE { ... } # Overrides inherited method + + + package main; + + tie *FH, 'NewHandle'; + +=head1 DESCRIPTION + +This module provides some skeletal methods for handle-tying classes. See +L<perltie> for a list of the functions required in tying a handle to a package. +The basic B<Tie::Handle> package provides a C<new> method, as well as methods +C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>. + +For developers wishing to write their own tied-handle classes, the methods +are summarized below. The L<perltie> section not only documents these, but +has sample code as well: + +=over 4 + +=item TIEHANDLE classname, LIST + +The method invoked by the command C<tie *glob, classname>. Associates a new +glob instance with the specified class. C<LIST> would represent additional +arguments (along the lines of L<AnyDBM_File> and compatriots) needed to +complete the association. + +=item WRITE this, scalar, length, offset + +Write I<length> bytes of data from I<scalar> starting at I<offset>. + +=item PRINT this, LIST + +Print the values in I<LIST> + +=item PRINTF this, format, LIST + +Print the values in I<LIST> using I<format> + +=item READ this, scalar, length, offset + +Read I<length> bytes of data into I<scalar> starting at I<offset>. + +=item READLINE this + +Read a single line + +=item GETC this + +Get a single character + +=item CLOSE this + +Close the handle + +=item OPEN this, filename + +(Re-)open the handle + +=item BINMODE this + +Specify content is binary + +=item EOF this + +Test for end of file. + +=item TELL this + +Return position in the file. + +=item SEEK this, offset, whence + +Position the file. + +Test for end of file. + +=item DESTROY this + +Free the storage associated with the tied handle referenced by I<this>. +This is rarely needed, as Perl manages its memory quite well. But the +option exists, should a class wish to perform specific actions upon the +destruction of an instance. + +=back + +=head1 MORE INFORMATION + +The L<perltie> section contains an example of tying handles. + +=head1 COMPATIBILITY + +This version of Tie::Handle is neither related to nor compatible with +the Tie::Handle (3.0) module available on CPAN. It was due to an +accident that two modules with the same name appeared. The namespace +clash has been cleared in favor of this module that comes with the +perl core in September 2000 and accordingly the version number has +been bumped up to 4.0. + +=cut + +use Carp; +use warnings::register; + +sub new { + my $pkg = shift; + $pkg->TIEHANDLE(@_); +} + +# "Grandfather" the new, a la Tie::Hash + +sub TIEHANDLE { + my $pkg = shift; + if (defined &{"{$pkg}::new"}) { + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"); + $pkg->new(@_); + } + else { + croak "$pkg doesn't define a TIEHANDLE method"; + } +} + +sub PRINT { + my $self = shift; + if($self->can('WRITE') != \&WRITE) { + my $buf = join(defined $, ? $, : "",@_); + $buf .= $\ if defined $\; + $self->WRITE($buf,length($buf),0); + } + else { + croak ref($self)," doesn't define a PRINT method"; + } +} + +sub PRINTF { + my $self = shift; + + if($self->can('WRITE') != \&WRITE) { + my $buf = sprintf(shift,@_); + $self->WRITE($buf,length($buf),0); + } + else { + croak ref($self)," doesn't define a PRINTF method"; + } +} + +sub READLINE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a READLINE method"; +} + +sub GETC { + my $self = shift; + + if($self->can('READ') != \&READ) { + my $buf; + $self->READ($buf,1); + return $buf; + } + else { + croak ref($self)," doesn't define a GETC method"; + } +} + +sub READ { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a READ method"; +} + +sub WRITE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a WRITE method"; +} + +sub CLOSE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a CLOSE method"; +} + +package Tie::StdHandle; +our @ISA = 'Tie::Handle'; +use Carp; + +sub TIEHANDLE +{ + my $class = shift; + my $fh = \do { local *HANDLE}; + bless $fh,$class; + $fh->OPEN(@_) if (@_); + return $fh; +} + +sub EOF { eof($_[0]) } +sub TELL { tell($_[0]) } +sub FILENO { fileno($_[0]) } +sub SEEK { seek($_[0],$_[1],$_[2]) } +sub CLOSE { close($_[0]) } +sub BINMODE { binmode($_[0]) } + +sub OPEN +{ + $_[0]->CLOSE if defined($_[0]->FILENO); + @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]); +} + +sub READ { read($_[0],$_[1],$_[2]) } +sub READLINE { my $fh = $_[0]; <$fh> } +sub GETC { getc($_[0]) } + +sub WRITE +{ + my $fh = $_[0]; + print $fh substr($_[1],0,$_[2]) +} + + +1; diff --git a/Master/tlpkg/installer/perllib/Tie/Memoize.pm b/Master/tlpkg/installer/perllib/Tie/Memoize.pm new file mode 100644 index 00000000000..2793a04590d --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tie/Memoize.pm @@ -0,0 +1,128 @@ +use strict; +package Tie::Memoize; +use Tie::Hash; +our @ISA = 'Tie::ExtraHash'; +our $VERSION = '1.0'; + +our $exists_token = \undef; + +sub croak {require Carp; goto &Carp::croak} + +# Format: [0: STORAGE, 1: EXISTS-CACHE, 2: FETCH_function; +# 3: EXISTS_function, 4: DATA, 5: EXISTS_different ] + +sub FETCH { + my ($h,$key) = ($_[0][0], $_[1]); + my $res = $h->{$key}; + return $res if defined $res; # Shortcut if accessible + return $res if exists $h->{$key}; # Accessible, but undef + my $cache = $_[0][1]{$key}; + return if defined $cache and not $cache; # Known to not exist + my @res = $_[0][2]->($key, $_[0][4]); # Autoload + $_[0][1]{$key} = 0, return unless @res; # Cache non-existence + delete $_[0][1]{$key}; # Clear existence cache, not needed any more + $_[0][0]{$key} = $res[0]; # Store data and return +} + +sub EXISTS { + my ($a,$key) = (shift, shift); + return 1 if exists $a->[0]{$key}; # Have data + my $cache = $a->[1]{$key}; + return $cache if defined $cache; # Existence cache + my @res = $a->[3]($key,$a->[4]); + $_[0][1]{$key} = 0, return unless @res; # Cache non-existence + # Now we know it exists + return ($_[0][1]{$key} = 1) if $a->[5]; # Only existence reported + # Now know the value + $_[0][0]{$key} = $res[0]; # Store data + return 1 +} + +sub TIEHASH { + croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr' if @_ < 2; + croak 'syntax: tie %hash, \'Tie::AutoLoad\', \&fetch_subr, $data, \&exists_subr, \%data_cache, \%existence_cache' if @_ > 6; + push @_, undef if @_ < 3; # Data + push @_, $_[1] if @_ < 4; # exists + push @_, {} while @_ < 6; # initial value and caches + bless [ @_[4,5,1,3,2], $_[1] ne $_[3]], $_[0] +} + +1; + +=head1 NAME + +Tie::Memoize - add data to hash when needed + +=head1 SYNOPSIS + + require Tie::Memoize; + tie %hash, 'Tie::Memoize', + \&fetch, # The rest is optional + $DATA, \&exists, + {%ini_value}, {%ini_existence}; + +=head1 DESCRIPTION + +This package allows a tied hash to autoload its values on the first access, +and to use the cached value on the following accesses. + +Only read-accesses (via fetching the value or C<exists>) result in calls to +the functions; the modify-accesses are performed as on a normal hash. + +The required arguments during C<tie> are the hash, the package, and +the reference to the C<FETCH>ing function. The optional arguments are +an arbitrary scalar $data, the reference to the C<EXISTS> function, +and initial values of the hash and of the existence cache. + +Both the C<FETCH>ing function and the C<EXISTS> functions have the +same signature: the arguments are C<$key, $data>; $data is the same +value as given as argument during tie()ing. Both functions should +return an empty list if the value does not exist. If C<EXISTS> +function is different from the C<FETCH>ing function, it should return +a TRUE value on success. The C<FETCH>ing function should return the +intended value if the key is valid. + +=head1 Inheriting from B<Tie::Memoize> + +The structure of the tied() data is an array reference with elements + + 0: cache of known values + 1: cache of known existence of keys + 2: FETCH function + 3: EXISTS function + 4: $data + +The rest is for internal usage of this package. In particular, if +TIEHASH is overwritten, it should call SUPER::TIEHASH. + +=head1 EXAMPLE + + sub slurp { + my ($key, $dir) = shift; + open my $h, '<', "$dir/$key" or return; + local $/; <$h> # slurp it all + } + sub exists { my ($key, $dir) = shift; return -f "$dir/$key" } + + tie %hash, 'Tie::Memoize', \&slurp, $directory, \&exists, + { fake_file1 => $content1, fake_file2 => $content2 }, + { pretend_does_not_exists => 0, known_to_exist => 1 }; + +This example treats the slightly modified contents of $directory as a +hash. The modifications are that the keys F<fake_file1> and +F<fake_file2> fetch values $content1 and $content2, and +F<pretend_does_not_exists> will never be accessed. Additionally, the +existence of F<known_to_exist> is never checked (so if it does not +exists when its content is needed, the user of %hash may be confused). + +=head1 BUGS + +FIRSTKEY and NEXTKEY methods go through the keys which were already read, +not all the possible keys of the hash. + +=head1 AUTHOR + +Ilya Zakharevich L<mailto:perl-module-hash-memoize@ilyaz.org>. + +=cut + diff --git a/Master/tlpkg/installer/perllib/Tie/RefHash.pm b/Master/tlpkg/installer/perllib/Tie/RefHash.pm new file mode 100644 index 00000000000..cfcdd5b5a10 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tie/RefHash.pm @@ -0,0 +1,170 @@ +package Tie::RefHash; + +our $VERSION = 1.32; + +=head1 NAME + +Tie::RefHash - use references as hash keys + +=head1 SYNOPSIS + + require 5.004; + use Tie::RefHash; + tie HASHVARIABLE, 'Tie::RefHash', LIST; + tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST; + + untie HASHVARIABLE; + +=head1 DESCRIPTION + +This module provides the ability to use references as hash keys if you +first C<tie> the hash variable to this module. Normally, only the +keys of the tied hash itself are preserved as references; to use +references as keys in hashes-of-hashes, use Tie::RefHash::Nestable, +included as part of Tie::RefHash. + +It is implemented using the standard perl TIEHASH interface. Please +see the C<tie> entry in perlfunc(1) and perltie(1) for more information. + +The Nestable version works by looking for hash references being stored +and converting them to tied hashes so that they too can have +references as keys. This will happen without warning whenever you +store a reference to one of your own hashes in the tied hash. + +=head1 EXAMPLE + + use Tie::RefHash; + tie %h, 'Tie::RefHash'; + $a = []; + $b = {}; + $c = \*main; + $d = \"gunk"; + $e = sub { 'foo' }; + %h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5); + $a->[0] = 'foo'; + $b->{foo} = 'bar'; + for (keys %h) { + print ref($_), "\n"; + } + + tie %h, 'Tie::RefHash::Nestable'; + $h{$a}->{$b} = 1; + for (keys %h, keys %{$h{$a}}) { + print ref($_), "\n"; + } + +=head1 AUTHOR + +Gurusamy Sarathy gsar@activestate.com + +'Nestable' by Ed Avis ed@membled.com + +=head1 VERSION + +Version 1.32 + +=head1 SEE ALSO + +perl(1), perlfunc(1), perltie(1) + +=cut + +use Tie::Hash; +use vars '@ISA'; +@ISA = qw(Tie::Hash); +use strict; + +require overload; # to support objects with overloaded "" + +sub TIEHASH { + my $c = shift; + my $s = []; + bless $s, $c; + while (@_) { + $s->STORE(shift, shift); + } + return $s; +} + +sub FETCH { + my($s, $k) = @_; + if (ref $k) { + my $kstr = overload::StrVal($k); + if (defined $s->[0]{$kstr}) { + $s->[0]{$kstr}[1]; + } + else { + undef; + } + } + else { + $s->[1]{$k}; + } +} + +sub STORE { + my($s, $k, $v) = @_; + if (ref $k) { + $s->[0]{overload::StrVal($k)} = [$k, $v]; + } + else { + $s->[1]{$k} = $v; + } + $v; +} + +sub DELETE { + my($s, $k) = @_; + (ref $k) + ? (delete($s->[0]{overload::StrVal($k)}) || [])->[1] + : delete($s->[1]{$k}); +} + +sub EXISTS { + my($s, $k) = @_; + (ref $k) ? exists($s->[0]{overload::StrVal($k)}) : exists($s->[1]{$k}); +} + +sub FIRSTKEY { + my $s = shift; + keys %{$s->[0]}; # reset iterator + keys %{$s->[1]}; # reset iterator + $s->[2] = 0; # flag for iteration, see NEXTKEY + $s->NEXTKEY; +} + +sub NEXTKEY { + my $s = shift; + my ($k, $v); + if (!$s->[2]) { + if (($k, $v) = each %{$s->[0]}) { + return $v->[0]; + } + else { + $s->[2] = 1; + } + } + return each %{$s->[1]}; +} + +sub CLEAR { + my $s = shift; + $s->[2] = 0; + %{$s->[0]} = (); + %{$s->[1]} = (); +} + +package Tie::RefHash::Nestable; +use vars '@ISA'; +@ISA = 'Tie::RefHash'; + +sub STORE { + my($s, $k, $v) = @_; + if (ref($v) eq 'HASH' and not tied %$v) { + my @elems = %$v; + tie %$v, ref($s), @elems; + } + $s->SUPER::STORE($k, $v); +} + +1; diff --git a/Master/tlpkg/installer/perllib/Tie/Scalar.pm b/Master/tlpkg/installer/perllib/Tie/Scalar.pm new file mode 100644 index 00000000000..c23c12187a8 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tie/Scalar.pm @@ -0,0 +1,140 @@ +package Tie::Scalar; + +our $VERSION = '1.00'; + +=head1 NAME + +Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars + +=head1 SYNOPSIS + + package NewScalar; + require Tie::Scalar; + + @ISA = (Tie::Scalar); + + sub FETCH { ... } # Provide a needed method + sub TIESCALAR { ... } # Overrides inherited method + + + package NewStdScalar; + require Tie::Scalar; + + @ISA = (Tie::StdScalar); + + # All methods provided by default, so define only what needs be overridden + sub FETCH { ... } + + + package main; + + tie $new_scalar, 'NewScalar'; + tie $new_std_scalar, 'NewStdScalar'; + +=head1 DESCRIPTION + +This module provides some skeletal methods for scalar-tying classes. See +L<perltie> for a list of the functions required in tying a scalar to a +package. The basic B<Tie::Scalar> package provides a C<new> method, as well +as methods C<TIESCALAR>, C<FETCH> and C<STORE>. The B<Tie::StdScalar> +package provides all the methods specified in L<perltie>. It inherits from +B<Tie::Scalar> and causes scalars tied to it to behave exactly like the +built-in scalars, allowing for selective overloading of methods. The C<new> +method is provided as a means of grandfathering, for classes that forget to +provide their own C<TIESCALAR> method. + +For developers wishing to write their own tied-scalar classes, the methods +are summarized below. The L<perltie> section not only documents these, but +has sample code as well: + +=over 4 + +=item TIESCALAR classname, LIST + +The method invoked by the command C<tie $scalar, classname>. Associates a new +scalar instance with the specified class. C<LIST> would represent additional +arguments (along the lines of L<AnyDBM_File> and compatriots) needed to +complete the association. + +=item FETCH this + +Retrieve the value of the tied scalar referenced by I<this>. + +=item STORE this, value + +Store data I<value> in the tied scalar referenced by I<this>. + +=item DESTROY this + +Free the storage associated with the tied scalar referenced by I<this>. +This is rarely needed, as Perl manages its memory quite well. But the +option exists, should a class wish to perform specific actions upon the +destruction of an instance. + +=back + +=head1 MORE INFORMATION + +The L<perltie> section uses a good example of tying scalars by associating +process IDs with priority. + +=cut + +use Carp; +use warnings::register; + +sub new { + my $pkg = shift; + $pkg->TIESCALAR(@_); +} + +# "Grandfather" the new, a la Tie::Hash + +sub TIESCALAR { + my $pkg = shift; + if ($pkg->can('new') and $pkg ne __PACKAGE__) { + warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing"); + $pkg->new(@_); + } + else { + croak "$pkg doesn't define a TIESCALAR method"; + } +} + +sub FETCH { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a FETCH method"; +} + +sub STORE { + my $pkg = ref $_[0]; + croak "$pkg doesn't define a STORE method"; +} + +# +# The Tie::StdScalar package provides scalars that behave exactly like +# Perl's built-in scalars. Good base to inherit from, if you're only going to +# tweak a small bit. +# +package Tie::StdScalar; +@ISA = (Tie::Scalar); + +sub TIESCALAR { + my $class = shift; + my $instance = shift || undef; + return bless \$instance => $class; +} + +sub FETCH { + return ${$_[0]}; +} + +sub STORE { + ${$_[0]} = $_[1]; +} + +sub DESTROY { + undef ${$_[0]}; +} + +1; diff --git a/Master/tlpkg/installer/perllib/Tie/SubstrHash.pm b/Master/tlpkg/installer/perllib/Tie/SubstrHash.pm new file mode 100644 index 00000000000..476dd686787 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Tie/SubstrHash.pm @@ -0,0 +1,215 @@ +package Tie::SubstrHash; + +our $VERSION = '1.00'; + +=head1 NAME + +Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing + +=head1 SYNOPSIS + + require Tie::SubstrHash; + + tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size; + +=head1 DESCRIPTION + +The B<Tie::SubstrHash> package provides a hash-table-like interface to +an array of determinate size, with constant key size and record size. + +Upon tying a new hash to this package, the developer must specify the +size of the keys that will be used, the size of the value fields that the +keys will index, and the size of the overall table (in terms of key-value +pairs, not size in hard memory). I<These values will not change for the +duration of the tied hash>. The newly-allocated hash table may now have +data stored and retrieved. Efforts to store more than C<$table_size> +elements will result in a fatal error, as will efforts to store a value +not exactly C<$value_len> characters in length, or reference through a +key not exactly C<$key_len> characters in length. While these constraints +may seem excessive, the result is a hash table using much less internal +memory than an equivalent freely-allocated hash table. + +=head1 CAVEATS + +Because the current implementation uses the table and key sizes for the +hashing algorithm, there is no means by which to dynamically change the +value of any of the initialization parameters. + +The hash does not support exists(). + +=cut + +use Carp; + +sub TIEHASH { + my $pack = shift; + my ($klen, $vlen, $tsize) = @_; + my $rlen = 1 + $klen + $vlen; + $tsize = [$tsize, + findgteprime($tsize * 1.1)]; # Allow 10% empty. + local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1]; + $$self[0] x= $rlen * $tsize->[1]; + $self; +} + +sub CLEAR { + local($self) = @_; + $$self[0] = "\0" x ($$self[4] * $$self[3]->[1]); + $$self[5] = 0; + $$self[6] = -1; +} + +sub FETCH { + local($self,$key) = @_; + local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; + &hashkey; + for (;;) { + $offset = $hash * $rlen; + $record = substr($$self[0], $offset, $rlen); + if (ord($record) == 0) { + return undef; + } + elsif (ord($record) == 1) { + } + elsif (substr($record, 1, $klen) eq $key) { + return substr($record, 1+$klen, $vlen); + } + &rehash; + } +} + +sub STORE { + local($self,$key,$val) = @_; + local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; + croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0]; + croak(qq/Value "$val" is not $vlen characters long/) + if length($val) != $vlen; + my $writeoffset; + + &hashkey; + for (;;) { + $offset = $hash * $rlen; + $record = substr($$self[0], $offset, $rlen); + if (ord($record) == 0) { + $record = "\2". $key . $val; + die "panic" unless length($record) == $rlen; + $writeoffset = $offset unless defined $writeoffset; + substr($$self[0], $writeoffset, $rlen) = $record; + ++$$self[5]; + return; + } + elsif (ord($record) == 1) { + $writeoffset = $offset unless defined $writeoffset; + } + elsif (substr($record, 1, $klen) eq $key) { + $record = "\2". $key . $val; + die "panic" unless length($record) == $rlen; + substr($$self[0], $offset, $rlen) = $record; + return; + } + &rehash; + } +} + +sub DELETE { + local($self,$key) = @_; + local($klen, $vlen, $tsize, $rlen) = @$self[1..4]; + &hashkey; + for (;;) { + $offset = $hash * $rlen; + $record = substr($$self[0], $offset, $rlen); + if (ord($record) == 0) { + return undef; + } + elsif (ord($record) == 1) { + } + elsif (substr($record, 1, $klen) eq $key) { + substr($$self[0], $offset, 1) = "\1"; + return substr($record, 1+$klen, $vlen); + --$$self[5]; + } + &rehash; + } +} + +sub FIRSTKEY { + local($self) = @_; + $$self[6] = -1; + &NEXTKEY; +} + +sub NEXTKEY { + local($self) = @_; + local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6]; + for (++$iterix; $iterix < $tsize->[1]; ++$iterix) { + next unless substr($$self[0], $iterix * $rlen, 1) eq "\2"; + $$self[6] = $iterix; + return substr($$self[0], $iterix * $rlen + 1, $klen); + } + $$self[6] = -1; + undef; +} + +sub EXISTS { + croak "Tie::SubstrHash does not support exists()"; +} + +sub hashkey { + croak(qq/Key "$key" is not $klen characters long/) + if length($key) != $klen; + $hash = 2; + for (unpack('C*', $key)) { + $hash = $hash * 33 + $_; + &_hashwrap if $hash >= 1e13; + } + &_hashwrap if $hash >= $tsize->[1]; + $hash = 1 unless $hash; + $hashbase = $hash; +} + +sub _hashwrap { + $hash -= int($hash / $tsize->[1]) * $tsize->[1]; +} + +sub rehash { + $hash += $hashbase; + $hash -= $tsize->[1] if $hash >= $tsize->[1]; +} + +# using POSIX::ceil() would be too heavy, and not all platforms have it. +sub ceil { + my $num = shift; + $num = int($num + 1) unless $num == int $num; + return $num; +} + +# See: +# +# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html +# + +sub findgteprime { # find the smallest prime integer greater than or equal to + use integer; + + my $num = ceil(shift); + return 2 if $num <= 2; + + $num++ unless $num % 2; + my $i; + my $sqrtnum = int sqrt $num; + my $sqrtnumsquared = $sqrtnum * $sqrtnum; + + NUM: + for (;; $num += 2) { + if ($sqrtnumsquared < $num) { + $sqrtnum++; + $sqrtnumsquared = $sqrtnum * $sqrtnum; + } + for ($i = 3; $i <= $sqrtnum; $i += 2) { + next NUM unless $num % $i; + } + return $num; + } +} + +1; diff --git a/Master/tlpkg/installer/perllib/Time/HiRes.pm b/Master/tlpkg/installer/perllib/Time/HiRes.pm new file mode 100644 index 00000000000..964e4385dfc --- /dev/null +++ b/Master/tlpkg/installer/perllib/Time/HiRes.pm @@ -0,0 +1,500 @@ +package Time::HiRes; + +use strict; +use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); + +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader); + +@EXPORT = qw( ); +@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval + getitimer setitimer nanosleep clock_gettime clock_getres + clock clock_nanosleep + CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID + CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID + CLOCK_TIMEOFDAY CLOCKS_PER_SEC + ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF + TIMER_ABSTIME + d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer + d_nanosleep d_clock_gettime d_clock_getres + d_clock d_clock_nanosleep); + +$VERSION = '1.86'; +$XS_VERSION = $VERSION; +$VERSION = eval $VERSION; + +sub AUTOLOAD { + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + # print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n"; + die "&Time::HiRes::constant not defined" if $constname eq 'constant'; + my ($error, $val) = constant($constname); + # print "AUTOLOAD: error = $error, val = $val\n"; + if ($error) { + my (undef,$file,$line) = caller; + die "$error at $file line $line.\n"; + } + { + no strict 'refs'; + *$AUTOLOAD = sub { $val }; + } + goto &$AUTOLOAD; +} + +sub import { + my $this = shift; + for my $i (@_) { + if (($i eq 'clock_getres' && !&d_clock_getres) || + ($i eq 'clock_gettime' && !&d_clock_gettime) || + ($i eq 'clock_nanosleep' && !&d_clock_nanosleep) || + ($i eq 'clock' && !&d_clock) || + ($i eq 'nanosleep' && !&d_nanosleep) || + ($i eq 'usleep' && !&d_usleep) || + ($i eq 'ualarm' && !&d_ualarm)) { + require Carp; + Carp::croak("Time::HiRes::$i(): unimplemented in this platform"); + } + } + Time::HiRes->export_to_level(1, $this, @_); +} + +bootstrap Time::HiRes; + +# Preloaded methods go here. + +sub tv_interval { + # probably could have been done in C + my ($a, $b) = @_; + $b = [gettimeofday()] unless defined($b); + (${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000); +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ + +=head1 NAME + +Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers + +=head1 SYNOPSIS + + use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep + clock_gettime clock_getres clock_nanosleep clock ); + + usleep ($microseconds); + nanosleep ($nanoseconds); + + ualarm ($microseconds); + ualarm ($microseconds, $interval_microseconds); + + $t0 = [gettimeofday]; + ($seconds, $microseconds) = gettimeofday; + + $elapsed = tv_interval ( $t0, [$seconds, $microseconds]); + $elapsed = tv_interval ( $t0, [gettimeofday]); + $elapsed = tv_interval ( $t0 ); + + use Time::HiRes qw ( time alarm sleep ); + + $now_fractions = time; + sleep ($floating_seconds); + alarm ($floating_seconds); + alarm ($floating_seconds, $floating_interval); + + use Time::HiRes qw( setitimer getitimer + ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF ); + + setitimer ($which, $floating_seconds, $floating_interval ); + getitimer ($which); + + $realtime = clock_gettime(CLOCK_REALTIME); + $resolution = clock_getres(CLOCK_REALTIME); + + clock_nanosleep(CLOCK_REALTIME, 1.5); + clock_nanosleep(CLOCK_REALTIME, time() + 10, TIMER_ABSTIME); + + my $ticktock = clock(); + +=head1 DESCRIPTION + +The C<Time::HiRes> module implements a Perl interface to the +C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and +C<setitimer>/C<getitimer> system calls, in other words, high +resolution time and timers. See the L</EXAMPLES> section below and the +test scripts for usage; see your system documentation for the +description of the underlying C<nanosleep> or C<usleep>, C<ualarm>, +C<gettimeofday>, and C<setitimer>/C<getitimer> calls. + +If your system lacks C<gettimeofday()> or an emulation of it you don't +get C<gettimeofday()> or the one-argument form of C<tv_interval()>. +If your system lacks all of C<nanosleep()>, C<usleep()>, +C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>, +C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>. +If your system lacks both C<ualarm()> and C<setitimer()> you don't get +C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>. + +If you try to import an unimplemented function in the C<use> statement +it will fail at compile time. + +If your subsecond sleeping is implemented with C<nanosleep()> instead +of C<usleep()>, you can mix subsecond sleeping with signals since +C<nanosleep()> does not use signals. This, however, is not portable, +and you should first check for the truth value of +C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and +then carefully read your C<nanosleep()> C API documentation for any +peculiarities. + +If you are using C<nanosleep> for something else than mixing sleeping +with signals, give some thought to whether Perl is the tool you should +be using for work requiring nanosecond accuracies. + +The following functions can be imported from this module. +No functions are exported by default. + +=over 4 + +=item gettimeofday () + +In array context returns a two-element array with the seconds and +microseconds since the epoch. In scalar context returns floating +seconds like C<Time::HiRes::time()> (see below). + +=item usleep ( $useconds ) + +Sleeps for the number of microseconds (millionths of a second) +specified. Returns the number of microseconds actually slept. Can +sleep for more than one second, unlike the C<usleep> system call. Can +also sleep for zero seconds, which often works like a I<thread yield>. +See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and +C<Time::HiRes::clock_nanosleep()>. + +Do not expect usleep() to be exact down to one microsecond. + +=item nanosleep ( $nanoseconds ) + +Sleeps for the number of nanoseconds (1e9ths of a second) specified. +Returns the number of nanoseconds actually slept (accurate only to +microseconds, the nearest thousand of them). Can sleep for more than +one second. Can also sleep for zero seconds, which often works like a +I<thread yield>. See also C<Time::HiRes::sleep()>, +C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>. + +Do not expect nanosleep() to be exact down to one nanosecond. +Getting even accuracy of one thousand nanoseconds is good. + +=item ualarm ( $useconds [, $interval_useconds ] ) + +Issues a C<ualarm> call; the C<$interval_useconds> is optional and +will be zero if unspecified, resulting in C<alarm>-like behaviour. + +Note that the interaction between alarms and sleeps is unspecified. + +=item tv_interval + +tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] ) + +Returns the floating seconds between the two times, which should have +been returned by C<gettimeofday()>. If the second argument is omitted, +then the current time is used. + +=item time () + +Returns a floating seconds since the epoch. This function can be +imported, resulting in a nice drop-in replacement for the C<time> +provided with core Perl; see the L</EXAMPLES> below. + +B<NOTE 1>: This higher resolution timer can return values either less +or more than the core C<time()>, depending on whether your platform +rounds the higher resolution timer values up, down, or to the nearest second +to get the core C<time()>, but naturally the difference should be never +more than half a second. See also L</clock_getres>, if available +in your system. + +B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when +the C<time()> seconds since epoch rolled over to 1_000_000_000, the +default floating point format of Perl and the seconds since epoch have +conspired to produce an apparent bug: if you print the value of +C<Time::HiRes::time()> you seem to be getting only five decimals, not +six as promised (microseconds). Not to worry, the microseconds are +there (assuming your platform supports such granularity in the first +place). What is going on is that the default floating point format of +Perl only outputs 15 digits. In this case that means ten digits +before the decimal separator and five after. To see the microseconds +you can use either C<printf>/C<sprintf> with C<"%.6f">, or the +C<gettimeofday()> function in list context, which will give you the +seconds and microseconds as two separate values. + +=item sleep ( $floating_seconds ) + +Sleeps for the specified amount of seconds. Returns the number of +seconds actually slept (a floating point value). This function can +be imported, resulting in a nice drop-in replacement for the C<sleep> +provided with perl, see the L</EXAMPLES> below. + +Note that the interaction between alarms and sleeps is unspecified. + +=item alarm ( $floating_seconds [, $interval_floating_seconds ] ) + +The C<SIGALRM> signal is sent after the specified number of seconds. +Implemented using C<ualarm()>. The C<$interval_floating_seconds> argument +is optional and will be zero if unspecified, resulting in C<alarm()>-like +behaviour. This function can be imported, resulting in a nice drop-in +replacement for the C<alarm> provided with perl, see the L</EXAMPLES> below. + +B<NOTE 1>: With some combinations of operating systems and Perl +releases C<SIGALRM> restarts C<select()>, instead of interrupting it. +This means that an C<alarm()> followed by a C<select()> may together +take the sum of the times specified for the the C<alarm()> and the +C<select()>, not just the time of the C<alarm()>. + +Note that the interaction between alarms and sleeps is unspecified. + +=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] ) + +Start up an interval timer: after a certain time, a signal arrives, +and more signals may keep arriving at certain intervals. To disable +an "itimer", use C<$floating_seconds> of zero. If the +C<$interval_floating_seconds> is set to zero (or unspecified), the +timer is disabled B<after> the next delivered signal. + +Use of interval timers may interfere with C<alarm()>, C<sleep()>, +and C<usleep()>. In standard-speak the "interaction is unspecified", +which means that I<anything> may happen: it may work, it may not. + +In scalar context, the remaining time in the timer is returned. + +In list context, both the remaining time and the interval are returned. + +There are usually three or four interval timers available: the +C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or +C<ITIMER_REALPROF>. Note that which ones are available depends: true +UNIX platforms usually have the first three, but (for example) Win32 +and Cygwin have only C<ITIMER_REAL>, and only Solaris seems to have +C<ITIMER_REALPROF> (which is used to profile multithreaded programs). + +C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in +I<real time>; that is, wallclock time. C<SIGALRM> is delivered when +the timer expires. + +C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is, +only when the process is running. In multiprocessor/user/CPU systems +this may be more or less than real or wallclock time. (This time is +also known as the I<user time>.) C<SIGVTALRM> is delivered when the +timer expires. + +C<ITIMER_PROF> counts time when either the process virtual time or when +the operating system is running on behalf of the process (such as I/O). +(This time is also known as the I<system time>.) (The sum of user +time and system time is known as the I<CPU time>.) C<SIGPROF> is +delivered when the timer expires. C<SIGPROF> can interrupt system calls. + +The semantics of interval timers for multithreaded programs are +system-specific, and some systems may support additional interval +timers. See your C<setitimer()> documentation. + +=item getitimer ( $which ) + +Return the remaining time in the interval timer specified by C<$which>. + +In scalar context, the remaining time is returned. + +In list context, both the remaining time and the interval are returned. +The interval is always what you put in using C<setitimer()>. + +=item clock_gettime ( $which ) + +Return as seconds the current value of the POSIX high resolution timer +specified by C<$which>. All implementations that support POSIX high +resolution timers are supposed to support at least the C<$which> value +of C<CLOCK_REALTIME>, which is supposed to return results close to the +results of C<gettimeofday>, or the number of seconds since 00:00:00:00 +January 1, 1970 Greenwich Mean Time (GMT). Do not assume that +CLOCK_REALTIME is zero, it might be one, or something else. +Another potentially useful (but not available everywhere) value is +C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time +value (unlike time(), which can be adjusted). See your system +documentation for other possibly supported values. + +=item clock_getres ( $which ) + +Return as seconds the resolution of the POSIX high resolution timer +specified by C<$which>. All implementations that support POSIX high +resolution timers are supposed to support at least the C<$which> value +of C<CLOCK_REALTIME>, see L</clock_gettime>. + +=item clock_nanosleep ( $which, $seconds, $flags = 0) + +Sleeps for the number of seconds (1e9ths of a second) specified. +Returns the number of seconds actually slept. The $which is the +"clock id", as with clock_gettime() and clock_getres(). The flags +default to zero but C<TIMER_ABSTIME> can specified (must be exported +explicitly) which means that C<$nanoseconds> is not a time interval +(as is the default) but instead an absolute time. Can sleep for more +than one second. Can also sleep for zero seconds, which often works +like a I<thread yield>. See also C<Time::HiRes::sleep()>, +C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>. + +Do not expect clock_nanosleep() to be exact down to one nanosecond. +Getting even accuracy of one thousand nanoseconds is good. + +=item clock() + +Return as seconds the I<process time> (user + system time) spent by +the process since the first call to clock() (the definition is B<not> +"since the start of the process", though if you are lucky these times +may be quite close to each other, depending on the system). What this +means is that you probably need to store the result of your first call +to clock(), and subtract that value from the following results of clock(). + +The time returned also includes the process times of the terminated +child processes for which wait() has been executed. This value is +somewhat like the second value returned by the times() of core Perl, +but not necessarily identical. Note that due to backward +compatibility limitations the returned value may wrap around at about +2147 seconds or at about 36 minutes. + +=back + +=head1 EXAMPLES + + use Time::HiRes qw(usleep ualarm gettimeofday tv_interval); + + $microseconds = 750_000; + usleep($microseconds); + + # signal alarm in 2.5s & every .1s thereafter + ualarm(2_500_000, 100_000); + + # get seconds and microseconds since the epoch + ($s, $usec) = gettimeofday(); + + # measure elapsed time + # (could also do by subtracting 2 gettimeofday return values) + $t0 = [gettimeofday]; + # do bunch of stuff here + $t1 = [gettimeofday]; + # do more stuff here + $t0_t1 = tv_interval $t0, $t1; + + $elapsed = tv_interval ($t0, [gettimeofday]); + $elapsed = tv_interval ($t0); # equivalent code + + # + # replacements for time, alarm and sleep that know about + # floating seconds + # + use Time::HiRes; + $now_fractions = Time::HiRes::time; + Time::HiRes::sleep (2.5); + Time::HiRes::alarm (10.6666666); + + use Time::HiRes qw ( time alarm sleep ); + $now_fractions = time; + sleep (2.5); + alarm (10.6666666); + + # Arm an interval timer to go off first at 10 seconds and + # after that every 2.5 seconds, in process virtual time + + use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time ); + + $SIG{VTALRM} = sub { print time, "\n" }; + setitimer(ITIMER_VIRTUAL, 10, 2.5); + + use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME ); + # Read the POSIX high resolution timer. + my $high = clock_getres(CLOCK_REALTIME); + # But how accurate we can be, really? + my $reso = clock_getres(CLOCK_REALTIME); + + use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME ); + clock_nanosleep(CLOCK_REALTIME, 1e6); + clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME); + + use Time::HiRes qw( clock ); + my $clock0 = clock(); + ... # Do something. + my $clock1 = clock(); + my $clockd = $clock1 - $clock0; + +=head1 C API + +In addition to the perl API described above, a C API is available for +extension writers. The following C functions are available in the +modglobal hash: + + name C prototype + --------------- ---------------------- + Time::NVtime double (*)() + Time::U2time void (*)(pTHX_ UV ret[2]) + +Both functions return equivalent information (like C<gettimeofday>) +but with different representations. The names C<NVtime> and C<U2time> +were selected mainly because they are operating system independent. +(C<gettimeofday> is Unix-centric, though some platforms like Win32 and +VMS have emulations for it.) + +Here is an example of using C<NVtime> from C: + + double (*myNVtime)(); /* Returns -1 on failure. */ + SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0); + if (!svp) croak("Time::HiRes is required"); + if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer"); + myNVtime = INT2PTR(double(*)(), SvIV(*svp)); + printf("The current time is: %f\n", (*myNVtime)()); + +=head1 DIAGNOSTICS + +=head2 negative time not invented yet + +You tried to use a negative time argument. + +=head2 internal error: useconds < 0 (unsigned ... signed ...) + +Something went horribly wrong-- the number of microseconds that cannot +become negative just became negative. Maybe your compiler is broken? + +=head1 CAVEATS + +Notice that the core C<time()> maybe rounding rather than truncating. +What this means is that the core C<time()> may be reporting the time +as one second later than C<gettimeofday()> and C<Time::HiRes::time()>. + +Adjusting the system clock (either manually or by services like ntp) +may cause problems, especially for long running programs that assume +a monotonously increasing time (note that all platforms do not adjust +time as gracefully as UNIX ntp does). For example in Win32 (and derived +platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily +drift off from the system clock (and the original time()) by up to 0.5 +seconds. Time::HiRes will notice this eventually and recalibrate. +Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC) +might help in this (in case your system supports CLOCK_MONOTONIC). + +=head1 SEE ALSO + +Perl modules L<BSD::Resource>, L<Time::TAI64>. + +Your system documentation for C<clock_gettime>, C<clock_settime>, +C<gettimeofday>, C<getitimer>, C<setitimer>, C<ualarm>. + +=head1 AUTHORS + +D. Wegscheid <wegscd@whirlpool.com> +R. Schertler <roderick@argon.org> +J. Hietaniemi <jhi@iki.fi> +G. Aas <gisle@aas.no> + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved. + +Copyright (c) 2002, 2003, 2004, 2005 Jarkko Hietaniemi. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Time/Local.pm b/Master/tlpkg/installer/perllib/Time/Local.pm new file mode 100644 index 00000000000..912f17d0310 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Time/Local.pm @@ -0,0 +1,366 @@ +package Time::Local; + +require Exporter; +use Carp; +use Config; +use strict; +use integer; + +use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK ); +$VERSION = '1.11'; +$VERSION = eval $VERSION; +@ISA = qw( Exporter ); +@EXPORT = qw( timegm timelocal ); +@EXPORT_OK = qw( timegm_nocheck timelocal_nocheck ); + +my @MonthDays = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + +# Determine breakpoint for rolling century +my $ThisYear = (localtime())[5]; +my $Breakpoint = ($ThisYear + 50) % 100; +my $NextCentury = $ThisYear - $ThisYear % 100; + $NextCentury += 100 if $Breakpoint < 50; +my $Century = $NextCentury - 100; +my $SecOff = 0; + +my (%Options, %Cheat, %Min, %Max); +my ($MinInt, $MaxInt); + +if ($^O eq 'MacOS') { + # time_t is unsigned... + $MaxInt = (1 << (8 * $Config{intsize})) - 1; + $MinInt = 0; +} else { + $MaxInt = ((1 << (8 * $Config{intsize} - 2))-1)*2 + 1; + $MinInt = -$MaxInt - 1; + + # On Win32 (and others?) time_t appears to be signed, but negative + # epochs still don't work. - XXX - this is experimental + $MinInt = 0 + unless defined ((localtime(-1))[0]); +} + +$Max{Day} = ($MaxInt >> 1) / 43200; +$Min{Day} = $MinInt ? -($Max{Day} + 1) : 0; + +$Max{Sec} = $MaxInt - 86400 * $Max{Day}; +$Min{Sec} = $MinInt - 86400 * $Min{Day}; + +# Determine the EPOC day for this machine +my $Epoc = 0; +if ($^O eq 'vos') { +# work around posix-977 -- VOS doesn't handle dates in +# the range 1970-1980. + $Epoc = _daygm((0, 0, 0, 1, 0, 70, 4, 0)); +} +elsif ($^O eq 'MacOS') { + no integer; + + # MacOS time() is seconds since 1 Jan 1904, localtime + # so we need to calculate an offset to apply later + $Epoc = 693901; + $SecOff = timelocal(localtime(0)) - timelocal(gmtime(0)); + $Epoc += _daygm(gmtime(0)); +} +else { + $Epoc = _daygm(gmtime(0)); +} + +%Cheat=(); # clear the cache as epoc has changed + +sub _daygm { + $_[3] + ($Cheat{pack("ss",@_[4,5])} ||= do { + my $month = ($_[4] + 10) % 12; + my $year = $_[5] + 1900 - $month/10; + 365*$year + $year/4 - $year/100 + $year/400 + ($month*306 + 5)/10 - $Epoc + }); +} + + +sub _timegm { + my $sec = $SecOff + $_[0] + 60 * $_[1] + 3600 * $_[2]; + + no integer; + + $sec + 86400 * &_daygm; +} + + +sub _zoneadjust { + my ($day, $sec, $time) = @_; + + $sec = $sec + _timegm(localtime($time)) - $time; + if ($sec >= 86400) { $day++; $sec -= 86400; } + if ($sec < 0) { $day--; $sec += 86400; } + + ($day, $sec); +} + + +sub timegm { + my ($sec,$min,$hour,$mday,$month,$year) = @_; + + if ($year >= 1000) { + $year -= 1900; + } + elsif ($year < 100 and $year >= 0) { + $year += ($year > $Breakpoint) ? $Century : $NextCentury; + } + + unless ($Options{no_range_check}) { + if (abs($year) >= 0x7fff) { + $year += 1900; + croak "Cannot handle date ($sec, $min, $hour, $mday, $month, *$year*)"; + } + + croak "Month '$month' out of range 0..11" if $month > 11 or $month < 0; + + my $md = $MonthDays[$month]; +# ++$md if $month == 1 and $year % 4 == 0 and +# ($year % 100 != 0 or ($year + 1900) % 400 == 0); + ++$md unless $month != 1 or $year % 4 or !($year % 400); + + croak "Day '$mday' out of range 1..$md" if $mday > $md or $mday < 1; + croak "Hour '$hour' out of range 0..23" if $hour > 23 or $hour < 0; + croak "Minute '$min' out of range 0..59" if $min > 59 or $min < 0; + croak "Second '$sec' out of range 0..59" if $sec > 59 or $sec < 0; + } + + my $days = _daygm(undef, undef, undef, $mday, $month, $year); + my $xsec = $sec + $SecOff + 60*$min + 3600*$hour; + + unless ($Options{no_range_check} + or ($days > $Min{Day} or $days == $Min{Day} and $xsec >= $Min{Sec}) + and ($days < $Max{Day} or $days == $Max{Day} and $xsec <= $Max{Sec})) + { + warn "Day too small - $days > $Min{Day}\n" if $days < $Min{Day}; + warn "Day too big - $days > $Max{Day}\n" if $days > $Max{Day}; + warn "Sec too small - $days < $Min{Sec}\n" if $days < $Min{Sec}; + warn "Sec too big - $days > $Max{Sec}\n" if $days > $Max{Sec}; + $year += 1900; + croak "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)"; + } + + no integer; + + $xsec + 86400 * $days; +} + + +sub timegm_nocheck { + local $Options{no_range_check} = 1; + &timegm; +} + + +sub timelocal { + # Adjust Max/Min allowed times to fit local time zone and call timegm + local ($Max{Day}, $Max{Sec}) = _zoneadjust($Max{Day}, $Max{Sec}, $MaxInt); + local ($Min{Day}, $Min{Sec}) = _zoneadjust($Min{Day}, $Min{Sec}, $MinInt); + my $ref_t = &timegm; + + # Calculate first guess with a one-day delta to avoid localtime overflow + my $delta = ($_[5] < 100)? 86400 : -86400; + my $loc_t = _timegm(localtime( $ref_t + $delta )) - $delta; + + # Is there a timezone offset from GMT or are we done + my $zone_off = $ref_t - $loc_t + or return $loc_t; + + # This hack is needed to always pick the first matching time + # during a DST change when time would otherwise be ambiguous + $zone_off -= 3600 if ($delta > 0 && $ref_t >= 3600); + + # Adjust for timezone + $loc_t = $ref_t + $zone_off; + + # Are we close to a DST change or are we done + my $dst_off = $ref_t - _timegm(localtime($loc_t)) + or return $loc_t; + + # Adjust for DST change + $loc_t += $dst_off; + + return $loc_t if $dst_off >= 0; + + # for a negative offset from GMT, and if the original date + # was a non-extent gap in a forward DST jump, we should + # now have the wrong answer - undo the DST adjust; + + my ($s,$m,$h) = localtime($loc_t); + $loc_t -= $dst_off if $s != $_[0] || $m != $_[1] || $h != $_[2]; + + $loc_t; +} + + +sub timelocal_nocheck { + local $Options{no_range_check} = 1; + &timelocal; +} + +1; + +__END__ + +=head1 NAME + +Time::Local - efficiently compute time from local and GMT time + +=head1 SYNOPSIS + + $time = timelocal($sec,$min,$hour,$mday,$mon,$year); + $time = timegm($sec,$min,$hour,$mday,$mon,$year); + +=head1 DESCRIPTION + +These routines are the inverse of built-in perl functions localtime() +and gmtime(). They accept a date as a six-element array, and return +the corresponding time(2) value in seconds since the system epoch +(Midnight, January 1, 1970 GMT on Unix, for example). This value can +be positive or negative, though POSIX only requires support for +positive values, so dates before the system's epoch may not work on +all operating systems. + +It is worth drawing particular attention to the expected ranges for +the values provided. The value for the day of the month is the actual day +(ie 1..31), while the month is the number of months since January (0..11). +This is consistent with the values returned from localtime() and gmtime(). + +The timelocal() and timegm() functions perform range checking on the +input $sec, $min, $hour, $mday, and $mon values by default. If you'd +rather they didn't, you can explicitly import the timelocal_nocheck() +and timegm_nocheck() functions. + + use Time::Local 'timelocal_nocheck'; + + { + # The 365th day of 1999 + print scalar localtime timelocal_nocheck 0,0,0,365,0,99; + + # The twenty thousandth day since 1970 + print scalar localtime timelocal_nocheck 0,0,0,20000,0,70; + + # And even the 10,000,000th second since 1999! + print scalar localtime timelocal_nocheck 10000000,0,0,1,0,99; + } + +Your mileage may vary when trying these with minutes and hours, +and it doesn't work at all for months. + +Strictly speaking, the year should also be specified in a form consistent +with localtime(), i.e. the offset from 1900. +In order to make the interpretation of the year easier for humans, +however, who are more accustomed to seeing years as two-digit or four-digit +values, the following conventions are followed: + +=over 4 + +=item * + +Years greater than 999 are interpreted as being the actual year, +rather than the offset from 1900. Thus, 1964 would indicate the year +Martin Luther King won the Nobel prize, not the year 3864. + +=item * + +Years in the range 100..999 are interpreted as offset from 1900, +so that 112 indicates 2012. This rule also applies to years less than zero +(but see note below regarding date range). + +=item * + +Years in the range 0..99 are interpreted as shorthand for years in the +rolling "current century," defined as 50 years on either side of the current +year. Thus, today, in 1999, 0 would refer to 2000, and 45 to 2045, +but 55 would refer to 1955. Twenty years from now, 55 would instead refer +to 2055. This is messy, but matches the way people currently think about +two digit dates. Whenever possible, use an absolute four digit year instead. + +=back + +The scheme above allows interpretation of a wide range of dates, particularly +if 4-digit years are used. + +Please note, however, that the range of dates that can be actually be handled +depends on the size of an integer (time_t) on a given platform. +Currently, this is 32 bits for most systems, yielding an approximate range +from Dec 1901 to Jan 2038. + +Both timelocal() and timegm() croak if given dates outside the supported +range. + +=head2 Ambiguous Local Times (DST) + +Because of DST changes, there are many time zones where the same local +time occurs for two different GMT times on the same day. For example, +in the "Europe/Paris" time zone, the local time of 2001-10-28 02:30:00 +can represent either 2001-10-28 00:30:00 GMT, B<or> 2001-10-28 +01:30:00 GMT. + +When given an ambiguous local time, the timelocal() function should +always return the epoch for the I<earlier> of the two possible GMT +times. + +=head2 Non-Existent Local Times (DST) + +When a DST change causes a locale clock to skip one hour forward, +there will be an hour's worth of local times that don't exist. Again, +for the "Europe/Paris" time zone, the local clock jumped from +2001-03-25 01:59:59 to 2001-03-25 03:00:00. + +If the timelocal() function is given a non-existent local time, it +will simply return an epoch value for the time one hour later. + +=head2 Negative Epoch Values + +Negative epoch (time_t) values are not officially supported by the +POSIX standards, so this module's tests do not test them. On some +systems, they are known not to work. These include MacOS (pre-OSX) +and Win32. + +On systems which do support negative epoch values, this module should +be able to cope with dates before the start of the epoch, down the +minimum value of time_t for the system. + +=head1 IMPLEMENTATION + +These routines are quite efficient and yet are always guaranteed to agree +with localtime() and gmtime(). We manage this by caching the start times +of any months we've seen before. If we know the start time of the month, +we can always calculate any time within the month. The start times +are calculated using a mathematical formula. Unlike other algorithms +that do multiple calls to gmtime(). + +timelocal() is implemented using the same cache. We just assume that we're +translating a GMT time, and then fudge it when we're done for the timezone +and daylight savings arguments. Note that the timezone is evaluated for +each date because countries occasionally change their official timezones. +Assuming that localtime() corrects for these changes, this routine will +also be correct. + +=head1 BUGS + +The whole scheme for interpreting two-digit years can be considered a bug. + +=head1 SUPPORT + +Support for this module is provided via the datetime@perl.org +email list. See http://lists.perl.org/ for more details. + +Please submit bugs using the RT system at rt.cpan.org, or as a last +resort, to the datetime@perl.org list. + +=head1 AUTHOR + +This module is based on a Perl 4 library, timelocal.pl, that was +included with Perl 4.036, and was most likely written by Tom +Christiansen. + +The current version was written by Graham Barr. + +It is now being maintained separately from the Perl core by Dave +Rolsky, <autarch@urth.org>. + +=cut + diff --git a/Master/tlpkg/installer/perllib/Time/gmtime.pm b/Master/tlpkg/installer/perllib/Time/gmtime.pm new file mode 100644 index 00000000000..4e1359b36d9 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Time/gmtime.pm @@ -0,0 +1,90 @@ +package Time::gmtime; +use strict; +use 5.006_001; + +use Time::tm; + +our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION); +BEGIN { + use Exporter (); + @ISA = qw(Exporter Time::tm); + @EXPORT = qw(gmtime gmctime); + @EXPORT_OK = qw( + $tm_sec $tm_min $tm_hour $tm_mday + $tm_mon $tm_year $tm_wday $tm_yday + $tm_isdst + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + $VERSION = 1.02; +} +use vars @EXPORT_OK; + +sub populate (@) { + return unless @_; + my $tmob = Time::tm->new(); + @$tmob = ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst ) + = @_; + return $tmob; +} + +sub gmtime (;$) { populate CORE::gmtime(@_ ? shift : time)} +sub gmctime (;$) { scalar CORE::gmtime(@_ ? shift : time)} + +1; +__END__ + +=head1 NAME + +Time::gmtime - by-name interface to Perl's built-in gmtime() function + +=head1 SYNOPSIS + + use Time::gmtime; + $gm = gmtime(); + printf "The day in Greenwich is %s\n", + (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm->wday() ]; + + use Time::gmtime w(:FIELDS; + printf "The day in Greenwich is %s\n", + (qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm_wday() ]; + + $now = gmctime(); + + use Time::gmtime; + use File::stat; + $date_string = gmctime(stat($file)->mtime); + +=head1 DESCRIPTION + +This module's default exports override the core gmtime() function, +replacing it with a version that returns "Time::tm" objects. +This object has methods that return the similarly named structure field +name from the C's tm structure from F<time.h>; namely sec, min, hour, +mday, mon, year, wday, yday, and isdst. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this +still overrides your core functions.) Access these fields as variables +named with a preceding C<tm_> in front their method names. Thus, +C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields. + +The gmctime() function provides a way of getting at the +scalar sense of the original CORE::gmtime() function. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/Master/tlpkg/installer/perllib/Time/localtime.pm b/Master/tlpkg/installer/perllib/Time/localtime.pm new file mode 100644 index 00000000000..c3d9fb36085 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Time/localtime.pm @@ -0,0 +1,86 @@ +package Time::localtime; +use strict; +use 5.006_001; + +use Time::tm; + +our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION); +BEGIN { + use Exporter (); + @ISA = qw(Exporter Time::tm); + @EXPORT = qw(localtime ctime); + @EXPORT_OK = qw( + $tm_sec $tm_min $tm_hour $tm_mday + $tm_mon $tm_year $tm_wday $tm_yday + $tm_isdst + ); + %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); + $VERSION = 1.02; +} +use vars @EXPORT_OK; + +sub populate (@) { + return unless @_; + my $tmob = Time::tm->new(); + @$tmob = ( + $tm_sec, $tm_min, $tm_hour, $tm_mday, + $tm_mon, $tm_year, $tm_wday, $tm_yday, + $tm_isdst ) + = @_; + return $tmob; +} + +sub localtime (;$) { populate CORE::localtime(@_ ? shift : time)} +sub ctime (;$) { scalar CORE::localtime(@_ ? shift : time) } + +1; + +__END__ + +=head1 NAME + +Time::localtime - by-name interface to Perl's built-in localtime() function + +=head1 SYNOPSIS + + use Time::localtime; + printf "Year is %d\n", localtime->year() + 1900; + + $now = ctime(); + + use Time::localtime; + use File::stat; + $date_string = ctime(stat($file)->mtime); + +=head1 DESCRIPTION + +This module's default exports override the core localtime() function, +replacing it with a version that returns "Time::tm" objects. +This object has methods that return the similarly named structure field +name from the C's tm structure from F<time.h>; namely sec, min, hour, +mday, mon, year, wday, yday, and isdst. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your core functions.) Access these fields as +variables named with a preceding C<tm_> in front their method names. +Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import +the fields. + +The ctime() function provides a way of getting at the +scalar sense of the original CORE::localtime() function. + +To access this functionality without the core overrides, +pass the C<use> an empty import list, and then access +function functions with their full qualified names. +On the other hand, the built-ins are still available +via the C<CORE::> pseudo-package. + +=head1 NOTE + +While this class is currently implemented using the Class::Struct +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/Master/tlpkg/installer/perllib/Time/tm.pm b/Master/tlpkg/installer/perllib/Time/tm.pm new file mode 100644 index 00000000000..2c308ebb411 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Time/tm.pm @@ -0,0 +1,33 @@ +package Time::tm; +use strict; + +our $VERSION = '1.00'; + +use Class::Struct qw(struct); +struct('Time::tm' => [ + map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst } +]); + +1; +__END__ + +=head1 NAME + +Time::tm - internal object used by Time::gmtime and Time::localtime + +=head1 SYNOPSIS + +Don't use this module directly. + +=head1 DESCRIPTION + +This module is used internally as a base class by Time::localtime And +Time::gmtime functions. It creates a Time::tm struct object which is +addressable just like's C's tm structure from F<time.h>; namely with sec, +min, hour, mday, mon, year, wday, yday, and isdst. + +This class is an internal interface only. + +=head1 AUTHOR + +Tom Christiansen diff --git a/Master/tlpkg/installer/perllib/UNIVERSAL.pm b/Master/tlpkg/installer/perllib/UNIVERSAL.pm new file mode 100644 index 00000000000..7b7bfc4058a --- /dev/null +++ b/Master/tlpkg/installer/perllib/UNIVERSAL.pm @@ -0,0 +1,147 @@ +package UNIVERSAL; + +our $VERSION = '1.01'; + +# UNIVERSAL should not contain any extra subs/methods beyond those +# that it exists to define. The use of Exporter below is a historical +# accident that can't be fixed without breaking code. Note that we +# *don't* set @ISA here, don't want all classes/objects inheriting from +# Exporter. It's bad enough that all classes have a import() method +# whenever UNIVERSAL.pm is loaded. +require Exporter; +*import = \&Exporter::import; +@EXPORT_OK = qw(isa can VERSION); + +1; +__END__ + +=head1 NAME + +UNIVERSAL - base class for ALL classes (blessed references) + +=head1 SYNOPSIS + + $is_io = $fd->isa("IO::Handle"); + $is_io = Class->isa("IO::Handle"); + + $sub = $obj->can("print"); + $sub = Class->can("print"); + + use UNIVERSAL qw( isa can VERSION ); + $yes = isa $ref, "HASH" ; + $sub = can $ref, "fandango" ; + $ver = VERSION $obj ; + +=head1 DESCRIPTION + +C<UNIVERSAL> is the base class which all bless references will inherit from, +see L<perlobj>. + +C<UNIVERSAL> provides the following methods and functions: + +=over 4 + +=item C<< $obj->isa( TYPE ) >> + +=item C<< CLASS->isa( TYPE ) >> + +=item C<isa( VAL, TYPE )> + +Where + +=over 4 + +=item C<TYPE> + +is a package name + +=item C<$obj> + +is a blessed reference or a string containing a package name + +=item C<CLASS> + +is a package name + +=item C<VAL> + +is any of the above or an unblessed reference + +=back + +When used as an instance or class method (C<< $obj->isa( TYPE ) >>), +C<isa> returns I<true> if $obj is blessed into package C<TYPE> or +inherits from package C<TYPE>. + +When used as a class method (C<< CLASS->isa( TYPE ) >>: sometimes +referred to as a static method), C<isa> returns I<true> if C<CLASS> +inherits from (or is itself) the name of the package C<TYPE> or +inherits from package C<TYPE>. + +When used as a function, like + + use UNIVERSAL qw( isa ) ; + $yes = isa $h, "HASH"; + $yes = isa "Foo", "Bar"; + +or + + require UNIVERSAL ; + $yes = UNIVERSAL::isa $a, "ARRAY"; + +C<isa> returns I<true> in the same cases as above and also if C<VAL> is an +unblessed reference to a perl variable of type C<TYPE>, such as "HASH", +"ARRAY", or "Regexp". + +=item C<< $obj->can( METHOD ) >> + +=item C<< CLASS->can( METHOD ) >> + +=item C<can( VAL, METHOD )> + +C<can> checks if the object or class has a method called C<METHOD>. If it does +then a reference to the sub is returned. If it does not then I<undef> is +returned. This includes methods inherited or imported by C<$obj>, C<CLASS>, or +C<VAL>. + +C<can> cannot know whether an object will be able to provide a method +through AUTOLOAD, so a return value of I<undef> does not necessarily mean +the object will not be able to handle the method call. To get around +this some module authors use a forward declaration (see L<perlsub>) +for methods they will handle via AUTOLOAD. For such 'dummy' subs, C<can> +will still return a code reference, which, when called, will fall through +to the AUTOLOAD. If no suitable AUTOLOAD is provided, calling the coderef +will cause an error. + +C<can> can be called as a class (static) method, an object method, or a +function. + +When used as a function, if C<VAL> is a blessed reference or package name which +has a method called C<METHOD>, C<can> returns a reference to the subroutine. +If C<VAL> is not a blessed reference, or if it does not have a method +C<METHOD>, I<undef> is returned. + +=item C<VERSION ( [ REQUIRE ] )> + +C<VERSION> will return the value of the variable C<$VERSION> in the +package the object is blessed into. If C<REQUIRE> is given then +it will do a comparison and die if the package version is not +greater than or equal to C<REQUIRE>. + +C<VERSION> can be called as either a class (static) method, an object +method or a function. + + +=back + +=head1 EXPORTS + +None by default. + +You may request the import of all three functions (C<isa>, C<can>, and +C<VERSION>), however it isn't usually necessary to do so. Perl magically +makes these functions act as methods on all objects. The one exception is +C<isa>, which is useful as a function when operating on non-blessed +references. + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32.pm b/Master/tlpkg/installer/perllib/Win32.pm new file mode 100644 index 00000000000..e55bfee4dfe --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32.pm @@ -0,0 +1,712 @@ +package Win32; + +BEGIN { + use strict; + use vars qw|$VERSION @ISA @EXPORT @EXPORT_OK|; + + require Exporter; + require DynaLoader; + + @ISA = qw|Exporter DynaLoader|; + $VERSION = '0.2601'; + + @EXPORT = qw( + NULL + WIN31_CLASS + OWNER_SECURITY_INFORMATION + GROUP_SECURITY_INFORMATION + DACL_SECURITY_INFORMATION + SACL_SECURITY_INFORMATION + MB_ICONHAND + MB_ICONQUESTION + MB_ICONEXCLAMATION + MB_ICONASTERISK + MB_ICONWARNING + MB_ICONERROR + MB_ICONINFORMATION + MB_ICONSTOP + ); + @EXPORT_OK = qw( + GetOSName + SW_HIDE + SW_SHOWNORMAL + SW_SHOWMINIMIZED + SW_SHOWMAXIMIZED + SW_SHOWNOACTIVATE + + CSIDL_DESKTOP + CSIDL_PROGRAMS + CSIDL_PERSONAL + CSIDL_FAVORITES + CSIDL_STARTUP + CSIDL_RECENT + CSIDL_SENDTO + CSIDL_STARTMENU + CSIDL_MYMUSIC + CSIDL_MYVIDEO + CSIDL_DESKTOPDIRECTORY + CSIDL_NETHOOD + CSIDL_FONTS + CSIDL_TEMPLATES + CSIDL_COMMON_STARTMENU + CSIDL_COMMON_PROGRAMS + CSIDL_COMMON_STARTUP + CSIDL_COMMON_DESKTOPDIRECTORY + CSIDL_APPDATA + CSIDL_PRINTHOOD + CSIDL_LOCAL_APPDATA + CSIDL_COMMON_FAVORITES + CSIDL_INTERNET_CACHE + CSIDL_COOKIES + CSIDL_HISTORY + CSIDL_COMMON_APPDATA + CSIDL_WINDOWS + CSIDL_SYSTEM + CSIDL_PROGRAM_FILES + CSIDL_MYPICTURES + CSIDL_PROFILE + CSIDL_PROGRAM_FILES_COMMON + CSIDL_COMMON_TEMPLATES + CSIDL_COMMON_DOCUMENTS + CSIDL_COMMON_ADMINTOOLS + CSIDL_ADMINTOOLS + CSIDL_COMMON_MUSIC + CSIDL_COMMON_PICTURES + CSIDL_COMMON_VIDEO + CSIDL_RESOURCES + CSIDL_RESOURCES_LOCALIZED + CSIDL_CDBURN_AREA + ); +} + +# Routines available in core: +# Win32::GetLastError +# Win32::LoginName +# Win32::NodeName +# Win32::DomainName +# Win32::FsType +# Win32::GetCwd +# Win32::GetOSVersion +# Win32::FormatMessage ERRORCODE +# Win32::Spawn COMMAND, ARGS, PID +# Win32::GetTickCount +# Win32::IsWinNT +# Win32::IsWin95 + +# We won't bother with the constant stuff, too much of a hassle. Just hard +# code it here. + +sub NULL { 0 } +sub WIN31_CLASS { &NULL } + +sub OWNER_SECURITY_INFORMATION { 0x00000001 } +sub GROUP_SECURITY_INFORMATION { 0x00000002 } +sub DACL_SECURITY_INFORMATION { 0x00000004 } +sub SACL_SECURITY_INFORMATION { 0x00000008 } + +sub MB_ICONHAND { 0x00000010 } +sub MB_ICONQUESTION { 0x00000020 } +sub MB_ICONEXCLAMATION { 0x00000030 } +sub MB_ICONASTERISK { 0x00000040 } +sub MB_ICONWARNING { 0x00000030 } +sub MB_ICONERROR { 0x00000010 } +sub MB_ICONINFORMATION { 0x00000040 } +sub MB_ICONSTOP { 0x00000010 } + +# +# Newly added constants. These have an empty prototype, unlike the +# the ones above, which aren't prototyped for compatibility reasons. +# +sub SW_HIDE () { 0 } +sub SW_SHOWNORMAL () { 1 } +sub SW_SHOWMINIMIZED () { 2 } +sub SW_SHOWMAXIMIZED () { 3 } +sub SW_SHOWNOACTIVATE () { 4 } + +sub CSIDL_DESKTOP () { 0x0000 } # <desktop> +sub CSIDL_PROGRAMS () { 0x0002 } # Start Menu\Programs +sub CSIDL_PERSONAL () { 0x0005 } # "My Documents" folder +sub CSIDL_FAVORITES () { 0x0006 } # <user name>\Favorites +sub CSIDL_STARTUP () { 0x0007 } # Start Menu\Programs\Startup +sub CSIDL_RECENT () { 0x0008 } # <user name>\Recent +sub CSIDL_SENDTO () { 0x0009 } # <user name>\SendTo +sub CSIDL_STARTMENU () { 0x000B } # <user name>\Start Menu +sub CSIDL_MYMUSIC () { 0x000D } # "My Music" folder +sub CSIDL_MYVIDEO () { 0x000E } # "My Videos" folder +sub CSIDL_DESKTOPDIRECTORY () { 0x0010 } # <user name>\Desktop +sub CSIDL_NETHOOD () { 0x0013 } # <user name>\nethood +sub CSIDL_FONTS () { 0x0014 } # windows\fonts +sub CSIDL_TEMPLATES () { 0x0015 } +sub CSIDL_COMMON_STARTMENU () { 0x0016 } # All Users\Start Menu +sub CSIDL_COMMON_PROGRAMS () { 0x0017 } # All Users\Start Menu\Programs +sub CSIDL_COMMON_STARTUP () { 0x0018 } # All Users\Startup +sub CSIDL_COMMON_DESKTOPDIRECTORY () { 0x0019 } # All Users\Desktop +sub CSIDL_APPDATA () { 0x001A } # Application Data, new for NT4 +sub CSIDL_PRINTHOOD () { 0x001B } # <user name>\PrintHood +sub CSIDL_LOCAL_APPDATA () { 0x001C } # non roaming, user\Local Settings\Application Data +sub CSIDL_COMMON_FAVORITES () { 0x001F } +sub CSIDL_INTERNET_CACHE () { 0x0020 } +sub CSIDL_COOKIES () { 0x0021 } +sub CSIDL_HISTORY () { 0x0022 } +sub CSIDL_COMMON_APPDATA () { 0x0023 } # All Users\Application Data +sub CSIDL_WINDOWS () { 0x0024 } # GetWindowsDirectory() +sub CSIDL_SYSTEM () { 0x0025 } # GetSystemDirectory() +sub CSIDL_PROGRAM_FILES () { 0x0026 } # C:\Program Files +sub CSIDL_MYPICTURES () { 0x0027 } # "My Pictures", new for Win2K +sub CSIDL_PROFILE () { 0x0028 } # USERPROFILE +sub CSIDL_PROGRAM_FILES_COMMON () { 0x002B } # C:\Program Files\Common +sub CSIDL_COMMON_TEMPLATES () { 0x002D } # All Users\Templates +sub CSIDL_COMMON_DOCUMENTS () { 0x002E } # All Users\Documents +sub CSIDL_COMMON_ADMINTOOLS () { 0x002F } # All Users\Start Menu\Programs\Administrative Tools +sub CSIDL_ADMINTOOLS () { 0x0030 } # <user name>\Start Menu\Programs\Administrative Tools +sub CSIDL_COMMON_MUSIC () { 0x0035 } # All Users\My Music +sub CSIDL_COMMON_PICTURES () { 0x0036 } # All Users\My Pictures +sub CSIDL_COMMON_VIDEO () { 0x0037 } # All Users\My Video +sub CSIDL_RESOURCES () { 0x0038 } # %windir%\Resources\, For theme and other windows resources. +sub CSIDL_RESOURCES_LOCALIZED () { 0x0039 } # %windir%\Resources\<LangID>, for theme and other windows specific resources. +sub CSIDL_CDBURN_AREA () { 0x003B } # <user name>\Local Settings\Application Data\Microsoft\CD Burning + +### This method is just a simple interface into GetOSVersion(). More +### specific or demanding situations should use that instead. + +my ($found_os, $found_desc); + +sub GetOSName { + my ($os,$desc,$major, $minor, $build, $id)=("",""); + unless (defined $found_os) { + # If we have a run this already, we have the results cached + # If so, return them + + # Use the standard API call to determine the version + ($desc, $major, $minor, $build, $id) = Win32::GetOSVersion(); + + # If id==0 then its a win32s box -- Meaning Win3.11 + unless($id) { + $os = 'Win32s'; + } + else { + # Magic numbers from MSDN documentation of OSVERSIONINFO + # Most version names can be parsed from just the id and minor + # version + $os = { + 1 => { + 0 => "95", + 10 => "98", + 90 => "Me" + }, + 2 => { + 0 => "NT4", + 1 => "XP/.Net", + 2 => "2003", + 51 => "NT3.51" + } + }->{$id}->{$minor}; + } + + # This _really_ shouldnt happen. At least not for quite a while + # Politely warn and return undef + unless (defined $os) { + warn qq[Windows version [$id:$major:$minor] unknown!]; + return undef; + } + + my $tag = ""; + + # But distinguising W2k and Vista from NT4 requires looking at the major version + if ($os eq "NT4") { + $os = {5 => "2000", 6 => "Vista"}->{$major} || "NT4"; + } + + # For the rest we take a look at the build numbers and try to deduce + # the exact release name, but we put that in the $desc + elsif ($os eq "95") { + if ($build eq '67109814') { + $tag = '(a)'; + } + elsif ($build eq '67306684') { + $tag = '(b1)'; + } + elsif ($build eq '67109975') { + $tag = '(b2)'; + } + } + elsif ($os eq "98" && $build eq '67766446') { + $tag = '(2nd ed)'; + } + + if (length $tag) { + if (length $desc) { + $desc = "$tag $desc"; + } + else { + $desc = $tag; + } + } + + # cache the results, so we dont have to do this again + $found_os = "Win$os"; + $found_desc = $desc; + } + + return wantarray ? ($found_os, $found_desc) : $found_os; +} + +bootstrap Win32; + +1; + +__END__ + +=head1 NAME + +Win32 - Interfaces to some Win32 API Functions + +=head1 DESCRIPTION + +Perl on Win32 contains several functions to access Win32 APIs. Some +are included in Perl itself (on Win32) and some are only available +after explicitly requesting the Win32 module with: + + use Win32; + +The builtin functions are marked as [CORE] and the other ones +as [EXT] in the following alphabetical listing. + +=head2 Alphabetical Listing of Win32 Functions + +=over + +=item Win32::AbortSystemShutdown(MACHINE) + +[EXT] Aborts a system shutdown (started by the +InitiateSystemShutdown function) on the specified MACHINE. + +=item Win32::BuildNumber() + +[CORE] Returns the ActivePerl build number. This function is +only available in the ActivePerl binary distribution. + +=item Win32::CopyFile(FROM, TO, OVERWRITE) + +[CORE] The Win32::CopyFile() function copies an existing file to a new +file. All file information like creation time and file attributes will +be copied to the new file. However it will B<not> copy the security +information. If the destination file already exists it will only be +overwritten when the OVERWRITE parameter is true. But even this will +not overwrite a read-only file; you have to unlink() it first +yourself. + +=item Win32::DomainName() + +[CORE] Returns the name of the Microsoft Network domain that the +owner of the current perl process is logged into. This function does +B<not> work on Windows 9x. + +=item Win32::ExpandEnvironmentStrings(STRING) + +[EXT] Takes STRING and replaces all referenced environment variable +names with their defined values. References to environment variables +take the form C<%VariableName%>. Case is ignored when looking up the +VariableName in the environment. If the variable is not found then the +original C<%VariableName%> text is retained. Has the same effect +as the following: + + $string =~ s/%([^%]*)%/$ENV{$1} || "%$1%"/eg + +=item Win32::FormatMessage(ERRORCODE) + +[CORE] Converts the supplied Win32 error number (e.g. returned by +Win32::GetLastError()) to a descriptive string. Analogous to the +perror() standard-C library function. Note that C<$^E> used +in a string context has much the same effect. + + C:\> perl -e "$^E = 26; print $^E;" + The specified disk or diskette cannot be accessed + +=item Win32::FsType() + +[CORE] Returns the name of the filesystem of the currently active +drive (like 'FAT' or 'NTFS'). In list context it returns three values: +(FSTYPE, FLAGS, MAXCOMPLEN). FSTYPE is the filesystem type as +before. FLAGS is a combination of values of the following table: + + 0x00000001 supports case-sensitive filenames + 0x00000002 preserves the case of filenames + 0x00000004 supports Unicode in filenames + 0x00000008 preserves and enforces ACLs + 0x00000010 supports file-based compression + 0x00000020 supports disk quotas + 0x00000040 supports sparse files + 0x00000080 supports reparse points + 0x00000100 supports remote storage + 0x00008000 is a compressed volume (e.g. DoubleSpace) + 0x00010000 supports object identifiers + 0x00020000 supports the Encrypted File System (EFS) + +MAXCOMPLEN is the maximum length of a filename component (the part +between two backslashes) on this file system. + +=item Win32::FreeLibrary(HANDLE) + +[EXT] Unloads a previously loaded dynamic-link library. The HANDLE is +no longer valid after this call. See L<LoadLibrary|Win32::LoadLibrary(LIBNAME)> +for information on dynamically loading a library. + +=item Win32::GetArchName() + +[EXT] Use of this function is deprecated. It is equivalent with +$ENV{PROCESSOR_ARCHITECTURE}. This might not work on Win9X. + +=item Win32::GetChipName() + +[EXT] Returns the processor type: 386, 486 or 586 for Intel processors, +21064 for the Alpha chip. + +=item Win32::GetCwd() + +[CORE] Returns the current active drive and directory. This function +does not return a UNC path, since the functionality required for such +a feature is not available under Windows 95. + +=item Win32::GetFileVersion(FILENAME) + +[EXT] Returns the file version number from the VERSIONINFO resource of +the executable file or DLL. This is a tuple of four 16 bit numbers. +In list context these four numbers will be returned. In scalar context +they are concatenated into a string, separated by dots. + +=item Win32::GetFolderPath(FOLDER [, CREATE]) + +[EXT] Returns the full pathname of one of the Windows special folders. +The folder will be created if it doesn't exist and the optional CREATE +argument is true. The following FOLDER constants are defined by the +Win32 module, but only exported on demand: + + CSIDL_ADMINTOOLS + CSIDL_APPDATA + CSIDL_CDBURN_AREA + CSIDL_COMMON_ADMINTOOLS + CSIDL_COMMON_APPDATA + CSIDL_COMMON_DESKTOPDIRECTORY + CSIDL_COMMON_DOCUMENTS + CSIDL_COMMON_FAVORITES + CSIDL_COMMON_MUSIC + CSIDL_COMMON_PICTURES + CSIDL_COMMON_PROGRAMS + CSIDL_COMMON_STARTMENU + CSIDL_COMMON_STARTUP + CSIDL_COMMON_TEMPLATES + CSIDL_COMMON_VIDEO + CSIDL_COOKIES + CSIDL_DESKTOP + CSIDL_DESKTOPDIRECTORY + CSIDL_FAVORITES + CSIDL_FONTS + CSIDL_HISTORY + CSIDL_INTERNET_CACHE + CSIDL_LOCAL_APPDATA + CSIDL_MYMUSIC + CSIDL_MYPICTURES + CSIDL_MYVIDEO + CSIDL_NETHOOD + CSIDL_PERSONAL + CSIDL_PRINTHOOD + CSIDL_PROFILE + CSIDL_PROGRAMS + CSIDL_PROGRAM_FILES + CSIDL_PROGRAM_FILES_COMMON + CSIDL_RECENT + CSIDL_RESOURCES + CSIDL_RESOURCES_LOCALIZED + CSIDL_SENDTO + CSIDL_STARTMENU + CSIDL_STARTUP + CSIDL_SYSTEM + CSIDL_TEMPLATES + CSIDL_WINDOWS + +Note that not all folders are defined on all versions of Windows. + +Please refer to the MSDN documentation of the CSIDL constants, +currently available at: + +http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/enums/csidl.asp + +=item Win32::GetFullPathName(FILENAME) + +[CORE] GetFullPathName combines the FILENAME with the current drive +and directory name and returns a fully qualified (aka, absolute) +path name. In list context it returns two elements: (PATH, FILE) where +PATH is the complete pathname component (including trailing backslash) +and FILE is just the filename part. Note that no attempt is made to +convert 8.3 components in the supplied FILENAME to longnames or +vice-versa. Compare with Win32::GetShortPathName and +Win32::GetLongPathName. + +=item Win32::GetLastError() + +[CORE] Returns the last error value generated by a call to a Win32 API +function. Note that C<$^E> used in a numeric context amounts to the +same value. + +=item Win32::GetLongPathName(PATHNAME) + +[CORE] Returns a representation of PATHNAME composed of longname +components (if any). The result may not necessarily be longer +than PATHNAME. No attempt is made to convert PATHNAME to the +absolute path. Compare with Win32::GetShortPathName and +Win32::GetFullPathName. + +=item Win32::GetNextAvailDrive() + +[CORE] Returns a string in the form of "<d>:" where <d> is the first +available drive letter. + +=item Win32::GetOSVersion() + +[CORE] Returns the list (STRING, MAJOR, MINOR, BUILD, ID), where the +elements are, respectively: An arbitrary descriptive string, the major +version number of the operating system, the minor version number, the +build number, and a digit indicating the actual operating system. +For the ID, the values are 0 for Win32s, 1 for Windows 9X/Me and 2 for +Windows NT/2000/XP/2003. In scalar context it returns just the ID. + +Currently known values for ID MAJOR and MINOR are as follows: + + OS ID MAJOR MINOR + Win32s 0 - - + Windows 95 1 4 0 + Windows 98 1 4 10 + Windows Me 1 4 90 + Windows NT 3.51 2 3 51 + Windows NT 4 2 4 0 + Windows 2000 2 5 0 + Windows XP 2 5 1 + Windows Server 2003 2 5 2 + Windows Vista 2 6 0 + +On Windows NT 4 SP6 and later this function returns the following +additional values: SPMAJOR, SPMINOR, SUITEMASK, PRODUCTTYPE. + +SPMAJOR and SPMINOR are are the version numbers of the latest +installed service pack. + +SUITEMASK is a bitfield identifying the product suites available on +the system. Known bits are: + + VER_SUITE_SMALLBUSINESS 0x00000001 + VER_SUITE_ENTERPRISE 0x00000002 + VER_SUITE_BACKOFFICE 0x00000004 + VER_SUITE_COMMUNICATIONS 0x00000008 + VER_SUITE_TERMINAL 0x00000010 + VER_SUITE_SMALLBUSINESS_RESTRICTED 0x00000020 + VER_SUITE_EMBEDDEDNT 0x00000040 + VER_SUITE_DATACENTER 0x00000080 + VER_SUITE_SINGLEUSERTS 0x00000100 + VER_SUITE_PERSONAL 0x00000200 + VER_SUITE_BLADE 0x00000400 + VER_SUITE_EMBEDDED_RESTRICTED 0x00000800 + VER_SUITE_SECURITY_APPLIANCE 0x00001000 + +The VER_SUITE_xxx names are listed here to crossreference the Microsoft +documentation. The Win32 module does not provide symbolic names for these +constants. + +PRODUCTTYPE provides additional information about the system. It should +be one of the following integer values: + + 1 - Workstation (NT 4, 2000 Pro, XP Home, XP Pro) + 2 - Domaincontroller + 3 - Server + +=item Win32::GetOSName() + +[EXT] In scalar context returns the name of the Win32 operating system +being used. In list context returns a two element list of the OS name +and whatever edition information is known about the particular build +(for Win9X boxes) and whatever service packs have been installed. +The latter is roughly equivalent to the first item returned by +GetOSVersion() in list context. + +Currently the possible values for the OS name are + + Win32s Win95 Win98 WinMe WinNT3.51 WinNT4 Win2000 WinXP/.Net Win2003 + +This routine is just a simple interface into GetOSVersion(). More +specific or demanding situations should use that instead. Another +option would be to use POSIX::uname(), however the latter appears to +report only the OS family name and not the specific OS. In scalar +context it returns just the ID. + +The name "WinXP/.Net" is used for historical reasons only, to maintain +backwards compatibility of the Win32 module. Windows .NET Server has +been renamed as Windows 2003 Server before final release and uses a +different major/minor version number than Windows XP. + +=item Win32::GetShortPathName(PATHNAME) + +[CORE] Returns a representation of PATHNAME that is composed of short +(8.3) path components where available. For path components where the +file system has not generated the short form the returned path will +use the long form, so this function might still for instance return a +path containing spaces. Compare with Win32::GetFullPathName and +Win32::GetLongPathName. + +=item Win32::GetProcAddress(INSTANCE, PROCNAME) + +[EXT] Returns the address of a function inside a loaded library. The +information about what you can do with this address has been lost in +the mist of time. Use the Win32::API module instead of this deprecated +function. + +=item Win32::GetTickCount() + +[CORE] Returns the number of milliseconds elapsed since the last +system boot. Resolution is limited to system timer ticks (about 10ms +on WinNT and 55ms on Win9X). + +=item Win32::GuidGen() + +[EXT] Creates a globally unique 128 bit integer that can be used as a +persistent identifier in a distributed setting. To a very high degree +of certainty this function returns a unique value. No other +invocation, on the same or any other system (networked or not), should +return the same value. + +The return value is formatted according to OLE conventions, as groups +of hex digits with surrounding braces. For example: + + {09531CF1-D0C7-4860-840C-1C8C8735E2AD} + +=item Win32::InitiateSystemShutdown + +(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT) + +[EXT] Shutsdown the specified MACHINE, notifying users with the +supplied MESSAGE, within the specified TIMEOUT interval. Forces +closing of all documents without prompting the user if FORCECLOSE is +true, and reboots the machine if REBOOT is true. This function works +only on WinNT. + +=item Win32::IsAdminUser() + +[EXT] Returns non zero if the account in whose security context the +current process/thread is running belongs to the local group of +Administrators in the built-in system domain; returns 0 if not. +Returns the undefined value and prints a warning if an error occurred. +This function always returns 1 on Win9X. + +=item Win32::IsWinNT() + +[CORE] Returns non zero if the Win32 subsystem is Windows NT. + +=item Win32::IsWin95() + +[CORE] Returns non zero if the Win32 subsystem is Windows 95. + +=item Win32::LoadLibrary(LIBNAME) + +[EXT] Loads a dynamic link library into memory and returns its module +handle. This handle can be used with Win32::GetProcAddress and +Win32::FreeLibrary. This function is deprecated. Use the Win32::API +module instead. + +=item Win32::LoginName() + +[CORE] Returns the username of the owner of the current perl process. + +=item Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE) + +[EXT] Looks up ACCOUNT on SYSTEM and returns the domain name the SID and +the SID type. + +=item Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE) + +[EXT] Looks up SID on SYSTEM and returns the account name, domain name, +and the SID type. + +=item Win32::MsgBox(MESSAGE [, FLAGS [, TITLE]]) + +[EXT] Create a dialogbox containing MESSAGE. FLAGS specifies the +required icon and buttons according to the following table: + + 0 = OK + 1 = OK and Cancel + 2 = Abort, Retry, and Ignore + 3 = Yes, No and Cancel + 4 = Yes and No + 5 = Retry and Cancel + + MB_ICONSTOP "X" in a red circle + MB_ICONQUESTION question mark in a bubble + MB_ICONEXCLAMATION exclamation mark in a yellow triangle + MB_ICONINFORMATION "i" in a bubble + +TITLE specifies an optional window title. The default is "Perl". + +The function returns the menu id of the selected push button: + + 0 Error + + 1 OK + 2 Cancel + 3 Abort + 4 Retry + 5 Ignore + 6 Yes + 7 No + +=item Win32::NodeName() + +[CORE] Returns the Microsoft Network node-name of the current machine. + +=item Win32::RegisterServer(LIBRARYNAME) + +[EXT] Loads the DLL LIBRARYNAME and calls the function DllRegisterServer. + +=item Win32::SetChildShowWindow(SHOWWINDOW) + +[CORE] Sets the I<ShowMode> of child processes started by system(). +By default system() will create a new console window for child +processes if Perl itself is not running from a console. Calling +SetChildShowWindow(0) will make these new console windows invisible. +Calling SetChildShowWindow() without arguments reverts system() to the +default behavior. The return value of SetChildShowWindow() is the +previous setting or C<undef>. + +[EXT] The following symbolic constants for SHOWWINDOW are available +(but not exported) from the Win32 module: SW_HIDE, SW_SHOWNORMAL, +SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED and SW_SHOWNOACTIVATE. + +=item Win32::SetCwd(NEWDIRECTORY) + +[CORE] Sets the current active drive and directory. This function does not +work with UNC paths, since the functionality required to required for +such a feature is not available under Windows 95. + +=item Win32::SetLastError(ERROR) + +[CORE] Sets the value of the last error encountered to ERROR. This is +that value that will be returned by the Win32::GetLastError() +function. + +=item Win32::Sleep(TIME) + +[CORE] Pauses for TIME milliseconds. The timeslices are made available +to other processes and threads. + +=item Win32::Spawn(COMMAND, ARGS, PID) + +[CORE] Spawns a new process using the supplied COMMAND, passing in +arguments in the string ARGS. The pid of the new process is stored in +PID. This function is deprecated. Please use the Win32::Process module +instead. + +=item Win32::UnregisterServer(LIBRARYNAME) + +[EXT] Loads the DLL LIBRARYNAME and calls the function +DllUnregisterServer. + +=back + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm b/Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm new file mode 100644 index 00000000000..a86682da376 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/ChangeNotify.pm @@ -0,0 +1,198 @@ +#--------------------------------------------------------------------- +package Win32::ChangeNotify; +# +# Copyright 1998 Christopher J. Madsen +# +# Created: 3 Feb 1998 from the ActiveWare version +# (c) 1995 Microsoft Corporation. All rights reserved. +# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com +# +# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com> +# +# Author: Christopher J. Madsen <cjm@pobox.com> +# Version: 1.02 (13-Jun-1999) +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# Monitor directory for changes +#--------------------------------------------------------------------- +# 1.04 -Minor changes by Yves Orton to fix the trueness of $subtree (Dec 2002) + +$VERSION = '1.05'; + +use Carp; +use Win32::IPC 1.00 '/./'; # Import everything +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader Win32::IPC); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + FILE_NOTIFY_CHANGE_ATTRIBUTES + FILE_NOTIFY_CHANGE_DIR_NAME + FILE_NOTIFY_CHANGE_FILE_NAME + FILE_NOTIFY_CHANGE_LAST_WRITE + FILE_NOTIFY_CHANGE_SECURITY + FILE_NOTIFY_CHANGE_SIZE + INFINITE +); +@EXPORT_OK = qw( + wait_all wait_any +); + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + if ($constname =~ /^(?:FILE_NOTIFY_CHANGE_|INFINITE)/) { + local $! = 0; + my $val = constant($constname); + croak("$constname is not defined by Win32::ChangeNotify") if $! != 0; + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; + } +} # end AUTOLOAD + +bootstrap Win32::ChangeNotify; + +sub new { + my ($class,$path,$subtree,$filter) = @_; + + if ($filter =~ /\A[\s|A-Z_]+\Z/i) { + $filter = 0; + foreach (split(/[\s|]+/, $_[3])) { + $filter |= constant("FILE_NOTIFY_CHANGE_" . uc $_); + carp "Invalid filter $_" if $!; + } + } + _new($class,$path,$subtree,$filter); +} # end new + +sub Close { &close } + +sub FindFirst { $_[0] = Win32::ChangeNotify->_new(@_[1..3]); } + +sub FindNext { &reset } + +1; +__END__ + +=head1 NAME + +Win32::ChangeNotify - Monitor events related to files and directories + +=head1 SYNOPSIS + + require Win32::ChangeNotify; + + $notify = Win32::ChangeNotify->new($Path,$WatchSubTree,$Events); + $notify->wait or warn "Something failed: $!\n"; + # There has been a change. + +=head1 DESCRIPTION + +This module allows the user to use a Win32 change notification event +object from Perl. This allows the Perl program to monitor events +relating to files and directory trees. + +Unfortunately, the Win32 API which implements this feature does not +provide any indication of I<what> triggered the notification (as far +as I know). If you're monitoring a directory for file changes, and +you need to know I<which> file changed, you'll have to find some other +way of determining that. Depending on exactly what you're trying to +do, you may be able to check file timestamps to find recently changed +files. Or, you may need to cache the directory contents somewhere and +compare the current contents to your cached copy when you receive a +change notification. + +The C<wait> method and C<wait_all> & C<wait_any> functions are +inherited from the L<"Win32::IPC"> module. + +=head2 Methods + +=over 4 + +=item $notify = Win32::ChangeNotify->new($path, $subtree, $filter) + +Constructor for a new ChangeNotification object. C<$path> is the +directory to monitor. If C<$subtree> is true, then all directories +under C<$path> will be monitored. C<$filter> indicates what events +should trigger a notification. It should be a string containing any +of the following flags (separated by whitespace and/or C<|>). + + ATTRIBUTES Any attribute change + DIR_NAME Any directory name change + FILE_NAME Any file name change (creating/deleting/renaming) + LAST_WRITE Any change to a file's last write time + SECURITY Any security descriptor change + SIZE Any change in a file's size + +(C<$filter> can also be an integer composed from the +C<FILE_NOTIFY_CHANGE_*> constants.) + +=item $notify->close + +Shut down monitoring. You could just C<undef $notify> instead (but +C<close> works even if there are other copies of the object). This +happens automatically when your program exits. + +=item $notify->reset + +Resets the ChangeNotification object after a change has been detected. +The object will become signalled again after the next change. (It is +OK to call this immediately after C<new>, but it is not required.) + +=item $notify->wait + +See L<"Win32::IPC">. Remember to call C<reset> afterwards if you want +to continue monitoring. + +=back + +=head2 Deprecated Functions and Methods + +B<Win32::ChangeNotify> still supports the ActiveWare syntax, but its +use is deprecated. + +=over 4 + +=item FindFirst($Obj,$PathName,$WatchSubTree,$Filter) + +Use + + $Obj = Win32::ChangeNotify->new($PathName,$WatchSubTree,$Filter) + +instead. + +=item $obj->FindNext() + +Use C<$obj-E<gt>reset> instead. + +=item $obj->Close() + +Use C<$obj-E<gt>close> instead. + +=back + +=head1 AUTHOR + +Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> + +Loosely based on the original module by ActiveWare Internet Corp., +F<http://www.ActiveWare.com> + +=cut + +# Local Variables: +# tmtrack-file-task: "Win32::ChangeNotify" +# End: diff --git a/Master/tlpkg/installer/perllib/Win32/Client.pl b/Master/tlpkg/installer/perllib/Win32/Client.pl new file mode 100644 index 00000000000..6ae585b7c91 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Client.pl @@ -0,0 +1,63 @@ +use strict; +use Win32::Pipe; + +#### +# You may notice that named pipe names are case INsensitive! +#### + +my $PipeName = "\\\\.\\pipe\\TEST this LoNG Named Pipe!"; + +print "I am falling asleep for few seconds, so that we give time\nFor the server to get up and running.\n"; +sleep(4); +print "\nOpening a pipe ...\n"; + +if (my $Pipe = Win32::Pipe->new($PipeName)) { + print "\n\nPipe has been opened, writing data to it...\n"; + print "-------------------------------------------\n"; + $Pipe->Write("\n" . Win32::Pipe::Credit() . "\n\n"); + while () { + print "\nCommands:\n"; + print " FILE:xxxxx Dumps the file xxxxx.\n"; + print " Credit Dumps the credit screen.\n"; + print " Quit Quits this client (server remains running).\n"; + print " Exit Exits both client and server.\n"; + print " -----------------------------------------\n"; + + my $In = <STDIN>; + chop($In); + + if ((my $File = $In) =~ s/^file:(.*)/$1/i){ + if (-s $File) { + if (open(FILE, "< $File")) { + while ($File = <FILE>) { + $In .= $File; + }; + close(FILE); + } + } + } + + if ($In =~ /^credit$/i){ + $In = "\n" . Win32::Pipe::Credit() . "\n\n"; + } + + unless ($Pipe->Write($In)) { + print "Writing to pipe failed.\n"; + last; + } + + if ($In =~ /^(exit|quit)$/i) { + print "\nATTENTION: Closing due to user request.\n"; + last; + } + } + print "Closing...\n"; + $Pipe->Close(); +} +else { + my($Error, $ErrorText) = Win32::Pipe::Error(); + print "Error:$Error \"$ErrorText\"\n"; + sleep(4); +} + +print "Done...\n"; diff --git a/Master/tlpkg/installer/perllib/Win32/Clipboard.pm b/Master/tlpkg/installer/perllib/Win32/Clipboard.pm new file mode 100644 index 00000000000..ba4038a5ade --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Clipboard.pm @@ -0,0 +1,369 @@ +package Win32::Clipboard; +####################################################################### +# +# Win32::Clipboard - Interaction with the Windows clipboard +# +# Version: 0.52 +# Author: Aldo Calpini <dada@perl.it> +# +# Modified by: Hideyo Imazu <himazu@gmail.com> +# +####################################################################### + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. + +@ISA = qw( Exporter DynaLoader ); +@EXPORT = qw( + CF_TEXT + CF_BITMAP + CF_METAFILEPICT + CF_SYLK + CF_DIF + CF_TIFF + CF_OEMTEXT + CF_DIB + CF_PALETTE + CF_PENDATA + CF_RIFF + CF_WAVE + CF_UNICODETEXT + CF_ENHMETAFILE + CF_HDROP + CF_LOCALE +); + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } else { + my ($pack, $file, $line) = caller; + die "Win32::Clipboard::$constname is not defined, used at $file line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# STATIC OBJECT PROPERTIES +# +$VERSION = "0.5201"; + +####################################################################### +# FUNCTIONS +# + +sub new { + my($class, $value) = @_; + my $self = "I'm the Clipboard!"; + Set($value) if defined($value); + return bless(\$self); +} + +sub Version { + return $VERSION; +} + +sub Get { + if( IsBitmap() ) { return GetBitmap(); } + elsif( IsFiles() ) { return GetFiles(); } + else { return GetText(); } +} + +sub TIESCALAR { + my $class = shift; + my $value = shift; + Set($value) if defined $value; + my $self = "I'm the Clipboard!"; + return bless \$self, $class; +} + +sub FETCH { Get() } +sub STORE { shift; Set(@_) } + +sub DESTROY { + my($self) = @_; + undef $self; + StopClipboardViewer(); +} + +END { + StopClipboardViewer(); +} + +####################################################################### +# dynamically load in the Clipboard.pll module. +# + +bootstrap Win32::Clipboard; + +####################################################################### +# a little hack to use the module itself as a class. +# + +sub main::Win32::Clipboard { + my($value) = @_; + my $self={}; + my $result = Win32::Clipboard::Set($value) if defined($value); + return bless($self, "Win32::Clipboard"); +} + +1; + +__END__ + +=head1 NAME + +Win32::Clipboard - Interaction with the Windows clipboard + +=head1 SYNOPSIS + + use Win32::Clipboard; + + $CLIP = Win32::Clipboard(); + + print "Clipboard contains: ", $CLIP->Get(), "\n"; + + $CLIP->Set("some text to copy into the clipboard"); + + $CLIP->Empty(); + + $CLIP->WaitForChange(); + print "Clipboard has changed!\n"; + + +=head1 DESCRIPTION + +This module lets you interact with the Windows clipboard: you can get its content, +set it, empty it, or let your script sleep until it changes. +This version supports 3 formats for clipboard data: + +=over 4 + +=item * +text (C<CF_TEXT>) + +The clipboard contains some text; this is the B<only> format you can use to set +clipboard data; you get it as a single string. + +Example: + + $text = Win32::Clipboard::GetText(); + print $text; + +=item * +bitmap (C<CF_DIB>) + +The clipboard contains an image, either a bitmap or a picture copied in the +clipboard from a graphic application. The data you get is a binary buffer +ready to be written to a bitmap (BMP format) file. + +Example: + + $image = Win32::Clipboard::GetBitmap(); + open BITMAP, ">some.bmp"; + binmode BITMAP; + print BITMAP $image; + close BITMAP; + +=item * +list of files (C<CF_HDROP>) + +The clipboard contains files copied or cutted from an Explorer-like +application; you get a list of filenames. + +Example: + + @files = Win32::Clipboard::GetFiles(); + print join("\n", @files); + +=back + +=head2 REFERENCE + +All the functions can be used either with their full name (eg. B<Win32::Clipboard::Get>) +or as methods of a C<Win32::Clipboard> object. +For the syntax, refer to L</SYNOPSIS> above. Note also that you can create a clipboard +object and set its content at the same time with: + + $CLIP = Win32::Clipboard("blah blah blah"); + +or with the more common form: + + $CLIP = new Win32::Clipboard("blah blah blah"); + +If you prefer, you can even tie the Clipboard to a variable like this: + + tie $CLIP, 'Win32::Clipboard'; + + print "Clipboard content: $CLIP\n"; + + $CLIP = "some text to copy to the clipboard..."; + +In this case, you can still access other methods using the tied() function: + + tied($CLIP)->Empty; + print "got the picture" if tied($CLIP)->IsBitmap; + +=over 4 + +=item Empty() + +Empty the clipboard. + +=for html <P> + +=item EnumFormats() + +Returns an array of identifiers describing the format for the data currently in the +clipboard. Formats can be standard ones (described in the L</CONSTANTS> section) or +application-defined custom ones. See also IsFormatAvailable(). + +=for html <P> + +=item Get() + +Returns the clipboard content; note that the result depends on the nature of +clipboard data; to ensure that you get only the desired format, you should use +GetText(), GetBitmap() or GetFiles() instead. Get() is in fact implemented as: + + if( IsBitmap() ) { return GetBitmap(); } + elsif( IsFiles() ) { return GetFiles(); } + else { return GetText(); } + +See also IsBitmap(), IsFiles(), IsText(), EnumFormats() and IsFormatAvailable() +to check the clipboard format before getting data. + +=for html <P> + +=item GetAs(FORMAT) + +Returns the clipboard content in the desired FORMAT (can be one of the constants +defined in the L</CONSTANTS> section or a custom format). Note that the only +meaningful identifiers are C<CF_TEXT>, C<CF_DIB> and C<CF_HDROP>; any other +format is treated as a string. + +=for html <P> + +=item GetBitmap() + +Returns the clipboard content as an image, or C<undef> on errors. + +=for html <P> + +=item GetFiles() + +Returns the clipboard content as a list of filenames, or C<undef> on errors. + +=for html <P> + +=item GetFormatName(FORMAT) + +Returns the name of the specified custom clipboard format, or C<undef> on errors; +note that you cannot get the name of the standard formats (described in the +L</CONSTANTS> section). + +=for html <P> + +=item GetText() + +Returns the clipboard content as a string, or C<undef> on errors. + +=for html <P> + +=item IsBitmap() + +Returns a boolean value indicating if the clipboard contains an image. +See also GetBitmap(). + +=for html <P> + +=item IsFiles() + +Returns a boolean value indicating if the clipboard contains a list of +files. See also GetFiles(). + +=for html <P> + +=item IsFormatAvailable(FORMAT) + +Checks if the clipboard data matches the specified FORMAT (one of the constants +described in the L</CONSTANTS> section); returns zero if the data does not match, +a nonzero value if it matches. + +=for html <P> + +=item IsText() + +Returns a boolean value indicating if the clipboard contains text. +See also GetText(). + +=for html <P> + +=item Set(VALUE) + +Set the clipboard content to the specified string. + +=for html <P> + +=item WaitForChange([TIMEOUT]) + +This function halts the script until the clipboard content changes. If you specify +a C<TIMEOUT> value (in milliseconds), the function will return when this timeout +expires, even if the clipboard hasn't changed. If no value is given, it will wait +indefinitely. Returns 1 if the clipboard has changed, C<undef> on errors. + +=back + +=head2 CONSTANTS + +These constants are the standard clipboard formats recognized by Win32::Clipboard: + + CF_TEXT 1 + CF_DIB 8 + CF_HDROP 15 + +The following formats are B<not recognized> by Win32::Clipboard; they are, +however, exported constants and can eventually be used with the EnumFormats(), +IsFormatAvailable() and GetAs() functions: + + CF_BITMAP 2 + CF_METAFILEPICT 3 + CF_SYLK 4 + CF_DIF 5 + CF_TIFF 6 + CF_OEMTEXT 7 + CF_PALETTE 9 + CF_PENDATA 10 + CF_RIFF 11 + CF_WAVE 12 + CF_UNICODETEXT 13 + CF_ENHMETAFILE 14 + CF_LOCALE 16 + +=head1 AUTHOR + +This version was released by Hideyo Imazu <F<himazu@gmail.com>>. + +Aldo Calpini <F<dada@perl.it>> was the former maintainer. + +Original XS porting by Gurusamy Sarathy <F<gsar@activestate.com>>. + +=cut + + diff --git a/Master/tlpkg/installer/perllib/Win32/Console.pm b/Master/tlpkg/installer/perllib/Win32/Console.pm new file mode 100644 index 00000000000..1e3876a6a33 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Console.pm @@ -0,0 +1,1463 @@ +####################################################################### +# +# Win32::Console - Win32 Console and Character Mode Functions +# +####################################################################### + +package Win32::Console; + +require Exporter; +require DynaLoader; + +$VERSION = "0.07"; + +@ISA= qw( Exporter DynaLoader ); +@EXPORT = qw( + BACKGROUND_BLUE + BACKGROUND_GREEN + BACKGROUND_INTENSITY + BACKGROUND_RED + CAPSLOCK_ON + CONSOLE_TEXTMODE_BUFFER + CTRL_BREAK_EVENT + CTRL_C_EVENT + ENABLE_ECHO_INPUT + ENABLE_LINE_INPUT + ENABLE_MOUSE_INPUT + ENABLE_PROCESSED_INPUT + ENABLE_PROCESSED_OUTPUT + ENABLE_WINDOW_INPUT + ENABLE_WRAP_AT_EOL_OUTPUT + ENHANCED_KEY + FILE_SHARE_READ + FILE_SHARE_WRITE + FOREGROUND_BLUE + FOREGROUND_GREEN + FOREGROUND_INTENSITY + FOREGROUND_RED + LEFT_ALT_PRESSED + LEFT_CTRL_PRESSED + NUMLOCK_ON + GENERIC_READ + GENERIC_WRITE + RIGHT_ALT_PRESSED + RIGHT_CTRL_PRESSED + SCROLLLOCK_ON + SHIFT_PRESSED + STD_INPUT_HANDLE + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + $FG_BLACK + $FG_GRAY + $FG_BLUE + $FG_LIGHTBLUE + $FG_RED + $FG_LIGHTRED + $FG_GREEN + $FG_LIGHTGREEN + $FG_MAGENTA + $FG_LIGHTMAGENTA + $FG_CYAN + $FG_LIGHTCYAN + $FG_BROWN + $FG_YELLOW + $FG_LIGHTGRAY + $FG_WHITE + $BG_BLACK + $BG_GRAY + $BG_BLUE + $BG_LIGHTBLUE + $BG_RED + $BG_LIGHTRED + $BG_GREEN + $BG_LIGHTGREEN + $BG_MAGENTA + $BG_LIGHTMAGENTA + $BG_CYAN + $BG_LIGHTCYAN + $BG_BROWN + $BG_YELLOW + $BG_LIGHTGRAY + $BG_WHITE + $ATTR_NORMAL + $ATTR_INVERSE + @CONSOLE_COLORS +); + + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { +# if ($! =~ /Invalid/) { +# $AutoLoader::AUTOLOAD = $AUTOLOAD; +# goto &AutoLoader::AUTOLOAD; +# } else { + ($pack, $file, $line) = caller; undef $pack; + die "Symbol Win32::Console::$constname not defined, used at $file line $line."; +# } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# STATIC OBJECT PROPERTIES +# + +# %HandlerRoutineStack = (); +# $HandlerRoutineRegistered = 0; + +####################################################################### +# PUBLIC METHODS +# + +#======== +sub new { +#======== + my($class, $param1, $param2) = @_; + + my $self = {}; + + if (defined($param1) + and ($param1 == constant("STD_INPUT_HANDLE", 0) + or $param1 == constant("STD_OUTPUT_HANDLE", 0) + or $param1 == constant("STD_ERROR_HANDLE", 0))) + { + $self->{'handle'} = _GetStdHandle($param1); + } + else { + $param1 = constant("GENERIC_READ", 0) | constant("GENERIC_WRITE", 0) unless $param1; + $param2 = constant("FILE_SHARE_READ", 0) | constant("FILE_SHARE_WRITE", 0) unless $param2; + $self->{'handle'} = _CreateConsoleScreenBuffer($param1, $param2, + constant("CONSOLE_TEXTMODE_BUFFER", 0)); + } + bless $self, $class; + return $self; +} + +#============ +sub Display { +#============ + my($self) = @_; + return undef unless ref($self); + return _SetConsoleActiveScreenBuffer($self->{'handle'}); +} + +#=========== +sub Select { +#=========== + my($self, $type) = @_; + return undef unless ref($self); + return _SetStdHandle($type, $self->{'handle'}); +} + +#=========== +sub SetIcon { +#=========== + my($self, $icon) = @_; + $icon = $self unless ref($self); + return _SetConsoleIcon($icon); +} + +#========== +sub Title { +#========== + my($self, $title) = @_; + $title = $self unless ref($self); + + if (defined($title)) { + return _SetConsoleTitle($title); + } + else { + return _GetConsoleTitle(); + } +} + +#============== +sub WriteChar { +#============== + my($self, $text, $col, $row) = @_; + return undef unless ref($self); + return _WriteConsoleOutputCharacter($self->{'handle'},$text,$col,$row); +} + +#============= +sub ReadChar { +#============= + my($self, $size, $col, $row) = @_; + return undef unless ref($self); + + my $buffer = (" " x $size); + if (_ReadConsoleOutputCharacter($self->{'handle'}, $buffer, $size, $col, $row)) { + return $buffer; + } + else { + return undef; + } +} + +#============== +sub WriteAttr { +#============== + my($self, $attr, $col, $row) = @_; + return undef unless ref($self); + return _WriteConsoleOutputAttribute($self->{'handle'}, $attr, $col, $row); +} + +#============= +sub ReadAttr { +#============= + my($self, $size, $col, $row) = @_; + return undef unless ref($self); + return _ReadConsoleOutputAttribute($self->{'handle'}, $size, $col, $row); +} + +#========== +sub Write { +#========== + my($self,$string) = @_; + return undef unless ref($self); + return _WriteConsole($self->{'handle'}, $string); +} + +#============= +sub ReadRect { +#============= + my($self, $left, $top, $right, $bottom) = @_; + return undef unless ref($self); + + my $col = $right - $left + 1; + my $row = $bottom - $top + 1; + + my $buffer = (" " x ($col*$row*4)); + if (_ReadConsoleOutput($self->{'handle'}, $buffer, + $col, $row, 0, 0, + $left, $top, $right, $bottom)) + { + return $buffer; + } + else { + return undef; + } +} + +#============== +sub WriteRect { +#============== + my($self, $buffer, $left, $top, $right, $bottom) = @_; + return undef unless ref($self); + + my $col = $right - $left + 1; + my $row = $bottom - $top + 1; + + return _WriteConsoleOutput($self->{'handle'}, $buffer, + $col, $row, 0, 0, + $left, $top, $right, $bottom); +} + +#=========== +sub Scroll { +#=========== + my($self, $left1, $top1, $right1, $bottom1, + $col, $row, $char, $attr, + $left2, $top2, $right2, $bottom2) = @_; + return undef unless ref($self); + + return _ScrollConsoleScreenBuffer($self->{'handle'}, + $left1, $top1, $right1, $bottom1, + $col, $row, $char, $attr, + $left2, $top2, $right2, $bottom2); +} + +#============== +sub MaxWindow { +#============== + my($self, $flag) = @_; + return undef unless ref($self); + + if (not defined($flag)) { + my @info = _GetConsoleScreenBufferInfo($self->{'handle'}); + return $info[9], $info[10]; + } + else { + return _GetLargestConsoleWindowSize($self->{'handle'}); + } +} + +#========= +sub Info { +#========= + my($self) = @_; + return undef unless ref($self); + return _GetConsoleScreenBufferInfo($self->{'handle'}); +} + +#=========== +sub Window { +#=========== + my($self, $flag, $left, $top, $right, $bottom) = @_; + return undef unless ref($self); + + if (not defined($flag)) { + my @info = _GetConsoleScreenBufferInfo($self->{'handle'}); + return $info[5], $info[6], $info[7], $info[8]; + } + else { + return _SetConsoleWindowInfo($self->{'handle'}, $flag, $left, $top, $right, $bottom); + } +} + +#============== +sub GetEvents { +#============== + my($self) = @_; + return undef unless ref($self); + return _GetNumberOfConsoleInputEvents($self->{'handle'}); +} + +#========== +sub Flush { +#========== + my($self) = @_; + return undef unless ref($self); + return _FlushConsoleInputBuffer($self->{'handle'}); +} + +#============== +sub InputChar { +#============== + my($self, $number) = @_; + return undef unless ref($self); + + $number = 1 unless defined($number); + + my $buffer = (" " x $number); + if (_ReadConsole($self->{'handle'}, $buffer, $number) == $number) { + return $buffer; + } + else { + return undef; + } +} + +#========== +sub Input { +#========== + my($self) = @_; + return undef unless ref($self); + return _ReadConsoleInput($self->{'handle'}); +} + +#============== +sub PeekInput { +#============== + my($self) = @_; + return undef unless ref($self); + return _PeekConsoleInput($self->{'handle'}); +} + +#=============== +sub WriteInput { +#=============== + my($self) = shift; + return undef unless ref($self); + return _WriteConsoleInput($self->{'handle'}, @_); +} + +#========= +sub Mode { +#========= + my($self, $mode) = @_; + return undef unless ref($self); + if (defined($mode)) { + return _SetConsoleMode($self->{'handle'}, $mode); + } + else { + return _GetConsoleMode($self->{'handle'}); + } +} + +#======== +sub Cls { +#======== + my($self, $attr) = @_; + return undef unless ref($self); + + $attr = $ATTR_NORMAL unless defined($attr); + + my ($x, $y) = $self->Size(); + my($left, $top, $right ,$bottom) = $self->Window(); + my $vx = $right - $left; + my $vy = $bottom - $top; + $self->FillChar(" ", $x*$y, 0, 0); + $self->FillAttr($attr, $x*$y, 0, 0); + $self->Cursor(0, 0); + $self->Window(1, 0, 0, $vx, $vy); +} + +#========= +sub Attr { +#========= + my($self, $attr) = @_; + return undef unless ref($self); + + if (not defined($attr)) { + return (_GetConsoleScreenBufferInfo($self->{'handle'}))[4]; + } + else { + return _SetConsoleTextAttribute($self->{'handle'}, $attr); + } +} + +#=========== +sub Cursor { +#=========== + my($self, $col, $row, $size, $visi) = @_; + return undef unless ref($self); + + my $curr_row = 0; + my $curr_col = 0; + my $curr_size = 0; + my $curr_visi = 0; + my $return = 0; + my $discard = 0; + + + if (defined($col)) { + $row = -1 if not defined($row); + if ($col == -1 or $row == -1) { + ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + $col=$curr_col if $col==-1; + $row=$curr_row if $row==-1; + } + $return += _SetConsoleCursorPosition($self->{'handle'}, $col, $row); + if (defined($size) and defined($visi)) { + if ($size == -1 or $visi == -1) { + ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'}); + $size = $curr_size if $size == -1; + $visi = $curr_visi if $visi == -1; + } + $size = 1 if $size < 1; + $size = 99 if $size > 99; + $return += _SetConsoleCursorInfo($self->{'handle'}, $size, $visi); + } + return $return; + } + else { + ($discard, $discard, $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + ($curr_size, $curr_visi) = _GetConsoleCursorInfo($self->{'handle'}); + return ($curr_col, $curr_row, $curr_size, $curr_visi); + } +} + +#========= +sub Size { +#========= + my($self, $col, $row) = @_; + return undef unless ref($self); + + if (not defined($col)) { + ($col, $row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + return ($col, $row); + } + else { + $row = -1 if not defined($row); + if ($col == -1 or $row == -1) { + ($curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + $col=$curr_col if $col==-1; + $row=$curr_row if $row==-1; + } + return _SetConsoleScreenBufferSize($self->{'handle'}, $col, $row); + } +} + +#============= +sub FillAttr { +#============= + my($self, $attr, $number, $col, $row) = @_; + return undef unless ref($self); + + $number = 1 unless $number; + + if (!defined($col) or !defined($row) or $col == -1 or $row == -1) { + ($discard, $discard, + $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + $col = $curr_col if !defined($col) or $col == -1; + $row = $curr_row if !defined($row) or $row == -1; + } + return _FillConsoleOutputAttribute($self->{'handle'}, $attr, $number, $col, $row); +} + +#============= +sub FillChar { +#============= + my($self, $char, $number, $col, $row) = @_; + return undef unless ref($self); + + if (!defined($col) or !defined($row) or $col == -1 or $row == -1) { + ($discard, $discard, + $curr_col, $curr_row) = _GetConsoleScreenBufferInfo($self->{'handle'}); + $col = $curr_col if !defined($col) or $col == -1; + $row = $curr_row if !defined($row) or $row == -1; + } + return _FillConsoleOutputCharacter($self->{'handle'}, $char, $number, $col, $row); +} + +#============ +sub InputCP { +#============ + my($self, $codepage) = @_; + $codepage = $self if (defined($self) and ref($self) ne "Win32::Console"); + if (defined($codepage)) { + return _SetConsoleCP($codepage); + } + else { + return _GetConsoleCP(); + } +} + +#============= +sub OutputCP { +#============= + my($self, $codepage) = @_; + $codepage = $self if (defined($self) and ref($self) ne "Win32::Console"); + if (defined($codepage)) { + return _SetConsoleOutputCP($codepage); + } + else { + return _GetConsoleOutputCP(); + } +} + +#====================== +sub GenerateCtrlEvent { +#====================== + my($self, $type, $pid) = @_; + $type = constant("CTRL_C_EVENT", 0) unless defined($type); + $pid = 0 unless defined($pid); + return _GenerateConsoleCtrlEvent($type, $pid); +} + +#=================== +#sub SetCtrlHandler { +#=================== +# my($name, $add) = @_; +# $add = 1 unless defined($add); +# my @nor = keys(%HandlerRoutineStack); +# if ($add == 0) { +# foreach $key (@nor) { +# delete $HandlerRoutineStack{$key}, last if $HandlerRoutineStack{$key}==$name; +# } +# $HandlerRoutineRegistered--; +# } else { +# if ($#nor == -1) { +# my $r = _SetConsoleCtrlHandler(); +# if (!$r) { +# print "WARNING: SetConsoleCtrlHandler failed...\n"; +# } +# } +# $HandlerRoutineRegistered++; +# $HandlerRoutineStack{$HandlerRoutineRegistered} = $name; +# } +#} + +#=================== +sub get_Win32_IPC_HANDLE { # So Win32::IPC can wait on a console handle +#=================== + $_[0]->{'handle'}; +} + +######################################################################## +# PRIVATE METHODS +# + +#================ +#sub CtrlHandler { +#================ +# my($ctrltype) = @_; +# my $routine; +# my $result = 0; +# CALLEM: foreach $routine (sort { $b <=> $a } keys %HandlerRoutineStack) { +# #print "CtrlHandler: calling $HandlerRoutineStack{$routine}($ctrltype)\n"; +# $result = &{"main::".$HandlerRoutineStack{$routine}}($ctrltype); +# last CALLEM if $result; +# } +# return $result; +#} + +#============ +sub DESTROY { +#============ + my($self) = @_; + _CloseHandle($self->{'handle'}); +} + +####################################################################### +# dynamically load in the Console.pll module. +# + +bootstrap Win32::Console; + +####################################################################### +# ADDITIONAL CONSTANTS EXPORTED IN THE MAIN NAMESPACE +# + +$FG_BLACK = 0; +$FG_GRAY = constant("FOREGROUND_INTENSITY",0); +$FG_BLUE = constant("FOREGROUND_BLUE",0); +$FG_LIGHTBLUE = constant("FOREGROUND_BLUE",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_RED = constant("FOREGROUND_RED",0); +$FG_LIGHTRED = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_GREEN = constant("FOREGROUND_GREEN",0); +$FG_LIGHTGREEN = constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_MAGENTA = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_BLUE",0); +$FG_LIGHTMAGENTA = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_BLUE",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_CYAN = constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_BLUE",0); +$FG_LIGHTCYAN = constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_BLUE",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_BROWN = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_GREEN",0); +$FG_YELLOW = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_INTENSITY",0); +$FG_LIGHTGRAY = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_BLUE",0); +$FG_WHITE = constant("FOREGROUND_RED",0)| + constant("FOREGROUND_GREEN",0)| + constant("FOREGROUND_BLUE",0)| + constant("FOREGROUND_INTENSITY",0); + +$BG_BLACK = 0; +$BG_GRAY = constant("BACKGROUND_INTENSITY",0); +$BG_BLUE = constant("BACKGROUND_BLUE",0); +$BG_LIGHTBLUE = constant("BACKGROUND_BLUE",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_RED = constant("BACKGROUND_RED",0); +$BG_LIGHTRED = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_GREEN = constant("BACKGROUND_GREEN",0); +$BG_LIGHTGREEN = constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_MAGENTA = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_BLUE",0); +$BG_LIGHTMAGENTA = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_BLUE",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_CYAN = constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_BLUE",0); +$BG_LIGHTCYAN = constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_BLUE",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_BROWN = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_GREEN",0); +$BG_YELLOW = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_INTENSITY",0); +$BG_LIGHTGRAY = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_BLUE",0); +$BG_WHITE = constant("BACKGROUND_RED",0)| + constant("BACKGROUND_GREEN",0)| + constant("BACKGROUND_BLUE",0)| + constant("BACKGROUND_INTENSITY",0); + +$ATTR_NORMAL = $FG_LIGHTGRAY|$BG_BLACK; +$ATTR_INVERSE = $FG_BLACK|$BG_LIGHTGRAY; + +for my $fg ($FG_BLACK, $FG_GRAY, $FG_BLUE, $FG_GREEN, + $FG_CYAN, $FG_RED, $FG_MAGENTA, $FG_BROWN, + $FG_LIGHTBLUE, $FG_LIGHTGREEN, $FG_LIGHTCYAN, + $FG_LIGHTRED, $FG_LIGHTMAGENTA, $FG_YELLOW, + $FG_LIGHTGRAY, $FG_WHITE) +{ + for my $bg ($BG_BLACK, $BG_GRAY, $BG_BLUE, $BG_GREEN, + $BG_CYAN, $BG_RED, $BG_MAGENTA, $BG_BROWN, + $BG_LIGHTBLUE, $BG_LIGHTGREEN, $BG_LIGHTCYAN, + $BG_LIGHTRED, $BG_LIGHTMAGENTA, $BG_YELLOW, + $BG_LIGHTGRAY, $BG_WHITE) + { + push(@CONSOLE_COLORS, $fg|$bg); + } +} + +# Preloaded methods go here. + +#Currently Autoloading is not implemented in Perl for win32 +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; + +__END__ + +=head1 NAME + +Win32::Console - Win32 Console and Character Mode Functions + + +=head1 DESCRIPTION + +This module implements the Win32 console and character mode +functions. They give you full control on the console input and output, +including: support of off-screen console buffers (eg. multiple screen +pages) + +=over + +=item * + +reading and writing of characters, attributes and whole portions of +the screen + +=item * + +complete processing of keyboard and mouse events + +=item * + +some very funny additional features :) + +=back + +Those functions should also make possible a port of the Unix's curses +library; if there is anyone interested (and/or willing to contribute) +to this project, e-mail me. Thank you. + + +=head1 REFERENCE + + +=head2 Methods + +=over + +=item Alloc + +Allocates a new console for the process. Returns C<undef> on errors, a +nonzero value on success. A process cannot be associated with more +than one console, so this method will fail if there is already an +allocated console. Use Free to detach the process from the console, +and then call Alloc to create a new console. See also: C<Free> + +Example: + + $CONSOLE->Alloc(); + +=item Attr [attr] + +Gets or sets the current console attribute. This attribute is used by +the Write method. + +Example: + + $attr = $CONSOLE->Attr(); + $CONSOLE->Attr($FG_YELLOW | $BG_BLUE); + +=item Close + +Closes a shortcut object. Note that it is not "strictly" required to +close the objects you created, since the Win32::Shortcut objects are +automatically closed when the program ends (or when you elsehow +destroy such an object). + +Example: + + $LINK->Close(); + +=item Cls [attr] + +Clear the console, with the specified I<attr> if given, or using +ATTR_NORMAL otherwise. + +Example: + + $CONSOLE->Cls(); + $CONSOLE->Cls($FG_WHITE | $BG_GREEN); + +=item Cursor [x, y, size, visible] + +Gets or sets cursor position and appearance. Returns C<undef> on +errors, or a 4-element list containing: I<x>, I<y>, I<size>, +I<visible>. I<x> and I<y> are the current cursor position; ... + +Example: + + ($x, $y, $size, $visible) = $CONSOLE->Cursor(); + + # Get position only + ($x, $y) = $CONSOLE->Cursor(); + + $CONSOLE->Cursor(40, 13, 50, 1); + + # Set position only + $CONSOLE->Cursor(40, 13); + + # Set size and visibility without affecting position + $CONSOLE->Cursor(-1, -1, 50, 1); + +=item Display + +Displays the specified console on the screen. Returns C<undef> on errors, +a nonzero value on success. + +Example: + + $CONSOLE->Display(); + +=item FillAttr [attribute, number, col, row] + +Fills the specified number of consecutive attributes, beginning at +I<col>, I<row>, with the value specified in I<attribute>. Returns the +number of attributes filled, or C<undef> on errors. See also: +C<FillChar>. + +Example: + + $CONSOLE->FillAttr($FG_BLACK | $BG_BLACK, 80*25, 0, 0); + +=item FillChar char, number, col, row + +Fills the specified number of consecutive characters, beginning at +I<col>, I<row>, with the character specified in I<char>. Returns the +number of characters filled, or C<undef> on errors. See also: +C<FillAttr>. + +Example: + + $CONSOLE->FillChar("X", 80*25, 0, 0); + +=item Flush + +Flushes the console input buffer. All the events in the buffer are +discarded. Returns C<undef> on errors, a nonzero value on success. + +Example: + + $CONSOLE->Flush(); + +=item Free + +Detaches the process from the console. Returns C<undef> on errors, a +nonzero value on success. See also: C<Alloc>. + +Example: + + $CONSOLE->Free(); + +=item GenerateCtrlEvent [type, processgroup] + +Sends a break signal of the specified I<type> to the specified +I<processgroup>. I<type> can be one of the following constants: + + CTRL_BREAK_EVENT + CTRL_C_EVENT + +they signal, respectively, the pressing of Control + Break and of +Control + C; if not specified, it defaults to CTRL_C_EVENT. +I<processgroup> is the pid of a process sharing the same console. If +omitted, it defaults to 0 (the current process), which is also the +only meaningful value that you can pass to this function. Returns +C<undef> on errors, a nonzero value on success. + +Example: + + # break this script now + $CONSOLE->GenerateCtrlEvent(); + +=item GetEvents + +Returns the number of unread input events in the console's input +buffer, or C<undef> on errors. See also: C<Input>, C<InputChar>, +C<PeekInput>, C<WriteInput>. + +Example: + + $events = $CONSOLE->GetEvents(); + +=item Info + +Returns an array of informations about the console (or C<undef> on +errors), which contains: + +=over + +=item * + +columns (X size) of the console buffer. + +=item * + +rows (Y size) of the console buffer. + +=item * + +current column (X position) of the cursor. + +=item * + +current row (Y position) of the cursor. + +=item * + +current attribute used for C<Write>. + +=item * + +left column (X of the starting point) of the current console window. + +=item * + +top row (Y of the starting point) of the current console window. + +=item * + +right column (X of the final point) of the current console window. + +=item * + +bottom row (Y of the final point) of the current console window. + +=item * + +maximum number of columns for the console window, given the current +buffer size, font and the screen size. + +=item * + +maximum number of rows for the console window, given the current +buffer size, font and the screen size. + +=back + +See also: C<Attr>, C<Cursor>, C<Size>, C<Window>, C<MaxWindow>. + +Example: + + @info = $CONSOLE->Info(); + print "Cursor at $info[3], $info[4].\n"; + +=item Input + +Reads an event from the input buffer. Returns a list of values, which +depending on the event's nature are: + +=over + +=item keyboard event + +The list will contain: + +=over + +=item * + +event type: 1 for keyboard + +=item * + +key down: TRUE if the key is being pressed, FALSE if the key is being released + +=item * + +repeat count: the number of times the key is being held down + +=item * + +virtual keycode: the virtual key code of the key + +=item * + +virtual scancode: the virtual scan code of the key + +=item * + +char: the ASCII code of the character (if the key is a character key, 0 otherwise) + +=item * + +control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.) + +=back + +=item mouse event + +The list will contain: + +=over + +=item * + +event type: 2 for mouse + +=item * + +mouse pos. X: X coordinate (column) of the mouse location + +=item * + +mouse pos. Y: Y coordinate (row) of the mouse location + +=item * + +button state: the mouse button(s) which are pressed + +=item * + +control key state: the state of the control keys (SHIFTs, CTRLs, ALTs, etc.) + +=item * + +event flags: the type of the mouse event + +=back + +=back + +This method will return C<undef> on errors. Note that the events +returned are depending on the input C<Mode> of the console; for example, +mouse events are not intercepted unless ENABLE_MOUSE_INPUT is +specified. See also: C<GetEvents>, C<InputChar>, C<Mode>, +C<PeekInput>, C<WriteInput>. + +Example: + + @event = $CONSOLE->Input(); + +=item InputChar number + +Reads and returns I<number> characters from the console input buffer, +or C<undef> on errors. See also: C<Input>, C<Mode>. + +Example: + + $key = $CONSOLE->InputChar(1); + +=item InputCP [codepage] + +Gets or sets the input code page used by the console. Note that this +doesn't apply to a console object, but to the standard input +console. This attribute is used by the Write method. See also: +C<OutputCP>. + +Example: + + $codepage = $CONSOLE->InputCP(); + $CONSOLE->InputCP(437); + + # you may want to use the non-instanciated form to avoid confuzion :) + $codepage = Win32::Console::InputCP(); + Win32::Console::InputCP(437); + +=item MaxWindow + +Returns the size of the largest possible console window, based on the +current font and the size of the display. The result is C<undef> on +errors, otherwise a 2-element list containing col, row. + +Example: + + ($maxCol, $maxRow) = $CONSOLE->MaxWindow(); + +=item Mode [flags] + +Gets or sets the input or output mode of a console. I<flags> can be a +combination of the following constants: + + ENABLE_LINE_INPUT + ENABLE_ECHO_INPUT + ENABLE_PROCESSED_INPUT + ENABLE_WINDOW_INPUT + ENABLE_MOUSE_INPUT + ENABLE_PROCESSED_OUTPUT + ENABLE_WRAP_AT_EOL_OUTPUT + +For more informations on the meaning of those flags, please refer to +the L<"Microsoft's Documentation">. + +Example: + + $mode = $CONSOLE->Mode(); + $CONSOLE->Mode(ENABLE_MOUSE_INPUT | ENABLE_PROCESSED_INPUT); + +=item MouseButtons + +Returns the number of the buttons on your mouse, or C<undef> on errors. + +Example: + + print "Your mouse has ", $CONSOLE->MouseButtons(), " buttons.\n"; + +=item new Win32::Console standard_handle + +=item new Win32::Console [accessmode, sharemode] + +Creates a new console object. The first form creates a handle to a +standard channel, I<standard_handle> can be one of the following: + + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + STD_INPUT_HANDLE + +The second form, instead, creates a console screen buffer in memory, +which you can access for reading and writing as a normal console, and +then redirect on the standard output (the screen) with C<Display>. In +this case, you can specify one or both of the following values for +I<accessmode>: + + GENERIC_READ + GENERIC_WRITE + +which are the permissions you will have on the created buffer, and one +or both of the following values for I<sharemode>: + + FILE_SHARE_READ + FILE_SHARE_WRITE + +which affect the way the console can be shared. If you don't specify +any of those parameters, all 4 flags will be used. + +Example: + + $STDOUT = new Win32::Console(STD_OUTPUT_HANDLE); + $STDERR = new Win32::Console(STD_ERROR_HANDLE); + $STDIN = new Win32::Console(STD_INPUT_HANDLE); + + $BUFFER = new Win32::Console(); + $BUFFER = new Win32::Console(GENERIC_READ | GENERIC_WRITE); + +=item OutputCP [codepage] + +Gets or sets the output code page used by the console. Note that this +doesn't apply to a console object, but to the standard output console. +See also: C<InputCP>. + +Example: + + $codepage = $CONSOLE->OutputCP(); + $CONSOLE->OutputCP(437); + + # you may want to use the non-instanciated form to avoid confuzion :) + $codepage = Win32::Console::OutputCP(); + Win32::Console::OutputCP(437); + +=item PeekInput + +Does exactly the same as C<Input>, except that the event read is not +removed from the input buffer. See also: C<GetEvents>, C<Input>, +C<InputChar>, C<Mode>, C<WriteInput>. + +Example: + + @event = $CONSOLE->PeekInput(); + +=item ReadAttr [number, col, row] + +Reads the specified I<number> of consecutive attributes, beginning at +I<col>, I<row>, from the console. Returns the attributes read (a +variable containing one character for each attribute), or C<undef> on +errors. You can then pass the returned variable to C<WriteAttr> to +restore the saved attributes on screen. See also: C<ReadChar>, +C<ReadRect>. + +Example: + + $colors = $CONSOLE->ReadAttr(80*25, 0, 0); + +=item ReadChar [number, col, row] + +Reads the specified I<number> of consecutive characters, beginning at +I<col>, I<row>, from the console. Returns a string containing the +characters read, or C<undef> on errors. You can then pass the +returned variable to C<WriteChar> to restore the saved characters on +screen. See also: C<ReadAttr>, C<ReadRect>. + +Example: + + $chars = $CONSOLE->ReadChar(80*25, 0, 0); + +=item ReadRect left, top, right, bottom + +Reads the content (characters and attributes) of the rectangle +specified by I<left>, I<top>, I<right>, I<bottom> from the console. +Returns a string containing the rectangle read, or C<undef> on errors. +You can then pass the returned variable to C<WriteRect> to restore the +saved rectangle on screen (or on another console). See also: +C<ReadAttr>, C<ReadChar>. + +Example: + + $rect = $CONSOLE->ReadRect(0, 0, 80, 25); + +=item Scroll left, top, right, bottom, col, row, char, attr, + [cleft, ctop, cright, cbottom] + +Moves a block of data in a console buffer; the block is identified by +I<left>, I<top>, I<right>, I<bottom>, while I<row>, I<col> identify +the new location of the block. The cells left empty as a result of +the move are filled with the character I<char> and attribute I<attr>. +Optionally you can specify a clipping region with I<cleft>, I<ctop>, +I<cright>, I<cbottom>, so that the content of the console outside this +rectangle are unchanged. Returns C<undef> on errors, a nonzero value +on success. + +Example: + + # scrolls the screen 10 lines down, filling with black spaces + $CONSOLE->Scroll(0, 0, 80, 25, 0, 10, " ", $FG_BLACK | $BG_BLACK); + +=item Select standard_handle + +Redirects a standard handle to the specified console. +I<standard_handle> can have one of the following values: + + STD_INPUT_HANDLE + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + +Returns C<undef> on errors, a nonzero value on success. + +Example: + + $CONSOLE->Select(STD_OUTPUT_HANDLE); + +=item SetIcon icon_file + +Sets the icon in the title bar of the current console window. + +Example: + + $CONSOLE->SetIcon("C:/My/Path/To/Custom.ico"); + +=item Size [col, row] + +Gets or sets the console buffer size. + +Example: + + ($x, $y) = $CONSOLE->Size(); + $CONSOLE->Size(80, 25); + +=item Title [title] + +Gets or sets the title of the current console window. + +Example: + + $title = $CONSOLE->Title(); + $CONSOLE->Title("This is a title"); + +=item Window [flag, left, top, right, bottom] + +Gets or sets the current console window size. If called without +arguments, returns a 4-element list containing the current window +coordinates in the form of I<left>, I<top>, I<right>, I<bottom>. To +set the window size, you have to specify an additional I<flag> +parameter: if it is 0 (zero), coordinates are considered relative to +the current coordinates; if it is non-zero, coordinates are absolute. + +Example: + + ($left, $top, $right, $bottom) = $CONSOLE->Window(); + $CONSOLE->Window(1, 0, 0, 80, 50); + +=item Write string + +Writes I<string> on the console, using the current attribute, that you +can set with C<Attr>, and advancing the cursor as needed. This isn't +so different from Perl's "print" statement. Returns the number of +characters written or C<undef> on errors. See also: C<WriteAttr>, +C<WriteChar>, C<WriteRect>. + +Example: + + $CONSOLE->Write("Hello, world!"); + +=item WriteAttr attrs, col, row + +Writes the attributes in the string I<attrs>, beginning at I<col>, +I<row>, without affecting the characters that are on screen. The +string attrs can be the result of a C<ReadAttr> function, or you can +build your own attribute string; in this case, keep in mind that every +attribute is treated as a character, not a number (see example). +Returns the number of attributes written or C<undef> on errors. See +also: C<Write>, C<WriteChar>, C<WriteRect>. + +Example: + + $CONSOLE->WriteAttr($attrs, 0, 0); + + # note the use of chr()... + $attrs = chr($FG_BLACK | $BG_WHITE) x 80; + $CONSOLE->WriteAttr($attrs, 0, 0); + +=item WriteChar chars, col, row + +Writes the characters in the string I<attr>, beginning at I<col>, I<row>, +without affecting the attributes that are on screen. The string I<chars> +can be the result of a C<ReadChar> function, or a normal string. Returns +the number of characters written or C<undef> on errors. See also: +C<Write>, C<WriteAttr>, C<WriteRect>. + +Example: + + $CONSOLE->WriteChar("Hello, worlds!", 0, 0); + +=item WriteInput (event) + +Pushes data in the console input buffer. I<(event)> is a list of values, +for more information see C<Input>. The string chars can be the result of +a C<ReadChar> function, or a normal string. Returns the number of +characters written or C<undef> on errors. See also: C<Write>, +C<WriteAttr>, C<WriteRect>. + +Example: + + $CONSOLE->WriteInput(@event); + +=item WriteRect rect, left, top, right, bottom + +Writes a rectangle of characters and attributes (contained in I<rect>) +on the console at the coordinates specified by I<left>, I<top>, +I<right>, I<bottom>. I<rect> can be the result of a C<ReadRect> +function. Returns C<undef> on errors, otherwise a 4-element list +containing the coordinates of the affected rectangle, in the format +I<left>, I<top>, I<right>, I<bottom>. See also: C<Write>, +C<WriteAttr>, C<WriteChar>. + +Example: + + $CONSOLE->WriteRect($rect, 0, 0, 80, 25); + +=back + + +=head2 Constants + +The following constants are exported in the main namespace of your +script using Win32::Console: + + BACKGROUND_BLUE + BACKGROUND_GREEN + BACKGROUND_INTENSITY + BACKGROUND_RED + CAPSLOCK_ON + CONSOLE_TEXTMODE_BUFFER + ENABLE_ECHO_INPUT + ENABLE_LINE_INPUT + ENABLE_MOUSE_INPUT + ENABLE_PROCESSED_INPUT + ENABLE_PROCESSED_OUTPUT + ENABLE_WINDOW_INPUT + ENABLE_WRAP_AT_EOL_OUTPUT + ENHANCED_KEY + FILE_SHARE_READ + FILE_SHARE_WRITE + FOREGROUND_BLUE + FOREGROUND_GREEN + FOREGROUND_INTENSITY + FOREGROUND_RED + LEFT_ALT_PRESSED + LEFT_CTRL_PRESSED + NUMLOCK_ON + GENERIC_READ + GENERIC_WRITE + RIGHT_ALT_PRESSED + RIGHT_CTRL_PRESSED + SCROLLLOCK_ON + SHIFT_PRESSED + STD_INPUT_HANDLE + STD_OUTPUT_HANDLE + STD_ERROR_HANDLE + +Additionally, the following variables can be used: + + $FG_BLACK + $FG_GRAY + $FG_BLUE + $FG_LIGHTBLUE + $FG_RED + $FG_LIGHTRED + $FG_GREEN + $FG_LIGHTGREEN + $FG_MAGENTA + $FG_LIGHTMAGENTA + $FG_CYAN + $FG_LIGHTCYAN + $FG_BROWN + $FG_YELLOW + $FG_LIGHTGRAY + $FG_WHITE + + $BG_BLACK + $BG_GRAY + $BG_BLUE + $BG_LIGHTBLUE + $BG_RED + $BG_LIGHTRED + $BG_GREEN + $BG_LIGHTGREEN + $BG_MAGENTA + $BG_LIGHTMAGENTA + $BG_CYAN + $BG_LIGHTCYAN + $BG_BROWN + $BG_YELLOW + $BG_LIGHTGRAY + $BG_WHITE + + $ATTR_NORMAL + $ATTR_INVERSE + +ATTR_NORMAL is set to gray foreground on black background (DOS's +standard colors). + + +=head2 Microsoft's Documentation + +Documentation for the Win32 Console and Character mode Functions can +be found on Microsoft's site at this URL: + +http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar.htm + +A reference of the available functions is at: + +http://www.microsoft.com/msdn/sdk/platforms/doc/sdk/win32/sys/src/conchar_34.htm + + +=head1 AUTHOR + +Aldo Calpini <a.calpini@romagiubileo.it> + +=head1 CREDITS + +Thanks to: Jesse Dougherty, Dave Roth, ActiveWare, and the +Perl-Win32-Users community. + +=head1 DISCLAIMER + +This program is FREE; you can redistribute, modify, disassemble, or +even reverse engineer this software at your will. Keep in mind, +however, that NOTHING IS GUARANTEED to work and everything you do is +AT YOUR OWN RISK - I will not take responsibility for any damage, loss +of money and/or health that may arise from the use of this program! + +This is distributed under the terms of Larry Wall's Artistic License. diff --git a/Master/tlpkg/installer/perllib/Win32/Event.pm b/Master/tlpkg/installer/perllib/Win32/Event.pm new file mode 100644 index 00000000000..5faddf5a76e --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Event.pm @@ -0,0 +1,104 @@ +#--------------------------------------------------------------------- +package Win32::Event; +# +# Copyright 1998 Christopher J. Madsen +# +# Author: Christopher J. Madsen <cjm@pobox.com> +# Created: 3 Feb 1998 from the ActiveWare version +# Version: 1.00 (6-Feb-1998) +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# Use Win32 event objects for synchronization +#--------------------------------------------------------------------- + +$VERSION = '1.01'; + +use Win32::IPC 1.00 '/./'; # Import everything +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader Win32::IPC); +@EXPORT_OK = qw( + wait_all wait_any INFINITE +); + +bootstrap Win32::Event; + +1; +__END__ + +=head1 NAME + +Win32::Event - Use Win32 event objects from Perl + +=head1 SYNOPSIS + + use Win32::Event; + + $event = Win32::Event->new($manual,$initial,$name); + $event->wait(); + +=head1 DESCRIPTION + +This module allows access to the Win32 event objects. The C<wait> +method and C<wait_all> & C<wait_any> functions are inherited from the +L<"Win32::IPC"> module. + +=head2 Methods + +=over 4 + +=item $event = Win32::Event->new([$manual, [$initial, [$name]]]) + +Constructor for a new event object. If C<$manual> is true, you must +manually reset the event after it is signalled (the default is false). +If C<$initial> is true, the initial state of the object is signalled +(default false). If C<$name> is omitted, creates an unnamed event +object. + +If C<$name> signifies an existing event object, then C<$manual> and +C<$initial> are ignored and the object is opened. If this happens, +C<$^E> will be set to 183 (ERROR_ALREADY_EXISTS). + +=item $event = Win32::Event->open($name) + +Constructor for opening an existing event object. + +=item $event->pulse + +Signal the C<$event> and then immediately reset it. If C<$event> is a +manual-reset event, releases all threads currently blocking on it. If +it's an auto-reset event, releases just one thread. + +If no threads are waiting, just resets the event. + +=item $event->reset + +Reset the C<$event> to nonsignalled. + +=item $event->set + +Set the C<$event> to signalled. + +=item $event->wait([$timeout]) + +Wait for C<$event> to be signalled. See L<"Win32::IPC">. + +=back + +=head1 AUTHOR + +Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> + +=cut + +# Local Variables: +# tmtrack-file-task: "Win32::Event" +# End: diff --git a/Master/tlpkg/installer/perllib/Win32/EventLog.pm b/Master/tlpkg/installer/perllib/Win32/EventLog.pm new file mode 100644 index 00000000000..141821556e7 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/EventLog.pm @@ -0,0 +1,471 @@ +# +# EventLog.pm +# +# Creates an object oriented interface to the Windows NT Evenlog +# Written by Jesse Dougherty +# + +package Win32::EventLog; + +use strict; +use vars qw($VERSION $AUTOLOAD @ISA @EXPORT $GetMessageText); +$VERSION = '0.074'; + +require Exporter; +require DynaLoader; + +die "The Win32::Eventlog module works only on Windows NT" + unless Win32::IsWinNT(); + +@ISA= qw(Exporter DynaLoader); +@EXPORT = qw( + EVENTLOG_AUDIT_FAILURE + EVENTLOG_AUDIT_SUCCESS + EVENTLOG_BACKWARDS_READ + EVENTLOG_END_ALL_PAIRED_EVENTS + EVENTLOG_END_PAIRED_EVENT + EVENTLOG_ERROR_TYPE + EVENTLOG_FORWARDS_READ + EVENTLOG_INFORMATION_TYPE + EVENTLOG_PAIRED_EVENT_ACTIVE + EVENTLOG_PAIRED_EVENT_INACTIVE + EVENTLOG_SEEK_READ + EVENTLOG_SEQUENTIAL_READ + EVENTLOG_START_PAIRED_EVENT + EVENTLOG_SUCCESS + EVENTLOG_WARNING_TYPE +); + +$GetMessageText=0; + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + # reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($!) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + my ($pack,$file,$line) = caller; + die "Unknown Win32::EventLog macro $constname, at $file line $line.\n"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +# +# new() +# +# Win32::EventLog->new("source name", "ServerName"); +# +sub new { + die "usage: PACKAGE->new(SOURCENAME[, SERVERNAME])\n" unless @_ > 1; + my ($class,$source,$server) = @_; + my $handle; + + # Create new handle + if ($source !~ /\\/) { + OpenEventLog($handle, $server, $source); + } + else { + OpenBackupEventLog($handle, $server, $source); + } + return bless {handle => $handle, + Source => $source, + Computer => $server} => $class; +} + +sub DESTROY {shift->Close} + +# +# Open (the rather braindead old way) +# A variable initialized to empty must be supplied as the first +# arg, followed by whatever new() takes +# +sub Open { + $_[0] = Win32::EventLog->new($_[1],$_[2]); +} + +sub OpenBackup { + my ($class,$source,$server) = @_; + OpenBackupEventLog(my $handle, $server, $source); + return bless {handle => $handle, + Source => $source, + Computer => $server} => $class; +} + +sub Backup { + die " usage: OBJECT->Backup(FILENAME)\n" unless @_ == 2; + my ($self,$file) = @_; + return BackupEventLog($self->{handle}, $file); +} + +sub Close { + my $self = shift; + CloseEventLog($self->{handle}); + $self->{handle} = 0; +} + +# Read +# Note: the EventInfo arguement requires a hash reference. +sub Read { + my $self = shift; + + die "usage: OBJECT->Read(FLAGS, RECORDOFFSET, HASHREF)\n" unless @_ == 3; + + my ($readflags,$recordoffset) = @_; + # The following is stolen shamelessly from Wyt's tests for the registry. + my $result = ReadEventLog($self->{handle}, $readflags, $recordoffset, + my $header, my $source, my $computer, my $sid, + my $data, my $strings); + my ($length, + $reserved, + $recordnumber, + $timegenerated, + $timewritten, + $eventid, + $eventtype, + $numstrings, + $eventcategory, + $reservedflags, + $closingrecordnumber, + $stringoffset, + $usersidlength, + $usersidoffset, + $datalength, + $dataoffset) = unpack('l6s4l6', $header); + + # make a hash out of the values returned from ReadEventLog. + my %h = ( Source => $source, + Computer => $computer, + Length => $datalength, + Category => $eventcategory, + RecordNumber => $recordnumber, + TimeGenerated => $timegenerated, + Timewritten => $timewritten, + EventID => $eventid, + EventType => $eventtype, + ClosingRecordNumber => $closingrecordnumber, + User => $sid, + Strings => $strings, + Data => $data, + ); + + # get the text message here + if ($result and $GetMessageText) { + GetEventLogText($source, $eventid, $strings, $numstrings, my $message); + $h{Message} = $message; + } + + if (ref($_[2]) eq 'HASH') { + %{$_[2]} = %h; # this needed for Read(...,\%foo) case + } + else { + $_[2] = \%h; + } + return $result; +} + +sub GetMessageText { + my $self = shift; + local $^W; + GetEventLogText($self->{Source}, + $self->{EventID}, + $self->{Strings}, + $self->{Strings} =~ tr/\0/\0/, + my $message); + + $self->{Message} = $message; + return $message; +} + +sub Report { + die "usage: OBJECT->Report( HASHREF )\n" unless @_ == 2; + my ($self,$EventInfo) = @_; + + die "Win32::EventLog::Report requires a hash reference as arg 2\n" + unless ref($EventInfo) eq "HASH"; + + my $computer = $EventInfo->{Computer} ? $EventInfo->{Computer} + : $self->{Computer}; + my $source = exists($EventInfo->{Source}) ? $EventInfo->{Source} + : $self->{Source}; + + return WriteEventLog($computer, $source, $EventInfo->{EventType}, + $EventInfo->{Category}, $EventInfo->{EventID}, 0, + $EventInfo->{Data}, split(/\0/, $EventInfo->{Strings})); + +} + +sub GetOldest { + my $self = shift; + die "usage: OBJECT->GetOldest( SCALAREF )\n" unless @_ == 1; + return GetOldestEventLogRecord($self->{handle},$_[0]); +} + +sub GetNumber { + my $self = shift; + die "usage: OBJECT->GetNumber( SCALARREF )\n" unless @_ == 1; + return GetNumberOfEventLogRecords($self->{handle}, $_[0]); +} + +sub Clear { + my ($self,$file) = @_; + die "usage: OBJECT->Clear( FILENAME )\n" unless @_ == 2; + return ClearEventLog($self->{handle}, $file); +} + +bootstrap Win32::EventLog; + +1; +__END__ + +=head1 NAME + +Win32::EventLog - Process Win32 Event Logs from Perl + +=head1 SYNOPSIS + + use Win32::EventLog + $handle=Win32::EventLog->new("Application"); + +=head1 DESCRIPTION + +This module implements most of the functionality available from the +Win32 API for accessing and manipulating Win32 Event Logs. The access +to the EventLog routines is divided into those that relate to an +EventLog object and its associated methods and those that relate other +EventLog tasks (like adding an EventLog record). + +=head1 The EventLog Object and its Methods + +The following methods are available to open, read, close and backup +EventLogs. + +=over 4 + +=item Win32::EventLog->new(SOURCENAME [,SERVERNAME]); + +The new() method creates a new EventLog object and returns a handle +to it. This hande is then used to call the methods below. + +The method is overloaded in that if the supplied SOURCENAME +argument contains one or more literal '\' characters (an illegal +character in a SOURCENAME), it assumes that you are trying to open +a backup eventlog and uses SOURCENAME as the backup eventlog to +open. Note that when opening a backup eventlog, the SERVERNAME +argument is ignored (as it is in the underlying Win32 API). For +EventLogs on remote machines, the SOURCENAME parameter must +therefore be specified as a UNC path. + +=item $handle->Backup(FILENAME); + +The Backup() method backs up the EventLog represented by $handle. It +takes a single arguemt, FILENAME. When $handle represents an +EventLog on a remote machine, FILENAME is filename on the remote +machine and cannot be a UNC path (i.e you must use F<C:\TEMP\App.EVT>). +The method will fail if the log file already exists. + +=item $handle->Read(FLAGS, OFFSET, HASHREF); + +The Read() method read an EventLog entry from the EventLog represented +by $handle. + +=item $handle->Close(); + +The Close() method closes the EventLog represented by $handle. After +Close() has been called, any further attempt to use the EventLog +represented by $handle will fail. + +=item $handle->GetOldest(SCALARREF); + +The GetOldest() method number of the the oldest EventLog record in +the EventLog represented by $handle. This is required to correctly +compute the OFFSET required by the Read() method. + +=item $handle->GetNumber(SCALARREF); + +The GetNumber() method returns the number of EventLog records in +the EventLog represented by $handle. The number of the most recent +record in the EventLog is therefore computed by + + $handle->GetOldest($oldest); + $handle->GetNumber($lastRec); + $lastRecOffset=$oldest+$lastRec; + +=item $handle->Clear(FILENAME); + +The Clear() method clears the EventLog represented by $handle. If +you provide a non-null FILENAME, the EventLog will be backed up +into FILENAME before the EventLog is cleared. The method will fail +if FILENAME is specified and the file refered to exists. Note also +that FILENAME specifies a file local to the machine on which the +EventLog resides and cannot be specified as a UNC name. + +=item $handle->Report(HASHREF); + +The Report() method generates an EventLog entry. The HASHREF should +contain the following keys: + +=over 4 + +=item C<Computer> + +The C<Computer> field specfies which computer you want the EventLog +entry recorded. If this key doesn't exist, the server name used to +create the $handle is used. + +=item C<Source> + +The C<Source> field specifies the source that generated the EventLog +entry. If this key doesn't exist, the source name used to create the +$handle is used. + +=item C<EventType> + +The C<EventType> field should be one of the constants + +=over 4 + +=item C<EVENTLOG_ERROR_TYPE> + +An Error event is being logged. + +=item C<EVENTLOG_WARNING_TYPE> + +A Warning event is being logged. + +=item C<EVENTLOG_INFORMATION_TYPE> + +An Information event is being logged. + +=item C<EVENTLOG_AUDIT_SUCCESS> + +A Success Audit event is being logged (typically in the Security +EventLog). + +=item C<EVENTLOG_AUDIT_FAILURE> + +A Failure Audit event is being logged (typically in the Security +EventLog). + +=back + +These constants are exported into the main namespace by default. + +=item C<Category> + +The C<Category> field can have any value you want. It is specific to +the particular Source. + +=item C<EventID> + +The C<EventID> field should contain the ID of the message that this +event pertains too. This assumes that you have an associated message +file (indirectly referenced by the field C<Source>). + +=item C<Data> + +The C<Data> field contains raw data associated with this event. + +=item C<Strings> + +The C<Strings> field contains the single string that itself contains +NUL terminated sub-strings. This are used with the EventID to generate +the message as seen from (for example) the Event Viewer application. + +=back + +=back + +=head1 Other Win32::EventLog functions. + +The following functions are part of the Win32::EventLog package but +are not callable from an EventLog object. + +=over 4 + +=item GetMessageText(HASHREF); + +The GetMessageText() function assumes that HASHREF was obtained by +a call to C<$handle-E<gt>Read()>. It returns the formatted string that +represents the fully resolved text of the EventLog message (such as +would be seen in the Windows NT Event Viewer). For convenience, the +key 'Message' in the supplied HASHREF is also set to the return value +of this function. + +If you set the variable $Win32::EventLog::GetMessageText to 1 then +each call to C<$handle-E<gt>Read()> will call this function automatically. + +=back + +=head1 Example 1 + +The following example illustrates the way in which the EventLog module +can be used. It opens the System EventLog and reads through it from +oldest to newest records. For each record from the B<Source> EventLog +it extracts the full text of the Entry and prints the EventLog message +text out. + + use Win32::EventLog; + + $handle=Win32::EventLog->new("System", $ENV{ComputerName}) + or die "Can't open Application EventLog\n"; + $handle->GetNumber($recs) + or die "Can't get number of EventLog records\n"; + $handle->GetOldest($base) + or die "Can't get number of oldest EventLog record\n"; + + while ($x < $recs) { + $handle->Read(EVENTLOG_FORWARDS_READ|EVENTLOG_SEEK_READ, + $base+$x, + $hashRef) + or die "Can't read EventLog entry #$x\n"; + if ($hashRef->{Source} eq "EventLog") { + Win32::EventLog::GetMessageText($hashRef); + print "Entry $x: $hashRef->{Message}\n"; + } + $x++; + } + +=head1 Example 2 + +To backup and clear the EventLogs on a remote machine, do the following :- + + use Win32::EventLog; + + $myServer="\\\\my-server"; # your servername here. + my($date)=join("-", ((split(/\s+/, scalar(localtime)))[0,1,2,4])); + my($dest); + + for my $eventLog ("Application", "System", "Security") { + $handle=Win32::EventLog->new($eventLog, $myServer) + or die "Can't open Application EventLog on $myServer\n"; + + $dest="C:\\BackupEventLogs\\$eventLog\\$date.evt"; + $handle->Backup($dest) + or warn "Could not backup and clear the $eventLog EventLog on $myServer ($^E)\n"; + + $handle->Close; + } + +Note that only the Clear method is required. Note also that if the +file $dest exists, the function will fail. + +=head1 BUGS + +None currently known. + +The test script for 'make test' should be re-written to use the +EventLog object. + +=head1 AUTHOR + +Original code by Jesse Dougherty for HiP Communications. Additional +fixes and updates attributed to Martin Pauley +<martin.pauley@ulsterbank.ltd.uk>) and Bret Giddings (bret@essex.ac.uk). diff --git a/Master/tlpkg/installer/perllib/Win32/File.pm b/Master/tlpkg/installer/perllib/Win32/File.pm new file mode 100644 index 00000000000..d67a25448c8 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/File.pm @@ -0,0 +1,118 @@ +package Win32::File; + +# +# File.pm +# Written by Douglas_Lankshear@ActiveWare.com +# +# subsequent hacks: +# Gurusamy Sarathy +# + +$VERSION = '0.05'; + +require Exporter; +require DynaLoader; + +@ISA= qw( Exporter DynaLoader ); +@EXPORT = qw( + ARCHIVE + COMPRESSED + DIRECTORY + HIDDEN + NORMAL + OFFLINE + READONLY + SYSTEM + TEMPORARY + ); +@EXPORT_OK = qw(GetAttributes SetAttributes); + +=head1 NAME + +Win32::File - manage file attributes in perl + +=head1 SYNOPSIS + + use Win32::File; + +=head1 DESCRIPTION + +This module offers the retrieval and setting of file attributes. + +=head1 Functions + +=head2 NOTE + +All of the functions return FALSE (0) if they fail, unless otherwise noted. +The function names are exported into the caller's namespace by request. + +=over 10 + +=item GetAttributes(filename, returnedAttributes) + +Gets the attributes of a file or directory. returnedAttributes will be set +to the OR-ed combination of the filename attributes. + +=item SetAttributes(filename, newAttributes) + +Sets the attributes of a file or directory. newAttributes must be an OR-ed +combination of the attributes. + +=back + +=head1 Constants + +The following constants are exported by default. + +=over 10 + +=item ARCHIVE + +=item COMPRESSED + +=item DIRECTORY + +=item HIDDEN + +=item NORMAL + +=item OFFLINE + +=item READONLY + +=item SYSTEM + +=item TEMPORARY + +=back + +=cut + +sub AUTOLOAD +{ + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname); + if($! != 0) + { + if($! =~ /Invalid/) + { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else + { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::File macro $constname, used in $file at line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::File; + +1; +__END__ diff --git a/Master/tlpkg/installer/perllib/Win32/FileSecurity.pm b/Master/tlpkg/installer/perllib/Win32/FileSecurity.pm new file mode 100644 index 00000000000..6c6e5865336 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/FileSecurity.pm @@ -0,0 +1,308 @@ +package Win32::FileSecurity; + +# +# FileSecurity.pm +# By Monte Mitzelfelt, monte@conchas.nm.org +# Larry Wall's Artistic License applies to all related Perl +# and C code for this module +# Thanks to the guys at ActiveWare! +# ver 0.67 ALPHA 1997.07.07 +# + +require Exporter; +require DynaLoader; +use Carp ; + +$VERSION = '1.04'; + +require Win32 unless defined &Win32::IsWinNT; +croak "The Win32::FileSecurity module works only on Windows NT" unless Win32::IsWinNT(); + +@ISA= qw( Exporter DynaLoader ); + +require Exporter ; +require DynaLoader ; + +@ISA = qw(Exporter DynaLoader) ; +@EXPORT_OK = qw( + Get + Set + EnumerateRights + MakeMask + DELETE + READ_CONTROL + WRITE_DAC + WRITE_OWNER + SYNCHRONIZE + STANDARD_RIGHTS_REQUIRED + STANDARD_RIGHTS_READ + STANDARD_RIGHTS_WRITE + STANDARD_RIGHTS_EXECUTE + STANDARD_RIGHTS_ALL + SPECIFIC_RIGHTS_ALL + ACCESS_SYSTEM_SECURITY + MAXIMUM_ALLOWED + GENERIC_READ + GENERIC_WRITE + GENERIC_EXECUTE + GENERIC_ALL + F + FULL + R + READ + C + CHANGE + A + ADD + ) ; + +sub AUTOLOAD { + local($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + $val = constant($constname); + if($! != 0) { + if($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::FileSecurity macro " + ."$constname, used in $file at line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::FileSecurity; + +1; + +__END__ + +=head1 NAME + +Win32::FileSecurity - manage FileSecurity Discretionary Access Control Lists in perl + +=head1 SYNOPSIS + + use Win32::FileSecurity; + +=head1 DESCRIPTION + +This module offers control over the administration of system FileSecurity DACLs. +You may want to use Get and EnumerateRights to get an idea of what mask values +correspond to what rights as viewed from File Manager. + +=head1 CONSTANTS + + DELETE, READ_CONTROL, WRITE_DAC, WRITE_OWNER, + SYNCHRONIZE, STANDARD_RIGHTS_REQUIRED, + STANDARD_RIGHTS_READ, STANDARD_RIGHTS_WRITE, + STANDARD_RIGHTS_EXECUTE, STANDARD_RIGHTS_ALL, + SPECIFIC_RIGHTS_ALL, ACCESS_SYSTEM_SECURITY, + MAXIMUM_ALLOWED, GENERIC_READ, GENERIC_WRITE, + GENERIC_EXECUTE, GENERIC_ALL, F, FULL, R, READ, + C, CHANGE + +=head1 FUNCTIONS + +=head2 NOTE: + +All of the functions return false if they fail, unless otherwise noted. +Errors returned via $! containing both Win32 GetLastError() and a text message +indicating Win32 function that failed. + +=over 10 + +=item constant( $name, $set ) + +Stores the value of named constant $name into $set. +Same as C<$set = Win32::FileSecurity::NAME_OF_CONSTANT();>. + +=item Get( $filename, \%permisshash ) + +Gets the DACLs of a file or directory. + +=item Set( $filename, \%permisshash ) + +Sets the DACL for a file or directory. + +=item EnumerateRights( $mask, \@rightslist ) + +Turns the bitmask in $mask into a list of strings in @rightslist. + +=item MakeMask( qw( DELETE READ_CONTROL ) ) + +Takes a list of strings representing constants and returns a bitmasked +integer value. + +=back + +=head2 %permisshash + +Entries take the form $permisshash{USERNAME} = $mask ; + +=head1 EXAMPLE1 + + # Gets the rights for all files listed on the command line. + use Win32::FileSecurity qw(Get EnumerateRights); + + foreach( @ARGV ) { + next unless -e $_ ; + if ( Get( $_, \%hash ) ) { + while( ($name, $mask) = each %hash ) { + print "$name:\n\t"; + EnumerateRights( $mask, \@happy ) ; + print join( "\n\t", @happy ), "\n"; + } + } + else { + print( "Error #", int( $! ), ": $!" ) ; + } + } + +=head1 EXAMPLE2 + + # Gets existing DACL and modifies Administrator rights + use Win32::FileSecurity qw(MakeMask Get Set); + + # These masks show up as Full Control in File Manager + $file = MakeMask( qw( FULL ) ); + + $dir = MakeMask( qw( + FULL + GENERIC_ALL + ) ); + + foreach( @ARGV ) { + s/\\$//; + next unless -e; + Get( $_, \%hash ) ; + $hash{Administrator} = ( -d ) ? $dir : $file ; + Set( $_, \%hash ) ; + } + +=head1 COMMON MASKS FROM CACLS AND WINFILE + +=head2 READ + + MakeMask( qw( FULL ) ); # for files + MakeMask( qw( READ GENERIC_READ GENERIC_EXECUTE ) ); # for directories + +=head2 CHANGE + + MakeMask( qw( CHANGE ) ); # for files + MakeMask( qw( CHANGE GENERIC_WRITE GENERIC_READ GENERIC_EXECUTE ) ); # for directories + +=head2 ADD & READ + + MakeMask( qw( ADD GENERIC_READ GENERIC_EXECUTE ) ); # for directories only! + +=head2 FULL + + MakeMask( qw( FULL ) ); # for files + MakeMask( qw( FULL GENERIC_ALL ) ); # for directories + +=head1 RESOURCES + +From Microsoft: check_sd + http://premium.microsoft.com/download/msdn/samples/2760.exe + +(thanks to Guert Schimmel at Sybase for turning me on to this one) + +=head1 VERSION + +1.03 ALPHA 97-12-14 + +=head1 REVISION NOTES + +=over 10 + +=item 1.03 ALPHA 1998.01.11 + +Imported diffs from 0.67 (parent) version + +=item 1.02 ALPHA 1997.12.14 + +Pod fixes, @EXPORT list additions <gsar@activestate.com> + +Fix unitialized vars on unknown ACLs <jmk@exc.bybyte.de> + +=item 1.01 ALPHA 1997.04.25 + +CORE Win32 version imported from 0.66 <gsar@activestate.com> + +=item 0.67 ALPHA 1997.07.07 + +Kludged bug in mapping bits to separate ACE's. Notably, this screwed +up CHANGE access by leaving out a delete bit in the +C<INHERIT_ONLY_ACE | OBJECT_INHERIT_ACE> Access Control Entry. + +May need to rethink... + +=item 0.66 ALPHA 1997.03.13 + +Fixed bug in memory allocation check + +=item 0.65 ALPHA 1997.02.25 + +Tested with 5.003 build 303 + +Added ISA exporter, and @EXPORT_OK + +Added F, FULL, R, READ, C, CHANGE as composite pre-built mask names. + +Added server\ to keys returned in hash from Get + +Made constants and MakeMask case insensitive (I don't know why I did that) + +Fixed mask comparison in ListDacl and Enumerate Rights from simple & mask +to exact bit match ! ( ( x & y ) ^ x ) makes sure all bits in x +are set in y + +Fixed some "wild" pointers + +=item 0.60 ALPHA 1996.07.31 + +Now suitable for file and directory permissions + +Included ListDacl.exe in bundle for debugging + +Added "intuitive" inheritance for directories, basically functions like FM +triggered by presence of GENERIC_ rights this may need to change + +see EXAMPLE2 + +Changed from AddAccessAllowedAce to AddAce for control over inheritance + +=item 0.51 ALPHA 1996.07.20 + +Fixed memory allocation bug + +=item 0.50 ALPHA 1996.07.29 + +Base functionality + +Using AddAccessAllowedAce + +Suitable for file permissions + +=back + +=head1 KNOWN ISSUES / BUGS + +=over 10 + +=item 1 + +May not work on remote drives. + +=item 2 + +Errors croak, don't return via $! as documented. + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/IPC.pm b/Master/tlpkg/installer/perllib/Win32/IPC.pm new file mode 100644 index 00000000000..c97279b24c5 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/IPC.pm @@ -0,0 +1,195 @@ +#--------------------------------------------------------------------- +package Win32::IPC; +# +# Copyright 1998 Christopher J. Madsen +# +# Created: 3 Feb 1998 from the ActiveWare version +# (c) 1995 Microsoft Corporation. All rights reserved. +# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com +# +# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com> +# +# Author: Christopher J. Madsen <cjm@pobox.com> +# Version: 1.03 (11-Jul-2003) +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# Base class for Win32 synchronization objects +#--------------------------------------------------------------------- + +$VERSION = '1.03'; + +require Exporter; +require DynaLoader; +use strict; +use vars qw($AUTOLOAD $VERSION @ISA @EXPORT @EXPORT_OK); + +@ISA = qw(Exporter DynaLoader); +@EXPORT = qw( + INFINITE + WaitForMultipleObjects +); +@EXPORT_OK = qw( + wait_any wait_all +); + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + local $! = 0; + my $val = constant($constname); + if ($! != 0) { + my ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::IPC macro $constname, used at $file line $line."; + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} # end AUTOLOAD + +bootstrap Win32::IPC; + +# How's this for cryptic? Use wait_any or wait_all! +sub WaitForMultipleObjects +{ + my $result = (($_[1] ? wait_all($_[0], $_[2]) + : wait_any($_[0], $_[2])) + ? 1 + : 0); + @{$_[0]} = (); # Bug for bug compatibility! Use wait_any or wait_all! + $result; +} # end WaitForMultipleObjects + +1; +__END__ + +=head1 NAME + +Win32::IPC - Base class for Win32 synchronization objects + +=head1 SYNOPSIS + + use Win32::Event 1.00 qw(wait_any); + #Create objects. + + wait_any(@ListOfObjects,$timeout); + +=head1 DESCRIPTION + +This module is loaded by the other Win32 synchronization modules. You +shouldn't need to load it yourself. It supplies the wait functions to +those modules. + +The synchronization modules are L<"Win32::ChangeNotify">, +L<"Win32::Event">, L<"Win32::Mutex">, & L<"Win32::Semaphore">. + +In addition, you can use C<wait_any> and C<wait_all> with +L<"Win32::Console"> and L<"Win32::Process"> objects. (However, those +modules do not export the wait functions; you must load one of the +synchronization modules (or just Win32::IPC)). + +=head2 Methods + +B<Win32::IPC> supplies one method to all synchronization objects. + +=over 4 + +=item $obj->wait([$timeout]) + +Waits for C<$obj> to become signalled. C<$timeout> is the maximum time +to wait (in milliseconds). If C<$timeout> is omitted, waits forever. +If C<$timeout> is 0, returns immediately. + +Returns: + + +1 The object is signalled + -1 The object is an abandoned mutex + 0 Timed out + undef An error occurred + +=back + +=head2 Functions + +=over 4 + +=item wait_any(@objects, [$timeout]) + +Waits for at least one of the C<@objects> to become signalled. +C<$timeout> is the maximum time to wait (in milliseconds). If +C<$timeout> is omitted, waits forever. If C<$timeout> is 0, returns +immediately. + +The return value indicates which object ended the wait: + + +N $object[N-1] is signalled + -N $object[N-1] is an abandoned mutex + 0 Timed out + undef An error occurred + +If more than one object became signalled, the one with the lowest +index is used. + +=item wait_all(@objects, [$timeout]) + +This is the same as C<wait_any>, but it waits for all the C<@objects> +to become signalled. The return value indicates the last object to +become signalled, and is negative if at least one of the C<@objects> +is an abandoned mutex. + +=back + +=head2 Deprecated Functions and Methods + +B<Win32::IPC> still supports the ActiveWare syntax, but its use is +deprecated. + +=over 4 + +=item INFINITE + +Constant value for an infinite timeout. Omit the C<$timeout> argument +instead. + +=item WaitForMultipleObjects(\@objects, $wait_all, $timeout) + +Warning: C<WaitForMultipleObjects> erases C<@objects>! +Use C<wait_all> or C<wait_any> instead. + +=item $obj->Wait($timeout) + +Similar to C<not $obj-E<gt>wait($timeout)>. + +=back + +=head1 INTERNALS + +The C<wait_any> and C<wait_all> functions support two kinds of +objects. Objects derived from C<Win32::IPC> are expected to consist +of a reference to a scalar containing the Win32 HANDLE as an IV. + +Other objects (for which C<UNIVERSAL::isa($object, "Win32::IPC")> is +false), are expected to implement a C<get_Win32_IPC_HANDLE> method. +When called in scalar context with no arguments, this method should +return a Win32 HANDLE (as an IV) suitable for passing to the Win32 +WaitForMultipleObjects API function. + +=head1 AUTHOR + +Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> + +Loosely based on the original module by ActiveWare Internet Corp., +F<http://www.ActiveWare.com> + +=cut + +# Local Variables: +# tmtrack-file-task: "Win32::IPC" +# End: diff --git a/Master/tlpkg/installer/perllib/Win32/Internet.pm b/Master/tlpkg/installer/perllib/Win32/Internet.pm new file mode 100644 index 00000000000..f6dac3130af --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Internet.pm @@ -0,0 +1,3009 @@ +####################################################################### +# +# Win32::Internet - Perl Module for Internet Extensions +# ^^^^^^^^^^^^^^^ +# This module creates an object oriented interface to the Win32 +# Internet Functions (WININET.DLL). +# +# Version: 0.08 (14 Feb 1997) +# Version: 0.081 (25 Sep 1999) +# Version: 0.082 (04 Sep 2001) +# +####################################################################### + +# changes: +# - fixed 2 bugs in Option(s) related subs +# - works with build 30x also + +package Win32::Internet; + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. + +# use Win32::WinError; # for windows constants. + +@ISA= qw( Exporter DynaLoader ); +@EXPORT = qw( + HTTP_ADDREQ_FLAG_ADD + HTTP_ADDREQ_FLAG_REPLACE + HTTP_QUERY_ALLOW + HTTP_QUERY_CONTENT_DESCRIPTION + HTTP_QUERY_CONTENT_ID + HTTP_QUERY_CONTENT_LENGTH + HTTP_QUERY_CONTENT_TRANSFER_ENCODING + HTTP_QUERY_CONTENT_TYPE + HTTP_QUERY_COST + HTTP_QUERY_CUSTOM + HTTP_QUERY_DATE + HTTP_QUERY_DERIVED_FROM + HTTP_QUERY_EXPIRES + HTTP_QUERY_FLAG_REQUEST_HEADERS + HTTP_QUERY_FLAG_SYSTEMTIME + HTTP_QUERY_LANGUAGE + HTTP_QUERY_LAST_MODIFIED + HTTP_QUERY_MESSAGE_ID + HTTP_QUERY_MIME_VERSION + HTTP_QUERY_PRAGMA + HTTP_QUERY_PUBLIC + HTTP_QUERY_RAW_HEADERS + HTTP_QUERY_RAW_HEADERS_CRLF + HTTP_QUERY_REQUEST_METHOD + HTTP_QUERY_SERVER + HTTP_QUERY_STATUS_CODE + HTTP_QUERY_STATUS_TEXT + HTTP_QUERY_URI + HTTP_QUERY_USER_AGENT + HTTP_QUERY_VERSION + HTTP_QUERY_WWW_LINK + ICU_BROWSER_MODE + ICU_DECODE + ICU_ENCODE_SPACES_ONLY + ICU_ESCAPE + ICU_NO_ENCODE + ICU_NO_META + ICU_USERNAME + INTERNET_FLAG_PASSIVE + INTERNET_FLAG_ASYNC + INTERNET_HYPERLINK + INTERNET_FLAG_KEEP_CONNECTION + INTERNET_FLAG_MAKE_PERSISTENT + INTERNET_FLAG_NO_AUTH + INTERNET_FLAG_NO_AUTO_REDIRECT + INTERNET_FLAG_NO_CACHE_WRITE + INTERNET_FLAG_NO_COOKIES + INTERNET_FLAG_READ_PREFETCH + INTERNET_FLAG_RELOAD + INTERNET_FLAG_RESYNCHRONIZE + INTERNET_FLAG_TRANSFER_ASCII + INTERNET_FLAG_TRANSFER_BINARY + INTERNET_INVALID_PORT_NUMBER + INTERNET_INVALID_STATUS_CALLBACK + INTERNET_OPEN_TYPE_DIRECT + INTERNET_OPEN_TYPE_PROXY + INTERNET_OPEN_TYPE_PROXY_PRECONFIG + INTERNET_OPTION_CONNECT_BACKOFF + INTERNET_OPTION_CONNECT_RETRIES + INTERNET_OPTION_CONNECT_TIMEOUT + INTERNET_OPTION_CONTROL_SEND_TIMEOUT + INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT + INTERNET_OPTION_DATA_SEND_TIMEOUT + INTERNET_OPTION_DATA_RECEIVE_TIMEOUT + INTERNET_OPTION_HANDLE_SIZE + INTERNET_OPTION_LISTEN_TIMEOUT + INTERNET_OPTION_PASSWORD + INTERNET_OPTION_READ_BUFFER_SIZE + INTERNET_OPTION_USER_AGENT + INTERNET_OPTION_USERNAME + INTERNET_OPTION_VERSION + INTERNET_OPTION_WRITE_BUFFER_SIZE + INTERNET_SERVICE_FTP + INTERNET_SERVICE_GOPHER + INTERNET_SERVICE_HTTP + INTERNET_STATUS_CLOSING_CONNECTION + INTERNET_STATUS_CONNECTED_TO_SERVER + INTERNET_STATUS_CONNECTING_TO_SERVER + INTERNET_STATUS_CONNECTION_CLOSED + INTERNET_STATUS_HANDLE_CLOSING + INTERNET_STATUS_HANDLE_CREATED + INTERNET_STATUS_NAME_RESOLVED + INTERNET_STATUS_RECEIVING_RESPONSE + INTERNET_STATUS_REDIRECT + INTERNET_STATUS_REQUEST_COMPLETE + INTERNET_STATUS_REQUEST_SENT + INTERNET_STATUS_RESOLVING_NAME + INTERNET_STATUS_RESPONSE_RECEIVED + INTERNET_STATUS_SENDING_REQUEST +); + + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + + # [dada] This results in an ugly Autoloader error + #if ($! =~ /Invalid/) { + # $AutoLoader::AUTOLOAD = $AUTOLOAD; + # goto &AutoLoader::AUTOLOAD; + #} else { + + # [dada] ... I prefer this one :) + + ($pack,$file,$line) = caller; undef $pack; + die "Win32::Internet::$constname is not defined, used at $file line $line."; + + #} + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# STATIC OBJECT PROPERTIES +# +$VERSION = "0.082"; + +%callback_code = (); +%callback_info = (); + + +####################################################################### +# PUBLIC METHODS +# + +#======== ### CLASS CONSTRUCTOR +sub new { +#======== + my($class, $useragent, $opentype, $proxy, $proxybypass, $flags) = @_; + my $self = {}; + + if(ref($useragent) and ref($useragent) eq "HASH") { + $opentype = $useragent->{'opentype'}; + $proxy = $useragent->{'proxy'}; + $proxybypass = $useragent->{'proxybypass'}; + $flags = $useragent->{'flags'}; + my $myuseragent = $useragent->{'useragent'}; + undef $useragent; + $useragent = $myuseragent; + } + + $useragent = "Perl-Win32::Internet/".$VERSION unless defined($useragent); + $opentype = constant("INTERNET_OPEN_TYPE_DIRECT",0) unless defined($opentype); + $proxy = "" unless defined($proxy); + $proxybypass = "" unless defined($proxybypass); + $flags = 0 unless defined($flags); + + + my $handle = InternetOpen($useragent, $opentype, $proxy, $proxybypass, $flags); + if ($handle) { + $self->{'connections'} = 0; + $self->{'pasv'} = 0; + $self->{'handle'} = $handle; + $self->{'useragent'} = $useragent; + $self->{'proxy'} = $proxy; + $self->{'proxybypass'} = $proxybypass; + $self->{'flags'} = $flags; + $self->{'Type'} = "Internet"; + + # [dada] I think it's better to call SetStatusCallback explicitly... + #if($flags & constant("INTERNET_FLAG_ASYNC",0)) { + # my $callbackresult=InternetSetStatusCallback($handle); + # if($callbackresult==&constant("INTERNET_INVALID_STATUS_CALLBACK",0)) { + # $self->{'Error'} = -2; + # } + #} + + bless $self; + } else { + $self->{'handle'} = undef; + bless $self; + } + $self; +} + + +#============ +sub OpenURL { +#============ + my($self,$new,$URL) = @_; + return undef unless ref($self); + + my $newhandle=InternetOpenUrl($self->{'handle'},$URL,"",0,0,0); + if(!$newhandle) { + $self->{'Error'} = "Cannot open URL."; + return undef; + } else { + $self->{'connections'}++; + $_[1] = _new($newhandle); + $_[1]->{'Type'} = "URL"; + $_[1]->{'URL'} = $URL; + return $newhandle; + } +} + + +#================ +sub TimeConvert { +#================ + my($self, $sec, $min, $hour, $day, $mon, $year, $wday, $rfc) = @_; + return undef unless ref($self); + + if(!defined($rfc)) { + return InternetTimeToSystemTime($sec); + } else { + return InternetTimeFromSystemTime($sec, $min, $hour, + $day, $mon, $year, + $wday, $rfc); + } +} + + +#======================= +sub QueryDataAvailable { +#======================= + my($self) = @_; + return undef unless ref($self); + + return InternetQueryDataAvailable($self->{'handle'}); +} + + +#============= +sub ReadFile { +#============= + my($self, $buffersize) = @_; + return undef unless ref($self); + + my $howmuch = InternetQueryDataAvailable($self->{'handle'}); + $buffersize = $howmuch unless defined($buffersize); + return InternetReadFile($self->{'handle'}, ($howmuch<$buffersize) ? $howmuch + : $buffersize); +} + + +#=================== +sub ReadEntireFile { +#=================== + my($handle) = @_; + my $content = ""; + my $buffersize = 16000; + my $howmuch = 0; + my $buffer = ""; + + $handle = $handle->{'handle'} if defined($handle) and ref($handle); + + $howmuch = InternetQueryDataAvailable($handle); + # print "\nReadEntireFile: $howmuch bytes to read...\n"; + + while($howmuch>0) { + $buffer = InternetReadFile($handle, ($howmuch<$buffersize) ? $howmuch + : $buffersize); + # print "\nReadEntireFile: ", length($buffer), " bytes read...\n"; + + if(!defined($buffer)) { + return undef; + } else { + $content .= $buffer; + } + $howmuch = InternetQueryDataAvailable($handle); + # print "\nReadEntireFile: still $howmuch bytes to read...\n"; + + } + return $content; +} + + +#============= +sub FetchURL { +#============= + # (OpenURL+Read+Close)... + my($self, $URL) = @_; + return undef unless ref($self); + + my $newhandle = InternetOpenUrl($self->{'handle'}, $URL, "", 0, 0, 0); + if(!$newhandle) { + $self->{'Error'} = "Cannot open URL."; + return undef; + } else { + my $content = ReadEntireFile($newhandle); + InternetCloseHandle($newhandle); + return $content; + } +} + + +#================ +sub Connections { +#================ + my($self) = @_; + return undef unless ref($self); + + return $self->{'connections'} if $self->{'Type'} eq "Internet"; + return undef; +} + + +#================ +sub GetResponse { +#================ + my($num, $text) = InternetGetLastResponseInfo(); + return $text; +} + +#=========== +sub Option { +#=========== + my($self, $option, $value) = @_; + return undef unless ref($self); + + my $retval = 0; + + $option = constant("INTERNET_OPTION_USER_AGENT", 0) unless defined($option); + + if(!defined($value)) { + $retval = InternetQueryOption($self->{'handle'}, $option); + } else { + $retval = InternetSetOption($self->{'handle'}, $option, $value); + } + return $retval; +} + + +#============== +sub UserAgent { +#============== + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_USER_AGENT", 0), $value); +} + + +#============= +sub Username { +#============= + my($self, $value) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") { + $self->{'Error'} = "Username() only on FTP or HTTP sessions."; + return undef; + } + + return Option($self, constant("INTERNET_OPTION_USERNAME", 0), $value); +} + + +#============= +sub Password { +#============= + my($self, $value)=@_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") { + $self->{'Error'} = "Password() only on FTP or HTTP sessions."; + return undef; + } + + return Option($self, constant("INTERNET_OPTION_PASSWORD", 0), $value); +} + + +#=================== +sub ConnectTimeout { +#=================== + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONNECT_TIMEOUT", 0), $value); +} + + +#=================== +sub ConnectRetries { +#=================== + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONNECT_RETRIES", 0), $value); +} + + +#=================== +sub ConnectBackoff { +#=================== + my($self,$value)=@_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONNECT_BACKOFF", 0), $value); +} + + +#==================== +sub DataSendTimeout { +#==================== + my($self,$value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_DATA_SEND_TIMEOUT", 0), $value); +} + + +#======================= +sub DataReceiveTimeout { +#======================= + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_DATA_RECEIVE_TIMEOUT", 0), $value); +} + + +#========================== +sub ControlReceiveTimeout { +#========================== + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT", 0), $value); +} + + +#======================= +sub ControlSendTimeout { +#======================= + my($self, $value) = @_; + return undef unless ref($self); + + return Option($self, constant("INTERNET_OPTION_CONTROL_SEND_TIMEOUT", 0), $value); +} + + +#================ +sub QueryOption { +#================ + my($self, $option) = @_; + return undef unless ref($self); + + return InternetQueryOption($self->{'handle'}, $option); +} + + +#============== +sub SetOption { +#============== + my($self, $option, $value) = @_; + return undef unless ref($self); + + return InternetSetOption($self->{'handle'}, $option, $value); +} + + +#============= +sub CrackURL { +#============= + my($self, $URL, $flags) = @_; + return undef unless ref($self); + + $flags = constant("ICU_ESCAPE", 0) unless defined($flags); + + my @newurl = InternetCrackUrl($URL, $flags); + + if(!defined($newurl[0])) { + $self->{'Error'} = "Cannot crack URL."; + return undef; + } else { + return @newurl; + } +} + + +#============== +sub CreateURL { +#============== + my($self, $scheme, $hostname, $port, + $username, $password, + $path, $extrainfo, $flags) = @_; + return undef unless ref($self); + + if(ref($scheme) and ref($scheme) eq "HASH") { + $flags = $hostname; + $hostname = $scheme->{'hostname'}; + $port = $scheme->{'port'}; + $username = $scheme->{'username'}; + $password = $scheme->{'password'}; + $path = $scheme->{'path'}; + $extrainfo = $scheme->{'extrainfo'}; + my $myscheme = $scheme->{'scheme'}; + undef $scheme; + $scheme = $myscheme; + } + + $hostname = "" unless defined($hostname); + $port = 0 unless defined($port); + $username = "" unless defined($username); + $password = "" unless defined($password); + $path = "" unless defined($path); + $extrainfo = "" unless defined($extrainfo); + $flags = constant("ICU_ESCAPE", 0) unless defined($flags); + + my $newurl = InternetCreateUrl($scheme, $hostname, $port, + $username, $password, + $path, $extrainfo, $flags); + if(!defined($newurl)) { + $self->{'Error'} = "Cannot create URL."; + return undef; + } else { + return $newurl; + } +} + + +#==================== +sub CanonicalizeURL { +#==================== + my($self, $URL, $flags) = @_; + return undef unless ref($self); + + my $newurl = InternetCanonicalizeUrl($URL, $flags); + if(!defined($newurl)) { + $self->{'Error'} = "Cannot canonicalize URL."; + return undef; + } else { + return $newurl; + } +} + + +#=============== +sub CombineURL { +#=============== + my($self, $baseURL, $relativeURL, $flags) = @_; + return undef unless ref($self); + + my $newurl = InternetCombineUrl($baseURL, $relativeURL, $flags); + if(!defined($newurl)) { + $self->{'Error'} = "Cannot combine URL(s)."; + return undef; + } else { + return $newurl; + } +} + + +#====================== +sub SetStatusCallback { +#====================== + my($self) = @_; + return undef unless ref($self); + + my $callback = InternetSetStatusCallback($self->{'handle'}); + print "callback=$callback, constant=",constant("INTERNET_INVALID_STATUS_CALLBACK", 0), "\n"; + if($callback == constant("INTERNET_INVALID_STATUS_CALLBACK", 0)) { + return undef; + } else { + return $callback; + } +} + + +#====================== +sub GetStatusCallback { +#====================== + my($self, $context) = @_; + $context = $self if not defined $context; + return($callback_code{$context}, $callback_info{$context}); +} + + +#========== +sub Error { +#========== + my($self) = @_; + return undef unless ref($self); + + require Win32 unless defined &Win32::GetLastError; + my $errtext = ""; + my $tmp = ""; + my $errnum = Win32::GetLastError(); + + if($errnum < 12000) { + $errtext = Win32::FormatMessage($errnum); + $errtext =~ s/[\r\n]//g; + } elsif($errnum == 12003) { + ($tmp, $errtext) = InternetGetLastResponseInfo(); + chomp $errtext; + 1 while($errtext =~ s/(.*)\n//); # the last line should be significative... + # otherwise call GetResponse() to get it whole + } elsif($errnum >= 12000) { + $errtext = FormatMessage($errnum); + $errtext =~ s/[\r\n]//g; + } else { + $errtext="Error"; + } + if($errnum == 0 and defined($self->{'Error'})) { + if($self->{'Error'} == -2) { + $errnum = -2; + $errtext = "Asynchronous operations not available."; + } else { + $errnum = -1; + $errtext = $self->{'Error'}; + } + } + return (wantarray)? ($errnum, $errtext) : "\[".$errnum."\] ".$errtext; +} + + +#============ +sub Version { +#============ + my $dll = InternetDllVersion(); + $dll =~ s/\0//g; + return (wantarray)? ($Win32::Internet::VERSION, $dll) + : $Win32::Internet::VERSION."/".$dll; +} + + +#========== +sub Close { +#========== + my($self, $handle) = @_; + if(!defined($handle)) { + return undef unless ref($self); + $handle = $self->{'handle'}; + } + InternetCloseHandle($handle); +} + + + +####################################################################### +# FTP CLASS METHODS +# + +#======== ### FTP CONSTRUCTOR +sub FTP { +#======== + my($self, $new, $server, $username, $password, $port, $pasv, $context) = @_; + return undef unless ref($self); + + if(ref($server) and ref($server) eq "HASH") { + $port = $server->{'port'}; + $username = $server->{'username'}; + $password = $password->{'host'}; + my $myserver = $server->{'server'}; + $pasv = $server->{'pasv'}; + $context = $server->{'context'}; + undef $server; + $server = $myserver; + } + + $server = "" unless defined($server); + $username = "anonymous" unless defined($username); + $password = "" unless defined($password); + $port = 21 unless defined($port); + $context = 0 unless defined($context); + + $pasv = $self->{'pasv'} unless defined $pasv; + $pasv = $pasv ? constant("INTERNET_FLAG_PASSIVE",0) : 0; + + my $newhandle = InternetConnect($self->{'handle'}, $server, $port, + $username, $password, + constant("INTERNET_SERVICE_FTP", 0), + $pasv, $context); + if($newhandle) { + $self->{'connections'}++; + $_[1] = _new($newhandle); + $_[1]->{'Type'} = "FTP"; + $_[1]->{'Mode'} = "bin"; + $_[1]->{'pasv'} = $pasv; + $_[1]->{'username'} = $username; + $_[1]->{'password'} = $password; + $_[1]->{'server'} = $server; + return $newhandle; + } else { + return undef; + } +} + +#======== +sub Pwd { +#======== + my($self) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { + $self->{'Error'} = "Pwd() only on FTP sessions."; + return undef; + } + + return FtpGetCurrentDirectory($self->{'handle'}); +} + + +#======= +sub Cd { +#======= + my($self, $path) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" || !defined($self->{'handle'})) { + $self->{'Error'} = "Cd() only on FTP sessions."; + return undef; + } + + my $retval = FtpSetCurrentDirectory($self->{'handle'}, $path); + if(!defined($retval)) { + return undef; + } else { + return $path; + } +} +#==================== +sub Cwd { Cd(@_); } +sub Chdir { Cd(@_); } +#==================== + + +#========== +sub Mkdir { +#========== + my($self, $path) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { + $self->{'Error'} = "Mkdir() only on FTP sessions."; + return undef; + } + + my $retval = FtpCreateDirectory($self->{'handle'}, $path); + $self->{'Error'} = "Can't create directory." unless defined($retval); + return $retval; +} +#==================== +sub Md { Mkdir(@_); } +#==================== + + +#========= +sub Mode { +#========= + my($self, $value) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { + $self->{'Error'} = "Mode() only on FTP sessions."; + return undef; + } + + if(!defined($value)) { + return $self->{'Mode'}; + } else { + my $modesub = ($value =~ /^a/i) ? "Ascii" : "Binary"; + $self->$modesub($_[0]); + } + return $self->{'Mode'}; +} + + +#========== +sub Rmdir { +#========== + my($self, $path) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) { + $self->{'Error'} = "Rmdir() only on FTP sessions."; + return undef; + } + my $retval = FtpRemoveDirectory($self->{'handle'}, $path); + $self->{'Error'} = "Can't remove directory." unless defined($retval); + return $retval; +} +#==================== +sub Rd { Rmdir(@_); } +#==================== + + +#========= +sub Pasv { +#========= + my($self, $value) = @_; + return undef unless ref($self); + + if(defined($value) and $self->{'Type'} eq "Internet") { + if($value == 0) { + $self->{'pasv'} = 0; + } else { + $self->{'pasv'} = 1; + } + } + return $self->{'pasv'}; +} + +#========= +sub List { +#========= + my($self, $pattern, $retmode) = @_; + return undef unless ref($self); + + my $retval = ""; + my $size = ""; + my $attr = ""; + my $ctime = ""; + my $atime = ""; + my $mtime = ""; + my $csec = 0; my $cmin = 0; my $chou = 0; my $cday = 0; my $cmon = 0; my $cyea = 0; + my $asec = 0; my $amin = 0; my $ahou = 0; my $aday = 0; my $amon = 0; my $ayea = 0; + my $msec = 0; my $mmin = 0; my $mhou = 0; my $mday = 0; my $mmon = 0; my $myea = 0; + my $newhandle = 0; + my $nextfile = 1; + my @results = (); + my ($filename, $altname, $file); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "List() only on FTP sessions."; + return undef; + } + + $pattern = "" unless defined($pattern); + $retmode = 1 unless defined($retmode); + + if($retmode == 2) { + + ( $newhandle,$filename, $altname, $size, $attr, + $csec, $cmin, $chou, $cday, $cmon, $cyea, + $asec, $amin, $ahou, $aday, $amon, $ayea, + $msec, $mmin, $mhou, $mday, $mmon, $myea + ) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0); + + if(!$newhandle) { + $self->{'Error'} = "Can't read FTP directory."; + return undef; + } else { + + while($nextfile) { + $ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea)); + $atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea)); + $mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea)); + push(@results, $filename, $altname, $size, $attr, $ctime, $atime, $mtime); + + ( $nextfile, $filename, $altname, $size, $attr, + $csec, $cmin, $chou, $cday, $cmon, $cyea, + $asec, $amin, $ahou, $aday, $amon, $ayea, + $msec, $mmin, $mhou, $mday, $mmon, $myea + ) = InternetFindNextFile($newhandle); + + } + InternetCloseHandle($newhandle); + return @results; + + } + + } elsif($retmode == 3) { + + ( $newhandle,$filename, $altname, $size, $attr, + $csec, $cmin, $chou, $cday, $cmon, $cyea, + $asec, $amin, $ahou, $aday, $amon, $ayea, + $msec, $mmin, $mhou, $mday, $mmon, $myea + ) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0); + + if(!$newhandle) { + $self->{'Error'} = "Can't read FTP directory."; + return undef; + + } else { + + while($nextfile) { + $ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea)); + $atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea)); + $mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea)); + $file = { "name" => $filename, + "altname" => $altname, + "size" => $size, + "attr" => $attr, + "ctime" => $ctime, + "atime" => $atime, + "mtime" => $mtime, + }; + push(@results, $file); + + ( $nextfile, $filename, $altname, $size, $attr, + $csec, $cmin, $chou, $cday, $cmon, $cyea, + $asec, $amin, $ahou, $aday, $amon, $ayea, + $msec, $mmin, $mhou, $mday, $mmon, $myea + ) = InternetFindNextFile($newhandle); + + } + InternetCloseHandle($newhandle); + return @results; + } + + } else { + + ($newhandle, $filename) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0); + + if(!$newhandle) { + $self->{'Error'} = "Can't read FTP directory."; + return undef; + + } else { + + while($nextfile) { + push(@results, $filename); + + ($nextfile, $filename) = InternetFindNextFile($newhandle); + # print "List.no more files\n" if !$nextfile; + + } + InternetCloseHandle($newhandle); + return @results; + } + } +} +#==================== +sub Ls { List(@_); } +sub Dir { List(@_); } +#==================== + + +#================= +sub FileAttrInfo { +#================= + my($self,$attr) = @_; + my @attrinfo = (); + push(@attrinfo, "READONLY") if $attr & 1; + push(@attrinfo, "HIDDEN") if $attr & 2; + push(@attrinfo, "SYSTEM") if $attr & 4; + push(@attrinfo, "DIRECTORY") if $attr & 16; + push(@attrinfo, "ARCHIVE") if $attr & 32; + push(@attrinfo, "NORMAL") if $attr & 128; + push(@attrinfo, "TEMPORARY") if $attr & 256; + push(@attrinfo, "COMPRESSED") if $attr & 2048; + return (wantarray)? @attrinfo : join(" ", @attrinfo); +} + + +#=========== +sub Binary { +#=========== + my($self) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Binary() only on FTP sessions."; + return undef; + } + $self->{'Mode'} = "bin"; + return undef; +} +#====================== +sub Bin { Binary(@_); } +#====================== + + +#========== +sub Ascii { +#========== + my($self) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Ascii() only on FTP sessions."; + return undef; + } + $self->{'Mode'} = "asc"; + return undef; +} +#===================== +sub Asc { Ascii(@_); } +#===================== + + +#======== +sub Get { +#======== + my($self, $remote, $local, $overwrite, $flags, $context) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Get() only on FTP sessions."; + return undef; + } + my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2); + + $remote = "" unless defined($remote); + $local = $remote unless defined($local); + $overwrite = 0 unless defined($overwrite); + $flags = 0 unless defined($flags); + $context = 0 unless defined($context); + + my $retval = FtpGetFile($self->{'handle'}, + $remote, + $local, + $overwrite, + $flags, + $mode, + $context); + $self->{'Error'} = "Can't get file." unless defined($retval); + return $retval; +} + + +#=========== +sub Rename { +#=========== + my($self, $oldname, $newname) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Rename() only on FTP sessions."; + return undef; + } + + my $retval = FtpRenameFile($self->{'handle'}, $oldname, $newname); + $self->{'Error'} = "Can't rename file." unless defined($retval); + return $retval; +} +#====================== +sub Ren { Rename(@_); } +#====================== + + +#=========== +sub Delete { +#=========== + my($self, $filename) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Delete() only on FTP sessions."; + return undef; + } + my $retval = FtpDeleteFile($self->{'handle'}, $filename); + $self->{'Error'} = "Can't delete file." unless defined($retval); + return $retval; +} +#====================== +sub Del { Delete(@_); } +#====================== + + +#======== +sub Put { +#======== + my($self, $local, $remote, $context) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "FTP") { + $self->{'Error'} = "Put() only on FTP sessions."; + return undef; + } + my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2); + + $context = 0 unless defined($context); + + my $retval = FtpPutFile($self->{'handle'}, $local, $remote, $mode, $context); + $self->{'Error'} = "Can't put file." unless defined($retval); + return $retval; +} + + +####################################################################### +# HTTP CLASS METHODS +# + +#========= ### HTTP CONSTRUCTOR +sub HTTP { +#========= + my($self, $new, $server, $username, $password, $port, $flags, $context) = @_; + return undef unless ref($self); + + if(ref($server) and ref($server) eq "HASH") { + my $myserver = $server->{'server'}; + $username = $server->{'username'}; + $password = $password->{'host'}; + $port = $server->{'port'}; + $flags = $server->{'flags'}; + $context = $server->{'context'}; + undef $server; + $server = $myserver; + } + + $server = "" unless defined($server); + $username = "anonymous" unless defined($username); + $password = "" unless defined($password); + $port = 80 unless defined($port); + $flags = 0 unless defined($flags); + $context = 0 unless defined($context); + + my $newhandle = InternetConnect($self->{'handle'}, $server, $port, + $username, $password, + constant("INTERNET_SERVICE_HTTP", 0), + $flags, $context); + if($newhandle) { + $self->{'connections'}++; + $_[1] = _new($newhandle); + $_[1]->{'Type'} = "HTTP"; + $_[1]->{'username'} = $username; + $_[1]->{'password'} = $password; + $_[1]->{'server'} = $server; + $_[1]->{'accept'} = "text/*\0image/gif\0image/jpeg\0\0"; + return $newhandle; + } else { + return undef; + } +} + + +#================ +sub OpenRequest { +#================ + # alternatively to Request: + # it creates a new HTTP_Request object + # you can act upon it with AddHeader, SendRequest, ReadFile, QueryInfo, Close, ... + + my($self, $new, $path, $method, $version, $referer, $accept, $flags, $context) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP") { + $self->{'Error'} = "OpenRequest() only on HTTP sessions."; + return undef; + } + + if(ref($path) and ref($path) eq "HASH") { + $method = $path->{'method'}; + $version = $path->{'version'}; + $referer = $path->{'referer'}; + $accept = $path->{'accept'}; + $flags = $path->{'flags'}; + $context = $path->{'context'}; + my $mypath = $path->{'path'}; + undef $path; + $path = $mypath; + } + + $method = "GET" unless defined($method); + $path = "/" unless defined($path); + $version = "HTTP/1.0" unless defined($version); + $referer = "" unless defined($referer); + $accept = $self->{'accept'} unless defined($accept); + $flags = 0 unless defined($flags); + $context = 0 unless defined($context); + + $path = "/".$path if substr($path,0,1) ne "/"; + # accept string list needs to be terminated by double-NULL + $accept .= "\0\0" unless $accept =~ /\0\0\z/; + + my $newhandle = HttpOpenRequest($self->{'handle'}, + $method, + $path, + $version, + $referer, + $accept, + $flags, + $context); + if($newhandle) { + $_[1] = _new($newhandle); + $_[1]->{'Type'} = "HTTP_Request"; + $_[1]->{'method'} = $method; + $_[1]->{'request'} = $path; + $_[1]->{'accept'} = $accept; + return $newhandle; + } else { + return undef; + } +} + +#================ +sub SendRequest { +#================ + my($self, $postdata) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP_Request") { + $self->{'Error'} = "SendRequest() only on HTTP requests."; + return undef; + } + + $postdata = "" unless defined($postdata); + + return HttpSendRequest($self->{'handle'}, "", $postdata); +} + + +#============== +sub AddHeader { +#============== + my($self, $header, $flags) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP_Request") { + $self->{'Error'} = "AddHeader() only on HTTP requests."; + return undef; + } + + $flags = constant("HTTP_ADDREQ_FLAG_ADD", 0) if (!defined($flags) or $flags == 0); + + return HttpAddRequestHeaders($self->{'handle'}, $header, $flags); +} + + +#============== +sub QueryInfo { +#============== + my($self, $header, $flags) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP_Request") { + $self->{'Error'}="QueryInfo() only on HTTP requests."; + return undef; + } + + $flags = constant("HTTP_QUERY_CUSTOM", 0) if (!defined($flags) and defined($header)); + my @queryresult = HttpQueryInfo($self->{'handle'}, $flags, $header); + return (wantarray)? @queryresult : join(" ", @queryresult); +} + + +#============ +sub Request { +#============ + # HttpOpenRequest+HttpAddHeaders+HttpSendRequest+InternetReadFile+HttpQueryInfo + my($self, $path, $method, $version, $referer, $accept, $flags, $postdata) = @_; + return undef unless ref($self); + + if($self->{'Type'} ne "HTTP") { + $self->{'Error'} = "Request() only on HTTP sessions."; + return undef; + } + + if(ref($path) and ref($path) eq "HASH") { + $method = $path->{'method'}; + $version = $path->{'version'}; + $referer = $path->{'referer'}; + $accept = $path->{'accept'}; + $flags = $path->{'flags'}; + $postdata = $path->{'postdata'}; + my $mypath = $path->{'path'}; + undef $path; + $path = $mypath; + } + + my $content = ""; + my $result = ""; + my @queryresult = (); + my $statuscode = ""; + my $headers = ""; + + $path = "/" unless defined($path); + $method = "GET" unless defined($method); + $version = "HTTP/1.0" unless defined($version); + $referer = "" unless defined($referer); + $accept = $self->{'accept'} unless defined($accept); + $flags = 0 unless defined($flags); + $postdata = "" unless defined($postdata); + + $path = "/".$path if substr($path,0,1) ne "/"; + # accept string list needs to be terminated by double-NULL + $accept .= "\0\0" unless $accept =~ /\0\0\z/; + + my $newhandle = HttpOpenRequest($self->{'handle'}, + $method, + $path, + $version, + $referer, + $accept, + $flags, + 0); + + if($newhandle) { + + $result = HttpSendRequest($newhandle, "", $postdata); + + if(defined($result)) { + $statuscode = HttpQueryInfo($newhandle, + constant("HTTP_QUERY_STATUS_CODE", 0), ""); + $headers = HttpQueryInfo($newhandle, + constant("HTTP_QUERY_RAW_HEADERS_CRLF", 0), ""); + $content = ReadEntireFile($newhandle); + + InternetCloseHandle($newhandle); + + return($statuscode, $headers, $content); + } else { + return undef; + } + } else { + return undef; + } +} + + +####################################################################### +# END OF THE PUBLIC METHODS +# + + +#========= ### SUB-CLASSES CONSTRUCTOR +sub _new { +#========= + my $self = {}; + if ($_[0]) { + $self->{'handle'} = $_[0]; + bless $self; + } else { + undef($self); + } + $self; +} + + +#============ ### CLASS DESTRUCTOR +sub DESTROY { +#============ + my($self) = @_; + # print "Closing handle $self->{'handle'}...\n"; + InternetCloseHandle($self->{'handle'}); + # [dada] rest in peace +} + + +#============= +sub callback { +#============= + my($name, $status, $info) = @_; + $callback_code{$name} = $status; + $callback_info{$name} = $info; +} + +####################################################################### +# dynamically load in the Internet.pll module. +# + +bootstrap Win32::Internet; + +# Preloaded methods go here. + +#Currently Autoloading is not implemented in Perl for win32 +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ + +=head1 NAME + +Win32::Internet - Access to WININET.DLL functions + +=head1 INTRODUCTION + +This extension to Perl implements the Win32 Internet APIs (found in +F<WININET.DLL>). They give a complete support for HTTP, FTP and GOPHER +connections. + +See the L<"Version History"> and the L<"Functions Table"> for a list +of the currently supported features. You should also get a copy of the +L<"Microsoft Win32 Internet Functions"> documentation. + +=head1 REFERENCE + +To use this module, first add the following line at the beginning of +your script: + + use Win32::Internet; + +Then you have to open an Internet connection with this command: + + $Connection = new Win32::Internet(); + +This is required to use any of the function of this module. It will +create an Internet object in Perl on which you can act upon with the +L<"General Internet Functions"> explained later. + +The objects available are: + +=over + +=item * + +Internet connections (the main object, see C<new>) + +=item * + +URLs (see C<OpenURL>) + +=item * + +FTP sessions (see C<FTP>) + +=item * + +HTTP sessions (see C<HTTP>) + +=item * + +HTTP requests (see C<OpenRequest>) + +=back + +As in the good Perl tradition, there are in this extension different +ways to do the same thing; there are, in fact, different levels of +implementation of the Win32 Internet Functions. Some routines use +several Win32 API functions to perform a complex task in a single +call; they are simpler to use, but of course less powerful. + +There are then other functions that implement nothing more and nothing +less than the corresponding API function, so you can use all of their +power, but with some additional programming steps. + +To make an example, there is a function called C<FetchURL> that you +can use to fetch the content of any HTTP, FTP or GOPHER URL with this +simple commands: + + $INET = new Win32::Internet(); + $file = $INET->FetchURL("http://www.yahoo.com"); + +You can have the same result (and this is actually what is done by +C<FetchURL>) this way: + + $INET = new Win32::Internet(); + $URL = $INET->OpenURL("http://www.yahoo.com"); + $file = $URL->ReadFile(); + $URL->Close(); + +Or, you can open a complete HTTP session: + + $INET = new Win32::Internet(); + $HTTP = $INET->HTTP("www.yahoo.com", "anonymous", "dada@divinf.it"); + ($statuscode, $headers, $file) = $HTTP->Request("/"); + $HTTP->Close(); + +Finally, you can choose to manage even the HTTP request: + + $INET = new Win32::Internet(); + $HTTP = $INET->HTTP("www.yahoo.com", "anonymous", "dada@divinf.it"); + $HTTP->OpenRequest($REQ, "/"); + $REQ->AddHeader("If-Modified-Since: Saturday, 16-Nov-96 15:58:50 GMT"); + $REQ->SendRequest(); + $statuscode = $REQ->QueryInfo("",HTTP_QUERY_STATUS_CODE); + $lastmodified = $REQ->QueryInfo("Last-Modified"); + $file = $REQ->ReadEntireFile(); + $REQ->Close(); + $HTTP->Close(); + +To open and control a complete FTP session, type: + + $Connection->FTP($Session, "ftp://ftp.activeware.com", "anonymous", "dada\@divinf.it"); + +This will create an FTP object in Perl to which you can apply the L<"FTP +functions"> provided by the package: + + $Session->Cd("/ntperl/perl5.001m/CurrentBuild"); + $Session->Ascii(); + $Session->Get("110-i86.zip"); + $Session->Close(); + +For a more complete example, see the TEST.PL file that comes with the +package. + +=head2 General Internet Functions + +B<General Note> + +All methods assume that you have the line: + + use Win32::Internet; + +somewhere before the method calls, and that you have an Internet +object called $INET which was created using this call: + + $INET = new Win32::Internet(); + +See C<new> for more information. + +B<Methods> + +=over + +=item CanonicalizeURL URL, [flags] + +Converts a URL to a canonical format, which includes converting unsafe +characters to escape sequences. Returns the canonicalized URL or +C<undef> on errors. For the possible values of I<flags>, refer to the +L<"Microsoft Win32 Internet Functions"> document. See also +C<CombineURL> and C<OpenURL>. + +Example: + + $cURL = $INET->CanonicalizeURL($URL); + $URL = $INET->CanonicalizeURL($cURL, ICU_DECODE); + +=item Close + +=item Close object + +Closes an Internet connection. This can be applied to any +Win32::Internet object (Internet connections, URLs, FTP sessions, +etc.). Note that it is not "strictly" required to close the +connections you create, since the Win32::Internet objects are +automatically closed when the program ends (or when you elsehow +destroy such an object). + +Example: + + $INET->Close(); + $FTP->Close(); + $INET->Close($FTP); # same as above... + +=item CombineURL baseURL, relativeURL, [flags] + +Combines a base and relative URL into a single URL. Returns the +(canonicalized) combined URL or C<undef> on errors. For the possible +values of I<flags>, refer to the L<"Microsoft Win32 Internet +Functions"> document. See also C<CombineURL> and C<OpenURL>. + +Example: + + $URL = $INET->CombineURL("http://www.divinf.it/dada/perl/internet", ".."); + +=item ConnectBackoff [value] + +Reads or sets the delay value, in milliseconds, to wait between +connection retries. If no I<value> parameter is specified, the +current value is returned; otherwise, the delay between retries is set +to I<value>. See also C<ConnectTimeout>, C<ConnectRetries>, +C<QueryOption> and C<SetOption>. + +Example: + + $HTTP->ConnectBackoff(2000); + $backoff = $HTTP->ConnectBackoff(); + +=item ConnectRetries [value] + +Reads or sets the number of times a connection is retried before +considering it failed. If no I<value> parameter is specified, the +current value is returned; otherwise, the number of retries is set to +I<value>. The default value for C<ConnectRetries> is 5. See also +C<ConnectBackoff>, C<ConnectTimeout>, C<QueryOption> and C<SetOption>. + +Example: + + $HTTP->ConnectRetries(20); + $retries = $HTTP->ConnectRetries(); + +=item ConnectTimeout [value] + +Reads or sets the timeout value (in milliseconds) before a connection +is considered failed. If no I<value> parameter is specified, the +current value is returned; otherwise, the timeout is set to I<value>. +The default value for C<ConnectTimeout> is infinite. See also +C<ConnectBackoff>, C<ConnectRetries>, C<QueryOption> and C<SetOption>. + +Example: + + $HTTP->ConnectTimeout(10000); + $timeout = $HTTP->ConnectTimeout(); + +=item ControlReceiveTimeout [value] + +Reads or sets the timeout value (in milliseconds) to use for non-data +(control) receive requests before they are canceled. Currently, this +value has meaning only for C<FTP> sessions. If no I<value> parameter +is specified, the current value is returned; otherwise, the timeout is +set to I<value>. The default value for C<ControlReceiveTimeout> is +infinite. See also C<ControlSendTimeout>, C<QueryOption> and +C<SetOption>. + +Example: + + $HTTP->ControlReceiveTimeout(10000); + $timeout = $HTTP->ControlReceiveTimeout(); + +=item ControlSendTimeout [value] + +Reads or sets the timeout value (in milliseconds) to use for non-data +(control) send requests before they are canceled. Currently, this +value has meaning only for C<FTP> sessions. If no I<value> parameter +is specified, the current value is returned; otherwise, the timeout is +set to I<value>. The default value for C<ControlSendTimeout> is +infinite. See also C<ControlReceiveTimeout>, C<QueryOption> and +C<SetOption>. + +Example: + + $HTTP->ControlSendTimeout(10000); + $timeout = $HTTP->ControlSendTimeout(); + +=item CrackURL URL, [flags] + +Splits an URL into its component parts and returns them in an array. +Returns C<undef> on errors, otherwise the array will contain the +following values: I<scheme, host, port, username, password, path, +extrainfo>. + +For example, the URL "http://www.divinf.it/index.html#top" can be +splitted in: + + http, www.divinf.it, 80, anonymous, dada@divinf.it, /index.html, #top + +If you don't specify a I<flags> parameter, ICU_ESCAPE will be used by +default; for the possible values of I<flags> refer to the L<"Microsoft +Win32 Internet Functions"> documentation. See also C<CreateURL>. + +Example: + + @parts=$INET->CrackURL("http://www.activeware.com"); + ($scheme, $host, $port, $user, $pass, $path, $extra) = + $INET->CrackURL("http://www.divinf.it:80/perl-win32/index.sht#feedback"); + +=item CreateURL scheme, hostname, port, username, password, path, extrainfo, [flags] + +=item CreateURL hashref, [flags] + +Creates a URL from its component parts. Returns C<undef> on errors, +otherwise the created URL. + +If you pass I<hashref> (a reference to an hash array), the following +values are taken from the array: + + %hash=( + "scheme" => "scheme", + "hostname" => "hostname", + "port" => port, + "username" => "username", + "password" => "password", + "path" => "path", + "extrainfo" => "extrainfo", + ); + +If you don't specify a I<flags> parameter, ICU_ESCAPE will be used by +default; for the other possible values of I<flags> refer to the +L<"Microsoft Win32 Internet Functions"> documentation. See also +C<CrackURL>. + +Example: + + $URL=$I->CreateURL("http", "www.divinf.it", 80, "", "", "/perl-win32/index.sht", "#feedback"); + $URL=$I->CreateURL(\%params); + +=item DataReceiveTimeout [value] + +Reads or sets the timeout value (in milliseconds) to use for data +receive requests before they are canceled. If no I<value> parameter +is specified, the current value is returned; otherwise, the timeout is +set to I<value>. The default value for DataReceiveTimeout is +infinite. See also C<DataSendTimeout>, C<QueryOption> and +C<SetOption>. + +Example: + + $HTTP->DataReceiveTimeout(10000); + $timeout = $HTTP->DataReceiveTimeout(); + +=item DataSendTimeout [value] + +Reads or sets the timeout value (in milliseconds) to use for data send +requests before they are canceled. If no I<value> parameter is +specified, the current value is returned; otherwise, the timeout is +set to I<value>. The default value for DataSendTimeout is infinite. +See also C<DataReceiveTimeout>, C<QueryOption> and C<SetOption>. + +Example: + + $HTTP->DataSendTimeout(10000); + $timeout = $HTTP->DataSendTimeout(); + +=item Error + +Returns the last recorded error in the form of an array or string +(depending upon the context) containing the error number and an error +description. Can be applied on any Win32::Internet object (FTP +sessions, etc.). There are 3 types of error you can encounter; they +are recognizable by the error number returned: + +=over + +=item * -1 + +A "trivial" error has occurred in the package. For example, you tried +to use a method on the wrong type of object. + +=item * 1 .. 11999 + +A generic error has occurred and the Win32::GetLastError error message +is returned. + +=item * 12000 and higher + +An Internet error has occurred; the extended Win32 Internet API error +message is returned. + +=back + +See also C<GetResponse>. + +Example: + + die $INET->Error(), qq(\n); + ($ErrNum, $ErrText) = $INET->Error(); + +=item FetchURL URL + +Fetch the content of an HTTP, FTP or GOPHER URL. Returns the content +of the file read (or C<undef> if there was an error and nothing was +read). See also C<OpenURL> and C<ReadFile>. + +Example: + + $file = $INET->FetchURL("http://www.yahoo.com/"); + $file = $INET->FetchURL("ftp://www.activeware.com/contrib/internet.zip"); + +=item FTP ftpobject, server, username, password, [port, pasv, context] + +=item FTP ftpobject, hashref + +Opens an FTP connection to server logging in with the given +I<username> and I<password>. + +The parameters and their values are: + +=over + +=item * server + +The server to connect to. Default: I<none>. + +=item * username + +The username used to login to the server. Default: anonymous. + +=item * password + +The password used to login to the server. Default: I<none>. + +=item * port + +The port of the FTP service on the server. Default: 21. + +=item * pasv + +If it is a value other than 0, use passive transfer mode. Default is +taken from the parent Internet connection object; you can set this +value with the C<Pasv> method. + +=item * context + +A number to identify this operation if it is asynchronous. See +C<SetStatusCallback> and C<GetStatusCallback> for more info on +asynchronous operations. Default: I<none>. + +=back + +If you pass I<hashref> (a reference to an hash array), the following +values are taken from the array: + + %hash=( + "server" => "server", + "username" => "username", + "password" => "password", + "port" => port, + "pasv" => pasv, + "context" => context, + ); + +This method returns C<undef> if the connection failed, a number +otherwise. You can then call any of the L<"FTP functions"> as methods +of the newly created I<ftpobject>. + +Example: + + $result = $INET->FTP($FTP, "ftp.activeware.com", "anonymous", "dada\@divinf.it"); + # and then for example... + $FTP->Cd("/ntperl/perl5.001m/CurrentBuild"); + + $params{"server"} = "ftp.activeware.com"; + $params{"password"} = "dada\@divinf.it"; + $params{"pasv"} = 0; + $result = $INET->FTP($FTP,\%params); + +=item GetResponse + +Returns the text sent by a remote server in response to the last +function executed. It applies on any Win32::Internet object, +particularly of course on L<FTP sessions|"FTP functions">. See also +the C<Error> function. + +Example: + + print $INET->GetResponse(); + $INET->FTP($FTP, "ftp.activeware.com", "anonymous", "dada\@divinf.it"); + print $FTP->GetResponse(); + +=item GetStatusCallback context + +Returns information about the progress of the asynchronous operation +identified by I<context>; those informations consist of two values: a +status code (one of the INTERNET_STATUS_* L<"Constants">) and an +additional value depending on the status code; for example, if the +status code returned is INTERNET_STATUS_HANDLE_CREATED, the second +value will hold the handle just created. For more informations on +those values, please refer to the L<"Microsoft Win32 Internet +Functions"> documentation. See also C<SetStatusCallback>. + +Example: + + ($status, $info) = $INET->GetStatusCallback(1); + +=item HTTP httpobject, server, username, password, [port, flags, context] + +=item HTTP httpobject, hashref + +Opens an HTTP connection to I<server> logging in with the given +I<username> and I<password>. + +The parameters and their values are: + +=over + +=item * server + +The server to connect to. Default: I<none>. + +=item * username + +The username used to login to the server. Default: anonymous. + +=item * password + +The password used to login to the server. Default: I<none>. + +=item * port + +The port of the HTTP service on the server. Default: 80. + +=item * flags + +Additional flags affecting the behavior of the function. Default: +I<none>. + +=item * context + +A number to identify this operation if it is asynchronous. See +C<SetStatusCallback> and C<GetStatusCallback> for more info on +asynchronous operations. Default: I<none>. + +=back + +Refer to the L<"Microsoft Win32 Internet Functions"> documentation for +more details on those parameters. + +If you pass I<hashref> (a reference to an hash array), the following +values are taken from the array: + + %hash=( + "server" => "server", + "username" => "username", + "password" => "password", + "port" => port, + "flags" => flags, + "context" => context, + ); + +This method returns C<undef> if the connection failed, a number +otherwise. You can then call any of the L<"HTTP functions"> as +methods of the newly created I<httpobject>. + +Example: + + $result = $INET->HTTP($HTTP,"www.activeware.com","anonymous","dada\@divinf.it"); + # and then for example... + ($statuscode, $headers, $file) = $HTTP->Request("/gifs/camel.gif"); + + $params{"server"} = "www.activeware.com"; + $params{"password"} = "dada\@divinf.it"; + $params{"flags"} = INTERNET_FLAG_RELOAD; + $result = $INET->HTTP($HTTP,\%params); + +=item new Win32::Internet [useragent, opentype, proxy, proxybypass, flags] + +=item new Win32::Internet [hashref] + +Creates a new Internet object and initializes the use of the Internet +functions; this is required before any of the functions of this +package can be used. Returns C<undef> if the connection fails, a number +otherwise. The parameters and their values are: + +=over + +=item * useragent + +The user agent passed to HTTP requests. See C<OpenRequest>. Default: +Perl-Win32::Internet/I<version>. + +=item * opentype + +How to access to the Internet (eg. directly or using a proxy). +Default: INTERNET_OPEN_TYPE_DIRECT. + +=item * proxy + +Name of the proxy server (or servers) to use. Default: I<none>. + +=item * proxybypass + +Optional list of host names or IP addresses, or both, that are known +locally. Default: I<none>. + +=item * flags + +Additional flags affecting the behavior of the function. Default: +I<none>. + +=back + +Refer to the L<"Microsoft Win32 Internet Functions"> documentation for +more details on those parameters. If you pass I<hashref> (a reference to +an hash array), the following values are taken from the array: + + %hash=( + "useragent" => "useragent", + "opentype" => "opentype", + "proxy" => "proxy", + "proxybypass" => "proxybypass", + "flags" => flags, + ); + +Example: + + $INET = new Win32::Internet(); + die qq(Cannot connect to Internet...\n) if ! $INET; + + $INET = new Win32::Internet("Mozilla/3.0", INTERNET_OPEN_TYPE_PROXY, "www.microsoft.com", ""); + + $params{"flags"} = INTERNET_FLAG_ASYNC; + $INET = new Win32::Internet(\%params); + +=item OpenURL urlobject, URL + +Opens a connection to an HTTP, FTP or GOPHER Uniform Resource Location +(URL). Returns C<undef> on errors or a number if the connection was +succesful. You can then retrieve the URL content by applying the +methods C<QueryDataAvailable> and C<ReadFile> on the newly created +I<urlobject>. See also C<FetchURL>. + +Example: + + $INET->OpenURL($URL, "http://www.yahoo.com/"); + $bytes = $URL->QueryDataAvailable(); + $file = $URL->ReadEntireFile(); + $URL->Close(); + +=item Password [password] + +Reads or sets the password used for an C<FTP> or C<HTTP> connection. +If no I<password> parameter is specified, the current value is +returned; otherwise, the password is set to I<password>. See also +C<Username>, C<QueryOption> and C<SetOption>. + +Example: + + $HTTP->Password("splurfgnagbxam"); + $password = $HTTP->Password(); + +=item QueryDataAvailable + +Returns the number of bytes of data that are available to be read +immediately by a subsequent call to C<ReadFile> (or C<undef> on +errors). Can be applied to URL or HTTP request objects. See +C<OpenURL> or C<OpenRequest>. + +Example: + + $INET->OpenURL($URL, "http://www.yahoo.com/"); + $bytes = $URL->QueryDataAvailable(); + +=item QueryOption option + +Queries an Internet option. For the possible values of I<option>, +refer to the L<"Microsoft Win32 Internet Functions"> document. See +also C<SetOption>. + +Example: + + $value = $INET->QueryOption(INTERNET_OPTION_CONNECT_TIMEOUT); + $value = $HTTP->QueryOption(INTERNET_OPTION_USERNAME); + +=item ReadEntireFile + +Reads all the data available from an opened URL or HTTP request +object. Returns what have been read or C<undef> on errors. See also +C<OpenURL>, C<OpenRequest> and C<ReadFile>. + +Example: + + $INET->OpenURL($URL, "http://www.yahoo.com/"); + $file = $URL->ReadEntireFile(); + +=item ReadFile bytes + +Reads I<bytes> bytes of data from an opened URL or HTTP request +object. Returns what have been read or C<undef> on errors. See also +C<OpenURL>, C<OpenRequest>, C<QueryDataAvailable> and +C<ReadEntireFile>. + +B<Note:> be careful to keep I<bytes> to an acceptable value (eg. don't +tell him to swallow megabytes at once...). C<ReadEntireFile> in fact +uses C<QueryDataAvailable> and C<ReadFile> in a loop to read no more +than 16k at a time. + +Example: + + $INET->OpenURL($URL, "http://www.yahoo.com/"); + $chunk = $URL->ReadFile(16000); + +=item SetOption option, value + +Sets an Internet option. For the possible values of I<option>, refer to +the L<"Microsoft Win32 Internet Functions"> document. See also +C<QueryOption>. + +Example: + + $INET->SetOption(INTERNET_OPTION_CONNECT_TIMEOUT,10000); + $HTTP->SetOption(INTERNET_OPTION_USERNAME,"dada"); + +=item SetStatusCallback + +Initializes the callback routine used to return data about the +progress of an asynchronous operation. + +Example: + + $INET->SetStatusCallback(); + +This is one of the step required to perform asynchronous operations; +the complete procedure is: + + # use the INTERNET_FLAG_ASYNC when initializing + $params{'flags'}=INTERNET_FLAG_ASYNC; + $INET = new Win32::Internet(\%params); + + # initialize the callback routine + $INET->SetStatusCallback(); + + # specify the context parameter (the last 1 in this case) + $INET->HTTP($HTTP, "www.yahoo.com", "anonymous", "dada\@divinf.it", 80, 0, 1); + +At this point, control returns immediately to Perl and $INET->Error() +will return 997, which means an asynchronous I/O operation is +pending. Now, you can call + + $HTTP->GetStatusCallback(1); + +in a loop to verify what's happening; see also C<GetStatusCallback>. + +=item TimeConvert time + +=item TimeConvert seconds, minute, hours, day, month, year, + day_of_week, RFC + +The first form takes a HTTP date/time string and returns the date/time +converted in the following array: I<seconds, minute, hours, day, +month, year, day_of_week>. + +The second form does the opposite (or at least it should, because +actually seems to be malfunctioning): it takes the values and returns +an HTTP date/time string, in the RFC format specified by the I<RFC> +parameter (OK, I didn't find yet any accepted value in the range +0..2000, let me know if you have more luck with it). + +Example: + + ($sec, $min, $hour, $day, $mday, $year, $wday) = + $INET->TimeConvert("Sun, 26 Jan 1997 20:01:52 GMT"); + + # the opposite DOESN'T WORK! which value should $RFC have??? + $time = $INET->TimeConvert(52, 1, 20, 26, 1, 1997, 0, $RFC); + +=item UserAgent [name] + +Reads or sets the user agent used for HTTP requests. If no I<name> +parameter is specified, the current value is returned; otherwise, the +user agent is set to I<name>. See also C<QueryOption> and +C<SetOption>. + +Example: + + $INET->UserAgent("Mozilla/3.0"); + $useragent = $INET->UserAgent(); + +=item Username [name] + +Reads or sets the username used for an C<FTP> or C<HTTP> connection. +If no I<name> parameter is specified, the current value is returned; +otherwise, the username is set to I<name>. See also C<Password>, +C<QueryOption> and SetOption. + +Example: + + $HTTP->Username("dada"); + $username = $HTTP->Username(); + +=item Version + +Returns the version numbers for the Win32::Internet package and the +WININET.DLL version, as an array or string, depending on the context. +The string returned will contain "package_version/DLL_version", while +the array will contain: "package_version", "DLL_version". + +Example: + + $version = $INET->Version(); # should return "0.06/4.70.1215" + @version = $INET->Version(); # should return ("0.06", "4.70.1215") + +=back + + +=head2 FTP Functions + +B<General Note> + +All methods assume that you have the following lines: + + use Win32::Internet; + $INET = new Win32::Internet(); + $INET->FTP($FTP, "hostname", "username", "password"); + +somewhere before the method calls; in other words, we assume that you +have an Internet object called $INET and an open FTP session called +$FTP. + +See C<new> and C<FTP> for more information. + + +B<Methods> + +=over + +=item Ascii + +=item Asc + +Sets the ASCII transfer mode for this FTP session. It will be applied +to the subsequent C<Get> functions. See also the C<Binary> and +C<Mode> function. + +Example: + + $FTP->Ascii(); + +=item Binary + +=item Bin + +Sets the binary transfer mode for this FTP session. It will be +applied to the subsequent C<Get> functions. See also the C<Ascii> and +C<Mode> function. + +Example: + + $FTP->Binary(); + +=item Cd path + +=item Cwd path + +=item Chdir path + +Changes the current directory on the FTP remote host. Returns I<path> +or C<undef> on error. + +Example: + + $FTP->Cd("/pub"); + +=item Delete file + +=item Del file + +Deletes a file on the FTP remote host. Returns C<undef> on error. + +Example: + + $FTP->Delete("110-i86.zip"); + +=item Get remote, [local, overwrite, flags, context] + +Gets the I<remote> FTP file and saves it locally in I<local>. If +I<local> is not specified, it will be the same name as I<remote>. +Returns C<undef> on error. The parameters and their values are: + +=over + +=item * remote + +The name of the remote file on the FTP server. Default: I<none>. + +=item * local + +The name of the local file to create. Default: remote. + +=item * overwrite + +If 0, overwrites I<local> if it exists; with any other value, the +function fails if the I<local> file already exists. Default: 0. + +=item * flags + +Additional flags affecting the behavior of the function. Default: +I<none>. + +=item * context + +A number to identify this operation if it is asynchronous. See +C<SetStatusCallback> and C<GetStatusCallback> for more info on +asynchronous operations. Default: I<none>. + +=back + +Refer to the L<"Microsoft Win32 Internet Functions"> documentation for +more details on those parameters. + +Example: + + $FTP->Get("110-i86.zip"); + $FTP->Get("/pub/perl/languages/CPAN/00index.html", "CPAN_index.html"); + +=item List [pattern, listmode] + +=item Ls [pattern, listmode] + +=item Dir [pattern, listmode] + +Returns a list containing the files found in this directory, +eventually matching the given I<pattern> (which, if omitted, is +considered "*.*"). The content of the returned list depends on the +I<listmode> parameter, which can have the following values: + +=over + +=item * listmode=1 (or omitted) + +the list contains the names of the files found. Example: + + @files = $FTP->List(); + @textfiles = $FTP->List("*.txt"); + foreach $file (@textfiles) { + print "Name: ", $file, "\n"; + } + +=item * listmode=2 + +the list contains 7 values for each file, which respectively are: + +=over + +=item * the file name + +=item * the DOS short file name, aka 8.3 + +=item * the size + +=item * the attributes + +=item * the creation time + +=item * the last access time + +=item * the last modified time + +=back + +Example: + + @files = $FTP->List("*.*", 2); + for($i=0; $i<=$#files; $i+=7) { + print "Name: ", @files[$i], "\n"; + print "Size: ", @files[$i+2], "\n"; + print "Attr: ", @files[$i+3], "\n"; + } + +=item * listmode=3 + +the list contains a reference to an hash array for each found file; +each hash contains: + +=over + +=item * name => the file name + +=item * altname => the DOS short file name, aka 8.3 + +=item * size => the size + +=item * attr => the attributes + +=item * ctime => the creation time + +=item * atime => the last access time + +=item * mtime => the last modified time + +=back + +Example: + + @files = $FTP->List("*.*", 3); + foreach $file (@files) { + print $file->{'name'}, " ", $file->{'size'}, " ", $file->{'attr'}, "\n"; + } + +B<Note:> all times are reported as strings of the following format: +I<second, hour, minute, day, month, year>. + +Example: + + $file->{'mtime'} == "0,10,58,9,12,1996" stands for 09 Dec 1996 at 10:58:00 + +=back + +=item Mkdir name + +=item Md name + +Creates a directory on the FTP remote host. Returns C<undef> on error. + +Example: + + $FTP->Mkdir("NextBuild"); + +=item Mode [mode] + +If called with no arguments, returns the current transfer mode for +this FTP session ("asc" for ASCII or "bin" for binary). The I<mode> +argument can be "asc" or "bin", in which case the appropriate transfer +mode is selected. See also the Ascii and Binary functions. Returns +C<undef> on errors. + +Example: + + print "Current mode is: ", $FTP->Mode(); + $FTP->Mode("asc"); # ... same as $FTP->Ascii(); + +=item Pasv [mode] + +If called with no arguments, returns 1 if the current FTP session has +passive transfer mode enabled, 0 if not. + +You can call it with a I<mode> parameter (0/1) only as a method of a +Internet object (see C<new>), in which case it will set the default +value for the next C<FTP> objects you create (read: set it before, +because you can't change this value once you opened the FTP session). + +Example: + + print "Pasv is: ", $FTP->Pasv(); + + $INET->Pasv(1); + $INET->FTP($FTP,"ftp.activeware.com", "anonymous", "dada\@divinf.it"); + $FTP->Pasv(0); # this will be ignored... + +=item Put local, [remote, context] + +Upload the I<local> file to the FTP server saving it under the name +I<remote>, which if if omitted is the same name as I<local>. Returns +C<undef> on error. + +I<context> is a number to identify this operation if it is asynchronous. +See C<SetStatusCallback> and C<GetStatusCallback> for more info on +asynchronous operations. + +Example: + + $FTP->Put("internet.zip"); + $FTP->Put("d:/users/dada/temp.zip", "/temp/dada.zip"); + +=item Pwd + +Returns the current directory on the FTP server or C<undef> on errors. + +Example: + + $path = $FTP->Pwd(); + +=item Rename oldfile, newfile + +=item Ren oldfile, newfile + +Renames a file on the FTP remote host. Returns C<undef> on error. + +Example: + + $FTP->Rename("110-i86.zip", "68i-011.zip"); + +=item Rmdir name + +=item Rd name + +Removes a directory on the FTP remote host. Returns C<undef> on error. + +Example: + + $FTP->Rmdir("CurrentBuild"); + +=back + +=head2 HTTP Functions + +B<General Note> + +All methods assume that you have the following lines: + + use Win32::Internet; + $INET = new Win32::Internet(); + $INET->HTTP($HTTP, "hostname", "username", "password"); + +somewhere before the method calls; in other words, we assume that you +have an Internet object called $INET and an open HTTP session called +$HTTP. + +See C<new> and C<HTTP> for more information. + + +B<Methods> + +=over + +=item AddHeader header, [flags] + +Adds HTTP request headers to an HTTP request object created with +C<OpenRequest>. For the possible values of I<flags> refer to the +L<"Microsoft Win32 Internet Functions"> document. + +Example: + + $HTTP->OpenRequest($REQUEST,"/index.html"); + $REQUEST->AddHeader("If-Modified-Since: Sunday, 17-Nov-96 11:40:03 GMT"); + $REQUEST->AddHeader("Accept: text/html\r\n", HTTP_ADDREQ_FLAG_REPLACE); + +=item OpenRequest requestobject, [path, method, version, referer, accept, flags, context] + +=item OpenRequest requestobject, hashref + +Opens an HTTP request. Returns C<undef> on errors or a number if the +connection was succesful. You can then use one of the C<AddHeader>, +C<SendRequest>, C<QueryInfo>, C<QueryDataAvailable> and C<ReadFile> +methods on the newly created I<requestobject>. The parameters and +their values are: + +=over + +=item * path + +The object to request. This is generally a file name, an executable +module, etc. Default: / + +=item * method + +The method to use; can actually be GET, POST, HEAD or PUT. Default: +GET + +=item * version + +The HTTP version. Default: HTTP/1.0 + +=item * referer + +The URL of the document from which the URL in the request was +obtained. Default: I<none> + +=item * accept + +A single string with "\0" (ASCII zero) delimited list of content +types accepted. The string must be terminated by "\0\0". +Default: "text/*\0image/gif\0image/jpeg\0\0" + +=item * flags + +Additional flags affecting the behavior of the function. Default: +I<none> + +=item * context + +A number to identify this operation if it is asynchronous. See +C<SetStatusCallback> and C<GetStatusCallback> for more info on +asynchronous operations. Default: I<none> + +=back + +Refer to the L<"Microsoft Win32 Internet Functions"> documentation for +more details on those parameters. If you pass I<hashref> (a reference to +an hash array), the following values are taken from the array: + + %hash=( + "path" => "path", + "method" => "method", + "version" => "version", + "referer" => "referer", + "accept" => "accept", + "flags" => flags, + "context" => context, + ); + +See also C<Request>. + +Example: + + $HTTP->OpenRequest($REQUEST, "/index.html"); + $HTTP->OpenRequest($REQUEST, "/index.html", "GET", "HTTP/0.9"); + + $params{"path"} = "/index.html"; + $params{"flags"} = " + $HTTP->OpenRequest($REQUEST, \%params); + +=item QueryInfo header, [flags] + +Queries information about an HTTP request object created with +C<OpenRequest>. You can specify an I<header> (for example, +"Content-type") and/or one or more I<flags>. If you don't specify +I<flags>, HTTP_QUERY_CUSTOM will be used by default; this means that +I<header> should contain a valid HTTP header name. For the possible +values of I<flags> refer to the L<"Microsoft Win32 Internet +Functions"> document. + +Example: + + $HTTP->OpenRequest($REQUEST,"/index.html"); + $statuscode = $REQUEST->QueryInfo("", HTTP_QUERY_STATUS_CODE); + $headers = $REQUEST->QueryInfo("", HTTP_QUERY_RAW_HEADERS_CRLF); # will get all the headers + $length = $REQUEST->QueryInfo("Content-length"); + +=item Request [path, method, version, referer, accept, flags] + +=item Request hashref + +Performs an HTTP request and returns an array containing the status +code, the headers and the content of the file. It is a one-step +procedure that makes an C<OpenRequest>, a C<SendRequest>, some +C<QueryInfo>, C<ReadFile> and finally C<Close>. For a description of +the parameters, see C<OpenRequest>. + +Example: + + ($statuscode, $headers, $file) = $HTTP->Request("/index.html"); + ($s, $h, $f) = $HTTP->Request("/index.html", "GET", "HTTP/1.0"); + +=item SendRequest [postdata] + +Send an HTTP request to the destination server. I<postdata> are any +optional data to send immediately after the request header; this is +generally used for POST or PUT requests. See also C<OpenRequest>. + +Example: + + $HTTP->OpenRequest($REQUEST, "/index.html"); + $REQUEST->SendRequest(); + + # A POST request... + $HTTP->OpenRequest($REQUEST, "/cgi-bin/somescript.pl", "POST"); + + #This line is a must -> (thanks Philip :) + $REQUEST->AddHeader("Content-Type: application/x-www-form-urlencoded"); + + $REQUEST->SendRequest("key1=value1&key2=value2&key3=value3"); + +=back + + +=head1 APPENDIX + + +=head2 Microsoft Win32 Internet Functions + +Complete documentation for the Microsoft Win32 Internet Functions can +be found, in both HTML and zipped Word format, at this address: + + http://www.microsoft.com/intdev/sdk/docs/wininet/ + +=head2 Functions Table + +This table reports the correspondence between the functions offered by +WININET.DLL and their implementation in the Win32::Internet +extension. Functions showing a "---" are not currently +implemented. Functions enclosed in parens ( ) aren't implemented +straightforwardly, but in a higher-level routine, eg. together with +other functions. + + WININET.DLL Win32::Internet + + InternetOpen new Win32::Internet + InternetConnect FTP / HTTP + InternetCloseHandle Close + InternetQueryOption QueryOption + InternetSetOption SetOption + InternetSetOptionEx --- + InternetSetStatusCallback SetStatusCallback + InternetStatusCallback GetStatusCallback + InternetConfirmZoneCrossing --- + InternetTimeFromSystemTime TimeConvert + InternetTimeToSystemTime TimeConvert + InternetAttemptConnect --- + InternetReadFile ReadFile + InternetSetFilePointer --- + InternetFindNextFile (List) + InternetQueryDataAvailable QueryDataAvailable + InternetGetLastResponseInfo GetResponse + InternetWriteFile --- + InternetCrackUrl CrackURL + InternetCreateUrl CreateURL + InternetCanonicalizeUrl CanonicalizeURL + InternetCombineUrl CombineURL + InternetOpenUrl OpenURL + FtpFindFirstFile (List) + FtpGetFile Get + FtpPutFile Put + FtpDeleteFile Delete + FtpRenameFile Rename + FtpOpenFile --- + FtpCreateDirectory Mkdir + FtpRemoveDirectory Rmdir + FtpSetCurrentDirectory Cd + FtpGetCurrentDirectory Pwd + HttpOpenRequest OpenRequest + HttpAddRequestHeaders AddHeader + HttpSendRequest SendRequest + HttpQueryInfo QueryInfo + InternetErrorDlg --- + + +Actually, I don't plan to add support for Gopher, Cookie and Cache +functions. I will if there will be consistent requests to do so. + +There are a number of higher-level functions in the Win32::Internet +that simplify some usual procedures, calling more that one WININET API +function. This table reports those functions and the relative WININET +functions they use. + + Win32::Internet WININET.DLL + + FetchURL InternetOpenUrl + InternetQueryDataAvailable + InternetReadFile + InternetCloseHandle + + ReadEntireFile InternetQueryDataAvailable + InternetReadFile + + Request HttpOpenRequest + HttpSendRequest + HttpQueryInfo + InternetQueryDataAvailable + InternetReadFile + InternetCloseHandle + + List FtpFindFirstFile + InternetFindNextFile + + +=head2 Constants + +Those are the constants exported by the package in the main namespace +(eg. you can use them in your scripts); for their meaning and proper +use, refer to the Microsoft Win32 Internet Functions document. + + HTTP_ADDREQ_FLAG_ADD + HTTP_ADDREQ_FLAG_REPLACE + HTTP_QUERY_ALLOW + HTTP_QUERY_CONTENT_DESCRIPTION + HTTP_QUERY_CONTENT_ID + HTTP_QUERY_CONTENT_LENGTH + HTTP_QUERY_CONTENT_TRANSFER_ENCODING + HTTP_QUERY_CONTENT_TYPE + HTTP_QUERY_COST + HTTP_QUERY_CUSTOM + HTTP_QUERY_DATE + HTTP_QUERY_DERIVED_FROM + HTTP_QUERY_EXPIRES + HTTP_QUERY_FLAG_REQUEST_HEADERS + HTTP_QUERY_FLAG_SYSTEMTIME + HTTP_QUERY_LANGUAGE + HTTP_QUERY_LAST_MODIFIED + HTTP_QUERY_MESSAGE_ID + HTTP_QUERY_MIME_VERSION + HTTP_QUERY_PRAGMA + HTTP_QUERY_PUBLIC + HTTP_QUERY_RAW_HEADERS + HTTP_QUERY_RAW_HEADERS_CRLF + HTTP_QUERY_REQUEST_METHOD + HTTP_QUERY_SERVER + HTTP_QUERY_STATUS_CODE + HTTP_QUERY_STATUS_TEXT + HTTP_QUERY_URI + HTTP_QUERY_USER_AGENT + HTTP_QUERY_VERSION + HTTP_QUERY_WWW_LINK + ICU_BROWSER_MODE + ICU_DECODE + ICU_ENCODE_SPACES_ONLY + ICU_ESCAPE + ICU_NO_ENCODE + ICU_NO_META + ICU_USERNAME + INTERNET_FLAG_PASSIVE + INTERNET_FLAG_ASYNC + INTERNET_FLAG_HYPERLINK + INTERNET_FLAG_KEEP_CONNECTION + INTERNET_FLAG_MAKE_PERSISTENT + INTERNET_FLAG_NO_AUTH + INTERNET_FLAG_NO_AUTO_REDIRECT + INTERNET_FLAG_NO_CACHE_WRITE + INTERNET_FLAG_NO_COOKIES + INTERNET_FLAG_READ_PREFETCH + INTERNET_FLAG_RELOAD + INTERNET_FLAG_RESYNCHRONIZE + INTERNET_FLAG_TRANSFER_ASCII + INTERNET_FLAG_TRANSFER_BINARY + INTERNET_INVALID_PORT_NUMBER + INTERNET_INVALID_STATUS_CALLBACK + INTERNET_OPEN_TYPE_DIRECT + INTERNET_OPEN_TYPE_PROXY + INTERNET_OPEN_TYPE_PROXY_PRECONFIG + INTERNET_OPTION_CONNECT_BACKOFF + INTERNET_OPTION_CONNECT_RETRIES + INTERNET_OPTION_CONNECT_TIMEOUT + INTERNET_OPTION_CONTROL_SEND_TIMEOUT + INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT + INTERNET_OPTION_DATA_SEND_TIMEOUT + INTERNET_OPTION_DATA_RECEIVE_TIMEOUT + INTERNET_OPTION_HANDLE_TYPE + INTERNET_OPTION_LISTEN_TIMEOUT + INTERNET_OPTION_PASSWORD + INTERNET_OPTION_READ_BUFFER_SIZE + INTERNET_OPTION_USER_AGENT + INTERNET_OPTION_USERNAME + INTERNET_OPTION_VERSION + INTERNET_OPTION_WRITE_BUFFER_SIZE + INTERNET_SERVICE_FTP + INTERNET_SERVICE_GOPHER + INTERNET_SERVICE_HTTP + INTERNET_STATUS_CLOSING_CONNECTION + INTERNET_STATUS_CONNECTED_TO_SERVER + INTERNET_STATUS_CONNECTING_TO_SERVER + INTERNET_STATUS_CONNECTION_CLOSED + INTERNET_STATUS_HANDLE_CLOSING + INTERNET_STATUS_HANDLE_CREATED + INTERNET_STATUS_NAME_RESOLVED + INTERNET_STATUS_RECEIVING_RESPONSE + INTERNET_STATUS_REDIRECT + INTERNET_STATUS_REQUEST_COMPLETE + INTERNET_STATUS_REQUEST_SENT + INTERNET_STATUS_RESOLVING_NAME + INTERNET_STATUS_RESPONSE_RECEIVED + INTERNET_STATUS_SENDING_REQUEST + + +=head1 VERSION HISTORY + +=over + +=item * 0.082 (4 Sep 2001) + +=over + +=item * + +Fix passive FTP mode. INTERNET_FLAG_PASSIVE was misspelled in earlier +versions (as INTERNET_CONNECT_FLAG_PASSIVE) and wouldn't work. Found +by Steve Raynesford <stever@evolvecomm.com>. + +=back + +=item * 0.081 (25 Sep 1999) + +=over + +=item * + +Documentation converted to pod format by Jan Dubois <JanD@ActiveState.com>. + +=item * + +Minor changes from Perl 5.005xx compatibility. + +=back + +=item * 0.08 (14 Feb 1997) + +=over + +=item * + +fixed 2 more bugs in Option(s) related subs (thanks to Brian +Helterline!). + +=item * + +Error() now gets error messages directly from WININET.DLL. + +=item * + +The PLL file now comes in 2 versions, one for Perl version 5.001 +(build 100) and one for Perl version 5.003 (build 300 and +higher). Everybody should be happy now :) + +=item * + +added an installation program. + +=back + +=item * 0.07 (10 Feb 1997) + +=over + +=item * + +fixed a bug in Version() introduced with 0.06... + +=item * + +completely reworked PM file, fixed *lots* of minor bugs, and removed +almost all the warnings with "perl -w". + +=back + +=item * 0.06 (26 Jan 1997) + +=over + +=item * + +fixed another hideous bug in "new" (the 'class' parameter was still +missing). + +=item * + +added support for asynchronous operations (work still in embryo). + +=item * + +removed the ending \0 (ASCII zero) from the DLL version returned by +"Version". + +=item * + +added a lot of constants. + +=item * + +added safefree() after every safemalloc() in C... wonder why I didn't +it before :) + +=item * + +added TimeConvert, which actually works one way only. + +=back + +=item * 0.05f (29 Nov 1996) + +=over + +=item * + +fixed a bug in "new" (parameters passed were simply ignored). + +=item * + +fixed another bug: "Chdir" and "Cwd" were aliases of RMDIR instead of +CD.. + +=back + +=item * 0.05 (29 Nov 1996) + +=over + +=item * + +added "CrackURL" and "CreateURL". + +=item * + +corrected an error in TEST.PL (there was a GetUserAgent instead of +UserAgent). + +=back + +=item * 0.04 (25 Nov 1996) + +=over + +=item * + +added "Version" to retrieve package and DLL versions. + +=item * + +added proxies and other options to "new". + +=item * + +changed "OpenRequest" and "Request" to read parameters from a hash. + +=item * + +added "SetOption/QueryOption" and a lot of relative functions +(connect, username, password, useragent, etc.). + +=item * + +added "CanonicalizeURL" and "CombineURL". + +=item * + +"Error" covers a wider spectrum of errors. + +=back + +=item * 0.02 (18 Nov 1996) + +=over + +=item * + +added support for HTTP sessions and requests. + +=back + +=item * 0.01 (11 Nov 1996) + +=over + +=item * + +fetching of HTTP, FTP and GOPHER URLs. + +=item * + +complete set of commands to manage an FTP session. + +=back + +=back + +=head1 AUTHOR + +Version 0.08 (14 Feb 1997) by Aldo Calpini <a.calpini@romagiubileo.it> + + +=head1 CREDITS + +Win32::Internet is based on the Win32::Registry code written by Jesse +Dougherty. + +Additional thanks to: Carl Tichler for his help in the initial +development; Tore Haraldsen, Brian Helterline for the bugfixes; Dave +Roth for his great source code examples. + + +=head1 DISCLAIMER + +This program is FREE; you can redistribute, modify, disassemble, or +even reverse engineer this software at your will. Keep in mind, +however, that NOTHING IS GUARANTEED to work and everything you do is +AT YOUR OWN RISK - I will not take responsability for any damage, loss +of money and/or health that may arise from the use of this program! + +This is distributed under the terms of Larry Wall's Artistic License. diff --git a/Master/tlpkg/installer/perllib/Win32/Job.pm b/Master/tlpkg/installer/perllib/Win32/Job.pm new file mode 100644 index 00000000000..3350f76400d --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Job.pm @@ -0,0 +1,370 @@ +package Win32::Job; + +use strict; +use base qw(DynaLoader); +use vars qw($VERSION); + +$VERSION = '0.01'; + +use constant WIN32s => 0; +use constant WIN9X => 1; +use constant WINNT => 2; + +require Win32 unless defined &Win32::GetOSVersion; +my @ver = Win32::GetOSVersion; +die "Win32::Job is not supported on $ver[0]" unless ( + $ver[4] == WINNT and ( + $ver[1] > 5 or + ($ver[1] == 5 and $ver[2] > 0) or + ($ver[1] == 5 and $ver[2] == 0 and $ver[3] >= 0) + ) +); + +Win32::Job->bootstrap($VERSION); + +1; + +__END__ + +=head1 NAME + +Win32::Job - Run sub-processes in a "job" environment + +=head1 SYNOPSIS + + use Win32::Job; + + my $job = Win32::Job->new; + + # Run 'perl Makefile.PL' for 10 seconds + $job->spawn($Config{perlpath}, "perl Makefile.PL"); + $job->run(10); + +=head1 PLATFORMS + +Win32::Job requires Windows 2000 or later. Windows 95, 98, NT, and Me are not +supported. + +=head1 DESCRIPTION + +Windows 2000 introduced the concept of a "job": a collection of processes +which can be controlled as a single unit. For example, you can reliably kill a +process and all of its children by launching the process in a job, then +telling Windows to kill all processes in the job. Win32::Job makes this +feature available to Perl. + +For example, imagine you want to allow 2 minutes for a process to complete. +If you have control over the child process, you can probably just run it in +the background, then poll every second to see if it has finished. + +That's fine as long as the child process doesn't spawn any child processes. +What if it does? If you wrote the child process yourself and made an effort to +clean up your child processes before terminating, you don't have to worry. +If not, you will leave hanging processes (called "zombie" processes in Unix). + +With Win32::Job, just create a new Job, then use the job to spawn the child +process. All I<its> children will also be created in the new Job. When you +time out, just call the job's kill() method and the entire process tree will +be terminated. + +=head1 Using Win32::Job + +The following methods are available: + +=over 4 + +=item 1 + +new() + + new(); + +Creates a new Job object using the Win32 API call CreateJobObject(). The job +is created with a default security context, and is unnamed. + +Note: this method returns C<undef> if CreateJobObject() fails. Look at C<$^E> +for more detailed error information. + +=item 2 + +spawn() + + spawn($exe, $args, \%opts); + +Creates a new process and associates it with the Job. The process is initially +suspended, and can be resumed with one of the other methods. Uses the Win32 +API call CreateProcess(). Returns the PID of the newly created process. + +Note: this method returns C<undef> if CreateProcess() fails. See C<$^E> for +more detailed error information. One reason this will fail is if the calling +process is itself part of a job, and the job's security context does not allow +child processes to be created in a different job context than the parent. + +The arguments are described here: + +=over 4 + +=item 1 + +$exe + +The executable program to run. This may be C<undef>, in which case the first +argument in $args is the program to run. + +If this has path information in it, it is used "as is" and passed to +CreateProcess(), which interprets it as either an absolute path, or a +path relative to the current drive and directory. If you did not specify an +extension, ".exe" is assumed. + +If there are no path separators (either backslashes or forward slashes), +then Win32::Job will search the current directory and your PATH, looking +for the file. In addition, if you did not specify an extension, then +Win32::Job checks ".exe", ".com", and ".bat" in order. If it finds a ".bat" +file, Win32::Job will actually call F<cmd.exe> and prepend "cmd.exe" to the +$args. + +For example, assuming a fairly normal PATH: + + spawn(q{c:\winnt\system\cmd.exe}, q{cmd /C "echo %PATH%"}) + exefile: c:\winnt\system\cmd.exe + cmdline: cmd /C "echo %PATH%" + + spawn("cmd.exe", q{cmd /C "echo %PATH%"}) + exefile: c:\winnt\system\cmd.exe + cmdline: cmd /C "echo %PATH%" + +=item 2 + +$args + +The commandline to pass to the executable program. The first word will be +C<argv[0]> to an EXE file, so you should repeat the command name in $args. + +For example: + + $job->spawn($Config{perlpath}, "perl foo.pl"); + +In this case, the "perl" is ignored, since perl.exe doesn't use it. + +=item 3 + +%opts + +A hash reference for advanced options. This parameter is optional. +the following keys are recognized: + +=over 4 + +=item cwd + +A string specifying the current directory of the new process. + +By default, the process shares the parent's current directory, C<.>. + +=item new_console + +A boolean; if true, the process is started in a new console window. + +By default, the process shares the parent's console. This has no effect on GUI +programs which do not interact with the console. + +=item window_attr + +Either C<minimized>, which displays the new window minimized; C<maximimzed>, +which shows the new window maximized; or C<hidden>, which does not display the +new window. + +By default, the window is displayed using its application's defaults. + +=item new_group + +A boolean; if true, the process is the root of a new process group. This +process group includes all descendents of the child. + +By default, the process is in the parent's process group (but in a new job). + +=item no_window + +A boolean; if true, the process is run without a console window. This flag is +only valid when starting a console application, otherwise it is ignored. If you +are launching a GUI application, use the C<window_attr> tag instead. + +By default, the process shares its parent's console. + +=item stdin + +An open input filehandle, or the name of an existing file. The resulting +filehandle will be used for the child's standard input handle. + +By default, the child process shares the parent's standard input. + +=item stdout + +An open output filehandle or filename (will be opened for append). The +resulting filehandle will be used for the child's standard output handle. + +By default, the child process shares the parent's standard output. + +=item stderr + +An open output filehandle or filename (will be opened for append). The +resulting filehandle will be used for the child's standard error handle. + +By default, the child process shares the parent's standard error. + +=back + +Unrecognized keys are ignored. + +=back + +=item 3 + +run() + + run($timeout, $which); + +Provides a simple way to run the programs with a time limit. The +$timeout is in seconds with millisecond accuracy. This call blocks for +up to $timeout seconds, or until the processes finish. + +The $which parameter specifies whether to wait for I<all> processes to +complete within the $timeout, or whether to wait for I<any> process to +complete. You should set this to a boolean, where a true value means to +wait for I<all> the processes to complete, and a false value to wait +for I<any>. If you do not specify $which, it defaults to true (C<all>). + +Returns a boolean indicating whether the processes exited by themselves, +or whether the time expired. A true return value means the processes +exited normally; a false value means one or more processes was killed +will $timeout. + +You can get extended information on process exit codes using the +status() method. + +For example, this is how to build two perl modules at the same time, +with a 5 minute timeout: + + use Win32::Job; + $job = Win32::Job->new; + $job->spawn("cmd", q{cmd /C "cd Mod1 && nmake"}); + $job->spawn("cmd", q{cmd /C "cd Mod2 && nmake"}); + $ok = $job->run(5 * 60); + print "Mod1 and Mod2 built ok!\n" if $ok; + +=item 4 + +watch() + + watch(\&handler, $interval, $which); + + handler($job); + +Provides more fine-grained control over how to stop the programs. You specify +a callback and an interval in seconds, and Win32::Job will call the "watchdog" +function at this interval, either until the processes finish or your watchdog +tells Win32::Job to stop. You must return a value indicating whether to stop: a +true value means to terminate the processes immediately. + +The $which parameter has the same meaning as run()'s. + +Returns a boolean with the same meaning as run()'s. + +The handler may do anything it wants. One useful application of the watch() +method is to check the filesize of the output file, and terminate the Job if +the file becomes larger than a certain limit: + + use Win32::Job; + $job = Win32::Job->new; + $job->spawn("cmd", q{cmd /C "cd Mod1 && nmake"}, { + stdin => 'NUL', # the NUL device + stdout => 'stdout.log', + stderr => 'stdout.log', + }); + $ok = $job->watch(sub { + return 1 if -s "stdout.log" > 1_000_000; + }, 1); + print "Mod1 built ok!\n" if $ok; + +=item 5 + +status() + + status() + +Returns a hash containing information about the processes in the job. +Only returns valid information I<after> calling either run() or watch(); +returns an empty hash if you have not yet called them. May be called from a +watch() callback, in which case the C<exitcode> field should be ignored. + +The keys of the hash are the process IDs; the values are a subhash +containing the following keys: + +=over 4 + +=item exitcode + +The exit code returned by the process. If the process was killed because +of a timeout, the value is 293. + +=item time + +The time accumulated by the process. This is yet another subhash containing +the subkeys (i) C<user>, the amount of time the process spent in user +space; (ii) C<kernel>, the amount of time the process spent in kernel space; +and (iii) C<elapsed>, the total time the process was running. + +=back + +=item 6 + +kill() + + kill(); + +Kills all processes and subprocesses in the Job. Has no return value. +Sets the exit code to all processes killed to 293, which you can check +for in the status() return value. + +=back + +=head1 SEE ALSO + +For more information about jobs, see Microsoft's online help at + + http://msdn.microsoft.com/ + +For other modules which do similar things (but not as well), see: + +=over 4 + +=item 1 + +Win32::Process + +Low-level access to creating processes in Win32. See L<Win32::Process>. + +=item 2 + +Win32::Console + +Low-level access to consoles in Win32. See L<Win32::Console>. + +=item 3 + +Win32::ProcFarm + +Manage pools of threads to perform CPU-intensive tasks on Windows. See +L<Win32::ProcFarm>. + +=back + +=head1 AUTHOR + +ActiveState (support@ActiveState.com) + +=head1 COPYRIGHT + +Copyright (c) 2002, ActiveState Corporation. All Rights Reserved. + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/Mutex.pm b/Master/tlpkg/installer/perllib/Win32/Mutex.pm new file mode 100644 index 00000000000..801c2d35cda --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Mutex.pm @@ -0,0 +1,125 @@ +#--------------------------------------------------------------------- +package Win32::Mutex; +# +# Copyright 1998 Christopher J. Madsen +# +# Created: 3 Feb 1998 from the ActiveWare version +# (c) 1995 Microsoft Corporation. All rights reserved. +# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com +# +# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com> +# +# Author: Christopher J. Madsen <cjm@pobox.com> +# Version: 1.00 (6-Feb-1998) +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# Use Win32 mutex objects for synchronization +#--------------------------------------------------------------------- + +$VERSION = '1.02'; + +use Win32::IPC 1.00 '/./'; # Import everything +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader Win32::IPC); +@EXPORT_OK = qw( + wait_all wait_any +); + +bootstrap Win32::Mutex; + +sub Create { $_[0] = Win32::Mutex->new(@_[1..2]) } +sub Open { $_[0] = Win32::Mutex->open($_[1]) } +sub Release { &release } + +1; +__END__ + +=head1 NAME + +Win32::Mutex - Use Win32 mutex objects from Perl + +=head1 SYNOPSIS + + require Win32::Mutex; + + $mutex = Win32::Mutex->new($initial,$name); + $mutex->wait; + +=head1 DESCRIPTION + +This module allows access to the Win32 mutex objects. The C<wait> +method and C<wait_all> & C<wait_any> functions are inherited from the +L<"Win32::IPC"> module. + +=head2 Methods + +=over 4 + +=item $mutex = Win32::Mutex->new([$initial, [$name]]) + +Constructor for a new mutex object. If C<$initial> is true, requests +immediate ownership of the mutex (default false). If C<$name> is +omitted, creates an unnamed mutex object. + +If C<$name> signifies an existing mutex object, then C<$initial> is +ignored and the object is opened. If this happens, C<$^E> will be set +to 183 (ERROR_ALREADY_EXISTS). + +=item $mutex = Win32::Mutex->open($name) + +Constructor for opening an existing mutex object. + +=item $mutex->release + +Release ownership of a C<$mutex>. You should have obtained ownership +of the mutex through C<new> or one of the wait functions. Returns +true if successful. + +=item $mutex->wait([$timeout]) + +Wait for ownership of C<$mutex>. See L<"Win32::IPC">. + +=back + +=head2 Deprecated Functions and Methods + +B<Win32::Mutex> still supports the ActiveWare syntax, but its use is +deprecated. + +=over 4 + +=item Create($MutObj,$Initial,$Name) + +Use C<$MutObj = Win32::Mutex-E<gt>new($Initial,$Name)> instead. + +=item Open($MutObj,$Name) + +Use C<$MutObj = Win32::Mutex-E<gt>open($Name)> instead. + +=item $MutObj->Release() + +Use C<$MutObj-E<gt>release> instead. + +=back + +=head1 AUTHOR + +Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> + +Loosely based on the original module by ActiveWare Internet Corp., +F<http://www.ActiveWare.com> + +=cut + +# Local Variables: +# tmtrack-file-task: "Win32::Mutex" +# End: diff --git a/Master/tlpkg/installer/perllib/Win32/NetAdmin.pm b/Master/tlpkg/installer/perllib/Win32/NetAdmin.pm new file mode 100644 index 00000000000..ace31a619e4 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/NetAdmin.pm @@ -0,0 +1,419 @@ +package Win32::NetAdmin; + +# +#NetAdmin.pm +#Written by Douglas_Lankshear@ActiveWare.com +# + +$VERSION = '0.08'; + +require Exporter; +require DynaLoader; + +require Win32 unless defined &Win32::IsWinNT; +die "The Win32::NetAdmin module works only on Windows NT" unless Win32::IsWinNT(); + +@ISA= qw( Exporter DynaLoader ); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + DOMAIN_ALIAS_RID_ACCOUNT_OPS + DOMAIN_ALIAS_RID_ADMINS + DOMAIN_ALIAS_RID_BACKUP_OPS + DOMAIN_ALIAS_RID_GUESTS + DOMAIN_ALIAS_RID_POWER_USERS + DOMAIN_ALIAS_RID_PRINT_OPS + DOMAIN_ALIAS_RID_REPLICATOR + DOMAIN_ALIAS_RID_SYSTEM_OPS + DOMAIN_ALIAS_RID_USERS + DOMAIN_GROUP_RID_ADMINS + DOMAIN_GROUP_RID_GUESTS + DOMAIN_GROUP_RID_USERS + DOMAIN_USER_RID_ADMIN + DOMAIN_USER_RID_GUEST + FILTER_TEMP_DUPLICATE_ACCOUNT + FILTER_NORMAL_ACCOUNT + FILTER_INTERDOMAIN_TRUST_ACCOUNT + FILTER_WORKSTATION_TRUST_ACCOUNT + FILTER_SERVER_TRUST_ACCOUNT + SV_TYPE_WORKSTATION + SV_TYPE_SERVER + SV_TYPE_SQLSERVER + SV_TYPE_DOMAIN_CTRL + SV_TYPE_DOMAIN_BAKCTRL + SV_TYPE_TIMESOURCE + SV_TYPE_AFP + SV_TYPE_NOVELL + SV_TYPE_DOMAIN_MEMBER + SV_TYPE_PRINT + SV_TYPE_PRINTQ_SERVER + SV_TYPE_DIALIN + SV_TYPE_DIALIN_SERVER + SV_TYPE_XENIX_SERVER + SV_TYPE_NT + SV_TYPE_WFW + SV_TYPE_POTENTIAL_BROWSER + SV_TYPE_BACKUP_BROWSER + SV_TYPE_MASTER_BROWSER + SV_TYPE_DOMAIN_MASTER + SV_TYPE_DOMAIN_ENUM + SV_TYPE_SERVER_UNIX + SV_TYPE_SERVER_MFPN + SV_TYPE_SERVER_NT + SV_TYPE_SERVER_OSF + SV_TYPE_SERVER_VMS + SV_TYPE_WINDOWS + SV_TYPE_DFS + SV_TYPE_ALTERNATE_XPORT + SV_TYPE_LOCAL_LIST_ONLY + SV_TYPE_ALL + UF_TEMP_DUPLICATE_ACCOUNT + UF_NORMAL_ACCOUNT + UF_INTERDOMAIN_TRUST_ACCOUNT + UF_WORKSTATION_TRUST_ACCOUNT + UF_SERVER_TRUST_ACCOUNT + UF_MACHINE_ACCOUNT_MASK + UF_ACCOUNT_TYPE_MASK + UF_DONT_EXPIRE_PASSWD + UF_SETTABLE_BITS + UF_SCRIPT + UF_ACCOUNTDISABLE + UF_HOMEDIR_REQUIRED + UF_LOCKOUT + UF_PASSWD_NOTREQD + UF_PASSWD_CANT_CHANGE + USE_FORCE + USE_LOTS_OF_FORCE + USE_NOFORCE + USER_PRIV_MASK + USER_PRIV_GUEST + USER_PRIV_USER + USER_PRIV_ADMIN +); + +@EXPORT_OK = qw( + GetError + GetDomainController + GetAnyDomainController + UserCreate + UserDelete + UserGetAttributes + UserSetAttributes + UserChangePassword + UsersExist + GetUsers + GroupCreate + GroupDelete + GroupGetAttributes + GroupSetAttributes + GroupAddUsers + GroupDeleteUsers + GroupIsMember + GroupGetMembers + LocalGroupCreate + LocalGroupDelete + LocalGroupGetAttributes + LocalGroupSetAttributes + LocalGroupIsMember + LocalGroupGetMembers + LocalGroupGetMembersWithDomain + LocalGroupAddUsers + LocalGroupDeleteUsers + GetServers + GetTransports + LoggedOnUsers + GetAliasFromRID + GetUserGroupFromRID + GetServerDisks +); +$EXPORT_TAGS{ALL}= \@EXPORT_OK; + +=head1 NAME + +Win32::NetAdmin - manage network groups and users in perl + +=head1 SYNOPSIS + + use Win32::NetAdmin; + +=head1 DESCRIPTION + +This module offers control over the administration of groups and users over a +network. + +=head1 FUNCTIONS + +=head2 NOTE + +All of the functions return false if they fail, unless otherwise noted. +When a function fails call Win32::NetAdmin::GetError() rather than +GetLastError() or $^E to retrieve the error code. + +C<server> is optional for all the calls below. If not given the local machine is +assumed. + +=over 10 + +=item GetError() + +Returns the error code of the last call to this module. + +=item GetDomainController(server, domain, returnedName) + +Returns the name of the domain controller for server. + +=item GetAnyDomainController(server, domain, returnedName) + +Returns the name of any domain controller for a domain that is directly trusted +by the server. + +=item UserCreate(server, userName, password, passwordAge, privilege, homeDir, comment, flags, scriptPath) + +Creates a user on server with password, passwordAge, privilege, homeDir, comment, +flags, and scriptPath. + +=item UserDelete(server, user) + +Deletes a user from server. + +=item UserGetAttributes(server, userName, password, passwordAge, privilege, homeDir, comment, flags, scriptPath) + +Gets password, passwordAge, privilege, homeDir, comment, flags, and scriptPath +for user. + +=item UserSetAttributes(server, userName, password, passwordAge, privilege, homeDir, comment, flags, scriptPath) + +Sets password, passwordAge, privilege, homeDir, comment, flags, and scriptPath +for user. + +=item UserChangePassword(domainname, username, oldpassword, newpassword) + +Changes a users password. Can be run under any account. + +=item UsersExist(server, userName) + +Checks if a user exists. + +=item GetUsers(server, filter, userRef) + +Fills userRef with user names if it is an array reference and with the user +names and the full names if it is a hash reference. + +=item GroupCreate(server, group, comment) + +Creates a group. + +=item GroupDelete(server, group) + +Deletes a group. + +=item GroupGetAttributes(server, groupName, comment) + +Gets the comment. + +=item GroupSetAttributes(server, groupName, comment) + +Sets the comment. + +=item GroupAddUsers(server, groupName, users) + +Adds a user to a group. + +=item GroupDeleteUsers(server, groupName, users) + +Deletes a users from a group. + +=item GroupIsMember(server, groupName, user) + +Returns TRUE if user is a member of groupName. + +=item GroupGetMembers(server, groupName, userArrayRef) + +Fills userArrayRef with the members of groupName. + +=item LocalGroupCreate(server, group, comment) + +Creates a local group. + +=item LocalGroupDelete(server, group) + +Deletes a local group. + +=item LocalGroupGetAttributes(server, groupName, comment) + +Gets the comment. + +=item LocalGroupSetAttributes(server, groupName, comment) + +Sets the comment. + +=item LocalGroupIsMember(server, groupName, user) + +Returns TRUE if user is a member of groupName. + +=item LocalGroupGetMembers(server, groupName, userArrayRef) + +Fills userArrayRef with the members of groupName. + +=item LocalGroupGetMembersWithDomain(server, groupName, userRef) + +This function is similar LocalGroupGetMembers but accepts an array or +a hash reference. Unlike LocalGroupGetMembers it returns each user name +as C<DOMAIN\USERNAME>. If a hash reference is given, the function +returns to each user or group name the type (group, user, alias etc.). +The possible types are as follows: + + $SidTypeUser = 1; + $SidTypeGroup = 2; + $SidTypeDomain = 3; + $SidTypeAlias = 4; + $SidTypeWellKnownGroup = 5; + $SidTypeDeletedAccount = 6; + $SidTypeInvalid = 7; + $SidTypeUnknown = 8; + +=item LocalGroupAddUsers(server, groupName, users) + +Adds a user to a group. + +=item LocalGroupDeleteUsers(server, groupName, users) + +Deletes a users from a group. + +=item GetServers(server, domain, flags, serverRef) + +Gets an array of server names or an hash with the server names and the +comments as seen in the Network Neighborhood or the server manager. +For flags, see SV_TYPE_* constants. + +=item GetTransports(server, transportRef) + +Enumerates the network transports of a computer. If transportRef is an array +reference, it is filled with the transport names. If transportRef is a hash +reference then a hash of hashes is filled with the data for the transports. + +=item LoggedOnUsers(server, userRef) + +Gets an array or hash with the users logged on at the specified computer. If +userRef is a hash reference, the value is a semikolon separated string of +username, logon domain and logon server. + +=item GetAliasFromRID(server, RID, returnedName) + +=item GetUserGroupFromRID(server, RID, returnedName) + +Retrieves the name of an alias (i.e local group) or a user group for a RID +from the specified server. These functions can be used for example to get the +account name for the administrator account if it is renamed or localized. + +Possible values for C<RID>: + + DOMAIN_ALIAS_RID_ACCOUNT_OPS + DOMAIN_ALIAS_RID_ADMINS + DOMAIN_ALIAS_RID_BACKUP_OPS + DOMAIN_ALIAS_RID_GUESTS + DOMAIN_ALIAS_RID_POWER_USERS + DOMAIN_ALIAS_RID_PRINT_OPS + DOMAIN_ALIAS_RID_REPLICATOR + DOMAIN_ALIAS_RID_SYSTEM_OPS + DOMAIN_ALIAS_RID_USERS + DOMAIN_GROUP_RID_ADMINS + DOMAIN_GROUP_RID_GUESTS + DOMAIN_GROUP_RID_USERS + DOMAIN_USER_RID_ADMIN + DOMAIN_USER_RID_GUEST + +=item GetServerDisks(server, arrayRef) + +Returns an array with the disk drives of the specified server. The array +contains two-character strings (drive letter followed by a colon). + +=back + +=head1 EXAMPLE + + # Simple script using Win32::NetAdmin to set the login script for + # all members of the NT group "Domain Users". Only works if you + # run it on the PDC. (From Robert Spier <rspier@seas.upenn.edu>) + # + # FILTER_TEMP_DUPLICATE_ACCOUNTS + # Enumerates local user account data on a domain controller. + # + # FILTER_NORMAL_ACCOUNT + # Enumerates global user account data on a computer. + # + # FILTER_INTERDOMAIN_TRUST_ACCOUNT + # Enumerates domain trust account data on a domain controller. + # + # FILTER_WORKSTATION_TRUST_ACCOUNT + # Enumerates workstation or member server account data on a domain + # controller. + # + # FILTER_SERVER_TRUST_ACCOUNT + # Enumerates domain controller account data on a domain controller. + + + use Win32::NetAdmin qw(GetUsers GroupIsMember + UserGetAttributes UserSetAttributes); + + my %hash; + GetUsers("", FILTER_NORMAL_ACCOUNT , \%hash) + or die "GetUsers() failed: $^E"; + + foreach (keys %hash) { + my ($password, $passwordAge, $privilege, + $homeDir, $comment, $flags, $scriptPath); + if (GroupIsMember("", "Domain Users", $_)) { + print "Updating $_ ($hash{$_})\n"; + UserGetAttributes("", $_, $password, $passwordAge, $privilege, + $homeDir, $comment, $flags, $scriptPath) + or die "UserGetAttributes() failed: $^E"; + $scriptPath = "dnx_login.bat"; # this is the new login script + UserSetAttributes("", $_, $password, $passwordAge, $privilege, + $homeDir, $comment, $flags, $scriptPath) + or die "UserSetAttributes() failed: $^E"; + } + } + +=cut + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::NetAdmin macro $constname, used in $file at line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +$SidTypeUser = 1; +$SidTypeGroup = 2; +$SidTypeDomain = 3; +$SidTypeAlias = 4; +$SidTypeWellKnownGroup = 5; +$SidTypeDeletedAccount = 6; +$SidTypeInvalid = 7; +$SidTypeUnknown = 8; + +sub GetError() { + our $__lastError; + $__lastError; +} + +bootstrap Win32::NetAdmin; + +1; +__END__ + diff --git a/Master/tlpkg/installer/perllib/Win32/NetResource.pm b/Master/tlpkg/installer/perllib/Win32/NetResource.pm new file mode 100644 index 00000000000..04ac87acabd --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/NetResource.pm @@ -0,0 +1,456 @@ +package Win32::NetResource; + +require Exporter; +require DynaLoader; +require AutoLoader; + +$VERSION = '0.053'; + +@ISA = qw(Exporter DynaLoader); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + RESOURCEDISPLAYTYPE_DOMAIN + RESOURCEDISPLAYTYPE_FILE + RESOURCEDISPLAYTYPE_GENERIC + RESOURCEDISPLAYTYPE_GROUP + RESOURCEDISPLAYTYPE_SERVER + RESOURCEDISPLAYTYPE_SHARE + RESOURCEDISPLAYTYPE_TREE + RESOURCETYPE_ANY + RESOURCETYPE_DISK + RESOURCETYPE_PRINT + RESOURCETYPE_UNKNOWN + RESOURCEUSAGE_CONNECTABLE + RESOURCEUSAGE_CONTAINER + RESOURCEUSAGE_RESERVED + RESOURCE_CONNECTED + RESOURCE_GLOBALNET + RESOURCE_REMEMBERED + STYPE_DISKTREE + STYPE_PRINTQ + STYPE_DEVICE + STYPE_IPC + STYPE_SPECIAL + SHARE_NETNAME_PARMNUM + SHARE_TYPE_PARMNUM + SHARE_REMARK_PARMNUM + SHARE_PERMISSIONS_PARMNUM + SHARE_MAX_USES_PARMNUM + SHARE_CURRENT_USES_PARMNUM + SHARE_PATH_PARMNUM + SHARE_PASSWD_PARMNUM + SHARE_FILE_SD_PARMNUM +); + +@EXPORT_OK = qw( + GetSharedResources + AddConnection + CancelConnection + WNetGetLastError + GetError + GetUNCName + NetShareAdd + NetShareCheck + NetShareDel + NetShareGetInfo + NetShareSetInfo +); + +=head1 NAME + +Win32::NetResource - manage network resources in perl + +=head1 SYNOPSIS + + use Win32::NetResource; + + $ShareInfo = { + 'path' => "C:\\MyShareDir", + 'netname' => "MyShare", + 'remark' => "It is good to share", + 'passwd' => "", + 'current-users' =>0, + 'permissions' => 0, + 'maxusers' => -1, + 'type' => 0, + }; + + Win32::NetResource::NetShareAdd( $ShareInfo,$parm ) + or die "unable to add share"; + + +=head1 DESCRIPTION + +This module offers control over the network resources of Win32.Disks, +printers etc can be shared over a network. + +=head1 DATA TYPES + +There are two main data types required to control network resources. +In Perl these are represented by hash types. + +=over 4 + +=item %NETRESOURCE + + KEY VALUE + + 'Scope' => Scope of an Enumeration + RESOURCE_CONNECTED, + RESOURCE_GLOBALNET, + RESOURCE_REMEMBERED. + + 'Type' => The type of resource to Enum + RESOURCETYPE_ANY All resources + RESOURCETYPE_DISK Disk resources + RESOURCETYPE_PRINT Print resources + + 'DisplayType' => The way the resource should be displayed. + RESOURCEDISPLAYTYPE_DOMAIN + The object should be displayed as a domain. + RESOURCEDISPLAYTYPE_GENERIC + The method used to display the object does not matter. + RESOURCEDISPLAYTYPE_SERVER + The object should be displayed as a server. + RESOURCEDISPLAYTYPE_SHARE + The object should be displayed as a sharepoint. + + 'Usage' => Specifies the Resources usage: + RESOURCEUSAGE_CONNECTABLE + RESOURCEUSAGE_CONTAINER. + + 'LocalName' => Name of the local device the resource is + connected to. + + 'RemoteName' => The network name of the resource. + + 'Comment' => A string comment. + + 'Provider' => Name of the provider of the resource. + +=back + +=item %SHARE_INFO + +This hash represents the SHARE_INFO_502 struct. + +=over 4 + + KEY VALUE + 'netname' => Name of the share. + 'type' => type of share. + 'remark' => A string comment. + 'permissions' => Permissions value + 'maxusers' => the max # of users. + 'current-users' => the current # of users. + 'path' => The path of the share. + 'passwd' => A password if one is req'd + +=back + +=head1 FUNCTIONS + +=head2 NOTE + +All of the functions return false if they fail. + +=over 4 + +=item GetSharedResources(\@Resources,dwType,\%NetResource = NULL) + +Creates a list in @Resources of %NETRESOURCE hash references. + +The return value indicates whether there was an error in accessing +any of the shared resources. All the shared resources that were +encountered (until the point of an error, if any) are pushed into +@Resources as references to %NETRESOURCE hashes. See example +below. The \%NetResource argument is optional. If it is not supplied, +the root (that is, the topmost container) of the network is assumed, +and all network resources available from the toplevel container will +be enumerated. + +=item AddConnection(\%NETRESOURCE,$Password,$UserName,$Connection) + +Makes a connection to a network resource specified by %NETRESOURCE + +=item CancelConnection($Name,$Connection,$Force) + +Cancels a connection to a network resource connected to local device +$name.$Connection is either 1 - persistent connection or 0, non-persistent. + +=item WNetGetLastError($ErrorCode,$Description,$Name) + +Gets the Extended Network Error. + +=item GetError( $ErrorCode ) + +Gets the last Error for a Win32::NetResource call. + +=item GetUNCName( $UNCName, $LocalPath ); + +Returns the UNC name of the disk share connected to $LocalPath in $UNCName. +$LocalPath should be a drive based path. e.g. "C:\\share\\subdir" + +=back + +=head2 NOTE + +$servername is optional for all the calls below. (if not given the +local machine is assumed.) + +=over 4 + +=item NetShareAdd(\%SHARE,$parm_err,$servername = NULL ) + +Add a share for sharing. + +=item NetShareCheck($device,$type,$servername = NULL ) + +Check if a directory or a device is available for connection from the +network through a share. This includes all directories that are +reachable through a shared directory or device, meaning that if C:\foo +is shared, C:\foo\bar is also available for sharing. This means that +this function is pretty useless, given that by default every disk +volume has an administrative share such as "C$" associated with its +root directory. + +$device must be a drive name, directory, or a device. For example, +"C:", "C:\dir", "LPT1", "D$", "IPC$" are all valid as the $device +argument. $type is an output argument that will be set to one of +the following constants that describe the type of share: + + STYPE_DISKTREE Disk drive + STYPE_PRINTQ Print queue + STYPE_DEVICE Communication device + STYPE_IPC Interprocess communication (IPC) + STYPE_SPECIAL Special share reserved for interprocess + communication (IPC$) or remote administration + of the server (ADMIN$). Can also refer to + administrative shares such as C$, D$, etc. + +=item NetShareDel( $netname, $servername = NULL ) + +Remove a share from a machines list of shares. + +=item NetShareGetInfo( $netname, \%SHARE,$servername=NULL ) + +Get the %SHARE_INFO information about the share $netname on the +server $servername. + +=item NetShareSetInfo( $netname,\%SHARE,$parm_err,$servername=NULL) + +Set the information for share $netname. + +=back + +=head1 EXAMPLE + +=over 4 + +=item Enumerating all resources on the network + + # + # This example displays all the share points in the entire + # visible part of the network. + # + + use strict; + use Win32::NetResource qw(:DEFAULT GetSharedResources GetError); + my $resources = []; + unless(GetSharedResources($resources, RESOURCETYPE_ANY)) { + my $err; + GetError($err); + warn Win32::FormatMessage($err); + } + + foreach my $href (@$resources) { + next if ($$href{DisplayType} != RESOURCEDISPLAYTYPE_SHARE); + print "-----\n"; + foreach( keys %$href){ + print "$_: $href->{$_}\n"; + } + } + +=item Enumerating all resources on a particular host + + # + # This example displays all the share points exported by the local + # host. + # + + use strict; + use Win32::NetResource qw(:DEFAULT GetSharedResources GetError); + if (GetSharedResources(my $resources, RESOURCETYPE_ANY, + { RemoteName => "\\\\" . Win32::NodeName() })) + { + foreach my $href (@$resources) { + print "-----\n"; + foreach(keys %$href) { print "$_: $href->{$_}\n"; } + } + } + +=back + +=head1 AUTHOR + +Jesse Dougherty for Hip Communications. + +Additional general cleanups and bug fixes by Gurusamy Sarathy <gsar@activestate.com>. + +=cut + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::NetResource macro $constname, used at $file line $line. +"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +sub AddConnection +{ + my $h = $_[0]; + die "AddConnection: HASH reference required" unless ref($h) eq "HASH"; + + # + # The last four items *must* not be deallocated until the + # _AddConnection() completes (since the packed structure is + # pointing into these values. + # + my $netres = pack( 'i4 p4', $h->{Scope}, + $h->{Type}, + $h->{DisplayType}, + $h->{Usage}, + $h->{LocalName}, + $h->{RemoteName}, + $h->{Comment}, + $h->{Provider}); + _AddConnection($netres,$_[1],$_[2],$_[3]); +} + +#use Data::Dumper; + +sub GetSharedResources +{ + die "GetSharedResources: ARRAY reference required" + if defined $_[0] and ref($_[0]) ne "ARRAY"; + + my $aref = []; + + # Get the shared resources. + + my $ret; + + if (@_ > 2 and $_[2]) { + my $netres = pack('i4 p4', @{$_[2]}{qw(Scope + Type + DisplayType + Usage + LocalName + RemoteName + Comment + Provider)}); + $ret = _GetSharedResources( $aref , $_[1], $netres ); + } + else { + $ret = _GetSharedResources( $aref , $_[1] ); + } + + # build the array of hashes in $_[0] +# print Dumper($aref); + foreach ( @$aref ) { + my %hash; + @hash{'Scope', + 'Type', + 'DisplayType', + 'Usage', + 'LocalName', + 'RemoteName', + 'Comment', + 'Provider'} = split /\001/, $_; + push @{$_[0]}, \%hash; + } + + $ret; +} + +sub NetShareAdd +{ + my $shareinfo = _hash2SHARE( $_[0] ); + _NetShareAdd($shareinfo,$_[1], $_[2] || ""); +} + +sub NetShareGetInfo +{ + my ($netinfo,$val); + $val = _NetShareGetInfo( $_[0],$netinfo,$_[2] || ""); + %{$_[1]} = %{_SHARE2hash( $netinfo )}; + $val; +} + +sub NetShareSetInfo +{ + my $shareinfo = _hash2SHARE( $_[1] ); + _NetShareSetInfo( $_[0],$shareinfo,$_[2],$_[3] || ""); +} + + +# These are private functions to work with the ShareInfo structure. +# please note that the implementation of these calls requires the +# SHARE_INFO_502 level of information. + +sub _SHARE2hash +{ + my %hash = (); + @hash{'type', + 'permissions', + 'maxusers', + 'current-users', + 'remark', + 'netname', + 'path', + 'passwd'} = unpack('i4 A257 A81 A257 A257',$_[0]); + + return \%hash; +} + +sub _hash2SHARE +{ + my $h = $_[0]; + die "Argument must be a HASH reference" unless ref($h) eq "HASH"; + + return pack 'i4 a257 a81 a257 a257', + @$h{'type', + 'permissions', + 'maxusers', + 'current-users', + 'remark', + 'netname', + 'path', + 'passwd'}; +} + + +bootstrap Win32::NetResource; + +1; +__END__ diff --git a/Master/tlpkg/installer/perllib/Win32/ODBC.pm b/Master/tlpkg/installer/perllib/Win32/ODBC.pm new file mode 100644 index 00000000000..a51616388ea --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/ODBC.pm @@ -0,0 +1,1493 @@ +package Win32::ODBC; + +$VERSION = '0.032'; + +# Win32::ODBC.pm +# +==========================================================+ +# | | +# | ODBC.PM package | +# | --------------- | +# | | +# | Copyright (c) 1996, 1997 Dave Roth. All rights reserved. | +# | This program is free software; you can redistribute | +# | it and/or modify it under the same terms as Perl itself. | +# | | +# +==========================================================+ +# +# +# based on original code by Dan DeMaggio (dmag@umich.edu) +# +# Use under GNU General Public License or Larry Wall's "Artistic License" +# +# Check the README.TXT file that comes with this package for details about +# it's history. +# + +require Exporter; +require DynaLoader; + +$ODBCPackage = "Win32::ODBC"; +$ODBCPackage::Version = 970208; +$::ODBC = $ODBCPackage; +$CacheConnection = 0; + + # Reserve ODBC in the main namespace for US! +*ODBC::=\%Win32::ODBC::; + + +@ISA= qw( Exporter DynaLoader ); + # Items to export into callers namespace by default. Note: do not export + # names by default without a very good reason. Use EXPORT_OK instead. + # Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + ODBC_ADD_DSN + ODBC_REMOVE_DSN + ODBC_CONFIG_DSN + ODBC_ADD_SYS_DSN + ODBC_REMOVE_SYS_DSN + ODBC_CONFIG_SYS_DSN + + SQL_DONT_CLOSE + SQL_DROP + SQL_CLOSE + SQL_UNBIND + SQL_RESET_PARAMS + + SQL_FETCH_NEXT + SQL_FETCH_FIRST + SQL_FETCH_LAST + SQL_FETCH_PRIOR + SQL_FETCH_ABSOLUTE + SQL_FETCH_RELATIVE + SQL_FETCH_BOOKMARK + + SQL_COLUMN_COUNT + SQL_COLUMN_NAME + SQL_COLUMN_TYPE + SQL_COLUMN_LENGTH + SQL_COLUMN_PRECISION + SQL_COLUMN_SCALE + SQL_COLUMN_DISPLAY_SIZE + SQL_COLUMN_NULLABLE + SQL_COLUMN_UNSIGNED + SQL_COLUMN_MONEY + SQL_COLUMN_UPDATABLE + SQL_COLUMN_AUTO_INCREMENT + SQL_COLUMN_CASE_SENSITIVE + SQL_COLUMN_SEARCHABLE + SQL_COLUMN_TYPE_NAME + SQL_COLUMN_TABLE_NAME + SQL_COLUMN_OWNER_NAME + SQL_COLUMN_QUALIFIER_NAME + SQL_COLUMN_LABEL + SQL_COLATT_OPT_MAX + SQL_COLUMN_DRIVER_START + SQL_COLATT_OPT_MIN + SQL_ATTR_READONLY + SQL_ATTR_WRITE + SQL_ATTR_READWRITE_UNKNOWN + SQL_UNSEARCHABLE + SQL_LIKE_ONLY + SQL_ALL_EXCEPT_LIKE + SQL_SEARCHABLE + ); + #The above are included for backward compatibility + + +sub new +{ + my ($n, $self); + my ($type) = shift; + my ($DSN) = shift; + my (@Results) = @_; + + if (ref $DSN){ + @Results = ODBCClone($DSN->{'connection'}); + }else{ + @Results = ODBCConnect($DSN, @Results); + } + @Results = processError(-1, @Results); + if (! scalar(@Results)){ + return undef; + } + $self = bless {}; + $self->{'connection'} = $Results[0]; + $ErrConn = $Results[0]; + $ErrText = $Results[1]; + $ErrNum = 0; + $self->{'DSN'} = $DSN; + $self; +} + +#### +# Close this ODBC session (or all sessions) +#### +sub Close +{ + my ($self, $Result) = shift; + $Result = DESTROY($self); + $self->{'connection'} = -1; + return $Result; +} + +#### +# Auto-Kill an instance of this module +#### +sub DESTROY +{ + my ($self) = shift; + my (@Results) = (0); + if($self->{'connection'} > -1){ + @Results = ODBCDisconnect($self->{'connection'}); + @Results = processError($self, @Results); + if ($Results[0]){ + undef $self->{'DSN'}; + undef @{$self->{'fnames'}}; + undef %{$self->{'field'}}; + undef %{$self->{'connection'}}; + } + } + return $Results[0]; +} + + +sub sql{ + return (Sql(@_)); +} + +#### +# Submit an SQL Execute statement for processing +#### +sub Sql{ + my ($self, $Sql, @Results) = @_; + @Results = ODBCExecute($self->{'connection'}, $Sql); + return updateResults($self, @Results); +} + +#### +# Retrieve data from a particular field +#### +sub Data{ + + # Change by JOC 06-APR-96 + # Altered by Dave Roth <dave@roth.net> 96.05.07 + my($self) = shift; + my(@Fields) = @_; + my(@Results, $Results, $Field); + + if ($self->{'Dirty'}){ + GetData($self); + $self->{'Dirty'} = 0; + } + @Fields = @{$self->{'fnames'}} if (! scalar(@Fields)); + foreach $Field (@Fields) { + if (wantarray) { + push(@Results, data($self, $Field)); + } else { + $Results .= data($self, $Field); + } + } + return wantarray ? @Results : $Results; +} + +sub DataHash{ + my($self, @Results) = @_; + my(%Results, $Element); + + if ($self->{'Dirty'}){ + GetData($self); + $self->{'Dirty'} = 0; + } + @Results = @{$self->{'fnames'}} if (! scalar(@Results)); + foreach $Element (@Results) { + $Results{$Element} = data($self, $Element); + } + + return %Results; +} + +#### +# Retrieve data from the data buffer +#### +sub data +{ $_[0]->{'data'}->{$_[1]}; } + + +sub fetchrow{ + return (FetchRow(@_)); +} +#### +# Put a row from an ODBC data set into data buffer +#### +sub FetchRow{ + my ($self, @Results) = @_; + my ($item, $num, $sqlcode); + # Added by JOC 06-APR-96 + # $num = 0; + $num = 0; + undef $self->{'data'}; + + + @Results = ODBCFetch($self->{'connection'}, @Results); + if (! (@Results = processError($self, @Results))){ + #### + # There should be an innocuous error "No records remain" + # This indicates no more records in the dataset + #### + return undef; + } + # Set the Dirty bit so we will go and extract data via the + # ODBCGetData function. Otherwise use the cache. + $self->{'Dirty'} = 1; + + # Return the array of field Results. + return @Results; +} + +sub GetData{ + my($self) = @_; + my @Results; + my $num = 0; + + @Results = ODBCGetData($self->{'connection'}); + if (!(@Results = processError($self, @Results))){ + return undef; + } + #### + # This is a special case. Do not call processResults + #### + ClearError(); + foreach (@Results){ + s/ +$// if defined $_; # HACK + $self->{'data'}->{ ${$self->{'fnames'}}[$num] } = $_; + $num++; + } + # return is a hack to interface with a assoc array. + return wantarray? (1, 1): 1; +} + +#### +# See if any more ODBC Results Sets +# Added by Brian Dunfordshore <Brian_Dunfordshore@bridge.com> +# 96.07.10 +#### +sub MoreResults{ + my ($self) = @_; + + my(@Results) = ODBCMoreResults($self->{'connection'}); + return (processError($self, @Results))[0]; +} + +#### +# Retrieve the catalog from the current DSN +# NOTE: All Field names are uppercase!!! +#### +sub Catalog{ + my ($self) = shift; + my ($Qualifier, $Owner, $Name, $Type) = @_; + my (@Results) = ODBCTableList($self->{'connection'}, $Qualifier, $Owner, $Name, $Type); + + # If there was an error return 0 else 1 + return (updateResults($self, @Results) != 1); +} + +#### +# Return an array of names from the catalog for the current DSN +# TableList($Qualifier, $Owner, $Name, $Type) +# Return: (array of names of tables) +# NOTE: All Field names are uppercase!!! +#### +sub TableList{ + my ($self) = shift; + my (@Results) = @_; + if (! scalar(@Results)){ + @Results = ("", "", "%", "TABLE"); + } + + if (! Catalog($self, @Results)){ + return undef; + } + undef @Results; + while (FetchRow($self)){ + push(@Results, Data($self, "TABLE_NAME")); + } + return sort(@Results); +} + + +sub fieldnames{ + return (FieldNames(@_)); +} +#### +# Return an array of fieldnames extracted from the current dataset +#### +sub FieldNames { $self = shift; return @{$self->{'fnames'}}; } + + +#### +# Closes this connection. This is used mostly for testing. You should +# probably use Close(). +#### +sub ShutDown{ + my($self) = @_; + print "\nClosing connection $self->{'connection'}..."; + $self->Close(); + print "\nDone\n"; +} + +#### +# Return this connection number +#### +sub Connection{ + my($self) = @_; + return $self->{'connection'}; +} + +#### +# Returns the current connections that are in use. +#### +sub GetConnections{ + return ODBCGetConnections(); +} + +#### +# Set the Max Buffer Size for this connection. This determines just how much +# ram can be allocated when a fetch() is performed that requires a HUGE amount +# of memory. The default max is 10k and the absolute max is 100k. +# This will probably never be used but I put it in because I noticed a fetch() +# of a MEMO field in an Access table was something like 4Gig. Maybe I did +# something wrong, but after checking several times I decided to impliment +# this limit thingie. +#### +sub SetMaxBufSize{ + my($self, $Size) = @_; + my(@Results) = ODBCSetMaxBufSize($self->{'connection'}, $Size); + return (processError($self, @Results))[0]; +} + +#### +# Returns the Max Buffer Size for this connection. See SetMaxBufSize(). +#### +sub GetMaxBufSize{ + my($self) = @_; + my(@Results) = ODBCGetMaxBufSize($self->{'connection'}); + return (processError($self, @Results))[0]; +} + + +#### +# Returns the DSN for this connection as an associative array. +#### +sub GetDSN{ + my($self, $DSN) = @_; + if(! ref($self)){ + $DSN = $self; + $self = 0; + } + if (! $DSN){ + $self = $self->{'connection'}; + } + my(@Results) = ODBCGetDSN($self, $DSN); + return (processError($self, @Results)); +} + +#### +# Returns an associative array of $XXX{'DSN'}=Description +#### +sub DataSources{ + my($self, $DSN) = @_; + if(! ref $self){ + $DSN = $self; + $self = 0; + } + my(@Results) = ODBCDataSources($DSN); + return (processError($self, @Results)); +} + +#### +# Returns an associative array of $XXX{'Driver Name'}=Driver Attributes +#### +sub Drivers{ + my($self) = @_; + if(! ref $self){ + $self = 0; + } + my(@Results) = ODBCDrivers(); + return (processError($self, @Results)); +} + +#### +# Returns the number of Rows that were affected by the previous SQL command. +#### +sub RowCount{ + my($self, $Connection) = @_; + if (! ref($self)){ + $Connection = $self; + $self = 0; + } + if (! $Connection){$Connection = $self->{'connection'};} + my(@Results) = ODBCRowCount($Connection); + return (processError($self, @Results))[0]; +} + +#### +# Returns the Statement Close Type -- how does ODBC Close a statment. +# Types: +# SQL_DROP +# SQL_CLOSE +# SQL_UNBIND +# SQL_RESET_PARAMS +#### +sub GetStmtCloseType{ + my($self, $Connection) = @_; + if (! ref($self)){ + $Connection = $self; + $self = 0; + } + if (! $Connection){$Connection = $self->{'connection'};} + my(@Results) = ODBCGetStmtCloseType($Connection); + return (processError($self, @Results)); +} + +#### +# Sets the Statement Close Type -- how does ODBC Close a statment. +# Types: +# SQL_DROP +# SQL_CLOSE +# SQL_UNBIND +# SQL_RESET_PARAMS +# Returns the newly set value. +#### +sub SetStmtCloseType{ + my($self, $Type, $Connection) = @_; + if (! ref($self)){ + $Connection = $Type; + $Type = $self; + $self = 0; + } + if (! $Connection){$Connection = $self->{'connection'};} + my(@Results) = ODBCSetStmtCloseType($Connection, $Type); + return (processError($self, @Results))[0]; +} + +sub ColAttributes{ + my($self, $Type, @Field) = @_; + my(%Results, @Results, $Results, $Attrib, $Connection, $Temp); + if (! ref($self)){ + $Type = $Field; + $Field = $self; + $self = 0; + } + $Connection = $self->{'connection'}; + if (! scalar(@Field)){ @Field = $self->fieldnames;} + foreach $Temp (@Field){ + @Results = ODBCColAttributes($Connection, $Temp, $Type); + ($Attrib) = processError($self, @Results); + if (wantarray){ + $Results{$Temp} = $Attrib; + }else{ + $Results .= "$Temp"; + } + } + return wantarray? %Results:$Results; +} + +sub GetInfo{ + my($self, $Type) = @_; + my($Connection, @Results); + if(! ref $self){ + $Type = $self; + $self = 0; + $Connection = 0; + }else{ + $Connection = $self->{'connection'}; + } + @Results = ODBCGetInfo($Connection, $Type); + return (processError($self, @Results))[0]; +} + +sub GetConnectOption{ + my($self, $Type) = @_; + my(@Results); + if(! ref $self){ + $Type = $self; + $self = 0; + } + @Results = ODBCGetConnectOption($self->{'connection'}, $Type); + return (processError($self, @Results))[0]; +} + +sub SetConnectOption{ + my($self, $Type, $Value) = @_; + if(! ref $self){ + $Value = $Type; + $Type = $self; + $self = 0; + } + my(@Results) = ODBCSetConnectOption($self->{'connection'}, $Type, $Value); + return (processError($self, @Results))[0]; +} + + +sub Transact{ + my($self, $Type) = @_; + my(@Results); + if(! ref $self){ + $Type = $self; + $self = 0; + } + @Results = ODBCTransact($self->{'connection'}, $Type); + return (processError($self, @Results))[0]; +} + + +sub SetPos{ + my($self, @Results) = @_; + @Results = ODBCSetPos($self->{'connection'}, @Results); + $self->{'Dirty'} = 1; + return (processError($self, @Results))[0]; +} + +sub ConfigDSN{ + my($self) = shift @_; + my($Type, $Connection); + if(! ref $self){ + $Type = $self; + $Connection = 0; + $self = 0; + }else{ + $Type = shift @_; + $Connection = $self->{'connection'}; + } + my($Driver, @Attributes) = @_; + @Results = ODBCConfigDSN($Connection, $Type, $Driver, @Attributes); + return (processError($self, @Results))[0]; +} + + +sub Version{ + my($self, @Packages) = @_; + my($Temp, @Results); + if (! ref($self)){ + push(@Packages, $self); + } + my($ExtName, $ExtVersion) = Info(); + if (! scalar(@Packages)){ + @Packages = ("ODBC.PM", "ODBC.PLL"); + } + foreach $Temp (@Packages){ + if ($Temp =~ /pll/i){ + push(@Results, "ODBC.PM:$Win32::ODBC::Version"); + }elsif ($Temp =~ /pm/i){ + push(@Results, "ODBC.PLL:$ExtVersion"); + } + } + return @Results; +} + + +sub SetStmtOption{ + my($self, $Option, $Value) = @_; + if(! ref $self){ + $Value = $Option; + $Option = $self; + $self = 0; + } + my(@Results) = ODBCSetStmtOption($self->{'connection'}, $Option, $Value); + return (processError($self, @Results))[0]; +} + +sub GetStmtOption{ + my($self, $Type) = @_; + if(! ref $self){ + $Type = $self; + $self = 0; + } + my(@Results) = ODBCGetStmtOption($self->{'connection'}, $Type); + return (processError($self, @Results))[0]; +} + +sub GetFunctions{ + my($self, @Results)=@_; + @Results = ODBCGetFunctions($self->{'connection'}, @Results); + return (processError($self, @Results)); +} + +sub DropCursor{ + my($self) = @_; + my(@Results) = ODBCDropCursor($self->{'connection'}); + return (processError($self, @Results))[0]; +} + +sub SetCursorName{ + my($self, $Name) = @_; + my(@Results) = ODBCSetCursorName($self->{'connection'}, $Name); + return (processError($self, @Results))[0]; +} + +sub GetCursorName{ + my($self) = @_; + my(@Results) = ODBCGetCursorName($self->{'connection'}); + return (processError($self, @Results))[0]; +} + +sub GetSQLState{ + my($self) = @_; + my(@Results) = ODBCGetSQLState($self->{'connection'}); + return (processError($self, @Results))[0]; +} + + +# ----------- R e s u l t P r o c e s s i n g F u n c t i o n s ---------- +#### +# Generic processing of data into associative arrays +#### +sub updateResults{ + my ($self, $Error, @Results) = @_; + + undef %{$self->{'field'}}; + + ClearError($self); + if ($Error){ + SetError($self, $Results[0], $Results[1]); + return ($Error); + } + + @{$self->{'fnames'}} = @Results; + + foreach (0..$#{$self->{'fnames'}}){ + s/ +$//; + $self->{'field'}->{${$self->{'fnames'}}[$_]} = $_; + } + return undef; +} + +# ---------------------------------------------------------------------------- +# ----------------- D e b u g g i n g F u n c t i o n s -------------------- + +sub Debug{ + my($self, $iDebug, $File) = @_; + my(@Results); + if (! ref($self)){ + if (defined $self){ + $File = $iDebug; + $iDebug = $self; + } + $Connection = 0; + $self = 0; + }else{ + $Connection = $self->{'connection'}; + } + push(@Results, ($Connection, $iDebug)); + push(@Results, $File) if ($File ne ""); + @Results = ODBCDebug(@Results); + return (processError($self, @Results))[0]; +} + +#### +# Prints out the current dataset (used mostly for testing) +#### +sub DumpData { + my($self) = @_; my($f, $goo); + + # Changed by JOC 06-Apr-96 + # print "\nDumping Data for connection: $conn->{'connection'}\n"; + print "\nDumping Data for connection: $self->{'connection'}\n"; + print "Error: \""; + print $self->Error(); + print "\"\n"; + if (! $self->Error()){ + foreach $f ($self->FieldNames){ + print $f . " "; + $goo .= "-" x length($f); + $goo .= " "; + } + print "\n$goo\n"; + while ($self->FetchRow()){ + foreach $f ($self->FieldNames){ + print $self->Data($f) . " "; + } + print "\n"; + } + } +} + +sub DumpError{ + my($self) = @_; + my($ErrNum, $ErrText, $ErrConn); + my($Temp); + + print "\n---------- Error Report: ----------\n"; + if (ref $self){ + ($ErrNum, $ErrText, $ErrConn) = $self->Error(); + ($Temp = $self->GetDSN()) =~ s/.*DSN=(.*?);.*/$1/i; + print "Errors for \"$Temp\" on connection " . $self->{'connection'} . ":\n"; + }else{ + ($ErrNum, $ErrText, $ErrConn) = Error(); + print "Errors for the package:\n"; + } + + print "Connection Number: $ErrConn\nError number: $ErrNum\nError message: \"$ErrText\"\n"; + print "-----------------------------------\n"; + +} + +#### +# Submit an SQL statement and print data about it (used mostly for testing) +#### +sub Run{ + my($self, $Sql) = @_; + + print "\nExcecuting connection $self->{'connection'}\nsql statement: \"$Sql\"\n"; + $self->Sql($Sql); + print "Error: \""; + print $self->error; + print "\"\n"; + print "--------------------\n\n"; +} + +# ---------------------------------------------------------------------------- +# ----------- E r r o r P r o c e s s i n g F u n c t i o n s ------------ + +#### +# Process Errors returned from a call to ODBCxxxx(). +# It is assumed that the Win32::ODBC function returned the following structure: +# ($ErrorNumber, $ResultsText, ...) +# $ErrorNumber....0 = No Error +# >0 = Error Number +# $ResultsText.....if no error then this is the first Results element. +# if error then this is the error text. +#### +sub processError{ + my($self, $Error, @Results) = @_; + if ($Error){ + SetError($self, $Results[0], $Results[1]); + undef @Results; + } + return @Results; +} + +#### +# Return the last recorded error message +#### +sub error{ + return (Error(@_)); +} + +sub Error{ + my($self) = @_; + if(ref($self)){ + if($self->{'ErrNum'}){ + my($State) = ODBCGetSQLState($self->{'connection'}); + return (wantarray)? ($self->{'ErrNum'}, $self->{'ErrText'}, $self->{'connection'}, $State) :"[$self->{'ErrNum'}] [$self->{'connection'}] [$State] \"$self->{'ErrText'}\""; + } + }elsif ($ErrNum){ + return (wantarray)? ($ErrNum, $ErrText, $ErrConn):"[$ErrNum] [$ErrConn] \"$ErrText\""; + } + return undef +} + +#### +# SetError: +# Assume that if $self is not a reference then it is just a placeholder +# and should be ignored. +#### +sub SetError{ + my($self, $Num, $Text, $Conn) = @_; + if (ref $self){ + $self->{'ErrNum'} = $Num; + $self->{'ErrText'} = $Text; + $Conn = $self->{'connection'} if ! $Conn; + } + $ErrNum = $Num; + $ErrText = $Text; + + #### + # Test Section Begin + #### +# $! = ($Num, $Text); + #### + # Test Section End + #### + + $ErrConn = $Conn; +} + +sub ClearError{ + my($self, $Num, $Text) = @_; + if (ref $self){ + undef $self->{'ErrNum'}; + undef $self->{'ErrText'}; + }else{ + undef $ErrConn; + undef $ErrNum; + undef $ErrText; + } + ODBCCleanError(); + return 1; +} + + +sub GetError{ + my($self, $Connection) = @_; + my(@Results); + if (! ref($self)){ + $Connection = $self; + $self = 0; + }else{ + if (! defined($Connection)){ + $Connection = $self->{'connection'}; + } + } + + @Results = ODBCGetError($Connection); + return @Results; +} + + + + +# ---------------------------------------------------------------------------- +# ------------------ A U T O L O A D F U N C T I O N ----------------------- + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + $val = constant($constname); + + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + + # Added by JOC 06-APR-96 + # $pack = 0; + $pack = 0; + ($pack,$file,$line) = caller; + print "Your vendor has not defined Win32::ODBC macro $constname, used in $file at line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + + # -------------------------------------------------------------- + # + # + # Make sure that we shutdown ODBC and free memory even if we are + # using perlis.dll on Win32 platform! +END{ +# ODBCShutDown() unless $CacheConnection; +} + + +bootstrap Win32::ODBC; + +# Preloaded methods go here. + +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ + +=head1 NAME + +Win32::ODBC - ODBC Extension for Win32 + +=head1 SYNOPSIS + +To use this module, include the following statement at the top of your +script: + + use Win32::ODBC; + +Next, create a data connection to your DSN: + + $Data = new Win32::ODBC("MyDSN"); + +B<NOTE>: I<MyDSN> can be either the I<DSN> as defined in the ODBC +Administrator, I<or> it can be an honest-to-God I<DSN Connect String>. + + Example: "DSN=My Database;UID=Brown Cow;PWD=Moo;" + +You should check to see if C<$Data> is indeed defined, otherwise there +has been an error. + +You can now send SQL queries and retrieve info to your heart's +content! See the description of the methods provided by this module +below and also the file F<TEST.PL> as referred to in L<INSTALLATION +NOTES> to see how it all works. + +Finally, B<MAKE SURE> that you close your connection when you are +finished: + + $Data->Close(); + +=head1 DESCRIPTION + +=head2 Background + +This is a hack of Dan DeMaggio's <dmag@umich.edu> F<NTXS.C> ODBC +implementation. I have recoded and restructured most of it including +most of the F<ODBC.PM> package, but its very core is still based on +Dan's code (thanks Dan!). + +The history of this extension is found in the file F<HISTORY.TXT> that +comes with the original archive (see L<INSTALLATION NOTES> below). + +=head2 Benefits + +And what are the benefits of this module? + +=over + +=item * + +The number of ODBC connections is limited by memory and ODBC itself +(have as many as you want!). + +=item * + +The working limit for the size of a field is 10,240 bytes, but you can +increase that limit (if needed) to a max of 2,147,483,647 bytes. (You +can always recompile to increase the max limit.) + +=item * + +You can open a connection by either specifing a DSN or a connection +string! + +=item * + +You can open and close the connections in any order! + +=item * + +Other things that I can not think of right now... :) + +=back + +=head1 CONSTANTS + +This package defines a number of constants. You may refer to each of +these constants using the notation C<ODBC::xxxxx>, where C<xxxxx> is +the constant. + +Example: + + print ODBC::SQL_SQL_COLUMN_NAME, "\n"; + +=head1 SPECIAL NOTATION + +For the method documentation that follows, an B<*> following the +method parameters indicates that that method is new or has been +modified for this version. + +=head1 CONSTRUCTOR + +=over + +=item new ( ODBC_OBJECT | DSN [, (OPTION1, VALUE1), (OPTION2, VALUE2) ...] ) +* + +Creates a new ODBC connection based on C<DSN>, or, if you specify an +already existing ODBC object, then a new ODBC object will be created +but using the ODBC Connection specified by C<ODBC_OBJECT>. (The new +object will be a new I<hstmt> using the I<hdbc> connection in +C<ODBC_OBJECT>.) + +C<DSN> is I<Data Source Name> or a proper C<ODBCDriverConnect> string. + +You can specify SQL Connect Options that are implemented before the +actual connection to the DSN takes place. These option/values are the +same as specified in C<GetConnectOption>/C<SetConnectOption> (see +below) and are defined in the ODBC API specs. + +Returns a handle to the database on success, or I<undef> on failure. + +=back + +=head1 METHODS + +=over + +=item Catalog ( QUALIFIER, OWNER, NAME, TYPE ) + +Tells ODBC to create a data set that contains table information about +the DSN. Use C<Fetch> and C<Data> or C<DataHash> to retrieve the data. +The returned format is: + + [Qualifier] [Owner] [Name] [Type] + +Returns I<true> on error. + +=item ColAttributes ( ATTRIBUTE [, FIELD_NAMES ] ) + +Returns the attribute C<ATTRIBUTE> on each of the fields in the list +C<FIELD_NAMES> in the current record set. If C<FIELD_NAMES> is empty, +then all fields are assumed. The attributes are returned as an +associative array. + +=item ConfigDSN ( OPTION, DRIVER, ATTRIBUTE1 [, ATTRIBUTE2, ATTRIBUTE3, ... +] ) + +Configures a DSN. C<OPTION> takes on one of the following values: + + ODBC_ADD_DSN.......Adds a new DSN. + ODBC_MODIFY_DSN....Modifies an existing DSN. + ODBC_REMOVE_DSN....Removes an existing DSN. + + ODBC_ADD_SYS_DSN.......Adds a new System DSN. + ODBC_MODIFY_SYS_DSN....Modifies an existing System DSN. + ODBC_REMOVE_SYS_DSN....Removes an existing System DSN. + +You must specify the driver C<DRIVER> (which can be retrieved by using +C<DataSources> or C<Drivers>). + +C<ATTRIBUTE1> B<should> be I<"DSN=xxx"> where I<xxx> is the name of +the DSN. Other attributes can be any DSN attribute such as: + + "UID=Cow" + "PWD=Moo" + "Description=My little bitty Data Source Name" + +Returns I<true> on success, I<false> on failure. + +B<NOTE 1>: If you use C<ODBC_ADD_DSN>, then you must include at least +I<"DSN=xxx"> and the location of the database. + +Example: For MS Access databases, you must specify the +I<DatabaseQualifier>: + + "DBQ=c:\\...\\MyDatabase.mdb" + +B<NOTE 2>: If you use C<ODBC_MODIFY_DSN>, then you need only specify +the I<"DNS=xxx"> attribute. Any other attribute you include will be +changed to what you specify. + +B<NOTE 3>: If you use C<ODBC_REMOVE_DSN>, then you need only specify +the I<"DSN=xxx"> attribute. + +=item Connection () + +Returns the connection number associated with the ODBC connection. + +=item Close () + +Closes the ODBC connection. No return value. + +=item Data ( [ FIELD_NAME ] ) + +Returns the contents of column name C<FIELD_NAME> or the current row +(if nothing is specified). + +=item DataHash ( [ FIELD1, FIELD2, ... ] ) + +Returns the contents for C<FIELD1, FIELD2, ...> or the entire row (if +nothing is specified) as an associative array consisting of: + + {Field Name} => Field Data + +=item DataSources () + +Returns an associative array of Data Sources and ODBC remarks about them. +They are returned in the form of: + + $ArrayName{'DSN'}=Driver + +where I<DSN> is the Data Source Name and ODBC Driver used. + +=item Debug ( [ 1 | 0 ] ) + +Sets the debug option to on or off. If nothing is specified, then +nothing is changed. + +Returns the debugging value (I<1> or I<0>). + +=item Drivers () + +Returns an associative array of ODBC Drivers and their attributes. +They are returned in the form of: + + $ArrayName{'DRIVER'}=Attrib1;Attrib2;Attrib3;... + +where I<DRIVER> is the ODBC Driver Name and I<AttribX> are the +driver-defined attributes. + +=item DropCursor ( [ CLOSE_TYPE ] ) + +Drops the cursor associated with the ODBC object. This forces the +cursor to be deallocated. This overrides C<SetStmtCloseType>, but the +ODBC object does not lose the C<StmtCloseType> setting. C<CLOSE_TYPE> +can be any valid C<SmtpCloseType> and will perform a close on the stmt +using the specified close type. + +Returns I<true> on success, I<false> on failure. + +=item DumpData () + +Dumps to the screen the fieldnames and all records of the current data +set. Used primarily for debugging. No return value. + +=item Error () + +Returns the last encountered error. The returned value is context +dependent: + +If called in a I<scalar> context, then a I<3-element array> is +returned: + + ( ERROR_NUMBER, ERROR_TEXT, CONNECTION_NUMBER ) + +If called in a I<string> context, then a I<string> is returned: + + "[ERROR_NUMBER] [CONNECTION_NUMBER] [ERROR_TEXT]" + +If debugging is on then two more variables are returned: + + ( ..., FUNCTION, LEVEL ) + +where C<FUNCTION> is the name of the function in which the error +occurred, and C<LEVEL> represents extra information about the error +(usually the location of the error). + +=item FetchRow ( [ ROW [, TYPE ] ] ) + +Retrieves the next record from the keyset. When C<ROW> and/or C<TYPE> +are specified, the call is made using C<SQLExtendedFetch> instead of +C<SQLFetch>. + +B<NOTE 1>: If you are unaware of C<SQLExtendedFetch> and its +implications, stay with just regular C<FetchRow> with no parameters. + +B<NOTE 2>: The ODBC API explicitly warns against mixing calls to +C<SQLFetch> and C<SQLExtendedFetch>; use one or the other but not +both. + +If I<ROW> is specified, it moves the keyset B<RELATIVE> C<ROW> number +of rows. + +If I<ROW> is specified and C<TYPE> is B<not>, then the type used is +B<RELATIVE>. + +Returns I<true> when another record is available to read, and I<false> +when there are no more records. + +=item FieldNames () + +Returns an array of fieldnames found in the current data set. There is +no guarantee on order. + +=item GetConnections () + +Returns an array of connection numbers showing what connections are +currently open. + +=item GetConnectOption ( OPTION ) + +Returns the value of the specified connect option C<OPTION>. Refer to +ODBC documentation for more information on the options and values. + +Returns a string or scalar depending upon the option specified. + +=item GetCursorName () + +Returns the name of the current cursor as a string or I<undef>. + +=item GetData () + +Retrieves the current row from the dataset. This is not generally +used by users; it is used internally. + +Returns an array of field data where the first element is either +I<false> (if successful) and I<true> (if B<not> successful). + +=item getDSN ( [ DSN ] ) + +Returns an associative array indicating the configuration for the +specified DSN. + +If no DSN is specified then the current connection is used. + +The returned associative array consists of: + + keys=DSN keyword; values=Keyword value. $Data{$Keyword}=Value + +=item GetFunctions ( [ FUNCTION1, FUNCTION2, ... ] ) + +Returns an associative array indicating the ability of the ODBC Driver +to support the specified functions. If no functions are specified, +then a 100 element associative array is returned containing all +possible functions and their values. + +C<FUNCTION> must be in the form of an ODBC API constant like +C<SQL_API_SQLTRANSACT>. + +The returned array will contain the results like: + + $Results{SQL_API_SQLTRANSACT}=Value + +Example: + + $Results = $O->GetFunctions( + $O->SQL_API_SQLTRANSACT, + SQL_API_SQLSETCONNECTOPTION + ); + $ConnectOption = $Results{SQL_API_SQLSETCONNECTOPTION}; + $Transact = $Results{SQL_API_SQLTRANSACT}; + +=item GetInfo ( OPTION ) + +Returns a string indicating the value of the particular +option specified. + +=item GetMaxBufSize () + +Returns the current allocated limit for I<MaxBufSize>. For more info, +see C<SetMaxBufSize>. + +=item GetSQLState () * + +Returns a string indicating the SQL state as reported by ODBC. The SQL +state is a code that the ODBC Manager or ODBC Driver returns after the +execution of a SQL function. This is helpful for debugging purposes. + +=item GetStmtCloseType ( [ CONNECTION ] ) + +Returns a string indicating the type of closure that will be used +everytime the I<hstmt> is freed. See C<SetStmtCloseType> for details. + +By default, the connection of the current object will be used. If +C<CONNECTION> is a valid connection number, then it will be used. + +=item GetStmtOption ( OPTION ) + +Returns the value of the specified statement option C<OPTION>. Refer +to ODBC documentation for more information on the options and values. + +Returns a string or scalar depending upon the option specified. + +=item MoreResults () + +This will report whether there is data yet to be retrieved from the +query. This can happen if the query was a multiple select. + +Example: + + "SELECT * FROM [foo] SELECT * FROM [bar]" + +B<NOTE>: Not all drivers support this. + +Returns I<1> if there is more data, I<undef> otherwise. + +=item RowCount ( CONNECTION ) + +For I<UPDATE>, I<INSERT> and I<DELETE> statements, the returned value +is the number of rows affected by the request or I<-1> if the number +of affected rows is not available. + +B<NOTE 1>: This function is not supported by all ODBC drivers! Some +drivers do support this but not for all statements (e.g., it is +supported for I<UPDATE>, I<INSERT> and I<DELETE> commands but not for +the I<SELECT> command). + +B<NOTE 2>: Many data sources cannot return the number of rows in a +result set before fetching them; for maximum interoperability, +applications should not rely on this behavior. + +Returns the number of affected rows, or I<-1> if not supported by the +driver in the current context. + +=item Run ( SQL ) + +Executes the SQL command B<SQL> and dumps to the screen info about +it. Used primarily for debugging. + +No return value. + +=item SetConnectOption ( OPTION ) * + +Sets the value of the specified connect option B<OPTION>. Refer to +ODBC documentation for more information on the options and values. + +Returns I<true> on success, I<false> otherwise. + +=item SetCursorName ( NAME ) * + +Sets the name of the current cursor. + +Returns I<true> on success, I<false> otherwise. + +=item SetPos ( ROW [, OPTION, LOCK ] ) * + +Moves the cursor to the row C<ROW> within the current keyset (B<not> +the current data/result set). + +Returns I<true> on success, I<false> otherwise. + +=item SetMaxBufSize ( SIZE ) + +This sets the I<MaxBufSize> for a particular connection. This will +most likely never be needed but... + +The amount of memory that is allocated to retrieve the field data of a +record is dynamic and changes when it need to be larger. I found that +a memo field in an MS Access database ended up requesting 4 Gig of +space. This was a bit much so there is an imposed limit (2,147,483,647 +bytes) that can be allocated for data retrieval. + +Since it is possible that someone has a database with field data +greater than 10,240, you can use this function to increase the limit +up to a ceiling of 2,147,483,647 (recompile if you need more). + +Returns the max number of bytes. + +=item SetStmtCloseType ( TYPE [, CONNECTION ] ) + +Sets a particular I<hstmt> close type for the connection. This is the +same as C<ODBCFreeStmt(hstmt, TYPE)>. By default, the connection of +the current object will be used. If C<CONNECTION> is a valid +connection number, then it will be used. + +C<TYPE> may be one of: + + SQL_CLOSE + SQL_DROP + SQL_UNBIND + SQL_RESET_PARAMS + +Returns a string indicating the newly set type. + +=item SetStmtOption ( OPTION ) * + +Sets the value of the specified statement option C<OPTION>. Refer to +ODBC documentation for more information on the options and values. + +Returns I<true> on success, I<false> otherwise. + +=item ShutDown () + +Closes the ODBC connection and dumps to the screen info about +it. Used primarily for debugging. + +No return value. + +=item Sql ( SQL_STRING ) + +Executes the SQL command C<SQL_STRING> on the current connection. + +Returns I<?> on success, or an error number on failure. + +=item TableList ( QUALIFIER, OWNER, NAME, TYPE ) + +Returns the catalog of tables that are available in the DSN. For an +unknown parameter, just specify the empty string I<"">. + +Returns an array of table names. + +=item Transact ( TYPE ) * + +Forces the ODBC connection to perform a I<rollback> or I<commit> +transaction. + +C<TYPE> may be one of: + + SQL_COMMIT + SQL_ROLLBACK + +B<NOTE>: This only works with ODBC drivers that support transactions. +Your driver supports it if I<true> is returned from: + + $O->GetFunctions($O->SQL_API_SQLTRANSACT)[1] + +(See C<GetFunctions> for more details.) + +Returns I<true> on success, I<false> otherwise. + +=item Version ( PACKAGES ) + +Returns an array of version numbers for the requested packages +(F<ODBC.pm> or F<ODBC.PLL>). If the list C<PACKAGES> is empty, then +all version numbers are returned. + +=back + +=head1 LIMITATIONS + +What known problems does this thing have? + +=over + +=item * + +If the account under which the process runs does not have write +permission on the default directory (for the process, not the ODBC +DSN), you will probably get a runtime error during a +C<SQLConnection>. I don't think that this is a problem with the code, +but more like a problem with ODBC. This happens because some ODBC +drivers need to write a temporary file. I noticed this using the MS +Jet Engine (Access Driver). + +=item * + +This module has been neither optimized for speed nor optimized for +memory consumption. + +=back + +=head1 INSTALLATION NOTES + +If you wish to use this module with a build of Perl other than +ActivePerl, you may wish to fetch the original source distribution for +this module at: + + ftp://ftp.roth.net:/pub/ntperl/ODBC/970208/Bin/Win32_ODBC_Build_CORE.zip + +or one of the other archives at that same location. See the included +README for hints on installing this module manually, what to do if you +get a I<parse exception>, and a pointer to a test script for this +module. + +=head1 OTHER DOCUMENTATION + +Find a FAQ for Win32::ODBC at: + + http://www.roth.net/odbc/odbcfaq.htm + +=head1 AUTHOR + +Dave Roth <rothd@roth.net> + +=head1 CREDITS + +Based on original code by Dan DeMaggio <dmag@umich.edu> + +=head1 DISCLAIMER + +I do not guarantee B<ANYTHING> with this package. If you use it you +are doing so B<AT YOUR OWN RISK>! I may or may not support this +depending on my time schedule. + +=head1 HISTORY + +Last Modified 1999.09.25. + +=head1 COPYRIGHT + +Copyright (c) 1996-1998 Dave Roth. All rights reserved. + +Courtesy of Roth Consulting: http://www.roth.net/consult/ + +Use under GNU General Public License. Details can be found at: +http://www.gnu.org/copyleft/gpl.html + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/PerfLib.pm b/Master/tlpkg/installer/perllib/Win32/PerfLib.pm new file mode 100644 index 00000000000..2b773d68f4b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/PerfLib.pm @@ -0,0 +1,538 @@ +package Win32::PerfLib; + +use strict; +use Carp; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); + +require Exporter; +require DynaLoader; +require AutoLoader; + +@ISA = qw(Exporter DynaLoader); + +@EXPORT = qw( + PERF_100NSEC_MULTI_TIMER + PERF_100NSEC_MULTI_TIMER_INV + PERF_100NSEC_TIMER + PERF_100NSEC_TIMER_INV + PERF_AVERAGE_BASE + PERF_AVERAGE_BULK + PERF_AVERAGE_TIMER + PERF_COUNTER_BASE + PERF_COUNTER_BULK_COUNT + PERF_COUNTER_COUNTER + PERF_COUNTER_DELTA + PERF_COUNTER_ELAPSED + PERF_COUNTER_FRACTION + PERF_COUNTER_HISTOGRAM + PERF_COUNTER_HISTOGRAM_TYPE + PERF_COUNTER_LARGE_DELTA + PERF_COUNTER_LARGE_QUEUELEN_TYPE + PERF_COUNTER_LARGE_RAWCOUNT + PERF_COUNTER_LARGE_RAWCOUNT_HEX + PERF_COUNTER_MULTI_BASE + PERF_COUNTER_MULTI_TIMER + PERF_COUNTER_MULTI_TIMER_INV + PERF_COUNTER_NODATA + PERF_COUNTER_QUEUELEN + PERF_COUNTER_QUEUELEN_TYPE + PERF_COUNTER_RATE + PERF_COUNTER_RAWCOUNT + PERF_COUNTER_RAWCOUNT_HEX + PERF_COUNTER_TEXT + PERF_COUNTER_TIMER + PERF_COUNTER_TIMER_INV + PERF_COUNTER_VALUE + PERF_DATA_REVISION + PERF_DATA_VERSION + PERF_DELTA_BASE + PERF_DELTA_COUNTER + PERF_DETAIL_ADVANCED + PERF_DETAIL_EXPERT + PERF_DETAIL_NOVICE + PERF_DETAIL_WIZARD + PERF_DISPLAY_NOSHOW + PERF_DISPLAY_NO_SUFFIX + PERF_DISPLAY_PERCENT + PERF_DISPLAY_PER_SEC + PERF_DISPLAY_SECONDS + PERF_ELAPSED_TIME + PERF_INVERSE_COUNTER + PERF_MULTI_COUNTER + PERF_NO_INSTANCES + PERF_NO_UNIQUE_ID + PERF_NUMBER_DECIMAL + PERF_NUMBER_DEC_1000 + PERF_NUMBER_HEX + PERF_OBJECT_TIMER + PERF_RAW_BASE + PERF_RAW_FRACTION + PERF_SAMPLE_BASE + PERF_SAMPLE_COUNTER + PERF_SAMPLE_FRACTION + PERF_SIZE_DWORD + PERF_SIZE_LARGE + PERF_SIZE_VARIABLE_LEN + PERF_SIZE_ZERO + PERF_TEXT_ASCII + PERF_TEXT_UNICODE + PERF_TIMER_100NS + PERF_TIMER_TICK + PERF_TYPE_COUNTER + PERF_TYPE_NUMBER + PERF_TYPE_TEXT + PERF_TYPE_ZERO + ); + +$VERSION = '0.05'; + +sub AUTOLOAD { + + my $constname; + ($constname = $AUTOLOAD) =~ s/.*:://; + local $! = 0; + my $val = constant($constname); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + croak "Your vendor has not defined Win32::PerfLib macro $constname"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::PerfLib $VERSION; + +# Preloaded methods go here. + +sub new +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $comp = shift; + my $handle; + my $self = {}; + if(PerfLibOpen($comp,$handle)) + { + $self->{handle} = $handle; + bless $self, $class; + return $self; + } + else + { + return undef; + } + +} + +sub Close +{ + my $self = shift; + return PerfLibClose($self->{handle}); +} + +sub DESTROY +{ + my $self = shift; + if(!PerfLibClose($self->{handle})) + { + croak "Error closing handle!\n"; + } +} + +sub GetCounterNames +{ + my($machine,$href) = @_; + if(ref $href ne "HASH") + { + croak("usage: Win32::PerfLib::GetCounterNames(machine,hashRef)\n"); + } + my($data,@data,$num,$name); + my $retval = PerfLibGetNames($machine,$data); + if($retval) + { + @data = split(/\0/, $data); + while(@data) + { + $num = shift @data; + $name = shift @data; + $href->{$num} = $name; + } + } + $retval; +} + +sub GetCounterHelp +{ + my($machine,$href) = @_; + if(ref $href ne "HASH") + { + croak("usage: Win32::PerfLib::GetCounterHelp(machine,hashRef)\n"); + } + my($data,@data,$num,$name); + my $retval = PerfLibGetHelp($machine,$data); + if($retval) + { + @data = split(/\0/, $data); + while(@data) + { + $num = shift @data; + $name = shift @data; + $href->{$num} = $name; + } + } + $retval; +} + +sub GetObjectList +{ + my $self = shift; + my $object = shift; + my $data = shift; + if(ref $data ne "HASH") + { + croak("reference isn't a hash reference!\n"); + } + return PerfLibGetObjects($self->{handle}, $object, $data); +} + +sub GetCounterType +{ + my $type = shift; + my $retval; + if( &Win32::PerfLib::PERF_100NSEC_MULTI_TIMER == $type ) + { + $retval = "PERF_100NSEC_MULTI_TIMER"; + } + elsif( &Win32::PerfLib::PERF_100NSEC_MULTI_TIMER_INV == $type ) + { + $retval = "PERF_100NSEC_MULTI_TIMER_INV"; + } + elsif( &Win32::PerfLib::PERF_100NSEC_TIMER == $type ) + { + $retval = "PERF_100NSEC_TIMER"; + } + elsif( &Win32::PerfLib::PERF_100NSEC_TIMER_INV == $type ) + { + $retval = "PERF_100NSEC_TIMER_INV"; + } + elsif( &Win32::PerfLib::PERF_AVERAGE_BASE == $type ) + { + $retval = "PERF_AVERAGE_BASE"; + } + elsif( &Win32::PerfLib::PERF_AVERAGE_BULK == $type ) + { + $retval = "PERF_AVERAGE_BULK"; + } + elsif( &Win32::PerfLib::PERF_AVERAGE_TIMER == $type ) + { + $retval = "PERF_AVERAGE_TIMER"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_BULK_COUNT == $type ) + { + $retval = "PERF_COUNTER_BULK_COUNT"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_COUNTER == $type ) + { + $retval = "PERF_COUNTER_COUNTER"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_DELTA == $type ) + { + $retval = "PERF_COUNTER_DELTA"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_DELTA == $type ) + { + $retval = "PERF_COUNTER_LARGE_DELTA"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_QUEUELEN_TYPE == $type ) + { + $retval = "PERF_COUNTER_LARGE_QUEUELEN_TYPE"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_RAWCOUNT == $type ) + { + $retval = "PERF_COUNTER_LARGE_RAWCOUNT"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_LARGE_RAWCOUNT_HEX == $type ) + { + $retval = "PERF_COUNTER_LARGE_RAWCOUNT_HEX"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_MULTI_BASE == $type ) + { + $retval = "PERF_COUNTER_MULTI_BASE"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_MULTI_TIMER == $type ) + { + $retval = "PERF_COUNTER_MULTI_TIMER"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_MULTI_TIMER_INV == $type ) + { + $retval = "PERF_COUNTER_MULTI_TIMER_INV"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_NODATA == $type ) + { + $retval = "PERF_COUNTER_NODATA"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_QUEUELEN_TYPE == $type ) + { + $retval = "PERF_COUNTER_QUEUELEN_TYPE"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_RAWCOUNT == $type ) + { + $retval = "PERF_COUNTER_RAWCOUNT"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_RAWCOUNT_HEX == $type ) + { + $retval = "PERF_COUNTER_RAWCOUNT_HEX"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_TEXT == $type ) + { + $retval = "PERF_COUNTER_TEXT"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_TIMER == $type ) + { + $retval = "PERF_COUNTER_TIMER"; + } + elsif( &Win32::PerfLib::PERF_COUNTER_TIMER_INV == $type ) + { + $retval = "PERF_COUNTER_TIMER_INV"; + } + elsif( &Win32::PerfLib::PERF_ELAPSED_TIME == $type ) + { + $retval = "PERF_ELAPSED_TIME"; + } + elsif( &Win32::PerfLib::PERF_RAW_BASE == $type ) + { + $retval = "PERF_RAW_BASE"; + } + elsif( &Win32::PerfLib::PERF_RAW_FRACTION == $type ) + { + $retval = "PERF_RAW_FRACTION"; + } + elsif( &Win32::PerfLib::PERF_SAMPLE_BASE == $type ) + { + $retval = "PERF_SAMPLE_BASE"; + } + elsif( &Win32::PerfLib::PERF_SAMPLE_COUNTER == $type ) + { + $retval = "PERF_SAMPLE_COUNTER"; + } + elsif( &Win32::PerfLib::PERF_SAMPLE_FRACTION == $type ) + { + $retval = "PERF_SAMPLE_FRACTION"; + } + $retval; +} + + + +1; +__END__ + +=head1 NAME + +Win32::PerfLib - accessing the Windows NT Performance Counter + +=head1 SYNOPSIS + + use Win32::PerfLib; + my $server = ""; + Win32::PerfLib::GetCounterNames($server, \%counter); + %r_counter = map { $counter{$_} => $_ } keys %counter; + # retrieve the id for process object + $process_obj = $r_counter{Process}; + # retrieve the id for the process ID counter + $process_id = $r_counter{'ID Process'}; + + # create connection to $server + $perflib = new Win32::PerfLib($server); + $proc_ref = {}; + # get the performance data for the process object + $perflib->GetObjectList($process_obj, $proc_ref); + $perflib->Close(); + $instance_ref = $proc_ref->{Objects}->{$process_obj}->{Instances}; + foreach $p (sort keys %{$instance_ref}) + { + $counter_ref = $instance_ref->{$p}->{Counters}; + foreach $i (keys %{$counter_ref}) + { + if($counter_ref->{$i}->{CounterNameTitleIndex} == $process_id) + { + printf( "% 6d %s\n", $counter_ref->{$i}->{Counter}, + $instance_ref->{$p}->{Name} + ); + } + } + } + +=head1 DESCRIPTION + +This module allows to retrieve the performance counter of any computer +(running Windows NT) in the network. + +=head1 FUNCTIONS + +=head2 NOTE + +All of the functions return false if they fail, unless otherwise noted. +If the $server argument is undef the local machine is assumed. + +=over 10 + +=item Win32::PerfLib::GetCounterNames($server,$hashref) + +Retrieves the counter names and their indices from the registry and stores them +in the hash reference + +=item Win32::PerfLib::GetCounterHelp($server,$hashref) + +Retrieves the counter help strings and their indices from the registry and +stores them in the hash reference + +=item $perflib = Win32::PerfLib->new ($server) + +Creates a connection to the performance counters of the given server + +=item $perflib->GetObjectList($objectid,$hashref) + +retrieves the object and counter list of the given performance object. + +=item $perflib->Close($hashref) + +closes the connection to the performance counters + +=item Win32::PerfLib::GetCounterType(countertype) + +converts the counter type to readable string as referenced in L<calc.html> so +that it is easier to find the appropriate formula to calculate the raw counter +data. + +=back + +=head1 Datastructures + +The performance data is returned in the following data structure: + +=over 10 + +=item Level 1 + + $hashref = { + 'NumObjectTypes' => VALUE + 'Objects' => HASHREF + 'PerfFreq' => VALUE + 'PerfTime' => VALUE + 'PerfTime100nSec' => VALUE + 'SystemName' => STRING + 'SystemTime' => VALUE + } + +=item Level 2 + +The hash reference $hashref->{Objects} has the returned object ID(s) as keys and +a hash reference to the object counter data as value. Even there is only one +object requested in the call to GetObjectList there may be more than one object +in the result. + + $hashref->{Objects} = { + <object1> => HASHREF + <object2> => HASHREF + ... + } + +=item Level 3 + +Each returned object ID has object-specific performance information. If an +object has instances like the process object there is also a reference to +the instance information. + + $hashref->{Objects}->{<object1>} = { + 'DetailLevel' => VALUE + 'Instances' => HASHREF + 'Counters' => HASHREF + 'NumCounters' => VALUE + 'NumInstances' => VALUE + 'ObjectHelpTitleIndex' => VALUE + 'ObjectNameTitleIndex' => VALUE + 'PerfFreq' => VALUE + 'PerfTime' => VALUE + } + +=item Level 4 + +If there are instance information for the object available they are stored in +the 'Instances' hashref. If the object has no instances there is an 'Counters' +key instead. The instances or counters are numbered. + + $hashref->{Objects}->{<object1>}->{Instances} = { + <1> => HASHREF + <2> => HASHREF + ... + <n> => HASHREF + } + or + $hashref->{Objects}->{<object1>}->{Counters} = { + <1> => HASHREF + <2> => HASHREF + ... + <n> => HASHREF + } + +=item Level 5 + + $hashref->{Objects}->{<object1>}->{Instances}->{<1>} = { + Counters => HASHREF + Name => STRING + ParentObjectInstance => VALUE + ParentObjectTitleIndex => VALUE + } + or + $hashref->{Objects}->{<object1>}->{Counters}->{<1>} = { + Counter => VALUE + CounterHelpTitleIndex => VALUE + CounterNameTitleIndex => VALUE + CounterSize => VALUE + CounterType => VALUE + DefaultScale => VALUE + DetailLevel => VALUE + Display => STRING + } + +=item Level 6 + + $hashref->{Objects}->{<object1>}->{Instances}->{<1>}->{Counters} = { + <1> => HASHREF + <2> => HASHREF + ... + <n> => HASHREF + } + +=item Level 7 + + $hashref->{Objects}->{<object1>}->{Instances}->{<1>}->{Counters}->{<1>} = { + Counter => VALUE + CounterHelpTitleIndex => VALUE + CounterNameTitleIndex => VALUE + CounterSize => VALUE + CounterType => VALUE + DefaultScale => VALUE + DetailLevel => VALUE + Display => STRING + } + +Depending on the B<CounterType> there are calculations to do (see calc.html). + +=back + +=head1 AUTHOR + +Jutta M. Klebe, jmk@bybyte.de + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/Pipe.pm b/Master/tlpkg/installer/perllib/Win32/Pipe.pm new file mode 100644 index 00000000000..a99d5a0da08 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Pipe.pm @@ -0,0 +1,414 @@ +package Win32::Pipe; + +$VERSION = '0.022'; + +# Win32::Pipe.pm +# +==========================================================+ +# | | +# | PIPE.PM package | +# | --------------- | +# | Release v96.05.11 | +# | | +# | Copyright (c) 1996 Dave Roth. All rights reserved. | +# | This program is free software; you can redistribute | +# | it and/or modify it under the same terms as Perl itself. | +# | | +# +==========================================================+ +# +# +# Use under GNU General Public License or Larry Wall's "Artistic License" +# +# Check the README.TXT file that comes with this package for details about +# it's history. +# + +require Exporter; +require DynaLoader; + +@ISA= qw( Exporter DynaLoader ); + # Items to export into callers namespace by default. Note: do not export + # names by default without a very good reason. Use EXPORT_OK instead. + # Do not simply export all your public functions/methods/constants. +@EXPORT = qw(); + +$ErrorNum = 0; +$ErrorText = ""; + +sub new +{ + my ($self, $Pipe); + my ($Type, $Name, $Time) = @_; + + if (! $Time){ + $Time = DEFAULT_WAIT_TIME(); + } + $Pipe = PipeCreate($Name, $Time); + if ($Pipe){ + $self = bless {}; + $self->{'Pipe'} = $Pipe; + }else{ + ($ErrorNum, $ErrorText) = PipeError(); + return undef; + } + $self; +} + +sub Write{ + my($self, $Data) = @_; + $Data = PipeWrite($self->{'Pipe'}, $Data); + return $Data; +} + +sub Read{ + my($self) = @_; + my($Data); + $Data = PipeRead($self->{'Pipe'}); + return $Data; +} + +sub Error{ + my($self) = @_; + my($MyError, $MyErrorText, $Temp); + if (! ref($self)){ + undef $Temp; + }else{ + $Temp = $self->{'Pipe'}; + } + ($MyError, $MyErrorText) = PipeError($Temp); + return wantarray? ($MyError, $MyErrorText):"[$MyError] \"$MyErrorText\""; +} + + +sub Close{ + my ($self) = shift; + PipeClose($self->{'Pipe'}); + $self->{'Pipe'} = 0; +} + +sub Connect{ + my ($self) = @_; + my ($Result); + $Result = PipeConnect($self->{'Pipe'}); + return $Result; +} + +sub Disconnect{ + my ($self, $iPurge) = @_; + my ($Result); + if (! $iPurge){ + $iPurge = 1; + } + $Result = PipeDisconnect($self->{'Pipe'}, $iPurge); + return $Result; +} + +sub BufferSize{ + my($self) = @_; + my($Result) = PipeBufferSize($self->{'Pipe'}); + return $Result; +} + +sub ResizeBuffer{ + my($self, $Size) = @_; + my($Result) = PipeResizeBuffer($self->{'Pipe'}, $Size); + return $Result; +} + + +#### +# Auto-Kill an instance of this module +#### +sub DESTROY +{ + my ($self) = shift; + Close($self); +} + + +sub Credit{ + my($Name, $Version, $Date, $Author, $CompileDate, $CompileTime, $Credits) = Win32::Pipe::Info(); + my($Out, $iWidth); + $iWidth = 60; + $Out .= "\n"; + $Out .= " +". "=" x ($iWidth). "+\n"; + $Out .= " |". Center("", $iWidth). "|\n"; + $Out .= " |" . Center("", $iWidth). "|\n"; + $Out .= " |". Center("$Name", $iWidth). "|\n"; + $Out .= " |". Center("-" x length("$Name"), $iWidth). "|\n"; + $Out .= " |". Center("", $iWidth). "|\n"; + + $Out .= " |". Center("Version $Version ($Date)", $iWidth). "|\n"; + $Out .= " |". Center("by $Author", $iWidth). "|\n"; + $Out .= " |". Center("Compiled on $CompileDate at $CompileTime.", $iWidth). "|\n"; + $Out .= " |". Center("", $iWidth). "|\n"; + $Out .= " |". Center("Credits:", $iWidth). "|\n"; + $Out .= " |". Center(("-" x length("Credits:")), $iWidth). "|\n"; + foreach $Temp (split("\n", $Credits)){ + $Out .= " |". Center("$Temp", $iWidth). "|\n"; + } + $Out .= " |". Center("", $iWidth). "|\n"; + $Out .= " +". "=" x ($iWidth). "+\n"; + return $Out; +} + +sub Center{ + local($Temp, $Width) = @_; + local($Len) = ($Width - length($Temp)) / 2; + return " " x int($Len) . $Temp . " " x (int($Len) + (($Len != int($Len))? 1:0)); +} + +# ------------------ A U T O L O A D F U N C T I O N --------------------- + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + $val = constant($constname, @_ ? $_[0] : 0); + + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + + # Added by JOC 06-APR-96 + # $pack = 0; + $pack = 0; + ($pack,$file,$line) = caller; + print "Your vendor has not defined Win32::Pipe macro $constname, used in $file at line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::Pipe; + +1; +__END__ + +=head1 NAME + +Win32::Pipe - Win32 Named Pipe + +=head1 SYNOPSIS + +To use this extension, follow these basic steps. First, you need to +'use' the pipe extension: + + use Win32::Pipe; + +Then you need to create a server side of a named pipe: + + $Pipe = new Win32::Pipe("My Pipe Name"); + +or if you are going to connect to pipe that has already been created: + + $Pipe = new Win32::Pipe("\\\\server\\pipe\\My Pipe Name"); + + NOTE: The "\\\\server\\pipe\\" is necessary when connecting + to an existing pipe! If you are accessing the same + machine you could use "\\\\.\\pipe\\" but either way + works fine. + +You should check to see if C<$Pipe> is indeed defined otherwise there +has been an error. + +Whichever end is the server, it must now wait for a connection... + + $Result = $Pipe->Connect(); + + NOTE: The client end does not do this! When the client creates + the pipe it has already connected! + +Now you can read and write data from either end of the pipe: + + $Data = $Pipe->Read(); + + $Result = $Pipe->Write("Howdy! This is cool!"); + +When the server is finished it must disconnect: + + $Pipe->Disconnect(); + +Now the server could C<Connect> again (and wait for another client) or +it could destroy the named pipe... + + $Data->Close(); + +The client should C<Close> in order to properly end the session. + +=head1 DESCRIPTION + +=head2 General Use + +This extension gives Win32 Perl the ability to use Named Pipes. Why? +Well considering that Win32 Perl does not (yet) have the ability to +C<fork> I could not see what good the C<pipe(X,Y)> was. Besides, where +I am as an admin I must have several perl daemons running on several +NT Servers. It dawned on me one day that if I could pipe all these +daemons' output to my workstation (across the net) then it would be +much easier to monitor. This was the impetus for an extension using +Named Pipes. I think that it is kinda cool. :) + +=head2 Benefits + +And what are the benefits of this module? + +=over + +=item * + +You may create as many named pipes as you want (uh, well, as many as +your resources will allow). + +=item * + +Currently there is a limit of 256 instances of a named pipe (once a +pipe is created you can have 256 client/server connections to that +name). + +=item * + +The default buffer size is 512 bytes; this can be altered by the +C<ResizeBuffer> method. + +=item * + +All named pipes are byte streams. There is currently no way to alter a +pipe to be message based. + +=item * + +Other things that I cannot think of right now... :) + +=back + +=head1 CONSTRUCTOR + +=over + +=item new ( NAME ) + +Creates a named pipe if used in server context or a connection to the +specified named pipe if used in client context. Client context is +determined by prepending $Name with "\\\\". + +Returns I<true> on success, I<false> on failure. + +=back + +=head1 METHODS + +=over + +=item BufferSize () + +Returns the size of the instance of the buffer of the named pipe. + +=item Connect () + +Tells the named pipe to create an instance of the named pipe and wait +until a client connects. Returns I<true> on success, I<false> on +failure. + +=item Close () + +Closes the named pipe. + +=item Disconnect () + +Disconnects (and destroys) the instance of the named pipe from the +client. Returns I<true> on success, I<false> on failure. + +=item Error () + +Returns the last error messages pertaining to the named pipe. If used +in context to the package. Returns a list containing C<ERROR_NUMBER> +and C<ERROR_TEXT>. + +=item Read () + +Reads from the named pipe. Returns data read from the pipe on success, +undef on failure. + +=item ResizeBuffer ( SIZE ) + +Sets the size of the buffer of the instance of the named pipe to +C<SIZE>. Returns the size of the buffer on success, I<false> on +failure. + +=item Write ( DATA ) + +Writes C<DATA> to the named pipe. Returns I<true> on success, I<false> +on failure. + +=back + +=head1 LIMITATIONS + +What known problems does this thing have? + +=over + +=item * + +If someone is waiting on a C<Read> and the other end terminates then +you will wait for one B<REALLY> long time! (If anyone has an idea on +how I can detect the termination of the other end let me know!) + +=item * + +All pipes are blocking. I am considering using threads and callbacks +into Perl to perform async IO but this may be too much for my time +stress. ;) + +=item * + +There is no security placed on these pipes. + +=item * + +This module has neither been optimized for speed nor optimized for +memory consumption. This may run into memory bloat. + +=back + +=head1 INSTALLATION NOTES + +If you wish to use this module with a build of Perl other than +ActivePerl, you may wish to fetch the source distribution for this +module. The source is included as part of the C<libwin32> bundle, +which you can find in any CPAN mirror here: + + modules/by-authors/Gurusamy_Sarathy/libwin32-0.151.tar.gz + +The source distribution also contains a pair of sample client/server +test scripts. For the latest information on this module, consult the +following web site: + + http://www.roth.net/perl + +=head1 AUTHOR + +Dave Roth <rothd@roth.net> + +=head1 DISCLAIMER + +I do not guarantee B<ANYTHING> with this package. If you use it you +are doing so B<AT YOUR OWN RISK>! I may or may not support this +depending on my time schedule. + +=head1 COPYRIGHT + +Copyright (c) 1996 Dave Roth. All rights reserved. +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/Process.pm b/Master/tlpkg/installer/perllib/Win32/Process.pm new file mode 100644 index 00000000000..f07169b4080 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Process.pm @@ -0,0 +1,217 @@ +package Win32::Process; + +require Exporter; +require DynaLoader; +@ISA = qw(Exporter DynaLoader); + +$VERSION = '0.10'; + +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + CREATE_DEFAULT_ERROR_MODE + CREATE_NEW_CONSOLE + CREATE_NEW_PROCESS_GROUP + CREATE_NO_WINDOW + CREATE_SEPARATE_WOW_VDM + CREATE_SUSPENDED + CREATE_UNICODE_ENVIRONMENT + DEBUG_ONLY_THIS_PROCESS + DEBUG_PROCESS + DETACHED_PROCESS + HIGH_PRIORITY_CLASS + IDLE_PRIORITY_CLASS + INFINITE + NORMAL_PRIORITY_CLASS + REALTIME_PRIORITY_CLASS + THREAD_PRIORITY_ABOVE_NORMAL + THREAD_PRIORITY_BELOW_NORMAL + THREAD_PRIORITY_ERROR_RETURN + THREAD_PRIORITY_HIGHEST + THREAD_PRIORITY_IDLE + THREAD_PRIORITY_LOWEST + THREAD_PRIORITY_NORMAL + THREAD_PRIORITY_TIME_CRITICAL +); + +@EXPORT_OK = qw( + STILL_ACTIVE +); + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + local $! = 0; + my $val = constant($constname); + if ($! != 0) { + my ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::Process macro $constname, used at $file line $line."; + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} # end AUTOLOAD + +bootstrap Win32::Process; + +# Win32::IPC > 1.02 uses the get_Win32_IPC_HANDLE method: +*get_Win32_IPC_HANDLE = \&get_process_handle; + +1; +__END__ + +=head1 NAME + +Win32::Process - Create and manipulate processes. + +=head1 SYNOPSIS + + use Win32::Process; + use Win32; + + sub ErrorReport{ + print Win32::FormatMessage( Win32::GetLastError() ); + } + + Win32::Process::Create($ProcessObj, + "C:\\winnt\\system32\\notepad.exe", + "notepad temp.txt", + 0, + NORMAL_PRIORITY_CLASS, + ".")|| die ErrorReport(); + + $ProcessObj->Suspend(); + $ProcessObj->Resume(); + $ProcessObj->Wait(INFINITE); + +=head1 DESCRIPTION + +This module provides access to the process control functions in the +Win32 API. + +=head1 METHODS + +=over 8 + +=item Win32::Process::Create($obj,$appname,$cmdline,$iflags,$cflags,$curdir) + +Creates a new process. + + Args: + + $obj container for process object + $appname full path name of executable module + $cmdline command line args + $iflags flag: inherit calling processes handles or not + $cflags flags for creation (see exported vars below) + $curdir working dir of new process + +Returns non-zero on success, 0 on failure. + +=item Win32::Process::Open($obj,$pid,$iflags) + +Creates a handle Perl can use to an existing process as identified by $pid. +The $iflags is the inherit flag that is passed to OpenProcess. Currently +Win32::Process objects created using Win32::Process::Open cannot Suspend +or Resume the process. All other calls should work. + +Win32::Process::Open returns non-zero on success, 0 on failure. + +=item Win32::Process::KillProcess($pid, $exitcode) + +Terminates any process identified by $pid. $exitcode will be set to +the exit code of the process. + +=item $ProcessObj->Suspend() + +Suspend the process associated with the $ProcessObj. + +=item $ProcessObj->Resume() + +Resume a suspended process. + +=item $ProcessObj->Kill($exitcode) + +Kill the associated process, have it terminate with exit code $ExitCode. + +=item $ProcessObj->GetPriorityClass($class) + +Get the priority class of the process. + +=item $ProcessObj->SetPriorityClass($class) + +Set the priority class of the process (see exported values below for +options). + +=item $ProcessObj->GetProcessAffinityMask($processAffinityMask, $systemAffinityMask) + +Get the process affinity mask. This is a bitvector in which each bit +represents the processors that a process is allowed to run on. + +=item $ProcessObj->SetProcessAffinityMask($processAffinityMask) + +Set the process affinity mask. Only available on Windows NT. + +=item $ProcessObj->GetExitCode($exitcode) + +Retrieve the exitcode of the process. Will return STILL_ACTIVE if the +process is still running. The STILL_ACTIVE constant is only exported +by explicit request. + +=item $ProcessObj->Wait($timeout) + +Wait for the process to die. $timeout should be specified in milliseconds. +To wait forever, specify the constant C<INFINITE>. + +=item $ProcessObj->GetProcessID() + +Returns the Process ID. + +=item Win32::Process::GetCurrentProcessID() + +Returns the current process ID, which is the same as $$. But not on cygwin, +where $$ is the cygwin-internal PID and not the windows PID. +On cygwin GetCurrentProcessID() returns the windows PID as needed for all +the Win32::Process functions. + +=back + +=head1 EXPORTS + +The following constants are exported by default: + + CREATE_DEFAULT_ERROR_MODE + CREATE_NEW_CONSOLE + CREATE_NEW_PROCESS_GROUP + CREATE_NO_WINDOW + CREATE_SEPARATE_WOW_VDM + CREATE_SUSPENDED + CREATE_UNICODE_ENVIRONMENT + DEBUG_ONLY_THIS_PROCESS + DEBUG_PROCESS + DETACHED_PROCESS + HIGH_PRIORITY_CLASS + IDLE_PRIORITY_CLASS + INFINITE + NORMAL_PRIORITY_CLASS + REALTIME_PRIORITY_CLASS + THREAD_PRIORITY_ABOVE_NORMAL + THREAD_PRIORITY_BELOW_NORMAL + THREAD_PRIORITY_ERROR_RETURN + THREAD_PRIORITY_HIGHEST + THREAD_PRIORITY_IDLE + THREAD_PRIORITY_LOWEST + THREAD_PRIORITY_NORMAL + THREAD_PRIORITY_TIME_CRITICAL + +The following additional constants are exported by request only: + + STILL_ACTIVE + +=cut + +# Local Variables: +# tmtrack-file-task: "Win32::Process" +# End: diff --git a/Master/tlpkg/installer/perllib/Win32/Semaphore.pm b/Master/tlpkg/installer/perllib/Win32/Semaphore.pm new file mode 100644 index 00000000000..2e2096eb6ed --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Semaphore.pm @@ -0,0 +1,128 @@ +#--------------------------------------------------------------------- +package Win32::Semaphore; +# +# Copyright 1998 Christopher J. Madsen +# +# Created: 3 Feb 1998 from the ActiveWare version +# (c) 1995 Microsoft Corporation. All rights reserved. +# Developed by ActiveWare Internet Corp., http://www.ActiveWare.com +# +# Other modifications (c) 1997 by Gurusamy Sarathy <gsar@activestate.com> +# +# Author: Christopher J. Madsen <cjm@pobox.com> +# Version: 1.00 (6-Feb-1998) +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# Use Win32 semaphore objects for synchronization +#--------------------------------------------------------------------- + +$VERSION = '1.02'; + +use Win32::IPC 1.00 '/./'; # Import everything +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader Win32::IPC); +@EXPORT_OK = qw( + wait_all wait_any +); + +bootstrap Win32::Semaphore; + +sub Create { $_[0] = new('Win32::Semaphore',@_[1..3]) } +sub Open { $_[0] = Win32::Semaphore->open($_[1]) } +sub Release { &release } + +1; +__END__ + +=head1 NAME + +Win32::Semaphore - Use Win32 semaphore objects from Perl + +=head1 SYNOPSIS + require Win32::Semaphore; + + $sem = Win32::Semaphore->new($initial,$maximum,$name); + $sem->wait; + +=head1 DESCRIPTION + +This module allows access to Win32 semaphore objects. The C<wait> +method and C<wait_all> & C<wait_any> functions are inherited from the +L<"Win32::IPC"> module. + +=head2 Methods + +=over 4 + +=item $semaphore = Win32::Semaphore->new($initial, $maximum, [$name]) + +Constructor for a new semaphore object. C<$initial> is the initial +count, and C<$maximum> is the maximum count for the semaphore. If +C<$name> is omitted, creates an unnamed semaphore object. + +If C<$name> signifies an existing semaphore object, then C<$initial> +and C<$maximum> are ignored and the object is opened. If this +happens, C<$^E> will be set to 183 (ERROR_ALREADY_EXISTS). + +=item $semaphore = Win32::Semaphore->open($name) + +Constructor for opening an existing semaphore object. + +=item $semaphore->release([$increment, [$previous]]) + +Increment the count of C<$semaphore> by C<$increment> (default 1). +If C<$increment> plus the semaphore's current count is more than its +maximum count, the count is not changed. Returns true if the +increment is successful. + +The semaphore's count (before incrementing) is stored in the second +argument (if any). + +It is not necessary to wait on a semaphore before calling C<release>, +but you'd better know what you're doing. + +=item $semaphore->wait([$timeout]) + +Wait for C<$semaphore>'s count to be nonzero, then decrement it by 1. +See L<"Win32::IPC">. + +=back + +=head2 Deprecated Functions and Methods + +B<Win32::Semaphore> still supports the ActiveWare syntax, but its use +is deprecated. + +=over 4 + +=item Win32::Semaphore::Create($SemObject,$Initial,$Max,$Name) + +Use C<$SemObject = Win32::Semaphore-E<gt>new($Initial,$Max,$Name)> instead. + +=item Win32::Semaphore::Open($SemObject, $Name) + +Use C<$SemObject = Win32::Semaphore-E<gt>open($Name)> instead. + +=item $SemObj->Release($Count,$LastVal) + +Use C<$SemObj-E<gt>release($Count,$LastVal)> instead. + +=back + +=head1 AUTHOR + +Christopher J. Madsen E<lt>F<cjm@pobox.com>E<gt> + +Loosely based on the original module by ActiveWare Internet Corp., +F<http://www.ActiveWare.com> + +=cut diff --git a/Master/tlpkg/installer/perllib/Win32/Server.pl b/Master/tlpkg/installer/perllib/Win32/Server.pl new file mode 100644 index 00000000000..ecfb91ba864 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Server.pl @@ -0,0 +1,48 @@ +use strict; +use Win32::Pipe; + +my $PipeName = "TEST this long named pipe!"; +my $NewSize = 2048; +my $iMessage; + +while () { + print "Creating pipe \"$PipeName\".\n"; + if (my $Pipe = new Win32::Pipe($PipeName)) { + my $PipeSize = $Pipe->BufferSize(); + print "This pipe's current size is $PipeSize byte" . (($PipeSize == 1)? "":"s") . ".\nWe shall change it to $NewSize ..."; + print +(($Pipe->ResizeBuffer($NewSize) == $NewSize)? "Successful":"Unsucessful") . "!\n\n"; + + print "\n\nR e a d y f o r r e a d i n g :\n"; + print "-----------------------------------\n"; + + print "Openning the pipe...\n"; + while ($Pipe->Connect()) { + while () { + ++$iMessage; + print "Reading Message #$iMessage: "; + my $In = $Pipe->Read(); + unless ($In) { + print "Recieved no data, closing connection....\n"; + last; + } + if ($In =~ /^quit/i){ + print "\n\nQuitting this connection....\n"; + last; + } + elsif ($In =~ /^exit/i){ + print "\n\nExitting.....\n"; + exit; + } + else{ + print "\"$In\"\n"; + } + } + print "Disconnecting...\n"; + $Pipe->Disconnect(); + } + print "Closing...\n"; + $Pipe->Close(); + } +} + +print "You can't get here...\n"; diff --git a/Master/tlpkg/installer/perllib/Win32/Service.pm b/Master/tlpkg/installer/perllib/Win32/Service.pm new file mode 100644 index 00000000000..0ae33b13ef8 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Service.pm @@ -0,0 +1,103 @@ +package Win32::Service; + +# +# Service.pm +# Written by Douglas_Lankshear@ActiveWare.com +# +# subsequently hacked by Gurusamy Sarathy <gsar@activestate.com> +# + +$VERSION = '0.05'; + +require Exporter; +require DynaLoader; + +require Win32 unless defined &Win32::IsWinNT; +die "The Win32::Service module works only on Windows NT" unless Win32::IsWinNT(); + +@ISA= qw( Exporter DynaLoader ); +@EXPORT_OK = + qw( + StartService + StopService + GetStatus + PauseService + ResumeService + GetServices + ); + +=head1 NAME + +Win32::Service - manage system services in perl + +=head1 SYNOPSIS + + use Win32::Service; + +=head1 DESCRIPTION + +This module offers control over the administration of system services. + +=head1 FUNCTIONS + +=head2 NOTE: + +All of the functions return false if they fail, unless otherwise noted. +If hostName is an empty string, the local machine is assumed. + +=over 10 + +=item StartService(hostName, serviceName) + +Start the service serviceName on machine hostName. + +=item StopService(hostName, serviceName) + +Stop the service serviceName on the machine hostName. + +=item GetStatus(hostName, serviceName, status) + +Get the status of a service. The third argument must be a hash +reference that will be populated with entries corresponding +to the SERVICE_STATUS structure of the Win32 API. See the +Win32 Platform SDK documentation for details of this structure. + +=item PauseService(hostName, serviceName) + +=item ResumeService(hostName, serviceName) + +=item GetServices(hostName, hashref) + +Enumerates both active and inactive Win32 services at the specified host. +The hashref is populated with the descriptive service names as keys +and the short names as the values. + +=back + +=cut + +sub AUTOLOAD +{ + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname); + if ($! != 0) { + if($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::Service macro $constname, used in $file at line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::Service; + +1; +__END__ diff --git a/Master/tlpkg/installer/perllib/Win32/Sound.pm b/Master/tlpkg/installer/perllib/Win32/Sound.pm new file mode 100644 index 00000000000..a8d52a95117 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Sound.pm @@ -0,0 +1,582 @@ +####################################################################### +# +# Win32::Sound - An extension to play with Windows sounds +# +# Author: Aldo Calpini <dada@divinf.it> +# Version: 0.47 +# Info: +# http://www.divinf.it/dada/perl +# http://www.perl.com/CPAN/authors/Aldo_Calpini +# +####################################################################### +# Version history: +# 0.01 (19 Nov 1996) file created +# 0.03 (08 Apr 1997) first release +# 0.30 (20 Oct 1998) added Volume/Format/Devices/DeviceInfo +# (thanks Dave Roth!) +# 0.40 (16 Mar 1999) added the WaveOut object +# 0.45 (09 Apr 1999) added $! support, documentation et goodies +# 0.46 (25 Sep 1999) fixed small bug in DESTROY, wo was used without being +# initialized (Gurusamy Sarathy <gsar@activestate.com>) +# 0.47 (22 May 2000) support for passing Unicode string to Play() +# (Doug Lankshear <dougl@activestate.com>) + +package Win32::Sound; + +# See the bottom of this file for the POD documentation. +# Search for the string '=head'. + +require Exporter; # to export the constants to the main:: space +require DynaLoader; # to dynuhlode the module. + +@ISA= qw( Exporter DynaLoader ); +@EXPORT = qw( + SND_ASYNC + SND_NODEFAULT + SND_LOOP + SND_NOSTOP +); + +####################################################################### +# This AUTOLOAD is used to 'autoload' constants from the constant() +# XS function. If a constant is not found then control is passed +# to the AUTOLOAD in AutoLoader. +# + +sub AUTOLOAD { + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + + # [dada] This results in an ugly Autoloader error + + #if ($! =~ /Invalid/) { + # $AutoLoader::AUTOLOAD = $AUTOLOAD; + # goto &AutoLoader::AUTOLOAD; + #} else { + + # [dada] ... I prefer this one :) + + ($pack, $file, $line) = caller; + undef $pack; # [dada] and get rid of "used only once" warning... + die "Win32::Sound::$constname is not defined, used at $file line $line."; + + #} + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + + +####################################################################### +# STATIC OBJECT PROPERTIES +# +$VERSION="0.47"; +undef unless $VERSION; # [dada] to avoid "possible typo" warning + +####################################################################### +# METHODS +# + +sub Version { $VERSION } + +sub Volume { + my(@in) = @_; + # Allows '0%'..'100%' + $in[0] =~ s{ ([\d\.]+)%$ }{ int($1*100/255) }ex if defined $in[0]; + $in[1] =~ s{ ([\d\.]+)%$ }{ int($1*100/255) }ex if defined $in[1]; + _Volume(@in); +} + +####################################################################### +# dynamically load in the Sound.dll module. +# + +bootstrap Win32::Sound; + +####################################################################### +# Win32::Sound::WaveOut +# + +package Win32::Sound::WaveOut; + +sub new { + my($class, $one, $two, $three) = @_; + my $self = {}; + bless($self, $class); + + if($one !~ /^\d+$/ + and not defined($two) + and not defined($three)) { + # Looks like a file + $self->Open($one); + } else { + # Default format if not given + $self->{samplerate} = ($one or 44100); + $self->{bits} = ($two or 16); + $self->{channels} = ($three or 2); + $self->OpenDevice(); + } + return $self; +} + +sub Volume { + my(@in) = @_; + # Allows '0%'..'100%' + $in[0] =~ s{ ([\d\.]+)%$ }{ int($1*255/100) }ex if defined $in[0]; + $in[1] =~ s{ ([\d\.]+)%$ }{ int($1*255/100) }ex if defined $in[1]; + _Volume(@in); +} + +sub Pitch { + my($self, $pitch) = @_; + my($int, $frac); + if(defined($pitch)) { + $pitch =~ /(\d+).?(\d+)?/; + $int = $1; + $frac = $2 or 0; + $int = $int << 16; + $frac = eval("0.$frac * 65536"); + $pitch = $int + $frac; + return _Pitch($self, $pitch); + } else { + $pitch = _Pitch($self); + $int = ($pitch & 0xFFFF0000) >> 16; + $frac = $pitch & 0x0000FFFF; + return eval("$int.$frac"); + } +} + +sub PlaybackRate { + my($self, $rate) = @_; + my($int, $frac); + if(defined($rate)) { + $rate =~ /(\d+).?(\d+)?/; + $int = $1; + $frac = $2 or 0; + $int = $int << 16; + $frac = eval("0.$frac * 65536"); + $rate = $int + $frac; + return _PlaybackRate($self, $rate); + } else { + $rate = _PlaybackRate($self); + $int = ($rate & 0xFFFF0000) >> 16; + $frac = $rate & 0x0000FFFF; + return eval("$int.$frac"); + } +} + +# Preloaded methods go here. + +#Currently Autoloading is not implemented in Perl for win32 +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ + + +=head1 NAME + +Win32::Sound - An extension to play with Windows sounds + +=head1 SYNOPSIS + + use Win32::Sound; + Win32::Sound::Volume('100%'); + Win32::Sound::Play("file.wav"); + Win32::Sound::Stop(); + + # ...and read on for more fun ;-) + +=head1 FUNCTIONS + +=over 4 + +=item B<Win32::Sound::Play(SOUND, [FLAGS])> + +Plays the specified sound: SOUND can the be name of a WAV file +or one of the following predefined sound names: + + SystemDefault + SystemAsterisk + SystemExclamation + SystemExit + SystemHand + SystemQuestion + SystemStart + +Additionally, if the named sound could not be found, the +function plays the system default sound (unless you specify the +C<SND_NODEFAULT> flag). If no parameters are given, this function +stops the sound actually playing (see also Win32::Sound::Stop). + +FLAGS can be a combination of the following constants: + +=over 4 + +=item C<SND_ASYNC> + +The sound is played asynchronously and the function +returns immediately after beginning the sound +(if this flag is not specified, the sound is +played synchronously and the function returns +when the sound ends). + +=item C<SND_LOOP> + +The sound plays repeatedly until it is stopped. +You must also specify C<SND_ASYNC> flag. + +=item C<SND_NODEFAULT> + +No default sound is used. If the specified I<sound> +cannot be found, the function returns without +playing anything. + +=item C<SND_NOSTOP> + +If a sound is already playing, the function fails. +By default, any new call to the function will stop +previously playing sounds. + +=back + +=item B<Win32::Sound::Stop()> + +Stops the sound currently playing. + +=item B<Win32::Sound::Volume()> + +Returns the wave device volume; if +called in an array context, returns left +and right values. Otherwise, returns a single +32 bit value (left in the low word, right +in the high word). +In case of error, returns C<undef> and sets +$!. + +Examples: + + ($L, $R) = Win32::Sound::Volume(); + if( not defined Win32::Sound::Volume() ) { + die "Can't get volume: $!"; + } + +=item B<Win32::Sound::Volume(LEFT, [RIGHT])> + +Sets the wave device volume; if two arguments +are given, sets left and right channels +independently, otherwise sets them both to +LEFT (eg. RIGHT=LEFT). Values range from +0 to 65535 (0xFFFF), but they can also be +given as percentage (use a string containing +a number followed by a percent sign). + +Returns C<undef> and sets $! in case of error, +a true value if successful. + +Examples: + + Win32::Sound::Volume('50%'); + Win32::Sound::Volume(0xFFFF, 0x7FFF); + Win32::Sound::Volume('100%', '50%'); + Win32::Sound::Volume(0); + +=item B<Win32::Sound::Format(filename)> + +Returns information about the specified WAV file format; +the array contains: + +=over + +=item * sample rate (in Hz) + +=item * bits per sample (8 or 16) + +=item * channels (1 for mono, 2 for stereo) + +=back + +Example: + + ($hz, $bits, $channels) + = Win32::Sound::Format("file.wav"); + + +=item B<Win32::Sound::Devices()> + +Returns all the available sound devices; +their names contain the type of the +device (WAVEOUT, WAVEIN, MIDIOUT, +MIDIIN, AUX or MIXER) and +a zero-based ID number: valid devices +names are for example: + + WAVEOUT0 + WAVEOUT1 + WAVEIN0 + MIDIOUT0 + MIDIIN0 + AUX0 + AUX1 + AUX2 + +There are also two special device +names, C<WAVE_MAPPER> and C<MIDI_MAPPER> +(the default devices for wave output +and midi output). + +Example: + + @devices = Win32::Sound::Devices(); + +=item Win32::Sound::DeviceInfo(DEVICE) + +Returns an associative array of information +about the sound device named DEVICE (the +same format of Win32::Sound::Devices). + +The content of the array depends on the device +type queried. Each device type returns B<at least> +the following information: + + manufacturer_id + product_id + name + driver_version + +For additional data refer to the following +table: + + WAVEIN..... formats + channels + + WAVEOUT.... formats + channels + support + + MIDIOUT.... technology + voices + notes + channels + support + + AUX........ technology + support + + MIXER...... destinations + support + +The meaning of the fields, where not +obvious, can be evinced from the +Microsoft SDK documentation (too long +to report here, maybe one day... :-). + +Example: + + %info = Win32::Sound::DeviceInfo('WAVE_MAPPER'); + print "$info{name} version $info{driver_version}\n"; + +=back + +=head1 THE WaveOut PACKAGE + +Win32::Sound also provides a different, more +powerful approach to wave audio data with its +C<WaveOut> package. It has methods to load and +then play WAV files, with the additional feature +of specifying the start and end range, so you +can play only a portion of an audio file. + +Furthermore, it is possible to load arbitrary +binary data to the soundcard to let it play and +save them back into WAV files; in a few words, +you can do some sound synthesis work. + +=head2 FUNCTIONS + +=over + +=item new Win32::Sound::WaveOut(FILENAME) + +=item new Win32::Sound::WaveOut(SAMPLERATE, BITS, CHANNELS) + +=item new Win32::Sound::WaveOut() + +This function creates a C<WaveOut> object; the +first form opens the specified wave file (see +also C<Open()> ), so you can directly C<Play()> it. + +The second (and third) form opens the +wave output device with the format given +(or if none given, defaults to 44.1kHz, +16 bits, stereo); to produce something +audible you can either C<Open()> a wave file +or C<Load()> binary data to the soundcard +and then C<Write()> it. + +=item Close() + +Closes the wave file currently opened. + +=item CloseDevice() + +Closes the wave output device; you can change +format and reopen it with C<OpenDevice()>. + +=item GetErrorText(ERROR) + +Returns the error text associated with +the specified ERROR number; note it only +works for wave-output-specific errors. + +=item Load(DATA) + +Loads the DATA buffer in the soundcard. +The format of the data buffer depends +on the format used; for example, with +8 bit mono each sample is one character, +while with 16 bit stereo each sample is +four characters long (two 16 bit values +for left and right channels). The sample +rate defines how much samples are in one +second of sound. For example, to fit one +second at 44.1kHz 16 bit stereo your buffer +must contain 176400 bytes (44100 * 4). + +=item Open(FILE) + +Opens the specified wave FILE. + +=item OpenDevice() + +Opens the wave output device with the +current sound format (not needed unless +you used C<CloseDevice()>). + +=item Pause() + +Pauses the sound currently playing; +use C<Restart()> to continue playing. + +=item Play( [FROM, TO] ) + +Plays the opened wave file. You can optionally +specify a FROM - TO range, where FROM and TO +are expressed in samples (or use FROM=0 for the +first sample and TO=-1 for the last sample). +Playback happens always asynchronously, eg. in +the background. + +=item Position() + +Returns the sample number currently playing; +note that the play position is not zeroed +when the sound ends, so you have to call a +C<Reset()> between plays to receive the +correct position in the current sound. + +=item Reset() + +Stops playing and resets the play position +(see C<Position()>). + +=item Restart() + +Continues playing the sound paused by C<Pause()>. + +=item Save(FILE, [DATA]) + +Writes the DATA buffer (if not given, uses the +buffer currently loaded in the soundcard) +to the specified wave FILE. + +=item Status() + +Returns 0 if the soundcard is currently playing, +1 if it's free, or C<undef> on errors. + +=item Unload() + +Frees the soundcard from the loaded data. + +=item Volume( [LEFT, RIGHT] ) + +Gets or sets the volume for the wave output device. +It works the same way as Win32::Sound::Volume. + +=item Write() + +Plays the data currently loaded in the soundcard; +playback happens always asynchronously, eg. in +the background. + +=back + +=head2 THE SOUND FORMAT + +The sound format is stored in three properties of +the C<WaveOut> object: C<samplerate>, C<bits> and +C<channels>. +If you need to change them without creating a +new object, you should close before and reopen +afterwards the device. + + $WAV->CloseDevice(); + $WAV->{samplerate} = 44100; # 44.1kHz + $WAV->{bits} = 8; # 8 bit + $WAV->{channels} = 1; # mono + $WAV->OpenDevice(); + +You can also use the properties to query the +sound format currently used. + +=head2 EXAMPLE + +This small example produces a 1 second sinusoidal +wave at 440Hz and saves it in F<sinus.wav>: + + use Win32::Sound; + + # Create the object + $WAV = new Win32::Sound::WaveOut(44100, 8, 2); + + $data = ""; + $counter = 0; + $increment = 440/44100; + + # Generate 44100 samples ( = 1 second) + for $i (1..44100) { + + # Calculate the pitch + # (range 0..255 for 8 bits) + $v = sin($counter/2*3.14) * 128 + 128; + + # "pack" it twice for left and right + $data .= pack("cc", $v, $v); + + $counter += $increment; + } + + $WAV->Load($data); # get it + $WAV->Write(); # hear it + 1 until $WAV->Status(); # wait for completion + $WAV->Save("sinus.wav"); # write to disk + $WAV->Unload(); # drop it + +=head1 VERSION + +Win32::Sound version 0.46, 25 Sep 1999. + +=head1 AUTHOR + +Aldo Calpini, C<dada@divinf.it> + +Parts of the code provided and/or suggested by Dave Roth. + +=cut + + diff --git a/Master/tlpkg/installer/perllib/Win32/Test.pl b/Master/tlpkg/installer/perllib/Win32/Test.pl new file mode 100644 index 00000000000..235e94bdd78 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/Test.pl @@ -0,0 +1,477 @@ +##### +# T E S T . P L +# ------------- +# A test script for exercising the Win32::ODBC extension. Install +# the ODBC.PLL extension and the ODBC.PM wrapper, set up an ODBC +# DSN (Data Source Name) by the ODBC administrator, then give this a try! +# +# READ THE DOCUMENTATION -- I AM NOT RESPOSIBLE FOR ANY PROBLEMS THAT +# THIS MAY CAUSE WHATSOEVER. BY USING THIS OR ANY --- +# OF THE WIN32::ODBC PARTS FOUND IN THE DISTRIBUTION YOU ARE AGREEING +# WITH THE TERMS OF THIS DISTRIBUTION!!!!! +# +# +# You have been warned. +# --- ---- ---- ------ +# +# Updated to test newest version v961007. Dave Roth <rothd@roth.net> +# This version contains a small sample database (in MS Access 7.0 +# format) called ODBCTest.mdb. Place this database in the same +# directory as this test.pl file. +# +# -------------------------------------------------------------------- +# +# SYNTAX: +# perl test.pl ["DSN Name" [Max Rows]] +# +# DSN Name....Name of DSN that will be used. If this is +# omitted then we will use the obnoxious default DSN. +# Max Rows....Maximum number of rows wanted to be retrieved from +# the DSN. +# - If this is 0 then the request is to retrieve as +# many as possible. +# - If this is a value greater than that which the DSN +# driver can handle the value will be the greatest +# the DSN driver allows. +# - If omitted then we use the default value. +##### + + use Win32::ODBC; + + + $TempDSN = "Win32 ODBC Test --123xxYYzz987--"; + $iTempDSN = 1; + + if (!($DSN = $ARGV[0])){ + $DSN = $TempDSN; + } + $MaxRows = 8 unless defined ($MaxRows = $ARGV[1]); + + $DriverType = "Microsoft Access Driver (*.mdb)"; + $Desc = "Description=The Win32::ODBC Test DSN for Perl"; + $Dir = Win32::GetCwd(); + $DBase = "ODBCTest.mdb"; + + $iWidth=60; + %SQLStmtTypes = (SQL_CLOSE, "SQL_CLOSE", SQL_DROP, "SQL_DROP", SQL_UNBIND, "SQL_UNBIND", SQL_RESET_PARAMS, "SQL_RESET_PARAMS"); + +# Initialize(); + + ($Name, $Version, $Date, $Author, $CompileDate, $CompileTime, $Credits) = Win32::ODBC::Info(); + print "\n"; + print "\t+", "=" x ($iWidth), "+\n"; + print "\t|", Center("", $iWidth), "|\n"; + print "\t|", Center("", $iWidth), "|\n"; + print "\t|", Center("$Name", $iWidth), "|\n"; + print "\t|", Center("-" x length("$Name"), $iWidth), "|\n"; + print "\t|", Center("", $iWidth), "|\n"; + + print "\t|", Center("Version $Version ($Date)", $iWidth), "|\n"; + print "\t|", Center("by $Author", $iWidth), "|\n"; + print "\t|", Center("Compiled on $CompileDate at $CompileTime.", $iWidth), "|\n"; + print "\t|", Center("", $iWidth), "|\n"; + print "\t|", Center("Credits:", $iWidth), "|\n"; + print "\t|", Center(("-" x length("Credits:")), $iWidth), "|\n"; + foreach $Temp (split("\n", $Credits)){ + print "\t|", Center("$Temp", $iWidth), "|\n"; + } + print "\t|", Center("", $iWidth), "|\n"; + print "\t+", "=" x ($iWidth), "+\n"; + +#### +# T E S T 1 +#### + PrintTest(1, "Dump available ODBC Drivers"); + print "\nAvailable ODBC Drivers:\n"; + if (!(%Drivers = Win32::ODBC::Drivers())){ + $Failed{'Test 1'} = "Drivers(): " . Win32::ODBC::Error(); + } + foreach $Driver (keys(%Drivers)){ + print " Driver=\"$Driver\"\n Attributes: ", join("\n" . " "x14, sort(split(';', $Drivers{$Driver}))), "\n\n"; + } + + +#### +# T E S T 2 +#### + PrintTest(2,"Dump available datasources"); + + #### + # Notice you don't need an instantiated object to use this... + #### + print "\nHere are the available datasources...\n"; + if (!(%DSNs = Win32::ODBC::DataSources())){ + $Failed{'Test 2'} = "DataSources(): " . Win32::ODBC::Error(); + } + foreach $Temp (keys(%DSNs)){ + if (($Temp eq $TempDSN) && ($DSNs{$Temp} eq $DriverType)){ + $iTempDSNExists++; + } + if ($DSN =~ /$Temp/i){ + $iTempDSN = 0; + $DriverType = $DSNs{$Temp}; + } + print "\tDSN=\"$Temp\" (\"$DSNs{$Temp}\")\n"; + } + +#### +# T E S T 2.5 +#### + # IF WE DO NOT find the DSN the user specified... + if ($iTempDSN){ + PrintTest("2.5", "Create a Temporary DSN"); + + print "\n\tCould not find the DSN (\"$DSN\") so we will\n\tuse a temporary one (\"$TempDSN\")...\n\n"; + + $DSN = $TempDSN; + + if (! $iTempDSNExists){ + print "\tAdding DSN \"$DSN\"..."; + if (Win32::ODBC::ConfigDSN(ODBC_ADD_DSN, $DriverType, ("DSN=$DSN", "Description=The Win32 ODBC Test DSN for Perl", "DBQ=$Dir\\$DBase", "DEFAULTDIR=$Dir", "UID=", "PWD="))){ + print "Successful!\n"; + }else{ + print "Failure\n"; + $Failed{'Test 2.5'} = "ConfigDSN(): Could not add \"$DSN\": " . Win32::ODBC::Error(); + # If we failed here then use the last DSN we listed in Test 2 + $DriverType = $DSNs{$Temp}; + $DSN = $Temp; + print "\n\tCould not add a temporary DSN so using the last one listed:\n"; + print "\t\t$DSN ($DriverType)\n"; + + } + } + } + +#### +# Report What Driver/DSN we are using +#### + + print "\n\nWe are using the DSN:\n\tDSN = \"$DSN\"\n"; + print "\tDriver = \"$DriverType\"\n\n"; + + +#### +# T E S T 3 +#### + PrintTest(3, "Open several ODBC connections"); + print "\n\tOpening ODBC connection for \"$DSN\"...\n\t\t"; + if (!($O = new Win32::ODBC($DSN))){ + print "Failure. \n\n"; + $Failed{'Test 3a'} = "new(): " . Win32::ODBC::Error(); + PresentErrors(); + exit(); + }else{ + print "Success (connection #", $O->Connection(), ")\n\n"; + } + + print "\tOpening ODBC connection for \"$DSN\"...\n\t\t"; + if (!($O2 = new Win32::ODBC($DSN))){ + $Failed{'Test 3b'} = "new(): " . Win32::ODBC::Error(); + print "Failure. \n\n"; + }else{ + print "Success (connection #", $O2->Connection(), ")\n\n"; + } + + print "\tOpening ODBC connection for \"$DSN\"\n\t\t"; + if (!($O3 = new Win32::ODBC($DSN))){ + $Failed{'Test 3c'} = "new(): " . Win32::ODBC::Error(); + print "Failure. \n\n"; + }else{ + print "Success (connection #", $O3->Connection(), ")\n\n"; + } + + +#### +# T E S T 4 +#### + PrintTest(4, "Close all but one connection"); + + print "\n\tCurrently open ODBC connections are: \"", join(", ", sort($O2->GetConnections())), "\"\n"; + print "\tClosing ODBC connection #", $O2->Connection(), "...\n"; + print "\t\t...", (($O2->Close())? "Successful.":"Failure."), "\n"; + + print "\n\tCurrently open ODBC connections are: \"", join(", ", sort($O3->GetConnections())), "\"\n"; + print "\tClosing ODBC connection #", $O3->Connection(), "...\n"; + print "\t\t...", (($O3->Close())? "Successful.":"Failure."), "\n"; + + print "\n\tCurrently open ODBC connections are: \"", join(", ", sort($O2->GetConnections())), "\"\n"; + +#### +# T E S T 5 +#### + PrintTest(5, "Set/query Max Buffer size for a connection"); + + srand(time); + $Temp = int(rand(10240)) + 10240; + print "\nMaximum Buffer Size for connection #", $O->Connection(), ":\n"; + print "\tValue set at ", $O->GetMaxBufSize(), "\n"; + + print "\tSetting Maximum Buffer Size to $Temp... it has been set to ", $O->SetMaxBufSize($Temp), "\n"; + print "\tValue set at ", $O->GetMaxBufSize(), "\n"; + + $Temp += int(rand(10240)) + 102400; + print "\tSetting Maximum Buffer Size to $Temp... (can not be more than 102400)\n\t\t...it has been set to ", $O->SetMaxBufSize($Temp), "\n"; + print "\tValue set at ", $O->GetMaxBufSize(), "\n"; + + $Temp = int(rand(1024)) + 2048; + print "\tSetting Maximum Buffer Size to $Temp... it has been set to ", $O->SetMaxBufSize($Temp), "\n"; + + print "\tValue set at ", $O->GetMaxBufSize(), "\n"; + + +#### +# T E S T 6 +#### + PrintTest(6, "Set/query Stmt Close Type"); + + print "\n\tStatement Close Type is currently set as ", $O->GetStmtCloseType(), " " . $O->Error . "\n"; + print "\tSetting Statement Close Type to SQL_CLOSE: (returned code of ", $O->SetStmtCloseType(SQL_CLOSE), ")" . $O->Error . "\n"; + print "\tStatement Close Type is currently set as ", $O->GetStmtCloseType(), " " . $O->Error ."\n"; + + +#### +# T E S T 7 +#### + PrintTest(7, "Dump DSN for current connection"); + + if (! (%DSNAttributes = $O->GetDSN())){ + $Failed{'Test 7'} = "GetDSN(): " . $O->Error(); + }else{ + print"\nThe DSN for connection #", $O->Connection(), ":\n"; + print "\tDSN...\n"; + foreach (sort(keys(%DSNAttributes))){ + print "\t$_ = \"$DSNAttributes{$_}\"\n"; + } + } + + + +#### +# T E S T 8 +#### + PrintTest(8, "Dump list of ALL tables in datasource"); + + print "\nList of tables for \"$DSN\"\n\n"; + $Num = 0; + if ($O->Catalog("", "", "%", "'TABLE','VIEW','SYSTEM TABLE', 'GLOBAL TEMPORARY','LOCAL TEMPORARY','ALIAS','SYNONYM'")){ + + print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n"; + print "\tRenaming cursor to \"TestCursor\"...", (($O->SetCursorName("TestCursor"))? "Success":"Failure"), ".\n"; + print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n\n"; + + @FieldNames = $O->FieldNames(); + + $~ = "Test_8_Header"; + write; + + $~ = "Test_8_Body"; + while($O->FetchRow()){ + undef %Data; + %Data = $O->DataHash(); + write; + } + } + print "\n\tTotal number of tables displayed: $Num\n"; + + + +#### +# T E S T 9 +#### + PrintTest(9, "Dump list of non-system tables and views in datasource"); + + print "\n"; + $Num = 0; + + foreach $Temp ($O->TableList("", "", "%", "TABLE, VIEW, SYSTEM_TABLE")){ + $Table = $Temp; + print "\t", ++$Num, ".) \"$Temp\"\n"; + } + print "\n\tTotal number of tables displayed: $Num\n"; + + +#### +# T E S T 10 +#### + PrintTest(10, "Dump contents of the table: \"$Table\""); + + print "\n"; + + print "\tResetting (dropping) cursor...", (($O->DropCursor())? "Successful":"Failure"), ".\n\n"; + + print "\tCurrently the cursor type is: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n"; + print "\tSetting Cursor to Dynamic (", ($O->SQL_CURSOR_DYNAMIC), ")...", (($O->SetStmtOption($O->SQL_CURSOR_TYPE, $O->SQL_CURSOR_DYNAMIC))? "Success":"Failure"), ".\n"; + print "\t\tThis may have failed depending on your ODBC Driver.\n"; + print "\t\tThis is not really a problem, it will default to another value.\n"; + print "\tUsing the cursor type of: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n\n"; + + print "\tSetting the connection to only grab $MaxRows row", ($MaxRows == 1)? "":"s", " maximum..."; + if ($O->SetStmtOption($O->SQL_MAX_ROWS, $MaxRows)){ + print "Success!\n"; + }else{ + $Failed{'Test 10a'} = "SetStmtOption(): " . Win32::ODBC::Error(); + print "Failure.\n"; + } + + $iTemp = $O->GetStmtOption($O->SQL_MAX_ROWS); + print "\tUsing the maximum rows: ", (($iTemp)? $iTemp:"No maximum limit"), "\n\n"; + + print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n"; + print "\tRenaming cursor to \"TestCursor\"...", (($O->SetCursorName("TestCursor"))? "Success":"Failure"), ".\n"; + print "\tCursor is currently named \"", $O->GetCursorName(), "\".\n\n"; + + if (! $O->Sql("SELECT * FROM [$Table]")){ + @FieldNames = $O->FieldNames(); + $Cols = $#FieldNames + 1; + $Cols = 8 if ($Cols > 8); + + $FmH = "format Test_10_Header =\n"; + $FmH2 = ""; + $FmH3 = ""; + $FmB = "format Test_10_Body = \n"; + $FmB2 = ""; + + for ($iTemp = 0; $iTemp < $Cols; $iTemp++){ + $FmH .= "@" . "<" x (80/$Cols - 2) . " "; + $FmH2 .= "\$FieldNames[$iTemp],"; + $FmH3 .= "-" x (80/$Cols - 1) . " "; + + $FmB .= "@" . "<" x (80/$Cols - 2) . " "; + $FmB2 .= "\$Data{\$FieldNames[$iTemp]},"; + } + chop $FmH2; + chop $FmB2; + + eval"$FmH\n$FmH2\n$FmH3\n.\n"; + eval "$FmB\n$FmB2\n.\n"; + + $~ = "Test_10_Header"; + write(); + $~ = "Test_10_Body"; + + # Fetch the next rowset + while($O->FetchRow()){ + undef %Data; + %Data = $O->DataHash(); + write(); + } + #### + # THE preceeding block could have been written like this: + # ------------------------------------------------------ + # + # print "\tCurrently the cursor type is: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n"; + # print "\tSetting Cursor to Dynamic (", ($O->SQL_CURSOR_DYNAMIC), ")...", (($O->SetStmtOption($O->SQL_CURSOR_TYPE, $O->SQL_CURSOR_DYNAMIC))? "Success":"Failure"), ".\n"; + # print "\t\tThis may have failed depending on your ODBC Driver. No real problem.\n"; + # print "\tUsing the cursor type of: ", $O->GetStmtOption($O->SQL_CURSOR_TYPE), "\n\n"; + # + # print "\tSetting rowset size = 15 ...", (($O->SetStmtOption($O->SQL_ROWSET_SIZE, 15))? "Success":"Failure"), ".\n"; + # print "\tGetting rowset size: ", $O->GetStmtOption($O->SQL_ROWSET_SIZE), "\n\n"; + # + # while($O->FetchRow()){ + # $iNum = 1; + # # Position yourself in the rowset + # while($O->SetPos($iNum++ ,$O->SQL_POSITION, $O->SQL_LOCK_NO_CHANGE)){ + # undef %Data; + # %Data = $O->DataHash(); + # write(); + # } + # print "\t\tNext rowset...\n"; + # } + # + # The reason I didn't write it that way (which is easier) is to + # show that we can now SetPos(). Also Fetch() now uses + # SQLExtendedFetch() so it can position itself and retrieve + # rowsets. Notice earlier in this Test 10 we set the + # SQL_ROWSET_SIZE. If this was not set it would default to + # no limit (depending upon your ODBC Driver). + #### + + print "\n\tNo more records available.\n"; + }else{ + $Failed{'Test 10'} = "Sql(): " . $O->Error(); + } + + $O->Close(); + +#### +# T E S T 11 +#### + if ($iTempDSN){ + PrintTest(11, "Remove the temporary DSN"); + print "\n\tRemoving the temporary DSN:\n"; + print "\t\tDSN = \"$DSN\"\n\t\tDriver = \"$DriverType\"\n"; + + if (Win32::ODBC::ConfigDSN(ODBC_REMOVE_DSN, $DriverType, "DSN=$DSN")){ + print "\tSuccessful!\n"; + }else{ + print "\tFailed.\n"; + $Failed{'Test 11'} = "ConfigDSN(): Could not remove \"$DSN\":" . Win32::ODBC::Error(); + } + } + + + PrintTest("E N D O F T E S T"); + PresentErrors(); + + + +#----------------------- F U N C T I O N S --------------------------- + +sub Error{ + my($Data) = @_; + $Data->DumpError() if ref($Data); + Win32::ODBC::DumpError() if ! ref($Data); +} + + +sub Center{ + local($Temp, $Width) = @_; + local($Len) = ($Width - length($Temp)) / 2; + return " " x int($Len), $Temp, " " x (int($Len) + (($Len != int($Len))? 1:0)); +} + +sub PrintTest{ + my($Num, $String) = @_; + my($Temp); + if (length($String)){ + $Temp = " T E S T $Num $String "; + }else{ + $Temp = " $Num "; + } + $Len = length($Temp); + print "\n", "-" x ((79 - $Len)/2), $Temp, "-" x ((79 - $Len)/2 - 1), "\n"; + print "\t$String\n"; +} + +sub PresentErrors{ + PrintTest("", "Error Report:"); + if (keys(%Failed)){ + print "The following were errors:\n"; + foreach (sort(keys(%Failed))){ + print "$_ = $Failed{$_}\n"; + } + }else{ + print "\n\nThere were no errors reported during this test.\n\n"; + } +} + + +sub Initialize{ +format Test_8_Header = + @<<<<<<<<<<<<<<<<<<<<<<<<<<< @|||||||||||| @|||||||||||| @||||||||||| + $FieldNames[0], $FieldNames[1], $FieldNames[2], $FieldNames[3] + ---------------------------- ------------- ------------- ------------ +. +format Test_8_Body = + @>. @<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<< @<<<<<<<<<<<< @<<<<<<<<<<< + ++$Num, $Data{$FieldNames[0]}, $Data{$FieldNames[1]}, $Data{$FieldNames[2]}, $Data{$FieldNames[3]} +. +format Test_9_Header = + @<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< + $FieldNames[0], $FieldNames[1], $FieldNames[2], $FieldNames[3] +. +format Test_9_Body = + @<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< @<<<<<<<<<<<<<< + $Data{$FieldNames[0]}, $Data{$FieldNames[1]}, $Data{$FieldNames[2]}, $Data{$FieldNames[3]} +. +} diff --git a/Master/tlpkg/installer/perllib/Win32/WinError.pm b/Master/tlpkg/installer/perllib/Win32/WinError.pm new file mode 100644 index 00000000000..46028a79321 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/WinError.pm @@ -0,0 +1,1017 @@ +package Win32::WinError; + +require Exporter; +require DynaLoader; + +$VERSION = '0.02'; + +@ISA = qw(Exporter DynaLoader); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + GetLastError + CACHE_E_FIRST + CACHE_E_LAST + CACHE_E_NOCACHE_UPDATED + CACHE_S_FIRST + CACHE_S_FORMATETC_NOTSUPPORTED + CACHE_S_LAST + CACHE_S_SAMECACHE + CACHE_S_SOMECACHES_NOTUPDATED + CLASSFACTORY_E_FIRST + CLASSFACTORY_E_LAST + CLASSFACTORY_S_FIRST + CLASSFACTORY_S_LAST + CLASS_E_CLASSNOTAVAILABLE + CLASS_E_NOAGGREGATION + CLIENTSITE_E_FIRST + CLIENTSITE_E_LAST + CLIENTSITE_S_FIRST + CLIENTSITE_S_LAST + CLIPBRD_E_BAD_DATA + CLIPBRD_E_CANT_CLOSE + CLIPBRD_E_CANT_EMPTY + CLIPBRD_E_CANT_OPEN + CLIPBRD_E_CANT_SET + CLIPBRD_E_FIRST + CLIPBRD_E_LAST + CLIPBRD_S_FIRST + CLIPBRD_S_LAST + CONVERT10_E_FIRST + CONVERT10_E_LAST + CONVERT10_E_OLESTREAM_BITMAP_TO_DIB + CONVERT10_E_OLESTREAM_FMT + CONVERT10_E_OLESTREAM_GET + CONVERT10_E_OLESTREAM_PUT + CONVERT10_E_STG_DIB_TO_BITMAP + CONVERT10_E_STG_FMT + CONVERT10_E_STG_NO_STD_STREAM + CONVERT10_S_FIRST + CONVERT10_S_LAST + CONVERT10_S_NO_PRESENTATION + CO_E_ALREADYINITIALIZED + CO_E_APPDIDNTREG + CO_E_APPNOTFOUND + CO_E_APPSINGLEUSE + CO_E_BAD_PATH + CO_E_CANTDETERMINECLASS + CO_E_CLASSSTRING + CO_E_CLASS_CREATE_FAILED + CO_E_DLLNOTFOUND + CO_E_ERRORINAPP + CO_E_ERRORINDLL + CO_E_FIRST + CO_E_IIDSTRING + CO_E_INIT_CLASS_CACHE + CO_E_INIT_MEMORY_ALLOCATOR + CO_E_INIT_ONLY_SINGLE_THREADED + CO_E_INIT_RPC_CHANNEL + CO_E_INIT_SCM_EXEC_FAILURE + CO_E_INIT_SCM_FILE_MAPPING_EXISTS + CO_E_INIT_SCM_MAP_VIEW_OF_FILE + CO_E_INIT_SCM_MUTEX_EXISTS + CO_E_INIT_SHARED_ALLOCATOR + CO_E_INIT_TLS + CO_E_INIT_TLS_CHANNEL_CONTROL + CO_E_INIT_TLS_SET_CHANNEL_CONTROL + CO_E_INIT_UNACCEPTED_USER_ALLOCATOR + CO_E_LAST + CO_E_NOTINITIALIZED + CO_E_OBJISREG + CO_E_OBJNOTCONNECTED + CO_E_OBJNOTREG + CO_E_OBJSRV_RPC_FAILURE + CO_E_RELEASED + CO_E_SCM_ERROR + CO_E_SCM_RPC_FAILURE + CO_E_SERVER_EXEC_FAILURE + CO_E_SERVER_STOPPING + CO_E_WRONGOSFORAPP + CO_S_FIRST + CO_S_LAST + DATA_E_FIRST + DATA_E_LAST + DATA_S_FIRST + DATA_S_LAST + DATA_S_SAMEFORMATETC + DISP_E_ARRAYISLOCKED + DISP_E_BADCALLEE + DISP_E_BADINDEX + DISP_E_BADPARAMCOUNT + DISP_E_BADVARTYPE + DISP_E_EXCEPTION + DISP_E_MEMBERNOTFOUND + DISP_E_NONAMEDARGS + DISP_E_NOTACOLLECTION + DISP_E_OVERFLOW + DISP_E_PARAMNOTFOUND + DISP_E_PARAMNOTOPTIONAL + DISP_E_TYPEMISMATCH + DISP_E_UNKNOWNINTERFACE + DISP_E_UNKNOWNLCID + DISP_E_UNKNOWNNAME + DRAGDROP_E_ALREADYREGISTERED + DRAGDROP_E_FIRST + DRAGDROP_E_INVALIDHWND + DRAGDROP_E_LAST + DRAGDROP_E_NOTREGISTERED + DRAGDROP_S_CANCEL + DRAGDROP_S_DROP + DRAGDROP_S_FIRST + DRAGDROP_S_LAST + DRAGDROP_S_USEDEFAULTCURSORS + DV_E_CLIPFORMAT + DV_E_DVASPECT + DV_E_DVTARGETDEVICE + DV_E_DVTARGETDEVICE_SIZE + DV_E_FORMATETC + DV_E_LINDEX + DV_E_NOIVIEWOBJECT + DV_E_STATDATA + DV_E_STGMEDIUM + DV_E_TYMED + ENUM_E_FIRST + ENUM_E_LAST + ENUM_S_FIRST + ENUM_S_LAST + EPT_S_CANT_CREATE + EPT_S_CANT_PERFORM_OP + EPT_S_INVALID_ENTRY + EPT_S_NOT_REGISTERED + ERROR_ACCESS_DENIED + ERROR_ACCOUNT_DISABLED + ERROR_ACCOUNT_EXPIRED + ERROR_ACCOUNT_LOCKED_OUT + ERROR_ACCOUNT_RESTRICTION + ERROR_ACTIVE_CONNECTIONS + ERROR_ADAP_HDW_ERR + ERROR_ADDRESS_ALREADY_ASSOCIATED + ERROR_ADDRESS_NOT_ASSOCIATED + ERROR_ALIAS_EXISTS + ERROR_ALLOTTED_SPACE_EXCEEDED + ERROR_ALREADY_ASSIGNED + ERROR_ALREADY_EXISTS + ERROR_ALREADY_REGISTERED + ERROR_ALREADY_RUNNING_LKG + ERROR_ALREADY_WAITING + ERROR_ARENA_TRASHED + ERROR_ARITHMETIC_OVERFLOW + ERROR_ATOMIC_LOCKS_NOT_SUPPORTED + ERROR_AUTODATASEG_EXCEEDS_64k + ERROR_BADDB + ERROR_BADKEY + ERROR_BAD_ARGUMENTS + ERROR_BAD_COMMAND + ERROR_BAD_DESCRIPTOR_FORMAT + ERROR_BAD_DEVICE + ERROR_BAD_DEV_TYPE + ERROR_BAD_DRIVER + ERROR_BAD_DRIVER_LEVEL + ERROR_BAD_ENVIRONMENT + ERROR_BAD_EXE_FORMAT + ERROR_BAD_FORMAT + ERROR_BAD_IMPERSONATION_LEVEL + ERROR_BAD_INHERITANCE_ACL + ERROR_BAD_LENGTH + ERROR_BAD_LOGON_SESSION_STATE + ERROR_BAD_NETPATH + ERROR_BAD_NET_NAME + ERROR_BAD_NET_RESP + ERROR_BAD_PATHNAME + ERROR_BAD_PIPE + ERROR_BAD_PROFILE + ERROR_BAD_PROVIDER + ERROR_BAD_REM_ADAP + ERROR_BAD_THREADID_ADDR + ERROR_BAD_TOKEN_TYPE + ERROR_BAD_UNIT + ERROR_BAD_USERNAME + ERROR_BAD_VALIDATION_CLASS + ERROR_BEGINNING_OF_MEDIA + ERROR_BOOT_ALREADY_ACCEPTED + ERROR_BROKEN_PIPE + ERROR_BUFFER_OVERFLOW + ERROR_BUSY + ERROR_BUSY_DRIVE + ERROR_BUS_RESET + ERROR_CALL_NOT_IMPLEMENTED + ERROR_CANCELLED + ERROR_CANCEL_VIOLATION + ERROR_CANNOT_COPY + ERROR_CANNOT_FIND_WND_CLASS + ERROR_CANNOT_IMPERSONATE + ERROR_CANNOT_MAKE + ERROR_CANNOT_OPEN_PROFILE + ERROR_CANTOPEN + ERROR_CANTREAD + ERROR_CANTWRITE + ERROR_CANT_ACCESS_DOMAIN_INFO + ERROR_CANT_DISABLE_MANDATORY + ERROR_CANT_OPEN_ANONYMOUS + ERROR_CAN_NOT_COMPLETE + ERROR_CAN_NOT_DEL_LOCAL_WINS + ERROR_CHILD_MUST_BE_VOLATILE + ERROR_CHILD_NOT_COMPLETE + ERROR_CHILD_WINDOW_MENU + ERROR_CIRCULAR_DEPENDENCY + ERROR_CLASS_ALREADY_EXISTS + ERROR_CLASS_DOES_NOT_EXIST + ERROR_CLASS_HAS_WINDOWS + ERROR_CLIPBOARD_NOT_OPEN + ERROR_CLIPPING_NOT_SUPPORTED + ERROR_CONNECTION_ABORTED + ERROR_CONNECTION_ACTIVE + ERROR_CONNECTION_COUNT_LIMIT + ERROR_CONNECTION_INVALID + ERROR_CONNECTION_REFUSED + ERROR_CONNECTION_UNAVAIL + ERROR_CONTROL_ID_NOT_FOUND + ERROR_COUNTER_TIMEOUT + ERROR_CRC + ERROR_CURRENT_DIRECTORY + ERROR_DATABASE_DOES_NOT_EXIST + ERROR_DC_NOT_FOUND + ERROR_DEPENDENT_SERVICES_RUNNING + ERROR_DESTROY_OBJECT_OF_OTHER_THREAD + ERROR_DEVICE_ALREADY_REMEMBERED + ERROR_DEVICE_IN_USE + ERROR_DEVICE_NOT_PARTITIONED + ERROR_DEV_NOT_EXIST + ERROR_DIRECTORY + ERROR_DIRECT_ACCESS_HANDLE + ERROR_DIR_NOT_EMPTY + ERROR_DIR_NOT_ROOT + ERROR_DISCARDED + ERROR_DISK_CHANGE + ERROR_DISK_CORRUPT + ERROR_DISK_FULL + ERROR_DISK_OPERATION_FAILED + ERROR_DISK_RECALIBRATE_FAILED + ERROR_DISK_RESET_FAILED + ERROR_DLL_INIT_FAILED + ERROR_DOMAIN_CONTROLLER_NOT_FOUND + ERROR_DOMAIN_EXISTS + ERROR_DOMAIN_LIMIT_EXCEEDED + ERROR_DOMAIN_TRUST_INCONSISTENT + ERROR_DRIVE_LOCKED + ERROR_DUPLICATE_SERVICE_NAME + ERROR_DUP_DOMAINNAME + ERROR_DUP_NAME + ERROR_DYNLINK_FROM_INVALID_RING + ERROR_EAS_DIDNT_FIT + ERROR_EAS_NOT_SUPPORTED + ERROR_EA_ACCESS_DENIED + ERROR_EA_FILE_CORRUPT + ERROR_EA_LIST_INCONSISTENT + ERROR_EA_TABLE_FULL + ERROR_END_OF_MEDIA + ERROR_ENVVAR_NOT_FOUND + ERROR_EOM_OVERFLOW + ERROR_EVENTLOG_CANT_START + ERROR_EVENTLOG_FILE_CHANGED + ERROR_EVENTLOG_FILE_CORRUPT + ERROR_EXCEPTION_IN_SERVICE + ERROR_EXCL_SEM_ALREADY_OWNED + ERROR_EXE_MARKED_INVALID + ERROR_EXTENDED_ERROR + ERROR_FAILED_SERVICE_CONTROLLER_CONNECT + ERROR_FAIL_I24 + ERROR_FILEMARK_DETECTED + ERROR_FILENAME_EXCED_RANGE + ERROR_FILE_CORRUPT + ERROR_FILE_EXISTS + ERROR_FILE_INVALID + ERROR_FILE_NOT_FOUND + ERROR_FLOPPY_BAD_REGISTERS + ERROR_FLOPPY_ID_MARK_NOT_FOUND + ERROR_FLOPPY_UNKNOWN_ERROR + ERROR_FLOPPY_WRONG_CYLINDER + ERROR_FULLSCREEN_MODE + ERROR_FULL_BACKUP + ERROR_GENERIC_NOT_MAPPED + ERROR_GEN_FAILURE + ERROR_GLOBAL_ONLY_HOOK + ERROR_GRACEFUL_DISCONNECT + ERROR_GROUP_EXISTS + ERROR_HANDLE_DISK_FULL + ERROR_HANDLE_EOF + ERROR_HOOK_NEEDS_HMOD + ERROR_HOOK_NOT_INSTALLED + ERROR_HOST_UNREACHABLE + ERROR_HOTKEY_ALREADY_REGISTERED + ERROR_HOTKEY_NOT_REGISTERED + ERROR_HWNDS_HAVE_DIFF_PARENT + ERROR_ILL_FORMED_PASSWORD + ERROR_INCORRECT_ADDRESS + ERROR_INC_BACKUP + ERROR_INFLOOP_IN_RELOC_CHAIN + ERROR_INSUFFICIENT_BUFFER + ERROR_INTERNAL_DB_CORRUPTION + ERROR_INTERNAL_DB_ERROR + ERROR_INTERNAL_ERROR + ERROR_INVALID_ACCEL_HANDLE + ERROR_INVALID_ACCESS + ERROR_INVALID_ACCOUNT_NAME + ERROR_INVALID_ACL + ERROR_INVALID_ADDRESS + ERROR_INVALID_AT_INTERRUPT_TIME + ERROR_INVALID_BLOCK + ERROR_INVALID_BLOCK_LENGTH + ERROR_INVALID_CATEGORY + ERROR_INVALID_COMBOBOX_MESSAGE + ERROR_INVALID_COMPUTERNAME + ERROR_INVALID_CURSOR_HANDLE + ERROR_INVALID_DATA + ERROR_INVALID_DATATYPE + ERROR_INVALID_DOMAINNAME + ERROR_INVALID_DOMAIN_ROLE + ERROR_INVALID_DOMAIN_STATE + ERROR_INVALID_DRIVE + ERROR_INVALID_DWP_HANDLE + ERROR_INVALID_EA_HANDLE + ERROR_INVALID_EA_NAME + ERROR_INVALID_EDIT_HEIGHT + ERROR_INVALID_ENVIRONMENT + ERROR_INVALID_EVENTNAME + ERROR_INVALID_EVENT_COUNT + ERROR_INVALID_EXE_SIGNATURE + ERROR_INVALID_FILTER_PROC + ERROR_INVALID_FLAGS + ERROR_INVALID_FLAG_NUMBER + ERROR_INVALID_FORM_NAME + ERROR_INVALID_FORM_SIZE + ERROR_INVALID_FUNCTION + ERROR_INVALID_GROUPNAME + ERROR_INVALID_GROUP_ATTRIBUTES + ERROR_INVALID_GW_COMMAND + ERROR_INVALID_HANDLE + ERROR_INVALID_HOOK_FILTER + ERROR_INVALID_HOOK_HANDLE + ERROR_INVALID_ICON_HANDLE + ERROR_INVALID_ID_AUTHORITY + ERROR_INVALID_INDEX + ERROR_INVALID_LB_MESSAGE + ERROR_INVALID_LEVEL + ERROR_INVALID_LIST_FORMAT + ERROR_INVALID_LOGON_HOURS + ERROR_INVALID_LOGON_TYPE + ERROR_INVALID_MEMBER + ERROR_INVALID_MENU_HANDLE + ERROR_INVALID_MESSAGE + ERROR_INVALID_MESSAGEDEST + ERROR_INVALID_MESSAGENAME + ERROR_INVALID_MINALLOCSIZE + ERROR_INVALID_MODULETYPE + ERROR_INVALID_MSGBOX_STYLE + ERROR_INVALID_NAME + ERROR_INVALID_NETNAME + ERROR_INVALID_ORDINAL + ERROR_INVALID_OWNER + ERROR_INVALID_PARAMETER + ERROR_INVALID_PASSWORD + ERROR_INVALID_PASSWORDNAME + ERROR_INVALID_PIXEL_FORMAT + ERROR_INVALID_PRIMARY_GROUP + ERROR_INVALID_PRINTER_COMMAND + ERROR_INVALID_PRINTER_NAME + ERROR_INVALID_PRINTER_STATE + ERROR_INVALID_PRIORITY + ERROR_INVALID_SCROLLBAR_RANGE + ERROR_INVALID_SECURITY_DESCR + ERROR_INVALID_SEGDPL + ERROR_INVALID_SEGMENT_NUMBER + ERROR_INVALID_SEPARATOR_FILE + ERROR_INVALID_SERVER_STATE + ERROR_INVALID_SERVICENAME + ERROR_INVALID_SERVICE_ACCOUNT + ERROR_INVALID_SERVICE_CONTROL + ERROR_INVALID_SERVICE_LOCK + ERROR_INVALID_SHARENAME + ERROR_INVALID_SHOWWIN_COMMAND + ERROR_INVALID_SID + ERROR_INVALID_SIGNAL_NUMBER + ERROR_INVALID_SPI_VALUE + ERROR_INVALID_STACKSEG + ERROR_INVALID_STARTING_CODESEG + ERROR_INVALID_SUB_AUTHORITY + ERROR_INVALID_TARGET_HANDLE + ERROR_INVALID_THREAD_ID + ERROR_INVALID_TIME + ERROR_INVALID_USER_BUFFER + ERROR_INVALID_VERIFY_SWITCH + ERROR_INVALID_WINDOW_HANDLE + ERROR_INVALID_WINDOW_STYLE + ERROR_INVALID_WORKSTATION + ERROR_IOPL_NOT_ENABLED + ERROR_IO_DEVICE + ERROR_IO_INCOMPLETE + ERROR_IO_PENDING + ERROR_IRQ_BUSY + ERROR_IS_JOINED + ERROR_IS_JOIN_PATH + ERROR_IS_JOIN_TARGET + ERROR_IS_SUBSTED + ERROR_IS_SUBST_PATH + ERROR_IS_SUBST_TARGET + ERROR_ITERATED_DATA_EXCEEDS_64k + ERROR_JOIN_TO_JOIN + ERROR_JOIN_TO_SUBST + ERROR_JOURNAL_HOOK_SET + ERROR_KEY_DELETED + ERROR_KEY_HAS_CHILDREN + ERROR_LABEL_TOO_LONG + ERROR_LAST_ADMIN + ERROR_LB_WITHOUT_TABSTOPS + ERROR_LISTBOX_ID_NOT_FOUND + ERROR_LM_CROSS_ENCRYPTION_REQUIRED + ERROR_LOCAL_USER_SESSION_KEY + ERROR_LOCKED + ERROR_LOCK_FAILED + ERROR_LOCK_VIOLATION + ERROR_LOGIN_TIME_RESTRICTION + ERROR_LOGIN_WKSTA_RESTRICTION + ERROR_LOGON_FAILURE + ERROR_LOGON_NOT_GRANTED + ERROR_LOGON_SESSION_COLLISION + ERROR_LOGON_SESSION_EXISTS + ERROR_LOGON_TYPE_NOT_GRANTED + ERROR_LOG_FILE_FULL + ERROR_LUIDS_EXHAUSTED + ERROR_MAPPED_ALIGNMENT + ERROR_MAX_THRDS_REACHED + ERROR_MEDIA_CHANGED + ERROR_MEMBERS_PRIMARY_GROUP + ERROR_MEMBER_IN_ALIAS + ERROR_MEMBER_IN_GROUP + ERROR_MEMBER_NOT_IN_ALIAS + ERROR_MEMBER_NOT_IN_GROUP + ERROR_METAFILE_NOT_SUPPORTED + ERROR_META_EXPANSION_TOO_LONG + ERROR_MOD_NOT_FOUND + ERROR_MORE_DATA + ERROR_MORE_WRITES + ERROR_MR_MID_NOT_FOUND + ERROR_NEGATIVE_SEEK + ERROR_NESTING_NOT_ALLOWED + ERROR_NETLOGON_NOT_STARTED + ERROR_NETNAME_DELETED + ERROR_NETWORK_ACCESS_DENIED + ERROR_NETWORK_BUSY + ERROR_NETWORK_UNREACHABLE + ERROR_NET_WRITE_FAULT + ERROR_NOACCESS + ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT + ERROR_NOLOGON_SERVER_TRUST_ACCOUNT + ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT + ERROR_NONE_MAPPED + ERROR_NON_MDICHILD_WINDOW + ERROR_NOTIFY_ENUM_DIR + ERROR_NOT_ALL_ASSIGNED + ERROR_NOT_CHILD_WINDOW + ERROR_NOT_CONNECTED + ERROR_NOT_CONTAINER + ERROR_NOT_DOS_DISK + ERROR_NOT_ENOUGH_MEMORY + ERROR_NOT_ENOUGH_QUOTA + ERROR_NOT_ENOUGH_SERVER_MEMORY + ERROR_NOT_JOINED + ERROR_NOT_LOCKED + ERROR_NOT_LOGON_PROCESS + ERROR_NOT_OWNER + ERROR_NOT_READY + ERROR_NOT_REGISTRY_FILE + ERROR_NOT_SAME_DEVICE + ERROR_NOT_SUBSTED + ERROR_NOT_SUPPORTED + ERROR_NO_BROWSER_SERVERS_FOUND + ERROR_NO_DATA + ERROR_NO_DATA_DETECTED + ERROR_NO_IMPERSONATION_TOKEN + ERROR_NO_INHERITANCE + ERROR_NO_LOGON_SERVERS + ERROR_NO_LOG_SPACE + ERROR_NO_MEDIA_IN_DRIVE + ERROR_NO_MORE_FILES + ERROR_NO_MORE_ITEMS + ERROR_NO_MORE_SEARCH_HANDLES + ERROR_NO_NETWORK + ERROR_NO_NET_OR_BAD_PATH + ERROR_NO_PROC_SLOTS + ERROR_NO_QUOTAS_FOR_ACCOUNT + ERROR_NO_SCROLLBARS + ERROR_NO_SECURITY_ON_OBJECT + ERROR_NO_SHUTDOWN_IN_PROGRESS + ERROR_NO_SIGNAL_SENT + ERROR_NO_SPOOL_SPACE + ERROR_NO_SUCH_ALIAS + ERROR_NO_SUCH_DOMAIN + ERROR_NO_SUCH_GROUP + ERROR_NO_SUCH_LOGON_SESSION + ERROR_NO_SUCH_MEMBER + ERROR_NO_SUCH_PACKAGE + ERROR_NO_SUCH_PRIVILEGE + ERROR_NO_SUCH_USER + ERROR_NO_SYSTEM_MENU + ERROR_NO_TOKEN + ERROR_NO_TRUST_LSA_SECRET + ERROR_NO_TRUST_SAM_ACCOUNT + ERROR_NO_UNICODE_TRANSLATION + ERROR_NO_USER_SESSION_KEY + ERROR_NO_VOLUME_LABEL + ERROR_NO_WILDCARD_CHARACTERS + ERROR_NT_CROSS_ENCRYPTION_REQUIRED + ERROR_NULL_LM_PASSWORD + ERROR_OPEN_FAILED + ERROR_OPEN_FILES + ERROR_OPERATION_ABORTED + ERROR_OUTOFMEMORY + ERROR_OUT_OF_PAPER + ERROR_OUT_OF_STRUCTURES + ERROR_PARTIAL_COPY + ERROR_PARTITION_FAILURE + ERROR_PASSWORD_EXPIRED + ERROR_PASSWORD_MUST_CHANGE + ERROR_PASSWORD_RESTRICTION + ERROR_PATH_BUSY + ERROR_PATH_NOT_FOUND + ERROR_PIPE_BUSY + ERROR_PIPE_CONNECTED + ERROR_PIPE_LISTENING + ERROR_PIPE_NOT_CONNECTED + ERROR_POPUP_ALREADY_ACTIVE + ERROR_PORT_UNREACHABLE + ERROR_POSSIBLE_DEADLOCK + ERROR_PRINTER_ALREADY_EXISTS + ERROR_PRINTER_DELETED + ERROR_PRINTER_DRIVER_ALREADY_INSTALLED + ERROR_PRINTER_DRIVER_IN_USE + ERROR_PRINTQ_FULL + ERROR_PRINT_CANCELLED + ERROR_PRINT_MONITOR_ALREADY_INSTALLED + ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED + ERROR_PRIVATE_DIALOG_INDEX + ERROR_PRIVILEGE_NOT_HELD + ERROR_PROCESS_ABORTED + ERROR_PROC_NOT_FOUND + ERROR_PROTOCOL_UNREACHABLE + ERROR_READ_FAULT + ERROR_REC_NON_EXISTENT + ERROR_REDIRECTOR_HAS_OPEN_HANDLES + ERROR_REDIR_PAUSED + ERROR_REGISTRY_CORRUPT + ERROR_REGISTRY_IO_FAILED + ERROR_REGISTRY_RECOVERED + ERROR_RELOC_CHAIN_XEEDS_SEGLIM + ERROR_REMOTE_SESSION_LIMIT_EXCEEDED + ERROR_REM_NOT_LIST + ERROR_REQUEST_ABORTED + ERROR_REQ_NOT_ACCEP + ERROR_RESOURCE_DATA_NOT_FOUND + ERROR_RESOURCE_LANG_NOT_FOUND + ERROR_RESOURCE_NAME_NOT_FOUND + ERROR_RESOURCE_TYPE_NOT_FOUND + ERROR_RETRY + ERROR_REVISION_MISMATCH + ERROR_RING2SEG_MUST_BE_MOVABLE + ERROR_RING2_STACK_IN_USE + ERROR_RPL_NOT_ALLOWED + ERROR_RXACT_COMMIT_FAILURE + ERROR_RXACT_INVALID_STATE + ERROR_SAME_DRIVE + ERROR_SCREEN_ALREADY_LOCKED + ERROR_SECRET_TOO_LONG + ERROR_SECTOR_NOT_FOUND + ERROR_SEEK + ERROR_SEEK_ON_DEVICE + ERROR_SEM_IS_SET + ERROR_SEM_NOT_FOUND + ERROR_SEM_OWNER_DIED + ERROR_SEM_TIMEOUT + ERROR_SEM_USER_LIMIT + ERROR_SERIAL_NO_DEVICE + ERROR_SERVER_DISABLED + ERROR_SERVER_HAS_OPEN_HANDLES + ERROR_SERVER_NOT_DISABLED + ERROR_SERVICE_ALREADY_RUNNING + ERROR_SERVICE_CANNOT_ACCEPT_CTRL + ERROR_SERVICE_DATABASE_LOCKED + ERROR_SERVICE_DEPENDENCY_DELETED + ERROR_SERVICE_DEPENDENCY_FAIL + ERROR_SERVICE_DISABLED + ERROR_SERVICE_DOES_NOT_EXIST + ERROR_SERVICE_EXISTS + ERROR_SERVICE_LOGON_FAILED + ERROR_SERVICE_MARKED_FOR_DELETE + ERROR_SERVICE_NEVER_STARTED + ERROR_SERVICE_NOT_ACTIVE + ERROR_SERVICE_NOT_FOUND + ERROR_SERVICE_NO_THREAD + ERROR_SERVICE_REQUEST_TIMEOUT + ERROR_SERVICE_SPECIFIC_ERROR + ERROR_SERVICE_START_HANG + ERROR_SESSION_CREDENTIAL_CONFLICT + ERROR_SETCOUNT_ON_BAD_LB + ERROR_SETMARK_DETECTED + ERROR_SHARING_BUFFER_EXCEEDED + ERROR_SHARING_PAUSED + ERROR_SHARING_VIOLATION + ERROR_SHUTDOWN_IN_PROGRESS + ERROR_SIGNAL_PENDING + ERROR_SIGNAL_REFUSED + ERROR_SOME_NOT_MAPPED + ERROR_SPECIAL_ACCOUNT + ERROR_SPECIAL_GROUP + ERROR_SPECIAL_USER + ERROR_SPL_NO_ADDJOB + ERROR_SPL_NO_STARTDOC + ERROR_SPOOL_FILE_NOT_FOUND + ERROR_STACK_OVERFLOW + ERROR_STATIC_INIT + ERROR_SUBST_TO_JOIN + ERROR_SUBST_TO_SUBST + ERROR_SUCCESS + ERROR_SWAPERROR + ERROR_SYSTEM_TRACE + ERROR_THREAD_1_INACTIVE + ERROR_TLW_WITH_WSCHILD + ERROR_TOKEN_ALREADY_IN_USE + ERROR_TOO_MANY_CMDS + ERROR_TOO_MANY_CONTEXT_IDS + ERROR_TOO_MANY_LUIDS_REQUESTED + ERROR_TOO_MANY_MODULES + ERROR_TOO_MANY_MUXWAITERS + ERROR_TOO_MANY_NAMES + ERROR_TOO_MANY_OPEN_FILES + ERROR_TOO_MANY_POSTS + ERROR_TOO_MANY_SECRETS + ERROR_TOO_MANY_SEMAPHORES + ERROR_TOO_MANY_SEM_REQUESTS + ERROR_TOO_MANY_SESS + ERROR_TOO_MANY_SIDS + ERROR_TOO_MANY_TCBS + ERROR_TRANSFORM_NOT_SUPPORTED + ERROR_TRUSTED_DOMAIN_FAILURE + ERROR_TRUSTED_RELATIONSHIP_FAILURE + ERROR_TRUST_FAILURE + ERROR_UNABLE_TO_LOCK_MEDIA + ERROR_UNABLE_TO_UNLOAD_MEDIA + ERROR_UNEXP_NET_ERR + ERROR_UNKNOWN_PORT + ERROR_UNKNOWN_PRINTER_DRIVER + ERROR_UNKNOWN_PRINTPROCESSOR + ERROR_UNKNOWN_PRINT_MONITOR + ERROR_UNKNOWN_REVISION + ERROR_UNRECOGNIZED_MEDIA + ERROR_UNRECOGNIZED_VOLUME + ERROR_USER_EXISTS + ERROR_USER_MAPPED_FILE + ERROR_VC_DISCONNECTED + ERROR_WAIT_NO_CHILDREN + ERROR_WINDOW_NOT_COMBOBOX + ERROR_WINDOW_NOT_DIALOG + ERROR_WINDOW_OF_OTHER_THREAD + ERROR_WINS_INTERNAL + ERROR_WRITE_FAULT + ERROR_WRITE_PROTECT + ERROR_WRONG_DISK + ERROR_WRONG_PASSWORD + E_ABORT + E_ACCESSDENIED + E_FAIL + E_HANDLE + E_INVALIDARG + E_NOINTERFACE + E_NOTIMPL + E_OUTOFMEMORY + E_POINTER + E_UNEXPECTED + FACILITY_CONTROL + FACILITY_DISPATCH + FACILITY_ITF + FACILITY_NT_BIT + FACILITY_NULL + FACILITY_RPC + FACILITY_STORAGE + FACILITY_WIN32 + FACILITY_WINDOWS + INPLACE_E_FIRST + INPLACE_E_LAST + INPLACE_E_NOTOOLSPACE + INPLACE_E_NOTUNDOABLE + INPLACE_S_FIRST + INPLACE_S_LAST + INPLACE_S_TRUNCATED + MARSHAL_E_FIRST + MARSHAL_E_LAST + MARSHAL_S_FIRST + MARSHAL_S_LAST + MEM_E_INVALID_LINK + MEM_E_INVALID_ROOT + MEM_E_INVALID_SIZE + MK_E_CANTOPENFILE + MK_E_CONNECTMANUALLY + MK_E_ENUMERATION_FAILED + MK_E_EXCEEDEDDEADLINE + MK_E_FIRST + MK_E_INTERMEDIATEINTERFACENOTSUPPORTED + MK_E_INVALIDEXTENSION + MK_E_LAST + MK_E_MUSTBOTHERUSER + MK_E_NEEDGENERIC + MK_E_NOINVERSE + MK_E_NOOBJECT + MK_E_NOPREFIX + MK_E_NOSTORAGE + MK_E_NOTBINDABLE + MK_E_NOTBOUND + MK_E_NO_NORMALIZED + MK_E_SYNTAX + MK_E_UNAVAILABLE + MK_S_FIRST + MK_S_HIM + MK_S_LAST + MK_S_ME + MK_S_MONIKERALREADYREGISTERED + MK_S_REDUCED_TO_SELF + MK_S_US + NOERROR + NO_ERROR + OLEOBJ_E_FIRST + OLEOBJ_E_INVALIDVERB + OLEOBJ_E_LAST + OLEOBJ_E_NOVERBS + OLEOBJ_S_CANNOT_DOVERB_NOW + OLEOBJ_S_FIRST + OLEOBJ_S_INVALIDHWND + OLEOBJ_S_INVALIDVERB + OLEOBJ_S_LAST + OLE_E_ADVF + OLE_E_ADVISENOTSUPPORTED + OLE_E_BLANK + OLE_E_CANTCONVERT + OLE_E_CANT_BINDTOSOURCE + OLE_E_CANT_GETMONIKER + OLE_E_CLASSDIFF + OLE_E_ENUM_NOMORE + OLE_E_FIRST + OLE_E_INVALIDHWND + OLE_E_INVALIDRECT + OLE_E_LAST + OLE_E_NOCACHE + OLE_E_NOCONNECTION + OLE_E_NOSTORAGE + OLE_E_NOTRUNNING + OLE_E_NOT_INPLACEACTIVE + OLE_E_OLEVERB + OLE_E_PROMPTSAVECANCELLED + OLE_E_STATIC + OLE_E_WRONGCOMPOBJ + OLE_S_FIRST + OLE_S_LAST + OLE_S_MAC_CLIPFORMAT + OLE_S_STATIC + OLE_S_USEREG + REGDB_E_CLASSNOTREG + REGDB_E_FIRST + REGDB_E_IIDNOTREG + REGDB_E_INVALIDVALUE + REGDB_E_KEYMISSING + REGDB_E_LAST + REGDB_E_READREGDB + REGDB_E_WRITEREGDB + REGDB_S_FIRST + REGDB_S_LAST + RPC_E_ATTEMPTED_MULTITHREAD + RPC_E_CALL_CANCELED + RPC_E_CALL_REJECTED + RPC_E_CANTCALLOUT_AGAIN + RPC_E_CANTCALLOUT_INASYNCCALL + RPC_E_CANTCALLOUT_INEXTERNALCALL + RPC_E_CANTCALLOUT_ININPUTSYNCCALL + RPC_E_CANTPOST_INSENDCALL + RPC_E_CANTTRANSMIT_CALL + RPC_E_CHANGED_MODE + RPC_E_CLIENT_CANTMARSHAL_DATA + RPC_E_CLIENT_CANTUNMARSHAL_DATA + RPC_E_CLIENT_DIED + RPC_E_CONNECTION_TERMINATED + RPC_E_DISCONNECTED + RPC_E_FAULT + RPC_E_INVALIDMETHOD + RPC_E_INVALID_CALLDATA + RPC_E_INVALID_DATA + RPC_E_INVALID_DATAPACKET + RPC_E_INVALID_PARAMETER + RPC_E_NOT_REGISTERED + RPC_E_OUT_OF_RESOURCES + RPC_E_RETRY + RPC_E_SERVERCALL_REJECTED + RPC_E_SERVERCALL_RETRYLATER + RPC_E_SERVERFAULT + RPC_E_SERVER_CANTMARSHAL_DATA + RPC_E_SERVER_CANTUNMARSHAL_DATA + RPC_E_SERVER_DIED + RPC_E_SERVER_DIED_DNE + RPC_E_SYS_CALL_FAILED + RPC_E_THREAD_NOT_INIT + RPC_E_UNEXPECTED + RPC_E_WRONG_THREAD + RPC_S_ADDRESS_ERROR + RPC_S_ALREADY_LISTENING + RPC_S_ALREADY_REGISTERED + RPC_S_BINDING_HAS_NO_AUTH + RPC_S_BINDING_INCOMPLETE + RPC_S_CALL_CANCELLED + RPC_S_CALL_FAILED + RPC_S_CALL_FAILED_DNE + RPC_S_CALL_IN_PROGRESS + RPC_S_CANNOT_SUPPORT + RPC_S_CANT_CREATE_ENDPOINT + RPC_S_COMM_FAILURE + RPC_S_DUPLICATE_ENDPOINT + RPC_S_ENTRY_ALREADY_EXISTS + RPC_S_ENTRY_NOT_FOUND + RPC_S_FP_DIV_ZERO + RPC_S_FP_OVERFLOW + RPC_S_FP_UNDERFLOW + RPC_S_GROUP_MEMBER_NOT_FOUND + RPC_S_INCOMPLETE_NAME + RPC_S_INTERFACE_NOT_FOUND + RPC_S_INTERNAL_ERROR + RPC_S_INVALID_AUTH_IDENTITY + RPC_S_INVALID_BINDING + RPC_S_INVALID_BOUND + RPC_S_INVALID_ENDPOINT_FORMAT + RPC_S_INVALID_NAF_ID + RPC_S_INVALID_NAME_SYNTAX + RPC_S_INVALID_NETWORK_OPTIONS + RPC_S_INVALID_NET_ADDR + RPC_S_INVALID_OBJECT + RPC_S_INVALID_RPC_PROTSEQ + RPC_S_INVALID_STRING_BINDING + RPC_S_INVALID_STRING_UUID + RPC_S_INVALID_TAG + RPC_S_INVALID_TIMEOUT + RPC_S_INVALID_VERS_OPTION + RPC_S_MAX_CALLS_TOO_SMALL + RPC_S_NAME_SERVICE_UNAVAILABLE + RPC_S_NOTHING_TO_EXPORT + RPC_S_NOT_ALL_OBJS_UNEXPORTED + RPC_S_NOT_CANCELLED + RPC_S_NOT_LISTENING + RPC_S_NOT_RPC_ERROR + RPC_S_NO_BINDINGS + RPC_S_NO_CALL_ACTIVE + RPC_S_NO_CONTEXT_AVAILABLE + RPC_S_NO_ENDPOINT_FOUND + RPC_S_NO_ENTRY_NAME + RPC_S_NO_INTERFACES + RPC_S_NO_MORE_BINDINGS + RPC_S_NO_MORE_MEMBERS + RPC_S_NO_PRINC_NAME + RPC_S_NO_PROTSEQS + RPC_S_NO_PROTSEQS_REGISTERED + RPC_S_OBJECT_NOT_FOUND + RPC_S_OUT_OF_RESOURCES + RPC_S_PROCNUM_OUT_OF_RANGE + RPC_S_PROTOCOL_ERROR + RPC_S_PROTSEQ_NOT_FOUND + RPC_S_PROTSEQ_NOT_SUPPORTED + RPC_S_SEC_PKG_ERROR + RPC_S_SERVER_TOO_BUSY + RPC_S_SERVER_UNAVAILABLE + RPC_S_STRING_TOO_LONG + RPC_S_TYPE_ALREADY_REGISTERED + RPC_S_UNKNOWN_AUTHN_LEVEL + RPC_S_UNKNOWN_AUTHN_SERVICE + RPC_S_UNKNOWN_AUTHN_TYPE + RPC_S_UNKNOWN_AUTHZ_SERVICE + RPC_S_UNKNOWN_IF + RPC_S_UNKNOWN_MGR_TYPE + RPC_S_UNSUPPORTED_AUTHN_LEVEL + RPC_S_UNSUPPORTED_NAME_SYNTAX + RPC_S_UNSUPPORTED_TRANS_SYN + RPC_S_UNSUPPORTED_TYPE + RPC_S_UUID_LOCAL_ONLY + RPC_S_UUID_NO_ADDRESS + RPC_S_WRONG_KIND_OF_BINDING + RPC_S_ZERO_DIVIDE + RPC_X_BAD_STUB_DATA + RPC_X_BYTE_COUNT_TOO_SMALL + RPC_X_ENUM_VALUE_OUT_OF_RANGE + RPC_X_INVALID_ES_ACTION + RPC_X_NO_MORE_ENTRIES + RPC_X_NULL_REF_POINTER + RPC_X_SS_CANNOT_GET_CALL_HANDLE + RPC_X_SS_CHAR_TRANS_OPEN_FAIL + RPC_X_SS_CHAR_TRANS_SHORT_FILE + RPC_X_SS_CONTEXT_DAMAGED + RPC_X_SS_HANDLES_MISMATCH + RPC_X_SS_IN_NULL_CONTEXT + RPC_X_WRONG_ES_VERSION + RPC_X_WRONG_STUB_VERSION + SEVERITY_ERROR + SEVERITY_SUCCESS + STG_E_ABNORMALAPIEXIT + STG_E_ACCESSDENIED + STG_E_CANTSAVE + STG_E_DISKISWRITEPROTECTED + STG_E_EXTANTMARSHALLINGS + STG_E_FILEALREADYEXISTS + STG_E_FILENOTFOUND + STG_E_INSUFFICIENTMEMORY + STG_E_INUSE + STG_E_INVALIDFLAG + STG_E_INVALIDFUNCTION + STG_E_INVALIDHANDLE + STG_E_INVALIDHEADER + STG_E_INVALIDNAME + STG_E_INVALIDPARAMETER + STG_E_INVALIDPOINTER + STG_E_LOCKVIOLATION + STG_E_MEDIUMFULL + STG_E_NOMOREFILES + STG_E_NOTCURRENT + STG_E_NOTFILEBASEDSTORAGE + STG_E_OLDDLL + STG_E_OLDFORMAT + STG_E_PATHNOTFOUND + STG_E_READFAULT + STG_E_REVERTED + STG_E_SEEKERROR + STG_E_SHAREREQUIRED + STG_E_SHAREVIOLATION + STG_E_TOOMANYOPENFILES + STG_E_UNIMPLEMENTEDFUNCTION + STG_E_UNKNOWN + STG_E_WRITEFAULT + STG_S_CONVERTED + S_FALSE + S_OK + TYPE_E_AMBIGUOUSNAME + TYPE_E_BADMODULEKIND + TYPE_E_BUFFERTOOSMALL + TYPE_E_CANTCREATETMPFILE + TYPE_E_CANTLOADLIBRARY + TYPE_E_CIRCULARTYPE + TYPE_E_DLLFUNCTIONNOTFOUND + TYPE_E_DUPLICATEID + TYPE_E_ELEMENTNOTFOUND + TYPE_E_INCONSISTENTPROPFUNCS + TYPE_E_INVALIDID + TYPE_E_INVALIDSTATE + TYPE_E_INVDATAREAD + TYPE_E_IOERROR + TYPE_E_LIBNOTREGISTERED + TYPE_E_NAMECONFLICT + TYPE_E_OUTOFBOUNDS + TYPE_E_QUALIFIEDNAMEDISALLOWED + TYPE_E_REGISTRYACCESS + TYPE_E_SIZETOOBIG + TYPE_E_TYPEMISMATCH + TYPE_E_UNDEFINEDTYPE + TYPE_E_UNKNOWNLCID + TYPE_E_UNSUPFORMAT + TYPE_E_WRONGTYPEKIND + VIEW_E_DRAW + VIEW_E_FIRST + VIEW_E_LAST + VIEW_S_ALREADY_FROZEN + VIEW_S_FIRST + VIEW_S_LAST +); + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + #reset $! to zero to reset any current errors. + local $! = 0; + local $^E = 0; + my $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined Win32::WinError macro $constname, used at $file line $line."; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap Win32::WinError; + +# Preloaded methods go here. + +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ diff --git a/Master/tlpkg/installer/perllib/Win32/test-async.pl b/Master/tlpkg/installer/perllib/Win32/test-async.pl new file mode 100644 index 00000000000..c47e2df04ec --- /dev/null +++ b/Master/tlpkg/installer/perllib/Win32/test-async.pl @@ -0,0 +1,129 @@ +# +# TEST-ASYNC.PL +# Test Win32::Internet's Asynchronous Operations +# by Aldo Calpini <dada@divinf.it> +# +# WARNING: this code is most likely to fail with almost-random errors +# I don't know what is wrong here, any hint will be greatly +# appreciated! + +use Win32::Internet; + +$params{'flags'} = INTERNET_FLAG_ASYNC; +$params{'opentype'} = INTERNET_OPEN_TYPE_DIRECT; +$I = new Win32::Internet(\%params); + +# print "Error: ", $I->Error(), "\n"; +print "I.handle=", $I->{'handle'}, "\n"; + +$return = $I->SetStatusCallback(); +print "SetStatusCallback=$return"; +print "ERROR" if $return eq undef; +print "\n"; + +$buffer = $I->QueryOption(INTERNET_OPTION_READ_BUFFER_SIZE); +print "Buffer=$buffer\n"; + +$host = "ftp.activeware.com"; +$user = "anonymous"; +$pass = "dada\@divinf.it"; + + +print "Doing FTP()...\n"; + +$handle2 = $I->FTP($FTP, $host, $user, $pass, 21, 1); + +print "Returned from FTP()...\n"; + +($n, $t) = $I->Error(); + +if($n == 997) { + print "Going asynchronous...\n"; + ($status, $info) = $I->GetStatusCallback(1); + while($status != 100 and $status != 70) { + if($oldstatus != $status) { + if($status == 60) { + $FTP->{'handle'} = $info; + } elsif($status == 10) { + print "resolving name... \n"; + } elsif($status == 11) { + print "name resolved... \n"; + } elsif($status == 20) { + print "connecting... \n"; + } elsif($status == 21) { + print "connected... \n"; + } elsif($status == 30) { + print "sending... \n"; + } elsif($status == 31) { + print "$info bytes sent. \n"; + } elsif($status == 40) { + print "receiving... \n"; + } elsif($status == 41) { + print "$info bytes received. \n"; + } else { + print "status=$status\n"; + } + } + $oldstatus = $status; + ($status, $info) = $I->GetStatusCallback(1); + } +} else { + print "Error=", $I->Error(), "\n"; +} +print "FTP.handle=", $FTP->{'handle'}, "\n"; +print "STATUS(after FTP)=", $I->GetStatusCallback(1), "\n"; + +# "/pub/microsoft/sdk/activex13.exe", + +print "Doing Get()...\n"; + +$file = "/Perl-Win32/perl5.001m/currentBuild/110-i86.zip"; + +$FTP->Get($file, "110-i86.zip", 1, 0, 2); + +print "Returned from Get()...\n"; + +($n, $t) = $I->Error(); +if($n == 997) { + print "Going asynchronous...\n"; + $bytes = 0; + $oldstatus = 0; + ($status, $info) = $I->GetStatusCallback(2); + while($status != 100 and $status != 70) { + # print "status=$status info=$info\n"; + # if($oldstatus!=$status) { + if($status == 10) { + print "resolving name... \n"; + } elsif($status == 11) { + print "name resolved... \n"; + } elsif($status == 20) { + print "connecting... \n"; + } elsif($status == 21) { + print "connected... \n"; + #} elsif($status == 30) { + # print "sending... \n"; + } elsif($status == 31) { + print "$info bytes sent. \n"; + #} elsif($status == 40) { + # print "receiving... \n"; + } elsif($status == 41) { + $bytes = $bytes+$info; + print "$bytes bytes received. \n"; + #} else { + # print "status=$status\n"; + } + # } + $oldstatus = $status; + undef $status, $info; + ($status, $info) = $I->GetStatusCallback(2); + } +} else { + print "Error=[$n] $t\n"; +} +print "\n"; +($status, $info) = $I->GetStatusCallback(2); +print "STATUS(after Get)=$status\n"; +print "Error=", $I->Error(), "\n"; +exit(0); + + diff --git a/Master/tlpkg/installer/perllib/attributes.pm b/Master/tlpkg/installer/perllib/attributes.pm new file mode 100644 index 00000000000..714cb267218 --- /dev/null +++ b/Master/tlpkg/installer/perllib/attributes.pm @@ -0,0 +1,418 @@ +package attributes; + +our $VERSION = 0.06; + +@EXPORT_OK = qw(get reftype); +@EXPORT = (); +%EXPORT_TAGS = (ALL => [@EXPORT, @EXPORT_OK]); + +use strict; + +sub croak { + require Carp; + goto &Carp::croak; +} + +sub carp { + require Carp; + goto &Carp::carp; +} + +## forward declaration(s) rather than wrapping the bootstrap call in BEGIN{} +#sub reftype ($) ; +#sub _fetch_attrs ($) ; +#sub _guess_stash ($) ; +#sub _modify_attrs ; +#sub _warn_reserved () ; +# +# The extra trips through newATTRSUB in the interpreter wipe out any savings +# from avoiding the BEGIN block. Just do the bootstrap now. +BEGIN { bootstrap attributes } + +sub import { + @_ > 2 && ref $_[2] or do { + require Exporter; + goto &Exporter::import; + }; + my (undef,$home_stash,$svref,@attrs) = @_; + + my $svtype = uc reftype($svref); + my $pkgmeth; + $pkgmeth = UNIVERSAL::can($home_stash, "MODIFY_${svtype}_ATTRIBUTES") + if defined $home_stash && $home_stash ne ''; + my @badattrs; + if ($pkgmeth) { + my @pkgattrs = _modify_attrs($svref, @attrs); + @badattrs = $pkgmeth->($home_stash, $svref, @attrs); + if (!@badattrs && @pkgattrs) { + return unless _warn_reserved; + @pkgattrs = grep { m/\A[[:lower:]]+(?:\z|\()/ } @pkgattrs; + if (@pkgattrs) { + for my $attr (@pkgattrs) { + $attr =~ s/\(.+\z//s; + } + my $s = ((@pkgattrs == 1) ? '' : 's'); + carp "$svtype package attribute$s " . + "may clash with future reserved word$s: " . + join(' : ' , @pkgattrs); + } + } + } + else { + @badattrs = _modify_attrs($svref, @attrs); + } + if (@badattrs) { + croak "Invalid $svtype attribute" . + (( @badattrs == 1 ) ? '' : 's') . + ": " . + join(' : ', @badattrs); + } +} + +sub get ($) { + @_ == 1 && ref $_[0] or + croak 'Usage: '.__PACKAGE__.'::get $ref'; + my $svref = shift; + my $svtype = uc reftype $svref; + my $stash = _guess_stash $svref; + $stash = caller unless defined $stash; + my $pkgmeth; + $pkgmeth = UNIVERSAL::can($stash, "FETCH_${svtype}_ATTRIBUTES") + if defined $stash && $stash ne ''; + return $pkgmeth ? + (_fetch_attrs($svref), $pkgmeth->($stash, $svref)) : + (_fetch_attrs($svref)) + ; +} + +sub require_version { goto &UNIVERSAL::VERSION } + +1; +__END__ +#The POD goes here + +=head1 NAME + +attributes - get/set subroutine or variable attributes + +=head1 SYNOPSIS + + sub foo : method ; + my ($x,@y,%z) : Bent = 1; + my $s = sub : method { ... }; + + use attributes (); # optional, to get subroutine declarations + my @attrlist = attributes::get(\&foo); + + use attributes 'get'; # import the attributes::get subroutine + my @attrlist = get \&foo; + +=head1 DESCRIPTION + +Subroutine declarations and definitions may optionally have attribute lists +associated with them. (Variable C<my> declarations also may, but see the +warning below.) Perl handles these declarations by passing some information +about the call site and the thing being declared along with the attribute +list to this module. In particular, the first example above is equivalent to +the following: + + use attributes __PACKAGE__, \&foo, 'method'; + +The second example in the synopsis does something equivalent to this: + + use attributes (); + my ($x,@y,%z); + attributes::->import(__PACKAGE__, \$x, 'Bent'); + attributes::->import(__PACKAGE__, \@y, 'Bent'); + attributes::->import(__PACKAGE__, \%z, 'Bent'); + ($x,@y,%z) = 1; + +Yes, that's a lot of expansion. + +B<WARNING>: attribute declarations for variables are still evolving. +The semantics and interfaces of such declarations could change in +future versions. They are present for purposes of experimentation +with what the semantics ought to be. Do not rely on the current +implementation of this feature. + +There are only a few attributes currently handled by Perl itself (or +directly by this module, depending on how you look at it.) However, +package-specific attributes are allowed by an extension mechanism. +(See L<"Package-specific Attribute Handling"> below.) + +The setting of subroutine attributes happens at compile time. +Variable attributes in C<our> declarations are also applied at compile time. +However, C<my> variables get their attributes applied at run-time. +This means that you have to I<reach> the run-time component of the C<my> +before those attributes will get applied. For example: + + my $x : Bent = 42 if 0; + +will neither assign 42 to $x I<nor> will it apply the C<Bent> attribute +to the variable. + +An attempt to set an unrecognized attribute is a fatal error. (The +error is trappable, but it still stops the compilation within that +C<eval>.) Setting an attribute with a name that's all lowercase +letters that's not a built-in attribute (such as "foo") will result in +a warning with B<-w> or C<use warnings 'reserved'>. + +=head2 Built-in Attributes + +The following are the built-in attributes for subroutines: + +=over 4 + +=item locked + +B<5.005 threads only! The use of the "locked" attribute currently +only makes sense if you are using the deprecated "Perl 5.005 threads" +implementation of threads.> + +Setting this attribute is only meaningful when the subroutine or +method is to be called by multiple threads. When set on a method +subroutine (i.e., one marked with the B<method> attribute below), +Perl ensures that any invocation of it implicitly locks its first +argument before execution. When set on a non-method subroutine, +Perl ensures that a lock is taken on the subroutine itself before +execution. The semantics of the lock are exactly those of one +explicitly taken with the C<lock> operator immediately after the +subroutine is entered. + +=item method + +Indicates that the referenced subroutine is a method. +This has a meaning when taken together with the B<locked> attribute, +as described there. It also means that a subroutine so marked +will not trigger the "Ambiguous call resolved as CORE::%s" warning. + +=item lvalue + +Indicates that the referenced subroutine is a valid lvalue and can +be assigned to. The subroutine must return a modifiable value such +as a scalar variable, as described in L<perlsub>. + +=back + +For global variables there is C<unique> attribute: see L<perlfunc/our>. + +=head2 Available Subroutines + +The following subroutines are available for general use once this module +has been loaded: + +=over 4 + +=item get + +This routine expects a single parameter--a reference to a +subroutine or variable. It returns a list of attributes, which may be +empty. If passed invalid arguments, it uses die() (via L<Carp::croak|Carp>) +to raise a fatal exception. If it can find an appropriate package name +for a class method lookup, it will include the results from a +C<FETCH_I<type>_ATTRIBUTES> call in its return list, as described in +L<"Package-specific Attribute Handling"> below. +Otherwise, only L<built-in attributes|"Built-in Attributes"> will be returned. + +=item reftype + +This routine expects a single parameter--a reference to a subroutine or +variable. It returns the built-in type of the referenced variable, +ignoring any package into which it might have been blessed. +This can be useful for determining the I<type> value which forms part of +the method names described in L<"Package-specific Attribute Handling"> below. + +=back + +Note that these routines are I<not> exported by default. + +=head2 Package-specific Attribute Handling + +B<WARNING>: the mechanisms described here are still experimental. Do not +rely on the current implementation. In particular, there is no provision +for applying package attributes to 'cloned' copies of subroutines used as +closures. (See L<perlref/"Making References"> for information on closures.) +Package-specific attribute handling may change incompatibly in a future +release. + +When an attribute list is present in a declaration, a check is made to see +whether an attribute 'modify' handler is present in the appropriate package +(or its @ISA inheritance tree). Similarly, when C<attributes::get> is +called on a valid reference, a check is made for an appropriate attribute +'fetch' handler. See L<"EXAMPLES"> to see how the "appropriate package" +determination works. + +The handler names are based on the underlying type of the variable being +declared or of the reference passed. Because these attributes are +associated with subroutine or variable declarations, this deliberately +ignores any possibility of being blessed into some package. Thus, a +subroutine declaration uses "CODE" as its I<type>, and even a blessed +hash reference uses "HASH" as its I<type>. + +The class methods invoked for modifying and fetching are these: + +=over 4 + +=item FETCH_I<type>_ATTRIBUTES + +This method receives a single argument, which is a reference to the +variable or subroutine for which package-defined attributes are desired. +The expected return value is a list of associated attributes. +This list may be empty. + +=item MODIFY_I<type>_ATTRIBUTES + +This method is called with two fixed arguments, followed by the list of +attributes from the relevant declaration. The two fixed arguments are +the relevant package name and a reference to the declared subroutine or +variable. The expected return value is a list of attributes which were +not recognized by this handler. Note that this allows for a derived class +to delegate a call to its base class, and then only examine the attributes +which the base class didn't already handle for it. + +The call to this method is currently made I<during> the processing of the +declaration. In particular, this means that a subroutine reference will +probably be for an undefined subroutine, even if this declaration is +actually part of the definition. + +=back + +Calling C<attributes::get()> from within the scope of a null package +declaration C<package ;> for an unblessed variable reference will +not provide any starting package name for the 'fetch' method lookup. +Thus, this circumstance will not result in a method call for package-defined +attributes. A named subroutine knows to which symbol table entry it belongs +(or originally belonged), and it will use the corresponding package. +An anonymous subroutine knows the package name into which it was compiled +(unless it was also compiled with a null package declaration), and so it +will use that package name. + +=head2 Syntax of Attribute Lists + +An attribute list is a sequence of attribute specifications, separated by +whitespace or a colon (with optional whitespace). +Each attribute specification is a simple +name, optionally followed by a parenthesised parameter list. +If such a parameter list is present, it is scanned past as for the rules +for the C<q()> operator. (See L<perlop/"Quote and Quote-like Operators">.) +The parameter list is passed as it was found, however, and not as per C<q()>. + +Some examples of syntactically valid attribute lists: + + switch(10,foo(7,3)) : expensive + Ugly('\(") :Bad + _5x5 + locked method + +Some examples of syntactically invalid attribute lists (with annotation): + + switch(10,foo() # ()-string not balanced + Ugly('(') # ()-string not balanced + 5x5 # "5x5" not a valid identifier + Y2::north # "Y2::north" not a simple identifier + foo + bar # "+" neither a colon nor whitespace + +=head1 EXPORTS + +=head2 Default exports + +None. + +=head2 Available exports + +The routines C<get> and C<reftype> are exportable. + +=head2 Export tags defined + +The C<:ALL> tag will get all of the above exports. + +=head1 EXAMPLES + +Here are some samples of syntactically valid declarations, with annotation +as to how they resolve internally into C<use attributes> invocations by +perl. These examples are primarily useful to see how the "appropriate +package" is found for the possible method lookups for package-defined +attributes. + +=over 4 + +=item 1. + +Code: + + package Canine; + package Dog; + my Canine $spot : Watchful ; + +Effect: + + use attributes (); + attributes::->import(Canine => \$spot, "Watchful"); + +=item 2. + +Code: + + package Felis; + my $cat : Nervous; + +Effect: + + use attributes (); + attributes::->import(Felis => \$cat, "Nervous"); + +=item 3. + +Code: + + package X; + sub foo : locked ; + +Effect: + + use attributes X => \&foo, "locked"; + +=item 4. + +Code: + + package X; + sub Y::x : locked { 1 } + +Effect: + + use attributes Y => \&Y::x, "locked"; + +=item 5. + +Code: + + package X; + sub foo { 1 } + + package Y; + BEGIN { *bar = \&X::foo; } + + package Z; + sub Y::bar : locked ; + +Effect: + + use attributes X => \&X::foo, "locked"; + +=back + +This last example is purely for purposes of completeness. You should not +be trying to mess with the attributes of something in a package that's +not your own. + +=head1 SEE ALSO + +L<perlsub/"Private Variables via my()"> and +L<perlsub/"Subroutine Attributes"> for details on the basic declarations; +L<attrs> for the obsolescent form of subroutine attribute specification +which this module replaces; +L<perlfunc/use> for details on the normal invocation mechanism. + +=cut + diff --git a/Master/tlpkg/installer/perllib/bytes_heavy.pl b/Master/tlpkg/installer/perllib/bytes_heavy.pl new file mode 100644 index 00000000000..923381de58d --- /dev/null +++ b/Master/tlpkg/installer/perllib/bytes_heavy.pl @@ -0,0 +1,40 @@ +package bytes; + +sub length ($) { + BEGIN { bytes::import() } + return CORE::length($_[0]); +} + +sub substr ($$;$$) { + BEGIN { bytes::import() } + return + @_ == 2 ? CORE::substr($_[0], $_[1]) : + @_ == 3 ? CORE::substr($_[0], $_[1], $_[2]) : + CORE::substr($_[0], $_[1], $_[2], $_[3]) ; +} + +sub ord ($) { + BEGIN { bytes::import() } + return CORE::ord($_[0]); +} + +sub chr ($) { + BEGIN { bytes::import() } + return CORE::chr($_[0]); +} + +sub index ($$;$) { + BEGIN { bytes::import() } + return + @_ == 2 ? CORE::index($_[0], $_[1]) : + CORE::index($_[0], $_[1], $_[2]) ; +} + +sub rindex ($$;$) { + BEGIN { bytes::import() } + return + @_ == 2 ? CORE::rindex($_[0], $_[1]) : + CORE::rindex($_[0], $_[1], $_[2]) ; +} + +1; diff --git a/Master/tlpkg/installer/perllib/fields.pm b/Master/tlpkg/installer/perllib/fields.pm new file mode 100644 index 00000000000..cca778f905d --- /dev/null +++ b/Master/tlpkg/installer/perllib/fields.pm @@ -0,0 +1,319 @@ +package fields; + +require 5.005; +use strict; +no strict 'refs'; +unless( eval q{require warnings::register; warnings::register->import} ) { + *warnings::warnif = sub { + require Carp; + Carp::carp(@_); + } +} +use vars qw(%attr $VERSION); + +$VERSION = '2.03'; + +# constant.pm is slow +sub PUBLIC () { 2**0 } +sub PRIVATE () { 2**1 } +sub INHERITED () { 2**2 } +sub PROTECTED () { 2**3 } + + +# The %attr hash holds the attributes of the currently assigned fields +# per class. The hash is indexed by class names and the hash value is +# an array reference. The first element in the array is the lowest field +# number not belonging to a base class. The remaining elements' indices +# are the field numbers. The values are integer bit masks, or undef +# in the case of base class private fields (which occupy a slot but are +# otherwise irrelevant to the class). + +sub import { + my $class = shift; + return unless @_; + my $package = caller(0); + # avoid possible typo warnings + %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"}; + my $fields = \%{"$package\::FIELDS"}; + my $fattr = ($attr{$package} ||= [1]); + my $next = @$fattr; + + # Quiet pseudo-hash deprecation warning for uses of fields::new. + bless \%{"$package\::FIELDS"}, 'pseudohash'; + + if ($next > $fattr->[0] + and ($fields->{$_[0]} || 0) >= $fattr->[0]) + { + # There are already fields not belonging to base classes. + # Looks like a possible module reload... + $next = $fattr->[0]; + } + foreach my $f (@_) { + my $fno = $fields->{$f}; + + # Allow the module to be reloaded so long as field positions + # have not changed. + if ($fno and $fno != $next) { + require Carp; + if ($fno < $fattr->[0]) { + if ($] < 5.006001) { + warn("Hides field '$f' in base class") if $^W; + } else { + warnings::warnif("Hides field '$f' in base class") ; + } + } else { + Carp::croak("Field name '$f' already in use"); + } + } + $fields->{$f} = $next; + $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC; + $next += 1; + } + if (@$fattr > $next) { + # Well, we gave them the benefit of the doubt by guessing the + # module was reloaded, but they appear to be declaring fields + # in more than one place. We can't be sure (without some extra + # bookkeeping) that the rest of the fields will be declared or + # have the same positions, so punt. + require Carp; + Carp::croak ("Reloaded module must declare all fields at once"); + } +} + +sub inherit { + require base; + goto &base::inherit_fields; +} + +sub _dump # sometimes useful for debugging +{ + for my $pkg (sort keys %attr) { + print "\n$pkg"; + if (@{"$pkg\::ISA"}) { + print " (", join(", ", @{"$pkg\::ISA"}), ")"; + } + print "\n"; + my $fields = \%{"$pkg\::FIELDS"}; + for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) { + my $no = $fields->{$f}; + print " $no: $f"; + my $fattr = $attr{$pkg}[$no]; + if (defined $fattr) { + my @a; + push(@a, "public") if $fattr & PUBLIC; + push(@a, "private") if $fattr & PRIVATE; + push(@a, "inherited") if $fattr & INHERITED; + print "\t(", join(", ", @a), ")"; + } + print "\n"; + } + } +} + +if ($] < 5.009) { + *new = sub { + my $class = shift; + $class = ref $class if ref $class; + return bless [\%{$class . "::FIELDS"}], $class; + } +} else { + *new = sub { + my $class = shift; + $class = ref $class if ref $class; + require Hash::Util; + my $self = bless {}, $class; + + # The lock_keys() prototype won't work since we require Hash::Util :( + &Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'}); + return $self; + } +} + +sub phash { + die "Pseudo-hashes have been removed from Perl" if $] >= 5.009; + my $h; + my $v; + if (@_) { + if (ref $_[0] eq 'ARRAY') { + my $a = shift; + @$h{@$a} = 1 .. @$a; + if (@_) { + $v = shift; + unless (! @_ and ref $v eq 'ARRAY') { + require Carp; + Carp::croak ("Expected at most two array refs\n"); + } + } + } + else { + if (@_ % 2) { + require Carp; + Carp::croak ("Odd number of elements initializing pseudo-hash\n"); + } + my $i = 0; + @$h{grep ++$i % 2, @_} = 1 .. @_ / 2; + $i = 0; + $v = [grep $i++ % 2, @_]; + } + } + else { + $h = {}; + $v = []; + } + [ $h, @$v ]; + +} + +1; + +__END__ + +=head1 NAME + +fields - compile-time class fields + +=head1 SYNOPSIS + + { + package Foo; + use fields qw(foo bar _Foo_private); + sub new { + my Foo $self = shift; + unless (ref $self) { + $self = fields::new($self); + $self->{_Foo_private} = "this is Foo's secret"; + } + $self->{foo} = 10; + $self->{bar} = 20; + return $self; + } + } + + my $var = Foo->new; + $var->{foo} = 42; + + # this will generate an error + $var->{zap} = 42; + + # subclassing + { + package Bar; + use base 'Foo'; + use fields qw(baz _Bar_private); # not shared with Foo + sub new { + my $class = shift; + my $self = fields::new($class); + $self->SUPER::new(); # init base fields + $self->{baz} = 10; # init own fields + $self->{_Bar_private} = "this is Bar's secret"; + return $self; + } + } + +=head1 DESCRIPTION + +The C<fields> pragma enables compile-time verified class fields. + +NOTE: The current implementation keeps the declared fields in the %FIELDS +hash of the calling package, but this may change in future versions. +Do B<not> update the %FIELDS hash directly, because it must be created +at compile-time for it to be fully useful, as is done by this pragma. + +B<Only valid for perl before 5.9.0:> + +If a typed lexical variable holding a reference is used to access a +hash element and a package with the same name as the type has +declared class fields using this pragma, then the operation is +turned into an array access at compile time. + + +The related C<base> pragma will combine fields from base classes and any +fields declared using the C<fields> pragma. This enables field +inheritance to work properly. + +Field names that start with an underscore character are made private to +the class and are not visible to subclasses. Inherited fields can be +overridden but will generate a warning if used together with the C<-w> +switch. + +B<Only valid for perls before 5.9.0:> + +The effect of all this is that you can have objects with named +fields which are as compact and as fast arrays to access. This only +works as long as the objects are accessed through properly typed +variables. If the objects are not typed, access is only checked at +run time. + + +The following functions are supported: + +=over 4 + +=item new + +B< perl before 5.9.0: > fields::new() creates and blesses a +pseudo-hash comprised of the fields declared using the C<fields> +pragma into the specified class. + +B< perl 5.9.0 and higher: > fields::new() creates and blesses a +restricted-hash comprised of the fields declared using the C<fields> +pragma into the specified class. + +This function is usable with or without pseudo-hashes. It is the +recommended way to construct a fields-based object. + +This makes it possible to write a constructor like this: + + package Critter::Sounds; + use fields qw(cat dog bird); + + sub new { + my $self = shift; + $self = fields::new($self) unless ref $self; + $self->{cat} = 'meow'; # scalar element + @$self{'dog','bird'} = ('bark','tweet'); # slice + return $self; + } + +=item phash + +B< before perl 5.9.0: > + +fields::phash() can be used to create and initialize a plain (unblessed) +pseudo-hash. This function should always be used instead of creating +pseudo-hashes directly. + +If the first argument is a reference to an array, the pseudo-hash will +be created with keys from that array. If a second argument is supplied, +it must also be a reference to an array whose elements will be used as +the values. If the second array contains less elements than the first, +the trailing elements of the pseudo-hash will not be initialized. +This makes it particularly useful for creating a pseudo-hash from +subroutine arguments: + + sub dogtag { + my $tag = fields::phash([qw(name rank ser_num)], [@_]); + } + +fields::phash() also accepts a list of key-value pairs that will +be used to construct the pseudo hash. Examples: + + my $tag = fields::phash(name => "Joe", + rank => "captain", + ser_num => 42); + + my $pseudohash = fields::phash(%args); + +B< perl 5.9.0 and higher: > + +Pseudo-hashes have been removed from Perl as of 5.10. Consider using +restricted hashes or fields::new() instead. Using fields::phash() +will cause an error. + +=back + +=head1 SEE ALSO + +L<base> + +=cut diff --git a/Master/tlpkg/installer/perllib/lib.pm b/Master/tlpkg/installer/perllib/lib.pm new file mode 100644 index 00000000000..06a03502368 --- /dev/null +++ b/Master/tlpkg/installer/perllib/lib.pm @@ -0,0 +1,206 @@ +package lib; + +# THIS FILE IS AUTOMATICALLY GENERATED FROM lib_pm.PL. +# ANY CHANGES TO THIS FILE WILL BE OVERWRITTEN BY THE NEXT PERL BUILD. + +use Config; + +use strict; + +my $archname = $Config{archname}; +my $version = $Config{version}; +my @inc_version_list = reverse split / /, $Config{inc_version_list}; + + +our @ORIG_INC = @INC; # take a handy copy of 'original' value +our $VERSION = '0.5565'; +my $Is_MacOS = $^O eq 'MacOS'; +my $Mac_FS; +if ($Is_MacOS) { + require File::Spec; + $Mac_FS = eval { require Mac::FileSpec::Unixish }; +} + +sub import { + shift; + + my %names; + foreach (reverse @_) { + my $path = $_; # we'll be modifying it, so break the alias + if ($path eq '') { + require Carp; + Carp::carp("Empty compile time value given to use lib"); + } + + $path = _nativize($path); + + if (-e $path && ! -d _) { + require Carp; + Carp::carp("Parameter to use lib must be directory, not file"); + } + unshift(@INC, $path); + # Add any previous version directories we found at configure time + foreach my $incver (@inc_version_list) + { + my $dir = $Is_MacOS + ? File::Spec->catdir( $path, $incver ) + : "$path/$incver"; + unshift(@INC, $dir) if -d $dir; + } + # Put a corresponding archlib directory in front of $path if it + # looks like $path has an archlib directory below it. + my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir) + = _get_dirs($path); + unshift(@INC, $arch_dir) if -d $arch_auto_dir; + unshift(@INC, $version_dir) if -d $version_dir; + unshift(@INC, $version_arch_dir) if -d $version_arch_dir; + } + + # remove trailing duplicates + @INC = grep { ++$names{$_} == 1 } @INC; + return; +} + + +sub unimport { + shift; + + my %names; + foreach (@_) { + my $path = _nativize($_); + + my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir) + = _get_dirs($path); + ++$names{$path}; + ++$names{$arch_dir} if -d $arch_auto_dir; + ++$names{$version_dir} if -d $version_dir; + ++$names{$version_arch_dir} if -d $version_arch_dir; + } + + # Remove ALL instances of each named directory. + @INC = grep { !exists $names{$_} } @INC; + return; +} + +sub _get_dirs { + my($dir) = @_; + my($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir); + + # we could use this for all platforms in the future, but leave it + # Mac-only for now, until there is more time for testing it. + if ($Is_MacOS) { + $arch_auto_dir = File::Spec->catdir( $dir, $archname, 'auto' ); + $arch_dir = File::Spec->catdir( $dir, $archname, ); + $version_dir = File::Spec->catdir( $dir, $version ); + $version_arch_dir = File::Spec->catdir( $dir, $version, $archname ); + } else { + $arch_auto_dir = "$dir/$archname/auto"; + $arch_dir = "$dir/$archname"; + $version_dir = "$dir/$version"; + $version_arch_dir = "$dir/$version/$archname"; + } + return($arch_auto_dir, $arch_dir, $version_dir, $version_arch_dir); +} + +sub _nativize { + my($dir) = @_; + + if ($Is_MacOS && $Mac_FS && ! -d $dir) { + $dir = Mac::FileSpec::Unixish::nativize($dir); + $dir .= ":" unless $dir =~ /:$/; + } + + return $dir; +} + +1; +__END__ + +=head1 NAME + +lib - manipulate @INC at compile time + +=head1 SYNOPSIS + + use lib LIST; + + no lib LIST; + +=head1 DESCRIPTION + +This is a small simple module which simplifies the manipulation of @INC +at compile time. + +It is typically used to add extra directories to perl's search path so +that later C<use> or C<require> statements will find modules which are +not located on perl's default search path. + +=head2 Adding directories to @INC + +The parameters to C<use lib> are added to the start of the perl search +path. Saying + + use lib LIST; + +is I<almost> the same as saying + + BEGIN { unshift(@INC, LIST) } + +For each directory in LIST (called $dir here) the lib module also +checks to see if a directory called $dir/$archname/auto exists. +If so the $dir/$archname directory is assumed to be a corresponding +architecture specific directory and is added to @INC in front of $dir. + +To avoid memory leaks, all trailing duplicate entries in @INC are +removed. + +=head2 Deleting directories from @INC + +You should normally only add directories to @INC. If you need to +delete directories from @INC take care to only delete those which you +added yourself or which you are certain are not needed by other modules +in your script. Other modules may have added directories which they +need for correct operation. + +The C<no lib> statement deletes all instances of each named directory +from @INC. + +For each directory in LIST (called $dir here) the lib module also +checks to see if a directory called $dir/$archname/auto exists. +If so the $dir/$archname directory is assumed to be a corresponding +architecture specific directory and is also deleted from @INC. + +=head2 Restoring original @INC + +When the lib module is first loaded it records the current value of @INC +in an array C<@lib::ORIG_INC>. To restore @INC to that value you +can say + + @INC = @lib::ORIG_INC; + +=head1 CAVEATS + +In order to keep lib.pm small and simple, it only works with Unix +filepaths. This doesn't mean it only works on Unix, but non-Unix +users must first translate their file paths to Unix conventions. + + # VMS users wanting to put [.stuff.moo] into + # their @INC would write + use lib 'stuff/moo'; + +=head1 NOTES + +In the future, this module will likely use File::Spec for determining +paths, as it does now for Mac OS (where Unix-style or Mac-style paths +work, and Unix-style paths are converted properly to Mac-style paths +before being added to @INC). + +=head1 SEE ALSO + +FindBin - optional module which deals with paths relative to the source file. + +=head1 AUTHOR + +Tim Bunce, 2nd June 1995. + +=cut diff --git a/Master/tlpkg/installer/perllib/re.pm b/Master/tlpkg/installer/perllib/re.pm new file mode 100644 index 00000000000..6e9d1218ef0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/re.pm @@ -0,0 +1,134 @@ +package re; + +our $VERSION = 0.05; + +=head1 NAME + +re - Perl pragma to alter regular expression behaviour + +=head1 SYNOPSIS + + use re 'taint'; + ($x) = ($^X =~ /^(.*)$/s); # $x is tainted here + + $pat = '(?{ $foo = 1 })'; + use re 'eval'; + /foo${pat}bar/; # won't fail (when not under -T switch) + + { + no re 'taint'; # the default + ($x) = ($^X =~ /^(.*)$/s); # $x is not tainted here + + no re 'eval'; # the default + /foo${pat}bar/; # disallowed (with or without -T switch) + } + + use re 'debug'; # NOT lexically scoped (as others are) + /^(.*)$/s; # output debugging info during + # compile and run time + + use re 'debugcolor'; # same as 'debug', but with colored output + ... + +(We use $^X in these examples because it's tainted by default.) + +=head1 DESCRIPTION + +When C<use re 'taint'> is in effect, and a tainted string is the target +of a regex, the regex memories (or values returned by the m// operator +in list context) are tainted. This feature is useful when regex operations +on tainted data aren't meant to extract safe substrings, but to perform +other transformations. + +When C<use re 'eval'> is in effect, a regex is allowed to contain +C<(?{ ... })> zero-width assertions even if regular expression contains +variable interpolation. That is normally disallowed, since it is a +potential security risk. Note that this pragma is ignored when the regular +expression is obtained from tainted data, i.e. evaluation is always +disallowed with tainted regular expressions. See L<perlre/(?{ code })>. + +For the purpose of this pragma, interpolation of precompiled regular +expressions (i.e., the result of C<qr//>) is I<not> considered variable +interpolation. Thus: + + /foo${pat}bar/ + +I<is> allowed if $pat is a precompiled regular expression, even +if $pat contains C<(?{ ... })> assertions. + +When C<use re 'debug'> is in effect, perl emits debugging messages when +compiling and using regular expressions. The output is the same as that +obtained by running a C<-DDEBUGGING>-enabled perl interpreter with the +B<-Dr> switch. It may be quite voluminous depending on the complexity +of the match. Using C<debugcolor> instead of C<debug> enables a +form of output that can be used to get a colorful display on terminals +that understand termcap color sequences. Set C<$ENV{PERL_RE_TC}> to a +comma-separated list of C<termcap> properties to use for highlighting +strings on/off, pre-point part on/off. +See L<perldebug/"Debugging regular expressions"> for additional info. + +The directive C<use re 'debug'> is I<not lexically scoped>, as the +other directives are. It has both compile-time and run-time effects. + +See L<perlmodlib/Pragmatic Modules>. + +=cut + +# N.B. File::Basename contains a literal for 'taint' as a fallback. If +# taint is changed here, File::Basename must be updated as well. +my %bitmask = ( +taint => 0x00100000, # HINT_RE_TAINT +eval => 0x00200000, # HINT_RE_EVAL +); + +sub setcolor { + eval { # Ignore errors + require Term::Cap; + + my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning. + my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue'; + my @props = split /,/, $props; + my $colors = join "\t", map {$terminal->Tputs($_,1)} @props; + + $colors =~ s/\0//g; + $ENV{PERL_RE_COLORS} = $colors; + }; +} + +sub bits { + my $on = shift; + my $bits = 0; + unless (@_) { + require Carp; + Carp::carp("Useless use of \"re\" pragma"); + } + foreach my $s (@_){ + if ($s eq 'debug' or $s eq 'debugcolor') { + setcolor() if $s eq 'debugcolor'; + require XSLoader; + XSLoader::load('re'); + install() if $on; + uninstall() unless $on; + next; + } + if (exists $bitmask{$s}) { + $bits |= $bitmask{$s}; + } else { + require Carp; + Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: @{[join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask)]})"); + } + } + $bits; +} + +sub import { + shift; + $^H |= bits(1, @_); +} + +sub unimport { + shift; + $^H &= ~ bits(0, @_); +} + +1; |