diff options
| author | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
|---|---|---|
| committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:54:37 +0000 |
| commit | 661c41a09e39a182865e0b51e34cc995a0dc96e8 (patch) | |
| tree | 2f79bb1406e22fdcb2587be8ffda6c0c609d7932 /Master/tlpkg/tlperl/bin | |
| parent | b645030efc22e13c2498a1522083634ab91b2de1 (diff) | |
move tlperl.straw to tlperl
git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/bin')
123 files changed, 45769 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/bin/a2p.exe b/Master/tlpkg/tlperl/bin/a2p.exe Binary files differnew file mode 100755 index 00000000000..b18a77b4a08 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/a2p.exe diff --git a/Master/tlpkg/tlperl/bin/bdf2gdfont.bat b/Master/tlpkg/tlperl/bin/bdf2gdfont.bat new file mode 100755 index 00000000000..c87b4618745 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/bdf2gdfont.bat @@ -0,0 +1,205 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+
+#
+# Simple convertor from bdf to loadable GD font format.
+#
+# Author: Lincoln Stein <lstein@cshl.edu>, heavily adopted from bdftogd from
+# Jan Pazdziora <adelton@fi.muni.cz>
+#
+# Example of use:
+# fstobdf -s fontserverhost:7100 -fn 8x16 | bdftofnt > myfont.fnt
+#
+
+use strict;
+our $VERSION = '1.00';
+
+if ($ARGV[0] =~ /^--?h/) {
+ exec "perldoc $0";
+}
+
+my ($width, $height);
+my (@data, @left, @bottom);
+my ($globalleft, $globaltop);
+
+my ($minchar, $maxchar);
+
+my ($copyright, $fontdef);
+
+my $currentchar;
+my $gobitmap = 0;
+
+foreach (@ARGV) {
+ $_ = "gunzip -c $_ |" if /\.gz$/;
+}
+
+while (<>)
+ {
+ chomp;
+ s/\r$//;
+ next unless $_;
+ my ($tag, $value) = split / /, $_, 2;
+ die "Font is not fixed width\n"
+ if $tag eq 'SPACING' and not $value =~ /[CM]/i;
+
+ $currentchar = $value if $tag eq 'ENCODING';
+ $minchar = $currentchar if not defined $minchar
+ or ($currentchar < $minchar && $currentchar >= 0);
+ $maxchar = $currentchar if not defined $maxchar
+ or ($currentchar > $maxchar && $currentchar >= 0);
+
+ if ($tag eq 'ENDCHAR')
+ {
+ next if $currentchar < 0;
+ $gobitmap = 0;
+ my $bottom = $globaltop - $bottom[$currentchar];
+
+
+ if ($bottom > 0)
+ { $data[$currentchar] = substr $data[$currentchar], 0, length($data[$currentchar]) - $bottom * $width; }
+ else
+ { $data[$currentchar] .= '0' x (-$bottom * $width); }
+ }
+
+ if ($tag eq 'FONTBOUNDINGBOX')
+ {
+ my ($tag, $wid, $hei, $left, $top) = split / /;
+ if (defined $top)
+ {
+ $globalleft = $left;
+ $globaltop = $top;
+ $height = $hei;
+ $width = $wid;
+ }
+ }
+ if ($tag eq 'FONT' and not defined $fontdef)
+ { $fontdef = $value; }
+ if ($tag eq 'COPYRIGHT' and not defined $copyright)
+ { $copyright = $value; }
+
+ if ($tag eq 'BBX')
+ {
+ my ($tag, $wid, $hei, $left, $bottom) = split / /;
+ if (defined $bottom)
+ {
+ $left[$currentchar] = $left;
+ $bottom[$currentchar] = $bottom;
+ }
+ }
+
+ if ($gobitmap)
+ {
+ my $value = pack 'H*', $_;
+ my $bits = unpack 'B*', $value;
+ $bits = ('0' x $left[$currentchar]) . $bits;
+ $bits .= '0' x ($width - length $bits);
+ $bits = substr $bits, 0, $width;
+ $data[$currentchar] .= $bits;
+ }
+
+ if ($tag eq 'BITMAP')
+ {
+ $gobitmap = 1;
+ $data[$currentchar] = '';
+ }
+ }
+
+$minchar = 0 unless defined $minchar;
+$maxchar = 255 unless defined $maxchar;
+
+binmode STDOUT; # for DOS/Windows systems
+my $length = $maxchar-$minchar+1;
+
+
+print pack ('VVVV',$length,$minchar,$width,$height); # header
+
+for (my $i = $minchar; $i <= $maxchar; $i++) {
+ $data[$i] = '' unless defined $data[$i];
+ $data[$i] = '0' x ($width * $height - length $data[$i]) . $data[$i];
+ print pack('C*',split '',$data[$i]);
+}
+
+print STDERR "Successfully converted $length ${width}x$}height} characters\n";
+
+__END__
+
+=head1 NAME
+
+bdf2gdfont.pl - Convert X11 "BDF" fonts into a loadable font format for GD.
+
+=head1 SYNOPSIS
+
+ % bdf2gdfont.pl courR12.bdf > courR12.fnt
+
+=head1 DESCRIPTION
+
+This script converts BDF-style X11 font files into a format that can
+be loaded by the GD module using the GD::Font->load() method. There
+are a number of ways to obtain BDF fonts.
+
+=over 4
+
+=item 1. The font is already present on your system.
+
+Some BDF fonts can be found in the standard X11R6 distribution. This
+script will automatically uncompress gzipped font files if their
+extension ends with .gz (the gunzip program must be on your path).
+
+=item 2. From a font server.
+
+The "fstobdf" utility, a standard X11 utility, will read a named font
+from the font server of your choice and return it in BDF format. You
+can pipe it to bdf2gdfont.pl:
+
+ fstobdf -s fontserverhost:7100 -fn 8x16 | bdf2gdfont.pl > newfont.fnt
+
+Use xlsfonts to find out what fonts are available. Most fonts will
+have long names like
+-B&H-LucidaTypewriter-Bold-R-Normal-Sans-18-180-75-75-M-110-ISO8859-10.
+
+=item 3. Using the pcf2bdf utility.
+
+Some fonts are only available in PCF (compiled) format. To obtain
+these, you can either turn on a font server and follow recipe (2), or
+use TAGA Nayuta's pcf2bdf utility. This utility is available from
+http://www.tsg.ne.jp/GANA/S/pcf2bdf/ (page is in Japanese, but you can
+find the download link).
+
+=back
+
+=head2 Limitations
+
+This font converter only works with fixed-width fonts. If used with a
+TrueType or proportional font it will die with an error message.
+
+=head1 SEE ALSO
+
+L<GD>
+
+=head1 AUTHOR
+
+Lincoln Stein <lstein@cshl.org>, heavily adapted from bdftogd from
+Jan Pazdziora <adelton@fi.muni.cz>.
+
+Copyright (c) 2004 Cold Spring Harbor Laboratory
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/bdf2gdfont.pl b/Master/tlpkg/tlperl/bin/bdf2gdfont.pl new file mode 100755 index 00000000000..e807b81137b --- /dev/null +++ b/Master/tlpkg/tlperl/bin/bdf2gdfont.pl @@ -0,0 +1,189 @@ +#!perl + +# +# Simple convertor from bdf to loadable GD font format. +# +# Author: Lincoln Stein <lstein@cshl.edu>, heavily adopted from bdftogd from +# Jan Pazdziora <adelton@fi.muni.cz> +# +# Example of use: +# fstobdf -s fontserverhost:7100 -fn 8x16 | bdftofnt > myfont.fnt +# + +use strict; +our $VERSION = '1.00'; + +if ($ARGV[0] =~ /^--?h/) { + exec "perldoc $0"; +} + +my ($width, $height); +my (@data, @left, @bottom); +my ($globalleft, $globaltop); + +my ($minchar, $maxchar); + +my ($copyright, $fontdef); + +my $currentchar; +my $gobitmap = 0; + +foreach (@ARGV) { + $_ = "gunzip -c $_ |" if /\.gz$/; +} + +while (<>) + { + chomp; + s/\r$//; + next unless $_; + my ($tag, $value) = split / /, $_, 2; + die "Font is not fixed width\n" + if $tag eq 'SPACING' and not $value =~ /[CM]/i; + + $currentchar = $value if $tag eq 'ENCODING'; + $minchar = $currentchar if not defined $minchar + or ($currentchar < $minchar && $currentchar >= 0); + $maxchar = $currentchar if not defined $maxchar + or ($currentchar > $maxchar && $currentchar >= 0); + + if ($tag eq 'ENDCHAR') + { + next if $currentchar < 0; + $gobitmap = 0; + my $bottom = $globaltop - $bottom[$currentchar]; + + + if ($bottom > 0) + { $data[$currentchar] = substr $data[$currentchar], 0, length($data[$currentchar]) - $bottom * $width; } + else + { $data[$currentchar] .= '0' x (-$bottom * $width); } + } + + if ($tag eq 'FONTBOUNDINGBOX') + { + my ($tag, $wid, $hei, $left, $top) = split / /; + if (defined $top) + { + $globalleft = $left; + $globaltop = $top; + $height = $hei; + $width = $wid; + } + } + if ($tag eq 'FONT' and not defined $fontdef) + { $fontdef = $value; } + if ($tag eq 'COPYRIGHT' and not defined $copyright) + { $copyright = $value; } + + if ($tag eq 'BBX') + { + my ($tag, $wid, $hei, $left, $bottom) = split / /; + if (defined $bottom) + { + $left[$currentchar] = $left; + $bottom[$currentchar] = $bottom; + } + } + + if ($gobitmap) + { + my $value = pack 'H*', $_; + my $bits = unpack 'B*', $value; + $bits = ('0' x $left[$currentchar]) . $bits; + $bits .= '0' x ($width - length $bits); + $bits = substr $bits, 0, $width; + $data[$currentchar] .= $bits; + } + + if ($tag eq 'BITMAP') + { + $gobitmap = 1; + $data[$currentchar] = ''; + } + } + +$minchar = 0 unless defined $minchar; +$maxchar = 255 unless defined $maxchar; + +binmode STDOUT; # for DOS/Windows systems +my $length = $maxchar-$minchar+1; + + +print pack ('VVVV',$length,$minchar,$width,$height); # header + +for (my $i = $minchar; $i <= $maxchar; $i++) { + $data[$i] = '' unless defined $data[$i]; + $data[$i] = '0' x ($width * $height - length $data[$i]) . $data[$i]; + print pack('C*',split '',$data[$i]); +} + +print STDERR "Successfully converted $length ${width}x$}height} characters\n"; + +__END__ + +=head1 NAME + +bdf2gdfont.pl - Convert X11 "BDF" fonts into a loadable font format for GD. + +=head1 SYNOPSIS + + % bdf2gdfont.pl courR12.bdf > courR12.fnt + +=head1 DESCRIPTION + +This script converts BDF-style X11 font files into a format that can +be loaded by the GD module using the GD::Font->load() method. There +are a number of ways to obtain BDF fonts. + +=over 4 + +=item 1. The font is already present on your system. + +Some BDF fonts can be found in the standard X11R6 distribution. This +script will automatically uncompress gzipped font files if their +extension ends with .gz (the gunzip program must be on your path). + +=item 2. From a font server. + +The "fstobdf" utility, a standard X11 utility, will read a named font +from the font server of your choice and return it in BDF format. You +can pipe it to bdf2gdfont.pl: + + fstobdf -s fontserverhost:7100 -fn 8x16 | bdf2gdfont.pl > newfont.fnt + +Use xlsfonts to find out what fonts are available. Most fonts will +have long names like +-B&H-LucidaTypewriter-Bold-R-Normal-Sans-18-180-75-75-M-110-ISO8859-10. + +=item 3. Using the pcf2bdf utility. + +Some fonts are only available in PCF (compiled) format. To obtain +these, you can either turn on a font server and follow recipe (2), or +use TAGA Nayuta's pcf2bdf utility. This utility is available from +http://www.tsg.ne.jp/GANA/S/pcf2bdf/ (page is in Japanese, but you can +find the download link). + +=back + +=head2 Limitations + +This font converter only works with fixed-width fonts. If used with a +TrueType or proportional font it will die with an error message. + +=head1 SEE ALSO + +L<GD> + +=head1 AUTHOR + +Lincoln Stein <lstein@cshl.org>, heavily adapted from bdftogd from +Jan Pazdziora <adelton@fi.muni.cz>. + +Copyright (c) 2004 Cold Spring Harbor Laboratory + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/Master/tlpkg/tlperl/bin/c2ph.bat b/Master/tlpkg/tlperl/bin/c2ph.bat new file mode 100755 index 00000000000..84937d17f3c --- /dev/null +++ b/Master/tlpkg/tlperl/bin/c2ph.bat @@ -0,0 +1,1383 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+#
+#
+# c2ph (aka pstruct)
+# Tom Christiansen, <tchrist@convex.com>
+#
+# As pstruct, dump C structures as generated from 'cc -g -S' stabs.
+# As c2ph, do this PLUS generate perl code for getting at the structures.
+#
+# See the usage message for more. If this isn't enough, read the code.
+#
+
+=head1 NAME
+
+c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
+
+=head1 SYNOPSIS
+
+ c2ph [-dpnP] [var=val] [files ...]
+
+=head2 OPTIONS
+
+ Options:
+
+ -w wide; short for: type_width=45 member_width=35 offset_width=8
+ -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+ -n do not generate perl code (default when invoked as pstruct)
+ -p generate perl code (default when invoked as c2ph)
+ -v generate perl code, with C decls as comments
+
+ -i do NOT recompute sizes for intrinsic datatypes
+ -a dump information on intrinsics also
+
+ -t trace execution
+ -d spew reams of debugging output
+
+ -slist give comma-separated list a structures to dump
+
+=head1 DESCRIPTION
+
+The following is the old c2ph.doc documentation by Tom Christiansen
+<tchrist@perl.com>
+Date: 25 Jul 91 08:10:21 GMT
+
+Once upon a time, I wrote a program called pstruct. It was a perl
+program that tried to parse out C structures and display their member
+offsets for you. This was especially useful for people looking at
+binary dumps or poking around the kernel.
+
+Pstruct was not a pretty program. Neither was it particularly robust.
+The problem, you see, was that the C compiler was much better at parsing
+C than I could ever hope to be.
+
+So I got smart: I decided to be lazy and let the C compiler parse the C,
+which would spit out debugger stabs for me to read. These were much
+easier to parse. It's still not a pretty program, but at least it's more
+robust.
+
+Pstruct takes any .c or .h files, or preferably .s ones, since that's
+the format it is going to massage them into anyway, and spits out
+listings like this:
+
+ struct tty {
+ int tty.t_locker 000 4
+ int tty.t_mutex_index 004 4
+ struct tty * tty.t_tp_virt 008 4
+ struct clist tty.t_rawq 00c 20
+ int tty.t_rawq.c_cc 00c 4
+ int tty.t_rawq.c_cmax 010 4
+ int tty.t_rawq.c_cfx 014 4
+ int tty.t_rawq.c_clx 018 4
+ struct tty * tty.t_rawq.c_tp_cpu 01c 4
+ struct tty * tty.t_rawq.c_tp_iop 020 4
+ unsigned char * tty.t_rawq.c_buf_cpu 024 4
+ unsigned char * tty.t_rawq.c_buf_iop 028 4
+ struct clist tty.t_canq 02c 20
+ int tty.t_canq.c_cc 02c 4
+ int tty.t_canq.c_cmax 030 4
+ int tty.t_canq.c_cfx 034 4
+ int tty.t_canq.c_clx 038 4
+ struct tty * tty.t_canq.c_tp_cpu 03c 4
+ struct tty * tty.t_canq.c_tp_iop 040 4
+ unsigned char * tty.t_canq.c_buf_cpu 044 4
+ unsigned char * tty.t_canq.c_buf_iop 048 4
+ struct clist tty.t_outq 04c 20
+ int tty.t_outq.c_cc 04c 4
+ int tty.t_outq.c_cmax 050 4
+ int tty.t_outq.c_cfx 054 4
+ int tty.t_outq.c_clx 058 4
+ struct tty * tty.t_outq.c_tp_cpu 05c 4
+ struct tty * tty.t_outq.c_tp_iop 060 4
+ unsigned char * tty.t_outq.c_buf_cpu 064 4
+ unsigned char * tty.t_outq.c_buf_iop 068 4
+ (*int)() tty.t_oproc_cpu 06c 4
+ (*int)() tty.t_oproc_iop 070 4
+ (*int)() tty.t_stopproc_cpu 074 4
+ (*int)() tty.t_stopproc_iop 078 4
+ struct thread * tty.t_rsel 07c 4
+
+etc.
+
+
+Actually, this was generated by a particular set of options. You can control
+the formatting of each column, whether you prefer wide or fat, hex or decimal,
+leading zeroes or whatever.
+
+All you need to be able to use this is a C compiler than generates
+BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
+should get this for you.
+
+To learn more, just type a bogus option, like B<-\?>, and a long usage message
+will be provided. There are a fair number of possibilities.
+
+If you're only a C programmer, than this is the end of the message for you.
+You can quit right now, and if you care to, save off the source and run it
+when you feel like it. Or not.
+
+
+
+But if you're a perl programmer, then for you I have something much more
+wondrous than just a structure offset printer.
+
+You see, if you call pstruct by its other incybernation, c2ph, you have a code
+generator that translates C code into perl code! Well, structure and union
+declarations at least, but that's quite a bit.
+
+Prior to this point, anyone programming in perl who wanted to interact
+with C programs, like the kernel, was forced to guess the layouts of
+the C structures, and then hardwire these into his program. Of course,
+when you took your wonderfully crafted program to a system where the
+sgtty structure was laid out differently, your program broke. Which is
+a shame.
+
+We've had Larry's h2ph translator, which helped, but that only works on
+cpp symbols, not real C, which was also very much needed. What I offer
+you is a symbolic way of getting at all the C structures. I've couched
+them in terms of packages and functions. Consider the following program:
+
+ #!/usr/local/bin/perl
+
+ require 'syscall.ph';
+ require 'sys/time.ph';
+ require 'sys/resource.ph';
+
+ $ru = "\0" x &rusage'sizeof();
+
+ syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
+
+ @ru = unpack($t = &rusage'typedef(), $ru);
+
+ $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
+
+ $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
+
+ printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
+
+
+As you see, the name of the package is the name of the structure. Regular
+fields are just their own names. Plus the following accessor functions are
+provided for your convenience:
+
+ struct This takes no arguments, and is merely the number of first-level
+ elements in the structure. You would use this for indexing
+ into arrays of structures, perhaps like this
+
+
+ $usec = $u[ &user'u_utimer
+ + (&ITIMER_VIRTUAL * &itimerval'struct)
+ + &itimerval'it_value
+ + &timeval'tv_usec
+ ];
+
+ sizeof Returns the bytes in the structure, or the member if
+ you pass it an argument, such as
+
+ &rusage'sizeof(&rusage'ru_utime)
+
+ typedef This is the perl format definition for passing to pack and
+ unpack. If you ask for the typedef of a nothing, you get
+ the whole structure, otherwise you get that of the member
+ you ask for. Padding is taken care of, as is the magic to
+ guarantee that a union is unpacked into all its aliases.
+ Bitfields are not quite yet supported however.
+
+ offsetof This function is the byte offset into the array of that
+ member. You may wish to use this for indexing directly
+ into the packed structure with vec() if you're too lazy
+ to unpack it.
+
+ typeof Not to be confused with the typedef accessor function, this
+ one returns the C type of that field. This would allow
+ you to print out a nice structured pretty print of some
+ structure without knoning anything about it beforehand.
+ No args to this one is a noop. Someday I'll post such
+ a thing to dump out your u structure for you.
+
+
+The way I see this being used is like basically this:
+
+ % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
+ % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
+ % install
+
+It's a little tricker with c2ph because you have to get the includes right.
+I can't know this for your system, but it's not usually too terribly difficult.
+
+The code isn't pretty as I mentioned -- I never thought it would be a 1000-
+line program when I started, or I might not have begun. :-) But I would have
+been less cavalier in how the parts of the program communicated with each
+other, etc. It might also have helped if I didn't have to divine the makeup
+of the stabs on the fly, and then account for micro differences between my
+compiler and gcc.
+
+Anyway, here it is. Should run on perl v4 or greater. Maybe less.
+
+
+ --tom
+
+=cut
+
+$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
+
+use File::Temp;
+
+######################################################################
+
+# some handy data definitions. many of these can be reset later.
+
+$bitorder = 'b'; # ascending; set to B for descending bit fields
+
+%intrinsics =
+%template = (
+ 'char', 'c',
+ 'unsigned char', 'C',
+ 'short', 's',
+ 'short int', 's',
+ 'unsigned short', 'S',
+ 'unsigned short int', 'S',
+ 'short unsigned int', 'S',
+ 'int', 'i',
+ 'unsigned int', 'I',
+ 'long', 'l',
+ 'long int', 'l',
+ 'unsigned long', 'L',
+ 'unsigned long', 'L',
+ 'long unsigned int', 'L',
+ 'unsigned long int', 'L',
+ 'long long', 'q',
+ 'long long int', 'q',
+ 'unsigned long long', 'Q',
+ 'unsigned long long int', 'Q',
+ 'float', 'f',
+ 'double', 'd',
+ 'pointer', 'p',
+ 'null', 'x',
+ 'neganull', 'X',
+ 'bit', $bitorder,
+);
+
+&buildscrunchlist;
+delete $intrinsics{'neganull'};
+delete $intrinsics{'bit'};
+delete $intrinsics{'null'};
+
+# use -s to recompute sizes
+%sizeof = (
+ 'char', '1',
+ 'unsigned char', '1',
+ 'short', '2',
+ 'short int', '2',
+ 'unsigned short', '2',
+ 'unsigned short int', '2',
+ 'short unsigned int', '2',
+ 'int', '4',
+ 'unsigned int', '4',
+ 'long', '4',
+ 'long int', '4',
+ 'unsigned long', '4',
+ 'unsigned long int', '4',
+ 'long unsigned int', '4',
+ 'long long', '8',
+ 'long long int', '8',
+ 'unsigned long long', '8',
+ 'unsigned long long int', '8',
+ 'float', '4',
+ 'double', '8',
+ 'pointer', '4',
+);
+
+($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
+
+($offset_fmt, $size_fmt) = ('d', 'd');
+
+$indent = 2;
+
+$CC = 'cc';
+$CFLAGS = '-gstabs -S';
+$DEFINES = '';
+
+$perl++ if $0 =~ m#/?c2ph$#;
+
+require 'getopts.pl';
+
+use File::Temp 'tempdir';
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+&Getopts('aixdpvtnws:') || &usage(0);
+
+$opt_d && $debug++;
+$opt_t && $trace++;
+$opt_p && $perl++;
+$opt_v && $verbose++;
+$opt_n && ($perl = 0);
+
+if ($opt_w) {
+ ($type_width, $member_width, $offset_width) = (45, 35, 8);
+}
+if ($opt_x) {
+ ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
+}
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+sub PLUMBER {
+ select(STDERR);
+ print "oops, apperent pager foulup\n";
+ $isatty++;
+ &usage(1);
+}
+
+sub usage {
+ local($oops) = @_;
+ unless (-t STDOUT) {
+ select(STDERR);
+ } elsif (!$oops) {
+ $isatty++;
+ $| = 1;
+ print "hit <RETURN> for further explanation: ";
+ <STDIN>;
+ open (PIPE, "|". ($ENV{PAGER} || 'more'));
+ $SIG{PIPE} = PLUMBER;
+ select(PIPE);
+ }
+
+ print "usage: $0 [-dpnP] [var=val] [files ...]\n";
+
+ exit unless $isatty;
+
+ print <<EOF;
+
+Options:
+
+-w wide; short for: type_width=45 member_width=35 offset_width=8
+-x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+-n do not generate perl code (default when invoked as pstruct)
+-p generate perl code (default when invoked as c2ph)
+-v generate perl code, with C decls as comments
+
+-i do NOT recompute sizes for intrinsic datatypes
+-a dump information on intrinsics also
+
+-t trace execution
+-d spew reams of debugging output
+
+-slist give comma-separated list a structures to dump
+
+
+Var Name Default Value Meaning
+
+EOF
+
+ &defvar('CC', 'which_compiler to call');
+ &defvar('CFLAGS', 'how to generate *.s files with stabs');
+ &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
+
+ print "\n";
+
+ &defvar('type_width', 'width of type field (column 1)');
+ &defvar('member_width', 'width of member field (column 2)');
+ &defvar('offset_width', 'width of offset field (column 3)');
+ &defvar('size_width', 'width of size field (column 4)');
+
+ print "\n";
+
+ &defvar('offset_fmt', 'sprintf format type for offset');
+ &defvar('size_fmt', 'sprintf format type for size');
+
+ print "\n";
+
+ &defvar('indent', 'how far to indent each nesting level');
+
+ print <<'EOF';
+
+ If any *.[ch] files are given, these will be catted together into
+ a temporary *.c file and sent through:
+ $CC $CFLAGS $DEFINES
+ and the resulting *.s groped for stab information. If no files are
+ supplied, then stdin is read directly with the assumption that it
+ contains stab information. All other lines will be ignored. At
+ most one *.s file should be supplied.
+
+EOF
+ close PIPE;
+ exit 1;
+}
+
+sub defvar {
+ local($var, $msg) = @_;
+ printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
+}
+
+sub safedir {
+ $SAFEDIR = File::Temp::tempdir("c2ph.XXXXXX", TMPDIR => 1, CLEANUP => 1)
+ unless (defined($SAFEDIR));
+}
+
+undef $SAFEDIR;
+
+$recurse = 1;
+
+if (@ARGV) {
+ if (grep(!/\.[csh]$/,@ARGV)) {
+ warn "Only *.[csh] files expected!\n";
+ &usage;
+ }
+ elsif (grep(/\.s$/,@ARGV)) {
+ if (@ARGV > 1) {
+ warn "Only one *.s file allowed!\n";
+ &usage;
+ }
+ }
+ elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
+ local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
+ $chdir = "cd $dir && " if $dir;
+ &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
+ $ARGV[0] =~ s/\.c$/.s/;
+ }
+ else {
+ &safedir;
+ $TMP = "$SAFEDIR/c2ph.$$.c";
+ &system("cat @ARGV > $TMP") && exit 1;
+ &system("cd $SAFEDIR && $CC $CFLAGS $DEFINES $TMP") && exit 1;
+ unlink $TMP;
+ $TMP =~ s/\.c$/.s/;
+ @ARGV = ($TMP);
+ }
+}
+
+if ($opt_s) {
+ for (split(/[\s,]+/, $opt_s)) {
+ $interested{$_}++;
+ }
+}
+
+
+$| = 1 if $debug;
+
+main: {
+
+ if ($trace) {
+ if (-t && !@ARGV) {
+ print STDERR "reading from your keyboard: ";
+ } else {
+ print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
+ }
+ }
+
+STAB: while (<>) {
+ if ($trace && !($. % 10)) {
+ $lineno = $..'';
+ print STDERR $lineno, "\b" x length($lineno);
+ }
+ next unless /^\s*\.stabs\s+/;
+ $line = $_;
+ s/^\s*\.stabs\s+//;
+ if (s/\\\\"[d,]+$//) {
+ $saveline .= $line;
+ $savebar = $_;
+ next STAB;
+ }
+ if ($saveline) {
+ s/^"//;
+ $_ = $savebar . $_;
+ $line = $saveline;
+ }
+ &stab;
+ $savebar = $saveline = undef;
+ }
+ print STDERR "$.\n" if $trace;
+ unlink $TMP if $TMP;
+
+ &compute_intrinsics if $perl && !$opt_i;
+
+ print STDERR "resolving types\n" if $trace;
+
+ &resolve_types;
+ &adjust_start_addrs;
+
+ $sum = 2 + $type_width + $member_width;
+ $pmask1 = "%-${type_width}s %-${member_width}s";
+ $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
+
+
+
+ if ($perl) {
+ # resolve template -- should be in stab define order, but even this isn't enough.
+ print STDERR "\nbuilding type templates: " if $trace;
+ for $i (reverse 0..$#type) {
+ next unless defined($name = $type[$i]);
+ next unless defined $struct{$name};
+ ($iname = $name) =~ s/\..*//;
+ $build_recursed = 0;
+ &build_template($name) unless defined $template{&psou($name)} ||
+ $opt_s && !$interested{$iname};
+ }
+ print STDERR "\n\n" if $trace;
+ }
+
+ print STDERR "dumping structs: " if $trace;
+
+ local($iam);
+
+
+
+ foreach $name (sort keys %struct) {
+ ($iname = $name) =~ s/\..*//;
+ next if $opt_s && !$interested{$iname};
+ print STDERR "$name " if $trace;
+
+ undef @sizeof;
+ undef @typedef;
+ undef @offsetof;
+ undef @indices;
+ undef @typeof;
+ undef @fieldnames;
+
+ $mname = &munge($name);
+
+ $fname = &psou($name);
+
+ print "# " if $perl && $verbose;
+ $pcode = '';
+ print "$fname {\n" if !$perl || $verbose;
+ $template{$fname} = &scrunch($template{$fname}) if $perl;
+ &pstruct($name,$name,0);
+ print "# " if $perl && $verbose;
+ print "}\n" if !$perl || $verbose;
+ print "\n" if $perl && $verbose;
+
+ if ($perl) {
+ print "$pcode";
+
+ printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
+
+ print <<EOF;
+sub ${mname}'typedef {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'typedef[\$${mname}'index]
+ : \$${mname}'typedef;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'sizeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'sizeof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'offsetof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'offsetof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'typeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'typeof[\$${mname}'index]
+ : '$name';
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'fieldnames {
+ \@${mname}'fieldnames;
+}
+EOF
+
+ $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
+
+ print <<EOF;
+sub ${mname}'isastruct {
+ '$iam';
+}
+EOF
+
+ print "\$${mname}'typedef = '" . &scrunch($template{$fname})
+ . "';\n";
+
+ print "\$${mname}'sizeof = $sizeof{$name};\n\n";
+
+
+ print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
+
+ print "\n";
+
+ print "\@${mname}'typedef[\@${mname}'indices] = (",
+ join("\n\t", '', @typedef), "\n );\n\n";
+ print "\@${mname}'sizeof[\@${mname}'indices] = (",
+ join("\n\t", '', @sizeof), "\n );\n\n";
+ print "\@${mname}'offsetof[\@${mname}'indices] = (",
+ join("\n\t", '', @offsetof), "\n );\n\n";
+ print "\@${mname}'typeof[\@${mname}'indices] = (",
+ join("\n\t", '', @typeof), "\n );\n\n";
+ print "\@${mname}'fieldnames[\@${mname}'indices] = (",
+ join("\n\t", '', @fieldnames), "\n );\n\n";
+
+ $template_printed{$fname}++;
+ $size_printed{$fname}++;
+ }
+ print "\n";
+ }
+
+ print STDERR "\n" if $trace;
+
+ unless ($perl && $opt_a) {
+ print "\n1;\n" if $perl;
+ exit;
+ }
+
+
+
+ foreach $name (sort bysizevalue keys %intrinsics) {
+ next if $size_printed{$name};
+ print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
+ }
+
+ print "\n";
+
+ sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
+
+
+ foreach $name (sort keys %intrinsics) {
+ print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
+ }
+
+ print "\n1;\n" if $perl;
+
+ exit;
+}
+
+########################################################################################
+
+
+sub stab {
+ next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
+ s/"// || next;
+ s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
+
+ next if /^\s*$/;
+
+ $size = $3 if $3;
+ $_ = $continued . $_ if length($continued);
+ if (s/\\\\$//) {
+ # if last 2 chars of string are '\\' then stab is continued
+ # in next stab entry
+ chop;
+ $continued = $_;
+ next;
+ }
+ $continued = '';
+
+
+ $line = $_;
+
+ if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
+ print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
+ &pdecl($pdecl);
+ next;
+ }
+
+
+
+ if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
+ local($ident) = $2;
+ push(@intrinsics, $ident);
+ $typeno = &typeno($3);
+ $type[$typeno] = $ident;
+ print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
+ next;
+ }
+
+ if (($name, $typeordef, $typeno, $extra, $struct, $_)
+ = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
+ {
+ $typeno = &typeno($typeno); # sun foolery
+ }
+ elsif (/^[\$\w]+:/) {
+ next; # variable
+ }
+ else {
+ warn "can't grok stab: <$_> in: $line " if $_;
+ next;
+ }
+
+ #warn "got size $size for $name\n";
+ $sizeof{$name} = $size if $size;
+
+ s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
+
+ $typenos{$name} = $typeno;
+
+ unless (defined $type[$typeno]) {
+ &panic("type 0??") unless $typeno;
+ $type[$typeno] = $name unless defined $type[$typeno];
+ printf "new type $typeno is $name" if $debug;
+ if ($extra =~ /\*/ && defined $type[$struct]) {
+ print ", a typedef for a pointer to " , $type[$struct] if $debug;
+ }
+ } else {
+ printf "%s is type %d", $name, $typeno if $debug;
+ print ", a typedef for " , $type[$typeno] if $debug;
+ }
+ print "\n" if $debug;
+ #next unless $extra =~ /[su*]/;
+
+ #$type[$struct] = $name;
+
+ if ($extra =~ /[us*]/) {
+ &sou($name, $extra);
+ $_ = &sdecl($name, $_, 0);
+ }
+ elsif (/^=ar/) {
+ print "it's a bare array typedef -- that's pretty sick\n" if $debug;
+ $_ = "$typeno$_";
+ $scripts = '';
+ $_ = &adecl($_,1);
+
+ }
+ elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
+ push(@intrinsics, $2);
+ $typeno = &typeno($3);
+ $type[$typeno] = $2;
+ print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
+ }
+ elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
+ &edecl;
+ }
+ else {
+ warn "Funny remainder for $name on line $_ left in $line " if $_;
+ }
+}
+
+sub typeno { # sun thinks types are (0,27) instead of just 27
+ local($_) = @_;
+ s/\(\d+,(\d+)\)/$1/;
+ $_;
+}
+
+sub pstruct {
+ local($what,$prefix,$base) = @_;
+ local($field, $fieldname, $typeno, $count, $offset, $entry);
+ local($fieldtype);
+ local($type, $tname);
+ local($mytype, $mycount, $entry2);
+ local($struct_count) = 0;
+ local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
+ local($bits,$bytes);
+ local($template);
+
+
+ local($mname) = &munge($name);
+
+ sub munge {
+ local($_) = @_;
+ s/[\s\$\.]/_/g;
+ $_;
+ }
+
+ local($sname) = &psou($what);
+
+ $nesting++;
+
+ for $field (split(/;/, $struct{$what})) {
+ $pad = $prepad = 0;
+ $entry = '';
+ ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
+
+ $type = $type[$typeno];
+
+ $type =~ /([^[]*)(\[.*\])?/;
+ $mytype = $1;
+ $count .= $2;
+ $fieldtype = &psou($mytype);
+
+ local($fname) = &psou($name);
+
+ if ($build_templates) {
+
+ $pad = ($offset - ($lastoffset + $lastlength))/8
+ if defined $lastoffset;
+
+ if (! $finished_template{$sname}) {
+ if ($isaunion{$what}) {
+ $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
+ } else {
+ $template{$sname} .= 'x' x $pad . ' ' if $pad;
+ }
+ }
+
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+
+ if (! $finished_template{$sname}) {
+ $template{$sname} .= $template;
+ }
+
+ $revpad = $length/8 if $isaunion{$what};
+
+ ($lastoffset, $lastlength) = ($offset, $length);
+
+ } else {
+ print '# ' if $perl && $verbose;
+ $entry = sprintf($pmask1,
+ ' ' x ($nesting * $indent) . $fieldtype,
+ "$prefix.$fieldname" . $count);
+
+ $entry =~ s/(\*+)( )/$2$1/;
+
+ printf $pmask2,
+ $entry,
+ ($base+$offset)/8,
+ ($bits = ($base+$offset)%8) ? ".$bits" : " ",
+ $length/8,
+ ($bits = $length % 8) ? ".$bits": ""
+ if !$perl || $verbose;
+
+ if ($perl) {
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+ }
+
+ if ($perl && $nesting == 1) {
+
+ push(@sizeof, int($length/8) .",\t# $fieldname");
+ push(@offsetof, int($offset/8) .",\t# $fieldname");
+ local($little) = &scrunch($template);
+ push(@typedef, "'$little', \t# $fieldname");
+ $type =~ s/(struct|union) //;
+ push(@typeof, "'$mytype" . ($count ? $count : '') .
+ "',\t# $fieldname");
+ push(@fieldnames, "'$fieldname',");
+ }
+
+ print ' ', ' ' x $indent x $nesting, $template
+ if $perl && $verbose;
+
+ print "\n" if !$perl || $verbose;
+
+ }
+ if ($perl) {
+ local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
+ $mycount *= &scripts2count($count) if $count;
+ if ($nesting==1 && !$build_templates) {
+ $pcode .= sprintf("sub %-32s { %4d; }\n",
+ "${mname}'${fieldname}", $struct_count);
+ push(@indices, $struct_count);
+ }
+ $struct_count += $mycount;
+ }
+
+
+ &pstruct($type, "$prefix.$fieldname", $base+$offset)
+ if $recurse && defined $struct{$type};
+ }
+
+ $countof{$what} = $struct_count unless defined $countof{$whati};
+
+ $template{$sname} .= '$' if $build_templates;
+ $finished_template{$sname}++;
+
+ if ($build_templates && !defined $sizeof{$name}) {
+ local($fmt) = &scrunch($template{$sname});
+ print STDERR "no size for $name, punting with $fmt..." if $debug;
+ eval '$sizeof{$name} = length(pack($fmt, ()))';
+ if ($@) {
+ chop $@;
+ warn "couldn't get size for \$name: $@";
+ } else {
+ print STDERR $sizeof{$name}, "\n" if $debUg;
+ }
+ }
+
+ --$nesting;
+}
+
+
+sub psize {
+ local($me) = @_;
+ local($amstruct) = $struct{$me} ? 'struct ' : '';
+
+ print '$sizeof{\'', $amstruct, $me, '\'} = ';
+ printf "%d;\n", $sizeof{$me};
+}
+
+sub pdecl {
+ local($pdecl) = @_;
+ local(@pdecls);
+ local($tname);
+
+ warn "pdecl: $pdecl\n" if $debug;
+
+ $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
+ $pdecl =~ s/\*//g;
+ @pdecls = split(/=/, $pdecl);
+ $typeno = $pdecls[0];
+ $tname = pop @pdecls;
+
+ if ($tname =~ s/^f//) { $tname = "$tname&"; }
+ #else { $tname = "$tname*"; }
+
+ for (reverse @pdecls) {
+ $tname .= s/^f// ? "&" : "*";
+ #$tname =~ s/^f(.*)/$1&/;
+ print "type[$_] is $tname\n" if $debug;
+ $type[$_] = $tname unless defined $type[$_];
+ }
+}
+
+
+
+sub adecl {
+ ($arraytype, $unknown, $lower, $upper) = ();
+ #local($typeno);
+ # global $typeno, @type
+ local($_, $typedef) = @_;
+
+ while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
+ ($arraytype, $unknown) = ($2, $3);
+ $arraytype = &typeno($arraytype);
+ $unknown = &typeno($unknown);
+ if (s/^(\d+);(\d+);//) {
+ ($lower, $upper) = ($1, $2);
+ $scripts .= '[' . ($upper+1) . ']';
+ } else {
+ warn "can't find array bounds: $_";
+ }
+ }
+ if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ $whatis = $1;
+ if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
+ $typeno = &typeno($1);
+ &pdecl($whatis);
+ } else {
+ $typeno = &typeno($whatis);
+ }
+ } elsif (s/^(\d+)(=[*suf]\d*)//) {
+ local($whatis) = $2;
+
+ if ($whatis =~ /[f*]/) {
+ &pdecl($whatis);
+ } elsif ($whatis =~ /[su]/) { #
+ print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
+ if $debug;
+ #$type[$typeno] = $name unless defined $type[$typeno];
+ ##printf "new type $typeno is $name" if $debug;
+ $typeno = $1;
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = $type[$typeno];
+ &sou($name, $whatis);
+ $_ = &sdecl($name, $_, $start+$offset);
+ 1;
+ $start = $start{$name};
+ $offset = $sizeof{$name};
+ $length = $offset;
+ } else {
+ warn "what's this? $whatis in $line ";
+ }
+ } elsif (/^\d+$/) {
+ $typeno = $_;
+ } else {
+ warn "bad array stab: $_ in $line ";
+ next STAB;
+ }
+ #local($wasdef) = defined($type[$typeno]) && $debug;
+ #if ($typedef) {
+ #print "redefining $type[$typeno] to " if $wasdef;
+ #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
+ #print "$type[$typeno]\n" if $wasdef;
+ #} else {
+ #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
+ #}
+ $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
+ print "type[$arraytype] is $type[$arraytype]\n" if $debug;
+ print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
+ $_;
+}
+
+
+
+sub sdecl {
+ local($prefix, $_, $offset) = @_;
+
+ local($fieldname, $scripts, $type, $arraytype, $unknown,
+ $whatis, $pdecl, $upper,$lower, $start,$length) = ();
+ local($typeno,$sou);
+
+
+SFIELD:
+ while (/^([^;]+);/) {
+ $scripts = '';
+ warn "sdecl $_\n" if $debug;
+ if (s/^([\$\w]+)://) {
+ $fieldname = $1;
+ } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
+ $typeno = &typeno($1);
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$2);
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $offset += $sizeof{$name};
+ #print "done with anon, start is $start, offset is $offset\n";
+ #next SFIELD;
+ } else {
+ warn "weird field $_ of $line" if $debug;
+ next STAB;
+ #$fieldname = &gensym;
+ #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ }
+
+ if (/^(\d+|\(\d+,\d+\))=ar/) {
+ $_ = &adecl($_);
+ }
+ elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
+ ($pdecl, $start, $length) = ($1,$5,$6);
+ &pdecl($pdecl);
+ }
+ elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
+ ($typeno, $sou) = ($1, $2);
+ $typeno = &typeno($typeno);
+ if (defined($type[$typeno])) {
+ warn "now how did we get type $1 in $fieldname of $line?";
+ } else {
+ print "anon type $typeno is $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
+ };
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$sou);
+ print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname";
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $length = $sizeof{$name};
+ }
+ else {
+ warn "can't grok stab for $name ($_) in line $line ";
+ next STAB;
+ }
+
+ &panic("no length for $prefix.$fieldname") unless $length;
+ $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
+ }
+ if (s/;\d*,(\d+),(\d+);//) {
+ local($start, $size) = ($1, $2);
+ $sizeof{$prefix} = $size;
+ print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
+ $start{$prefix} = $start;
+ }
+ $_;
+}
+
+sub edecl {
+ s/;$//;
+ $enum{$name} = $_;
+ $_ = '';
+}
+
+sub resolve_types {
+ local($sou);
+ for $i (0 .. $#type) {
+ next unless defined $type[$i];
+ $_ = $type[$i];
+ unless (/\d/) {
+ print "type[$i] $type[$i]\n" if $debug;
+ next;
+ }
+ print "type[$i] $_ ==> " if $debug;
+ s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
+ s/^(\d+)\&/&type($1)/e;
+ s/^(\d+)/&type($1)/e;
+ s/(\*+)([^*]+)(\*+)/$1$3$2/;
+ s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
+ s/^(\d+)([\*\[].*)/&type($1).$2/e;
+ #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
+ $type[$i] = $_;
+ print "$_\n" if $debug;
+ }
+}
+sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
+
+sub adjust_start_addrs {
+ for (sort keys %start) {
+ ($basename = $_) =~ s/\.[^.]+$//;
+ $start{$_} += $start{$basename};
+ print "start: $_ @ $start{$_}\n" if $debug;
+ }
+}
+
+sub sou {
+ local($what, $_) = @_;
+ /u/ && $isaunion{$what}++;
+ /s/ && $isastruct{$what}++;
+}
+
+sub psou {
+ local($what) = @_;
+ local($prefix) = '';
+ if ($isaunion{$what}) {
+ $prefix = 'union ';
+ } elsif ($isastruct{$what}) {
+ $prefix = 'struct ';
+ }
+ $prefix . $what;
+}
+
+sub scrunch {
+ local($_) = @_;
+
+ return '' if $_ eq '';
+
+ study;
+
+ s/\$//g;
+ s/ / /g;
+ 1 while s/(\w) \1/$1$1/g;
+
+ # i wanna say this, but perl resists my efforts:
+ # s/(\w)(\1+)/$2 . length($1)/ge;
+
+ &quick_scrunch;
+
+ s/ $//;
+
+ $_;
+}
+
+sub buildscrunchlist {
+ $scrunch_code = "sub quick_scrunch {\n";
+ for (values %intrinsics) {
+ $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
+ }
+ $scrunch_code .= "}\n";
+ print "$scrunch_code" if $debug;
+ eval $scrunch_code;
+ &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
+}
+
+sub fetch_template {
+ local($mytype) = @_;
+ local($fmt);
+ local($count) = 1;
+
+ &panic("why do you care?") unless $perl;
+
+ if ($mytype =~ s/(\[\d+\])+$//) {
+ $count .= $1;
+ }
+
+ if ($mytype =~ /\*/) {
+ $fmt = $template{'pointer'};
+ }
+ elsif (defined $template{$mytype}) {
+ $fmt = $template{$mytype};
+ }
+ elsif (defined $struct{$mytype}) {
+ if (!defined $template{&psou($mytype)}) {
+ &build_template($mytype) unless $mytype eq $name;
+ }
+ elsif ($template{&psou($mytype)} !~ /\$$/) {
+ #warn "incomplete template for $mytype\n";
+ }
+ $fmt = $template{&psou($mytype)} || '?';
+ }
+ else {
+ warn "unknown fmt for $mytype\n";
+ $fmt = '?';
+ }
+
+ $fmt x $count . ' ';
+}
+
+sub compute_intrinsics {
+ &safedir;
+ local($TMP) = "$SAFEDIR/c2ph-i.$$.c";
+ open (TMP, ">$TMP") || die "can't open $TMP: $!";
+ select(TMP);
+
+ print STDERR "computing intrinsic sizes: " if $trace;
+
+ undef %intrinsics;
+
+ print <<'EOF';
+main() {
+ char *mask = "%d %s\n";
+EOF
+
+ for $type (@intrinsics) {
+ next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
+ print <<"EOF";
+ printf(mask,sizeof($type), "$type");
+EOF
+ }
+
+ print <<'EOF';
+ printf(mask,sizeof(char *), "pointer");
+ exit(0);
+}
+EOF
+ close TMP;
+
+ select(STDOUT);
+ open(PIPE, "cd $SAFEDIR && $CC $TMP && $SAFEDIR/a.out|");
+ while (<PIPE>) {
+ chop;
+ split(' ',$_,2);;
+ print "intrinsic $_[1] is size $_[0]\n" if $debug;
+ $sizeof{$_[1]} = $_[0];
+ $intrinsics{$_[1]} = $template{$_[0]};
+ }
+ close(PIPE) || die "couldn't read intrinsics!";
+ unlink($TMP, "$SAFEDIR/a.out");
+ print STDERR "done\n" if $trace;
+}
+
+sub scripts2count {
+ local($_) = @_;
+
+ s/^\[//;
+ s/\]$//;
+ s/\]\[/*/g;
+ $_ = eval;
+ &panic("$_: $@") if $@;
+ $_;
+}
+
+sub system {
+ print STDERR "@_\n" if $trace;
+ system @_;
+}
+
+sub build_template {
+ local($name) = @_;
+
+ &panic("already got a template for $name") if defined $template{$name};
+
+ local($build_templates) = 1;
+
+ local($lparen) = '(' x $build_recursed;
+ local($rparen) = ')' x $build_recursed;
+
+ print STDERR "$lparen$name$rparen " if $trace;
+ $build_recursed++;
+ &pstruct($name,$name,0);
+ print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
+ --$build_recursed;
+}
+
+
+sub panic {
+
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ local($i,$_);
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @DB'args;
+ for (@a) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+ $_ = sprintf("%s",$_);
+ }
+ else {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ push(@sub, "$w&$s$a from file $f line $l\n");
+ last if $signal;
+ }
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ print $sub[$i];
+ }
+ exit 1;
+}
+
+sub squishseq {
+ local($num);
+ local($last) = -1e8;
+ local($string);
+ local($seq) = '..';
+
+ while (defined($num = shift)) {
+ if ($num == ($last + 1)) {
+ $string .= $seq unless $inseq++;
+ $last = $num;
+ next;
+ } elsif ($inseq) {
+ $string .= $last unless $last == -1e8;
+ }
+
+ $string .= ',' if defined $string;
+ $string .= $num;
+ $last = $num;
+ $inseq = 0;
+ }
+ $string .= $last if $inseq && $last != -e18;
+ $string;
+}
+
+sub repeat_template {
+ # local($template, $scripts) = @_; have to change caller's values
+
+ if ( $_[1] ) {
+ local($ncount) = &scripts2count($_[1]);
+ if ($_[0] =~ /^\s*c\s*$/i) {
+ $_[0] = "A$ncount ";
+ $_[1] = '';
+ } else {
+ $_[0] = $template x $ncount;
+ }
+ }
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/config_data b/Master/tlpkg/tlperl/bin/config_data new file mode 100755 index 00000000000..532fe2406b0 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/config_data @@ -0,0 +1,249 @@ +#!C:\strawberry\perl\bin\perl.exe
+
+use strict;
+use Module::Build 0.25;
+use Getopt::Long;
+
+my %opt_defs = (
+ module => {type => '=s',
+ desc => 'The name of the module to configure (required)'},
+ feature => {type => ':s',
+ desc => 'Print the value of a feature or all features'},
+ config => {type => ':s',
+ desc => 'Print the value of a config option'},
+ set_feature => {type => '=s%',
+ desc => "Set a feature to 'true' or 'false'"},
+ set_config => {type => '=s%',
+ desc => 'Set a config option to the given value'},
+ eval => {type => '',
+ desc => 'eval() config values before setting'},
+ help => {type => '',
+ desc => 'Print a help message and exit'},
+ );
+
+my %opts;
+GetOptions( \%opts, map "$_$opt_defs{$_}{type}", keys %opt_defs ) or die usage(%opt_defs);
+print usage(%opt_defs) and exit(0)
+ if $opts{help};
+
+my @exclusive = qw(feature config set_feature set_config);
+die "Exactly one of the options '" . join("', '", @exclusive) . "' must be specified\n" . usage(%opt_defs)
+ unless grep(exists $opts{$_}, @exclusive) == 1;
+
+die "Option --module is required\n" . usage(%opt_defs)
+ unless $opts{module};
+
+my $cf = load_config($opts{module});
+
+if (exists $opts{feature}) {
+
+ if (length $opts{feature}) {
+ print $cf->feature($opts{feature});
+ } else {
+ my %auto;
+ # note: need to support older ConfigData.pm's
+ @auto{$cf->auto_feature_names} = () if $cf->can("auto_feature_names");
+
+ print " Features defined in $cf:\n";
+ foreach my $name (sort $cf->feature_names) {
+ print " $name => ", $cf->feature($name), (exists $auto{$name} ? " (dynamic)" : ""), "\n";
+ }
+ }
+
+} elsif (exists $opts{config}) {
+
+ require Data::Dumper;
+ local $Data::Dumper::Terse = 1;
+
+ if (length $opts{config}) {
+ print Data::Dumper::Dumper($cf->config($opts{config})), "\n";
+ } else {
+ print " Configuration defined in $cf:\n";
+ foreach my $name (sort $cf->config_names) {
+ print " $name => ", Data::Dumper::Dumper($cf->config($name)), "\n";
+ }
+ }
+
+} elsif (exists $opts{set_feature}) {
+ my %to_set = %{$opts{set_feature}};
+ while (my ($k, $v) = each %to_set) {
+ die "Feature value must be 0 or 1\n" unless $v =~ /^[01]$/;
+ $cf->set_feature($k, 0+$v); # Cast to a number, not a string
+ }
+ $cf->write;
+ print "Feature" . 's'x(keys(%to_set)>1) . " saved\n";
+
+} elsif (exists $opts{set_config}) {
+
+ my %to_set = %{$opts{set_config}};
+ while (my ($k, $v) = each %to_set) {
+ if ($opts{eval}) {
+ $v = eval($v);
+ die $@ if $@;
+ }
+ $cf->set_config($k, $v);
+ }
+ $cf->write;
+ print "Config value" . 's'x(keys(%to_set)>1) . " saved\n";
+}
+
+sub load_config {
+ my $mod = shift;
+
+ $mod =~ /^([\w:]+)$/
+ or die "Invalid module name '$mod'";
+
+ my $cf = $mod . "::ConfigData";
+ eval "require $cf";
+ die $@ if $@;
+
+ return $cf;
+}
+
+sub usage {
+ my %defs = @_;
+
+ my $out = "\nUsage: $0 [options]\n\n Options include:\n";
+
+ foreach my $name (sort keys %defs) {
+ $out .= " --$name";
+
+ for ($defs{$name}{type}) {
+ /^=s$/ and $out .= " <string>";
+ /^=s%$/ and $out .= " <string>=<value>";
+ }
+
+ pad_line($out, 35);
+ $out .= "$defs{$name}{desc}\n";
+ }
+
+ $out .= <<EOF;
+
+ Examples:
+ $0 --module Foo::Bar --feature bazzable
+ $0 --module Foo::Bar --config magic_number
+ $0 --module Foo::Bar --set_feature bazzable=1
+ $0 --module Foo::Bar --set_config magic_number=42
+
+EOF
+
+ return $out;
+}
+
+sub pad_line { $_[0] .= ' ' x ($_[1] - length($_[0]) + rindex($_[0], "\n")) }
+
+
+__END__
+
+=head1 NAME
+
+config_data - Query or change configuration of Perl modules
+
+=head1 SYNOPSIS
+
+ # Get config/feature values
+ config_data --module Foo::Bar --feature bazzable
+ config_data --module Foo::Bar --config magic_number
+
+ # Set config/feature values
+ config_data --module Foo::Bar --set_feature bazzable=1
+ config_data --module Foo::Bar --set_config magic_number=42
+
+ # Print a usage message
+ config_data --help
+
+=head1 DESCRIPTION
+
+The C<config_data> tool provides a command-line interface to the
+configuration of Perl modules. By "configuration", we mean something
+akin to "user preferences" or "local settings". This is a
+formalization and abstraction of the systems that people like Andreas
+Koenig (C<CPAN::Config>), Jon Swartz (C<HTML::Mason::Config>), Andy
+Wardley (C<Template::Config>), and Larry Wall (perl's own Config.pm)
+have developed independently.
+
+The configuration system emplyed here was developed in the context of
+C<Module::Build>. Under this system, configuration information for a
+module C<Foo>, for example, is stored in a module called
+C<Foo::ConfigData>) (I would have called it C<Foo::Config>, but that
+was taken by all those other systems mentioned in the previous
+paragraph...). These C<...::ConfigData> modules contain the
+configuration data, as well as publically accessible methods for
+querying and setting (yes, actually re-writing) the configuration
+data. The C<config_data> script (whose docs you are currently
+reading) is merely a front-end for those methods. If you wish, you
+may create alternate front-ends.
+
+The two types of data that may be stored are called C<config> values
+and C<feature> values. A C<config> value may be any perl scalar,
+including references to complex data structures. It must, however, be
+serializable using C<Data::Dumper>. A C<feature> is a boolean (1 or
+0) value.
+
+=head1 USAGE
+
+This script functions as a basic getter/setter wrapper around the
+configuration of a single module. On the command line, specify which
+module's configuration you're interested in, and pass options to get
+or set C<config> or C<feature> values. The following options are
+supported:
+
+=over 4
+
+=item module
+
+Specifies the name of the module to configure (required).
+
+=item feature
+
+When passed the name of a C<feature>, shows its value. The value will
+be 1 if the feature is enabled, 0 if the feature is not enabled, or
+empty if the feature is unknown. When no feature name is supplied,
+the names and values of all known features will be shown.
+
+=item config
+
+When passed the name of a C<config> entry, shows its value. The value
+will be displayed using C<Data::Dumper> (or similar) as perl code.
+When no config name is supplied, the names and values of all known
+config entries will be shown.
+
+=item set_feature
+
+Sets the given C<feature> to the given boolean value. Specify the value
+as either 1 or 0.
+
+=item set_config
+
+Sets the given C<config> entry to the given value.
+
+=item eval
+
+If the C<--eval> option is used, the values in C<set_config> will be
+evaluated as perl code before being stored. This allows moderately
+complicated data structures to be stored. For really complicated
+structures, you probably shouldn't use this command-line interface,
+just use the Perl API instead.
+
+=item help
+
+Prints a help message, including a few examples, and exits.
+
+=back
+
+=head1 AUTHOR
+
+Ken Williams, kwilliams@cpan.org
+
+=head1 COPYRIGHT
+
+Copyright (c) 1999, Ken Williams. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Module::Build(3), perl(1).
+
+=cut
diff --git a/Master/tlpkg/tlperl/bin/config_data.bat b/Master/tlpkg/tlperl/bin/config_data.bat new file mode 100755 index 00000000000..19604694e39 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/config_data.bat @@ -0,0 +1,265 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!C:\strawberry\perl\bin\perl.exe
+#line 15
+
+use strict;
+use Module::Build 0.25;
+use Getopt::Long;
+
+my %opt_defs = (
+ module => {type => '=s',
+ desc => 'The name of the module to configure (required)'},
+ feature => {type => ':s',
+ desc => 'Print the value of a feature or all features'},
+ config => {type => ':s',
+ desc => 'Print the value of a config option'},
+ set_feature => {type => '=s%',
+ desc => "Set a feature to 'true' or 'false'"},
+ set_config => {type => '=s%',
+ desc => 'Set a config option to the given value'},
+ eval => {type => '',
+ desc => 'eval() config values before setting'},
+ help => {type => '',
+ desc => 'Print a help message and exit'},
+ );
+
+my %opts;
+GetOptions( \%opts, map "$_$opt_defs{$_}{type}", keys %opt_defs ) or die usage(%opt_defs);
+print usage(%opt_defs) and exit(0)
+ if $opts{help};
+
+my @exclusive = qw(feature config set_feature set_config);
+die "Exactly one of the options '" . join("', '", @exclusive) . "' must be specified\n" . usage(%opt_defs)
+ unless grep(exists $opts{$_}, @exclusive) == 1;
+
+die "Option --module is required\n" . usage(%opt_defs)
+ unless $opts{module};
+
+my $cf = load_config($opts{module});
+
+if (exists $opts{feature}) {
+
+ if (length $opts{feature}) {
+ print $cf->feature($opts{feature});
+ } else {
+ my %auto;
+ # note: need to support older ConfigData.pm's
+ @auto{$cf->auto_feature_names} = () if $cf->can("auto_feature_names");
+
+ print " Features defined in $cf:\n";
+ foreach my $name (sort $cf->feature_names) {
+ print " $name => ", $cf->feature($name), (exists $auto{$name} ? " (dynamic)" : ""), "\n";
+ }
+ }
+
+} elsif (exists $opts{config}) {
+
+ require Data::Dumper;
+ local $Data::Dumper::Terse = 1;
+
+ if (length $opts{config}) {
+ print Data::Dumper::Dumper($cf->config($opts{config})), "\n";
+ } else {
+ print " Configuration defined in $cf:\n";
+ foreach my $name (sort $cf->config_names) {
+ print " $name => ", Data::Dumper::Dumper($cf->config($name)), "\n";
+ }
+ }
+
+} elsif (exists $opts{set_feature}) {
+ my %to_set = %{$opts{set_feature}};
+ while (my ($k, $v) = each %to_set) {
+ die "Feature value must be 0 or 1\n" unless $v =~ /^[01]$/;
+ $cf->set_feature($k, 0+$v); # Cast to a number, not a string
+ }
+ $cf->write;
+ print "Feature" . 's'x(keys(%to_set)>1) . " saved\n";
+
+} elsif (exists $opts{set_config}) {
+
+ my %to_set = %{$opts{set_config}};
+ while (my ($k, $v) = each %to_set) {
+ if ($opts{eval}) {
+ $v = eval($v);
+ die $@ if $@;
+ }
+ $cf->set_config($k, $v);
+ }
+ $cf->write;
+ print "Config value" . 's'x(keys(%to_set)>1) . " saved\n";
+}
+
+sub load_config {
+ my $mod = shift;
+
+ $mod =~ /^([\w:]+)$/
+ or die "Invalid module name '$mod'";
+
+ my $cf = $mod . "::ConfigData";
+ eval "require $cf";
+ die $@ if $@;
+
+ return $cf;
+}
+
+sub usage {
+ my %defs = @_;
+
+ my $out = "\nUsage: $0 [options]\n\n Options include:\n";
+
+ foreach my $name (sort keys %defs) {
+ $out .= " --$name";
+
+ for ($defs{$name}{type}) {
+ /^=s$/ and $out .= " <string>";
+ /^=s%$/ and $out .= " <string>=<value>";
+ }
+
+ pad_line($out, 35);
+ $out .= "$defs{$name}{desc}\n";
+ }
+
+ $out .= <<EOF;
+
+ Examples:
+ $0 --module Foo::Bar --feature bazzable
+ $0 --module Foo::Bar --config magic_number
+ $0 --module Foo::Bar --set_feature bazzable=1
+ $0 --module Foo::Bar --set_config magic_number=42
+
+EOF
+
+ return $out;
+}
+
+sub pad_line { $_[0] .= ' ' x ($_[1] - length($_[0]) + rindex($_[0], "\n")) }
+
+
+__END__
+
+=head1 NAME
+
+config_data - Query or change configuration of Perl modules
+
+=head1 SYNOPSIS
+
+ # Get config/feature values
+ config_data --module Foo::Bar --feature bazzable
+ config_data --module Foo::Bar --config magic_number
+
+ # Set config/feature values
+ config_data --module Foo::Bar --set_feature bazzable=1
+ config_data --module Foo::Bar --set_config magic_number=42
+
+ # Print a usage message
+ config_data --help
+
+=head1 DESCRIPTION
+
+The C<config_data> tool provides a command-line interface to the
+configuration of Perl modules. By "configuration", we mean something
+akin to "user preferences" or "local settings". This is a
+formalization and abstraction of the systems that people like Andreas
+Koenig (C<CPAN::Config>), Jon Swartz (C<HTML::Mason::Config>), Andy
+Wardley (C<Template::Config>), and Larry Wall (perl's own Config.pm)
+have developed independently.
+
+The configuration system emplyed here was developed in the context of
+C<Module::Build>. Under this system, configuration information for a
+module C<Foo>, for example, is stored in a module called
+C<Foo::ConfigData>) (I would have called it C<Foo::Config>, but that
+was taken by all those other systems mentioned in the previous
+paragraph...). These C<...::ConfigData> modules contain the
+configuration data, as well as publically accessible methods for
+querying and setting (yes, actually re-writing) the configuration
+data. The C<config_data> script (whose docs you are currently
+reading) is merely a front-end for those methods. If you wish, you
+may create alternate front-ends.
+
+The two types of data that may be stored are called C<config> values
+and C<feature> values. A C<config> value may be any perl scalar,
+including references to complex data structures. It must, however, be
+serializable using C<Data::Dumper>. A C<feature> is a boolean (1 or
+0) value.
+
+=head1 USAGE
+
+This script functions as a basic getter/setter wrapper around the
+configuration of a single module. On the command line, specify which
+module's configuration you're interested in, and pass options to get
+or set C<config> or C<feature> values. The following options are
+supported:
+
+=over 4
+
+=item module
+
+Specifies the name of the module to configure (required).
+
+=item feature
+
+When passed the name of a C<feature>, shows its value. The value will
+be 1 if the feature is enabled, 0 if the feature is not enabled, or
+empty if the feature is unknown. When no feature name is supplied,
+the names and values of all known features will be shown.
+
+=item config
+
+When passed the name of a C<config> entry, shows its value. The value
+will be displayed using C<Data::Dumper> (or similar) as perl code.
+When no config name is supplied, the names and values of all known
+config entries will be shown.
+
+=item set_feature
+
+Sets the given C<feature> to the given boolean value. Specify the value
+as either 1 or 0.
+
+=item set_config
+
+Sets the given C<config> entry to the given value.
+
+=item eval
+
+If the C<--eval> option is used, the values in C<set_config> will be
+evaluated as perl code before being stored. This allows moderately
+complicated data structures to be stored. For really complicated
+structures, you probably shouldn't use this command-line interface,
+just use the Perl API instead.
+
+=item help
+
+Prints a help message, including a few examples, and exits.
+
+=back
+
+=head1 AUTHOR
+
+Ken Williams, kwilliams@cpan.org
+
+=head1 COPYRIGHT
+
+Copyright (c) 1999, Ken Williams. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Module::Build(3), perl(1).
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/corelist b/Master/tlpkg/tlperl/bin/corelist new file mode 100755 index 00000000000..b59aef34776 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/corelist @@ -0,0 +1,272 @@ +#!/usr/bin/perl + +=head1 NAME + +corelist - a commandline frontend to Module::CoreList + +=head1 DESCRIPTION + +See L<Module::CoreList> for one. + +=head1 SYNOPSIS + + corelist -v + corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ... + corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ... + +=head1 OPTIONS + +=over + +=item -a + +lists all versions of the given module (or the matching modules, in case you +used a module regexp) in the perls Module::CoreList knows about. + + corelist -a utf8 + + utf8 was first released with perl 5.006 + 5.006 undef + 5.006001 undef + 5.006002 undef + 5.007003 1.00 + 5.008 1.00 + 5.008001 1.02 + 5.008002 1.02 + 5.008003 1.02 + 5.008004 1.03 + 5.008005 1.04 + 5.008006 1.04 + 5.008007 1.05 + 5.008008 1.06 + 5.009 1.02 + 5.009001 1.02 + 5.009002 1.04 + 5.009003 1.06 + +=item -d + +finds the first perl version where a module has been released by +date, and not by version number (as is the default). + +=item -? or -help + +help! help! help! to see more help, try --man. + +=item -man + +all of the help + +=item -v + +lists all of the perl release versions we got the CoreList for. + +If you pass a version argument (value of C<$]>, like C<5.00503> or C<5.008008>), +you get a list of all the modules and their respective versions. +(If you have the C<version> module, you can also use new-style version numbers, +like C<5.8.8>.) + +In module filtering context, it can be used as Perl version filter. + +=back + +As a special case, if you specify the module name C<Unicode>, you'll get +the version number of the Unicode Character Database bundled with the +requested perl versions. + +=cut + +use Module::CoreList; +use Getopt::Long; +use Pod::Usage; +use strict; +use warnings; + +my %Opts; + +GetOptions(\%Opts, qw[ help|?! man! v|version:f a! d ] ); + +pod2usage(1) if $Opts{help}; +pod2usage(-verbose=>2) if $Opts{man}; + +if(exists $Opts{v} ){ + if( !$Opts{v} ) { + print "\nModule::CoreList has info on the following perl versions:\n"; + print "$_\n" for sort keys %Module::CoreList::version; + print "\n"; + exit 0; + } + + $Opts{v} = numify_version( $Opts{v} ); + my $version_hash = Module::CoreList->find_version($Opts{v}); + if( !$version_hash ) { + print "\nModule::CoreList has no info on perl v$Opts{v}\n\n"; + exit 1; + } + + if ( !@ARGV ) { + print "\nThe following modules were in perl v$Opts{v} CORE\n"; + print "$_ ", $version_hash->{$_} || " ","\n" + for sort keys %$version_hash; + print "\n"; + exit 0; + } +} + +if ( !@ARGV ) { + pod2usage(0); +} + +while (@ARGV) { + my ($mod, $ver); + if ($ARGV[0] =~ /=/) { + ($mod, $ver) = split /=/, shift @ARGV; + } else { + $mod = shift @ARGV; + $ver = (@ARGV && $ARGV[0] =~ /^\d/) ? shift @ARGV : ""; + } + + if ($mod !~ m|^/(.*)/([imosx]*)$|) { # not a regex + module_version($mod,$ver); + } else { + my $re; + eval { $re = $2 ? qr/(?$2)($1)/ : qr/$1/; }; # trap exceptions while building regex + if ($@) { + # regex errors are usually like 'Quantifier follow nothing in regex; marked by ...' + # then we drop text after ';' to shorten message + my $errmsg = $@ =~ /(.*);/ ? $1 : $@; + warn "\n$mod is a bad regex: $errmsg\n"; + next; + } + my @mod = Module::CoreList->find_modules($re); + if (@mod) { + module_version($_, $ver) for @mod; + } else { + $ver |= ''; + print "\n$mod $ver has no match in CORE (or so I think)\n"; + } + + } +} + +exit(); + +sub module_version { + my($mod,$ver) = @_; + + if ( $Opts{v} ) { + my $version_hash = Module::CoreList->find_version($Opts{v}); + if ($version_hash) { + print $mod, " ", $version_hash->{$mod} || 'undef', "\n"; + return; + } + else { die "Shouldn't happen" } + } + + my $ret = $Opts{d} + ? Module::CoreList->first_release_by_date(@_) + : Module::CoreList->first_release(@_); + my $msg = $mod; + $msg .= " $ver" if $ver; + + if( defined $ret ) { + $msg .= " was "; + $msg .= "first " unless $ver; + $msg .= "released with perl $ret" + } else { + $msg .= " was not in CORE (or so I think)"; + } + + print "\n",$msg,"\n"; + + if(defined $ret and exists $Opts{a} and $Opts{a}){ + for my $v( + sort keys %Module::CoreList::version ){ + + printf " %-10s %-10s\n", + $v, + $Module::CoreList::version{$v}{$mod} + || 'undef' + if exists $Module::CoreList::version{$v}{$mod}; + } + print "\n"; + } +} + +sub numify_version { + my $ver = shift; + if ($ver =~ /\..+\./) { + eval { require version ; 1 } + or die "You need to install version.pm to use dotted version numbers\n"; + $ver = version->new($ver)->numify; + } + $ver += 0; + return $ver; +} + +=head1 EXAMPLES + + $ corelist File::Spec + + File::Spec was first released with perl 5.005 + + $ corelist File::Spec 0.83 + + File::Spec 0.83 was released with perl 5.007003 + + $ corelist File::Spec 0.89 + + File::Spec 0.89 was not in CORE (or so I think) + + $ corelist File::Spec::Aliens + + File::Spec::Aliens was not in CORE (or so I think) + + $ corelist /IPC::Open/ + + IPC::Open2 was first released with perl 5 + + IPC::Open3 was first released with perl 5 + + $ corelist /MANIFEST/i + + ExtUtils::Manifest was first released with perl 5.001 + + $ corelist /Template/ + + /Template/ has no match in CORE (or so I think) + + $ corelist -v 5.8.8 B + + B 1.09_01 + + $ corelist -v 5.8.8 /^B::/ + + B::Asmdata 1.01 + B::Assembler 0.07 + B::Bblock 1.02_01 + B::Bytecode 1.01_01 + B::C 1.04_01 + B::CC 1.00_01 + B::Concise 0.66 + B::Debug 1.02_01 + B::Deparse 0.71 + B::Disassembler 1.05 + B::Lint 1.03 + B::O 1.00 + B::Showlex 1.02 + B::Stackobj 1.00 + B::Stash 1.00 + B::Terse 1.03_01 + B::Xref 1.01 + +=head1 COPYRIGHT + +Copyright (c) 2002-2007 by D.H. aka PodMaster + +Currently maintained by the perl 5 porters E<lt>perl5-porters@perl.orgE<gt>. + +This program is distributed under the same terms as perl itself. +See http://perl.org/ or http://cpan.org/ for more info on that. + +=cut diff --git a/Master/tlpkg/tlperl/bin/corelist.bat b/Master/tlpkg/tlperl/bin/corelist.bat new file mode 100755 index 00000000000..f0cc991ff10 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/corelist.bat @@ -0,0 +1,288 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+=head1 NAME
+
+corelist - a commandline frontend to Module::CoreList
+
+=head1 DESCRIPTION
+
+See L<Module::CoreList> for one.
+
+=head1 SYNOPSIS
+
+ corelist -v
+ corelist [-a|-d] <ModuleName> | /<ModuleRegex>/ [<ModuleVersion>] ...
+ corelist [-v <PerlVersion>] [ <ModuleName> | /<ModuleRegex>/ ] ...
+
+=head1 OPTIONS
+
+=over
+
+=item -a
+
+lists all versions of the given module (or the matching modules, in case you
+used a module regexp) in the perls Module::CoreList knows about.
+
+ corelist -a utf8
+
+ utf8 was first released with perl 5.006
+ 5.006 undef
+ 5.006001 undef
+ 5.006002 undef
+ 5.007003 1.00
+ 5.008 1.00
+ 5.008001 1.02
+ 5.008002 1.02
+ 5.008003 1.02
+ 5.008004 1.03
+ 5.008005 1.04
+ 5.008006 1.04
+ 5.008007 1.05
+ 5.008008 1.06
+ 5.009 1.02
+ 5.009001 1.02
+ 5.009002 1.04
+ 5.009003 1.06
+
+=item -d
+
+finds the first perl version where a module has been released by
+date, and not by version number (as is the default).
+
+=item -? or -help
+
+help! help! help! to see more help, try --man.
+
+=item -man
+
+all of the help
+
+=item -v
+
+lists all of the perl release versions we got the CoreList for.
+
+If you pass a version argument (value of C<$]>, like C<5.00503> or C<5.008008>),
+you get a list of all the modules and their respective versions.
+(If you have the C<version> module, you can also use new-style version numbers,
+like C<5.8.8>.)
+
+In module filtering context, it can be used as Perl version filter.
+
+=back
+
+As a special case, if you specify the module name C<Unicode>, you'll get
+the version number of the Unicode Character Database bundled with the
+requested perl versions.
+
+=cut
+
+use Module::CoreList;
+use Getopt::Long;
+use Pod::Usage;
+use strict;
+use warnings;
+
+my %Opts;
+
+GetOptions(\%Opts, qw[ help|?! man! v|version:f a! d ] );
+
+pod2usage(1) if $Opts{help};
+pod2usage(-verbose=>2) if $Opts{man};
+
+if(exists $Opts{v} ){
+ if( !$Opts{v} ) {
+ print "\nModule::CoreList has info on the following perl versions:\n";
+ print "$_\n" for sort keys %Module::CoreList::version;
+ print "\n";
+ exit 0;
+ }
+
+ $Opts{v} = numify_version( $Opts{v} );
+ my $version_hash = Module::CoreList->find_version($Opts{v});
+ if( !$version_hash ) {
+ print "\nModule::CoreList has no info on perl v$Opts{v}\n\n";
+ exit 1;
+ }
+
+ if ( !@ARGV ) {
+ print "\nThe following modules were in perl v$Opts{v} CORE\n";
+ print "$_ ", $version_hash->{$_} || " ","\n"
+ for sort keys %$version_hash;
+ print "\n";
+ exit 0;
+ }
+}
+
+if ( !@ARGV ) {
+ pod2usage(0);
+}
+
+while (@ARGV) {
+ my ($mod, $ver);
+ if ($ARGV[0] =~ /=/) {
+ ($mod, $ver) = split /=/, shift @ARGV;
+ } else {
+ $mod = shift @ARGV;
+ $ver = (@ARGV && $ARGV[0] =~ /^\d/) ? shift @ARGV : "";
+ }
+
+ if ($mod !~ m|^/(.*)/([imosx]*)$|) { # not a regex
+ module_version($mod,$ver);
+ } else {
+ my $re;
+ eval { $re = $2 ? qr/(?$2)($1)/ : qr/$1/; }; # trap exceptions while building regex
+ if ($@) {
+ # regex errors are usually like 'Quantifier follow nothing in regex; marked by ...'
+ # then we drop text after ';' to shorten message
+ my $errmsg = $@ =~ /(.*);/ ? $1 : $@;
+ warn "\n$mod is a bad regex: $errmsg\n";
+ next;
+ }
+ my @mod = Module::CoreList->find_modules($re);
+ if (@mod) {
+ module_version($_, $ver) for @mod;
+ } else {
+ $ver |= '';
+ print "\n$mod $ver has no match in CORE (or so I think)\n";
+ }
+
+ }
+}
+
+exit();
+
+sub module_version {
+ my($mod,$ver) = @_;
+
+ if ( $Opts{v} ) {
+ my $version_hash = Module::CoreList->find_version($Opts{v});
+ if ($version_hash) {
+ print $mod, " ", $version_hash->{$mod} || 'undef', "\n";
+ return;
+ }
+ else { die "Shouldn't happen" }
+ }
+
+ my $ret = $Opts{d}
+ ? Module::CoreList->first_release_by_date(@_)
+ : Module::CoreList->first_release(@_);
+ my $msg = $mod;
+ $msg .= " $ver" if $ver;
+
+ if( defined $ret ) {
+ $msg .= " was ";
+ $msg .= "first " unless $ver;
+ $msg .= "released with perl $ret"
+ } else {
+ $msg .= " was not in CORE (or so I think)";
+ }
+
+ print "\n",$msg,"\n";
+
+ if(defined $ret and exists $Opts{a} and $Opts{a}){
+ for my $v(
+ sort keys %Module::CoreList::version ){
+
+ printf " %-10s %-10s\n",
+ $v,
+ $Module::CoreList::version{$v}{$mod}
+ || 'undef'
+ if exists $Module::CoreList::version{$v}{$mod};
+ }
+ print "\n";
+ }
+}
+
+sub numify_version {
+ my $ver = shift;
+ if ($ver =~ /\..+\./) {
+ eval { require version ; 1 }
+ or die "You need to install version.pm to use dotted version numbers\n";
+ $ver = version->new($ver)->numify;
+ }
+ $ver += 0;
+ return $ver;
+}
+
+=head1 EXAMPLES
+
+ $ corelist File::Spec
+
+ File::Spec was first released with perl 5.005
+
+ $ corelist File::Spec 0.83
+
+ File::Spec 0.83 was released with perl 5.007003
+
+ $ corelist File::Spec 0.89
+
+ File::Spec 0.89 was not in CORE (or so I think)
+
+ $ corelist File::Spec::Aliens
+
+ File::Spec::Aliens was not in CORE (or so I think)
+
+ $ corelist /IPC::Open/
+
+ IPC::Open2 was first released with perl 5
+
+ IPC::Open3 was first released with perl 5
+
+ $ corelist /MANIFEST/i
+
+ ExtUtils::Manifest was first released with perl 5.001
+
+ $ corelist /Template/
+
+ /Template/ has no match in CORE (or so I think)
+
+ $ corelist -v 5.8.8 B
+
+ B 1.09_01
+
+ $ corelist -v 5.8.8 /^B::/
+
+ B::Asmdata 1.01
+ B::Assembler 0.07
+ B::Bblock 1.02_01
+ B::Bytecode 1.01_01
+ B::C 1.04_01
+ B::CC 1.00_01
+ B::Concise 0.66
+ B::Debug 1.02_01
+ B::Deparse 0.71
+ B::Disassembler 1.05
+ B::Lint 1.03
+ B::O 1.00
+ B::Showlex 1.02
+ B::Stackobj 1.00
+ B::Stash 1.00
+ B::Terse 1.03_01
+ B::Xref 1.01
+
+=head1 COPYRIGHT
+
+Copyright (c) 2002-2007 by D.H. aka PodMaster
+
+Currently maintained by the perl 5 porters E<lt>perl5-porters@perl.orgE<gt>.
+
+This program is distributed under the same terms as perl itself.
+See http://perl.org/ or http://cpan.org/ for more info on that.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/cpan b/Master/tlpkg/tlperl/bin/cpan new file mode 100755 index 00000000000..5e5609555f6 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpan @@ -0,0 +1,229 @@ +#!/usr/local/bin/perl +use strict; +use vars qw($VERSION); + +use App::Cpan; +$VERSION = '1.57'; + +my $rc = App::Cpan->run( @ARGV ); + +# will this work under Strawberry Perl? +exit( $rc || 0 ); + +=head1 NAME + +cpan - easily interact with CPAN from the command line + +=head1 SYNOPSIS + + # with arguments and no switches, installs specified modules + cpan module_name [ module_name ... ] + + # with switches, installs modules with extra behavior + cpan [-cfgimt] module_name [ module_name ... ] + + # with just the dot, install from the distribution in the + # current directory + cpan . + + # without arguments, starts CPAN.pm shell + cpan + + # dump the configuration + cpan -J + + # load a different configuration to install Module::Foo + cpan -j some/other/file Module::Foo + + # without arguments, but some switches + cpan [-ahrvACDlLO] + +=head1 DESCRIPTION + +This script provides a command interface (not a shell) to CPAN. At the +moment it uses CPAN.pm to do the work, but it is not a one-shot command +runner for CPAN.pm. + +=head2 Options + +=over 4 + +=item -a + +Creates a CPAN.pm autobundle with CPAN::Shell->autobundle. + +=item -A module [ module ... ] + +Shows the primary maintainers for the specified modules. + +=item -c module + +Runs a `make clean` in the specified module's directories. + +=item -C module [ module ... ] + +Show the F<Changes> files for the specified modules + +=item -D module [ module ... ] + +Show the module details. This prints one line for each out-of-date module +(meaning, modules locally installed but have newer versions on CPAN). +Each line has three columns: module name, local version, and CPAN +version. + +=item -f + +Force the specified action, when it normally would have failed. Use this +to install a module even if its tests fail. When you use this option, +-i is not optional for installing a module when you need to force it: + + % cpan -f -i Module::Foo + +=item -F + +Turn off CPAN.pm's attempts to lock anything. You should be careful with +this since you might end up with multiple scripts trying to muck in the +same directory. This isn't so much of a concern if you're loading a special +config with C<-j>, and that config sets up its own work directories. + +=item -g module [ module ... ] + +Downloads to the current directory the latest distribution of the module. + +=item -G module [ module ... ] + +UNIMPLEMENTED + +Download to the current directory the latest distribution of the +modules, unpack each distribution, and create a git repository for each +distribution. + +If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch> +distribution. + +=item -h + +Print a help message and exit. When you specify C<-h>, it ignores all +of the other options and arguments. + +=item -i + +Install the specified modules. + +=item -j Config.pm + +Load the file that has the CPAN configuration data. This should have the +same format as the standard F<CPAN/Config.pm> file, which defines +C<$CPAN::Config> as an anonymous hash. + +=item -J + +Dump the configuration in the same format that CPAN.pm uses. This is useful +for checking the configuration as well as using the dump as a starting point +for a new, custom configuration. + +=item -L author [ author ... ] + +List the modules by the specified authors. + +=item -m + +Make the specified modules. + +=item -O + +Show the out-of-date modules. + +=item -t + +Run a `make test` on the specified modules. + +=item -r + +Recompiles dynamically loaded modules with CPAN::Shell->recompile. + +=item -v + +Print the script version and CPAN.pm version then exit. + +=back + +=head2 Examples + + # print a help message + cpan -h + + # print the version numbers + cpan -v + + # create an autobundle + cpan -a + + # recompile modules + cpan -r + + # install modules ( sole -i is optional ) + cpan -i Netscape::Booksmarks Business::ISBN + + # force install modules ( must use -i ) + cpan -fi CGI::Minimal URI + +=head1 EXIT VALUES + +The script exits with zero if it thinks that everything worked, or a +positive number if it thinks that something failed. Note, however, that +in some cases it has to divine a failure by the output of things it does +not control. For now, the exit codes are vague: + + 1 An unknown error + + 2 The was an external problem + + 4 There was an internal problem with the script + + 8 A module failed to install + +=head1 TO DO + +* one shot configuration values from the command line + + + +=head1 BUGS + +* none noted + +=head1 SEE ALSO + +Most behaviour, including environment variables and configuration, +comes directly from CPAN.pm. + +=head1 SOURCE AVAILABILITY + +This code is in Github: + + git://github.com/briandfoy/cpan_script.git + +=head1 CREDITS + +Japheth Cleaver added the bits to allow a forced install (-f). + +Jim Brandt suggest and provided the initial implementation for the +up-to-date and Changes features. + +Adam Kennedy pointed out that exit() causes problems on Windows +where this script ends up with a .bat extension + +=head1 AUTHOR + +brian d foy, C<< <bdfoy@cpan.org> >> + +=head1 COPYRIGHT + +Copyright (c) 2001-2009, brian d foy, All Rights Reserved. + +You may redistribute this under the same terms as Perl itself. + +=cut + +1; diff --git a/Master/tlpkg/tlperl/bin/cpan.bat b/Master/tlpkg/tlperl/bin/cpan.bat new file mode 100755 index 00000000000..b96d7678fd2 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpan.bat @@ -0,0 +1,245 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl
+#line 15
+use strict;
+use vars qw($VERSION);
+
+use App::Cpan;
+$VERSION = '1.57';
+
+my $rc = App::Cpan->run( @ARGV );
+
+# will this work under Strawberry Perl?
+exit( $rc || 0 );
+
+=head1 NAME
+
+cpan - easily interact with CPAN from the command line
+
+=head1 SYNOPSIS
+
+ # with arguments and no switches, installs specified modules
+ cpan module_name [ module_name ... ]
+
+ # with switches, installs modules with extra behavior
+ cpan [-cfgimt] module_name [ module_name ... ]
+
+ # with just the dot, install from the distribution in the
+ # current directory
+ cpan .
+
+ # without arguments, starts CPAN.pm shell
+ cpan
+
+ # dump the configuration
+ cpan -J
+
+ # load a different configuration to install Module::Foo
+ cpan -j some/other/file Module::Foo
+
+ # without arguments, but some switches
+ cpan [-ahrvACDlLO]
+
+=head1 DESCRIPTION
+
+This script provides a command interface (not a shell) to CPAN. At the
+moment it uses CPAN.pm to do the work, but it is not a one-shot command
+runner for CPAN.pm.
+
+=head2 Options
+
+=over 4
+
+=item -a
+
+Creates a CPAN.pm autobundle with CPAN::Shell->autobundle.
+
+=item -A module [ module ... ]
+
+Shows the primary maintainers for the specified modules.
+
+=item -c module
+
+Runs a `make clean` in the specified module's directories.
+
+=item -C module [ module ... ]
+
+Show the F<Changes> files for the specified modules
+
+=item -D module [ module ... ]
+
+Show the module details. This prints one line for each out-of-date module
+(meaning, modules locally installed but have newer versions on CPAN).
+Each line has three columns: module name, local version, and CPAN
+version.
+
+=item -f
+
+Force the specified action, when it normally would have failed. Use this
+to install a module even if its tests fail. When you use this option,
+-i is not optional for installing a module when you need to force it:
+
+ % cpan -f -i Module::Foo
+
+=item -F
+
+Turn off CPAN.pm's attempts to lock anything. You should be careful with
+this since you might end up with multiple scripts trying to muck in the
+same directory. This isn't so much of a concern if you're loading a special
+config with C<-j>, and that config sets up its own work directories.
+
+=item -g module [ module ... ]
+
+Downloads to the current directory the latest distribution of the module.
+
+=item -G module [ module ... ]
+
+UNIMPLEMENTED
+
+Download to the current directory the latest distribution of the
+modules, unpack each distribution, and create a git repository for each
+distribution.
+
+If you want this feature, check out Yanick Champoux's C<Git::CPAN::Patch>
+distribution.
+
+=item -h
+
+Print a help message and exit. When you specify C<-h>, it ignores all
+of the other options and arguments.
+
+=item -i
+
+Install the specified modules.
+
+=item -j Config.pm
+
+Load the file that has the CPAN configuration data. This should have the
+same format as the standard F<CPAN/Config.pm> file, which defines
+C<$CPAN::Config> as an anonymous hash.
+
+=item -J
+
+Dump the configuration in the same format that CPAN.pm uses. This is useful
+for checking the configuration as well as using the dump as a starting point
+for a new, custom configuration.
+
+=item -L author [ author ... ]
+
+List the modules by the specified authors.
+
+=item -m
+
+Make the specified modules.
+
+=item -O
+
+Show the out-of-date modules.
+
+=item -t
+
+Run a `make test` on the specified modules.
+
+=item -r
+
+Recompiles dynamically loaded modules with CPAN::Shell->recompile.
+
+=item -v
+
+Print the script version and CPAN.pm version then exit.
+
+=back
+
+=head2 Examples
+
+ # print a help message
+ cpan -h
+
+ # print the version numbers
+ cpan -v
+
+ # create an autobundle
+ cpan -a
+
+ # recompile modules
+ cpan -r
+
+ # install modules ( sole -i is optional )
+ cpan -i Netscape::Booksmarks Business::ISBN
+
+ # force install modules ( must use -i )
+ cpan -fi CGI::Minimal URI
+
+=head1 EXIT VALUES
+
+The script exits with zero if it thinks that everything worked, or a
+positive number if it thinks that something failed. Note, however, that
+in some cases it has to divine a failure by the output of things it does
+not control. For now, the exit codes are vague:
+
+ 1 An unknown error
+
+ 2 The was an external problem
+
+ 4 There was an internal problem with the script
+
+ 8 A module failed to install
+
+=head1 TO DO
+
+* one shot configuration values from the command line
+
+
+
+=head1 BUGS
+
+* none noted
+
+=head1 SEE ALSO
+
+Most behaviour, including environment variables and configuration,
+comes directly from CPAN.pm.
+
+=head1 SOURCE AVAILABILITY
+
+This code is in Github:
+
+ git://github.com/briandfoy/cpan_script.git
+
+=head1 CREDITS
+
+Japheth Cleaver added the bits to allow a forced install (-f).
+
+Jim Brandt suggest and provided the initial implementation for the
+up-to-date and Changes features.
+
+Adam Kennedy pointed out that exit() causes problems on Windows
+where this script ends up with a .bat extension
+
+=head1 AUTHOR
+
+brian d foy, C<< <bdfoy@cpan.org> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001-2009, brian d foy, All Rights Reserved.
+
+You may redistribute this under the same terms as Perl itself.
+
+=cut
+
+1;
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/cpan2dist b/Master/tlpkg/tlperl/bin/cpan2dist new file mode 100755 index 00000000000..5ba4556c529 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpan2dist @@ -0,0 +1,671 @@ +#!/usr/bin/perl -w +use strict; +use CPANPLUS::Backend; +use CPANPLUS::Dist; +use CPANPLUS::Internals::Constants; +use Data::Dumper; +use Getopt::Long; +use File::Spec; +use File::Temp qw|tempfile|; +use File::Basename; +use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; + +local $Data::Dumper::Indent = 1; + +use constant PREREQ_SKIP_CLASS => 'CPANPLUS::To::Dist::PREREQ_SKIP'; +use constant ALARM_CLASS => 'CPANPLUS::To::Dist::ALARM'; + +### print when you can +$|++; + +my $cb = CPANPLUS::Backend->new + or die loc("Could not create new CPANPLUS::Backend object"); +my $conf = $cb->configure_object; + +my %formats = map { $_ => $_ } CPANPLUS::Dist->dist_types; + +my $opts = {}; +GetOptions( $opts, + 'format=s', 'archive', + 'verbose!', 'force!', + 'skiptest!', 'keepsource!', + 'makefile!', 'buildprereq!', + 'help', 'flushcache', + 'ban=s@', 'banlist=s@', + 'ignore=s@', 'ignorelist=s@', + 'defaults', 'modulelist=s@', + 'logfile=s', 'timeout=s', + 'dist-opts=s%', 'set-config=s%', + 'default-banlist!', 'set-program=s%', + 'default-ignorelist!', 'edit-metafile!', + 'install!' + ); + +die usage() if exists $opts->{'help'}; + +### parse options +my $tarball = $opts->{'archive'} || 0; +my $keep = $opts->{'keepsource'} ? 1 : 0; +my $prereqbuild = exists $opts->{'buildprereq'} + ? $opts->{'buildprereq'} + : 0; +my $timeout = exists $opts->{'timeout'} + ? $opts->{'timeout'} + : 300; + +### use default answers? +$ENV{'PERL_MM_USE_DEFAULT'} = $opts->{'defaults'} ? 1 : 0; + +my $format; +### if provided, we go with the command line option, fall back to conf setting +{ $format = $opts->{'format'} || $conf->get_conf('dist_type'); + $conf->set_conf( dist_type => $format ); + + ### is this a valid format?? + die loc("Invalid format: " . ($format || "[NONE]") ) . usage() + unless $formats{$format}; + + ### any options to fix config entries + { my $set_conf = $opts->{'set-config'} || {}; + while( my($key,$val) = each %$set_conf ) { + $conf->set_conf( $key => $val ); + } + } + + ### any options to fix program entries + { my $set_prog = $opts->{'set-program'} || {}; + while( my($key,$val) = each %$set_prog ) { + $conf->set_program( $key => $val ); + } + } + + ### any other options passed + { my %map = ( verbose => 'verbose', + force => 'force', + skiptest => 'skiptest', + makefile => 'prefer_makefile' + ); + + ### set config options from arguments + while (my($key,$val) = each %map) { + my $bool = exists $opts->{$key} + ? $opts->{$key} + : $conf->get_conf($val); + $conf->set_conf( $val => $bool ); + } + } +} + +my @modules = @ARGV; +if( exists $opts->{'modulelist'} ) { + push @modules, map { parse_file( $_ ) } @{ $opts->{'modulelist'} }; +} + +die usage() unless @modules; + +### set up munge callback if requested +{ if( $opts->{'edit-metafile'} ) { + my $editor = $conf->get_program('editor'); + + if( $editor ) { + + ### register install callback ### + $cb->_register_callback( + name => 'munge_dist_metafile', + code => sub { + my $self = shift; + my $text = shift or return; + + my($fh,$file) = tempfile( UNLINK => 1 ); + + unless( print $fh $text ) { + warn "Could not print metafile information: $!"; + return; + } + + close $fh; + + system( $editor => $file ); + + my $cont = $cb->_get_file_contents( file => $file ); + + return $cont; + }, + ); + + } else { + warn "No editor configured. Can not edit metafiles!\n"; + } + } +} + +my $fh; +LOGFILE: { + if( my $file = $opts->{logfile} ) { + open $fh, ">$file" or ( + warn loc("Could not open '%1' for writing: %2", $file,$!), + last LOGFILE + ); + + warn "Logging to '$file'\n"; + + *STDERR = $fh; + *STDOUT = $fh; + } +} + +### reload indices if so desired +$cb->reload_indices() if $opts->{'flushcache'}; + +{ my @ban = exists $opts->{'ban'} + ? map { qr/$_/ } @{ $opts->{'ban'} } + : (); + + + if( exists $opts->{'banlist'} ) { + push @ban, map { parse_file( $_, 1 ) } @{ $opts->{'banlist'} }; + } + + push @ban, map { s/\s+//; $_ } + map { [split /\s*#\s*/]->[0] } + grep { /#/ } + map { split /\n/ } _default_ban_list() + if $opts->{'default-banlist'}; + + ### use our prereq install callback + $conf->set_conf( prereqs => PREREQ_ASK ); + + ### register install callback ### + $cb->_register_callback( + name => 'install_prerequisite', + code => \&__ask_about_install, + ); + + + ### check for ban patterns when handling prereqs + sub __ask_about_install { + + my $mod = shift or return; + my $prereq = shift or return; + + + ### die with an error object, so we can verify that + ### the die came from this location, and that it's an + ### 'acceptable' death + my $pat = ban_me( $prereq ); + die bless sub { loc("Module '%1' requires '%2' to be installed " . + "but found in your ban list (%3) -- skipping", + $mod->module, $prereq->module, $pat ) + }, PREREQ_SKIP_CLASS if $pat; + return 1; + } + + ### should we skip this module? + sub ban_me { + my $mod = shift; + + for my $pat ( @ban ) { + return $pat if $mod->module =~ /$pat/i; + } + return; + } +} + +### patterns to strip from prereq lists +{ my @ignore = exists $opts->{'ignore'} + ? map { qr/$_/ } @{ $opts->{'ignore'} } + : (); + + if( exists $opts->{'ignorelist'} ) { + push @ignore, map { parse_file( $_, 1 ) } @{ $opts->{'ignorelist'} }; + } + + push @ignore, map { s/\s+//; $_ } + map { [split /\s*#\s*/]->[0] } + grep { /#/ } + map { split /\n/ } _default_ignore_list() + if $opts->{'default-ignorelist'}; + + + ### register install callback ### + $cb->_register_callback( + name => 'filter_prereqs', + code => \&__filter_prereqs, + ); + + sub __filter_prereqs { + my $cb = shift; + my $href = shift; + + for my $name ( keys %$href ) { + my $obj = $cb->parse_module( module => $name ) or ( + warn "Cannot make a module object out of ". + "'$name' -- skipping\n", + next ); + + if( my $pat = ignore_me( $obj ) ) { + warn loc("'%1' found in your ignore list (%2) ". + "-- filtering it out\n", $name, $pat); + + delete $href->{ $name }; + } + } + + return $href; + } + + ### should we skip this module? + sub ignore_me { + my $mod = shift; + + for my $pat ( @ignore ) { + return $pat if $mod->module =~ /$pat/i; + return $pat if $mod->package_name =~ /$pat/i; + } + return; + } +} + + +my %done; +for my $name (@modules) { + + my $obj; + + ### is it a tarball? then we get it locally and transform it + ### and its dependencies into .debs + if( $tarball ) { + ### make sure we use an absolute path, so chdirs() dont + ### mess things up + $name = File::Spec->rel2abs( $name ); + + ### ENOTARBALL? + unless( -e $name ) { + warn loc("Archive '$name' does not exist"); + next; + } + + $obj = CPANPLUS::Module::Fake->new( + module => basename($name), + path => dirname($name), + package => basename($name), + ); + + ### if it's a traditional CPAN package, we can tidy + ### up the module name some + $obj->module( $obj->package_name ) if $obj->package_name; + + ### get the version from the package name + $obj->version( $obj->package_version || 0 ); + + ### set the location of the tarball + $obj->status->fetch($name); + + ### plain old cpan module? + } else { + + ### find the corresponding module object ### + $obj = $cb->parse_module( module => $name ) or ( + warn "Cannot make a module object out of ". + "'$name' -- skipping\n", + next ); + } + + ### you banned it? + if( my $pat = ban_me( $obj ) ) { + warn loc("'%1' found in your ban list (%2) -- skipping\n", + $obj->module, $pat ); + next; + } + + ### or just ignored it? + if( my $pat = ignore_me( $obj ) ) { + warn loc("'%1' found in your ignore list (%2) -- skipping\n", + $obj->module, $pat ); + next; + } + + + my $target = $opts->{'install'} ? 'install' : 'create'; + my $dist = eval { + local $SIG{ALRM} = sub { die bless {}, ALARM_CLASS } + if $timeout; + + alarm $timeout || 0; + + my $dist_opts = $opts->{'dist-opts'} || {}; + + my $rv = $obj->install( + prereq_target => $target, + target => $target, + keep_source => $keep, + prereq_build => $prereqbuild, + + ### any passed arbitrary options + %$dist_opts, + ); + + alarm 0; + + $rv; + }; + + ### set here again, in case the install dies + alarm 0; + + ### install failed due to a 'die' in our prereq skipper? + if( $@ and ref $@ and $@->isa( PREREQ_SKIP_CLASS ) ) { + warn loc("Dist creation of '%1' skipped: '%2'", + $obj->module, $@->() ); + next; + + } elsif ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) { + warn loc("\nDist creation of '%1' skipped, build time exceeded: ". + "%2 seconds\n", $obj->module, $timeout ); + next; + + ### died for some other reason? just report and skip + } elsif ( $@ ) { + warn loc("Dist creation of '%1' failed: '%2'", + $obj->module, $@ ); + next; + } + + ### we didn't get a dist object back? + unless ($dist and $obj->status->dist) { + warn loc("Unable to create '%1' dist of '%2'", $format, $obj->module); + next + } + + print "Created '$format' distribution for ", $obj->module, + " to:\n\t", $obj->status->dist->status->dist, "\n"; +} + + +sub parse_file { + my $file = shift or return; + my $qr = shift() ? 1 : 0; + + my $fh = OPEN_FILE->( $file ) or return; + + my @rv; + while( <$fh> ) { + chomp; + next if /^#/; # skip comments + next unless /\S/; # skip empty lines + s/^(\S+).*/$1/; # skip extra info + push @rv, $qr ? qr/$_/ : $_; # add pattern to the list + } + + return @rv; +} + +=head1 NAME + +cpan2dist - The CPANPLUS distribution creator + +=head1 DESCRIPTION + +This script will create distributions of C<CPAN> modules of the format +you specify, including its prerequisites. These packages can then be +installed using the corresponding package manager for the format. + +Note, you can also do this interactively from the default shell, +C<CPANPLUS::Shell::Default>. See the C<CPANPLUS::Dist> documentation, +as well as the documentation of your format of choice for any format +specific documentation. + +=head1 USAGE + +=cut + +sub usage { + my $me = basename($0); + my $formats = join "\n", map { "\t\t$_" } sort keys %formats; + + my $usage = << '=cut'; +=pod + + Usage: cpan2dist [--format FMT] [OPTS] Mod::Name [Mod::Name, ...] + cpan2dist [--format FMT] [OPTS] --modulelist /tmp/mods.list + cpan2dist [--format FMT] [OPTS] --archive /tmp/dist [/tmp/dist2] + + Will create a distribution of type FMT of the modules + specified on the command line, and all their prerequisites. + + Can also create a distribution of type FMT from a local + archive and all of its prerequisites. + +=cut + + $usage .= qq[ + Possible formats are: +$formats + + You can install more formats from CPAN! + \n]; + + $usage .= << '=cut'; +=pod + +Options: + + ### take no argument: + --help Show this help message + --install Install this package (and any prerequisites you built) + after building it. + --skiptest Skip tests. Can be negated using --noskiptest + --force Force operation. Can be negated using --noforce + --verbose Be verbose. Can be negated using --noverbose + --keepsource Keep sources after building distribution. Can be + negated by --nokeepsource. May not be supported + by all formats + --makefile Prefer Makefile.PL over Build.PL. Can be negated + using --nomakefile. Defaults to your config setting + --buildprereq Build packages of any prerequisites, even if they are + already uptodate on the local system. Can be negated + using --nobuildprereq. Defaults to false. + --archive Indicate that all modules listed are actually archives + --flushcache Update CPANPLUS' cache before commencing any operation + --defaults Instruct ExtUtils::MakeMaker and Module::Build to use + default answers during 'perl Makefile.PL' or 'perl + Build.PL' calls where possible + --edit-metafile Edit the distributions metafile(s) before the distribution + is built. Requires a configured editor. + + ### take argument: + --format Installer format to use (defaults to config setting) + --ban Patterns of module names to skip during installation, + case-insensitive (affects prerequisites too) + May be given multiple times + --banlist File containing patterns that could be given to --ban + Are appended to the ban list built up by --ban + May be given multiple times. + --ignore Patterns of modules to exclude from prereq list. Useful + for when a prereq listed by a CPAN module is resolved + in another way than from its corresponding CPAN package + (Match is done on both module name, and package name of + the package the module is in, case-insensitive) + --ignorelist File containing patterns that may be given to --ignore. + Are appended to the ban list built up by --ignore. + May be given multiple times. + --modulelist File containing a list of modules that should be built. + Are appended to the list of command line modules. + May be given multiple times. + --logfile File to log all output to. By default, all output goes + to the console. + --timeout The allowed time for buliding a distribution before + aborting. This is useful to terminate any build that + hang or happen to be interactive despite being told not + to be. Defaults to 300 seconds. To turn off, you can + set it to 0. + --set-config Change any options as specified in your config for this + invocation only. See CPANPLUS::Config for a list of + supported options. + --set-program Change any programs as specified in your config for this + invocation only. See CPANPLUS::Config for a list of + supported programs. + --dist-opts Arbitrary options passed along to the chosen installer + format's prepare()/create() routine. Please see the + documentation of the installer of your choice for + options it accepts. + + ### builtin lists + --default-banlist Use our builtin banlist. Works just like --ban + and --banlist, but with pre-set lists. See the + "Builtin Lists" section for details. + --default-ignorelist Use our builtin ignorelist. Works just like + --ignore and --ignorelist but with pre-set lists. + See the "Builtin Lists" section for details. + +Examples: + + ### build a debian package of DBI and its prerequisites, + ### don't bother running tests + cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --skiptest DBI + + ### build a debian package of DBI and its prerequisites and install them + cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --install DBI + + ### Build a package, whose format is determined by your config, of + ### the local tarball, reloading cpanplus' indices first and using + ### the tarballs Makefile.PL if it has one. + cpan2dist --makefile --flushcache --archive /path/to/Cwd-1.0.tgz + + ### build a package from Net::FTP, but dont build any packages or + ### dependencies whose name match 'Foo', 'Bar' or any of the + ### patterns mentioned in /tmp/ban + cpan2dist --ban Foo --ban Bar --banlist /tmp/ban Net::FTP + + ### build a package from Net::FTP, but ignore its listed dependency + ### on IO::Socket, as it's shipped per default with the OS we're on + cpan2dist --ignore IO::Socket Net::FTP + + ### building all modules listed, plus their prerequisites + cpan2dist --ignorelist /tmp/modules.ignore --banlist /tmp/modules.ban + --modulelist /tmp/modules.list --buildprereq --flushcache + --makefile --defaults + + ### pass arbitrary options to the format's prepare()/create() routine + cpan2dist --dist-opts deb_version=3 --dist-opts prefix=corp + +=cut + + $usage .= qq[ +Builtin Lists: + + Ignore list:] . _default_ignore_list() . qq[ + Ban list:] . _default_ban_list(); + + ### strip the pod directives + $usage =~ s/=pod\n//g; + + return $usage; +} + +=pod + +=head1 Built-In Filter Lists + +Some modules you'd rather not package. Some because they +are part of core-perl and you dont want a new package. +Some because they won't build on your system. Some because +your package manager of choice already packages them for you. + +There may be a myriad of reasons. You can use the C<--ignore> +and C<--ban> options for this, but we provide some built-in +lists that catch common cases. You can use these built-in lists +if you like, or supply your own if need be. + +=head2 Built-In Ignore List + +=pod + +You can use this list of regexes to ignore modules matching +to be listed as prerequisites of a package. Particulaly useful +if they are bundled with core-perl anyway and they have known +issues building. + +Toggle it by supplying the C<--default-ignorelist> option. + +=cut + +sub _default_ignore_list { + + my $list = << '=cut'; +=pod + + ^IO$ # Provided with core anyway + ^Cwd$ # Provided with core anyway + ^File::Spec # Provided with core anyway + ^Config$ # Perl's own config, not shipped separately + ^ExtUtils::MakeMaker$ # Shipped with perl, recent versions + # have bug 14721 (see rt.cpan.org) + ^ExtUtils::Install$ # Part of of EU::MM, same reason + +=cut + + return $list; +} + +=head2 Built-In Ban list + +You can use this list of regexes to disable building of these +modules altogether. + +Toggle it by supplying the C<--default-banlist> option. + +=cut + +sub _default_ban_list { + + my $list = << '=cut'; +=pod + + ^GD$ # Needs c libaries + ^Berk.*DB # DB packages require specific options & linking + ^DBD:: # DBD drives require database files/headers + ^XML:: # XML modules usually require expat libraries + Apache # These usually require apache libraries + SSL # These usually require SSL certificates & libs + Image::Magick # Needs ImageMagick C libraries + Mail::ClamAV # Needs ClamAV C Libraries + ^Verilog # Needs Verilog C Libraries + ^Authen::PAM$ # Needs PAM C libraries & Headers + +=cut + + return $list; +} + +__END__ + +=head1 SEE ALSO + +L<CPANPLUS::Dist>, L<CPANPLUS::Module>, L<CPANPLUS::Shell::Default>, +C<cpanp> + +=head1 BUG REPORTS + +Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>. + +=head1 AUTHOR + +This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. + +=head1 COPYRIGHT + +The CPAN++ interface (of which this module is a part of) is copyright (c) +2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved. + +This library is free software; you may redistribute and/or modify it +under the same terms as Perl itself. + +=cut + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl/bin/cpan2dist.bat b/Master/tlpkg/tlperl/bin/cpan2dist.bat new file mode 100755 index 00000000000..aa670d75d28 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpan2dist.bat @@ -0,0 +1,687 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+use strict;
+use CPANPLUS::Backend;
+use CPANPLUS::Dist;
+use CPANPLUS::Internals::Constants;
+use Data::Dumper;
+use Getopt::Long;
+use File::Spec;
+use File::Temp qw|tempfile|;
+use File::Basename;
+use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
+
+local $Data::Dumper::Indent = 1;
+
+use constant PREREQ_SKIP_CLASS => 'CPANPLUS::To::Dist::PREREQ_SKIP';
+use constant ALARM_CLASS => 'CPANPLUS::To::Dist::ALARM';
+
+### print when you can
+$|++;
+
+my $cb = CPANPLUS::Backend->new
+ or die loc("Could not create new CPANPLUS::Backend object");
+my $conf = $cb->configure_object;
+
+my %formats = map { $_ => $_ } CPANPLUS::Dist->dist_types;
+
+my $opts = {};
+GetOptions( $opts,
+ 'format=s', 'archive',
+ 'verbose!', 'force!',
+ 'skiptest!', 'keepsource!',
+ 'makefile!', 'buildprereq!',
+ 'help', 'flushcache',
+ 'ban=s@', 'banlist=s@',
+ 'ignore=s@', 'ignorelist=s@',
+ 'defaults', 'modulelist=s@',
+ 'logfile=s', 'timeout=s',
+ 'dist-opts=s%', 'set-config=s%',
+ 'default-banlist!', 'set-program=s%',
+ 'default-ignorelist!', 'edit-metafile!',
+ 'install!'
+ );
+
+die usage() if exists $opts->{'help'};
+
+### parse options
+my $tarball = $opts->{'archive'} || 0;
+my $keep = $opts->{'keepsource'} ? 1 : 0;
+my $prereqbuild = exists $opts->{'buildprereq'}
+ ? $opts->{'buildprereq'}
+ : 0;
+my $timeout = exists $opts->{'timeout'}
+ ? $opts->{'timeout'}
+ : 300;
+
+### use default answers?
+$ENV{'PERL_MM_USE_DEFAULT'} = $opts->{'defaults'} ? 1 : 0;
+
+my $format;
+### if provided, we go with the command line option, fall back to conf setting
+{ $format = $opts->{'format'} || $conf->get_conf('dist_type');
+ $conf->set_conf( dist_type => $format );
+
+ ### is this a valid format??
+ die loc("Invalid format: " . ($format || "[NONE]") ) . usage()
+ unless $formats{$format};
+
+ ### any options to fix config entries
+ { my $set_conf = $opts->{'set-config'} || {};
+ while( my($key,$val) = each %$set_conf ) {
+ $conf->set_conf( $key => $val );
+ }
+ }
+
+ ### any options to fix program entries
+ { my $set_prog = $opts->{'set-program'} || {};
+ while( my($key,$val) = each %$set_prog ) {
+ $conf->set_program( $key => $val );
+ }
+ }
+
+ ### any other options passed
+ { my %map = ( verbose => 'verbose',
+ force => 'force',
+ skiptest => 'skiptest',
+ makefile => 'prefer_makefile'
+ );
+
+ ### set config options from arguments
+ while (my($key,$val) = each %map) {
+ my $bool = exists $opts->{$key}
+ ? $opts->{$key}
+ : $conf->get_conf($val);
+ $conf->set_conf( $val => $bool );
+ }
+ }
+}
+
+my @modules = @ARGV;
+if( exists $opts->{'modulelist'} ) {
+ push @modules, map { parse_file( $_ ) } @{ $opts->{'modulelist'} };
+}
+
+die usage() unless @modules;
+
+### set up munge callback if requested
+{ if( $opts->{'edit-metafile'} ) {
+ my $editor = $conf->get_program('editor');
+
+ if( $editor ) {
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'munge_dist_metafile',
+ code => sub {
+ my $self = shift;
+ my $text = shift or return;
+
+ my($fh,$file) = tempfile( UNLINK => 1 );
+
+ unless( print $fh $text ) {
+ warn "Could not print metafile information: $!";
+ return;
+ }
+
+ close $fh;
+
+ system( $editor => $file );
+
+ my $cont = $cb->_get_file_contents( file => $file );
+
+ return $cont;
+ },
+ );
+
+ } else {
+ warn "No editor configured. Can not edit metafiles!\n";
+ }
+ }
+}
+
+my $fh;
+LOGFILE: {
+ if( my $file = $opts->{logfile} ) {
+ open $fh, ">$file" or (
+ warn loc("Could not open '%1' for writing: %2", $file,$!),
+ last LOGFILE
+ );
+
+ warn "Logging to '$file'\n";
+
+ *STDERR = $fh;
+ *STDOUT = $fh;
+ }
+}
+
+### reload indices if so desired
+$cb->reload_indices() if $opts->{'flushcache'};
+
+{ my @ban = exists $opts->{'ban'}
+ ? map { qr/$_/ } @{ $opts->{'ban'} }
+ : ();
+
+
+ if( exists $opts->{'banlist'} ) {
+ push @ban, map { parse_file( $_, 1 ) } @{ $opts->{'banlist'} };
+ }
+
+ push @ban, map { s/\s+//; $_ }
+ map { [split /\s*#\s*/]->[0] }
+ grep { /#/ }
+ map { split /\n/ } _default_ban_list()
+ if $opts->{'default-banlist'};
+
+ ### use our prereq install callback
+ $conf->set_conf( prereqs => PREREQ_ASK );
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'install_prerequisite',
+ code => \&__ask_about_install,
+ );
+
+
+ ### check for ban patterns when handling prereqs
+ sub __ask_about_install {
+
+ my $mod = shift or return;
+ my $prereq = shift or return;
+
+
+ ### die with an error object, so we can verify that
+ ### the die came from this location, and that it's an
+ ### 'acceptable' death
+ my $pat = ban_me( $prereq );
+ die bless sub { loc("Module '%1' requires '%2' to be installed " .
+ "but found in your ban list (%3) -- skipping",
+ $mod->module, $prereq->module, $pat )
+ }, PREREQ_SKIP_CLASS if $pat;
+ return 1;
+ }
+
+ ### should we skip this module?
+ sub ban_me {
+ my $mod = shift;
+
+ for my $pat ( @ban ) {
+ return $pat if $mod->module =~ /$pat/i;
+ }
+ return;
+ }
+}
+
+### patterns to strip from prereq lists
+{ my @ignore = exists $opts->{'ignore'}
+ ? map { qr/$_/ } @{ $opts->{'ignore'} }
+ : ();
+
+ if( exists $opts->{'ignorelist'} ) {
+ push @ignore, map { parse_file( $_, 1 ) } @{ $opts->{'ignorelist'} };
+ }
+
+ push @ignore, map { s/\s+//; $_ }
+ map { [split /\s*#\s*/]->[0] }
+ grep { /#/ }
+ map { split /\n/ } _default_ignore_list()
+ if $opts->{'default-ignorelist'};
+
+
+ ### register install callback ###
+ $cb->_register_callback(
+ name => 'filter_prereqs',
+ code => \&__filter_prereqs,
+ );
+
+ sub __filter_prereqs {
+ my $cb = shift;
+ my $href = shift;
+
+ for my $name ( keys %$href ) {
+ my $obj = $cb->parse_module( module => $name ) or (
+ warn "Cannot make a module object out of ".
+ "'$name' -- skipping\n",
+ next );
+
+ if( my $pat = ignore_me( $obj ) ) {
+ warn loc("'%1' found in your ignore list (%2) ".
+ "-- filtering it out\n", $name, $pat);
+
+ delete $href->{ $name };
+ }
+ }
+
+ return $href;
+ }
+
+ ### should we skip this module?
+ sub ignore_me {
+ my $mod = shift;
+
+ for my $pat ( @ignore ) {
+ return $pat if $mod->module =~ /$pat/i;
+ return $pat if $mod->package_name =~ /$pat/i;
+ }
+ return;
+ }
+}
+
+
+my %done;
+for my $name (@modules) {
+
+ my $obj;
+
+ ### is it a tarball? then we get it locally and transform it
+ ### and its dependencies into .debs
+ if( $tarball ) {
+ ### make sure we use an absolute path, so chdirs() dont
+ ### mess things up
+ $name = File::Spec->rel2abs( $name );
+
+ ### ENOTARBALL?
+ unless( -e $name ) {
+ warn loc("Archive '$name' does not exist");
+ next;
+ }
+
+ $obj = CPANPLUS::Module::Fake->new(
+ module => basename($name),
+ path => dirname($name),
+ package => basename($name),
+ );
+
+ ### if it's a traditional CPAN package, we can tidy
+ ### up the module name some
+ $obj->module( $obj->package_name ) if $obj->package_name;
+
+ ### get the version from the package name
+ $obj->version( $obj->package_version || 0 );
+
+ ### set the location of the tarball
+ $obj->status->fetch($name);
+
+ ### plain old cpan module?
+ } else {
+
+ ### find the corresponding module object ###
+ $obj = $cb->parse_module( module => $name ) or (
+ warn "Cannot make a module object out of ".
+ "'$name' -- skipping\n",
+ next );
+ }
+
+ ### you banned it?
+ if( my $pat = ban_me( $obj ) ) {
+ warn loc("'%1' found in your ban list (%2) -- skipping\n",
+ $obj->module, $pat );
+ next;
+ }
+
+ ### or just ignored it?
+ if( my $pat = ignore_me( $obj ) ) {
+ warn loc("'%1' found in your ignore list (%2) -- skipping\n",
+ $obj->module, $pat );
+ next;
+ }
+
+
+ my $target = $opts->{'install'} ? 'install' : 'create';
+ my $dist = eval {
+ local $SIG{ALRM} = sub { die bless {}, ALARM_CLASS }
+ if $timeout;
+
+ alarm $timeout || 0;
+
+ my $dist_opts = $opts->{'dist-opts'} || {};
+
+ my $rv = $obj->install(
+ prereq_target => $target,
+ target => $target,
+ keep_source => $keep,
+ prereq_build => $prereqbuild,
+
+ ### any passed arbitrary options
+ %$dist_opts,
+ );
+
+ alarm 0;
+
+ $rv;
+ };
+
+ ### set here again, in case the install dies
+ alarm 0;
+
+ ### install failed due to a 'die' in our prereq skipper?
+ if( $@ and ref $@ and $@->isa( PREREQ_SKIP_CLASS ) ) {
+ warn loc("Dist creation of '%1' skipped: '%2'",
+ $obj->module, $@->() );
+ next;
+
+ } elsif ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
+ warn loc("\nDist creation of '%1' skipped, build time exceeded: ".
+ "%2 seconds\n", $obj->module, $timeout );
+ next;
+
+ ### died for some other reason? just report and skip
+ } elsif ( $@ ) {
+ warn loc("Dist creation of '%1' failed: '%2'",
+ $obj->module, $@ );
+ next;
+ }
+
+ ### we didn't get a dist object back?
+ unless ($dist and $obj->status->dist) {
+ warn loc("Unable to create '%1' dist of '%2'", $format, $obj->module);
+ next
+ }
+
+ print "Created '$format' distribution for ", $obj->module,
+ " to:\n\t", $obj->status->dist->status->dist, "\n";
+}
+
+
+sub parse_file {
+ my $file = shift or return;
+ my $qr = shift() ? 1 : 0;
+
+ my $fh = OPEN_FILE->( $file ) or return;
+
+ my @rv;
+ while( <$fh> ) {
+ chomp;
+ next if /^#/; # skip comments
+ next unless /\S/; # skip empty lines
+ s/^(\S+).*/$1/; # skip extra info
+ push @rv, $qr ? qr/$_/ : $_; # add pattern to the list
+ }
+
+ return @rv;
+}
+
+=head1 NAME
+
+cpan2dist - The CPANPLUS distribution creator
+
+=head1 DESCRIPTION
+
+This script will create distributions of C<CPAN> modules of the format
+you specify, including its prerequisites. These packages can then be
+installed using the corresponding package manager for the format.
+
+Note, you can also do this interactively from the default shell,
+C<CPANPLUS::Shell::Default>. See the C<CPANPLUS::Dist> documentation,
+as well as the documentation of your format of choice for any format
+specific documentation.
+
+=head1 USAGE
+
+=cut
+
+sub usage {
+ my $me = basename($0);
+ my $formats = join "\n", map { "\t\t$_" } sort keys %formats;
+
+ my $usage = << '=cut';
+=pod
+
+ Usage: cpan2dist [--format FMT] [OPTS] Mod::Name [Mod::Name, ...]
+ cpan2dist [--format FMT] [OPTS] --modulelist /tmp/mods.list
+ cpan2dist [--format FMT] [OPTS] --archive /tmp/dist [/tmp/dist2]
+
+ Will create a distribution of type FMT of the modules
+ specified on the command line, and all their prerequisites.
+
+ Can also create a distribution of type FMT from a local
+ archive and all of its prerequisites.
+
+=cut
+
+ $usage .= qq[
+ Possible formats are:
+$formats
+
+ You can install more formats from CPAN!
+ \n];
+
+ $usage .= << '=cut';
+=pod
+
+Options:
+
+ ### take no argument:
+ --help Show this help message
+ --install Install this package (and any prerequisites you built)
+ after building it.
+ --skiptest Skip tests. Can be negated using --noskiptest
+ --force Force operation. Can be negated using --noforce
+ --verbose Be verbose. Can be negated using --noverbose
+ --keepsource Keep sources after building distribution. Can be
+ negated by --nokeepsource. May not be supported
+ by all formats
+ --makefile Prefer Makefile.PL over Build.PL. Can be negated
+ using --nomakefile. Defaults to your config setting
+ --buildprereq Build packages of any prerequisites, even if they are
+ already uptodate on the local system. Can be negated
+ using --nobuildprereq. Defaults to false.
+ --archive Indicate that all modules listed are actually archives
+ --flushcache Update CPANPLUS' cache before commencing any operation
+ --defaults Instruct ExtUtils::MakeMaker and Module::Build to use
+ default answers during 'perl Makefile.PL' or 'perl
+ Build.PL' calls where possible
+ --edit-metafile Edit the distributions metafile(s) before the distribution
+ is built. Requires a configured editor.
+
+ ### take argument:
+ --format Installer format to use (defaults to config setting)
+ --ban Patterns of module names to skip during installation,
+ case-insensitive (affects prerequisites too)
+ May be given multiple times
+ --banlist File containing patterns that could be given to --ban
+ Are appended to the ban list built up by --ban
+ May be given multiple times.
+ --ignore Patterns of modules to exclude from prereq list. Useful
+ for when a prereq listed by a CPAN module is resolved
+ in another way than from its corresponding CPAN package
+ (Match is done on both module name, and package name of
+ the package the module is in, case-insensitive)
+ --ignorelist File containing patterns that may be given to --ignore.
+ Are appended to the ban list built up by --ignore.
+ May be given multiple times.
+ --modulelist File containing a list of modules that should be built.
+ Are appended to the list of command line modules.
+ May be given multiple times.
+ --logfile File to log all output to. By default, all output goes
+ to the console.
+ --timeout The allowed time for buliding a distribution before
+ aborting. This is useful to terminate any build that
+ hang or happen to be interactive despite being told not
+ to be. Defaults to 300 seconds. To turn off, you can
+ set it to 0.
+ --set-config Change any options as specified in your config for this
+ invocation only. See CPANPLUS::Config for a list of
+ supported options.
+ --set-program Change any programs as specified in your config for this
+ invocation only. See CPANPLUS::Config for a list of
+ supported programs.
+ --dist-opts Arbitrary options passed along to the chosen installer
+ format's prepare()/create() routine. Please see the
+ documentation of the installer of your choice for
+ options it accepts.
+
+ ### builtin lists
+ --default-banlist Use our builtin banlist. Works just like --ban
+ and --banlist, but with pre-set lists. See the
+ "Builtin Lists" section for details.
+ --default-ignorelist Use our builtin ignorelist. Works just like
+ --ignore and --ignorelist but with pre-set lists.
+ See the "Builtin Lists" section for details.
+
+Examples:
+
+ ### build a debian package of DBI and its prerequisites,
+ ### don't bother running tests
+ cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --skiptest DBI
+
+ ### build a debian package of DBI and its prerequisites and install them
+ cpan2dist --format CPANPLUS::Dist::Deb --buildprereq --install DBI
+
+ ### Build a package, whose format is determined by your config, of
+ ### the local tarball, reloading cpanplus' indices first and using
+ ### the tarballs Makefile.PL if it has one.
+ cpan2dist --makefile --flushcache --archive /path/to/Cwd-1.0.tgz
+
+ ### build a package from Net::FTP, but dont build any packages or
+ ### dependencies whose name match 'Foo', 'Bar' or any of the
+ ### patterns mentioned in /tmp/ban
+ cpan2dist --ban Foo --ban Bar --banlist /tmp/ban Net::FTP
+
+ ### build a package from Net::FTP, but ignore its listed dependency
+ ### on IO::Socket, as it's shipped per default with the OS we're on
+ cpan2dist --ignore IO::Socket Net::FTP
+
+ ### building all modules listed, plus their prerequisites
+ cpan2dist --ignorelist /tmp/modules.ignore --banlist /tmp/modules.ban
+ --modulelist /tmp/modules.list --buildprereq --flushcache
+ --makefile --defaults
+
+ ### pass arbitrary options to the format's prepare()/create() routine
+ cpan2dist --dist-opts deb_version=3 --dist-opts prefix=corp
+
+=cut
+
+ $usage .= qq[
+Builtin Lists:
+
+ Ignore list:] . _default_ignore_list() . qq[
+ Ban list:] . _default_ban_list();
+
+ ### strip the pod directives
+ $usage =~ s/=pod\n//g;
+
+ return $usage;
+}
+
+=pod
+
+=head1 Built-In Filter Lists
+
+Some modules you'd rather not package. Some because they
+are part of core-perl and you dont want a new package.
+Some because they won't build on your system. Some because
+your package manager of choice already packages them for you.
+
+There may be a myriad of reasons. You can use the C<--ignore>
+and C<--ban> options for this, but we provide some built-in
+lists that catch common cases. You can use these built-in lists
+if you like, or supply your own if need be.
+
+=head2 Built-In Ignore List
+
+=pod
+
+You can use this list of regexes to ignore modules matching
+to be listed as prerequisites of a package. Particulaly useful
+if they are bundled with core-perl anyway and they have known
+issues building.
+
+Toggle it by supplying the C<--default-ignorelist> option.
+
+=cut
+
+sub _default_ignore_list {
+
+ my $list = << '=cut';
+=pod
+
+ ^IO$ # Provided with core anyway
+ ^Cwd$ # Provided with core anyway
+ ^File::Spec # Provided with core anyway
+ ^Config$ # Perl's own config, not shipped separately
+ ^ExtUtils::MakeMaker$ # Shipped with perl, recent versions
+ # have bug 14721 (see rt.cpan.org)
+ ^ExtUtils::Install$ # Part of of EU::MM, same reason
+
+=cut
+
+ return $list;
+}
+
+=head2 Built-In Ban list
+
+You can use this list of regexes to disable building of these
+modules altogether.
+
+Toggle it by supplying the C<--default-banlist> option.
+
+=cut
+
+sub _default_ban_list {
+
+ my $list = << '=cut';
+=pod
+
+ ^GD$ # Needs c libaries
+ ^Berk.*DB # DB packages require specific options & linking
+ ^DBD:: # DBD drives require database files/headers
+ ^XML:: # XML modules usually require expat libraries
+ Apache # These usually require apache libraries
+ SSL # These usually require SSL certificates & libs
+ Image::Magick # Needs ImageMagick C libraries
+ Mail::ClamAV # Needs ClamAV C Libraries
+ ^Verilog # Needs Verilog C Libraries
+ ^Authen::PAM$ # Needs PAM C libraries & Headers
+
+=cut
+
+ return $list;
+}
+
+__END__
+
+=head1 SEE ALSO
+
+L<CPANPLUS::Dist>, L<CPANPLUS::Module>, L<CPANPLUS::Shell::Default>,
+C<cpanp>
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-cpanplus@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+The CPAN++ interface (of which this module is a part of) is copyright (c)
+2001 - 2007, Jos Boumans E<lt>kane@cpan.orgE<gt>. All rights reserved.
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/cpandb b/Master/tlpkg/tlperl/bin/cpandb new file mode 100755 index 00000000000..46c07b939a1 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpandb @@ -0,0 +1,272 @@ +#!C:\strawberry\perl\bin\perl.exe
+use strict;
+use warnings;
+use CPAN::SQLite;
+use CPAN::SQLite::Util qw(%chaps);
+use Getopt::Long;
+my ($CPAN, $setup, $help, $reindex, $index, $query,
+ $db_name, $db_dir, $module, $dist, $cpanid, $update);
+
+my $rc = GetOptions('CPAN=s' => \$CPAN,
+ 'db_name=s' => \$db_name,
+ 'db_dir=s' => \$db_dir,
+ 'setup' => \$setup,
+ 'update' => \$update,
+ 'help' => \$help,
+ 'module=s' => \$module,
+ 'dist=s' => \$dist,
+ 'cpanid=s' => \$cpanid,
+ 'reindex=s' => \$reindex);
+
+$query = ($module or $dist or $cpanid);
+$index = ($update or $reindex or $setup);
+
+if ($help or not $rc or not ($index or $query)) {
+ print <<"END";
+
+Setup, maintain, and search the CPAN::SQLite database
+Usage:
+ $^X $0 --setup
+ $^X $0 --update
+ $^X $0 --reindex dist_name
+
+ $^X $0 --module Mod::Name
+ $^X $0 --dist Distname
+ $^X $0 --cpanid CPANID
+
+ $^X $0 --help
+END
+ exit(1);
+}
+
+if (defined $setup and defined $reindex) {
+ die "Must reindex on an exisiting database";
+}
+
+if ($index) {
+ my $obj = CPAN::SQLite->new(CPAN => $CPAN,
+ setup => $setup,
+ db_name => $db_name,
+ db_dir => $db_dir,
+ reindex => $reindex,
+ );
+ $obj->index();
+}
+else {
+
+ my $max_results = 100;
+ my $obj = CPAN::SQLite->new(CPAN => $CPAN,
+ db_name => $db_name,
+ db_dir => $db_dir,
+ max_results => $max_results);
+ my $results;
+
+ RESULTS : {
+ $module and do {
+ $obj->query(mode => 'module', name => $module);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo module by name of "$module" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ my $abs = $results->{mod_abs} || '';
+ my $dslip = '';
+ if (my $dslip_info = $results->{dslip_info}) {
+ foreach my $entry (@$dslip_info) {
+ $dslip .= " $entry->{desc}: $entry->{what}\n";
+ }
+ }
+ my $chapter_desc = $results->{chapter_desc} || '';
+ print << "EOI";
+
+Module: $results->{mod_name}
+Abstract: $abs
+Version: $results->{mod_vers}
+Chapter: $chapter_desc
+Distribution: $results->{dist_name}
+CPAN author: $results->{cpanid}
+CPAN file: $results->{dist_file}
+Download: $results->{download}
+dslip info:
+$dslip
+EOI
+ }
+ last RESULTS;
+ };
+ $dist and do {
+ $obj->query(mode => 'dist', name => $dist);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo distribution by name of "$dist" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ my $abs = $results->{dist_abs} || '';
+ my $dslip = '';
+ if (my $dslip_info = $results->{dslip_info}) {
+ foreach my $entry (@$dslip_info) {
+ $dslip .= " $entry->{desc}: $entry->{what}\n";
+ }
+ }
+ print << "EOI";
+
+Distribution: $results->{dist_name}
+Abstract: $abs
+Version: $results->{dist_vers}
+CPAN author: $results->{cpanid}
+CPAN file: $results->{dist_file}
+Download: $results->{download}
+dslip info:
+$dslip
+EOI
+ }
+ my $mods = $results->{mods};
+ if ($mods and (ref($mods) eq 'ARRAY')) {
+ print qq{\nProvided modules:\n};
+ foreach my $item(@$mods) {
+ my $abs = $item->{mod_abs} || '';
+ print qq{ $item->{mod_name}: $abs\n};
+ }
+ }
+ last RESULTS;
+ };
+ $cpanid and do {
+ $obj->query(mode => 'author', name => $cpanid);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo cpanid by name of "$cpanid" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ print << "EOI";
+
+CPANID: $results->{cpanid}
+Full Name: $results->{fullname}
+email: $results->{email}
+EOI
+ }
+ my $dists = $results->{dists};
+ if ($dists and (ref($dists) eq 'ARRAY')) {
+ print qq{\nAvailable distributions:\n};
+ foreach my $item(@$dists) {
+ my $abs = $item->{dist_abs} || '';
+ print qq{ $item->{dist_file}: $abs\n};
+ }
+ }
+ last RESULTS;
+ };
+ }
+}
+
+__END__
+
+=head1 NAME
+
+cpandb - interface to C<CPAN::SQLite>
+
+=head1 DESCRIPTION
+
+This script is an interface to the routines of
+L<CPAN::SQLite> for setting up, maintaining and
+searching a C<DBD::SQLite> database
+of CPAN. Available options can be grouped into
+three categories.
+
+=head2 Common options
+
+These are options which are common to both setting up
+and maintaining the database or performing queries on it.
+These are
+
+=over 3
+
+=item * C<--CPAN '/path/to/CPAN'>
+
+This specifies the path to where the index files are
+to be stored. This could be a local CPAN mirror,
+defined here by the presence of a F<MIRRORED.BY> file beneath
+this directory, or a local directory in which to store
+these files from a remote CPAN mirror. In the latter case,
+the index files are fetched from a remote CPAN mirror,
+using the same list that C<CPAN.pm> uses, if this is
+configured, and are updated if they are more than one
+day old.
+
+If the C<CPAN> option is not given, it will default
+to C<cpan_home> of L<CPAN>, if this is configured,
+with the sources being found under C<keep_source_where>.
+A fatal error results if such a directory isn't found.
+Updates to these index files are assumed here to be
+handled by C<CPAN.pm>.
+
+=item * C<--db_name 'cpan-sqlite'>
+
+This is the name of the database that C<DBD::SQLite>
+will use. If not given, this defaults to C<cpandb-sqlite>.
+
+=item * C<--db_dir '/path/to/db/dir'>
+
+This specifies the path to where the database file is
+found. If not given, it defaults to the
+C<cpan_home> directory of C<CPAN.pm>, if present, or to
+the directory in which the script was invoked.
+
+=back
+
+=head2 Indexing options
+
+These are options which are used for setting up and
+maintaining the database. These include
+
+=over 3
+
+=item * C<--setup>
+
+This specifies that the database is to be created and
+populated from the CPAN indices; any exisiting database
+will be overwritten.
+
+=item * C<--update>
+
+This is used to update an exisiting database,
+which must have first been created with the C<setup>
+option.
+
+=item * C<--reindex 'dist_name'>
+
+This specifies that the CPAN distribution C<dist_name>
+is to be reindexed.
+
+=back
+
+=head2 Querying options
+
+These options are used to query the database. Available
+options are
+
+=over 3
+
+=item * C<--module Mod::Name>
+
+This provides information on the specified module name.
+
+=item * C<--dist Dist-Name>
+
+This provides information on the specified distribution name.
+
+=item * C<--cpanid CPANID>
+
+This provides information on the specified CPAN author id
+
+=back
+
+All search terms are assumed to be exact matches in a
+case-insensitive manner.
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/bin/cpandb.bat b/Master/tlpkg/tlperl/bin/cpandb.bat new file mode 100755 index 00000000000..0eeeb422909 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpandb.bat @@ -0,0 +1,288 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!C:\strawberry\perl\bin\perl.exe
+#line 15
+use strict;
+use warnings;
+use CPAN::SQLite;
+use CPAN::SQLite::Util qw(%chaps);
+use Getopt::Long;
+my ($CPAN, $setup, $help, $reindex, $index, $query,
+ $db_name, $db_dir, $module, $dist, $cpanid, $update);
+
+my $rc = GetOptions('CPAN=s' => \$CPAN,
+ 'db_name=s' => \$db_name,
+ 'db_dir=s' => \$db_dir,
+ 'setup' => \$setup,
+ 'update' => \$update,
+ 'help' => \$help,
+ 'module=s' => \$module,
+ 'dist=s' => \$dist,
+ 'cpanid=s' => \$cpanid,
+ 'reindex=s' => \$reindex);
+
+$query = ($module or $dist or $cpanid);
+$index = ($update or $reindex or $setup);
+
+if ($help or not $rc or not ($index or $query)) {
+ print <<"END";
+
+Setup, maintain, and search the CPAN::SQLite database
+Usage:
+ $^X $0 --setup
+ $^X $0 --update
+ $^X $0 --reindex dist_name
+
+ $^X $0 --module Mod::Name
+ $^X $0 --dist Distname
+ $^X $0 --cpanid CPANID
+
+ $^X $0 --help
+END
+ exit(1);
+}
+
+if (defined $setup and defined $reindex) {
+ die "Must reindex on an exisiting database";
+}
+
+if ($index) {
+ my $obj = CPAN::SQLite->new(CPAN => $CPAN,
+ setup => $setup,
+ db_name => $db_name,
+ db_dir => $db_dir,
+ reindex => $reindex,
+ );
+ $obj->index();
+}
+else {
+
+ my $max_results = 100;
+ my $obj = CPAN::SQLite->new(CPAN => $CPAN,
+ db_name => $db_name,
+ db_dir => $db_dir,
+ max_results => $max_results);
+ my $results;
+
+ RESULTS : {
+ $module and do {
+ $obj->query(mode => 'module', name => $module);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo module by name of "$module" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ my $abs = $results->{mod_abs} || '';
+ my $dslip = '';
+ if (my $dslip_info = $results->{dslip_info}) {
+ foreach my $entry (@$dslip_info) {
+ $dslip .= " $entry->{desc}: $entry->{what}\n";
+ }
+ }
+ my $chapter_desc = $results->{chapter_desc} || '';
+ print << "EOI";
+
+Module: $results->{mod_name}
+Abstract: $abs
+Version: $results->{mod_vers}
+Chapter: $chapter_desc
+Distribution: $results->{dist_name}
+CPAN author: $results->{cpanid}
+CPAN file: $results->{dist_file}
+Download: $results->{download}
+dslip info:
+$dslip
+EOI
+ }
+ last RESULTS;
+ };
+ $dist and do {
+ $obj->query(mode => 'dist', name => $dist);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo distribution by name of "$dist" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ my $abs = $results->{dist_abs} || '';
+ my $dslip = '';
+ if (my $dslip_info = $results->{dslip_info}) {
+ foreach my $entry (@$dslip_info) {
+ $dslip .= " $entry->{desc}: $entry->{what}\n";
+ }
+ }
+ print << "EOI";
+
+Distribution: $results->{dist_name}
+Abstract: $abs
+Version: $results->{dist_vers}
+CPAN author: $results->{cpanid}
+CPAN file: $results->{dist_file}
+Download: $results->{download}
+dslip info:
+$dslip
+EOI
+ }
+ my $mods = $results->{mods};
+ if ($mods and (ref($mods) eq 'ARRAY')) {
+ print qq{\nProvided modules:\n};
+ foreach my $item(@$mods) {
+ my $abs = $item->{mod_abs} || '';
+ print qq{ $item->{mod_name}: $abs\n};
+ }
+ }
+ last RESULTS;
+ };
+ $cpanid and do {
+ $obj->query(mode => 'author', name => $cpanid);
+ $results = $obj->{results};
+ if (not $results) {
+ print qq{\nNo cpanid by name of "$cpanid" was found.\n};
+ print qq{Error: $obj->{error}\n} if $obj->{error};
+ }
+ else {
+ print << "EOI";
+
+CPANID: $results->{cpanid}
+Full Name: $results->{fullname}
+email: $results->{email}
+EOI
+ }
+ my $dists = $results->{dists};
+ if ($dists and (ref($dists) eq 'ARRAY')) {
+ print qq{\nAvailable distributions:\n};
+ foreach my $item(@$dists) {
+ my $abs = $item->{dist_abs} || '';
+ print qq{ $item->{dist_file}: $abs\n};
+ }
+ }
+ last RESULTS;
+ };
+ }
+}
+
+__END__
+
+=head1 NAME
+
+cpandb - interface to C<CPAN::SQLite>
+
+=head1 DESCRIPTION
+
+This script is an interface to the routines of
+L<CPAN::SQLite> for setting up, maintaining and
+searching a C<DBD::SQLite> database
+of CPAN. Available options can be grouped into
+three categories.
+
+=head2 Common options
+
+These are options which are common to both setting up
+and maintaining the database or performing queries on it.
+These are
+
+=over 3
+
+=item * C<--CPAN '/path/to/CPAN'>
+
+This specifies the path to where the index files are
+to be stored. This could be a local CPAN mirror,
+defined here by the presence of a F<MIRRORED.BY> file beneath
+this directory, or a local directory in which to store
+these files from a remote CPAN mirror. In the latter case,
+the index files are fetched from a remote CPAN mirror,
+using the same list that C<CPAN.pm> uses, if this is
+configured, and are updated if they are more than one
+day old.
+
+If the C<CPAN> option is not given, it will default
+to C<cpan_home> of L<CPAN>, if this is configured,
+with the sources being found under C<keep_source_where>.
+A fatal error results if such a directory isn't found.
+Updates to these index files are assumed here to be
+handled by C<CPAN.pm>.
+
+=item * C<--db_name 'cpan-sqlite'>
+
+This is the name of the database that C<DBD::SQLite>
+will use. If not given, this defaults to C<cpandb-sqlite>.
+
+=item * C<--db_dir '/path/to/db/dir'>
+
+This specifies the path to where the database file is
+found. If not given, it defaults to the
+C<cpan_home> directory of C<CPAN.pm>, if present, or to
+the directory in which the script was invoked.
+
+=back
+
+=head2 Indexing options
+
+These are options which are used for setting up and
+maintaining the database. These include
+
+=over 3
+
+=item * C<--setup>
+
+This specifies that the database is to be created and
+populated from the CPAN indices; any exisiting database
+will be overwritten.
+
+=item * C<--update>
+
+This is used to update an exisiting database,
+which must have first been created with the C<setup>
+option.
+
+=item * C<--reindex 'dist_name'>
+
+This specifies that the CPAN distribution C<dist_name>
+is to be reindexed.
+
+=back
+
+=head2 Querying options
+
+These options are used to query the database. Available
+options are
+
+=over 3
+
+=item * C<--module Mod::Name>
+
+This provides information on the specified module name.
+
+=item * C<--dist Dist-Name>
+
+This provides information on the specified distribution name.
+
+=item * C<--cpanid CPANID>
+
+This provides information on the specified CPAN author id
+
+=back
+
+All search terms are assumed to be exact matches in a
+case-insensitive manner.
+
+=head1 SEE ALSO
+
+L<CPAN::SQLite>.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/cpaninject b/Master/tlpkg/tlperl/bin/cpaninject new file mode 100755 index 00000000000..12679fb1737 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpaninject @@ -0,0 +1,137 @@ +#!/usr/bin/perl + +=pod + +=head1 NAME + +cpaninject - Inject a distribution for installation via the CPAN shell + +=head1 SYNOPSIS + + # Add the distribution + cpaninject myperlmodule.tar.gz + + # And then install it from the cpan shell + cpan> install LOCAL/myperlmodule.tar.gz + +=head1 DESCRIPTION + +B<cpaninject> is a small front-end application for the L<CPAN::Inject> +module. + +It takes any arbitrary Perl distribution tarball (open source or +otherwise) and injects it into the local CPAN file cache, smoothing +some metadata files to make it look as if it came from CPAN. + +It makes use the officially blessed "Reserved Local CPAN Author" id +"LOCAL" as the author the distributions are added under. + +To use the program, just run F<cpaninject> F<mytarball.tar.gz> to add it, +then the CPAN shell to install it (with full automatic recursive +dependency installation). + +The key here being the recursive dependency installation, which you are +now able to do even for installing non-CPAN modules. + +This simplifies the installation process a little, and makes things easier +on someone that just wants to install a single commercial or non-CPAN +Perl module that might have a dozen or more CPAN dependencies. + +=cut + +package cpaninject; + +use strict; +use Params::Util '_STRING'; +use CPAN::Inject; + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '0.11'; +} + + + + + +##################################################################### +# Configuration + +unless ( @ARGV ) { + error("Usage: cpaninject ./any/Perl-Distribution-1.00.tar.gz"); +} + +# Get the file name +my $file = _STRING(shift @ARGV); +unless ( $file ) { + error("Did not provide a file name"); +} +unless ( -f $file ) { + error("File '$file' does not exist"); +} +unless ( -r $file ) { + error("No permissions to read '$file'"); +} + +# Create the injector +my $cpan = eval { CPAN::Inject->from_cpan_config }; +if ( $@ ) { + my $message = $@; + $message =~ s/^(.+)\s+at line.+$/$1/; + error( $message ); +} + +# Add the file +my $path = $cpan->add( file => $file ); +message( "Injected $file ok.\n" ); +message( "The following command will install it from the CPAN shell.\n" ); +message( "\n" ); +message( "cpan> install $path\n" ); +message( "\n" ); +exit(0); + + + + + +##################################################################### +# Support Functions + +sub message ($) { + print ' ' . $_[0]; +} + +sub error (@) { + print ' ' . join '', map { "$_\n" } ('', @_, ''); + exit(255); +} + +=pod + +=head1 SUPPORT + +All bugs should be filed via the bug tracker at + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPAN-Inject> + +For other issues, or commercial enhancement and support, contact the author + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 SEE ALSO + +L<CPAN::Mini::Inject> + +=head1 COPYRIGHT + +Copyright 2006 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/Master/tlpkg/tlperl/bin/cpaninject.bat b/Master/tlpkg/tlperl/bin/cpaninject.bat new file mode 100755 index 00000000000..ddbeeff5dd2 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpaninject.bat @@ -0,0 +1,153 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+=pod
+
+=head1 NAME
+
+cpaninject - Inject a distribution for installation via the CPAN shell
+
+=head1 SYNOPSIS
+
+ # Add the distribution
+ cpaninject myperlmodule.tar.gz
+
+ # And then install it from the cpan shell
+ cpan> install LOCAL/myperlmodule.tar.gz
+
+=head1 DESCRIPTION
+
+B<cpaninject> is a small front-end application for the L<CPAN::Inject>
+module.
+
+It takes any arbitrary Perl distribution tarball (open source or
+otherwise) and injects it into the local CPAN file cache, smoothing
+some metadata files to make it look as if it came from CPAN.
+
+It makes use the officially blessed "Reserved Local CPAN Author" id
+"LOCAL" as the author the distributions are added under.
+
+To use the program, just run F<cpaninject> F<mytarball.tar.gz> to add it,
+then the CPAN shell to install it (with full automatic recursive
+dependency installation).
+
+The key here being the recursive dependency installation, which you are
+now able to do even for installing non-CPAN modules.
+
+This simplifies the installation process a little, and makes things easier
+on someone that just wants to install a single commercial or non-CPAN
+Perl module that might have a dozen or more CPAN dependencies.
+
+=cut
+
+package cpaninject;
+
+use strict;
+use Params::Util '_STRING';
+use CPAN::Inject;
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '0.11';
+}
+
+
+
+
+
+#####################################################################
+# Configuration
+
+unless ( @ARGV ) {
+ error("Usage: cpaninject ./any/Perl-Distribution-1.00.tar.gz");
+}
+
+# Get the file name
+my $file = _STRING(shift @ARGV);
+unless ( $file ) {
+ error("Did not provide a file name");
+}
+unless ( -f $file ) {
+ error("File '$file' does not exist");
+}
+unless ( -r $file ) {
+ error("No permissions to read '$file'");
+}
+
+# Create the injector
+my $cpan = eval { CPAN::Inject->from_cpan_config };
+if ( $@ ) {
+ my $message = $@;
+ $message =~ s/^(.+)\s+at line.+$/$1/;
+ error( $message );
+}
+
+# Add the file
+my $path = $cpan->add( file => $file );
+message( "Injected $file ok.\n" );
+message( "The following command will install it from the CPAN shell.\n" );
+message( "\n" );
+message( "cpan> install $path\n" );
+message( "\n" );
+exit(0);
+
+
+
+
+
+#####################################################################
+# Support Functions
+
+sub message ($) {
+ print ' ' . $_[0];
+}
+
+sub error (@) {
+ print ' ' . join '', map { "$_\n" } ('', @_, '');
+ exit(255);
+}
+
+=pod
+
+=head1 SUPPORT
+
+All bugs should be filed via the bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPAN-Inject>
+
+For other issues, or commercial enhancement and support, contact the author
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+=head1 SEE ALSO
+
+L<CPAN::Mini::Inject>
+
+=head1 COPYRIGHT
+
+Copyright 2006 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/cpanp b/Master/tlpkg/tlperl/bin/cpanp new file mode 100755 index 00000000000..a493322cc29 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpanp @@ -0,0 +1,104 @@ +#!/usr/bin/perl +# $File: //depot/cpanplus/dist/bin/cpanp $ +# $Revision: #8 $ $Change: 8345 $ $DateTime: 2003/10/05 19:25:48 $ + +use strict; +use vars '$VERSION'; + +use CPANPLUS; +$VERSION = CPANPLUS->VERSION; + +use CPANPLUS::Shell qw[Default]; +my $shell = CPANPLUS::Shell->new; + +### if we're given a command, run it; otherwise, open a shell. +if (@ARGV) { + ### take the command line arguments as a command + my $input = "@ARGV"; + ### if they said "--help", fix it up to work. + $input = 'h' if $input =~ /^\s*--?h(?:elp)?\s*$/i; + ### strip the leading dash + $input =~ s/^\s*-//; + ### pass the command line to the shell + ### exit with a useful return value on return + exit not $shell->dispatch_on_input(input => $input, noninteractive => 1); +} else { + ### open a shell for the user + $shell->shell(); +} + +=head1 NAME + +cpanp - The CPANPLUS launcher + +=head1 SYNOPSIS + +B<cpanp> + +B<cpanp> S<[-]B<a>> S<[ --[B<no>-]I<option>... ]> S< I<author>... > + +B<cpanp> S<[-]B<mfitulrcz>> S<[ --[B<no>-]I<option>... ]> S< I<module>... > + +B<cpanp> S<[-]B<d>> S<[ --[B<no>-]I<option>... ]> S<[ --B<fetchdir>=... ]> S< I<module>... > + +B<cpanp> S<[-]B<xb>> S<[ --[B<no>-]I<option>... ]> + +B<cpanp> S<[-]B<o>> S<[ --[B<no>-]I<option>... ]> S<[ I<module>... ]> + +=head1 DESCRIPTION + +This script launches the B<CPANPLUS> utility to perform various operations +from the command line. If it's invoked without arguments, an interactive +shell is executed by default. + +Optionally, it can take a single-letter switch and one or more argument, +to perform the associated action on each arguments. A summary of the +available commands is listed below; C<cpanp -h> provides a detailed list. + + h # help information + v # version information + + a AUTHOR ... # search by author(s) + m MODULE ... # search by module(s) + f MODULE ... # list all releases of a module + + i MODULE ... # install module(s) + t MODULE ... # test module(s) + u MODULE ... # uninstall module(s) + d MODULE ... # download module(s) + l MODULE ... # display detailed information about module(s) + r MODULE ... # display README files of module(s) + c MODULE ... # check for module report(s) from cpan-testers + z MODULE ... # extract module(s) and open command prompt in it + + x # reload CPAN indices + + o [ MODULE ... ] # list installed module(s) that aren't up to date + b # write a bundle file for your configuration + +Each command may be followed by one or more I<options>. If preceded by C<no>, +the corresponding option will be set to C<0>, otherwise it's set to C<1>. + +Example: To skip a module's tests, + + cpanp -i --skiptest MODULE ... + +Valid options for most commands are C<cpantest>, C<debug>, C<flush>, C<force>, +C<prereqs>, C<storable>, C<verbose>, C<md5>, C<signature>, and C<skiptest>; the +'d' command also accepts C<fetchdir>. Please consult L<CPANPLUS::Configure> +for an explanation to their meanings. + +Example: To download a module's tarball to the current directory, + + cpanp -d --fetchdir=. MODULE ... + +=cut + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/Master/tlpkg/tlperl/bin/cpanp-run-perl b/Master/tlpkg/tlperl/bin/cpanp-run-perl new file mode 100755 index 00000000000..34e62bddd04 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpanp-run-perl @@ -0,0 +1,10 @@ +use strict; +my $old = select STDERR; $|++; # turn on autoflush +select $old; $|++; # turn on autoflush +$0 = shift(@ARGV); # rename the script +my $rv = do($0); # execute the file +die $@ if $@; # die on parse/execute error + +### XXX 'do' returns last statement evaluated, which may be +### undef as well. So don't die in that case. +#die $! if not defined $rv; # die on execute error diff --git a/Master/tlpkg/tlperl/bin/cpanp-run-perl.bat b/Master/tlpkg/tlperl/bin/cpanp-run-perl.bat new file mode 100755 index 00000000000..b00cb8b2282 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpanp-run-perl.bat @@ -0,0 +1,27 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+use strict;
+my $old = select STDERR; $|++; # turn on autoflush
+select $old; $|++; # turn on autoflush
+$0 = shift(@ARGV); # rename the script
+my $rv = do($0); # execute the file
+die $@ if $@; # die on parse/execute error
+
+### XXX 'do' returns last statement evaluated, which may be
+### undef as well. So don't die in that case.
+#die $! if not defined $rv; # die on execute error
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/cpanp.bat b/Master/tlpkg/tlperl/bin/cpanp.bat new file mode 100755 index 00000000000..af12a334b3e --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpanp.bat @@ -0,0 +1,120 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+# $File: //depot/cpanplus/dist/bin/cpanp $
+# $Revision: #8 $ $Change: 8345 $ $DateTime: 2003/10/05 19:25:48 $
+
+use strict;
+use vars '$VERSION';
+
+use CPANPLUS;
+$VERSION = CPANPLUS->VERSION;
+
+use CPANPLUS::Shell qw[Default];
+my $shell = CPANPLUS::Shell->new;
+
+### if we're given a command, run it; otherwise, open a shell.
+if (@ARGV) {
+ ### take the command line arguments as a command
+ my $input = "@ARGV";
+ ### if they said "--help", fix it up to work.
+ $input = 'h' if $input =~ /^\s*--?h(?:elp)?\s*$/i;
+ ### strip the leading dash
+ $input =~ s/^\s*-//;
+ ### pass the command line to the shell
+ ### exit with a useful return value on return
+ exit not $shell->dispatch_on_input(input => $input, noninteractive => 1);
+} else {
+ ### open a shell for the user
+ $shell->shell();
+}
+
+=head1 NAME
+
+cpanp - The CPANPLUS launcher
+
+=head1 SYNOPSIS
+
+B<cpanp>
+
+B<cpanp> S<[-]B<a>> S<[ --[B<no>-]I<option>... ]> S< I<author>... >
+
+B<cpanp> S<[-]B<mfitulrcz>> S<[ --[B<no>-]I<option>... ]> S< I<module>... >
+
+B<cpanp> S<[-]B<d>> S<[ --[B<no>-]I<option>... ]> S<[ --B<fetchdir>=... ]> S< I<module>... >
+
+B<cpanp> S<[-]B<xb>> S<[ --[B<no>-]I<option>... ]>
+
+B<cpanp> S<[-]B<o>> S<[ --[B<no>-]I<option>... ]> S<[ I<module>... ]>
+
+=head1 DESCRIPTION
+
+This script launches the B<CPANPLUS> utility to perform various operations
+from the command line. If it's invoked without arguments, an interactive
+shell is executed by default.
+
+Optionally, it can take a single-letter switch and one or more argument,
+to perform the associated action on each arguments. A summary of the
+available commands is listed below; C<cpanp -h> provides a detailed list.
+
+ h # help information
+ v # version information
+
+ a AUTHOR ... # search by author(s)
+ m MODULE ... # search by module(s)
+ f MODULE ... # list all releases of a module
+
+ i MODULE ... # install module(s)
+ t MODULE ... # test module(s)
+ u MODULE ... # uninstall module(s)
+ d MODULE ... # download module(s)
+ l MODULE ... # display detailed information about module(s)
+ r MODULE ... # display README files of module(s)
+ c MODULE ... # check for module report(s) from cpan-testers
+ z MODULE ... # extract module(s) and open command prompt in it
+
+ x # reload CPAN indices
+
+ o [ MODULE ... ] # list installed module(s) that aren't up to date
+ b # write a bundle file for your configuration
+
+Each command may be followed by one or more I<options>. If preceded by C<no>,
+the corresponding option will be set to C<0>, otherwise it's set to C<1>.
+
+Example: To skip a module's tests,
+
+ cpanp -i --skiptest MODULE ...
+
+Valid options for most commands are C<cpantest>, C<debug>, C<flush>, C<force>,
+C<prereqs>, C<storable>, C<verbose>, C<md5>, C<signature>, and C<skiptest>; the
+'d' command also accepts C<fetchdir>. Please consult L<CPANPLUS::Configure>
+for an explanation to their meanings.
+
+Example: To download a module's tarball to the current directory,
+
+ cpanp -d --fetchdir=. MODULE ...
+
+=cut
+
+1;
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/cpansign b/Master/tlpkg/tlperl/bin/cpansign new file mode 100755 index 00000000000..64fb87ed8f2 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpansign @@ -0,0 +1,95 @@ +#!/usr/bin/perl + +$VERSION = '0.06'; + +=head1 NAME + +cpansign - CPAN signature management utility + +=head1 SYNOPSIS + + % cpansign # verify an existing SIGNATURE, or + # make a new one if none exists + + % cpansign file.par # verify or sign a PAR file + + % cpansign sign # make signature; overwrites existing one + % cpansign -s # same thing + + % cpansign verify # verify a signature + % cpansign -v # same thing + % cpansign -v --skip # ignore files in MANIFEST.SKIP + + % cpansign help # display this documentation + % cpansign -h # same thing + +=head1 DESCRIPTION + +This utility lets you create and verify SIGNATURE files. + +=cut + +use strict; +use Module::Signature; + +$Module::Signature::Verbose = 1; + +my %cmd = ( + s => 'sign', + v => 'verify', + h => 'help', +); + +my $op = $ARGV[0]; $op =~ s/^--?// if defined $op; +my $dwim; +if (!$op or $op eq 'skip' or -e $op) { + $op = (-e 'SIGNATURE' ? 'verify' : 'sign'); + $dwim = 1; +} + +my $cmd = $cmd{substr($op, 0, 1)}; +(system("perldoc $0"), exit) if $cmd eq 'help'; +my @args; +push @args, (overwrite => '1') if $cmd eq 'sign'; +push @args, (skip => '0') unless grep /^-?-?skip/, @ARGV; + +if (my $sub = Module::Signature->can($cmd)) { + if (@ARGV and -e $ARGV[-1]) { + require PAR::Dist; + PAR::Dist::_verify_or_sign( + dist => $ARGV[-1], + $dwim ? () : (action => $cmd, @args) + ); + } + else { + #if ($cmd eq 'sign') { + # exit unless Module::Signature::verify(); + #} + exit($sub->(@args)); + } +} +else { + die "Unknown command: '$op'.\n". + "Available actions: " . (join(', ', sort values %cmd)) . ".\n"; +} + +exit; + +=head1 SEE ALSO + +L<Module::Signature> + +=head1 AUTHORS + +Audrey Tang E<lt>autrijus@autrijus.orgE<gt> + +=head1 COPYRIGHT + +Copyright 2002, 2003, 2006 by Audrey Tang. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + +=cut diff --git a/Master/tlpkg/tlperl/bin/cpansign.bat b/Master/tlpkg/tlperl/bin/cpansign.bat new file mode 100755 index 00000000000..512befb81d8 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/cpansign.bat @@ -0,0 +1,111 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+$VERSION = '0.06';
+
+=head1 NAME
+
+cpansign - CPAN signature management utility
+
+=head1 SYNOPSIS
+
+ % cpansign # verify an existing SIGNATURE, or
+ # make a new one if none exists
+
+ % cpansign file.par # verify or sign a PAR file
+
+ % cpansign sign # make signature; overwrites existing one
+ % cpansign -s # same thing
+
+ % cpansign verify # verify a signature
+ % cpansign -v # same thing
+ % cpansign -v --skip # ignore files in MANIFEST.SKIP
+
+ % cpansign help # display this documentation
+ % cpansign -h # same thing
+
+=head1 DESCRIPTION
+
+This utility lets you create and verify SIGNATURE files.
+
+=cut
+
+use strict;
+use Module::Signature;
+
+$Module::Signature::Verbose = 1;
+
+my %cmd = (
+ s => 'sign',
+ v => 'verify',
+ h => 'help',
+);
+
+my $op = $ARGV[0]; $op =~ s/^--?// if defined $op;
+my $dwim;
+if (!$op or $op eq 'skip' or -e $op) {
+ $op = (-e 'SIGNATURE' ? 'verify' : 'sign');
+ $dwim = 1;
+}
+
+my $cmd = $cmd{substr($op, 0, 1)};
+(system("perldoc $0"), exit) if $cmd eq 'help';
+my @args;
+push @args, (overwrite => '1') if $cmd eq 'sign';
+push @args, (skip => '0') unless grep /^-?-?skip/, @ARGV;
+
+if (my $sub = Module::Signature->can($cmd)) {
+ if (@ARGV and -e $ARGV[-1]) {
+ require PAR::Dist;
+ PAR::Dist::_verify_or_sign(
+ dist => $ARGV[-1],
+ $dwim ? () : (action => $cmd, @args)
+ );
+ }
+ else {
+ #if ($cmd eq 'sign') {
+ # exit unless Module::Signature::verify();
+ #}
+ exit($sub->(@args));
+ }
+}
+else {
+ die "Unknown command: '$op'.\n".
+ "Available actions: " . (join(', ', sort values %cmd)) . ".\n";
+}
+
+exit;
+
+=head1 SEE ALSO
+
+L<Module::Signature>
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>autrijus@autrijus.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002, 2003, 2006 by Audrey Tang.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/crc32 b/Master/tlpkg/tlperl/bin/crc32 new file mode 100755 index 00000000000..aa7da02a8ad --- /dev/null +++ b/Master/tlpkg/tlperl/bin/crc32 @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +# Computes and prints to stdout the CRC-32 values of the given files + +use strict; +use lib qw( blib/lib lib ); +use Archive::Zip; +use FileHandle; + +my $totalFiles = scalar(@ARGV); +foreach my $file (@ARGV) { + if ( -d $file ) { + warn "$0: ${file}: Is a directory\n"; + next; + } + my $fh = FileHandle->new(); + if ( !$fh->open( $file, 'r' ) ) { + warn "$0: $!\n"; + next; + } + binmode($fh); + my $buffer; + my $bytesRead; + my $crc = 0; + while ( $bytesRead = $fh->read( $buffer, 32768 ) ) { + $crc = Archive::Zip::computeCRC32( $buffer, $crc ); + } + printf( "%08x", $crc ); + print("\t$file") if ( $totalFiles > 1 ); + print("\n"); +} diff --git a/Master/tlpkg/tlperl/bin/crc32.bat b/Master/tlpkg/tlperl/bin/crc32.bat new file mode 100755 index 00000000000..623a893a786 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/crc32.bat @@ -0,0 +1,47 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+# Computes and prints to stdout the CRC-32 values of the given files
+
+use strict;
+use lib qw( blib/lib lib );
+use Archive::Zip;
+use FileHandle;
+
+my $totalFiles = scalar(@ARGV);
+foreach my $file (@ARGV) {
+ if ( -d $file ) {
+ warn "$0: ${file}: Is a directory\n";
+ next;
+ }
+ my $fh = FileHandle->new();
+ if ( !$fh->open( $file, 'r' ) ) {
+ warn "$0: $!\n";
+ next;
+ }
+ binmode($fh);
+ my $buffer;
+ my $bytesRead;
+ my $crc = 0;
+ while ( $bytesRead = $fh->read( $buffer, 32768 ) ) {
+ $crc = Archive::Zip::computeCRC32( $buffer, $crc );
+ }
+ printf( "%08x", $crc );
+ print("\t$file") if ( $totalFiles > 1 );
+ print("\n");
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/dbilogstrip b/Master/tlpkg/tlperl/bin/dbilogstrip new file mode 100755 index 00000000000..36623718308 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/dbilogstrip @@ -0,0 +1,50 @@ +#!perl
+
+=head1 NAME
+
+dbilogstrip - filter to normalize DBI trace logs for diff'ing
+
+=head1 SYNOPSIS
+
+Read DBI trace file C<dbitrace.log> and write out a stripped version to C<dbitrace_stripped.log>
+
+ dbilogstrip dbitrace.log > dbitrace_stripped.log
+
+Run C<yourscript.pl> twice, each with different sets of arguments, with
+DBI_TRACE enabled. Filter the output and trace through C<dbilogstrip> into a
+separate file for each run. Then compare using diff. (This example assumes
+you're using a standard shell.)
+
+ DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log
+ DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log
+ diff -u dbitrace1.log dbitrace2.log
+
+=head1 DESCRIPTION
+
+Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>.
+
+Replaces any references to process id or thread id, like C<pid#6254> with C<pidN>.
+
+So a DBI trace line like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params' ARRAY(0x1922018)) thr#1800400
+
+will look like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN
+
+=cut
+
+use strict;
+
+while (<>) {
+ # normalize hex addresses: 0xDEADHEAD => 0xN
+ s/ \b 0x [0-9a-f]+ /0xN/gx;
+ # normalize process and thread id number
+ s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx;
+
+} continue {
+ print or die "-p destination: $!\n";
+}
+
+
diff --git a/Master/tlpkg/tlperl/bin/dbilogstrip.bat b/Master/tlpkg/tlperl/bin/dbilogstrip.bat new file mode 100755 index 00000000000..f5f852aaee6 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/dbilogstrip.bat @@ -0,0 +1,66 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+
+=head1 NAME
+
+dbilogstrip - filter to normalize DBI trace logs for diff'ing
+
+=head1 SYNOPSIS
+
+Read DBI trace file C<dbitrace.log> and write out a stripped version to C<dbitrace_stripped.log>
+
+ dbilogstrip dbitrace.log > dbitrace_stripped.log
+
+Run C<yourscript.pl> twice, each with different sets of arguments, with
+DBI_TRACE enabled. Filter the output and trace through C<dbilogstrip> into a
+separate file for each run. Then compare using diff. (This example assumes
+you're using a standard shell.)
+
+ DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log
+ DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log
+ diff -u dbitrace1.log dbitrace2.log
+
+=head1 DESCRIPTION
+
+Replaces any hex addresses, e.g, C<0x128f72ce> with C<0xN>.
+
+Replaces any references to process id or thread id, like C<pid#6254> with C<pidN>.
+
+So a DBI trace line like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0x19162a0)~0x191f9c8 'f_params' ARRAY(0x1922018)) thr#1800400
+
+will look like this:
+
+ -> STORE for DBD::DBM::st (DBI::st=HASH(0xN)~0xN 'f_params' ARRAY(0xN)) thrN
+
+=cut
+
+use strict;
+
+while (<>) {
+ # normalize hex addresses: 0xDEADHEAD => 0xN
+ s/ \b 0x [0-9a-f]+ /0xN/gx;
+ # normalize process and thread id number
+ s/ \b (pid|tid|thr) \W? \d+ /${1}N/gx;
+
+} continue {
+ print or die "-p destination: $!\n";
+}
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/dbiprof b/Master/tlpkg/tlperl/bin/dbiprof new file mode 100755 index 00000000000..af238db7e7a --- /dev/null +++ b/Master/tlpkg/tlperl/bin/dbiprof @@ -0,0 +1,263 @@ +#!perl
+
+use strict;
+
+my $VERSION = sprintf("1.%06d", q$Revision: 9874 $ =~ /(\d+)/o);
+
+use Data::Dumper;
+use DBI::ProfileData;
+use Getopt::Long;
+
+# default options
+my $number = 10;
+my $sort = 'total';
+my $filename = 'dbi.prof';
+my $reverse = 0;
+my $case_sensitive = 0;
+my (%match, %exclude);
+
+# get options from command line
+GetOptions(
+ 'version' => sub { die "dbiprof $VERSION\n" },
+ 'help' => sub { exit usage() },
+ 'number=i' => \$number,
+ 'sort=s' => \$sort,
+ 'dumpnodes!' => \my $dumpnodes,
+ 'reverse' => \$reverse,
+ 'match=s' => \%match,
+ 'exclude=s' => \%exclude,
+ 'case-sensitive' => \$case_sensitive,
+ 'delete!' => \my $opt_delete,
+) or exit usage();
+
+sub usage {
+ print <<EOS;
+dbiprof [options] [files]
+
+Reads and merges DBI profile data from files and prints a summary.
+
+files: defaults to $filename
+
+options:
+
+ -number=N show top N, defaults to $number
+ -sort=S sort by S, defaults to $sort
+ -reverse reverse the sort
+ -match=K=V for filtering, see docs
+ -exclude=K=V for filtering, see docs
+ -case_sensitive for -match and -exclude
+ -delete rename files before reading then delete afterwards
+ -version print version number and exit
+ -help print this help
+
+EOS
+ return 1;
+}
+
+# list of files defaults to dbi.prof
+my @files = @ARGV ? @ARGV : ('dbi.prof');
+
+
+# instantiate ProfileData object
+my $prof = eval {
+ DBI::ProfileData->new(
+ Files => \@files,
+ DeleteFiles => $opt_delete,
+ );
+};
+die "Unable to load profile data: $@\n" if $@;
+
+if (%match) { # handle matches
+ while (my ($key, $val) = each %match) {
+ if ($val =~ m!^/(.+)/$!) {
+ $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+ }
+ $prof->match($key, $val, case_sensitive => $case_sensitive);
+ }
+}
+
+if (%exclude) { # handle excludes
+ while (my ($key, $val) = each %exclude) {
+ if ($val =~ m!^/(.+)/$!) {
+ $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+ }
+ $prof->exclude($key, $val, case_sensitive => $case_sensitive);
+ }
+}
+
+# sort the data
+$prof->sort(field => $sort, reverse => $reverse);
+
+# all done, print it out
+if ($dumpnodes) {
+ $Data::Dumper::Indent = 1;
+ $Data::Dumper::Terse = 1;
+ $Data::Dumper::Useqq = 1;
+ $Data::Dumper::Deparse = 0;
+ print Dumper($prof->nodes);
+}
+else {
+ print $prof->report(number => $number);
+}
+exit 0;
+
+__END__
+
+=head1 NAME
+
+dbiprof - command-line client for DBI::ProfileData
+
+=head1 SYNOPSIS
+
+See a report of the ten queries with the longest total runtime in the
+profile dump file F<prof1.out>:
+
+ dbiprof prof1.out
+
+See the top 10 most frequently run queries in the profile file
+F<dbi.prof> (the default):
+
+ dbiprof --sort count
+
+See the same report with 15 entries:
+
+ dbiprof --sort count --number 15
+
+=head1 DESCRIPTION
+
+This tool is a command-line client for the DBI::ProfileData. It
+allows you to analyze the profile data file produced by
+DBI::ProfileDumper and produce various useful reports.
+
+=head1 OPTIONS
+
+This program accepts the following options:
+
+=over 4
+
+=item --number N
+
+Produce this many items in the report. Defaults to 10. If set to
+"all" then all results are shown.
+
+=item --sort field
+
+Sort results by the given field. Sorting by multiple fields isn't currently
+supported (patches welcome). The available sort fields are:
+
+=over 4
+
+=item total
+
+Sorts by total time run time across all runs. This is the default
+sort.
+
+=item longest
+
+Sorts by the longest single run.
+
+=item count
+
+Sorts by total number of runs.
+
+=item first
+
+Sorts by the time taken in the first run.
+
+=item shortest
+
+Sorts by the shortest single run.
+
+=item key1
+
+Sorts by the value of the first element in the Path, which should be numeric.
+You can also sort by C<key2> and C<key3>.
+
+=back
+
+=item --reverse
+
+Reverses the selected sort. For example, to see a report of the
+shortest overall time:
+
+ dbiprof --sort total --reverse
+
+=item --match keyN=value
+
+Consider only items where the specified key matches the given value.
+Keys are numbered from 1. For example, let's say you used a
+DBI::Profile Path of:
+
+ [ DBIprofile_Statement, DBIprofile_Methodname ]
+
+And called dbiprof as in:
+
+ dbiprof --match key2=execute
+
+Your report would only show execute queries, leaving out prepares,
+fetches, etc.
+
+If the value given starts and ends with slashes (C</>) then it will be
+treated as a regular expression. For example, to only include SELECT
+queries where key1 is the statement:
+
+ dbiprof --match key1=/^SELECT/
+
+By default the match expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --exclude keyN=value
+
+Remove items for where the specified key matches the given value. For
+example, to exclude all prepare entries where key2 is the method name:
+
+ dbiprof --exclude key2=prepare
+
+Like C<--match>, If the value given starts and ends with slashes
+(C</>) then it will be treated as a regular expression. For example,
+to exclude UPDATE queries where key1 is the statement:
+
+ dbiprof --match key1=/^UPDATE/
+
+By default the exclude expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --case-sensitive
+
+Using this option causes --match and --exclude to work
+case-sensitively. Defaults to off.
+
+=item --delete
+
+Sets the C<DeleteFiles> option to L<DBI::ProfileData> which causes the
+files to be deleted after reading. See L<DBI::ProfileData> for more details.
+
+=item --dumpnodes
+
+Print the list of nodes in the form of a perl data structure.
+Use the C<-sort> option if you want the list sorted.
+
+=item --version
+
+Print the dbiprof version number and exit.
+
+=back
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=head1 SEE ALSO
+
+L<DBI::ProfileDumper|DBI::ProfileDumper>,
+L<DBI::Profile|DBI::Profile>, L<DBI|DBI>.
+
+=cut
+
diff --git a/Master/tlpkg/tlperl/bin/dbiprof.bat b/Master/tlpkg/tlperl/bin/dbiprof.bat new file mode 100755 index 00000000000..7dc86ee2ab0 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/dbiprof.bat @@ -0,0 +1,279 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+
+use strict;
+
+my $VERSION = sprintf("1.%06d", q$Revision: 9874 $ =~ /(\d+)/o);
+
+use Data::Dumper;
+use DBI::ProfileData;
+use Getopt::Long;
+
+# default options
+my $number = 10;
+my $sort = 'total';
+my $filename = 'dbi.prof';
+my $reverse = 0;
+my $case_sensitive = 0;
+my (%match, %exclude);
+
+# get options from command line
+GetOptions(
+ 'version' => sub { die "dbiprof $VERSION\n" },
+ 'help' => sub { exit usage() },
+ 'number=i' => \$number,
+ 'sort=s' => \$sort,
+ 'dumpnodes!' => \my $dumpnodes,
+ 'reverse' => \$reverse,
+ 'match=s' => \%match,
+ 'exclude=s' => \%exclude,
+ 'case-sensitive' => \$case_sensitive,
+ 'delete!' => \my $opt_delete,
+) or exit usage();
+
+sub usage {
+ print <<EOS;
+dbiprof [options] [files]
+
+Reads and merges DBI profile data from files and prints a summary.
+
+files: defaults to $filename
+
+options:
+
+ -number=N show top N, defaults to $number
+ -sort=S sort by S, defaults to $sort
+ -reverse reverse the sort
+ -match=K=V for filtering, see docs
+ -exclude=K=V for filtering, see docs
+ -case_sensitive for -match and -exclude
+ -delete rename files before reading then delete afterwards
+ -version print version number and exit
+ -help print this help
+
+EOS
+ return 1;
+}
+
+# list of files defaults to dbi.prof
+my @files = @ARGV ? @ARGV : ('dbi.prof');
+
+
+# instantiate ProfileData object
+my $prof = eval {
+ DBI::ProfileData->new(
+ Files => \@files,
+ DeleteFiles => $opt_delete,
+ );
+};
+die "Unable to load profile data: $@\n" if $@;
+
+if (%match) { # handle matches
+ while (my ($key, $val) = each %match) {
+ if ($val =~ m!^/(.+)/$!) {
+ $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+ }
+ $prof->match($key, $val, case_sensitive => $case_sensitive);
+ }
+}
+
+if (%exclude) { # handle excludes
+ while (my ($key, $val) = each %exclude) {
+ if ($val =~ m!^/(.+)/$!) {
+ $val = $case_sensitive ? qr/$1/ : qr/$1/i;
+ }
+ $prof->exclude($key, $val, case_sensitive => $case_sensitive);
+ }
+}
+
+# sort the data
+$prof->sort(field => $sort, reverse => $reverse);
+
+# all done, print it out
+if ($dumpnodes) {
+ $Data::Dumper::Indent = 1;
+ $Data::Dumper::Terse = 1;
+ $Data::Dumper::Useqq = 1;
+ $Data::Dumper::Deparse = 0;
+ print Dumper($prof->nodes);
+}
+else {
+ print $prof->report(number => $number);
+}
+exit 0;
+
+__END__
+
+=head1 NAME
+
+dbiprof - command-line client for DBI::ProfileData
+
+=head1 SYNOPSIS
+
+See a report of the ten queries with the longest total runtime in the
+profile dump file F<prof1.out>:
+
+ dbiprof prof1.out
+
+See the top 10 most frequently run queries in the profile file
+F<dbi.prof> (the default):
+
+ dbiprof --sort count
+
+See the same report with 15 entries:
+
+ dbiprof --sort count --number 15
+
+=head1 DESCRIPTION
+
+This tool is a command-line client for the DBI::ProfileData. It
+allows you to analyze the profile data file produced by
+DBI::ProfileDumper and produce various useful reports.
+
+=head1 OPTIONS
+
+This program accepts the following options:
+
+=over 4
+
+=item --number N
+
+Produce this many items in the report. Defaults to 10. If set to
+"all" then all results are shown.
+
+=item --sort field
+
+Sort results by the given field. Sorting by multiple fields isn't currently
+supported (patches welcome). The available sort fields are:
+
+=over 4
+
+=item total
+
+Sorts by total time run time across all runs. This is the default
+sort.
+
+=item longest
+
+Sorts by the longest single run.
+
+=item count
+
+Sorts by total number of runs.
+
+=item first
+
+Sorts by the time taken in the first run.
+
+=item shortest
+
+Sorts by the shortest single run.
+
+=item key1
+
+Sorts by the value of the first element in the Path, which should be numeric.
+You can also sort by C<key2> and C<key3>.
+
+=back
+
+=item --reverse
+
+Reverses the selected sort. For example, to see a report of the
+shortest overall time:
+
+ dbiprof --sort total --reverse
+
+=item --match keyN=value
+
+Consider only items where the specified key matches the given value.
+Keys are numbered from 1. For example, let's say you used a
+DBI::Profile Path of:
+
+ [ DBIprofile_Statement, DBIprofile_Methodname ]
+
+And called dbiprof as in:
+
+ dbiprof --match key2=execute
+
+Your report would only show execute queries, leaving out prepares,
+fetches, etc.
+
+If the value given starts and ends with slashes (C</>) then it will be
+treated as a regular expression. For example, to only include SELECT
+queries where key1 is the statement:
+
+ dbiprof --match key1=/^SELECT/
+
+By default the match expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --exclude keyN=value
+
+Remove items for where the specified key matches the given value. For
+example, to exclude all prepare entries where key2 is the method name:
+
+ dbiprof --exclude key2=prepare
+
+Like C<--match>, If the value given starts and ends with slashes
+(C</>) then it will be treated as a regular expression. For example,
+to exclude UPDATE queries where key1 is the statement:
+
+ dbiprof --match key1=/^UPDATE/
+
+By default the exclude expression is matched case-insensitively, but
+this can be changed with the --case-sensitive option.
+
+=item --case-sensitive
+
+Using this option causes --match and --exclude to work
+case-sensitively. Defaults to off.
+
+=item --delete
+
+Sets the C<DeleteFiles> option to L<DBI::ProfileData> which causes the
+files to be deleted after reading. See L<DBI::ProfileData> for more details.
+
+=item --dumpnodes
+
+Print the list of nodes in the form of a perl data structure.
+Use the C<-sort> option if you want the list sorted.
+
+=item --version
+
+Print the dbiprof version number and exit.
+
+=back
+
+=head1 AUTHOR
+
+Sam Tregar <sam@tregar.com>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2002 Sam Tregar
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl 5 itself.
+
+=head1 SEE ALSO
+
+L<DBI::ProfileDumper|DBI::ProfileDumper>,
+L<DBI::Profile|DBI::Profile>, L<DBI|DBI>.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/dbiproxy b/Master/tlpkg/tlperl/bin/dbiproxy new file mode 100755 index 00000000000..0ce06af6065 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/dbiproxy @@ -0,0 +1,184 @@ +#!perl
+
+use strict;
+
+my $VERSION = sprintf("1.%06d", q$Revision: 10720 $ =~ /(\d+)/o);
+
+my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test';
+$ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//;
+
+require DBI::ProxyServer;
+
+# XXX these should probably be moved into DBI::ProxyServer
+delete $ENV{IFS};
+delete $ENV{CDPATH};
+delete $ENV{ENV};
+delete $ENV{BASH_ENV};
+
+if ($arg_test) {
+ require RPC::PlServer::Test;
+ @DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI);
+}
+
+DBI::ProxyServer::main(@ARGV);
+
+exit(0);
+
+
+__END__
+
+=head1 NAME
+
+dbiproxy - A proxy server for the DBD::Proxy driver
+
+=head1 SYNOPSIS
+
+ dbiproxy <options> --localport=<port>
+
+
+=head1 DESCRIPTION
+
+This tool is just a front end for the DBI::ProxyServer package. All it
+does is picking options from the command line and calling
+DBI::ProxyServer::main(). See L<DBI::ProxyServer> for details.
+
+Available options include:
+
+=over 4
+
+=item B<--chroot=dir>
+
+(UNIX only) After doing a bind(), change root directory to the given
+directory by doing a chroot(). This is useful for security, but it
+restricts the environment a lot. For example, you need to load DBI
+drivers in the config file or you have to create hard links to Unix
+sockets, if your drivers are using them. For example, with MySQL, a
+config file might contain the following lines:
+
+ my $rootdir = '/var/dbiproxy';
+ my $unixsockdir = '/tmp';
+ my $unixsockfile = 'mysql.sock';
+ foreach $dir ($rootdir, "$rootdir$unixsockdir") {
+ mkdir 0755, $dir;
+ }
+ link("$unixsockdir/$unixsockfile",
+ "$rootdir$unixsockdir/$unixsockfile");
+ require DBD::mysql;
+
+ {
+ 'chroot' => $rootdir,
+ ...
+ }
+
+If you don't know chroot(), think of an FTP server where you can see a
+certain directory tree only after logging in. See also the --group and
+--user options.
+
+=item B<--configfile=file>
+
+Config files are assumed to return a single hash ref that overrides the
+arguments of the new method. However, command line arguments in turn take
+precedence over the config file. See the "CONFIGURATION FILE" section
+in the L<DBI::ProxyServer> documentation for details on the config file.
+
+=item B<--debug>
+
+Turn debugging mode on. Mainly this asserts that logging messages of
+level "debug" are created.
+
+=item B<--facility=mode>
+
+(UNIX only) Facility to use for L<Sys::Syslog>. The default is
+B<daemon>.
+
+=item B<--group=gid>
+
+After doing a bind(), change the real and effective GID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --user option.
+
+GID's can be passed as group names or numeric values.
+
+=item B<--localaddr=ip>
+
+By default a daemon is listening to any IP number that a machine
+has. This attribute allows to restrict the server to the given
+IP number.
+
+=item B<--localport=port>
+
+This attribute sets the port on which the daemon is listening. It
+must be given somehow, as there's no default.
+
+=item B<--logfile=file>
+
+Be default logging messages will be written to the syslog (Unix) or
+to the event log (Windows NT). On other operating systems you need to
+specify a log file. The special value "STDERR" forces logging to
+stderr. See L<Net::Daemon::Log> for details.
+
+=item B<--mode=modename>
+
+The server can run in three different modes, depending on the environment.
+
+If you are running Perl 5.005 and did compile it for threads, then the
+server will create a new thread for each connection. The thread will
+execute the server's Run() method and then terminate. This mode is the
+default, you can force it with "--mode=threads".
+
+If threads are not available, but you have a working fork(), then the
+server will behave similar by creating a new process for each connection.
+This mode will be used automatically in the absence of threads or if
+you use the "--mode=fork" option.
+
+Finally there's a single-connection mode: If the server has accepted a
+connection, he will enter the Run() method. No other connections are
+accepted until the Run() method returns (if the client disconnects).
+This operation mode is useful if you have neither threads nor fork(),
+for example on the Macintosh. For debugging purposes you can force this
+mode with "--mode=single".
+
+=item B<--pidfile=file>
+
+(UNIX only) If this option is present, a PID file will be created at the
+given location. Default is to not create a pidfile.
+
+=item B<--user=uid>
+
+After doing a bind(), change the real and effective UID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --group and the --chroot options.
+
+UID's can be passed as group names or numeric values.
+
+=item B<--version>
+
+Supresses startup of the server; instead the version string will
+be printed and the program exits immediately.
+
+=back
+
+
+=head1 AUTHOR
+
+ Copyright (c) 1997 Jochen Wiedmann
+ Am Eisteich 9
+ 72555 Metzingen
+ Germany
+
+ Email: joe@ispsoft.de
+ Phone: +49 7123 14881
+
+The DBI::ProxyServer module is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself. In particular
+permission is granted to Tim Bunce for distributing this as a part of
+the DBI.
+
+
+=head1 SEE ALSO
+
+L<DBI::ProxyServer>, L<DBD::Proxy>, L<DBI>
+
+=cut
diff --git a/Master/tlpkg/tlperl/bin/dbiproxy.bat b/Master/tlpkg/tlperl/bin/dbiproxy.bat new file mode 100755 index 00000000000..1199ebbfa92 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/dbiproxy.bat @@ -0,0 +1,200 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+
+use strict;
+
+my $VERSION = sprintf("1.%06d", q$Revision: 10720 $ =~ /(\d+)/o);
+
+my $arg_test = shift(@ARGV) if $ARGV[0] eq '--test';
+$ENV{DBI_TRACE} = shift(@ARGV) || 2 if $ARGV[0] =~ s/^--dbitrace=?//;
+
+require DBI::ProxyServer;
+
+# XXX these should probably be moved into DBI::ProxyServer
+delete $ENV{IFS};
+delete $ENV{CDPATH};
+delete $ENV{ENV};
+delete $ENV{BASH_ENV};
+
+if ($arg_test) {
+ require RPC::PlServer::Test;
+ @DBI::ProxyServer::ISA = qw(RPC::PlServer::Test DBI);
+}
+
+DBI::ProxyServer::main(@ARGV);
+
+exit(0);
+
+
+__END__
+
+=head1 NAME
+
+dbiproxy - A proxy server for the DBD::Proxy driver
+
+=head1 SYNOPSIS
+
+ dbiproxy <options> --localport=<port>
+
+
+=head1 DESCRIPTION
+
+This tool is just a front end for the DBI::ProxyServer package. All it
+does is picking options from the command line and calling
+DBI::ProxyServer::main(). See L<DBI::ProxyServer> for details.
+
+Available options include:
+
+=over 4
+
+=item B<--chroot=dir>
+
+(UNIX only) After doing a bind(), change root directory to the given
+directory by doing a chroot(). This is useful for security, but it
+restricts the environment a lot. For example, you need to load DBI
+drivers in the config file or you have to create hard links to Unix
+sockets, if your drivers are using them. For example, with MySQL, a
+config file might contain the following lines:
+
+ my $rootdir = '/var/dbiproxy';
+ my $unixsockdir = '/tmp';
+ my $unixsockfile = 'mysql.sock';
+ foreach $dir ($rootdir, "$rootdir$unixsockdir") {
+ mkdir 0755, $dir;
+ }
+ link("$unixsockdir/$unixsockfile",
+ "$rootdir$unixsockdir/$unixsockfile");
+ require DBD::mysql;
+
+ {
+ 'chroot' => $rootdir,
+ ...
+ }
+
+If you don't know chroot(), think of an FTP server where you can see a
+certain directory tree only after logging in. See also the --group and
+--user options.
+
+=item B<--configfile=file>
+
+Config files are assumed to return a single hash ref that overrides the
+arguments of the new method. However, command line arguments in turn take
+precedence over the config file. See the "CONFIGURATION FILE" section
+in the L<DBI::ProxyServer> documentation for details on the config file.
+
+=item B<--debug>
+
+Turn debugging mode on. Mainly this asserts that logging messages of
+level "debug" are created.
+
+=item B<--facility=mode>
+
+(UNIX only) Facility to use for L<Sys::Syslog>. The default is
+B<daemon>.
+
+=item B<--group=gid>
+
+After doing a bind(), change the real and effective GID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --user option.
+
+GID's can be passed as group names or numeric values.
+
+=item B<--localaddr=ip>
+
+By default a daemon is listening to any IP number that a machine
+has. This attribute allows to restrict the server to the given
+IP number.
+
+=item B<--localport=port>
+
+This attribute sets the port on which the daemon is listening. It
+must be given somehow, as there's no default.
+
+=item B<--logfile=file>
+
+Be default logging messages will be written to the syslog (Unix) or
+to the event log (Windows NT). On other operating systems you need to
+specify a log file. The special value "STDERR" forces logging to
+stderr. See L<Net::Daemon::Log> for details.
+
+=item B<--mode=modename>
+
+The server can run in three different modes, depending on the environment.
+
+If you are running Perl 5.005 and did compile it for threads, then the
+server will create a new thread for each connection. The thread will
+execute the server's Run() method and then terminate. This mode is the
+default, you can force it with "--mode=threads".
+
+If threads are not available, but you have a working fork(), then the
+server will behave similar by creating a new process for each connection.
+This mode will be used automatically in the absence of threads or if
+you use the "--mode=fork" option.
+
+Finally there's a single-connection mode: If the server has accepted a
+connection, he will enter the Run() method. No other connections are
+accepted until the Run() method returns (if the client disconnects).
+This operation mode is useful if you have neither threads nor fork(),
+for example on the Macintosh. For debugging purposes you can force this
+mode with "--mode=single".
+
+=item B<--pidfile=file>
+
+(UNIX only) If this option is present, a PID file will be created at the
+given location. Default is to not create a pidfile.
+
+=item B<--user=uid>
+
+After doing a bind(), change the real and effective UID to the given.
+This is useful, if you want your server to bind to a privileged port
+(<1024), but don't want the server to execute as root. See also
+the --group and the --chroot options.
+
+UID's can be passed as group names or numeric values.
+
+=item B<--version>
+
+Supresses startup of the server; instead the version string will
+be printed and the program exits immediately.
+
+=back
+
+
+=head1 AUTHOR
+
+ Copyright (c) 1997 Jochen Wiedmann
+ Am Eisteich 9
+ 72555 Metzingen
+ Germany
+
+ Email: joe@ispsoft.de
+ Phone: +49 7123 14881
+
+The DBI::ProxyServer module is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself. In particular
+permission is granted to Tim Bunce for distributing this as a part of
+the DBI.
+
+
+=head1 SEE ALSO
+
+L<DBI::ProxyServer>, L<DBD::Proxy>, L<DBI>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/dprofpp.bat b/Master/tlpkg/tlperl/bin/dprofpp.bat new file mode 100755 index 00000000000..ee8f9e3be95 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/dprofpp.bat @@ -0,0 +1,945 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -S $0 "$@"'
+ if 0;
+
+require 5.003;
+
+my $VERSION = '20080331.00';
+my $stty = undef;
+
+=head1 NAME
+
+dprofpp - display perl profile data
+
+=head1 SYNOPSIS
+
+dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-d>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [B<-G> <regexp> [B<-P>]] [B<-f> <regexp>] [profile]
+
+dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-G> <regexp> [B<-P>] [profile]
+
+dprofpp B<-p script> [B<-Q>] [other opts]
+
+dprofpp B<-V> [profile]
+
+=head1 DESCRIPTION
+
+The I<dprofpp> command interprets profile data produced by a profiler, such
+as the Devel::DProf profiler. Dprofpp will read the file F<tmon.out> and
+display the 15 subroutines which are using the most time. By default
+the times for each subroutine are given exclusive of the times of their
+child subroutines.
+
+To profile a Perl script run the perl interpreter with the B<-d> switch. So
+to profile script F<test.pl> with Devel::DProf use the following:
+
+ $ perl5 -d:DProf test.pl
+
+Then run dprofpp to analyze the profile. The output of dprofpp depends
+on the flags to the program and the version of Perl you're using.
+
+ $ dprofpp -u
+ Total Elapsed Time = 1.67 Seconds
+ User Time = 0.61 Seconds
+ Exclusive Times
+ %Time Seconds #Calls sec/call Name
+ 52.4 0.320 2 0.1600 main::foo
+ 45.9 0.280 200 0.0014 main::bar
+ 0.00 0.000 1 0.0000 DynaLoader::import
+ 0.00 0.000 1 0.0000 main::baz
+
+The dprofpp tool can also run the profiler before analyzing the profile
+data. The above two commands can be executed with one dprofpp command.
+
+ $ dprofpp -u -p test.pl
+
+Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
+
+=head1 OUTPUT
+
+Columns are:
+
+=over 4
+
+=item %Time
+
+Percentage of time spent in this routine.
+
+=item #Calls
+
+Number of calls to this routine.
+
+=item sec/call
+
+Average number of seconds per call to this routine.
+
+=item Name
+
+Name of routine.
+
+=item CumulS
+
+Time (in seconds) spent in this routine and routines called from it.
+
+=item ExclSec
+
+Time (in seconds) spent in this routine (not including those called
+from it).
+
+=item Csec/c
+
+Average time (in seconds) spent in each call of this routine
+(including those called from it).
+
+=back
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-a>
+
+Sort alphabetically by subroutine names.
+
+=item B<-d>
+
+Reverse whatever sort is used
+
+=item B<-A>
+
+Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
+Otherwise the time to autoload it is counted as time of the subroutine
+itself (there is no way to separate autoload time from run time).
+
+This is going to be irrelevant with newer Perls. They will inform
+C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
+so a separate statistics for C<AUTOLOAD> will be collected no matter
+whether this option is set.
+
+=item B<-R>
+
+Count anonymous subroutines defined in the same package separately.
+
+=item B<-E>
+
+(default) Display all subroutine times exclusive of child subroutine times.
+
+=item B<-F>
+
+Force the generation of fake exit timestamps if dprofpp reports that the
+profile is garbled. This is only useful if dprofpp determines that the
+profile is garbled due to missing exit timestamps. You're on your own if
+you do this. Consult the BUGS section.
+
+=item B<-I>
+
+Display all subroutine times inclusive of child subroutine times.
+
+=item B<-l>
+
+Sort by number of calls to the subroutines. This may help identify
+candidates for inlining.
+
+=item B<-O cnt>
+
+Show only I<cnt> subroutines. The default is 15.
+
+=item B<-p script>
+
+Tells dprofpp that it should profile the given script and then interpret its
+profile data. See B<-Q>.
+
+=item B<-Q>
+
+Used with B<-p> to tell dprofpp to quit after profiling the script, without
+interpreting the data.
+
+=item B<-q>
+
+Do not display column headers.
+
+=item B<-r>
+
+Display elapsed real times rather than user+system times.
+
+=item B<-s>
+
+Display system times rather than user+system times.
+
+=item B<-T>
+
+Display subroutine call tree to stdout. Subroutine statistics are
+not displayed.
+
+=item B<-t>
+
+Display subroutine call tree to stdout. Subroutine statistics are not
+displayed. When a function is called multiple consecutive times at the same
+calling level then it is displayed once with a repeat count.
+
+=item B<-S>
+
+Display I<merged> subroutine call tree to stdout. Statistics are
+displayed for each branch of the tree.
+
+When a function is called multiple (I<not necessarily consecutive>)
+times in the same branch then all these calls go into one branch of
+the next level. A repeat count is output together with combined
+inclusive, exclusive and kids time.
+
+Branches are sorted with regard to inclusive time.
+
+=item B<-U>
+
+Do not sort. Display in the order found in the raw profile.
+
+=item B<-u>
+
+Display user times rather than user+system times.
+
+=item B<-V>
+
+Print dprofpp's version number and exit. If a raw profile is found then its
+XS_VERSION variable will be displayed, too.
+
+=item B<-v>
+
+Sort by average time spent in subroutines during each call. This may help
+identify candidates for inlining.
+
+=item B<-z>
+
+(default) Sort by amount of user+system time used. The first few lines
+should show you which subroutines are using the most time.
+
+=item B<-g> C<subroutine>
+
+Ignore subroutines except C<subroutine> and whatever is called from it.
+
+=item B<-G> <regexp>
+
+Aggregate "Group" all calls matching the pattern together.
+For example this can be used to group all calls of a set of packages
+
+ -G "(package1::)|(package2::)|(package3::)"
+
+or to group subroutines by name:
+
+ -G "getNum"
+
+=item B<-P>
+
+Used with -G to aggregate "Pull" together all calls that did not match -G.
+
+=item B<-f> <regexp>
+
+Filter all calls matching the pattern.
+
+=item B<-h>
+
+Display brief help and exit.
+
+=item B<-H>
+
+Display long help and exit.
+
+=back
+
+=head1 ENVIRONMENT
+
+The environment variable B<DPROFPP_OPTS> can be set to a string containing
+options for dprofpp. You might use this if you prefer B<-I> over B<-E> or
+if you want B<-F> on all the time.
+
+This was added fairly lazily, so there are some undesirable side effects.
+Options on the commandline should override options in DPROFPP_OPTS--but
+don't count on that in this version.
+
+=head1 BUGS
+
+Applications which call _exit() or exec() from within a subroutine
+will leave an incomplete profile. See the B<-F> option.
+
+Any bugs in Devel::DProf, or any profiler generating the profile data, could
+be visible here. See L<Devel::DProf/BUGS>.
+
+Mail bug reports and feature requests to the perl5-porters mailing list at
+F<E<lt>perl5-porters@perl.orgE<gt>>. Bug reports should include the
+output of the B<-V> option.
+
+=head1 FILES
+
+ dprofpp - profile processor
+ tmon.out - raw profile
+
+=head1 SEE ALSO
+
+L<perl>, L<Devel::DProf>, times(2)
+
+=cut
+
+sub shortusage {
+ print <<'EOF';
+dprofpp [options] [profile]
+
+ -A Count autoloaded to *AUTOLOAD.
+ -a Sort by alphabetic name of subroutines.
+ -d Reverse sort.
+ -E Sub times are reported exclusive of child times. (default)
+ -f Filter all calls matching the pattern.
+ -G Group all calls matching the pattern together.
+ -g subr Count only subs who are SUBR or called from SUBR.
+ -H Display long manual page.
+ -h Display this short usage message.
+ -I Sub times are reported inclusive of child times.
+ -l Sort by number of calls to subroutines.
+ -O cnt Specifies maximum number of subroutines to display.
+ -P Used with -G to pull all other calls together.
+ -p script Specifies name of script to be profiled.
+ -Q Used with -p to indicate that dprofpp should quit
+ after profiling the script, without interpreting the data.
+ -q Do not print column headers.
+ -R Count anonymous subs separately even if from the same package.
+ -r Use real elapsed time rather than user+system time.
+ -S Create statistics for all the depths.
+ -s Use system time rather than user+system time.
+ -T Show call tree.
+ -t Show call tree, compressed.
+ -U Do not sort subroutines.
+ -u Use user time rather than user+system time.
+ -V Print dprofpp's version.
+ -v Sort by average amount of time spent in subroutines.
+ -z Sort by user+system time spent in subroutines. (default)
+EOF
+}
+
+use Getopt::Std 'getopts';
+use Config '%Config';
+
+Setup: {
+ my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVShH';
+
+ $Monfile = 'tmon.out';
+ if( exists $ENV{DPROFPP_OPTS} ){
+ my @tmpargv = @ARGV;
+ @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
+ getopts( $options );
+ if( @ARGV ){
+ # there was a filename.
+ $Monfile = shift;
+ }
+ @ARGV = @tmpargv;
+ }
+
+ getopts( $options ) or die "Try 'dprofpp -h' for help.\n";
+ if( @ARGV ){
+ # there was a filename, it overrides any earlier name.
+ $Monfile = shift;
+ }
+
+ if ( defined $opt_h ) {
+ shortusage();
+ exit;
+ }
+ if ( defined $opt_H ) {
+ require Pod::Usage;
+ Pod::Usage::pod2usage( {-verbose => 2, -input => $0 } );
+ exit;
+ }
+
+ if( defined $opt_V ){
+ my $fh = 'main::fh';
+ print "$0 version: $VERSION\n";
+ open( $fh, "<$Monfile" ) && do {
+ local $XS_VERSION = 'early';
+ header($fh);
+ close( $fh );
+ print "XS_VERSION: $XS_VERSION\n";
+ };
+ exit(0);
+ }
+ $cnt = $opt_O || 15;
+ $sort = 'by_time';
+ $sort = 'by_ctime' if defined $opt_I;
+ $sort = 'by_calls' if defined $opt_l;
+ $sort = 'by_alpha' if defined $opt_a;
+ $sort = 'by_avgcpu' if defined $opt_v;
+
+ if(defined $opt_d){
+ $sort = "r".$sort;
+ }
+ $incl_excl = 'Exclusive';
+ $incl_excl = 'Inclusive' if defined $opt_I;
+ $whichtime = 'User+System';
+ $whichtime = 'System' if defined $opt_s;
+ $whichtime = 'Real' if defined $opt_r;
+ $whichtime = 'User' if defined $opt_u;
+
+ if( defined $opt_p ){
+ my $prof = 'DProf';
+ my $startperl = $Config{'startperl'};
+
+ $startperl =~ s/^#!//; # remove shebang
+ run_profiler( $opt_p, $prof, $startperl );
+ $Monfile = 'tmon.out'; # because that's where it is
+ exit(0) if defined $opt_Q;
+ }
+ elsif( defined $opt_Q ){
+ die "-Q is meaningful only when used with -p\n";
+ }
+}
+
+Main: {
+ my $monout = $Monfile;
+ my $fh = 'main::fh';
+ local $names = {};
+ local $times = {}; # times in hz
+ local $ctimes = {}; # Cumulative times in hz
+ local $calls = {};
+ local $persecs = {}; # times in seconds
+ local $idkeys = [];
+ local $runtime; # runtime in seconds
+ my @a = ();
+ my $a;
+ local $rrun_utime = 0; # user time in hz
+ local $rrun_stime = 0; # system time in hz
+ local $rrun_rtime = 0; # elapsed run time in hz
+ local $rrun_ustime = 0; # user+system time in hz
+ local $hz = 0;
+ local $deep_times = {count => 0 , kids => {}, incl_time => 0};
+ local $time_precision = 2;
+ local $overhead = 0;
+
+ open( $fh, "<$monout" ) || die "Unable to open $monout\n";
+
+ header($fh);
+
+ $rrun_ustime = $rrun_utime + $rrun_stime;
+
+ $~ = 'STAT';
+ if( ! $opt_q ){
+ $^ = 'CSTAT_top';
+ }
+
+ parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
+
+ #filter calls
+ if( $opt_f ){
+ for(my $i = 0;$i < @$idkeys - 2;){
+ $key = $$idkeys[$i];
+ if($key =~ /$opt_f/){
+ splice(@$idkeys, $i, 1);
+ $runtime -= $$times{$key};
+ next;
+ }
+ $i++;
+ }
+ }
+
+ if( $opt_G ){
+ group($names, $calls, $times, $ctimes, $idkeys );
+ }
+
+ settime( \$runtime, $hz ) unless $opt_g;
+
+ exit(0) if $opt_T || $opt_t;
+
+ if( $opt_v ){
+ percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
+ }
+ if( ! $opt_U ){
+ @a = sort $sort @$idkeys;
+ $a = \@a;
+ }
+ else {
+ $a = $idkeys;
+ }
+ display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
+ $deep_times);
+}
+
+sub group{
+ my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
+ print "Option G Grouping: [$opt_G]\n";
+ # create entries to store grouping
+ $$names{$opt_G} = $opt_G;
+ $$calls{$opt_G} = 0;
+ $$times{$opt_G} = 0;
+ $$ctimes{$opt_G} = 0;
+ $$idkeys[@$idkeys] = $opt_G;
+ # Sum calls for the grouping
+
+ my $other = "other";
+ if($opt_P){
+ $$names{$other} = $other;
+ $$calls{$other} = 0;
+ $$times{$other} = 0;
+ $$ctimes{$other} = 0;
+ $$idkeys[@$idkeys] = $other;
+ }
+
+ for(my $i = 0;$i < @$idkeys - 2;){
+ $key = $$idkeys[$i];
+ if($key =~ /$opt_G/){
+ $$calls{$opt_G} += $$calls{$key};
+ $$times{$opt_G} += $$times{$key};
+ $$ctimes{$opt_G} += $$ctimes{$key};
+ splice(@$idkeys, $i, 1);
+ next;
+ }else{
+ if($opt_P){
+ $$calls{$other} += $$calls{$key};
+ $$times{$other} += $$times{$key};
+ $$ctimes{$other} += $$ctimes{$key};
+ splice(@$idkeys, $i, 1);
+ next;
+ }
+ }
+ $i++;
+ }
+ print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
+ "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
+ "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
+}
+
+# Sets $runtime to user, system, real, or user+system time. The
+# result is given in seconds.
+#
+sub settime {
+ my( $runtime, $hz ) = @_;
+
+ $hz ||= 1;
+
+ if( $opt_r ){
+ $$runtime = ($rrun_rtime - $overhead)/$hz;
+ }
+ elsif( $opt_s ){
+ $$runtime = ($rrun_stime - $overhead)/$hz;
+ }
+ elsif( $opt_u ){
+ $$runtime = ($rrun_utime - $overhead)/$hz;
+ }
+ else{
+ $$runtime = ($rrun_ustime - $overhead)/$hz;
+ }
+ $$runtime = 0 unless $$runtime > 0;
+}
+
+sub exclusives_in_tree {
+ my( $deep_times ) = @_;
+ my $kids_time = 0;
+ my $kid;
+ # When summing, take into account non-rounded-up kids time.
+ for $kid (keys %{$deep_times->{kids}}) {
+ $kids_time += $deep_times->{kids}{$kid}{incl_time};
+ }
+ $kids_time = 0 unless $kids_time >= 0;
+ $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
+ $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
+ for $kid (keys %{$deep_times->{kids}}) {
+ exclusives_in_tree($deep_times->{kids}{$kid});
+ }
+ $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
+ $deep_times->{kids_time} = $kids_time;
+}
+
+sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time}
+ or $a cmp $b }
+
+sub display_tree {
+ my( $deep_times, $name, $level ) = @_;
+ exclusives_in_tree($deep_times);
+
+ my $kid;
+
+ my $time;
+ if (%{$deep_times->{kids}}) {
+ $time = sprintf '%.*fs = (%.*f + %.*f)',
+ $time_precision, $deep_times->{incl_time}/$hz,
+ $time_precision, $deep_times->{excl_time}/$hz,
+ $time_precision, $deep_times->{kids_time}/$hz;
+ } else {
+ $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
+ }
+ print ' ' x (2*$level), "$name x $deep_times->{count} \t${time}s\n"
+ if $deep_times->{count};
+
+ for $kid (sort kids_by_incl %{$deep_times->{kids}}) {
+ display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
+ }
+}
+
+# Report the times in seconds.
+sub display {
+ my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt,
+ $idkeys, $deep_times ) = @_;
+ my( $x, $key, $s, $cs );
+ #format: $ncalls, $name, $secs, $percall, $pcnt
+
+ if ($opt_S) {
+ display_tree( $deep_times, 'toplevel', -1 )
+ } else {
+ for( $x = 0; $x < @$idkeys; ++$x ){
+ $key = $idkeys->[$x];
+ $ncalls = $calls->{$key};
+ $name = $names->{$key};
+ $s = $times->{$key}/$hz;
+ $secs = sprintf("%.3f", $s );
+ $cs = $ctimes->{$key}/$hz;
+ $csecs = sprintf("%.3f", $cs );
+ $percall = sprintf("%.4f", $s/$ncalls );
+ $cpercall = sprintf("%.4f", $cs/$ncalls );
+ $pcnt = sprintf("%.2f",
+ $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
+ write;
+ $pcnt = $secs = $ncalls = $percall = "";
+ write while( length $name );
+ last unless --$cnt;
+ }
+ }
+}
+
+sub move_keys {
+ my ($source, $dest) = @_;
+
+ for my $kid_name (keys %$source) {
+ my $source_kid = delete $source->{$kid_name};
+
+ if (my $dest_kid = $dest->{$kid_name}) {
+ $dest_kid->{count} += $source_kid->{count};
+ $dest_kid->{incl_time} += $source_kid->{incl_time};
+ move_keys($source_kid->{kids},$dest_kid->{kids});
+ } else {
+ $dest->{$kid_name} = $source_kid;
+ }
+ }
+}
+
+sub add_to_tree {
+ my ($curdeep_times, $name, $t) = @_;
+ if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
+ $name = $curdeep_times->[-1]{name};
+ }
+ die "Shorted?!" unless @$curdeep_times >= 2;
+ my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
+ count => 0,
+ kids => {},
+ incl_time => 0,
+ };
+ # Now transfer to the new node (could not do earlier, since name can change)
+ $entry->{count}++;
+ $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
+ # Merge the kids?
+ move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
+ pop @$curdeep_times;
+}
+
+
+sub parsestack {
+ my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
+ my( $dir, $name );
+ my( $t, $syst, $realt, $usert );
+ my( $x, $z, $c, $id, $pack );
+ my @stack = ();
+ my @tstack = ();
+ my %outer;
+ my $tab = 3;
+ my $in = 0;
+
+ # remember last call depth and function name
+ my $l_in = $in;
+ my $l_name = '';
+ my $repcnt = 0;
+ my $repstr = '';
+ my $dprof_stamp;
+ my %cv_hash;
+ my $in_level = not defined $opt_g; # Level deep in report grouping
+ my $curdeep_times = [$deep_times];
+
+ my $over_per_call;
+ if ( $opt_u ) { $over_per_call = $over_utime }
+ elsif( $opt_s ) { $over_per_call = $over_stime }
+ elsif( $opt_r ) { $over_per_call = $over_rtime }
+ else { $over_per_call = $over_utime + $over_stime }
+ $over_per_call /= 2*$over_tests; # distribute over entry and exit
+
+ while(<$fh>){
+ next if /^#/;
+ last if /^PART/;
+
+ chop;
+ if (/^&/) {
+ ($dir, $id, $pack, $name) = split;
+ if ($opt_R and ($name =~ /(?:::)?(__ANON__|END)$/)) {
+ $name .= "($id)";
+ }
+ $cv_hash{$id} = "$pack\::$name";
+ next;
+ }
+ ($dir, $usert, $syst, $realt, $name) = split;
+
+ my $ot = $t;
+ if ( $dir eq '/' ) {
+ $syst = $stack[-1][0] if scalar @stack;
+ $usert = '&';
+ $dir = '-';
+ #warn("Inserted exit for $stack[-1][0].\n")
+ }
+ if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
+ if ( $opt_u ) { $t = $usert }
+ elsif( $opt_s ) { $t = $syst }
+ elsif( $opt_r ) { $t = $realt }
+ else { $t = $usert + $syst }
+ $t += $ot, next if $dir eq '@'; # Increments there
+ } else {
+ # "- id" or "- & name"
+ $name = defined $syst ? $syst : $cv_hash{$usert};
+ }
+
+ next unless $in_level or $name eq $opt_g;
+ if ( $dir eq '-' or $dir eq '*' ) {
+ my $ename = $dir eq '*' ? $stack[-1][0] : $name;
+ $overhead += $over_per_call;
+ if ($name eq "Devel::DProf::write") {
+ $overhead += $t - $dprof_stamp;
+ next;
+ } elsif (defined $opt_g and $ename eq $opt_g) {
+ $in_level--;
+ }
+ add_to_tree($curdeep_times, $ename,
+ $t - $overhead) if $opt_S;
+ exitstamp( \@stack, \@tstack,
+ $t - $overhead,
+ $times, $ctimes, $name, \$in, $tab,
+ $curdeep_times, \%outer );
+ }
+ next unless $in_level or $name eq $opt_g;
+ if( $dir eq '+' or $dir eq '*' ){
+ if ($name eq "Devel::DProf::write") {
+ $dprof_stamp = $t;
+ next;
+ } elsif (defined $opt_g and $name eq $opt_g) {
+ $in_level++;
+ }
+ $overhead += $over_per_call;
+ if( $opt_T ){
+ print ' ' x $in, "$name\n";
+ $in += $tab;
+ }
+ elsif( $opt_t ){
+ # suppress output on same function if the
+ # same calling level is called.
+ if ($l_in == $in and $l_name eq $name) {
+ $repcnt++;
+ } else {
+ $repstr = ' ('.++$repcnt.'x)'
+ if $repcnt;
+ print ' ' x $l_in, "$l_name$repstr\n"
+ if $l_name ne '';
+ $repstr = '';
+ $repcnt = 0;
+ $l_in = $in;
+ $l_name = $name;
+ }
+ $in += $tab;
+ }
+ if( ! defined $names->{$name} ){
+ $names->{$name} = $name;
+ $times->{$name} = 0;
+ $ctimes->{$name} = 0;
+ push( @$idkeys, $name );
+ }
+ $calls->{$name}++;
+ $outer{$name}++;
+ push @$curdeep_times, { kids => {},
+ name => $name,
+ enter_stamp => $t - $overhead,
+ } if $opt_S;
+ $x = [ $name, $t - $overhead ];
+ push( @stack, $x );
+
+ # my children will put their time here
+ push( @tstack, 0 );
+ } elsif ($dir ne '-'){
+ die "Bad profile: $_";
+ }
+ }
+ if( $opt_t ){
+ $repstr = ' ('.++$repcnt.'x)' if $repcnt;
+ print ' ' x $l_in, "$l_name$repstr\n";
+ }
+
+ while (my ($key, $count) = each %outer) {
+ next unless $count;
+ warn "$key has $count unstacked calls in outer\n";
+ }
+
+ if( @stack ){
+ if( ! $opt_F ){
+ warn "Garbled profile is missing some exit time stamps:\n";
+ foreach $x (@stack) {
+ print $x->[0],"\n";
+ }
+ die "Try rerunning dprofpp with -F.\n";
+ # I don't want -F to be default behavior--yet
+ # 9/18/95 dmr
+ }
+ else{
+ warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
+ foreach $x ( reverse @stack ){
+ $name = $x->[0];
+ exitstamp( \@stack, \@tstack,
+ $t - $overhead, $times,
+ $ctimes, $name, \$in, $tab,
+ $curdeep_times, \%outer );
+ add_to_tree($curdeep_times, $name,
+ $t - $overhead)
+ if $opt_S;
+ }
+ }
+ }
+ if (defined $opt_g) {
+ $runtime = $ctimes->{$opt_g}/$hz;
+ $runtime = 0 unless $runtime > 0;
+ }
+}
+
+sub exitstamp {
+ my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep, $outer) = @_;
+ my( $x, $c, $z );
+
+ $x = pop( @$stack );
+ if( ! defined $x ){
+ die "Garbled profile, missing an enter time stamp";
+ }
+ if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
+ if ($x->[0] =~ /(?:::)?AUTOLOAD$/) {
+ if ($opt_A) {
+ $name = $x->[0];
+ }
+ } elsif ( $opt_F ) {
+ warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
+ $name = $x->[0];
+ } else {
+ foreach $z (@stack, $x) {
+ print $z->[0],"\n";
+ }
+ die "Garbled profile, unexpected exit time stamp";
+ }
+ }
+ if( $opt_T || $opt_t ){
+ $$in -= $tab;
+ }
+ # collect childtime
+ $c = pop( @$tstack );
+ # total time this func has been active
+ $z = $t - $x->[1];
+ $ctimes->{$name} += $z
+ unless --$outer->{$name};
+ $times->{$name} += $z - $c;
+ # pass my time to my parent
+ if( @$tstack ){
+ $c = pop( @$tstack );
+ push( @$tstack, $c + $z );
+ }
+}
+
+
+sub header {
+ my $fh = shift;
+ chop($_ = <$fh>);
+ if( ! /^#fOrTyTwO$/ ){
+ die "Not a perl profile";
+ }
+ while(<$fh>){
+ next if /^#/;
+ last if /^PART/;
+ eval;
+ }
+ $over_tests = 1 unless $over_tests;
+ $time_precision = length int ($hz - 1); # log ;-)
+}
+
+
+# Report avg time-per-function in seconds
+sub percalc {
+ my( $calls, $times, $persecs, $idkeys ) = @_;
+ my( $x, $t, $n, $key );
+
+ for( $x = 0; $x < @$idkeys; ++$x ){
+ $key = $idkeys->[$x];
+ $n = $calls->{$key};
+ $t = $times->{$key} / $hz;
+ $persecs->{$key} = $t ? $t / $n : 0;
+ }
+}
+
+
+# Runs the given script with the given profiler and the given perl.
+sub run_profiler {
+ my $script = shift;
+ my $profiler = shift;
+ my $startperl = shift;
+ my @script_parts = split /\s+/, $script;
+
+ system $startperl, "-d:$profiler", @script_parts;
+ if( $? / 256 > 0 ){
+ my $cmd = join ' ', @script_parts;
+ die "Failed: $startperl -d:$profiler $cmd: $!";
+ }
+}
+
+
+sub by_time { $times->{$b} <=> $times->{$a} }
+sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
+sub by_calls { $calls->{$b} <=> $calls->{$a} }
+sub by_alpha { $names->{$a} cmp $names->{$b} }
+sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
+# Reversed
+sub rby_time { $times->{$a} <=> $times->{$b} }
+sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
+sub rby_calls { $calls->{$a} <=> $calls->{$b} }
+sub rby_alpha { $names->{$b} cmp $names->{$a} }
+sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
+
+
+format CSTAT_top =
+Total Elapsed Time = @>>>>>>> Seconds
+(($rrun_rtime - $overhead) / $hz)
+ @>>>>>>>>>> Time = @>>>>>>> Seconds
+$whichtime, $runtime
+@<<<<<<<< Times
+$incl_excl
+%Time ExclSec CumulS #Calls sec/call Csec/c Name
+.
+
+BEGIN {
+ my $fmt = ' ^>>> ^>>>> ^>>>>> ^>>>>> ^>>>>> ^>>>>> ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
+ if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
+ {
+ $fmt .= '<' x ($cols - length $fmt) if $cols > 80;
+ }
+
+ eval "format STAT = \n$fmt" . '
+$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
+.';
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/enc2xs b/Master/tlpkg/tlperl/bin/enc2xs new file mode 100755 index 00000000000..773c0a09fba --- /dev/null +++ b/Master/tlpkg/tlperl/bin/enc2xs @@ -0,0 +1,1407 @@ +#!./perl +BEGIN { + # @INC poking no longer needed w/ new MakeMaker and Makefile.PL's + # with $ENV{PERL_CORE} set + # In case we need it in future... + require Config; import Config; +} +use strict; +use warnings; +use Getopt::Std; +use Config; +my @orig_ARGV = @ARGV; +our $VERSION = do { my @r = (q$Revision: 2.7 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +# These may get re-ordered. +# RAW is a do_now as inserted by &enter +# AGG is an aggreagated do_now, as built up by &process + +use constant { + RAW_NEXT => 0, + RAW_IN_LEN => 1, + RAW_OUT_BYTES => 2, + RAW_FALLBACK => 3, + + AGG_MIN_IN => 0, + AGG_MAX_IN => 1, + AGG_OUT_BYTES => 2, + AGG_NEXT => 3, + AGG_IN_LEN => 4, + AGG_OUT_LEN => 5, + AGG_FALLBACK => 6, +}; + +# (See the algorithm in encengine.c - we're building structures for it) + +# There are two sorts of structures. +# "do_now" (an array, two variants of what needs storing) is whatever we need +# to do now we've read an input byte. +# It's housed in a "do_next" (which is how we got to it), and in turn points +# to a "do_next" which contains all the "do_now"s for the next input byte. + +# There will be a "do_next" which is the start state. +# For a single byte encoding it's the only "do_next" - each "do_now" points +# back to it, and each "do_now" will cause bytes. There is no state. + +# For a multi-byte encoding where all characters in the input are the same +# length, then there will be a tree of "do_now"->"do_next"->"do_now" +# branching out from the start state, one step for each input byte. +# The leaf "do_now"s will all be at the same distance from the start state, +# only the leaf "do_now"s cause output bytes, and they in turn point back to +# the start state. + +# For an encoding where there are varaible length input byte sequences, you +# will encounter a leaf "do_now" sooner for the shorter input sequences, but +# as before the leaves will point back to the start state. + +# The system will cope with escape encodings (imagine them as a mostly +# self-contained tree for each escape state, and cross links between trees +# at the state-switching characters) but so far no input format defines these. + +# The system will also cope with having output "leaves" in the middle of +# the bifurcating branches, not just at the extremities, but again no +# input format does this yet. + +# There are two variants of the "do_now" structure. The first, smaller variant +# is generated by &enter as the input file is read. There is one structure +# for each input byte. Say we are mapping a single byte encoding to a +# single byte encoding, with "ABCD" going "abcd". There will be +# 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...} + +# &process then walks the tree, building aggregate "do_now" structres for +# adjacent bytes where possible. The aggregate is for a contiguous range of +# bytes which each produce the same length of output, each move to the +# same next state, and each have the same fallback flag. +# So our 4 RAW "do_now"s above become replaced by a single structure +# containing: +# ["A", "D", "abcd", 1, ...] +# ie, for an input byte $_ in "A".."D", output 1 byte, found as +# substr ("abcd", (ord $_ - ord "A") * 1, 1) +# which maps very nicely into pointer arithmetic in C for encengine.c + +sub encode_U +{ + # UTF-8 encode long hand - only covers part of perl's range + ## my $uv = shift; + # chr() works in native space so convert value from table + # into that space before using chr(). + my $ch = chr(utf8::unicode_to_native($_[0])); + # Now get core perl to encode that the way it likes. + utf8::encode($ch); + return $ch; +} + +sub encode_S +{ + # encode single byte + ## my ($ch,$page) = @_; return chr($ch); + return chr $_[0]; +} + +sub encode_D +{ + # encode double byte MS byte first + ## my ($ch,$page) = @_; return chr($page).chr($ch); + return chr ($_[1]) . chr $_[0]; +} + +sub encode_M +{ + # encode Multi-byte - single for 0..255 otherwise double + ## my ($ch,$page) = @_; + ## return &encode_D if $page; + ## return &encode_S; + return chr ($_[1]) . chr $_[0] if $_[1]; + return chr $_[0]; +} + +my %encode_types = (U => \&encode_U, + S => \&encode_S, + D => \&encode_D, + M => \&encode_M, + ); + +# Win32 does not expand globs on command line +eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32'); + +my %opt; +# I think these are: +# -Q to disable the duplicate codepoint test +# -S make mapping errors fatal +# -q to remove comments written to output files +# -O to enable the (brute force) substring optimiser +# -o <output> to specify the output file name (else it's the first arg) +# -f <inlist> to give a file with a list of input files (else use the args) +# -n <name> to name the encoding (else use the basename of the input file. +getopts('CM:SQqOo:f:n:',\%opt); + +$opt{M} and make_makefile_pl($opt{M}, @ARGV); +$opt{C} and make_configlocal_pm($opt{C}, @ARGV); + +# This really should go first, else the die here causes empty (non-erroneous) +# output files to be written. +my @encfiles; +if (exists $opt{'f'}) { + # -F is followed by name of file containing list of filenames + my $flist = $opt{'f'}; + open(FLIST,$flist) || die "Cannot open $flist:$!"; + chomp(@encfiles = <FLIST>); + close(FLIST); +} else { + @encfiles = @ARGV; +} + +my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV); +chmod(0666,$cname) if -f $cname && !-w $cname; +open(C,">$cname") || die "Cannot open $cname:$!"; + +my $dname = $cname; +my $hname = $cname; + +my ($doC,$doEnc,$doUcm,$doPet); + +if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined + { + $doC = 1; + $dname =~ s/(\.[^\.]*)?$/.exh/; + chmod(0666,$dname) if -f $cname && !-w $dname; + open(D,">$dname") || die "Cannot open $dname:$!"; + $hname =~ s/(\.[^\.]*)?$/.h/; + chmod(0666,$hname) if -f $cname && !-w $hname; + open(H,">$hname") || die "Cannot open $hname:$!"; + + foreach my $fh (\*C,\*D,\*H) + { + print $fh <<"END" unless $opt{'q'}; +/* + !!!!!!! DO NOT EDIT THIS FILE !!!!!!! + This file was autogenerated by: + $^X $0 @orig_ARGV + enc2xs VERSION $VERSION +*/ +END + } + + if ($cname =~ /(\w+)\.xs$/) + { + print C "#include <EXTERN.h>\n"; + print C "#include <perl.h>\n"; + print C "#include <XSUB.h>\n"; + print C "#define U8 U8\n"; + } + print C "#include \"encode.h\"\n\n"; + + } +elsif ($cname =~ /\.enc$/) + { + $doEnc = 1; + } +elsif ($cname =~ /\.ucm$/) + { + $doUcm = 1; + } +elsif ($cname =~ /\.pet$/) + { + $doPet = 1; + } + +my %encoding; +my %strings; +my $string_acc; +my %strings_in_acc; + +my $saved = 0; +my $subsave = 0; +my $strings = 0; + +sub cmp_name +{ + if ($a =~ /^.*-(\d+)/) + { + my $an = $1; + if ($b =~ /^.*-(\d+)/) + { + my $r = $an <=> $1; + return $r if $r; + } + } + return $a cmp $b; +} + + +foreach my $enc (sort cmp_name @encfiles) + { + my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/; + $name = $opt{'n'} if exists $opt{'n'}; + if (open(E,$enc)) + { + if ($sfx eq 'enc') + { + compile_enc(\*E,lc($name)); + } + else + { + compile_ucm(\*E,lc($name)); + } + } + else + { + warn "Cannot open $enc for $name:$!"; + } + } + +if ($doC) + { + print STDERR "Writing compiled form\n"; + foreach my $name (sort cmp_name keys %encoding) + { + my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}}; + process($name.'_utf8',$e2u); + addstrings(\*C,$e2u); + + process('utf8_'.$name,$u2e); + addstrings(\*C,$u2e); + } + outbigstring(\*C,"enctable"); + foreach my $name (sort cmp_name keys %encoding) + { + my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}}; + outtable(\*C,$e2u, "enctable"); + outtable(\*C,$u2e, "enctable"); + + # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep)); + } + my $cpp = ($Config{d_cplusplus} || '') eq 'define'; + my $exta = $cpp ? 'extern "C" ' : "static"; + my $extb = $cpp ? 'extern "C" ' : ""; + foreach my $enc (sort cmp_name keys %encoding) + { + # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}}; + my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}}; + #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el); + my $replen = 0; + $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g); + my $sym = "${enc}_encoding"; + $sym =~ s/\W+/_/g; + my @info = ($e2u->{Cname},$u2e->{Cname},"${sym}_rep_character",$replen, + $min_el,$max_el); + print C "${exta} const U8 ${sym}_rep_character[] = \"$rep\";\n"; + print C "${exta} const char ${sym}_enc_name[] = \"$enc\";\n\n"; + print C "${extb} const encode_t $sym = \n"; + # This is to make null encoding work -- dankogai + for (my $i = (scalar @info) - 1; $i >= 0; --$i){ + $info[$i] ||= 1; + } + # end of null tweak -- dankogai + print C " {",join(',',@info,"{${sym}_enc_name,(const char *)0}"),"};\n\n"; + } + + foreach my $enc (sort cmp_name keys %encoding) + { + my $sym = "${enc}_encoding"; + $sym =~ s/\W+/_/g; + print H "extern encode_t $sym;\n"; + print D " Encode_XSEncoding(aTHX_ &$sym);\n"; + } + + if ($cname =~ /(\w+)\.xs$/) + { + my $mod = $1; + print C <<'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); +} + +END + + print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n"; + print C "BOOT:\n{\n"; + print C "#include \"$dname\"\n"; + print C "}\n"; + } + # Close in void context is bad, m'kay + close(D) or warn "Error closing '$dname': $!"; + close(H) or warn "Error closing '$hname': $!"; + + my $perc_saved = $saved/($strings + $saved) * 100; + my $perc_subsaved = $subsave/($strings + $subsave) * 100; + printf STDERR "%d bytes in string tables\n",$strings; + printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n", + $saved, $perc_saved if $saved; + printf STDERR "%d bytes (%.3g%%) saved using substrings\n", + $subsave, $perc_subsaved if $subsave; + } +elsif ($doEnc) + { + foreach my $name (sort cmp_name keys %encoding) + { + my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}}; + output_enc(\*C,$name,$e2u); + } + } +elsif ($doUcm) + { + foreach my $name (sort cmp_name keys %encoding) + { + my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}}; + output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el); + } + } + +# writing half meg files and then not checking to see if you just filled the +# disk is bad, m'kay +close(C) or die "Error closing '$cname': $!"; + +# End of the main program. + +sub compile_ucm +{ + my ($fh,$name) = @_; + my $e2u = {}; + my $u2e = {}; + my $cs; + my %attr; + while (<$fh>) + { + s/#.*$//; + last if /^\s*CHARMAP\s*$/i; + if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr + { + $attr{$1} = $2; + } + } + if (!defined($cs = $attr{'code_set_name'})) + { + warn "No <code_set_name> in $name\n"; + } + else + { + $name = $cs unless exists $opt{'n'}; + } + my $erep; + my $urep; + my $max_el; + my $min_el; + if (exists $attr{'subchar'}) + { + #my @byte; + #$attr{'subchar'} =~ /^\s*/cg; + #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg; + #$erep = join('',map(chr(hex($_)),@byte)); + $erep = $attr{'subchar'}; + $erep =~ s/^\s+//; $erep =~ s/\s+$//; + } + print "Reading $name ($cs)\n"; + my $nfb = 0; + my $hfb = 0; + while (<$fh>) + { + s/#.*$//; + last if /^\s*END\s+CHARMAP\s*$/i; + next if /^\s*$/; + my (@uni, @byte) = (); + my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o + or die "Bad line: $_"; + while ($uni =~ m/\G<([U0-9a-fA-F\+]+)>/g){ + push @uni, map { substr($_, 1) } split(/\+/, $1); + } + while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){ + push @byte, $1; + } + if (@uni) + { + my $uch = join('', map { encode_U(hex($_)) } @uni ); + my $ech = join('',map(chr(hex($_)),@byte)); + my $el = length($ech); + $max_el = $el if (!defined($max_el) || $el > $max_el); + $min_el = $el if (!defined($min_el) || $el < $min_el); + if (length($fb)) + { + $fb = substr($fb,1); + $hfb++; + } + else + { + $nfb++; + $fb = '0'; + } + # $fb is fallback flag + # 0 - round trip safe + # 1 - fallback for unicode -> enc + # 2 - skip sub-char mapping + # 3 - fallback enc -> unicode + enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/); + enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/); + } + else + { + warn $_; + } + } + if ($nfb && $hfb) + { + die "$nfb entries without fallback, $hfb entries with\n"; + } + $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el]; +} + + + +sub compile_enc +{ + my ($fh,$name) = @_; + my $e2u = {}; + my $u2e = {}; + + my $type; + while ($type = <$fh>) + { + last if $type !~ /^\s*#/; + } + chomp($type); + return if $type eq 'E'; + # Do the hash lookup once, rather than once per function call. 4% speedup. + my $type_func = $encode_types{$type}; + my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>)); + warn "$type encoded $name\n"; + my $rep = ''; + # Save a defined test by setting these to defined values. + my $min_el = ~0; # A very big integer + my $max_el = 0; # Anything must be longer than 0 + { + my $v = hex($def); + $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe); + } + my $errors; + my $seen; + # use -Q to silence the seen test. Makefile.PL uses this by default. + $seen = {} unless $opt{Q}; + do + { + my $line = <$fh>; + chomp($line); + my $page = hex($line); + my $ch = 0; + my $i = 16; + do + { + # So why is it 1% faster to leave the my here? + my $line = <$fh>; + $line =~ s/\r\n$/\n/; + die "$.:${line}Line should be exactly 65 characters long including + newline (".length($line).")" unless length ($line) == 65; + # Split line into groups of 4 hex digits, convert groups to ints + # This takes 65.35 + # map {hex $_} $line =~ /(....)/g + # This takes 63.75 (2.5% less time) + # unpack "n*", pack "H*", $line + # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay + # Doing it as while ($line =~ /(....)/g) took 74.63 + foreach my $val (unpack "n*", pack "H*", $line) + { + next if $val == 0xFFFD; + my $ech = &$type_func($ch,$page); + if ($val || (!$ch && !$page)) + { + my $el = length($ech); + $max_el = $el if $el > $max_el; + $min_el = $el if $el < $min_el; + my $uch = encode_U($val); + if ($seen) { + # We're doing the test. + # We don't need to read this quickly, so storing it as a scalar, + # rather than 3 (anon array, plus the 2 scalars it holds) saves + # RAM and may make us faster on low RAM systems. [see __END__] + if (exists $seen->{$uch}) + { + warn sprintf("U%04X is %02X%02X and %04X\n", + $val,$page,$ch,$seen->{$uch}); + $errors++; + } + else + { + $seen->{$uch} = $page << 8 | $ch; + } + } + # Passing 2 extra args each time is 3.6% slower! + # Even with having to add $fallback ||= 0 later + enter_fb0($e2u,$ech,$uch); + enter_fb0($u2e,$uch,$ech); + } + else + { + # No character at this position + # enter($e2u,$ech,undef,$e2u); + } + $ch++; + } + } while --$i; + } while --$pages; + die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines" + if $min_el > $max_el; + die "$errors mapping conflicts\n" if ($errors && $opt{'S'}); + $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el]; +} + +# my ($a,$s,$d,$t,$fb) = @_; +sub enter { + my ($current,$inbytes,$outbytes,$next,$fallback) = @_; + # state we shift to after this (multibyte) input character defaults to same + # as current state. + $next ||= $current; + # Making sure it is defined seems to be faster than {no warnings;} in + # &process, or passing it in as 0 explicity. + # XXX $fallback ||= 0; + + # Start at the beginning and work forwards through the string to zero. + # effectively we are removing 1 character from the front each time + # but we don't actually edit the string. [this alone seems to be 14% speedup] + # Hence -$pos is the length of the remaining string. + my $pos = -length $inbytes; + while (1) { + my $byte = substr $inbytes, $pos, 1; + # RAW_NEXT => 0, + # RAW_IN_LEN => 1, + # RAW_OUT_BYTES => 2, + # RAW_FALLBACK => 3, + # to unicode an array would seem to be better, because the pages are dense. + # from unicode can be very sparse, favouring a hash. + # hash using the bytes (all length 1) as keys rather than ord value, + # as it's easier to sort these in &process. + + # It's faster to always add $fallback even if it's undef, rather than + # choosing between 3 and 4 element array. (hence why we set it defined + # above) + my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback]; + # When $pos was -1 we were at the last input character. + unless (++$pos) { + $do_now->[RAW_OUT_BYTES] = $outbytes; + $do_now->[RAW_NEXT] = $next; + return; + } + # Tail recursion. The intermdiate state may not have a name yet. + $current = $do_now->[RAW_NEXT]; + } +} + +# This is purely for optimistation. It's just &enter hard coded for $fallback +# of 0, using only a 3 entry array ref to save memory for every entry. +sub enter_fb0 { + my ($current,$inbytes,$outbytes,$next) = @_; + $next ||= $current; + + my $pos = -length $inbytes; + while (1) { + my $byte = substr $inbytes, $pos, 1; + my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'']; + unless (++$pos) { + $do_now->[RAW_OUT_BYTES] = $outbytes; + $do_now->[RAW_NEXT] = $next; + return; + } + $current = $do_now->[RAW_NEXT]; + } +} + +sub process +{ + my ($name,$a) = @_; + $name =~ s/\W+/_/g; + $a->{Cname} = $name; + my $raw = $a->{Raw}; + my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback); + my @ent; + $agg_max_in = 0; + foreach my $key (sort keys %$raw) { + # RAW_NEXT => 0, + # RAW_IN_LEN => 1, + # RAW_OUT_BYTES => 2, + # RAW_FALLBACK => 3, + my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}}; + # Now we are converting from raw to aggregate, switch from 1 byte strings + # to numbers + my $b = ord $key; + $fallback ||= 0; + if ($l && + # If this == fails, we're going to reset $agg_max_in below anyway. + $b == ++$agg_max_in && + # References in numeric context give the pointer as an int. + $agg_next == $next && + $agg_in_len == $in_len && + $agg_out_len == length $out_bytes && + $agg_fallback == $fallback + # && length($l->[AGG_OUT_BYTES]) < 16 + ) { + # my $i = ord($b)-ord($l->[AGG_MIN_IN]); + # we can aggregate this byte onto the end. + $l->[AGG_MAX_IN] = $b; + $l->[AGG_OUT_BYTES] .= $out_bytes; + } else { + # AGG_MIN_IN => 0, + # AGG_MAX_IN => 1, + # AGG_OUT_BYTES => 2, + # AGG_NEXT => 3, + # AGG_IN_LEN => 4, + # AGG_OUT_LEN => 5, + # AGG_FALLBACK => 6, + # Reset the last thing we saw, plus set 5 lexicals to save some derefs. + # (only gains .6% on euc-jp -- is it worth it?) + push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next, + $agg_in_len = $in_len, $agg_out_len = length $out_bytes, + $agg_fallback = $fallback]; + } + if (exists $next->{Cname}) { + $next->{'Forward'} = 1 if $next != $a; + } else { + process(sprintf("%s_%02x",$name,$b),$next); + } + } + # encengine.c rules say that last entry must be for 255 + if ($agg_max_in < 255) { + push @ent, [1+$agg_max_in, 255,undef,$a,0,0]; + } + $a->{'Entries'} = \@ent; +} + + +sub addstrings +{ + my ($fh,$a) = @_; + my $name = $a->{'Cname'}; + # String tables + foreach my $b (@{$a->{'Entries'}}) + { + next unless $b->[AGG_OUT_LEN]; + $strings{$b->[AGG_OUT_BYTES]} = undef; + } + if ($a->{'Forward'}) + { + my $cpp = ($Config{d_cplusplus} || '') eq 'define'; + my $var = $^O eq 'MacOS' || $cpp ? 'extern' : 'static'; + my $const = $cpp ? '' : 'const'; + print $fh "$var $const encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n"; + } + $a->{'DoneStrings'} = 1; + foreach my $b (@{$a->{'Entries'}}) + { + my ($s,$e,$out,$t,$end,$l) = @$b; + addstrings($fh,$t) unless $t->{'DoneStrings'}; + } +} + +sub outbigstring +{ + my ($fh,$name) = @_; + + $string_acc = ''; + + # Make the big string in the string accumulator. Longest first, on the hope + # that this makes it more likely that we find the short strings later on. + # Not sure if it helps sorting strings of the same length lexcically. + foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) { + my $index = index $string_acc, $s; + if ($index >= 0) { + $saved += length($s); + $strings_in_acc{$s} = $index; + } else { + OPTIMISER: { + if ($opt{'O'}) { + my $sublength = length $s; + while (--$sublength > 0) { + # progressively lop characters off the end, to see if the start of + # the new string overlaps the end of the accumulator. + if (substr ($string_acc, -$sublength) + eq substr ($s, 0, $sublength)) { + $subsave += $sublength; + $strings_in_acc{$s} = length ($string_acc) - $sublength; + # append the last bit on the end. + $string_acc .= substr ($s, $sublength); + last OPTIMISER; + } + # or if the end of the new string overlaps the start of the + # accumulator + next unless substr ($string_acc, 0, $sublength) + eq substr ($s, -$sublength); + # well, the last $sublength characters of the accumulator match. + # so as we're prepending to the accumulator, need to shift all our + # existing offsets forwards + $_ += $sublength foreach values %strings_in_acc; + $subsave += $sublength; + $strings_in_acc{$s} = 0; + # append the first bit on the start. + $string_acc = substr ($s, 0, -$sublength) . $string_acc; + last OPTIMISER; + } + } + # Optimiser (if it ran) found nothing, so just going have to tack the + # whole thing on the end. + $strings_in_acc{$s} = length $string_acc; + $string_acc .= $s; + }; + } + } + + $strings = length $string_acc; + my $cpp = ($Config{d_cplusplus} || '') eq 'define'; + my $var = $cpp ? '' : 'static'; + my $definition = "\n$var const U8 $name\[$strings] = { " . + join(',',unpack "C*",$string_acc); + # We have a single long line. Split it at convenient commas. + print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs; + print $fh substr ($definition, pos $definition), " };\n"; +} + +sub findstring { + my ($name,$s) = @_; + my $offset = $strings_in_acc{$s}; + die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator" + unless defined $offset; + "$name + $offset"; +} + +sub outtable +{ + my ($fh,$a,$bigname) = @_; + my $name = $a->{'Cname'}; + $a->{'Done'} = 1; + foreach my $b (@{$a->{'Entries'}}) + { + my ($s,$e,$out,$t,$end,$l) = @$b; + outtable($fh,$t,$bigname) unless $t->{'Done'}; + } + my $cpp = ($Config{d_cplusplus} || '') eq 'define'; + my $var = $cpp ? '' : 'static'; + my $const = $cpp ? '' : 'const'; + print $fh "\n$var $const encpage_t $name\[", + scalar(@{$a->{'Entries'}}), "] = {\n"; + foreach my $b (@{$a->{'Entries'}}) + { + my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b; + # $end |= 0x80 if $fb; # what the heck was on your mind, Nick? -- Dan + print $fh "{"; + if ($l) + { + printf $fh findstring($bigname,$out); + } + else + { + print $fh "0"; + } + print $fh ",",$t->{Cname}; + printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec; + } + print $fh "};\n"; +} + +sub output_enc +{ + my ($fh,$name,$a) = @_; + die "Changed - fix me for new structure"; + foreach my $b (sort keys %$a) + { + my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}}; + } +} + +sub decode_U +{ + my $s = shift; +} + +my @uname; +sub char_names +{ + my $s = do "unicore/Name.pl"; + die "char_names: unicore/Name.pl: $!\n" unless defined $s; + pos($s) = 0; + while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc) + { + my $name = $3; + my $s = hex($1); + last if $s >= 0x10000; + my $e = length($2) ? hex($2) : $s; + for (my $i = $s; $i <= $e; $i++) + { + $uname[$i] = $name; +# print sprintf("U%04X $name\n",$i); + } + } +} + +sub output_ucm_page +{ + my ($cmap,$a,$t,$pre) = @_; + # warn sprintf("Page %x\n",$pre); + my $raw = $t->{Raw}; + foreach my $key (sort keys %$raw) { + # RAW_NEXT => 0, + # RAW_IN_LEN => 1, + # RAW_OUT_BYTES => 2, + # RAW_FALLBACK => 3, + my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}}; + my $u = ord $key; + $fallback ||= 0; + + if ($next != $a && $next != $t) { + output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF); + } elsif (length $out_bytes) { + if ($pre) { + $u = $pre|($u &0x3f); + } + my $s = sprintf "<U%04X> ",$u; + #foreach my $c (split(//,$out_bytes)) { + # $s .= sprintf "\\x%02X",ord($c); + #} + # 9.5% faster changing that loop to this: + $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes; + $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u]; + push(@$cmap,$s); + } else { + warn join(',',$u, @{$raw->{$key}},$a,$t); + } + } +} + +sub output_ucm +{ + my ($fh,$name,$h,$rep,$min_el,$max_el) = @_; + print $fh "# $0 @orig_ARGV\n" unless $opt{'q'}; + print $fh "<code_set_name> \"$name\"\n"; + char_names(); + if (defined $min_el) + { + print $fh "<mb_cur_min> $min_el\n"; + } + if (defined $max_el) + { + print $fh "<mb_cur_max> $max_el\n"; + } + if (defined $rep) + { + print $fh "<subchar> "; + foreach my $c (split(//,$rep)) + { + printf $fh "\\x%02X",ord($c); + } + print $fh "\n"; + } + my @cmap; + output_ucm_page(\@cmap,$h,$h,0); + print $fh "#\nCHARMAP\n"; + foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap) + { + print $fh $line; + } + print $fh "END CHARMAP\n"; +} + +use vars qw( + $_Enc2xs + $_Version + $_Inc + $_E2X + $_Name + $_TableFiles + $_Now +); + +sub find_e2x{ + eval { require File::Find; }; + my (@inc, %e2x_dir); + for my $inc (@INC){ + push @inc, $inc unless $inc eq '.'; #skip current dir + } + File::Find::find( + sub { + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) + = lstat($_) or return; + -f _ or return; + if (/^.*\.e2x$/o){ + no warnings 'once'; + $e2x_dir{$File::Find::dir} ||= $mtime; + } + return; + }, @inc); + warn join("\n", keys %e2x_dir), "\n"; + for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){ + $_E2X = $d; + # warn "$_E2X => ", scalar localtime($e2x_dir{$d}); + return $_E2X; + } +} + +sub make_makefile_pl +{ + eval { require Encode; }; + $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n"; + # our used for variable expanstion + $_Enc2xs = $0; + $_Version = $VERSION; + $_E2X = find_e2x(); + $_Name = shift; + $_TableFiles = join(",", map {qq('$_')} @_); + $_Now = scalar localtime(); + + eval { require File::Spec; }; + _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL"); + _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"), "$_Name.pm"); + _print_expand(File::Spec->catfile($_E2X,"_T.e2x"), "t/$_Name.t"); + _print_expand(File::Spec->catfile($_E2X,"README.e2x"), "README"); + _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"), "Changes"); + exit; +} + +use vars qw( + $_ModLines + $_LocalVer + ); + +sub make_configlocal_pm { + eval { require Encode; }; + $@ and die "Unable to require Encode: $@\n"; + eval { require File::Spec; }; + + # our used for variable expanstion + my %in_core = map { $_ => 1 } ( + 'ascii', 'iso-8859-1', 'utf8', + 'ascii-ctrl', 'null', 'utf-8-strict' + ); + my %LocalMod = (); + # check @enc; + use File::Find (); + my $wanted = sub{ + -f $_ or return; + $File::Find::name =~ /\A\./ and return; + $File::Find::name =~ /\.pm\z/ or return; + $File::Find::name =~ m/\bEncode\b/ or return; + my $mod = $File::Find::name; + $mod =~ s/.*\bEncode\b/Encode/o; + $mod =~ s/\.pm\z//o; + $mod =~ s,/,::,og; + warn qq{ require $mod;\n}; + eval qq{ require $mod; }; + $@ and die "Can't require $mod: $@\n"; + for my $enc ( Encode->encodings() ) { + no warnings; + $in_core{$enc} and next; + $Encode::Config::ExtModule{$enc} and next; + $LocalMod{$enc} ||= $mod; + } + }; + File::Find::find({wanted => $wanted}, @INC); + $_ModLines = ""; + for my $enc ( sort keys %LocalMod ) { + $_ModLines .= + qq(\$Encode::ExtModule{'$enc'} = "$LocalMod{$enc}";\n); + } + warn $_ModLines; + $_LocalVer = _mkversion(); + $_E2X = find_e2x(); + $_Inc = $INC{"Encode.pm"}; + $_Inc =~ s/\.pm$//o; + _print_expand( File::Spec->catfile( $_E2X, "ConfigLocal_PM.e2x" ), + File::Spec->catfile( $_Inc, "ConfigLocal.pm" ), 1 ); + exit; +} + +sub _mkversion{ + # v-string is now depreciated; use time() instead; + #my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime(); + #$yyyy += 1900, $mo +=1; + #return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm); + return time(); +} + +sub _print_expand{ + eval { require File::Basename; }; + $@ and die "File::Basename needed. Are you on miniperl?;\nerror: $@\n"; + File::Basename->import(); + my ($src, $dst, $clobber) = @_; + if (!$clobber and -e $dst){ + warn "$dst exists. skipping\n"; + return; + } + warn "Generating $dst...\n"; + open my $in, $src or die "$src : $!"; + if ((my $d = dirname($dst)) ne '.'){ + -d $d or mkdir $d, 0755 or die "mkdir $d : $!"; + } + open my $out, ">$dst" or die "$!"; + my $asis = 0; + while (<$in>){ + if (/^#### END_OF_HEADER/){ + $asis = 1; next; + } + s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis; + print $out $_; + } +} +__END__ + +=head1 NAME + +enc2xs -- Perl Encode Module Generator + +=head1 SYNOPSIS + + enc2xs -[options] + enc2xs -M ModName mapfiles... + enc2xs -C + +=head1 DESCRIPTION + +F<enc2xs> builds a Perl extension for use by Encode from either +Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc). +Besides being used internally during the build process of the Encode +module, you can use F<enc2xs> to add your own encoding to perl. +No knowledge of XS is necessary. + +=head1 Quick Guide + +If you want to know as little about Perl as possible but need to +add a new encoding, just read this chapter and forget the rest. + +=over 4 + +=item 0. + +Have a .ucm file ready. You can get it from somewhere or you can write +your own from scratch or you can grab one from the Encode distribution +and customize it. For the UCM format, see the next Chapter. In the +example below, I'll call my theoretical encoding myascii, defined +in I<my.ucm>. C<$> is a shell prompt. + + $ ls -F + my.ucm + +=item 1. + +Issue a command as follows; + + $ enc2xs -M My my.ucm + generating Makefile.PL + generating My.pm + generating README + generating Changes + +Now take a look at your current directory. It should look like this. + + $ ls -F + Makefile.PL My.pm my.ucm t/ + +The following files were created. + + Makefile.PL - MakeMaker script + My.pm - Encode submodule + t/My.t - test file + +=over 4 + +=item 1.1. + +If you want *.ucm installed together with the modules, do as follows; + + $ mkdir Encode + $ mv *.ucm Encode + $ enc2xs -M My Encode/*ucm + +=back + +=item 2. + +Edit the files generated. You don't have to if you have no time AND no +intention to give it to someone else. But it is a good idea to edit +the pod and to add more tests. + +=item 3. + +Now issue a command all Perl Mongers love: + + $ perl Makefile.PL + Writing Makefile for Encode::My + +=item 4. + +Now all you have to do is make. + + $ make + cp My.pm blib/lib/Encode/My.pm + /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \ + -o encode_t.c -f encode_t.fnm + Reading myascii (myascii) + Writing compiled form + 128 bytes in string tables + 384 bytes (75%) saved spotting duplicates + 1 bytes (0.775%) saved using substrings + .... + chmod 644 blib/arch/auto/Encode/My/My.bs + $ + +The time it takes varies depending on how fast your machine is and +how large your encoding is. Unless you are working on something big +like euc-tw, it won't take too long. + +=item 5. + +You can "make install" already but you should test first. + + $ make test + PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \ + -e 'use Test::Harness qw(&runtests $verbose); \ + $verbose=0; runtests @ARGV;' t/*.t + t/My....ok + All tests successful. + Files=1, Tests=2, 0 wallclock secs + ( 0.09 cusr + 0.01 csys = 0.09 CPU) + +=item 6. + +If you are content with the test result, just "make install" + +=item 7. + +If you want to add your encoding to Encode's demand-loading list +(so you don't have to "use Encode::YourEncoding"), run + + enc2xs -C + +to update Encode::ConfigLocal, a module that controls local settings. +After that, "use Encode;" is enough to load your encodings on demand. + +=back + +=head1 The Unicode Character Map + +Encode uses the Unicode Character Map (UCM) format for source character +mappings. This format is used by IBM's ICU package and was adopted +by Nick Ing-Simmons for use with the Encode module. Since UCM is +more flexible than Tcl's Encoding Map and far more user-friendly, +this is the recommended format for Encode now. + +A UCM file looks like this. + + # + # Comments + # + <code_set_name> "US-ascii" # Required + <code_set_alias> "ascii" # Optional + <mb_cur_min> 1 # Required; usually 1 + <mb_cur_max> 1 # Max. # of bytes/char + <subchar> \x3F # Substitution char + # + CHARMAP + <U0000> \x00 |0 # <control> + <U0001> \x01 |0 # <control> + <U0002> \x02 |0 # <control> + .... + <U007C> \x7C |0 # VERTICAL LINE + <U007D> \x7D |0 # RIGHT CURLY BRACKET + <U007E> \x7E |0 # TILDE + <U007F> \x7F |0 # <control> + END CHARMAP + +=over 4 + +=item * + +Anything that follows C<#> is treated as a comment. + +=item * + +The header section continues until a line containing the word +CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one +pair per line. Strings used as values must be quoted. Barewords are +treated as numbers. I<\xXX> represents a byte. + +Most of the keywords are self-explanatory. I<subchar> means +substitution character, not subcharacter. When you decode a Unicode +sequence to this encoding but no matching character is found, the byte +sequence defined here will be used. For most cases, the value here is +\x3F; in ASCII, this is a question mark. + +=item * + +CHARMAP starts the character map section. Each line has a form as +follows: + + <UXXXX> \xXX.. |0 # comment + ^ ^ ^ + | | +- Fallback flag + | +-------- Encoded byte sequence + +-------------- Unicode Character ID in hex + +The format is roughly the same as a header section except for the +fallback flag: | followed by 0..3. The meaning of the possible +values is as follows: + +=over 4 + +=item |0 + +Round trip safe. A character decoded to Unicode encodes back to the +same byte sequence. Most characters have this flag. + +=item |1 + +Fallback for unicode -> encoding. When seen, enc2xs adds this +character for the encode map only. + +=item |2 + +Skip sub-char mapping should there be no code point. + +=item |3 + +Fallback for encoding -> unicode. When seen, enc2xs adds this +character for the decode map only. + +=back + +=item * + +And finally, END OF CHARMAP ends the section. + +=back + +When you are manually creating a UCM file, you should copy ascii.ucm +or an existing encoding which is close to yours, rather than write +your own from scratch. + +When you do so, make sure you leave at least B<U0000> to B<U0020> as +is, unless your environment is EBCDIC. + +B<CAVEAT>: not all features in UCM are implemented. For example, +icu:state is not used. Because of that, you need to write a perl +module if you want to support algorithmical encodings, notably +the ISO-2022 series. Such modules include L<Encode::JP::2022_JP>, +L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>. + +=head2 Coping with duplicate mappings + +When you create a map, you SHOULD make your mappings round-trip safe. +That is, C<encode('your-encoding', decode('your-encoding', $data)) eq +$data> stands for all characters that are marked as C<|0>. Here is +how to make sure: + +=over 4 + +=item * + +Sort your map in Unicode order. + +=item * + +When you have a duplicate entry, mark either one with '|1' or '|3'. + +=item * + +And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry. + +=back + +Here is an example from big5-eten. + + <U2550> \xF9\xF9 |0 + <U2550> \xA2\xA4 |3 + +Internally Encoding -> Unicode and Unicode -> Encoding Map looks like +this; + + E to U U to E + -------------------------------------- + \xF9\xF9 => U2550 U2550 => \xF9\xF9 + \xA2\xA4 => U2550 + +So it is round-trip safe for \xF9\xF9. But if the line above is upside +down, here is what happens. + + E to U U to E + -------------------------------------- + \xA2\xA4 => U2550 U2550 => \xF9\xF9 + (\xF9\xF9 => U2550 is now overwritten!) + +The Encode package comes with F<ucmlint>, a crude but sufficient +utility to check the integrity of a UCM file. Check under the +Encode/bin directory for this. + +When in doubt, you can use F<ucmsort>, yet another utility under +Encode/bin directory. + +=head1 Bookmarks + +=over 4 + +=item * + +ICU Home Page +L<http://www.icu-project.org/> + +=item * + +ICU Character Mapping Tables +L<http://site.icu-project.org/charts/charset> + +=item * + +ICU:Conversion Data +L<http://www.icu-project.org/userguide/conversion-data.html> + +=back + +=head1 SEE ALSO + +L<Encode>, +L<perlmod>, +L<perlpod> + +=cut + +# -Q to disable the duplicate codepoint test +# -S make mapping errors fatal +# -q to remove comments written to output files +# -O to enable the (brute force) substring optimiser +# -o <output> to specify the output file name (else it's the first arg) +# -f <inlist> to give a file with a list of input files (else use the args) +# -n <name> to name the encoding (else use the basename of the input file. + +With %seen holding array refs: + + 865.66 real 28.80 user 8.79 sys + 7904 maximum resident set size + 1356 average shared memory size + 18566 average unshared data size + 229 average unshared stack size + 46080 page reclaims + 33373 page faults + +With %seen holding simple scalars: + + 342.16 real 27.11 user 3.54 sys + 8388 maximum resident set size + 1394 average shared memory size + 14969 average unshared data size + 236 average unshared stack size + 28159 page reclaims + 9839 page faults + +Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is +how %seen is storing things its seen. So it is pathalogically bad on a 16M +RAM machine, but it's going to help even on modern machines. +Swapping is bad, m'kay :-) diff --git a/Master/tlpkg/tlperl/bin/enc2xs.bat b/Master/tlpkg/tlperl/bin/enc2xs.bat new file mode 100755 index 00000000000..dfed5e1ec34 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/enc2xs.bat @@ -0,0 +1,1423 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!./perl
+#line 15
+BEGIN {
+ # @INC poking no longer needed w/ new MakeMaker and Makefile.PL's
+ # with $ENV{PERL_CORE} set
+ # In case we need it in future...
+ require Config; import Config;
+}
+use strict;
+use warnings;
+use Getopt::Std;
+use Config;
+my @orig_ARGV = @ARGV;
+our $VERSION = do { my @r = (q$Revision: 2.7 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
+# These may get re-ordered.
+# RAW is a do_now as inserted by &enter
+# AGG is an aggreagated do_now, as built up by &process
+
+use constant {
+ RAW_NEXT => 0,
+ RAW_IN_LEN => 1,
+ RAW_OUT_BYTES => 2,
+ RAW_FALLBACK => 3,
+
+ AGG_MIN_IN => 0,
+ AGG_MAX_IN => 1,
+ AGG_OUT_BYTES => 2,
+ AGG_NEXT => 3,
+ AGG_IN_LEN => 4,
+ AGG_OUT_LEN => 5,
+ AGG_FALLBACK => 6,
+};
+
+# (See the algorithm in encengine.c - we're building structures for it)
+
+# There are two sorts of structures.
+# "do_now" (an array, two variants of what needs storing) is whatever we need
+# to do now we've read an input byte.
+# It's housed in a "do_next" (which is how we got to it), and in turn points
+# to a "do_next" which contains all the "do_now"s for the next input byte.
+
+# There will be a "do_next" which is the start state.
+# For a single byte encoding it's the only "do_next" - each "do_now" points
+# back to it, and each "do_now" will cause bytes. There is no state.
+
+# For a multi-byte encoding where all characters in the input are the same
+# length, then there will be a tree of "do_now"->"do_next"->"do_now"
+# branching out from the start state, one step for each input byte.
+# The leaf "do_now"s will all be at the same distance from the start state,
+# only the leaf "do_now"s cause output bytes, and they in turn point back to
+# the start state.
+
+# For an encoding where there are varaible length input byte sequences, you
+# will encounter a leaf "do_now" sooner for the shorter input sequences, but
+# as before the leaves will point back to the start state.
+
+# The system will cope with escape encodings (imagine them as a mostly
+# self-contained tree for each escape state, and cross links between trees
+# at the state-switching characters) but so far no input format defines these.
+
+# The system will also cope with having output "leaves" in the middle of
+# the bifurcating branches, not just at the extremities, but again no
+# input format does this yet.
+
+# There are two variants of the "do_now" structure. The first, smaller variant
+# is generated by &enter as the input file is read. There is one structure
+# for each input byte. Say we are mapping a single byte encoding to a
+# single byte encoding, with "ABCD" going "abcd". There will be
+# 4 "do_now"s, {"A" => [...,"a",...], "B" => [...,"b",...], "C"=>..., "D"=>...}
+
+# &process then walks the tree, building aggregate "do_now" structres for
+# adjacent bytes where possible. The aggregate is for a contiguous range of
+# bytes which each produce the same length of output, each move to the
+# same next state, and each have the same fallback flag.
+# So our 4 RAW "do_now"s above become replaced by a single structure
+# containing:
+# ["A", "D", "abcd", 1, ...]
+# ie, for an input byte $_ in "A".."D", output 1 byte, found as
+# substr ("abcd", (ord $_ - ord "A") * 1, 1)
+# which maps very nicely into pointer arithmetic in C for encengine.c
+
+sub encode_U
+{
+ # UTF-8 encode long hand - only covers part of perl's range
+ ## my $uv = shift;
+ # chr() works in native space so convert value from table
+ # into that space before using chr().
+ my $ch = chr(utf8::unicode_to_native($_[0]));
+ # Now get core perl to encode that the way it likes.
+ utf8::encode($ch);
+ return $ch;
+}
+
+sub encode_S
+{
+ # encode single byte
+ ## my ($ch,$page) = @_; return chr($ch);
+ return chr $_[0];
+}
+
+sub encode_D
+{
+ # encode double byte MS byte first
+ ## my ($ch,$page) = @_; return chr($page).chr($ch);
+ return chr ($_[1]) . chr $_[0];
+}
+
+sub encode_M
+{
+ # encode Multi-byte - single for 0..255 otherwise double
+ ## my ($ch,$page) = @_;
+ ## return &encode_D if $page;
+ ## return &encode_S;
+ return chr ($_[1]) . chr $_[0] if $_[1];
+ return chr $_[0];
+}
+
+my %encode_types = (U => \&encode_U,
+ S => \&encode_S,
+ D => \&encode_D,
+ M => \&encode_M,
+ );
+
+# Win32 does not expand globs on command line
+eval "\@ARGV = map(glob(\$_),\@ARGV)" if ($^O eq 'MSWin32');
+
+my %opt;
+# I think these are:
+# -Q to disable the duplicate codepoint test
+# -S make mapping errors fatal
+# -q to remove comments written to output files
+# -O to enable the (brute force) substring optimiser
+# -o <output> to specify the output file name (else it's the first arg)
+# -f <inlist> to give a file with a list of input files (else use the args)
+# -n <name> to name the encoding (else use the basename of the input file.
+getopts('CM:SQqOo:f:n:',\%opt);
+
+$opt{M} and make_makefile_pl($opt{M}, @ARGV);
+$opt{C} and make_configlocal_pm($opt{C}, @ARGV);
+
+# This really should go first, else the die here causes empty (non-erroneous)
+# output files to be written.
+my @encfiles;
+if (exists $opt{'f'}) {
+ # -F is followed by name of file containing list of filenames
+ my $flist = $opt{'f'};
+ open(FLIST,$flist) || die "Cannot open $flist:$!";
+ chomp(@encfiles = <FLIST>);
+ close(FLIST);
+} else {
+ @encfiles = @ARGV;
+}
+
+my $cname = (exists $opt{'o'}) ? $opt{'o'} : shift(@ARGV);
+chmod(0666,$cname) if -f $cname && !-w $cname;
+open(C,">$cname") || die "Cannot open $cname:$!";
+
+my $dname = $cname;
+my $hname = $cname;
+
+my ($doC,$doEnc,$doUcm,$doPet);
+
+if ($cname =~ /\.(c|xs)$/i) # VMS may have upcased filenames with DECC$ARGV_PARSE_STYLE defined
+ {
+ $doC = 1;
+ $dname =~ s/(\.[^\.]*)?$/.exh/;
+ chmod(0666,$dname) if -f $cname && !-w $dname;
+ open(D,">$dname") || die "Cannot open $dname:$!";
+ $hname =~ s/(\.[^\.]*)?$/.h/;
+ chmod(0666,$hname) if -f $cname && !-w $hname;
+ open(H,">$hname") || die "Cannot open $hname:$!";
+
+ foreach my $fh (\*C,\*D,\*H)
+ {
+ print $fh <<"END" unless $opt{'q'};
+/*
+ !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file was autogenerated by:
+ $^X $0 @orig_ARGV
+ enc2xs VERSION $VERSION
+*/
+END
+ }
+
+ if ($cname =~ /(\w+)\.xs$/)
+ {
+ print C "#include <EXTERN.h>\n";
+ print C "#include <perl.h>\n";
+ print C "#include <XSUB.h>\n";
+ print C "#define U8 U8\n";
+ }
+ print C "#include \"encode.h\"\n\n";
+
+ }
+elsif ($cname =~ /\.enc$/)
+ {
+ $doEnc = 1;
+ }
+elsif ($cname =~ /\.ucm$/)
+ {
+ $doUcm = 1;
+ }
+elsif ($cname =~ /\.pet$/)
+ {
+ $doPet = 1;
+ }
+
+my %encoding;
+my %strings;
+my $string_acc;
+my %strings_in_acc;
+
+my $saved = 0;
+my $subsave = 0;
+my $strings = 0;
+
+sub cmp_name
+{
+ if ($a =~ /^.*-(\d+)/)
+ {
+ my $an = $1;
+ if ($b =~ /^.*-(\d+)/)
+ {
+ my $r = $an <=> $1;
+ return $r if $r;
+ }
+ }
+ return $a cmp $b;
+}
+
+
+foreach my $enc (sort cmp_name @encfiles)
+ {
+ my ($name,$sfx) = $enc =~ /^.*?([\w-]+)\.(enc|ucm)$/;
+ $name = $opt{'n'} if exists $opt{'n'};
+ if (open(E,$enc))
+ {
+ if ($sfx eq 'enc')
+ {
+ compile_enc(\*E,lc($name));
+ }
+ else
+ {
+ compile_ucm(\*E,lc($name));
+ }
+ }
+ else
+ {
+ warn "Cannot open $enc for $name:$!";
+ }
+ }
+
+if ($doC)
+ {
+ print STDERR "Writing compiled form\n";
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ process($name.'_utf8',$e2u);
+ addstrings(\*C,$e2u);
+
+ process('utf8_'.$name,$u2e);
+ addstrings(\*C,$u2e);
+ }
+ outbigstring(\*C,"enctable");
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ outtable(\*C,$e2u, "enctable");
+ outtable(\*C,$u2e, "enctable");
+
+ # push(@{$encoding{$name}},outstring(\*C,$e2u->{Cname}.'_def',$erep));
+ }
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $exta = $cpp ? 'extern "C" ' : "static";
+ my $extb = $cpp ? 'extern "C" ' : "";
+ foreach my $enc (sort cmp_name keys %encoding)
+ {
+ # my ($e2u,$u2e,$rep,$min_el,$max_el,$rsym) = @{$encoding{$enc}};
+ my ($e2u,$u2e,$rep,$min_el,$max_el) = @{$encoding{$enc}};
+ #my @info = ($e2u->{Cname},$u2e->{Cname},$rsym,length($rep),$min_el,$max_el);
+ my $replen = 0;
+ $replen++ while($rep =~ /\G\\x[0-9A-Fa-f]/g);
+ my $sym = "${enc}_encoding";
+ $sym =~ s/\W+/_/g;
+ my @info = ($e2u->{Cname},$u2e->{Cname},"${sym}_rep_character",$replen,
+ $min_el,$max_el);
+ print C "${exta} const U8 ${sym}_rep_character[] = \"$rep\";\n";
+ print C "${exta} const char ${sym}_enc_name[] = \"$enc\";\n\n";
+ print C "${extb} const encode_t $sym = \n";
+ # This is to make null encoding work -- dankogai
+ for (my $i = (scalar @info) - 1; $i >= 0; --$i){
+ $info[$i] ||= 1;
+ }
+ # end of null tweak -- dankogai
+ print C " {",join(',',@info,"{${sym}_enc_name,(const char *)0}"),"};\n\n";
+ }
+
+ foreach my $enc (sort cmp_name keys %encoding)
+ {
+ my $sym = "${enc}_encoding";
+ $sym =~ s/\W+/_/g;
+ print H "extern encode_t $sym;\n";
+ print D " Encode_XSEncoding(aTHX_ &$sym);\n";
+ }
+
+ if ($cname =~ /(\w+)\.xs$/)
+ {
+ my $mod = $1;
+ print C <<'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);
+}
+
+END
+
+ print C "\nMODULE = Encode::$mod\tPACKAGE = Encode::$mod\n\n";
+ print C "BOOT:\n{\n";
+ print C "#include \"$dname\"\n";
+ print C "}\n";
+ }
+ # Close in void context is bad, m'kay
+ close(D) or warn "Error closing '$dname': $!";
+ close(H) or warn "Error closing '$hname': $!";
+
+ my $perc_saved = $saved/($strings + $saved) * 100;
+ my $perc_subsaved = $subsave/($strings + $subsave) * 100;
+ printf STDERR "%d bytes in string tables\n",$strings;
+ printf STDERR "%d bytes (%.3g%%) saved spotting duplicates\n",
+ $saved, $perc_saved if $saved;
+ printf STDERR "%d bytes (%.3g%%) saved using substrings\n",
+ $subsave, $perc_subsaved if $subsave;
+ }
+elsif ($doEnc)
+ {
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ output_enc(\*C,$name,$e2u);
+ }
+ }
+elsif ($doUcm)
+ {
+ foreach my $name (sort cmp_name keys %encoding)
+ {
+ my ($e2u,$u2e,$erep,$min_el,$max_el) = @{$encoding{$name}};
+ output_ucm(\*C,$name,$u2e,$erep,$min_el,$max_el);
+ }
+ }
+
+# writing half meg files and then not checking to see if you just filled the
+# disk is bad, m'kay
+close(C) or die "Error closing '$cname': $!";
+
+# End of the main program.
+
+sub compile_ucm
+{
+ my ($fh,$name) = @_;
+ my $e2u = {};
+ my $u2e = {};
+ my $cs;
+ my %attr;
+ while (<$fh>)
+ {
+ s/#.*$//;
+ last if /^\s*CHARMAP\s*$/i;
+ if (/^\s*<(\w+)>\s+"?([^"]*)"?\s*$/i) # " # Grrr
+ {
+ $attr{$1} = $2;
+ }
+ }
+ if (!defined($cs = $attr{'code_set_name'}))
+ {
+ warn "No <code_set_name> in $name\n";
+ }
+ else
+ {
+ $name = $cs unless exists $opt{'n'};
+ }
+ my $erep;
+ my $urep;
+ my $max_el;
+ my $min_el;
+ if (exists $attr{'subchar'})
+ {
+ #my @byte;
+ #$attr{'subchar'} =~ /^\s*/cg;
+ #push(@byte,$1) while $attr{'subchar'} =~ /\G\\x([0-9a-f]+)/icg;
+ #$erep = join('',map(chr(hex($_)),@byte));
+ $erep = $attr{'subchar'};
+ $erep =~ s/^\s+//; $erep =~ s/\s+$//;
+ }
+ print "Reading $name ($cs)\n";
+ my $nfb = 0;
+ my $hfb = 0;
+ while (<$fh>)
+ {
+ s/#.*$//;
+ last if /^\s*END\s+CHARMAP\s*$/i;
+ next if /^\s*$/;
+ my (@uni, @byte) = ();
+ my ($uni, $byte, $fb) = m/^(\S+)\s+(\S+)\s+(\S+)\s+/o
+ or die "Bad line: $_";
+ while ($uni =~ m/\G<([U0-9a-fA-F\+]+)>/g){
+ push @uni, map { substr($_, 1) } split(/\+/, $1);
+ }
+ while ($byte =~ m/\G\\x([0-9a-fA-F]+)/g){
+ push @byte, $1;
+ }
+ if (@uni)
+ {
+ my $uch = join('', map { encode_U(hex($_)) } @uni );
+ my $ech = join('',map(chr(hex($_)),@byte));
+ my $el = length($ech);
+ $max_el = $el if (!defined($max_el) || $el > $max_el);
+ $min_el = $el if (!defined($min_el) || $el < $min_el);
+ if (length($fb))
+ {
+ $fb = substr($fb,1);
+ $hfb++;
+ }
+ else
+ {
+ $nfb++;
+ $fb = '0';
+ }
+ # $fb is fallback flag
+ # 0 - round trip safe
+ # 1 - fallback for unicode -> enc
+ # 2 - skip sub-char mapping
+ # 3 - fallback enc -> unicode
+ enter($u2e,$uch,$ech,$u2e,$fb+0) if ($fb =~ /[01]/);
+ enter($e2u,$ech,$uch,$e2u,$fb+0) if ($fb =~ /[03]/);
+ }
+ else
+ {
+ warn $_;
+ }
+ }
+ if ($nfb && $hfb)
+ {
+ die "$nfb entries without fallback, $hfb entries with\n";
+ }
+ $encoding{$name} = [$e2u,$u2e,$erep,$min_el,$max_el];
+}
+
+
+
+sub compile_enc
+{
+ my ($fh,$name) = @_;
+ my $e2u = {};
+ my $u2e = {};
+
+ my $type;
+ while ($type = <$fh>)
+ {
+ last if $type !~ /^\s*#/;
+ }
+ chomp($type);
+ return if $type eq 'E';
+ # Do the hash lookup once, rather than once per function call. 4% speedup.
+ my $type_func = $encode_types{$type};
+ my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
+ warn "$type encoded $name\n";
+ my $rep = '';
+ # Save a defined test by setting these to defined values.
+ my $min_el = ~0; # A very big integer
+ my $max_el = 0; # Anything must be longer than 0
+ {
+ my $v = hex($def);
+ $rep = &$type_func($v & 0xFF, ($v >> 8) & 0xffe);
+ }
+ my $errors;
+ my $seen;
+ # use -Q to silence the seen test. Makefile.PL uses this by default.
+ $seen = {} unless $opt{Q};
+ do
+ {
+ my $line = <$fh>;
+ chomp($line);
+ my $page = hex($line);
+ my $ch = 0;
+ my $i = 16;
+ do
+ {
+ # So why is it 1% faster to leave the my here?
+ my $line = <$fh>;
+ $line =~ s/\r\n$/\n/;
+ die "$.:${line}Line should be exactly 65 characters long including
+ newline (".length($line).")" unless length ($line) == 65;
+ # Split line into groups of 4 hex digits, convert groups to ints
+ # This takes 65.35
+ # map {hex $_} $line =~ /(....)/g
+ # This takes 63.75 (2.5% less time)
+ # unpack "n*", pack "H*", $line
+ # There's an implicit loop in map. Loops are bad, m'kay. Ops are bad, m'kay
+ # Doing it as while ($line =~ /(....)/g) took 74.63
+ foreach my $val (unpack "n*", pack "H*", $line)
+ {
+ next if $val == 0xFFFD;
+ my $ech = &$type_func($ch,$page);
+ if ($val || (!$ch && !$page))
+ {
+ my $el = length($ech);
+ $max_el = $el if $el > $max_el;
+ $min_el = $el if $el < $min_el;
+ my $uch = encode_U($val);
+ if ($seen) {
+ # We're doing the test.
+ # We don't need to read this quickly, so storing it as a scalar,
+ # rather than 3 (anon array, plus the 2 scalars it holds) saves
+ # RAM and may make us faster on low RAM systems. [see __END__]
+ if (exists $seen->{$uch})
+ {
+ warn sprintf("U%04X is %02X%02X and %04X\n",
+ $val,$page,$ch,$seen->{$uch});
+ $errors++;
+ }
+ else
+ {
+ $seen->{$uch} = $page << 8 | $ch;
+ }
+ }
+ # Passing 2 extra args each time is 3.6% slower!
+ # Even with having to add $fallback ||= 0 later
+ enter_fb0($e2u,$ech,$uch);
+ enter_fb0($u2e,$uch,$ech);
+ }
+ else
+ {
+ # No character at this position
+ # enter($e2u,$ech,undef,$e2u);
+ }
+ $ch++;
+ }
+ } while --$i;
+ } while --$pages;
+ die "\$min_el=$min_el, \$max_el=$max_el - seems we read no lines"
+ if $min_el > $max_el;
+ die "$errors mapping conflicts\n" if ($errors && $opt{'S'});
+ $encoding{$name} = [$e2u,$u2e,$rep,$min_el,$max_el];
+}
+
+# my ($a,$s,$d,$t,$fb) = @_;
+sub enter {
+ my ($current,$inbytes,$outbytes,$next,$fallback) = @_;
+ # state we shift to after this (multibyte) input character defaults to same
+ # as current state.
+ $next ||= $current;
+ # Making sure it is defined seems to be faster than {no warnings;} in
+ # &process, or passing it in as 0 explicity.
+ # XXX $fallback ||= 0;
+
+ # Start at the beginning and work forwards through the string to zero.
+ # effectively we are removing 1 character from the front each time
+ # but we don't actually edit the string. [this alone seems to be 14% speedup]
+ # Hence -$pos is the length of the remaining string.
+ my $pos = -length $inbytes;
+ while (1) {
+ my $byte = substr $inbytes, $pos, 1;
+ # RAW_NEXT => 0,
+ # RAW_IN_LEN => 1,
+ # RAW_OUT_BYTES => 2,
+ # RAW_FALLBACK => 3,
+ # to unicode an array would seem to be better, because the pages are dense.
+ # from unicode can be very sparse, favouring a hash.
+ # hash using the bytes (all length 1) as keys rather than ord value,
+ # as it's easier to sort these in &process.
+
+ # It's faster to always add $fallback even if it's undef, rather than
+ # choosing between 3 and 4 element array. (hence why we set it defined
+ # above)
+ my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,'',$fallback];
+ # When $pos was -1 we were at the last input character.
+ unless (++$pos) {
+ $do_now->[RAW_OUT_BYTES] = $outbytes;
+ $do_now->[RAW_NEXT] = $next;
+ return;
+ }
+ # Tail recursion. The intermdiate state may not have a name yet.
+ $current = $do_now->[RAW_NEXT];
+ }
+}
+
+# This is purely for optimistation. It's just &enter hard coded for $fallback
+# of 0, using only a 3 entry array ref to save memory for every entry.
+sub enter_fb0 {
+ my ($current,$inbytes,$outbytes,$next) = @_;
+ $next ||= $current;
+
+ my $pos = -length $inbytes;
+ while (1) {
+ my $byte = substr $inbytes, $pos, 1;
+ my $do_now = $current->{Raw}{$byte} ||= [{},-$pos,''];
+ unless (++$pos) {
+ $do_now->[RAW_OUT_BYTES] = $outbytes;
+ $do_now->[RAW_NEXT] = $next;
+ return;
+ }
+ $current = $do_now->[RAW_NEXT];
+ }
+}
+
+sub process
+{
+ my ($name,$a) = @_;
+ $name =~ s/\W+/_/g;
+ $a->{Cname} = $name;
+ my $raw = $a->{Raw};
+ my ($l, $agg_max_in, $agg_next, $agg_in_len, $agg_out_len, $agg_fallback);
+ my @ent;
+ $agg_max_in = 0;
+ foreach my $key (sort keys %$raw) {
+ # RAW_NEXT => 0,
+ # RAW_IN_LEN => 1,
+ # RAW_OUT_BYTES => 2,
+ # RAW_FALLBACK => 3,
+ my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
+ # Now we are converting from raw to aggregate, switch from 1 byte strings
+ # to numbers
+ my $b = ord $key;
+ $fallback ||= 0;
+ if ($l &&
+ # If this == fails, we're going to reset $agg_max_in below anyway.
+ $b == ++$agg_max_in &&
+ # References in numeric context give the pointer as an int.
+ $agg_next == $next &&
+ $agg_in_len == $in_len &&
+ $agg_out_len == length $out_bytes &&
+ $agg_fallback == $fallback
+ # && length($l->[AGG_OUT_BYTES]) < 16
+ ) {
+ # my $i = ord($b)-ord($l->[AGG_MIN_IN]);
+ # we can aggregate this byte onto the end.
+ $l->[AGG_MAX_IN] = $b;
+ $l->[AGG_OUT_BYTES] .= $out_bytes;
+ } else {
+ # AGG_MIN_IN => 0,
+ # AGG_MAX_IN => 1,
+ # AGG_OUT_BYTES => 2,
+ # AGG_NEXT => 3,
+ # AGG_IN_LEN => 4,
+ # AGG_OUT_LEN => 5,
+ # AGG_FALLBACK => 6,
+ # Reset the last thing we saw, plus set 5 lexicals to save some derefs.
+ # (only gains .6% on euc-jp -- is it worth it?)
+ push @ent, $l = [$b, $agg_max_in = $b, $out_bytes, $agg_next = $next,
+ $agg_in_len = $in_len, $agg_out_len = length $out_bytes,
+ $agg_fallback = $fallback];
+ }
+ if (exists $next->{Cname}) {
+ $next->{'Forward'} = 1 if $next != $a;
+ } else {
+ process(sprintf("%s_%02x",$name,$b),$next);
+ }
+ }
+ # encengine.c rules say that last entry must be for 255
+ if ($agg_max_in < 255) {
+ push @ent, [1+$agg_max_in, 255,undef,$a,0,0];
+ }
+ $a->{'Entries'} = \@ent;
+}
+
+
+sub addstrings
+{
+ my ($fh,$a) = @_;
+ my $name = $a->{'Cname'};
+ # String tables
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ next unless $b->[AGG_OUT_LEN];
+ $strings{$b->[AGG_OUT_BYTES]} = undef;
+ }
+ if ($a->{'Forward'})
+ {
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $var = $^O eq 'MacOS' || $cpp ? 'extern' : 'static';
+ my $const = $cpp ? '' : 'const';
+ print $fh "$var $const encpage_t $name\[",scalar(@{$a->{'Entries'}}),"];\n";
+ }
+ $a->{'DoneStrings'} = 1;
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ my ($s,$e,$out,$t,$end,$l) = @$b;
+ addstrings($fh,$t) unless $t->{'DoneStrings'};
+ }
+}
+
+sub outbigstring
+{
+ my ($fh,$name) = @_;
+
+ $string_acc = '';
+
+ # Make the big string in the string accumulator. Longest first, on the hope
+ # that this makes it more likely that we find the short strings later on.
+ # Not sure if it helps sorting strings of the same length lexcically.
+ foreach my $s (sort {length $b <=> length $a || $a cmp $b} keys %strings) {
+ my $index = index $string_acc, $s;
+ if ($index >= 0) {
+ $saved += length($s);
+ $strings_in_acc{$s} = $index;
+ } else {
+ OPTIMISER: {
+ if ($opt{'O'}) {
+ my $sublength = length $s;
+ while (--$sublength > 0) {
+ # progressively lop characters off the end, to see if the start of
+ # the new string overlaps the end of the accumulator.
+ if (substr ($string_acc, -$sublength)
+ eq substr ($s, 0, $sublength)) {
+ $subsave += $sublength;
+ $strings_in_acc{$s} = length ($string_acc) - $sublength;
+ # append the last bit on the end.
+ $string_acc .= substr ($s, $sublength);
+ last OPTIMISER;
+ }
+ # or if the end of the new string overlaps the start of the
+ # accumulator
+ next unless substr ($string_acc, 0, $sublength)
+ eq substr ($s, -$sublength);
+ # well, the last $sublength characters of the accumulator match.
+ # so as we're prepending to the accumulator, need to shift all our
+ # existing offsets forwards
+ $_ += $sublength foreach values %strings_in_acc;
+ $subsave += $sublength;
+ $strings_in_acc{$s} = 0;
+ # append the first bit on the start.
+ $string_acc = substr ($s, 0, -$sublength) . $string_acc;
+ last OPTIMISER;
+ }
+ }
+ # Optimiser (if it ran) found nothing, so just going have to tack the
+ # whole thing on the end.
+ $strings_in_acc{$s} = length $string_acc;
+ $string_acc .= $s;
+ };
+ }
+ }
+
+ $strings = length $string_acc;
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $var = $cpp ? '' : 'static';
+ my $definition = "\n$var const U8 $name\[$strings] = { " .
+ join(',',unpack "C*",$string_acc);
+ # We have a single long line. Split it at convenient commas.
+ print $fh $1, "\n" while $definition =~ /\G(.{74,77},)/gcs;
+ print $fh substr ($definition, pos $definition), " };\n";
+}
+
+sub findstring {
+ my ($name,$s) = @_;
+ my $offset = $strings_in_acc{$s};
+ die "Can't find string " . join (',',unpack "C*",$s) . " in accumulator"
+ unless defined $offset;
+ "$name + $offset";
+}
+
+sub outtable
+{
+ my ($fh,$a,$bigname) = @_;
+ my $name = $a->{'Cname'};
+ $a->{'Done'} = 1;
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ my ($s,$e,$out,$t,$end,$l) = @$b;
+ outtable($fh,$t,$bigname) unless $t->{'Done'};
+ }
+ my $cpp = ($Config{d_cplusplus} || '') eq 'define';
+ my $var = $cpp ? '' : 'static';
+ my $const = $cpp ? '' : 'const';
+ print $fh "\n$var $const encpage_t $name\[",
+ scalar(@{$a->{'Entries'}}), "] = {\n";
+ foreach my $b (@{$a->{'Entries'}})
+ {
+ my ($sc,$ec,$out,$t,$end,$l,$fb) = @$b;
+ # $end |= 0x80 if $fb; # what the heck was on your mind, Nick? -- Dan
+ print $fh "{";
+ if ($l)
+ {
+ printf $fh findstring($bigname,$out);
+ }
+ else
+ {
+ print $fh "0";
+ }
+ print $fh ",",$t->{Cname};
+ printf $fh ",0x%02x,0x%02x,$l,$end},\n",$sc,$ec;
+ }
+ print $fh "};\n";
+}
+
+sub output_enc
+{
+ my ($fh,$name,$a) = @_;
+ die "Changed - fix me for new structure";
+ foreach my $b (sort keys %$a)
+ {
+ my ($s,$e,$out,$t,$end,$l,$fb) = @{$a->{$b}};
+ }
+}
+
+sub decode_U
+{
+ my $s = shift;
+}
+
+my @uname;
+sub char_names
+{
+ my $s = do "unicore/Name.pl";
+ die "char_names: unicore/Name.pl: $!\n" unless defined $s;
+ pos($s) = 0;
+ while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc)
+ {
+ my $name = $3;
+ my $s = hex($1);
+ last if $s >= 0x10000;
+ my $e = length($2) ? hex($2) : $s;
+ for (my $i = $s; $i <= $e; $i++)
+ {
+ $uname[$i] = $name;
+# print sprintf("U%04X $name\n",$i);
+ }
+ }
+}
+
+sub output_ucm_page
+{
+ my ($cmap,$a,$t,$pre) = @_;
+ # warn sprintf("Page %x\n",$pre);
+ my $raw = $t->{Raw};
+ foreach my $key (sort keys %$raw) {
+ # RAW_NEXT => 0,
+ # RAW_IN_LEN => 1,
+ # RAW_OUT_BYTES => 2,
+ # RAW_FALLBACK => 3,
+ my ($next, $in_len, $out_bytes, $fallback) = @{$raw->{$key}};
+ my $u = ord $key;
+ $fallback ||= 0;
+
+ if ($next != $a && $next != $t) {
+ output_ucm_page($cmap,$a,$next,(($pre|($u &0x3F)) << 6)&0xFFFF);
+ } elsif (length $out_bytes) {
+ if ($pre) {
+ $u = $pre|($u &0x3f);
+ }
+ my $s = sprintf "<U%04X> ",$u;
+ #foreach my $c (split(//,$out_bytes)) {
+ # $s .= sprintf "\\x%02X",ord($c);
+ #}
+ # 9.5% faster changing that loop to this:
+ $s .= sprintf +("\\x%02X" x length $out_bytes), unpack "C*", $out_bytes;
+ $s .= sprintf " |%d # %s\n",($fallback ? 1 : 0),$uname[$u];
+ push(@$cmap,$s);
+ } else {
+ warn join(',',$u, @{$raw->{$key}},$a,$t);
+ }
+ }
+}
+
+sub output_ucm
+{
+ my ($fh,$name,$h,$rep,$min_el,$max_el) = @_;
+ print $fh "# $0 @orig_ARGV\n" unless $opt{'q'};
+ print $fh "<code_set_name> \"$name\"\n";
+ char_names();
+ if (defined $min_el)
+ {
+ print $fh "<mb_cur_min> $min_el\n";
+ }
+ if (defined $max_el)
+ {
+ print $fh "<mb_cur_max> $max_el\n";
+ }
+ if (defined $rep)
+ {
+ print $fh "<subchar> ";
+ foreach my $c (split(//,$rep))
+ {
+ printf $fh "\\x%02X",ord($c);
+ }
+ print $fh "\n";
+ }
+ my @cmap;
+ output_ucm_page(\@cmap,$h,$h,0);
+ print $fh "#\nCHARMAP\n";
+ foreach my $line (sort { substr($a,8) cmp substr($b,8) } @cmap)
+ {
+ print $fh $line;
+ }
+ print $fh "END CHARMAP\n";
+}
+
+use vars qw(
+ $_Enc2xs
+ $_Version
+ $_Inc
+ $_E2X
+ $_Name
+ $_TableFiles
+ $_Now
+);
+
+sub find_e2x{
+ eval { require File::Find; };
+ my (@inc, %e2x_dir);
+ for my $inc (@INC){
+ push @inc, $inc unless $inc eq '.'; #skip current dir
+ }
+ File::Find::find(
+ sub {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks)
+ = lstat($_) or return;
+ -f _ or return;
+ if (/^.*\.e2x$/o){
+ no warnings 'once';
+ $e2x_dir{$File::Find::dir} ||= $mtime;
+ }
+ return;
+ }, @inc);
+ warn join("\n", keys %e2x_dir), "\n";
+ for my $d (sort {$e2x_dir{$a} <=> $e2x_dir{$b}} keys %e2x_dir){
+ $_E2X = $d;
+ # warn "$_E2X => ", scalar localtime($e2x_dir{$d});
+ return $_E2X;
+ }
+}
+
+sub make_makefile_pl
+{
+ eval { require Encode; };
+ $@ and die "You need to install Encode to use enc2xs -M\nerror: $@\n";
+ # our used for variable expanstion
+ $_Enc2xs = $0;
+ $_Version = $VERSION;
+ $_E2X = find_e2x();
+ $_Name = shift;
+ $_TableFiles = join(",", map {qq('$_')} @_);
+ $_Now = scalar localtime();
+
+ eval { require File::Spec; };
+ _print_expand(File::Spec->catfile($_E2X,"Makefile_PL.e2x"),"Makefile.PL");
+ _print_expand(File::Spec->catfile($_E2X,"_PM.e2x"), "$_Name.pm");
+ _print_expand(File::Spec->catfile($_E2X,"_T.e2x"), "t/$_Name.t");
+ _print_expand(File::Spec->catfile($_E2X,"README.e2x"), "README");
+ _print_expand(File::Spec->catfile($_E2X,"Changes.e2x"), "Changes");
+ exit;
+}
+
+use vars qw(
+ $_ModLines
+ $_LocalVer
+ );
+
+sub make_configlocal_pm {
+ eval { require Encode; };
+ $@ and die "Unable to require Encode: $@\n";
+ eval { require File::Spec; };
+
+ # our used for variable expanstion
+ my %in_core = map { $_ => 1 } (
+ 'ascii', 'iso-8859-1', 'utf8',
+ 'ascii-ctrl', 'null', 'utf-8-strict'
+ );
+ my %LocalMod = ();
+ # check @enc;
+ use File::Find ();
+ my $wanted = sub{
+ -f $_ or return;
+ $File::Find::name =~ /\A\./ and return;
+ $File::Find::name =~ /\.pm\z/ or return;
+ $File::Find::name =~ m/\bEncode\b/ or return;
+ my $mod = $File::Find::name;
+ $mod =~ s/.*\bEncode\b/Encode/o;
+ $mod =~ s/\.pm\z//o;
+ $mod =~ s,/,::,og;
+ warn qq{ require $mod;\n};
+ eval qq{ require $mod; };
+ $@ and die "Can't require $mod: $@\n";
+ for my $enc ( Encode->encodings() ) {
+ no warnings;
+ $in_core{$enc} and next;
+ $Encode::Config::ExtModule{$enc} and next;
+ $LocalMod{$enc} ||= $mod;
+ }
+ };
+ File::Find::find({wanted => $wanted}, @INC);
+ $_ModLines = "";
+ for my $enc ( sort keys %LocalMod ) {
+ $_ModLines .=
+ qq(\$Encode::ExtModule{'$enc'} = "$LocalMod{$enc}";\n);
+ }
+ warn $_ModLines;
+ $_LocalVer = _mkversion();
+ $_E2X = find_e2x();
+ $_Inc = $INC{"Encode.pm"};
+ $_Inc =~ s/\.pm$//o;
+ _print_expand( File::Spec->catfile( $_E2X, "ConfigLocal_PM.e2x" ),
+ File::Spec->catfile( $_Inc, "ConfigLocal.pm" ), 1 );
+ exit;
+}
+
+sub _mkversion{
+ # v-string is now depreciated; use time() instead;
+ #my ($ss,$mm,$hh,$dd,$mo,$yyyy) = localtime();
+ #$yyyy += 1900, $mo +=1;
+ #return sprintf("v%04d.%04d.%04d", $yyyy, $mo*100+$dd, $hh*100+$mm);
+ return time();
+}
+
+sub _print_expand{
+ eval { require File::Basename; };
+ $@ and die "File::Basename needed. Are you on miniperl?;\nerror: $@\n";
+ File::Basename->import();
+ my ($src, $dst, $clobber) = @_;
+ if (!$clobber and -e $dst){
+ warn "$dst exists. skipping\n";
+ return;
+ }
+ warn "Generating $dst...\n";
+ open my $in, $src or die "$src : $!";
+ if ((my $d = dirname($dst)) ne '.'){
+ -d $d or mkdir $d, 0755 or die "mkdir $d : $!";
+ }
+ open my $out, ">$dst" or die "$!";
+ my $asis = 0;
+ while (<$in>){
+ if (/^#### END_OF_HEADER/){
+ $asis = 1; next;
+ }
+ s/(\$_[A-Z][A-Za-z0-9]+)_/$1/gee unless $asis;
+ print $out $_;
+ }
+}
+__END__
+
+=head1 NAME
+
+enc2xs -- Perl Encode Module Generator
+
+=head1 SYNOPSIS
+
+ enc2xs -[options]
+ enc2xs -M ModName mapfiles...
+ enc2xs -C
+
+=head1 DESCRIPTION
+
+F<enc2xs> builds a Perl extension for use by Encode from either
+Unicode Character Mapping files (.ucm) or Tcl Encoding Files (.enc).
+Besides being used internally during the build process of the Encode
+module, you can use F<enc2xs> to add your own encoding to perl.
+No knowledge of XS is necessary.
+
+=head1 Quick Guide
+
+If you want to know as little about Perl as possible but need to
+add a new encoding, just read this chapter and forget the rest.
+
+=over 4
+
+=item 0.
+
+Have a .ucm file ready. You can get it from somewhere or you can write
+your own from scratch or you can grab one from the Encode distribution
+and customize it. For the UCM format, see the next Chapter. In the
+example below, I'll call my theoretical encoding myascii, defined
+in I<my.ucm>. C<$> is a shell prompt.
+
+ $ ls -F
+ my.ucm
+
+=item 1.
+
+Issue a command as follows;
+
+ $ enc2xs -M My my.ucm
+ generating Makefile.PL
+ generating My.pm
+ generating README
+ generating Changes
+
+Now take a look at your current directory. It should look like this.
+
+ $ ls -F
+ Makefile.PL My.pm my.ucm t/
+
+The following files were created.
+
+ Makefile.PL - MakeMaker script
+ My.pm - Encode submodule
+ t/My.t - test file
+
+=over 4
+
+=item 1.1.
+
+If you want *.ucm installed together with the modules, do as follows;
+
+ $ mkdir Encode
+ $ mv *.ucm Encode
+ $ enc2xs -M My Encode/*ucm
+
+=back
+
+=item 2.
+
+Edit the files generated. You don't have to if you have no time AND no
+intention to give it to someone else. But it is a good idea to edit
+the pod and to add more tests.
+
+=item 3.
+
+Now issue a command all Perl Mongers love:
+
+ $ perl Makefile.PL
+ Writing Makefile for Encode::My
+
+=item 4.
+
+Now all you have to do is make.
+
+ $ make
+ cp My.pm blib/lib/Encode/My.pm
+ /usr/local/bin/perl /usr/local/bin/enc2xs -Q -O \
+ -o encode_t.c -f encode_t.fnm
+ Reading myascii (myascii)
+ Writing compiled form
+ 128 bytes in string tables
+ 384 bytes (75%) saved spotting duplicates
+ 1 bytes (0.775%) saved using substrings
+ ....
+ chmod 644 blib/arch/auto/Encode/My/My.bs
+ $
+
+The time it takes varies depending on how fast your machine is and
+how large your encoding is. Unless you are working on something big
+like euc-tw, it won't take too long.
+
+=item 5.
+
+You can "make install" already but you should test first.
+
+ $ make test
+ PERL_DL_NONLAZY=1 /usr/local/bin/perl -Iblib/arch -Iblib/lib \
+ -e 'use Test::Harness qw(&runtests $verbose); \
+ $verbose=0; runtests @ARGV;' t/*.t
+ t/My....ok
+ All tests successful.
+ Files=1, Tests=2, 0 wallclock secs
+ ( 0.09 cusr + 0.01 csys = 0.09 CPU)
+
+=item 6.
+
+If you are content with the test result, just "make install"
+
+=item 7.
+
+If you want to add your encoding to Encode's demand-loading list
+(so you don't have to "use Encode::YourEncoding"), run
+
+ enc2xs -C
+
+to update Encode::ConfigLocal, a module that controls local settings.
+After that, "use Encode;" is enough to load your encodings on demand.
+
+=back
+
+=head1 The Unicode Character Map
+
+Encode uses the Unicode Character Map (UCM) format for source character
+mappings. This format is used by IBM's ICU package and was adopted
+by Nick Ing-Simmons for use with the Encode module. Since UCM is
+more flexible than Tcl's Encoding Map and far more user-friendly,
+this is the recommended format for Encode now.
+
+A UCM file looks like this.
+
+ #
+ # Comments
+ #
+ <code_set_name> "US-ascii" # Required
+ <code_set_alias> "ascii" # Optional
+ <mb_cur_min> 1 # Required; usually 1
+ <mb_cur_max> 1 # Max. # of bytes/char
+ <subchar> \x3F # Substitution char
+ #
+ CHARMAP
+ <U0000> \x00 |0 # <control>
+ <U0001> \x01 |0 # <control>
+ <U0002> \x02 |0 # <control>
+ ....
+ <U007C> \x7C |0 # VERTICAL LINE
+ <U007D> \x7D |0 # RIGHT CURLY BRACKET
+ <U007E> \x7E |0 # TILDE
+ <U007F> \x7F |0 # <control>
+ END CHARMAP
+
+=over 4
+
+=item *
+
+Anything that follows C<#> is treated as a comment.
+
+=item *
+
+The header section continues until a line containing the word
+CHARMAP. This section has a form of I<E<lt>keywordE<gt> value>, one
+pair per line. Strings used as values must be quoted. Barewords are
+treated as numbers. I<\xXX> represents a byte.
+
+Most of the keywords are self-explanatory. I<subchar> means
+substitution character, not subcharacter. When you decode a Unicode
+sequence to this encoding but no matching character is found, the byte
+sequence defined here will be used. For most cases, the value here is
+\x3F; in ASCII, this is a question mark.
+
+=item *
+
+CHARMAP starts the character map section. Each line has a form as
+follows:
+
+ <UXXXX> \xXX.. |0 # comment
+ ^ ^ ^
+ | | +- Fallback flag
+ | +-------- Encoded byte sequence
+ +-------------- Unicode Character ID in hex
+
+The format is roughly the same as a header section except for the
+fallback flag: | followed by 0..3. The meaning of the possible
+values is as follows:
+
+=over 4
+
+=item |0
+
+Round trip safe. A character decoded to Unicode encodes back to the
+same byte sequence. Most characters have this flag.
+
+=item |1
+
+Fallback for unicode -> encoding. When seen, enc2xs adds this
+character for the encode map only.
+
+=item |2
+
+Skip sub-char mapping should there be no code point.
+
+=item |3
+
+Fallback for encoding -> unicode. When seen, enc2xs adds this
+character for the decode map only.
+
+=back
+
+=item *
+
+And finally, END OF CHARMAP ends the section.
+
+=back
+
+When you are manually creating a UCM file, you should copy ascii.ucm
+or an existing encoding which is close to yours, rather than write
+your own from scratch.
+
+When you do so, make sure you leave at least B<U0000> to B<U0020> as
+is, unless your environment is EBCDIC.
+
+B<CAVEAT>: not all features in UCM are implemented. For example,
+icu:state is not used. Because of that, you need to write a perl
+module if you want to support algorithmical encodings, notably
+the ISO-2022 series. Such modules include L<Encode::JP::2022_JP>,
+L<Encode::KR::2022_KR>, and L<Encode::TW::HZ>.
+
+=head2 Coping with duplicate mappings
+
+When you create a map, you SHOULD make your mappings round-trip safe.
+That is, C<encode('your-encoding', decode('your-encoding', $data)) eq
+$data> stands for all characters that are marked as C<|0>. Here is
+how to make sure:
+
+=over 4
+
+=item *
+
+Sort your map in Unicode order.
+
+=item *
+
+When you have a duplicate entry, mark either one with '|1' or '|3'.
+
+=item *
+
+And make sure the '|1' or '|3' entry FOLLOWS the '|0' entry.
+
+=back
+
+Here is an example from big5-eten.
+
+ <U2550> \xF9\xF9 |0
+ <U2550> \xA2\xA4 |3
+
+Internally Encoding -> Unicode and Unicode -> Encoding Map looks like
+this;
+
+ E to U U to E
+ --------------------------------------
+ \xF9\xF9 => U2550 U2550 => \xF9\xF9
+ \xA2\xA4 => U2550
+
+So it is round-trip safe for \xF9\xF9. But if the line above is upside
+down, here is what happens.
+
+ E to U U to E
+ --------------------------------------
+ \xA2\xA4 => U2550 U2550 => \xF9\xF9
+ (\xF9\xF9 => U2550 is now overwritten!)
+
+The Encode package comes with F<ucmlint>, a crude but sufficient
+utility to check the integrity of a UCM file. Check under the
+Encode/bin directory for this.
+
+When in doubt, you can use F<ucmsort>, yet another utility under
+Encode/bin directory.
+
+=head1 Bookmarks
+
+=over 4
+
+=item *
+
+ICU Home Page
+L<http://www.icu-project.org/>
+
+=item *
+
+ICU Character Mapping Tables
+L<http://site.icu-project.org/charts/charset>
+
+=item *
+
+ICU:Conversion Data
+L<http://www.icu-project.org/userguide/conversion-data.html>
+
+=back
+
+=head1 SEE ALSO
+
+L<Encode>,
+L<perlmod>,
+L<perlpod>
+
+=cut
+
+# -Q to disable the duplicate codepoint test
+# -S make mapping errors fatal
+# -q to remove comments written to output files
+# -O to enable the (brute force) substring optimiser
+# -o <output> to specify the output file name (else it's the first arg)
+# -f <inlist> to give a file with a list of input files (else use the args)
+# -n <name> to name the encoding (else use the basename of the input file.
+
+With %seen holding array refs:
+
+ 865.66 real 28.80 user 8.79 sys
+ 7904 maximum resident set size
+ 1356 average shared memory size
+ 18566 average unshared data size
+ 229 average unshared stack size
+ 46080 page reclaims
+ 33373 page faults
+
+With %seen holding simple scalars:
+
+ 342.16 real 27.11 user 3.54 sys
+ 8388 maximum resident set size
+ 1394 average shared memory size
+ 14969 average unshared data size
+ 236 average unshared stack size
+ 28159 page reclaims
+ 9839 page faults
+
+Yes, 5 minutes is faster than 15. Above is for CP936 in CN. Only difference is
+how %seen is storing things its seen. So it is pathalogically bad on a 16M
+RAM machine, but it's going to help even on modern machines.
+Swapping is bad, m'kay :-)
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/exe_update.bat b/Master/tlpkg/tlperl/bin/exe_update.bat new file mode 100755 index 00000000000..5c3ab156379 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/exe_update.bat @@ -0,0 +1,114 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl
+#line 15
+# $File: //member/autrijus/Win32-Exe/script/exe_update.pl $ $Author: autrijus $
+# $Revision: #1 $ $Change: 9927 $ $DateTime: 2004/02/06 19:31:24 $
+
+use strict;
+use File::Basename;
+use Win32::Exe;
+use Getopt::Long;
+
+=head1 NAME
+
+exe_update.pl - Modify windows executable files
+
+=head1 SYNOPSIS
+
+B<exe_update.pl> S<[ B<--gui> | B<--console> ]> S<[ B<--icon> I<iconfile> ]>
+ S<[ B<--info> I<key=value;...> ]> I<exefile>
+
+=head1 DESCRIPTION
+
+This program rewrites PE headers in a Windows executable file. It can
+change whether the executable runs with a console window, as well as
+setting the icons and version information associated with it.
+
+=head1 OPTIONS
+
+Options are available in a I<short> form and a I<long> form. For
+example, the three lines below are all equivalent:
+
+ % exe_update.pl -i new.ico input.exe
+ % exe_update.pl --icon new.ico input.exe
+ % exe_update.pl --icon=new.ico input.exe
+
+=over 4
+
+=item B<-c>, B<--console>
+
+Set the executable to always display a console window.
+
+=item B<-g>, B<--gui>
+
+Set the executable so it does not have a console window.
+
+=item B<-i>, B<--icon>=I<FILE>
+
+Specify an icon file (in F<.ico>, F<.exe> or F<.dll> format) for the
+executable.
+
+=item B<-N>, B<--info>=I<KEY=VAL>
+
+Attach version information for the executable. The name/value pair is
+joined by C<=>. You may specify C<-N> multiple times, or use C<;> to
+link several pairs.
+
+These special C<KEY> names are recognized:
+
+ Comments CompanyName FileDescription FileVersion
+ InternalName LegalCopyright LegalTrademarks OriginalFilename
+ ProductName ProductVersion
+
+=back
+
+=cut
+
+my $Options = {};
+Getopt::Long::GetOptions( $Options,
+ 'g|gui', # No console window
+ 'c|console', # Use console window
+ 'i|icon:s', # Icon file
+ 'N|info:s@', # Executable header info
+);
+
+my $exe = shift or die "Usage: " . basename($0) .
+ " [--gui | --console] [--icon file.ico] [--info key=value] file.exe\n";
+
+Win32::Exe->new($exe)->update(
+ gui => $Options->{g},
+ console => $Options->{c},
+ icon => $Options->{i},
+ info => $Options->{N},
+) or die "Update of $exe failed!\n";
+
+__END__
+
+=head1 AUTHORS
+
+Audrey Tang E<lt>cpan@audreyt.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004, 2006 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/exe_update.pl b/Master/tlpkg/tlperl/bin/exe_update.pl new file mode 100755 index 00000000000..dc43251ebff --- /dev/null +++ b/Master/tlpkg/tlperl/bin/exe_update.pl @@ -0,0 +1,98 @@ +#!/usr/local/bin/perl +# $File: //member/autrijus/Win32-Exe/script/exe_update.pl $ $Author: autrijus $ +# $Revision: #1 $ $Change: 9927 $ $DateTime: 2004/02/06 19:31:24 $ + +use strict; +use File::Basename; +use Win32::Exe; +use Getopt::Long; + +=head1 NAME + +exe_update.pl - Modify windows executable files + +=head1 SYNOPSIS + +B<exe_update.pl> S<[ B<--gui> | B<--console> ]> S<[ B<--icon> I<iconfile> ]> + S<[ B<--info> I<key=value;...> ]> I<exefile> + +=head1 DESCRIPTION + +This program rewrites PE headers in a Windows executable file. It can +change whether the executable runs with a console window, as well as +setting the icons and version information associated with it. + +=head1 OPTIONS + +Options are available in a I<short> form and a I<long> form. For +example, the three lines below are all equivalent: + + % exe_update.pl -i new.ico input.exe + % exe_update.pl --icon new.ico input.exe + % exe_update.pl --icon=new.ico input.exe + +=over 4 + +=item B<-c>, B<--console> + +Set the executable to always display a console window. + +=item B<-g>, B<--gui> + +Set the executable so it does not have a console window. + +=item B<-i>, B<--icon>=I<FILE> + +Specify an icon file (in F<.ico>, F<.exe> or F<.dll> format) for the +executable. + +=item B<-N>, B<--info>=I<KEY=VAL> + +Attach version information for the executable. The name/value pair is +joined by C<=>. You may specify C<-N> multiple times, or use C<;> to +link several pairs. + +These special C<KEY> names are recognized: + + Comments CompanyName FileDescription FileVersion + InternalName LegalCopyright LegalTrademarks OriginalFilename + ProductName ProductVersion + +=back + +=cut + +my $Options = {}; +Getopt::Long::GetOptions( $Options, + 'g|gui', # No console window + 'c|console', # Use console window + 'i|icon:s', # Icon file + 'N|info:s@', # Executable header info +); + +my $exe = shift or die "Usage: " . basename($0) . + " [--gui | --console] [--icon file.ico] [--info key=value] file.exe\n"; + +Win32::Exe->new($exe)->update( + gui => $Options->{g}, + console => $Options->{c}, + icon => $Options->{i}, + info => $Options->{N}, +) or die "Update of $exe failed!\n"; + +__END__ + +=head1 AUTHORS + +Audrey Tang E<lt>cpan@audreyt.orgE<gt> + +=head1 COPYRIGHT + +Copyright 2004, 2006 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + +=cut diff --git a/Master/tlpkg/tlperl/bin/exetype.bat b/Master/tlpkg/tlperl/bin/exetype.bat new file mode 100755 index 00000000000..90e84330756 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/exetype.bat @@ -0,0 +1,124 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+use strict;
+
+# All the IMAGE_* structures are defined in the WINNT.H file
+# of the Microsoft Platform SDK.
+
+my %subsys = (NATIVE => 1,
+ WINDOWS => 2,
+ CONSOLE => 3,
+ POSIX => 7,
+ WINDOWSCE => 9);
+
+unless (0 < @ARGV && @ARGV < 3) {
+ printf "Usage: $0 exefile [%s]\n", join '|', sort keys %subsys;
+ exit;
+}
+
+$ARGV[1] = uc $ARGV[1] if $ARGV[1];
+unless (@ARGV == 1 || defined $subsys{$ARGV[1]}) {
+ (my $subsys = join(', ', sort keys %subsys)) =~ s/, (\w+)$/ or $1/;
+ print "Invalid subsystem $ARGV[1], please use $subsys\n";
+ exit;
+}
+
+my ($record,$magic,$signature,$offset,$size);
+open EXE, "+< $ARGV[0]" or die "Cannot open $ARGV[0]: $!\n";
+binmode EXE;
+
+# read IMAGE_DOS_HEADER structure
+read EXE, $record, 64;
+($magic,$offset) = unpack "Sx58L", $record;
+
+die "$ARGV[0] is not an MSDOS executable file.\n"
+ unless $magic == 0x5a4d; # "MZ"
+
+# read signature, IMAGE_FILE_HEADER and first WORD of IMAGE_OPTIONAL_HEADER
+seek EXE, $offset, 0;
+read EXE, $record, 4+20+2;
+($signature,$size,$magic) = unpack "Lx16Sx2S", $record;
+
+die "PE header not found" unless $signature == 0x4550; # "PE\0\0"
+
+die "Optional header is neither in NT32 nor in NT64 format"
+ unless ($size == 224 && $magic == 0x10b) || # IMAGE_NT_OPTIONAL_HDR32_MAGIC
+ ($size == 240 && $magic == 0x20b); # IMAGE_NT_OPTIONAL_HDR64_MAGIC
+
+# Offset 68 in the IMAGE_OPTIONAL_HEADER(32|64) is the 16 bit subsystem code
+seek EXE, $offset+4+20+68, 0;
+if (@ARGV == 1) {
+ read EXE, $record, 2;
+ my ($subsys) = unpack "S", $record;
+ $subsys = {reverse %subsys}->{$subsys} || "UNKNOWN($subsys)";
+ print "$ARGV[0] uses the $subsys subsystem.\n";
+}
+else {
+ print EXE pack "S", $subsys{$ARGV[1]};
+}
+close EXE;
+__END__
+
+=head1 NAME
+
+exetype - Change executable subsystem type between "Console" and "Windows"
+
+=head1 SYNOPSIS
+
+ C:\perl\bin> copy perl.exe guiperl.exe
+ C:\perl\bin> exetype guiperl.exe windows
+
+=head1 DESCRIPTION
+
+This program edits an executable file to indicate which subsystem the
+operating system must invoke for execution.
+
+You can specify any of the following subsystems:
+
+=over
+
+=item CONSOLE
+
+The CONSOLE subsystem handles a Win32 character-mode application that
+use a console supplied by the operating system.
+
+=item WINDOWS
+
+The WINDOWS subsystem handles an application that does not require a
+console and creates its own windows, if required.
+
+=item NATIVE
+
+The NATIVE subsystem handles a Windows NT device driver.
+
+=item WINDOWSCE
+
+The WINDOWSCE subsystem handles Windows CE consumer electronics
+applications.
+
+=item POSIX
+
+The POSIX subsystem handles a POSIX application in Windows NT.
+
+=back
+
+=head1 AUTHOR
+
+Jan Dubois <jand@activestate.com>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/find2perl.bat b/Master/tlpkg/tlperl/bin/find2perl.bat new file mode 100755 index 00000000000..208ed40e9e7 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/find2perl.bat @@ -0,0 +1,895 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+(my $perlpath = <<'/../') =~ s/\s*\z//;
+C:\strawberry\perl\bin\perl.exe
+/../
+use strict;
+use vars qw/$statdone/;
+use File::Spec::Functions 'curdir';
+my $startperl = "#! $perlpath -w";
+
+sub tab ();
+sub n ($$);
+sub fileglob_to_re ($);
+sub quote ($);
+
+my @roots = ();
+while ($ARGV[0] =~ /^[^-!(]/) {
+ push(@roots, shift);
+}
+@roots = (curdir()) unless @roots;
+for (@roots) { $_ = quote($_) }
+my $roots = join(', ', @roots);
+
+my $find = "find";
+my $indent_depth = 1;
+my $stat = 'lstat';
+my $decl = '';
+my $flushall = '';
+my $initfile = '';
+my $initnewer = '';
+my $out = '';
+my $declaresubs = "sub wanted;\n";
+my %init = ();
+my ($follow_in_effect,$Skip_And) = (0,0);
+my $print_needed = 1;
+
+while (@ARGV) {
+ $_ = shift;
+ s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
+ if ($_ eq '(') {
+ $out .= tab . "(\n";
+ $indent_depth++;
+ next;
+ } elsif ($_ eq ')') {
+ --$indent_depth;
+ $out .= tab . ")";
+ } elsif ($_ eq 'follow') {
+ $follow_in_effect= 1;
+ $stat = 'stat';
+ $Skip_And= 1;
+ } elsif ($_ eq '!') {
+ $out .= tab . "!";
+ next;
+ } elsif (/^(i)?name$/) {
+ $out .= tab . '/' . fileglob_to_re(shift) . "/s$1";
+ } elsif (/^(i)?path$/) {
+ $out .= tab . '$File::Find::name =~ /' . fileglob_to_re(shift) . "/s$1";
+ } elsif ($_ eq 'perm') {
+ my $onum = shift;
+ $onum =~ /^-?[0-7]+$/
+ || die "Malformed -perm argument: $onum\n";
+ $out .= tab;
+ if ($onum =~ s/^-//) {
+ $onum = sprintf("0%o", oct($onum) & 07777);
+ $out .= "((\$mode & $onum) == $onum)";
+ } else {
+ $onum =~ s/^0*/0/;
+ $out .= "((\$mode & 0777) == $onum)";
+ }
+ } elsif ($_ eq 'type') {
+ (my $filetest = shift) =~ tr/s/S/;
+ $out .= tab . "-$filetest _";
+ } elsif ($_ eq 'print') {
+ $out .= tab . 'print("$name\n")';
+ $print_needed = 0;
+ } elsif ($_ eq 'print0') {
+ $out .= tab . 'print("$name\0")';
+ $print_needed = 0;
+ } elsif ($_ eq 'fstype') {
+ my $type = shift;
+ $out .= tab;
+ if ($type eq 'nfs') {
+ $out .= '($dev < 0)';
+ } else {
+ $out .= '($dev >= 0)'; #XXX
+ }
+ } elsif ($_ eq 'user') {
+ my $uname = shift;
+ $out .= tab . "(\$uid == \$uid{'$uname'})";
+ $init{user} = 1;
+ } elsif ($_ eq 'group') {
+ my $gname = shift;
+ $out .= tab . "(\$gid == \$gid{'$gname'})";
+ $init{group} = 1;
+ } elsif ($_ eq 'nouser') {
+ $out .= tab . '!exists $uid{$uid}';
+ $init{user} = 1;
+ } elsif ($_ eq 'nogroup') {
+ $out .= tab . '!exists $gid{$gid}';
+ $init{group} = 1;
+ } elsif ($_ eq 'links') {
+ $out .= tab . n('$nlink', shift);
+ } elsif ($_ eq 'inum') {
+ $out .= tab . n('$ino', shift);
+ } elsif ($_ eq 'size') {
+ $_ = shift;
+ my $n = 'int(((-s _) + 511) / 512)';
+ if (s/c\z//) {
+ $n = 'int(-s _)';
+ } elsif (s/k\z//) {
+ $n = 'int(((-s _) + 1023) / 1024)';
+ }
+ $out .= tab . n($n, $_);
+ } elsif ($_ eq 'atime') {
+ $out .= tab . n('int(-A _)', shift);
+ } elsif ($_ eq 'mtime') {
+ $out .= tab . n('int(-M _)', shift);
+ } elsif ($_ eq 'ctime') {
+ $out .= tab . n('int(-C _)', shift);
+ } elsif ($_ eq 'exec') {
+ my @cmd = ();
+ while (@ARGV && $ARGV[0] ne ';')
+ { push(@cmd, shift) }
+ shift;
+ $out .= tab;
+ if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
+ && $cmd[$#cmd] eq '{}'
+ && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
+ if (@cmd == 2) {
+ $out .= '(unlink($_) || warn "$name: $!\n")';
+ } elsif (!@ARGV) {
+ $out .= 'unlink($_)';
+ } else {
+ $out .= '(unlink($_) || 1)';
+ }
+ } else {
+ for (@cmd)
+ { s/'/\\'/g }
+ { local $" = "','"; $out .= "doexec(0, '@cmd')"; }
+ $declaresubs .= "sub doexec (\$\@);\n";
+ $init{doexec} = 1;
+ }
+ $print_needed = 0;
+ } elsif ($_ eq 'ok') {
+ my @cmd = ();
+ while (@ARGV && $ARGV[0] ne ';')
+ { push(@cmd, shift) }
+ shift;
+ $out .= tab;
+ for (@cmd)
+ { s/'/\\'/g }
+ { local $" = "','"; $out .= "doexec(1, '@cmd')"; }
+ $declaresubs .= "sub doexec (\$\@);\n";
+ $init{doexec} = 1;
+ $print_needed = 0;
+ } elsif ($_ eq 'prune') {
+ $out .= tab . '($File::Find::prune = 1)';
+ } elsif ($_ eq 'xdev') {
+ $out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
+;
+ } elsif ($_ eq 'newer') {
+ my $file = shift;
+ my $newername = 'AGE_OF' . $file;
+ $newername =~ s/\W/_/g;
+ $newername = '$' . $newername;
+ $out .= tab . "(-M _ < $newername)";
+ $initnewer .= "my $newername = -M " . quote($file) . ";\n";
+ } elsif ($_ eq 'eval') {
+ my $prog = shift;
+ $prog =~ s/'/\\'/g;
+ $out .= tab . "eval {$prog}";
+ $print_needed = 0;
+ } elsif ($_ eq 'depth') {
+ $find = 'finddepth';
+ next;
+ } elsif ($_ eq 'ls') {
+ $out .= tab . "ls";
+ $declaresubs .= "sub ls ();\n";
+ $init{ls} = 1;
+ $print_needed = 0;
+ } elsif ($_ eq 'tar') {
+ die "-tar must have a filename argument\n" unless @ARGV;
+ my $file = shift;
+ my $fh = 'FH' . $file;
+ $fh =~ s/\W/_/g;
+ $out .= tab . "tar(*$fh, \$name)";
+ $flushall .= "tflushall;\n";
+ $declaresubs .= "sub tar;\nsub tflushall ();\n";
+ $initfile .= "open($fh, " . quote('> ' . $file) .
+ qq{) || die "Can't open $fh: \$!\\n";\n};
+ $init{tar} = 1;
+ } elsif (/^(n?)cpio\z/) {
+ die "-$_ must have a filename argument\n" unless @ARGV;
+ my $file = shift;
+ my $fh = 'FH' . $file;
+ $fh =~ s/\W/_/g;
+ $out .= tab . "cpio(*$fh, \$name, '$1')";
+ $find = 'finddepth';
+ $flushall .= "cflushall;\n";
+ $declaresubs .= "sub cpio;\nsub cflushall ();\n";
+ $initfile .= "open($fh, " . quote('> ' . $file) .
+ qq{) || die "Can't open $fh: \$!\\n";\n};
+ $init{cpio} = 1;
+ } else {
+ die "Unrecognized switch: -$_\n";
+ }
+
+ if (@ARGV) {
+ if ($ARGV[0] eq '-o') {
+ { local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
+ $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
+ $init{saw_or} = 1;
+ shift;
+ } else {
+ $out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
+ $out .= "\n";
+ shift if $ARGV[0] eq '-a';
+ }
+ }
+}
+
+if ($print_needed) {
+ my $t = tab;
+ if ($t !~ /&&\s*$/) { $t .= '&& ' }
+ $out .= "\n" . $t . 'print("$name\n")';
+}
+
+
+print <<"END";
+$startperl
+ eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+ if 0; #\$running_under_some_shell
+
+use strict;
+use File::Find ();
+
+# Set the variable \$File::Find::dont_use_nlink if you're using AFS,
+# since AFS cheats.
+
+# for the convenience of &wanted calls, including -eval statements:
+use vars qw/*name *dir *prune/;
+*name = *File::Find::name;
+*dir = *File::Find::dir;
+*prune = *File::Find::prune;
+
+$declaresubs
+
+END
+
+if (exists $init{doexec}) {
+ print <<'END';
+use Cwd ();
+my $cwd = Cwd::cwd();
+
+END
+}
+
+if (exists $init{ls}) {
+ print <<'END';
+my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
+my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
+
+END
+}
+
+if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
+ print "my (%uid, %user);\n";
+ print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
+ print ' $uid{$name} = $uid{$uid} = $uid;', "\n"
+ if exists $init{user};
+ print ' $user{$uid} = $name unless exists $user{$uid};', "\n"
+ if exists $init{ls} || exists $init{tar};
+ print "}\n\n";
+}
+
+if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
+ print "my (%gid, %group);\n";
+ print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
+ print ' $gid{$name} = $gid{$gid} = $gid;', "\n"
+ if exists $init{group};
+ print ' $group{$gid} = $name unless exists $group{$gid};', "\n"
+ if exists $init{ls} || exists $init{tar};
+ print "}\n\n";
+}
+
+print $initnewer, "\n" if $initnewer ne '';
+print $initfile, "\n" if $initfile ne '';
+$flushall .= "exit;\n";
+if (exists $init{declarestat}) {
+ $out = <<'END' . $out;
+ my ($dev,$ino,$mode,$nlink,$uid,$gid);
+
+END
+}
+
+if ( $follow_in_effect ) {
+$out =~ s/lstat\(\$_\)/lstat(_)/;
+print <<"END";
+$decl
+# Traverse desired filesystems
+File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
+$flushall
+
+sub wanted {
+$out;
+}
+
+END
+} else {
+print <<"END";
+$decl
+# Traverse desired filesystems
+File::Find::$find({wanted => \\&wanted}, $roots);
+$flushall
+
+sub wanted {
+$out;
+}
+
+END
+}
+
+if (exists $init{doexec}) {
+ print <<'END';
+
+sub doexec ($@) {
+ my $ok = shift;
+ my @command = @_; # copy so we don't try to s/// aliases to constants
+ for my $word (@command)
+ { $word =~ s#{}#$name#g }
+ if ($ok) {
+ my $old = select(STDOUT);
+ $| = 1;
+ print "@command";
+ select($old);
+ return 0 unless <STDIN> =~ /^y/;
+ }
+ chdir $cwd; #sigh
+ system @command;
+ chdir $File::Find::dir;
+ return !$?;
+}
+
+END
+}
+
+if (exists $init{ls}) {
+ print <<'INTRO', <<"SUB", <<'END';
+
+sub sizemm {
+ my $rdev = shift;
+ sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
+}
+
+sub ls () {
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+INTRO
+ \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
+SUB
+ my $pname = $name;
+
+ $blocks
+ or $blocks = int(($size + 1023) / 1024);
+
+ my $perms = $rwx[$mode & 7];
+ $mode >>= 3;
+ $perms = $rwx[$mode & 7] . $perms;
+ $mode >>= 3;
+ $perms = $rwx[$mode & 7] . $perms;
+ substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
+ substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
+ substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
+ if (-f _) { $perms = '-' . $perms; }
+ elsif (-d _) { $perms = 'd' . $perms; }
+ elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
+ elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
+ elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
+ elsif (-p _) { $perms = 'p' . $perms; }
+ elsif (-S _) { $perms = 's' . $perms; }
+ else { $perms = '?' . $perms; }
+
+ my $user = $user{$uid} || $uid;
+ my $group = $group{$gid} || $gid;
+
+ my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
+ if (-M _ > 365.25 / 2) {
+ $timeyear += 1900;
+ } else {
+ $timeyear = sprintf("%02d:%02d", $hour, $min);
+ }
+
+ printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
+ $ino,
+ $blocks,
+ $perms,
+ $nlink,
+ $user,
+ $group,
+ $size,
+ $moname[$mon],
+ $mday,
+ $timeyear,
+ $pname;
+ 1;
+}
+
+END
+}
+
+
+if (exists $init{cpio} || exists $init{tar}) {
+print <<'END';
+
+my %blocks = ();
+
+sub flush {
+ my ($fh, $varref, $blksz) = @_;
+
+ while (length($$varref) >= $blksz) {
+ no strict qw/refs/;
+ syswrite($fh, $$varref, $blksz);
+ substr($$varref, 0, $blksz) = '';
+ ++$blocks{$fh};
+ }
+}
+
+END
+}
+
+
+if (exists $init{cpio}) {
+ print <<'INTRO', <<"SUB", <<'END';
+
+my %cpout = ();
+my %nc = ();
+
+sub cpio {
+ my ($fh, $fname, $nc) = @_;
+ my $text = '';
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks);
+ local (*IN);
+
+ if ( ! defined $fname ) {
+ $fname = 'TRAILER!!!';
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+ $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
+ } else {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+INTRO
+ \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
+SUB
+ if (-f _) {
+ open(IN, "./$_\0") || do {
+ warn "Couldn't open $fname: $!\n";
+ return;
+ }
+ } else {
+ $text = readlink($_);
+ $size = 0 unless defined $text;
+ }
+ }
+
+ $fname =~ s#^\./##;
+ $nc{$fh} = $nc;
+ if ($nc eq 'n') {
+ $cpout{$fh} .=
+ sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
+ 070707,
+ $dev & 0777777,
+ $ino & 0777777,
+ $mode & 0777777,
+ $uid & 0777777,
+ $gid & 0777777,
+ $nlink & 0777777,
+ $rdev & 0177777,
+ $mtime,
+ length($fname)+1,
+ $size,
+ $fname);
+ } else {
+ $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
+ $cpout{$fh} .= pack("SSSSSSSSLSLa*",
+ 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
+ length($fname)+1, $size,
+ $fname . (length($fname) & 1 ? "\0" : "\0\0"));
+ }
+
+ if ($text ne '') {
+ $cpout{$fh} .= $text;
+ } elsif ($size) {
+ my $l;
+ flush($fh, \$cpout{$fh}, 5120)
+ while ($l = length($cpout{$fh})) >= 5120;
+ while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
+ flush($fh, \$cpout{$fh}, 5120);
+ $l = length($cpout{$fh});
+ }
+ close IN;
+ }
+}
+
+sub cflushall () {
+ for my $fh (keys %cpout) {
+ cpio($fh, undef, $nc{$fh});
+ $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
+ flush($fh, \$cpout{$fh}, 5120);
+ print $blocks{$fh} * 10, " blocks\n";
+ }
+}
+
+END
+}
+
+if (exists $init{tar}) {
+ print <<'INTRO', <<"SUB", <<'END';
+
+my %tarout = ();
+my %linkseen = ();
+
+sub tar {
+ my ($fh, $fname) = @_;
+ my $prefix = '';
+ my $typeflag = '0';
+ my $linkname;
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
+INTRO
+ \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
+SUB
+ local (*IN);
+
+ if ($nlink > 1) {
+ if ($linkname = $linkseen{$fh, $dev, $ino}) {
+ if (length($linkname) > 100) {
+ warn "$0: omitting file with linkname ",
+ "too long for tar output: $linkname\n";
+ return;
+ }
+ $typeflag = '1';
+ $size = 0;
+ } else {
+ $linkseen{$fh, $dev, $ino} = $fname;
+ }
+ }
+ if ($typeflag eq '0') {
+ if (-f _) {
+ open(IN, "./$_\0") || do {
+ warn "Couldn't open $fname: $!\n";
+ return;
+ }
+ } else {
+ $linkname = readlink($_);
+ if (defined $linkname) { $typeflag = '2' }
+ elsif (-c _) { $typeflag = '3' }
+ elsif (-b _) { $typeflag = '4' }
+ elsif (-d _) { $typeflag = '5' }
+ elsif (-p _) { $typeflag = '6' }
+ }
+ }
+
+ if (length($fname) > 100) {
+ ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
+ if (!defined($fname) || length($prefix) > 155) {
+ warn "$0: omitting file with name too long for tar output: ",
+ $fname, "\n";
+ return;
+ }
+ }
+
+ $size = 0 if $typeflag ne '0';
+ my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
+ $fname,
+ sprintf("%7o ", $mode & 0777),
+ sprintf("%7o ", $uid & 0777777),
+ sprintf("%7o ", $gid & 0777777),
+ sprintf("%11o ", $size),
+ sprintf("%11o ", $mtime),
+ ' 'x8,
+ $typeflag,
+ defined $linkname ? $linkname : '',
+ "ustar\0",
+ "00",
+ $user{$uid},
+ $group{$gid},
+ ($rdev >> 8) & 0xff,
+ $rdev & 0xff,
+ $prefix,
+ );
+ substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
+ my $l = length($header) % 512;
+ $tarout{$fh} .= $header;
+ $tarout{$fh} .= "\0" x (512 - $l) if $l;
+
+ if ($size) {
+ flush($fh, \$tarout{$fh}, 10240)
+ while ($l = length($tarout{$fh})) >= 10240;
+ while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
+ my $slop = length($tarout{$fh}) % 512;
+ $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
+ flush($fh, \$tarout{$fh}, 10240);
+ $l = length($tarout{$fh});
+ }
+ close IN;
+ }
+}
+
+sub tflushall () {
+ my $len;
+ for my $fh (keys %tarout) {
+ $len = 10240 - length($tarout{$fh});
+ $len += 10240 if $len < 1024;
+ $tarout{$fh} .= "\0" x $len;
+ flush($fh, \$tarout{$fh}, 10240);
+ }
+}
+
+END
+}
+
+exit;
+
+############################################################################
+
+sub tab () {
+ my $tabstring;
+
+ $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
+ if (!$statdone) {
+ if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
+ $init{delayedstat} = 1;
+ } else {
+ my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
+ . $stat . '($_))';
+ if (exists $init{saw_or}) {
+ $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
+ } else {
+ $tabstring .= "$statcall &&\n" . $tabstring;
+ }
+ $statdone = 1;
+ $init{declarestat} = 1;
+ }
+ }
+ $tabstring =~ s/^\s+/ / if $out =~ /!$/;
+ $tabstring;
+}
+
+sub fileglob_to_re ($) {
+ my $x = shift;
+ $x =~ s#([./^\$()+])#\\$1#g;
+ $x =~ s#([?*])#.$1#g;
+ "^$x\\z";
+}
+
+sub n ($$) {
+ my ($pre, $n) = @_;
+ $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
+ $n =~ s/ 0*(\d)/ $1/;
+ "($pre $n)";
+}
+
+sub quote ($) {
+ my $string = shift;
+ $string =~ s/\\/\\\\/g;
+ $string =~ s/'/\\'/g;
+ "'$string'";
+}
+
+__END__
+
+=head1 NAME
+
+find2perl - translate find command lines to Perl code
+
+=head1 SYNOPSIS
+
+ find2perl [paths] [predicates] | perl
+
+=head1 DESCRIPTION
+
+find2perl is a little translator to convert find command lines to
+equivalent Perl code. The resulting code is typically faster than
+running find itself.
+
+"paths" are a set of paths where find2perl will start its searches and
+"predicates" are taken from the following list.
+
+=over 4
+
+=item C<! PREDICATE>
+
+Negate the sense of the following predicate. The C<!> must be passed as
+a distinct argument, so it may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<( PREDICATES )>
+
+Group the given PREDICATES. The parentheses must be passed as distinct
+arguments, so they may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<PREDICATE1 PREDICATE2>
+
+True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
+evaluated if PREDICATE1 is false.
+
+=item C<PREDICATE1 -o PREDICATE2>
+
+True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
+not evaluated if PREDICATE1 is true.
+
+=item C<-follow>
+
+Follow (dereference) symlinks. The checking of file attributes depends
+on the position of the C<-follow> option. If it precedes the file
+check option, an C<stat> is done which means the file check applies to the
+file the symbolic link is pointing to. If C<-follow> option follows the
+file check option, this now applies to the symbolic link itself, i.e.
+an C<lstat> is done.
+
+=item C<-depth>
+
+Change directory traversal algorithm from breadth-first to depth-first.
+
+=item C<-prune>
+
+Do not descend into the directory currently matched.
+
+=item C<-xdev>
+
+Do not traverse mount points (prunes search at mount-point directories).
+
+=item C<-name GLOB>
+
+File name matches specified GLOB wildcard pattern. GLOB may need to be
+quoted to avoid interpretation by the shell (just as with using
+C<find(1)>).
+
+=item C<-iname GLOB>
+
+Like C<-name>, but the match is case insensitive.
+
+=item C<-path GLOB>
+
+Path name matches specified GLOB wildcard pattern.
+
+=item C<-ipath GLOB>
+
+Like C<-path>, but the match is case insensitive.
+
+=item C<-perm PERM>
+
+Low-order 9 bits of permission match octal value PERM.
+
+=item C<-perm -PERM>
+
+The bits specified in PERM are all set in file's permissions.
+
+=item C<-type X>
+
+The file's type matches perl's C<-X> operator.
+
+=item C<-fstype TYPE>
+
+Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
+is implemented).
+
+=item C<-user USER>
+
+True if USER is owner of file.
+
+=item C<-group GROUP>
+
+True if file's group is GROUP.
+
+=item C<-nouser>
+
+True if file's owner is not in password database.
+
+=item C<-nogroup>
+
+True if file's group is not in group database.
+
+=item C<-inum INUM>
+
+True file's inode number is INUM.
+
+=item C<-links N>
+
+True if (hard) link count of file matches N (see below).
+
+=item C<-size N>
+
+True if file's size matches N (see below) N is normally counted in
+512-byte blocks, but a suffix of "c" specifies that size should be
+counted in characters (bytes) and a suffix of "k" specifies that
+size should be counted in 1024-byte blocks.
+
+=item C<-atime N>
+
+True if last-access time of file matches N (measured in days) (see
+below).
+
+=item C<-ctime N>
+
+True if last-changed time of file's inode matches N (measured in days,
+see below).
+
+=item C<-mtime N>
+
+True if last-modified time of file matches N (measured in days, see below).
+
+=item C<-newer FILE>
+
+True if last-modified time of file matches N.
+
+=item C<-print>
+
+Print out path of file (always true). If none of C<-exec>, C<-ls>,
+C<-print0>, or C<-ok> is specified, then C<-print> will be added
+implicitly.
+
+=item C<-print0>
+
+Like -print, but terminates with \0 instead of \n.
+
+=item C<-exec OPTIONS ;>
+
+exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
+OPTIONS will first be substituted with the path of the current
+file. Note that the command "rm" has been special-cased to use perl's
+unlink() function instead (as an optimization). The C<;> must be passed as
+a distinct argument, so it may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<-ok OPTIONS ;>
+
+Like -exec, but first prompts user; if user's response does not begin
+with a y, skip the exec. The C<;> must be passed as
+a distinct argument, so it may need to be surrounded by whitespace and/or
+quoted from interpretation by the shell using a backslash (just as with
+using C<find(1)>).
+
+=item C<-eval EXPR>
+
+Has the perl script eval() the EXPR.
+
+=item C<-ls>
+
+Simulates C<-exec ls -dils {} ;>
+
+=item C<-tar FILE>
+
+Adds current output to tar-format FILE.
+
+=item C<-cpio FILE>
+
+Adds current output to old-style cpio-format FILE.
+
+=item C<-ncpio FILE>
+
+Adds current output to "new"-style cpio-format FILE.
+
+=back
+
+Predicates which take a numeric argument N can come in three forms:
+
+ * N is prefixed with a +: match values greater than N
+ * N is prefixed with a -: match values less than N
+ * N is not prefixed with either + or -: match only values equal to N
+
+=head1 SEE ALSO
+
+find, File::Find.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/findrule b/Master/tlpkg/tlperl/bin/findrule new file mode 100755 index 00000000000..6aa37d64f1c --- /dev/null +++ b/Master/tlpkg/tlperl/bin/findrule @@ -0,0 +1,138 @@ +#!perl -w +use strict; +use File::Find::Rule; +use File::Spec::Functions qw(catdir); + +# bootstrap extensions +for (@INC) { + my $dir = catdir($_, qw( File Find Rule ) ); + next unless -d $dir; + my @pm = find( name => '*.pm', maxdepth => 1, + exec => sub { (my $name = $_) =~ s/\.pm$//; + eval "require File::Find::Rule::$name"; }, + in => $dir ); +} + +# what directories are we searching in? +my @where; +while (@ARGV) { + local $_ = shift @ARGV; + if (/^-/) { + unshift @ARGV, $_; + last; + } + push @where, $_; +} + +# parse arguments, build a rule object +my $rule = new File::Find::Rule; +while (@ARGV) { + my $clause = shift @ARGV; + + unless ( $clause =~ s/^-// && $rule->can( $clause ) ) { + # not a known rule - complain about this + die "unknown option '$clause'\n" + } + + # it was the last switch + unless (@ARGV) { + $rule->$clause(); + next; + } + + # consume the parameters + my $param = shift @ARGV; + + if ($param =~ /^-/) { + # it's the next switch - put it back, and add one with no params + unshift @ARGV, $param; + $rule->$clause(); + next; + } + + if ($param eq '(') { + # multiple values - just look for the closing parenthesis + my @p; + while (@ARGV) { + my $val = shift @ARGV; + last if $val eq ')'; + push @p, $val; + } + $rule->$clause( @p ); + next; + } + + # a single argument + $rule->$clause( $param ); +} + +# add a print rule so things happen faster +$rule->exec( sub { print "$_[2]\n"; return; } ); + +# profit +$rule->in( @where ? @where : '.' ); +exit 0; + +__END__ + +=head1 NAME + +findrule - command line wrapper to File::Find::Rule + +=head1 USAGE + + findrule [path...] [expression] + +=head1 DESCRIPTION + +C<findrule> mostly borrows the interface from GNU find(1) to provide a +command-line interface onto the File::Find::Rule heirarchy of modules. + +The syntax for expressions is the rule name, preceded by a dash, +followed by an optional argument. If the argument is an opening +parenthesis it is taken as a list of arguments, terminated by a +closing parenthesis. + +Some examples: + + find -file -name ( foo bar ) + +files named C<foo> or C<bar>, below the current directory. + + find -file -name foo -bar + +files named C<foo>, that have pubs (for this is what our ficticious +C<bar> clause specifies), below the current directory. + + find -file -name ( -bar ) + +files named C<-bar>, below the current directory. In this case if +we'd have omitted the parenthesis it would have parsed as a call to +name with no arguments, followed by a call to -bar. + +=head2 Supported switches + +I'm very slack. Please consult the File::Find::Rule manpage for now, +and prepend - to the commands that you want. + +=head2 Extra bonus switches + +findrule automatically loads all of your installed File::Find::Rule::* +extension modules, so check the documentation to see what those would be. + +=head1 AUTHOR + +Richard Clamp <richardc@unixbeard.net> from a suggestion by Tatsuhiko Miyagawa + +=head1 COPYRIGHT + +Copyright (C) 2002 Richard Clamp. 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 + +L<File::Find::Rule> + +=cut diff --git a/Master/tlpkg/tlperl/bin/findrule.bat b/Master/tlpkg/tlperl/bin/findrule.bat new file mode 100755 index 00000000000..82bfb986fba --- /dev/null +++ b/Master/tlpkg/tlperl/bin/findrule.bat @@ -0,0 +1,154 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+use strict;
+use File::Find::Rule;
+use File::Spec::Functions qw(catdir);
+
+# bootstrap extensions
+for (@INC) {
+ my $dir = catdir($_, qw( File Find Rule ) );
+ next unless -d $dir;
+ my @pm = find( name => '*.pm', maxdepth => 1,
+ exec => sub { (my $name = $_) =~ s/\.pm$//;
+ eval "require File::Find::Rule::$name"; },
+ in => $dir );
+}
+
+# what directories are we searching in?
+my @where;
+while (@ARGV) {
+ local $_ = shift @ARGV;
+ if (/^-/) {
+ unshift @ARGV, $_;
+ last;
+ }
+ push @where, $_;
+}
+
+# parse arguments, build a rule object
+my $rule = new File::Find::Rule;
+while (@ARGV) {
+ my $clause = shift @ARGV;
+
+ unless ( $clause =~ s/^-// && $rule->can( $clause ) ) {
+ # not a known rule - complain about this
+ die "unknown option '$clause'\n"
+ }
+
+ # it was the last switch
+ unless (@ARGV) {
+ $rule->$clause();
+ next;
+ }
+
+ # consume the parameters
+ my $param = shift @ARGV;
+
+ if ($param =~ /^-/) {
+ # it's the next switch - put it back, and add one with no params
+ unshift @ARGV, $param;
+ $rule->$clause();
+ next;
+ }
+
+ if ($param eq '(') {
+ # multiple values - just look for the closing parenthesis
+ my @p;
+ while (@ARGV) {
+ my $val = shift @ARGV;
+ last if $val eq ')';
+ push @p, $val;
+ }
+ $rule->$clause( @p );
+ next;
+ }
+
+ # a single argument
+ $rule->$clause( $param );
+}
+
+# add a print rule so things happen faster
+$rule->exec( sub { print "$_[2]\n"; return; } );
+
+# profit
+$rule->in( @where ? @where : '.' );
+exit 0;
+
+__END__
+
+=head1 NAME
+
+findrule - command line wrapper to File::Find::Rule
+
+=head1 USAGE
+
+ findrule [path...] [expression]
+
+=head1 DESCRIPTION
+
+C<findrule> mostly borrows the interface from GNU find(1) to provide a
+command-line interface onto the File::Find::Rule heirarchy of modules.
+
+The syntax for expressions is the rule name, preceded by a dash,
+followed by an optional argument. If the argument is an opening
+parenthesis it is taken as a list of arguments, terminated by a
+closing parenthesis.
+
+Some examples:
+
+ find -file -name ( foo bar )
+
+files named C<foo> or C<bar>, below the current directory.
+
+ find -file -name foo -bar
+
+files named C<foo>, that have pubs (for this is what our ficticious
+C<bar> clause specifies), below the current directory.
+
+ find -file -name ( -bar )
+
+files named C<-bar>, below the current directory. In this case if
+we'd have omitted the parenthesis it would have parsed as a call to
+name with no arguments, followed by a call to -bar.
+
+=head2 Supported switches
+
+I'm very slack. Please consult the File::Find::Rule manpage for now,
+and prepend - to the commands that you want.
+
+=head2 Extra bonus switches
+
+findrule automatically loads all of your installed File::Find::Rule::*
+extension modules, so check the documentation to see what those would be.
+
+=head1 AUTHOR
+
+Richard Clamp <richardc@unixbeard.net> from a suggestion by Tatsuhiko Miyagawa
+
+=head1 COPYRIGHT
+
+Copyright (C) 2002 Richard Clamp. 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
+
+L<File::Find::Rule>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/gedi b/Master/tlpkg/tlperl/bin/gedi new file mode 100755 index 00000000000..c42bbb6fdd6 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/gedi @@ -0,0 +1,315 @@ +#!/usr/local/bin/perl -w + +############################################################################### +# Copyright (c) 1999 Greg London +# All rights reserved. +# This program is free software. +# You can redistribute it and/or modify it under the same terms as Perl itself. +############################################################################### + +############################################################################### +# This is a perl application, called gedi, implementing a text editor. +# gedi is short for Greg's EDItor. The "g" being pronounced like a "j". +############################################################################### + + +require 5; +use locale; +use strict; + +use Tk; +use Tk::widgets qw(TextEdit); +use File::Basename; + +########################################### +# check command line parameter. +# if none, start with file called 'NewFile' +# if -help, print help +# if filename, open file or die +# note, wildcard automatically gets handled by perl interpreter, +# so that @ARGV contains list of matches. +########################################### + +# Create MainWindow first to handle X11 options. +my $top = MainWindow->new(); + +my $argcount = @ARGV; +my ($global_filename) = @ARGV; + +if ($argcount>1) + { + print "\n"; + print "ERROR: too many files specified. \n"; + die "\n"; + } + +if ($argcount == 0) + {$global_filename = 'NoName';} + +if ( + ($global_filename eq 'help') || + ($global_filename eq '-help') || + ($global_filename eq '-h') || + ($global_filename eq '-?') + ) + { + print "\n"; + print "$0 expects one command line argument: \n"; + print " the name of the file to edit \n"; + die "\n"; + } + + +# want FileSelect to use the last used directory as the starting directory +# store directory in $global_directory. +my $global_directory = dirname($global_filename); + +############################################## +############################################## +## input parameters have been filtered. +## set up three frames to put everything into. +## menu_frame, text_frame, counter_frame +############################################## +############################################## +# my $menu_frame = $top->Frame->pack(-anchor=>'nw'); +my $text_frame = $top->Frame->pack + (-anchor=>'nw', -expand=>'yes', -fill => 'both'); # autosizing +my $counter_frame = $top->Frame->pack(-anchor=>'nw'); + +############################################## +############################################## +## now set up text window with contents. +############################################## +############################################## + +## autosizing is set up such that when the outside window is +## resized, the text box adjusts to fill everything else in. +## the text frame and the text window in the frame are both +## set up for autosizing. + +my $textwindow = $text_frame->Scrolled( + 'TextEdit', + -exportselection => 'true', # 'sel' tag is associated with selections + # initial height, if it isnt 1, then autosizing fails + # once window shrinks below height + # and the line counters go off the screen. + # seems to be a problem with the Tk::pack command; + -height => 1, + -background => 'white', + -wrap=> 'none', + -setgrid => 'true', # use this for autosizing + -scrollbars =>'se') + -> pack(-expand => 'yes' , -fill => 'both'); # autosizing + +#$textwindow->FileName($global_filename); + + +$top->protocol('WM_DELETE_WINDOW'=> + sub{$textwindow->ConfirmExit;} + ); + +$SIG{INT} = sub {$textwindow->ConfirmExit;}; + +############################################## +############################################## +## set up current line number display +############################################## +############################################## +my $current_line_label = $counter_frame + -> Label(-text=>'line: 1') + -> grid(-row=>1,-column=>1, -sticky=>'nw' ); + +my $total_line_label = $counter_frame + -> Label(-text=>'total lines: 1') + -> grid(-row=>2,-column=>1, -sticky=>'nw' ); + +my $current_column_label = $counter_frame + -> Label(-text=>'column: 0') + -> grid(-row=>3,-column=>1, -sticky=>'nw' ); + +my $insert_overstrike_mode_label = $counter_frame + -> Label(-text=>' ') + -> grid(-row=>5,-column=>1, -sticky=>'nw' ); + +sub update_indicators +{ + my ($line,$column)= split(/\./,$textwindow->index('insert')); + $current_line_label->configure (-text=> "line: $line"); + $current_column_label->configure (-text=> "column: $column"); + + my ($last_line,$last_col) = split(/\./,$textwindow->index('end')); + $total_line_label->configure (-text=> "total lines: $last_line"); + + my $mode = $textwindow->OverstrikeMode; + my $overstrke_insert='Insert Mode'; + if ($mode) + {$overstrke_insert='Overstrike Mode';} + $insert_overstrike_mode_label->configure + (-text=> "$overstrke_insert"); + + my $filename = $textwindow->FileName; + $filename = 'NoName' unless(defined($filename)); + my $edit_flag=''; + if($textwindow->numberChanges) + {$edit_flag='edited';} + $top->configure(-title => "Gedi $edit_flag $filename"); + $textwindow->idletasks; + +} + +$textwindow->SetGUICallbacks ( + [ + \&update_indicators, + sub{$textwindow->HighlightAllPairsBracketingCursor} + ] +); + + +############################################## +############################################## +# call back functions +############################################## +############################################## + +######################################################################## +my $about_pop_up_reference; +sub about_pop_up +{ + my $name = ref($about_pop_up_reference); + if (defined($about_pop_up_reference)) + { + $about_pop_up_reference->raise; + $about_pop_up_reference->focus; + } + else + { + my $pop = $top->Toplevel(); + $pop->title("About"); + + $pop->Label(-text=>"Gedi (Gregs EDItor)")->pack(); + $pop->Label(-text=>"Ver. 1.0")->pack(); + $pop->Label(-text=>"Copyright 1999")->pack(); + $pop->Label(-text=>"Greg London")->pack(); + $pop->Label(-text=>"All Rights Reserved.")->pack(); + $pop->Label(-text=>"This program is free software.")->pack(); + $pop->Label(-text=>"You can redistribute it and/or")->pack(); + $pop->Label(-text=>"modify it under the same terms")->pack(); + $pop->Label(-text=>"as Perl itself.")->pack(); + $pop->Label(-text=>"Special Thanks to")->pack(); + $pop->Label(-text=>"Nick Ing-Simmons.")->pack(); + + my $button_ok = $pop->Button(-text=>'OK', + -command => sub {$pop->destroy(); + $about_pop_up_reference = undef; + } ) + ->pack(); + $pop->resizable('no','no'); + $about_pop_up_reference = $pop; + } +} + +############################################## +############################################## +## now set up menu bar +############################################## +############################################## + +my $menu = $textwindow->menu; +$top->configure(-menu => $menu); + +############################################## +# help menu +############################################## +my $help_menu = $menu->cascade(-label=>'~Help', -tearoff => 0, -menuitems => [ + [Command => 'A~bout', -command => \&about_pop_up] + ]); + +############################################## +# debug menu +############################################## + +if (0) + { + my $debug_menu = $menu->cascade(-label=>'debug', -underline=>0); + + + $debug_menu->command(-label => 'Tag names', -underline=> 0 , + -command => + sub{ + my @tags = $textwindow->tagNames(); + print " @tags\n"; + + foreach my $tag (@tags) + { + my @ranges = $textwindow->tagRanges($tag); + print "tag: $tag ranges: @ranges \n"; + } + + print "\n\n\n"; + my @marks = $textwindow->markNames; + print " @marks \n"; + foreach my $mark (@marks) + { + my $mark_location = $textwindow->index($mark); + print "$mark is at $mark_location\n"; + } + + + print "\n\n\n"; + my @dump = $textwindow->dump ( '-tag', '1.0', '465.0' ); + print "@dump \n"; + + print "\n\n\n"; + print "showing tops children:"; + my @children = $top->children(); + print "@children\n"; + + foreach my $child (@children) + { + my $junk = ref($child); + print "ref of $child is $junk \n"; + } + + my $overstrike = $textwindow->OverstrikeMode; + print "Overstrike is $overstrike \n"; + + $textwindow->dump_array($textwindow); + }); + } + +############################################## +# set the window to a normal size and set the minimum size +$top->minsize(30,1); +$top->geometry("80x24"); + +############################################################################# +############################################################################# +############################################################################# +############################################################################# + + + + +############################################## +## this line for debug +## $top->bind('<Key>', [sub{print "ARGS: @_\n";}, Ev('k'), Ev('K') ] ); + +########################################## +## fill the text window with initial file. + +if ($argcount) + { + if (-e $global_filename) # if it doesn't exist, make it empty + { + # it may be a big file, draw the window, and then load it + # so that we know something is happening. + $top->update; + $textwindow->Load($global_filename); + } + } + + +############################################## +$textwindow->CallNextGUICallback; + +MainLoop(); diff --git a/Master/tlpkg/tlperl/bin/gedi.bat b/Master/tlpkg/tlperl/bin/gedi.bat new file mode 100755 index 00000000000..bf0a7d28ebf --- /dev/null +++ b/Master/tlpkg/tlperl/bin/gedi.bat @@ -0,0 +1,331 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+
+###############################################################################
+# Copyright (c) 1999 Greg London
+# All rights reserved.
+# This program is free software.
+# You can redistribute it and/or modify it under the same terms as Perl itself.
+###############################################################################
+
+###############################################################################
+# This is a perl application, called gedi, implementing a text editor.
+# gedi is short for Greg's EDItor. The "g" being pronounced like a "j".
+###############################################################################
+
+
+require 5;
+use locale;
+use strict;
+
+use Tk;
+use Tk::widgets qw(TextEdit);
+use File::Basename;
+
+###########################################
+# check command line parameter.
+# if none, start with file called 'NewFile'
+# if -help, print help
+# if filename, open file or die
+# note, wildcard automatically gets handled by perl interpreter,
+# so that @ARGV contains list of matches.
+###########################################
+
+# Create MainWindow first to handle X11 options.
+my $top = MainWindow->new();
+
+my $argcount = @ARGV;
+my ($global_filename) = @ARGV;
+
+if ($argcount>1)
+ {
+ print "\n";
+ print "ERROR: too many files specified. \n";
+ die "\n";
+ }
+
+if ($argcount == 0)
+ {$global_filename = 'NoName';}
+
+if (
+ ($global_filename eq 'help') ||
+ ($global_filename eq '-help') ||
+ ($global_filename eq '-h') ||
+ ($global_filename eq '-?')
+ )
+ {
+ print "\n";
+ print "$0 expects one command line argument: \n";
+ print " the name of the file to edit \n";
+ die "\n";
+ }
+
+
+# want FileSelect to use the last used directory as the starting directory
+# store directory in $global_directory.
+my $global_directory = dirname($global_filename);
+
+##############################################
+##############################################
+## input parameters have been filtered.
+## set up three frames to put everything into.
+## menu_frame, text_frame, counter_frame
+##############################################
+##############################################
+# my $menu_frame = $top->Frame->pack(-anchor=>'nw');
+my $text_frame = $top->Frame->pack
+ (-anchor=>'nw', -expand=>'yes', -fill => 'both'); # autosizing
+my $counter_frame = $top->Frame->pack(-anchor=>'nw');
+
+##############################################
+##############################################
+## now set up text window with contents.
+##############################################
+##############################################
+
+## autosizing is set up such that when the outside window is
+## resized, the text box adjusts to fill everything else in.
+## the text frame and the text window in the frame are both
+## set up for autosizing.
+
+my $textwindow = $text_frame->Scrolled(
+ 'TextEdit',
+ -exportselection => 'true', # 'sel' tag is associated with selections
+ # initial height, if it isnt 1, then autosizing fails
+ # once window shrinks below height
+ # and the line counters go off the screen.
+ # seems to be a problem with the Tk::pack command;
+ -height => 1,
+ -background => 'white',
+ -wrap=> 'none',
+ -setgrid => 'true', # use this for autosizing
+ -scrollbars =>'se')
+ -> pack(-expand => 'yes' , -fill => 'both'); # autosizing
+
+#$textwindow->FileName($global_filename);
+
+
+$top->protocol('WM_DELETE_WINDOW'=>
+ sub{$textwindow->ConfirmExit;}
+ );
+
+$SIG{INT} = sub {$textwindow->ConfirmExit;};
+
+##############################################
+##############################################
+## set up current line number display
+##############################################
+##############################################
+my $current_line_label = $counter_frame
+ -> Label(-text=>'line: 1')
+ -> grid(-row=>1,-column=>1, -sticky=>'nw' );
+
+my $total_line_label = $counter_frame
+ -> Label(-text=>'total lines: 1')
+ -> grid(-row=>2,-column=>1, -sticky=>'nw' );
+
+my $current_column_label = $counter_frame
+ -> Label(-text=>'column: 0')
+ -> grid(-row=>3,-column=>1, -sticky=>'nw' );
+
+my $insert_overstrike_mode_label = $counter_frame
+ -> Label(-text=>' ')
+ -> grid(-row=>5,-column=>1, -sticky=>'nw' );
+
+sub update_indicators
+{
+ my ($line,$column)= split(/\./,$textwindow->index('insert'));
+ $current_line_label->configure (-text=> "line: $line");
+ $current_column_label->configure (-text=> "column: $column");
+
+ my ($last_line,$last_col) = split(/\./,$textwindow->index('end'));
+ $total_line_label->configure (-text=> "total lines: $last_line");
+
+ my $mode = $textwindow->OverstrikeMode;
+ my $overstrke_insert='Insert Mode';
+ if ($mode)
+ {$overstrke_insert='Overstrike Mode';}
+ $insert_overstrike_mode_label->configure
+ (-text=> "$overstrke_insert");
+
+ my $filename = $textwindow->FileName;
+ $filename = 'NoName' unless(defined($filename));
+ my $edit_flag='';
+ if($textwindow->numberChanges)
+ {$edit_flag='edited';}
+ $top->configure(-title => "Gedi $edit_flag $filename");
+ $textwindow->idletasks;
+
+}
+
+$textwindow->SetGUICallbacks (
+ [
+ \&update_indicators,
+ sub{$textwindow->HighlightAllPairsBracketingCursor}
+ ]
+);
+
+
+##############################################
+##############################################
+# call back functions
+##############################################
+##############################################
+
+########################################################################
+my $about_pop_up_reference;
+sub about_pop_up
+{
+ my $name = ref($about_pop_up_reference);
+ if (defined($about_pop_up_reference))
+ {
+ $about_pop_up_reference->raise;
+ $about_pop_up_reference->focus;
+ }
+ else
+ {
+ my $pop = $top->Toplevel();
+ $pop->title("About");
+
+ $pop->Label(-text=>"Gedi (Gregs EDItor)")->pack();
+ $pop->Label(-text=>"Ver. 1.0")->pack();
+ $pop->Label(-text=>"Copyright 1999")->pack();
+ $pop->Label(-text=>"Greg London")->pack();
+ $pop->Label(-text=>"All Rights Reserved.")->pack();
+ $pop->Label(-text=>"This program is free software.")->pack();
+ $pop->Label(-text=>"You can redistribute it and/or")->pack();
+ $pop->Label(-text=>"modify it under the same terms")->pack();
+ $pop->Label(-text=>"as Perl itself.")->pack();
+ $pop->Label(-text=>"Special Thanks to")->pack();
+ $pop->Label(-text=>"Nick Ing-Simmons.")->pack();
+
+ my $button_ok = $pop->Button(-text=>'OK',
+ -command => sub {$pop->destroy();
+ $about_pop_up_reference = undef;
+ } )
+ ->pack();
+ $pop->resizable('no','no');
+ $about_pop_up_reference = $pop;
+ }
+}
+
+##############################################
+##############################################
+## now set up menu bar
+##############################################
+##############################################
+
+my $menu = $textwindow->menu;
+$top->configure(-menu => $menu);
+
+##############################################
+# help menu
+##############################################
+my $help_menu = $menu->cascade(-label=>'~Help', -tearoff => 0, -menuitems => [
+ [Command => 'A~bout', -command => \&about_pop_up]
+ ]);
+
+##############################################
+# debug menu
+##############################################
+
+if (0)
+ {
+ my $debug_menu = $menu->cascade(-label=>'debug', -underline=>0);
+
+
+ $debug_menu->command(-label => 'Tag names', -underline=> 0 ,
+ -command =>
+ sub{
+ my @tags = $textwindow->tagNames();
+ print " @tags\n";
+
+ foreach my $tag (@tags)
+ {
+ my @ranges = $textwindow->tagRanges($tag);
+ print "tag: $tag ranges: @ranges \n";
+ }
+
+ print "\n\n\n";
+ my @marks = $textwindow->markNames;
+ print " @marks \n";
+ foreach my $mark (@marks)
+ {
+ my $mark_location = $textwindow->index($mark);
+ print "$mark is at $mark_location\n";
+ }
+
+
+ print "\n\n\n";
+ my @dump = $textwindow->dump ( '-tag', '1.0', '465.0' );
+ print "@dump \n";
+
+ print "\n\n\n";
+ print "showing tops children:";
+ my @children = $top->children();
+ print "@children\n";
+
+ foreach my $child (@children)
+ {
+ my $junk = ref($child);
+ print "ref of $child is $junk \n";
+ }
+
+ my $overstrike = $textwindow->OverstrikeMode;
+ print "Overstrike is $overstrike \n";
+
+ $textwindow->dump_array($textwindow);
+ });
+ }
+
+##############################################
+# set the window to a normal size and set the minimum size
+$top->minsize(30,1);
+$top->geometry("80x24");
+
+#############################################################################
+#############################################################################
+#############################################################################
+#############################################################################
+
+
+
+
+##############################################
+## this line for debug
+## $top->bind('<Key>', [sub{print "ARGS: @_\n";}, Ev('k'), Ev('K') ] );
+
+##########################################
+## fill the text window with initial file.
+
+if ($argcount)
+ {
+ if (-e $global_filename) # if it doesn't exist, make it empty
+ {
+ # it may be a big file, draw the window, and then load it
+ # so that we know something is happening.
+ $top->update;
+ $textwindow->Load($global_filename);
+ }
+ }
+
+
+##############################################
+$textwindow->CallNextGUICallback;
+
+MainLoop();
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/h2ph.bat b/Master/tlpkg/tlperl/bin/h2ph.bat new file mode 100755 index 00000000000..eb1f7862961 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/h2ph.bat @@ -0,0 +1,959 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+use strict;
+
+use Config;
+use File::Path qw(mkpath);
+use Getopt::Std;
+
+# Make sure read permissions for all are set:
+if (defined umask && (umask() & 0444)) {
+ umask (umask() & ~0444);
+}
+
+getopts('Dd:rlhaQe');
+use vars qw($opt_D $opt_d $opt_r $opt_l $opt_h $opt_a $opt_Q $opt_e);
+die "-r and -a options are mutually exclusive\n" if ($opt_r and $opt_a);
+my @inc_dirs = inc_dirs() if $opt_a;
+
+my $Exit = 0;
+
+my $Dest_dir = $opt_d || $Config{installsitearch};
+die "Destination directory $Dest_dir doesn't exist or isn't a directory\n"
+ unless -d $Dest_dir;
+
+my @isatype = qw(
+ char uchar u_char
+ short ushort u_short
+ int uint u_int
+ long ulong u_long
+ FILE key_t caddr_t
+ float double size_t
+);
+
+my %isatype;
+@isatype{@isatype} = (1) x @isatype;
+my $inif = 0;
+my %Is_converted;
+my %bad_file = ();
+
+@ARGV = ('-') unless @ARGV;
+
+build_preamble_if_necessary();
+
+sub reindent($) {
+ my($text) = shift;
+ $text =~ s/\n/\n /g;
+ $text =~ s/ /\t/g;
+ $text;
+}
+
+my ($t, $tab, %curargs, $new, $eval_index, $dir, $name, $args, $outfile);
+my ($incl, $incl_type, $incl_quote, $next);
+while (defined (my $file = next_file())) {
+ if (-l $file and -d $file) {
+ link_if_possible($file) if ($opt_l);
+ next;
+ }
+
+ # Recover from header files with unbalanced cpp directives
+ $t = '';
+ $tab = 0;
+
+ # $eval_index goes into ``#line'' directives, to help locate syntax errors:
+ $eval_index = 1;
+
+ if ($file eq '-') {
+ open(IN, "-");
+ open(OUT, ">-");
+ } else {
+ ($outfile = $file) =~ s/\.h$/.ph/ || next;
+ print "$file -> $outfile\n" unless $opt_Q;
+ if ($file =~ m|^(.*)/|) {
+ $dir = $1;
+ mkpath "$Dest_dir/$dir";
+ }
+
+ if ($opt_a) { # automagic mode: locate header file in @inc_dirs
+ foreach (@inc_dirs) {
+ chdir $_;
+ last if -f $file;
+ }
+ }
+
+ open(IN,"$file") || (($Exit = 1),(warn "Can't open $file: $!\n"),next);
+ open(OUT,">$Dest_dir/$outfile") || die "Can't create $outfile: $!\n";
+ }
+
+ print OUT
+ "require '_h2ph_pre.ph';\n\n",
+ "no warnings qw(redefine misc);\n\n";
+
+ while (defined (local $_ = next_line($file))) {
+ if (s/^\s*\#\s*//) {
+ if (s/^define\s+(\w+)//) {
+ $name = $1;
+ $new = '';
+ s/\s+$//;
+ s/\(\w+\s*\(\*\)\s*\(\w*\)\)\s*(-?\d+)/$1/; # (int (*)(foo_t))0
+ if (s/^\(([\w,\s]*)\)//) {
+ $args = $1;
+ my $proto = '() ';
+ if ($args ne '') {
+ $proto = '';
+ foreach my $arg (split(/,\s*/,$args)) {
+ $arg =~ s/^\s*([^\s].*[^\s])\s*$/$1/;
+ $curargs{$arg} = 1;
+ }
+ $args =~ s/\b(\w)/\$$1/g;
+ $args = "my($args) = \@_;\n$t ";
+ }
+ s/^\s+//;
+ expr();
+ $new =~ s/(["\\])/\\$1/g; #"]);
+ EMIT:
+ $new = reindent($new);
+ $args = reindent($args);
+ if ($t ne '') {
+ $new =~ s/(['\\])/\\$1/g; #']);
+ if ($opt_h) {
+ print OUT $t,
+ "eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
+ $eval_index++;
+ } else {
+ print OUT $t,
+ "eval 'sub $name $proto\{\n$t ${args}eval q($new);\n$t}' unless defined(\&$name);\n";
+ }
+ } else {
+ print OUT "unless(defined(\&$name)) {\n sub $name $proto\{\n\t${args}eval q($new);\n }\n}\n";
+ }
+ %curargs = ();
+ } else {
+ s/^\s+//;
+ expr();
+ $new = 1 if $new eq '';
+ $new = reindent($new);
+ $args = reindent($args);
+ if ($t ne '') {
+ $new =~ s/(['\\])/\\$1/g; #']);
+
+ if ($opt_h) {
+ print OUT $t,"eval \"\\n#line $eval_index $outfile\\n\" . 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+ $eval_index++;
+ } else {
+ print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
+ }
+ } else {
+ # Shunt around such directives as `#define FOO FOO':
+ next if " \&$name" eq $new;
+
+ print OUT $t,"unless(defined(\&$name)) {\n sub $name () {\t",$new,";}\n}\n";
+ }
+ }
+ } elsif (/^(include|import|include_next)\s*([<\"])(.*)[>\"]/) {
+ $incl_type = $1;
+ $incl_quote = $2;
+ $incl = $3;
+ if (($incl_type eq 'include_next') ||
+ ($opt_e && exists($bad_file{$incl}))) {
+ $incl =~ s/\.h$/.ph/;
+ print OUT ($t,
+ "eval {\n");
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT ($t, "my(\@REM);\n");
+ if ($incl_type eq 'include_next') {
+ print OUT ($t,
+ "my(\%INCD) = map { \$INC{\$_} => 1 } ",
+ "(grep { \$_ eq \"$incl\" } ",
+ "keys(\%INC));\n");
+ print OUT ($t,
+ "\@REM = map { \"\$_/$incl\" } ",
+ "(grep { not exists(\$INCD{\"\$_/$incl\"})",
+ " and -f \"\$_/$incl\" } \@INC);\n");
+ } else {
+ print OUT ($t,
+ "\@REM = map { \"\$_/$incl\" } ",
+ "(grep {-r \"\$_/$incl\" } \@INC);\n");
+ }
+ print OUT ($t,
+ "require \"\$REM[0]\" if \@REM;\n");
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT ($t,
+ "};\n");
+ print OUT ($t,
+ "warn(\$\@) if \$\@;\n");
+ } else {
+ $incl =~ s/\.h$/.ph/;
+ # copy the prefix in the quote syntax (#include "x.h") case
+ if ($incl !~ m|/| && $incl_quote eq q{"} && $file =~ m|^(.*)/|) {
+ $incl = "$1/$incl";
+ }
+ print OUT $t,"require '$incl';\n";
+ }
+ } elsif (/^ifdef\s+(\w+)/) {
+ print OUT $t,"if(defined(&$1)) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (/^ifndef\s+(\w+)/) {
+ print OUT $t,"unless(defined(&$1)) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (s/^if\s+//) {
+ $new = '';
+ $inif = 1;
+ expr();
+ $inif = 0;
+ print OUT $t,"if($new) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (s/^elif\s+//) {
+ $new = '';
+ $inif = 1;
+ expr();
+ $inif = 0;
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"}\n elsif($new) {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (/^else/) {
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"} else {\n";
+ $tab += 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ } elsif (/^endif/) {
+ $tab -= 4;
+ $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
+ print OUT $t,"}\n";
+ } elsif(/^undef\s+(\w+)/) {
+ print OUT $t, "undef(&$1) if defined(&$1);\n";
+ } elsif(/^error\s+(".*")/) {
+ print OUT $t, "die($1);\n";
+ } elsif(/^error\s+(.*)/) {
+ print OUT $t, "die(\"", quotemeta($1), "\");\n";
+ } elsif(/^warning\s+(.*)/) {
+ print OUT $t, "warn(\"", quotemeta($1), "\");\n";
+ } elsif(/^ident\s+(.*)/) {
+ print OUT $t, "# $1\n";
+ }
+ } elsif (/^\s*(typedef\s*)?enum\s*(\s+[a-zA-Z_]\w*\s*)?/) { # { for vi
+ until(/\{[^}]*\}.*;/ || /;/) {
+ last unless defined ($next = next_line($file));
+ chomp $next;
+ # drop "#define FOO FOO" in enums
+ $next =~ s/^\s*#\s*define\s+(\w+)\s+\1\s*$//;
+ # #defines in enums (aliases)
+ $next =~ s/^\s*#\s*define\s+(\w+)\s+(\w+)\s*$/$1 = $2,/;
+ $_ .= $next;
+ print OUT "# $next\n" if $opt_D;
+ }
+ s/#\s*if.*?#\s*endif//g; # drop #ifdefs
+ s@/\*.*?\*/@@g;
+ s/\s+/ /g;
+ next unless /^\s?(typedef\s?)?enum\s?([a-zA-Z_]\w*)?\s?\{(.*)\}\s?([a-zA-Z_]\w*)?\s?;/;
+ (my $enum_subs = $3) =~ s/\s//g;
+ my @enum_subs = split(/,/, $enum_subs);
+ my $enum_val = -1;
+ foreach my $enum (@enum_subs) {
+ my ($enum_name, $enum_value) = $enum =~ /^([a-zA-Z_]\w*)(=.+)?$/;
+ $enum_name or next;
+ $enum_value =~ s/^=//;
+ $enum_val = (length($enum_value) ? $enum_value : $enum_val + 1);
+ if ($opt_h) {
+ print OUT ($t,
+ "eval(\"\\n#line $eval_index $outfile\\n",
+ "sub $enum_name () \{ $enum_val; \}\") ",
+ "unless defined(\&$enum_name);\n");
+ ++ $eval_index;
+ } else {
+ print OUT ($t,
+ "eval(\"sub $enum_name () \{ $enum_val; \}\") ",
+ "unless defined(\&$enum_name);\n");
+ }
+ }
+ } elsif (/^(?:__extension__\s+)?(?:extern|static)\s+(?:__)?inline(?:__)?\s+/
+ and !/;\s*$/ and !/{\s*}\s*$/)
+ { # { for vi
+ # This is a hack to parse the inline functions in the glibc headers.
+ # Warning: massive kludge ahead. We suppose inline functions
+ # are mainly constructed like macros.
+ while (1) {
+ last unless defined ($next = next_line($file));
+ chomp $next;
+ undef $_, last if $next =~ /__THROW\s*;/
+ or $next =~ /^(__extension__|extern|static)\b/;
+ $_ .= " $next";
+ print OUT "# $next\n" if $opt_D;
+ last if $next =~ /^}|^{.*}\s*$/;
+ }
+ next if not defined; # because it's only a prototype
+ s/\b(__extension__|extern|static|(?:__)?inline(?:__)?)\b//g;
+ # violently drop #ifdefs
+ s/#\s*if.*?#\s*endif//g
+ and print OUT "# some #ifdef were dropped here -- fill in the blanks\n";
+ if (s/^(?:\w|\s|\*)*\s(\w+)\s*//) {
+ $name = $1;
+ } else {
+ warn "name not found"; next; # shouldn't occur...
+ }
+ my @args;
+ if (s/^\(([^()]*)\)\s*(\w+\s*)*//) {
+ for my $arg (split /,/, $1) {
+ if ($arg =~ /(\w+)\s*$/) {
+ $curargs{$1} = 1;
+ push @args, $1;
+ }
+ }
+ }
+ $args = (
+ @args
+ ? "my(" . (join ',', map "\$$_", @args) . ") = \@_;\n$t "
+ : ""
+ );
+ my $proto = @args ? '' : '() ';
+ $new = '';
+ s/\breturn\b//g; # "return" doesn't occur in macros usually...
+ expr();
+ # try to find and perlify local C variables
+ our @local_variables = (); # needs to be a our(): (?{...}) bug workaround
+ {
+ use re "eval";
+ my $typelist = join '|', keys %isatype;
+ $new =~ s['
+ (?:(?:__)?const(?:__)?\s+)?
+ (?:(?:un)?signed\s+)?
+ (?:long\s+)?
+ (?:$typelist)\s+
+ (\w+)
+ (?{ push @local_variables, $1 })
+ ']
+ [my \$$1]gx;
+ $new =~ s['
+ (?:(?:__)?const(?:__)?\s+)?
+ (?:(?:un)?signed\s+)?
+ (?:long\s+)?
+ (?:$typelist)\s+
+ ' \s+ &(\w+) \s* ;
+ (?{ push @local_variables, $1 })
+ ]
+ [my \$$1;]gx;
+ }
+ $new =~ s/&$_\b/\$$_/g for @local_variables;
+ $new =~ s/(["\\])/\\$1/g; #"]);
+ # now that's almost like a macro (we hope)
+ goto EMIT;
+ }
+ }
+ $Is_converted{$file} = 1;
+ if ($opt_e && exists($bad_file{$file})) {
+ unlink($Dest_dir . '/' . $outfile);
+ $next = '';
+ } else {
+ print OUT "1;\n";
+ queue_includes_from($file) if $opt_a;
+ }
+}
+
+if ($opt_e && (scalar(keys %bad_file) > 0)) {
+ warn "Was unable to convert the following files:\n";
+ warn "\t" . join("\n\t",sort(keys %bad_file)) . "\n";
+}
+
+exit $Exit;
+
+sub expr {
+ $new = '"(assembly code)"' and return if /\b__asm__\b/; # freak out.
+ my $joined_args;
+ if(keys(%curargs)) {
+ $joined_args = join('|', keys(%curargs));
+ }
+ while ($_ ne '') {
+ s/^\&\&// && do { $new .= " &&"; next;}; # handle && operator
+ s/^\&([\(a-z\)]+)/$1/i; # hack for things that take the address of
+ s/^(\s+)// && do {$new .= ' '; next;};
+ s/^0X([0-9A-F]+)[UL]*//i
+ && do {my $hex = $1;
+ $hex =~ s/^0+//;
+ if (length $hex > 8 && !$Config{use64bitint}) {
+ # Croak if nv_preserves_uv_bits < 64 ?
+ $new .= hex(substr($hex, -8)) +
+ 2**32 * hex(substr($hex, 0, -8));
+ # The above will produce "errorneus" code
+ # if the hex constant was e.g. inside UINT64_C
+ # macro, but then again, h2ph is an approximation.
+ } else {
+ $new .= lc("0x$hex");
+ }
+ next;};
+ s/^(-?\d+\.\d+E[-+]?\d+)[FL]?//i && do {$new .= $1; next;};
+ s/^(\d+)\s*[LU]*//i && do {$new .= $1; next;};
+ s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
+ s/^'((\\"|[^"])*)'// && do {
+ if ($curargs{$1}) {
+ $new .= "ord('\$$1')";
+ } else {
+ $new .= "ord('$1')";
+ }
+ next;
+ };
+ # replace "sizeof(foo)" with "{foo}"
+ # also, remove * (C dereference operator) to avoid perl syntax
+ # problems. Where the %sizeof array comes from is anyone's
+ # guess (c2ph?), but this at least avoids fatal syntax errors.
+ # Behavior is undefined if sizeof() delimiters are unbalanced.
+ # This code was modified to able to handle constructs like this:
+ # sizeof(*(p)), which appear in the HP-UX 10.01 header files.
+ s/^sizeof\s*\(// && do {
+ $new .= '$sizeof';
+ my $lvl = 1; # already saw one open paren
+ # tack { on the front, and skip it in the loop
+ $_ = "{" . "$_";
+ my $index = 1;
+ # find balanced closing paren
+ while ($index <= length($_) && $lvl > 0) {
+ $lvl++ if substr($_, $index, 1) eq "(";
+ $lvl-- if substr($_, $index, 1) eq ")";
+ $index++;
+ }
+ # tack } on the end, replacing )
+ substr($_, $index - 1, 1) = "}";
+ # remove pesky * operators within the sizeof argument
+ substr($_, 0, $index - 1) =~ s/\*//g;
+ next;
+ };
+ # Eliminate typedefs
+ /\(([\w\s]+)[\*\s]*\)\s*[\w\(]/ && do {
+ my $doit = 1;
+ foreach (split /\s+/, $1) { # Make sure all the words are types,
+ unless($isatype{$_} or $_ eq 'struct' or $_ eq 'union'){
+ $doit = 0;
+ last;
+ }
+ }
+ if( $doit ){
+ s/\([\w\s]+[\*\s]*\)// && next; # then eliminate them.
+ }
+ };
+ # struct/union member, including arrays:
+ s/^([_A-Z]\w*(\[[^\]]+\])?((\.|->)[_A-Z]\w*(\[[^\]]+\])?)+)//i && do {
+ my $id = $1;
+ $id =~ s/(\.|(->))([^\.\-]*)/->\{$3\}/g;
+ $id =~ s/\b([^\$])($joined_args)/$1\$$2/g if length($joined_args);
+ while($id =~ /\[\s*([^\$\&\d\]]+)\]/) {
+ my($index) = $1;
+ $index =~ s/\s//g;
+ if(exists($curargs{$index})) {
+ $index = "\$$index";
+ } else {
+ $index = "&$index";
+ }
+ $id =~ s/\[\s*([^\$\&\d\]]+)\]/[$index]/;
+ }
+ $new .= " (\$$id)";
+ };
+ s/^([_a-zA-Z]\w*)// && do {
+ my $id = $1;
+ if ($id eq 'struct' || $id eq 'union') {
+ s/^\s+(\w+)//;
+ $id .= ' ' . $1;
+ $isatype{$id} = 1;
+ } elsif ($id =~ /^((un)?signed)|(long)|(short)$/) {
+ while (s/^\s+(\w+)//) { $id .= ' ' . $1; }
+ $isatype{$id} = 1;
+ }
+ if ($curargs{$id}) {
+ $new .= "\$$id";
+ $new .= '->' if /^[\[\{]/;
+ } elsif ($id eq 'defined') {
+ $new .= 'defined';
+ } elsif (/^\s*\(/) {
+ s/^\s*\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i; # cheat
+ $new .= " &$id";
+ } elsif ($isatype{$id}) {
+ if ($new =~ /{\s*$/) {
+ $new .= "'$id'";
+ } elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
+ $new =~ s/\(\s*$//;
+ s/^[\s*]*\)//;
+ } else {
+ $new .= q(').$id.q(');
+ }
+ } else {
+ if ($inif && $new !~ /defined\s*\($/) {
+ $new .= '(defined(&' . $id . ') ? &' . $id . ' : undef)';
+ } elsif (/^\[/) {
+ $new .= " \$$id";
+ } else {
+ $new .= ' &' . $id;
+ }
+ }
+ next;
+ };
+ s/^(.)// && do { if ($1 ne '#') { $new .= $1; } next;};
+ }
+}
+
+
+sub next_line
+{
+ my $file = shift;
+ my ($in, $out);
+ my $pre_sub_tri_graphs = 1;
+
+ READ: while (not eof IN) {
+ $in .= <IN>;
+ chomp $in;
+ next unless length $in;
+
+ while (length $in) {
+ if ($pre_sub_tri_graphs) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ $in =~ s/\?\?=/#/g; # | ??=| #|
+ $in =~ s/\?\?\!/|/g; # | ??!| ||
+ $in =~ s/\?\?'/^/g; # | ??'| ^|
+ $in =~ s/\?\?\(/[/g; # | ??(| [|
+ $in =~ s/\?\?\)/]/g; # | ??)| ]|
+ $in =~ s/\?\?\-/~/g; # | ??-| ~|
+ $in =~ s/\?\?\//\\/g; # | ??/| \|
+ $in =~ s/\?\?</{/g; # | ??<| {|
+ $in =~ s/\?\?>/}/g; # | ??>| }|
+ }
+ if ($in =~ /^\#ifdef __LANGUAGE_PASCAL__/) {
+ # Tru64 disassembler.h evilness: mixed C and Pascal.
+ while (<IN>) {
+ last if /^\#endif/;
+ }
+ $in = "";
+ next READ;
+ }
+ if ($in =~ /^extern inline / && # Inlined assembler.
+ $^O eq 'linux' && $file =~ m!(?:^|/)asm/[^/]+\.h$!) {
+ while (<IN>) {
+ last if /^}/;
+ }
+ $in = "";
+ next READ;
+ }
+ if ($in =~ s/\\$//) { # \-newline
+ $out .= ' ';
+ next READ;
+ } elsif ($in =~ s/^([^"'\\\/]+)//) { # Passthrough
+ $out .= $1;
+ } elsif ($in =~ s/^(\\.)//) { # \...
+ $out .= $1;
+ } elsif ($in =~ /^'/) { # '...
+ if ($in =~ s/^('(\\.|[^'\\])*')//) {
+ $out .= $1;
+ } else {
+ next READ;
+ }
+ } elsif ($in =~ /^"/) { # "...
+ if ($in =~ s/^("(\\.|[^"\\])*")//) {
+ $out .= $1;
+ } else {
+ next READ;
+ }
+ } elsif ($in =~ s/^\/\/.*//) { # //...
+ # fall through
+ } elsif ($in =~ m/^\/\*/) { # /*...
+ # C comment removal adapted from perlfaq6:
+ if ($in =~ s/^\/\*[^*]*\*+([^\/*][^*]*\*+)*\///) {
+ $out .= ' ';
+ } else { # Incomplete /* */
+ next READ;
+ }
+ } elsif ($in =~ s/^(\/)//) { # /...
+ $out .= $1;
+ } elsif ($in =~ s/^([^\'\"\\\/]+)//) {
+ $out .= $1;
+ } elsif ($^O eq 'linux' &&
+ $file =~ m!(?:^|/)linux/byteorder/pdp_endian\.h$! &&
+ $in =~ s!\'T KNOW!!) {
+ $out =~ s!I DON$!I_DO_NOT_KNOW!;
+ } else {
+ if ($opt_e) {
+ warn "Cannot parse $file:\n$in\n";
+ $bad_file{$file} = 1;
+ $in = '';
+ $out = undef;
+ last READ;
+ } else {
+ die "Cannot parse:\n$in\n";
+ }
+ }
+ }
+
+ last READ if $out =~ /\S/;
+ }
+
+ return $out;
+}
+
+
+# Handle recursive subdirectories without getting a grotesquely big stack.
+# Could this be implemented using File::Find?
+sub next_file
+{
+ my $file;
+
+ while (@ARGV) {
+ $file = shift @ARGV;
+
+ if ($file eq '-' or -f $file or -l $file) {
+ return $file;
+ } elsif (-d $file) {
+ if ($opt_r) {
+ expand_glob($file);
+ } else {
+ print STDERR "Skipping directory `$file'\n";
+ }
+ } elsif ($opt_a) {
+ return $file;
+ } else {
+ print STDERR "Skipping `$file': not a file or directory\n";
+ }
+ }
+
+ return undef;
+}
+
+
+# Put all the files in $directory into @ARGV for processing.
+sub expand_glob
+{
+ my ($directory) = @_;
+
+ $directory =~ s:/$::;
+
+ opendir DIR, $directory;
+ foreach (readdir DIR) {
+ next if ($_ eq '.' or $_ eq '..');
+
+ # expand_glob() is going to be called until $ARGV[0] isn't a
+ # directory; so push directories, and unshift everything else.
+ if (-d "$directory/$_") { push @ARGV, "$directory/$_" }
+ else { unshift @ARGV, "$directory/$_" }
+ }
+ closedir DIR;
+}
+
+
+# Given $file, a symbolic link to a directory in the C include directory,
+# make an equivalent symbolic link in $Dest_dir, if we can figure out how.
+# Otherwise, just duplicate the file or directory.
+sub link_if_possible
+{
+ my ($dirlink) = @_;
+ my $target = eval 'readlink($dirlink)';
+
+ if ($target =~ m:^\.\./: or $target =~ m:^/:) {
+ # The target of a parent or absolute link could leave the $Dest_dir
+ # hierarchy, so let's put all of the contents of $dirlink (actually,
+ # the contents of $target) into @ARGV; as a side effect down the
+ # line, $dirlink will get created as an _actual_ directory.
+ expand_glob($dirlink);
+ } else {
+ if (-l "$Dest_dir/$dirlink") {
+ unlink "$Dest_dir/$dirlink" or
+ print STDERR "Could not remove link $Dest_dir/$dirlink: $!\n";
+ }
+
+ if (eval 'symlink($target, "$Dest_dir/$dirlink")') {
+ print "Linking $target -> $Dest_dir/$dirlink\n";
+
+ # Make sure that the link _links_ to something:
+ if (! -e "$Dest_dir/$target") {
+ mkpath("$Dest_dir/$target", 0755) or
+ print STDERR "Could not create $Dest_dir/$target/\n";
+ }
+ } else {
+ print STDERR "Could not symlink $target -> $Dest_dir/$dirlink: $!\n";
+ }
+ }
+}
+
+
+# Push all #included files in $file onto our stack, except for STDIN
+# and files we've already processed.
+sub queue_includes_from
+{
+ my ($file) = @_;
+ my $line;
+
+ return if ($file eq "-");
+
+ open HEADER, $file or return;
+ while (defined($line = <HEADER>)) {
+ while (/\\$/) { # Handle continuation lines
+ chop $line;
+ $line .= <HEADER>;
+ }
+
+ if ($line =~ /^#\s*include\s+([<"])(.*?)[>"]/) {
+ my ($delimiter, $new_file) = ($1, $2);
+ # copy the prefix in the quote syntax (#include "x.h") case
+ if ($delimiter eq q{"} && $file =~ m|^(.*)/|) {
+ $new_file = "$1/$new_file";
+ }
+ push(@ARGV, $new_file) unless $Is_converted{$new_file};
+ }
+ }
+ close HEADER;
+}
+
+
+# Determine include directories; $Config{usrinc} should be enough for (all
+# non-GCC?) C compilers, but gcc uses additional include directories.
+sub inc_dirs
+{
+ my $from_gcc = `LC_ALL=C $Config{cc} -v 2>&1`;
+ if( !( $from_gcc =~ s:^Reading specs from (.*?)/specs\b.*:$1/include:s ) )
+ { # gcc-4+ :
+ $from_gcc = `LC_ALL=C $Config{cc} -print-search-dirs 2>&1`;
+ if ( !($from_gcc =~ s/^install:\s*([^\s]+[^\s\/])([\s\/]*).*$/$1\/include/s) )
+ {
+ $from_gcc = '';
+ };
+ };
+ length($from_gcc) ? ($from_gcc, $from_gcc . "-fixed", $Config{usrinc}) : ($Config{usrinc});
+}
+
+
+# Create "_h2ph_pre.ph", if it doesn't exist or was built by a different
+# version of h2ph.
+sub build_preamble_if_necessary
+{
+ # Increment $VERSION every time this function is modified:
+ my $VERSION = 2;
+ my $preamble = "$Dest_dir/_h2ph_pre.ph";
+
+ # Can we skip building the preamble file?
+ if (-r $preamble) {
+ # Extract version number from first line of preamble:
+ open PREAMBLE, $preamble or die "Cannot open $preamble: $!";
+ my $line = <PREAMBLE>;
+ $line =~ /(\b\d+\b)/;
+ close PREAMBLE or die "Cannot close $preamble: $!";
+
+ # Don't build preamble if a compatible preamble exists:
+ return if $1 == $VERSION;
+ }
+
+ my (%define) = _extract_cc_defines();
+
+ open PREAMBLE, ">$preamble" or die "Cannot open $preamble: $!";
+ print PREAMBLE "# This file was created by h2ph version $VERSION\n";
+
+ foreach (sort keys %define) {
+ if ($opt_D) {
+ print PREAMBLE "# $_=$define{$_}\n";
+ }
+ if ($define{$_} =~ /^\((.*)\)$/) {
+ # parenthesized value: d=(v)
+ $define{$_} = $1;
+ }
+ if ($define{$_} =~ /^([+-]?(\d+)?\.\d+([eE][+-]?\d+)?)[FL]?$/) {
+ # float:
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { $1 } }\n\n";
+ } elsif ($define{$_} =~ /^([+-]?\d+)U?L{0,2}$/i) {
+ # integer:
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { $1 } }\n\n";
+ } elsif ($define{$_} =~ /^\w+$/) {
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { &$define{$_} } }\n\n";
+ } else {
+ print PREAMBLE
+ "unless (defined &$_) { sub $_() { \"",
+ quotemeta($define{$_}), "\" } }\n\n";
+ }
+ }
+ print PREAMBLE "\n1;\n"; # avoid 'did not return a true value' when empty
+ close PREAMBLE or die "Cannot close $preamble: $!";
+}
+
+
+# %Config contains information on macros that are pre-defined by the
+# system's compiler. We need this information to make the .ph files
+# function with perl as the .h files do with cc.
+sub _extract_cc_defines
+{
+ my %define;
+ my $allsymbols = join " ",
+ @Config{'ccsymbols', 'cppsymbols', 'cppccsymbols'};
+
+ # Split compiler pre-definitions into `key=value' pairs:
+ while ($allsymbols =~ /([^\s]+)=((\\\s|[^\s])+)/g) {
+ $define{$1} = $2;
+ if ($opt_D) {
+ print STDERR "$_: $1 -> $2\n";
+ }
+ }
+
+ return %define;
+}
+
+
+1;
+
+##############################################################################
+__END__
+
+=head1 NAME
+
+h2ph - convert .h C header files to .ph Perl header files
+
+=head1 SYNOPSIS
+
+B<h2ph [-d destination directory] [-r | -a] [-l] [headerfiles]>
+
+=head1 DESCRIPTION
+
+I<h2ph>
+converts any C header files specified to the corresponding Perl header file
+format.
+It is most easily run while in /usr/include:
+
+ cd /usr/include; h2ph * sys/*
+
+or
+
+ cd /usr/include; h2ph * sys/* arpa/* netinet/*
+
+or
+
+ cd /usr/include; h2ph -r -l .
+
+The output files are placed in the hierarchy rooted at Perl's
+architecture dependent library directory. You can specify a different
+hierarchy with a B<-d> switch.
+
+If run with no arguments, filters standard input to standard output.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -d destination_dir
+
+Put the resulting B<.ph> files beneath B<destination_dir>, instead of
+beneath the default Perl library location (C<$Config{'installsitearch'}>).
+
+=item -r
+
+Run recursively; if any of B<headerfiles> are directories, then run I<h2ph>
+on all files in those directories (and their subdirectories, etc.). B<-r>
+and B<-a> are mutually exclusive.
+
+=item -a
+
+Run automagically; convert B<headerfiles>, as well as any B<.h> files
+which they include. This option will search for B<.h> files in all
+directories which your C compiler ordinarily uses. B<-a> and B<-r> are
+mutually exclusive.
+
+=item -l
+
+Symbolic links will be replicated in the destination directory. If B<-l>
+is not specified, then links are skipped over.
+
+=item -h
+
+Put ``hints'' in the .ph files which will help in locating problems with
+I<h2ph>. In those cases when you B<require> a B<.ph> file containing syntax
+errors, instead of the cryptic
+
+ [ some error condition ] at (eval mmm) line nnn
+
+you will see the slightly more helpful
+
+ [ some error condition ] at filename.ph line nnn
+
+However, the B<.ph> files almost double in size when built using B<-h>.
+
+=item -D
+
+Include the code from the B<.h> file as a comment in the B<.ph> file.
+This is primarily used for debugging I<h2ph>.
+
+=item -Q
+
+``Quiet'' mode; don't print out the names of the files being converted.
+
+=back
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 FILES
+
+ /usr/include/*.h
+ /usr/include/sys/*.h
+
+etc.
+
+=head1 AUTHOR
+
+Larry Wall
+
+=head1 SEE ALSO
+
+perl(1)
+
+=head1 DIAGNOSTICS
+
+The usual warnings if it can't read or write the files involved.
+
+=head1 BUGS
+
+Doesn't construct the %sizeof array for you.
+
+It doesn't handle all C constructs, but it does attempt to isolate
+definitions inside evals so that you can get at the definitions
+that it can translate.
+
+It's only intended as a rough tool.
+You may need to dicker with the files produced.
+
+You have to run this program by hand; it's not run as part of the Perl
+installation.
+
+Doesn't handle complicated expressions built piecemeal, a la:
+
+ enum {
+ FIRST_VALUE,
+ SECOND_VALUE,
+ #ifdef ABC
+ THIRD_VALUE
+ #endif
+ };
+
+Doesn't necessarily locate all of your C compiler's internally-defined
+symbols.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/h2xs.bat b/Master/tlpkg/tlperl/bin/h2xs.bat new file mode 100755 index 00000000000..136eeea2fad --- /dev/null +++ b/Master/tlpkg/tlperl/bin/h2xs.bat @@ -0,0 +1,2203 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+use warnings;
+
+=head1 NAME
+
+h2xs - convert .h C header files to Perl extensions
+
+=head1 SYNOPSIS
+
+B<h2xs> [B<OPTIONS> ...] [headerfile ... [extra_libraries]]
+
+B<h2xs> B<-h>|B<-?>|B<--help>
+
+=head1 DESCRIPTION
+
+I<h2xs> builds a Perl extension from C header files. The extension
+will include functions which can be used to retrieve the value of any
+#define statement which was in the C header files.
+
+The I<module_name> will be used for the name of the extension. If
+module_name is not supplied then the name of the first header file
+will be used, with the first character capitalized.
+
+If the extension might need extra libraries, they should be included
+here. The extension Makefile.PL will take care of checking whether
+the libraries actually exist and how they should be loaded. The extra
+libraries should be specified in the form -lm -lposix, etc, just as on
+the cc command line. By default, the Makefile.PL will search through
+the library path determined by Configure. That path can be augmented
+by including arguments of the form B<-L/another/library/path> in the
+extra-libraries argument.
+
+In spite of its name, I<h2xs> may also be used to create a skeleton pure
+Perl module. See the B<-X> option.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-A>, B<--omit-autoload>
+
+Omit all autoload facilities. This is the same as B<-c> but also
+removes the S<C<use AutoLoader>> statement from the .pm file.
+
+=item B<-B>, B<--beta-version>
+
+Use an alpha/beta style version number. Causes version number to
+be "0.00_01" unless B<-v> is specified.
+
+=item B<-C>, B<--omit-changes>
+
+Omits creation of the F<Changes> file, and adds a HISTORY section to
+the POD template.
+
+=item B<-F>, B<--cpp-flags>=I<addflags>
+
+Additional flags to specify to C preprocessor when scanning header for
+function declarations. Writes these options in the generated F<Makefile.PL>
+too.
+
+=item B<-M>, B<--func-mask>=I<regular expression>
+
+selects functions/macros to process.
+
+=item B<-O>, B<--overwrite-ok>
+
+Allows a pre-existing extension directory to be overwritten.
+
+=item B<-P>, B<--omit-pod>
+
+Omit the autogenerated stub POD section.
+
+=item B<-X>, B<--omit-XS>
+
+Omit the XS portion. Used to generate a skeleton pure Perl module.
+C<-c> and C<-f> are implicitly enabled.
+
+=item B<-a>, B<--gen-accessors>
+
+Generate an accessor method for each element of structs and unions. The
+generated methods are named after the element name; will return the current
+value of the element if called without additional arguments; and will set
+the element to the supplied value (and return the new value) if called with
+an additional argument. Embedded structures and unions are returned as a
+pointer rather than the complete structure, to facilitate chained calls.
+
+These methods all apply to the Ptr type for the structure; additionally
+two methods are constructed for the structure type itself, C<_to_ptr>
+which returns a Ptr type pointing to the same structure, and a C<new>
+method to construct and return a new structure, initialised to zeroes.
+
+=item B<-b>, B<--compat-version>=I<version>
+
+Generates a .pm file which is backwards compatible with the specified
+perl version.
+
+For versions < 5.6.0, the changes are.
+ - no use of 'our' (uses 'use vars' instead)
+ - no 'use warnings'
+
+Specifying a compatibility version higher than the version of perl you
+are using to run h2xs will have no effect. If unspecified h2xs will default
+to compatibility with the version of perl you are using to run h2xs.
+
+=item B<-c>, B<--omit-constant>
+
+Omit C<constant()> from the .xs file and corresponding specialised
+C<AUTOLOAD> from the .pm file.
+
+=item B<-d>, B<--debugging>
+
+Turn on debugging messages.
+
+=item B<-e>, B<--omit-enums>=[I<regular expression>]
+
+If I<regular expression> is not given, skip all constants that are defined in
+a C enumeration. Otherwise skip only those constants that are defined in an
+enum whose name matches I<regular expression>.
+
+Since I<regular expression> is optional, make sure that this switch is followed
+by at least one other switch if you omit I<regular expression> and have some
+pending arguments such as header-file names. This is ok:
+
+ h2xs -e -n Module::Foo foo.h
+
+This is not ok:
+
+ h2xs -n Module::Foo -e foo.h
+
+In the latter, foo.h is taken as I<regular expression>.
+
+=item B<-f>, B<--force>
+
+Allows an extension to be created for a header even if that header is
+not found in standard include directories.
+
+=item B<-g>, B<--global>
+
+Include code for safely storing static data in the .xs file.
+Extensions that do no make use of static data can ignore this option.
+
+=item B<-h>, B<-?>, B<--help>
+
+Print the usage, help and version for this h2xs and exit.
+
+=item B<-k>, B<--omit-const-func>
+
+For function arguments declared as C<const>, omit the const attribute in the
+generated XS code.
+
+=item B<-m>, B<--gen-tied-var>
+
+B<Experimental>: for each variable declared in the header file(s), declare
+a perl variable of the same name magically tied to the C variable.
+
+=item B<-n>, B<--name>=I<module_name>
+
+Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
+
+=item B<-o>, B<--opaque-re>=I<regular expression>
+
+Use "opaque" data type for the C types matched by the regular
+expression, even if these types are C<typedef>-equivalent to types
+from typemaps. Should not be used without B<-x>.
+
+This may be useful since, say, types which are C<typedef>-equivalent
+to integers may represent OS-related handles, and one may want to work
+with these handles in OO-way, as in C<$handle-E<gt>do_something()>.
+Use C<-o .> if you want to handle all the C<typedef>ed types as opaque
+types.
+
+The type-to-match is whitewashed (except for commas, which have no
+whitespace before them, and multiple C<*> which have no whitespace
+between them).
+
+=item B<-p>, B<--remove-prefix>=I<prefix>
+
+Specify a prefix which should be removed from the Perl function names,
+e.g., S<-p sec_rgy_> This sets up the XS B<PREFIX> keyword and removes
+the prefix from functions that are autoloaded via the C<constant()>
+mechanism.
+
+=item B<-s>, B<--const-subs>=I<sub1,sub2>
+
+Create a perl subroutine for the specified macros rather than autoload
+with the constant() subroutine. These macros are assumed to have a
+return type of B<char *>, e.g.,
+S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
+
+=item B<-t>, B<--default-type>=I<type>
+
+Specify the internal type that the constant() mechanism uses for macros.
+The default is IV (signed integer). Currently all macros found during the
+header scanning process will be assumed to have this type. Future versions
+of C<h2xs> may gain the ability to make educated guesses.
+
+=item B<--use-new-tests>
+
+When B<--compat-version> (B<-b>) is present the generated tests will use
+C<Test::More> rather than C<Test> which is the default for versions before
+5.7.2 . C<Test::More> will be added to PREREQ_PM in the generated
+C<Makefile.PL>.
+
+=item B<--use-old-tests>
+
+Will force the generation of test code that uses the older C<Test> module.
+
+=item B<--skip-exporter>
+
+Do not use C<Exporter> and/or export any symbol.
+
+=item B<--skip-ppport>
+
+Do not use C<Devel::PPPort>: no portability to older version.
+
+=item B<--skip-autoloader>
+
+Do not use the module C<AutoLoader>; but keep the constant() function
+and C<sub AUTOLOAD> for constants.
+
+=item B<--skip-strict>
+
+Do not use the pragma C<strict>.
+
+=item B<--skip-warnings>
+
+Do not use the pragma C<warnings>.
+
+=item B<-v>, B<--version>=I<version>
+
+Specify a version number for this extension. This version number is added
+to the templates. The default is 0.01, or 0.00_01 if C<-B> is specified.
+The version specified should be numeric.
+
+=item B<-x>, B<--autogen-xsubs>
+
+Automatically generate XSUBs basing on function declarations in the
+header file. The package C<C::Scan> should be installed. If this
+option is specified, the name of the header file may look like
+C<NAME1,NAME2>. In this case NAME1 is used instead of the specified
+string, but XSUBs are emitted only for the declarations included from
+file NAME2.
+
+Note that some types of arguments/return-values for functions may
+result in XSUB-declarations/typemap-entries which need
+hand-editing. Such may be objects which cannot be converted from/to a
+pointer (like C<long long>), pointers to functions, or arrays. See
+also the section on L<LIMITATIONS of B<-x>>.
+
+=back
+
+=head1 EXAMPLES
+
+
+ # Default behavior, extension is Rusers
+ h2xs rpcsvc/rusers
+
+ # Same, but extension is RUSERS
+ h2xs -n RUSERS rpcsvc/rusers
+
+ # Extension is rpcsvc::rusers. Still finds <rpcsvc/rusers.h>
+ h2xs rpcsvc::rusers
+
+ # Extension is ONC::RPC. Still finds <rpcsvc/rusers.h>
+ h2xs -n ONC::RPC rpcsvc/rusers
+
+ # Without constant() or AUTOLOAD
+ h2xs -c rpcsvc/rusers
+
+ # Creates templates for an extension named RPC
+ h2xs -cfn RPC
+
+ # Extension is ONC::RPC.
+ h2xs -cfn ONC::RPC
+
+ # Extension is a pure Perl module with no XS code.
+ h2xs -X My::Module
+
+ # Extension is Lib::Foo which works at least with Perl5.005_03.
+ # Constants are created for all #defines and enums h2xs can find
+ # in foo.h.
+ h2xs -b 5.5.3 -n Lib::Foo foo.h
+
+ # Extension is Lib::Foo which works at least with Perl5.005_03.
+ # Constants are created for all #defines but only for enums
+ # whose names do not start with 'bar_'.
+ h2xs -b 5.5.3 -e '^bar_' -n Lib::Foo foo.h
+
+ # Makefile.PL will look for library -lrpc in
+ # additional directory /opt/net/lib
+ h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
+
+ # Extension is DCE::rgynbase
+ # prefix "sec_rgy_" is dropped from perl function names
+ h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
+
+ # Extension is DCE::rgynbase
+ # prefix "sec_rgy_" is dropped from perl function names
+ # subroutines are created for sec_rgy_wildcard_name and
+ # sec_rgy_wildcard_sid
+ h2xs -n DCE::rgynbase -p sec_rgy_ \
+ -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
+
+ # Make XS without defines in perl.h, but with function declarations
+ # visible from perl.h. Name of the extension is perl1.
+ # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
+ # Extra backslashes below because the string is passed to shell.
+ # Note that a directory with perl header files would
+ # be added automatically to include path.
+ h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
+
+ # Same with function declaration in proto.h as visible from perl.h.
+ h2xs -xAn perl2 perl.h,proto.h
+
+ # Same but select only functions which match /^av_/
+ h2xs -M '^av_' -xAn perl2 perl.h,proto.h
+
+ # Same but treat SV* etc as "opaque" types
+ h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h
+
+=head2 Extension based on F<.h> and F<.c> files
+
+Suppose that you have some C files implementing some functionality,
+and the corresponding header files. How to create an extension which
+makes this functionality accessible in Perl? The example below
+assumes that the header files are F<interface_simple.h> and
+I<interface_hairy.h>, and you want the perl module be named as
+C<Ext::Ension>. If you need some preprocessor directives and/or
+linking with external libraries, see the flags C<-F>, C<-L> and C<-l>
+in L<"OPTIONS">.
+
+=over
+
+=item Find the directory name
+
+Start with a dummy run of h2xs:
+
+ h2xs -Afn Ext::Ension
+
+The only purpose of this step is to create the needed directories, and
+let you know the names of these directories. From the output you can
+see that the directory for the extension is F<Ext/Ension>.
+
+=item Copy C files
+
+Copy your header files and C files to this directory F<Ext/Ension>.
+
+=item Create the extension
+
+Run h2xs, overwriting older autogenerated files:
+
+ h2xs -Oxan Ext::Ension interface_simple.h interface_hairy.h
+
+h2xs looks for header files I<after> changing to the extension
+directory, so it will find your header files OK.
+
+=item Archive and test
+
+As usual, run
+
+ cd Ext/Ension
+ perl Makefile.PL
+ make dist
+ make
+ make test
+
+=item Hints
+
+It is important to do C<make dist> as early as possible. This way you
+can easily merge(1) your changes to autogenerated files if you decide
+to edit your C<.h> files and rerun h2xs.
+
+Do not forget to edit the documentation in the generated F<.pm> file.
+
+Consider the autogenerated files as skeletons only, you may invent
+better interfaces than what h2xs could guess.
+
+Consider this section as a guideline only, some other options of h2xs
+may better suit your needs.
+
+=back
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 AUTHOR
+
+Larry Wall and others
+
+=head1 SEE ALSO
+
+L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
+
+=head1 DIAGNOSTICS
+
+The usual warnings if it cannot read or write the files involved.
+
+=head1 LIMITATIONS of B<-x>
+
+F<h2xs> would not distinguish whether an argument to a C function
+which is of the form, say, C<int *>, is an input, output, or
+input/output parameter. In particular, argument declarations of the
+form
+
+ int
+ foo(n)
+ int *n
+
+should be better rewritten as
+
+ int
+ foo(n)
+ int &n
+
+if C<n> is an input parameter.
+
+Additionally, F<h2xs> has no facilities to intuit that a function
+
+ int
+ foo(addr,l)
+ char *addr
+ int l
+
+takes a pair of address and length of data at this address, so it is better
+to rewrite this function as
+
+ int
+ foo(sv)
+ SV *addr
+ PREINIT:
+ STRLEN len;
+ char *s;
+ CODE:
+ s = SvPV(sv,len);
+ RETVAL = foo(s, len);
+ OUTPUT:
+ RETVAL
+
+or alternately
+
+ static int
+ my_foo(SV *sv)
+ {
+ STRLEN len;
+ char *s = SvPV(sv,len);
+
+ return foo(s, len);
+ }
+
+ MODULE = foo PACKAGE = foo PREFIX = my_
+
+ int
+ foo(sv)
+ SV *sv
+
+See L<perlxs> and L<perlxstut> for additional details.
+
+=cut
+
+# ' # Grr
+use strict;
+
+
+my( $H2XS_VERSION ) = ' $Revision: 1.23 $ ' =~ /\$Revision:\s+([^\s]+)/;
+my $TEMPLATE_VERSION = '0.01';
+my @ARGS = @ARGV;
+my $compat_version = $];
+
+use Getopt::Long;
+use Config;
+use Text::Wrap;
+$Text::Wrap::huge = 'overflow';
+$Text::Wrap::columns = 80;
+use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload);
+use File::Compare;
+use File::Path;
+
+sub usage {
+ warn "@_\n" if @_;
+ die <<EOFUSAGE;
+h2xs [OPTIONS ... ] [headerfile [extra_libraries]]
+version: $H2XS_VERSION
+OPTIONS:
+ -A, --omit-autoload Omit all autoloading facilities (implies -c).
+ -B, --beta-version Use beta \$VERSION of 0.00_01 (ignored if -v).
+ -C, --omit-changes Omit creating the Changes file, add HISTORY heading
+ to stub POD.
+ -F, --cpp-flags Additional flags for C preprocessor/compile.
+ -M, --func-mask Mask to select C functions/macros
+ (default is select all).
+ -O, --overwrite-ok Allow overwriting of a pre-existing extension directory.
+ -P, --omit-pod Omit the stub POD section.
+ -X, --omit-XS Omit the XS portion (implies both -c and -f).
+ -a, --gen-accessors Generate get/set accessors for struct and union members
+ (used with -x).
+ -b, --compat-version Specify a perl version to be backwards compatibile with.
+ -c, --omit-constant Omit the constant() function and specialised AUTOLOAD
+ from the XS file.
+ -d, --debugging Turn on debugging messages.
+ -e, --omit-enums Omit constants from enums in the constant() function.
+ If a pattern is given, only the matching enums are
+ ignored.
+ -f, --force Force creation of the extension even if the C header
+ does not exist.
+ -g, --global Include code for safely storing static data in the .xs file.
+ -h, -?, --help Display this help message.
+ -k, --omit-const-func Omit 'const' attribute on function arguments
+ (used with -x).
+ -m, --gen-tied-var Generate tied variables for access to declared
+ variables.
+ -n, --name Specify a name to use for the extension (recommended).
+ -o, --opaque-re Regular expression for \"opaque\" types.
+ -p, --remove-prefix Specify a prefix which should be removed from the
+ Perl function names.
+ -s, --const-subs Create subroutines for specified macros.
+ -t, --default-type Default type for autoloaded constants (default is IV).
+ --use-new-tests Use Test::More in backward compatible modules.
+ --use-old-tests Use the module Test rather than Test::More.
+ --skip-exporter Do not export symbols.
+ --skip-ppport Do not use portability layer.
+ --skip-autoloader Do not use the module C<AutoLoader>.
+ --skip-strict Do not use the pragma C<strict>.
+ --skip-warnings Do not use the pragma C<warnings>.
+ -v, --version Specify a version number for this extension.
+ -x, --autogen-xsubs Autogenerate XSUBs using C::Scan.
+ --use-xsloader Use XSLoader in backward compatible modules (ignored
+ when used with -X).
+
+extra_libraries
+ are any libraries that might be needed for loading the
+ extension, e.g. -lm would try to link in the math library.
+EOFUSAGE
+}
+
+my ($opt_A,
+ $opt_B,
+ $opt_C,
+ $opt_F,
+ $opt_M,
+ $opt_O,
+ $opt_P,
+ $opt_X,
+ $opt_a,
+ $opt_c,
+ $opt_d,
+ $opt_e,
+ $opt_f,
+ $opt_g,
+ $opt_h,
+ $opt_k,
+ $opt_m,
+ $opt_n,
+ $opt_o,
+ $opt_p,
+ $opt_s,
+ $opt_v,
+ $opt_x,
+ $opt_b,
+ $opt_t,
+ $new_test,
+ $old_test,
+ $skip_exporter,
+ $skip_ppport,
+ $skip_autoloader,
+ $skip_strict,
+ $skip_warnings,
+ $use_xsloader
+ );
+
+Getopt::Long::Configure('bundling');
+Getopt::Long::Configure('pass_through');
+
+my %options = (
+ 'omit-autoload|A' => \$opt_A,
+ 'beta-version|B' => \$opt_B,
+ 'omit-changes|C' => \$opt_C,
+ 'cpp-flags|F=s' => \$opt_F,
+ 'func-mask|M=s' => \$opt_M,
+ 'overwrite_ok|O' => \$opt_O,
+ 'omit-pod|P' => \$opt_P,
+ 'omit-XS|X' => \$opt_X,
+ 'gen-accessors|a' => \$opt_a,
+ 'compat-version|b=s' => \$opt_b,
+ 'omit-constant|c' => \$opt_c,
+ 'debugging|d' => \$opt_d,
+ 'omit-enums|e:s' => \$opt_e,
+ 'force|f' => \$opt_f,
+ 'global|g' => \$opt_g,
+ 'help|h|?' => \$opt_h,
+ 'omit-const-func|k' => \$opt_k,
+ 'gen-tied-var|m' => \$opt_m,
+ 'name|n=s' => \$opt_n,
+ 'opaque-re|o=s' => \$opt_o,
+ 'remove-prefix|p=s' => \$opt_p,
+ 'const-subs|s=s' => \$opt_s,
+ 'default-type|t=s' => \$opt_t,
+ 'version|v=s' => \$opt_v,
+ 'autogen-xsubs|x' => \$opt_x,
+ 'use-new-tests' => \$new_test,
+ 'use-old-tests' => \$old_test,
+ 'skip-exporter' => \$skip_exporter,
+ 'skip-ppport' => \$skip_ppport,
+ 'skip-autoloader' => \$skip_autoloader,
+ 'skip-warnings' => \$skip_warnings,
+ 'skip-strict' => \$skip_strict,
+ 'use-xsloader' => \$use_xsloader,
+ );
+
+GetOptions(%options) || usage;
+
+usage if $opt_h;
+
+if( $opt_b ){
+ usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m);
+ $opt_b =~ /^v?(\d+)\.(\d+)\.(\d+)/ ||
+ usage "You must provide the backwards compatibility version in X.Y.Z form. "
+ . "(i.e. 5.5.0)\n";
+ my ($maj,$min,$sub) = ($1,$2,$3);
+ if ($maj < 5 || ($maj == 5 && $min < 6)) {
+ $compat_version =
+ $sub ? sprintf("%d.%03d%02d",$maj,$min,$sub) :
+ sprintf("%d.%03d", $maj,$min);
+ } else {
+ $compat_version = sprintf("%d.%03d%03d",$maj,$min,$sub);
+ }
+} else {
+ my ($maj,$min,$sub) = $compat_version =~ /(\d+)\.(\d\d\d)(\d*)/;
+ $sub ||= 0;
+ warn sprintf <<'EOF', $maj,$min,$sub;
+Defaulting to backwards compatibility with perl %d.%d.%d
+If you intend this module to be compatible with earlier perl versions, please
+specify a minimum perl version with the -b option.
+
+EOF
+}
+
+if( $opt_B ){
+ $TEMPLATE_VERSION = '0.00_01';
+}
+
+if( $opt_v ){
+ $TEMPLATE_VERSION = $opt_v;
+
+ # check if it is numeric
+ my $temp_version = $TEMPLATE_VERSION;
+ my $beta_version = $temp_version =~ s/(\d)_(\d\d)/$1$2/;
+ my $notnum;
+ {
+ local $SIG{__WARN__} = sub { $notnum = 1 };
+ use warnings 'numeric';
+ $temp_version = 0+$temp_version;
+ }
+
+ if ($notnum) {
+ my $module = $opt_n || 'Your::Module';
+ warn <<"EOF";
+You have specified a non-numeric version. Unless you supply an
+appropriate VERSION class method, users may not be able to specify a
+minimum required version with C<use $module versionnum>.
+
+EOF
+ }
+ else {
+ $opt_B = $beta_version;
+ }
+}
+
+# -A implies -c.
+$skip_autoloader = $opt_c = 1 if $opt_A;
+
+# -X implies -c and -f
+$opt_c = $opt_f = 1 if $opt_X;
+
+$opt_t ||= 'IV';
+
+my %const_xsub;
+%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
+
+my $extralibs = '';
+
+my @path_h;
+
+while (my $arg = shift) {
+ if ($arg =~ /^-l/i) {
+ $extralibs .= "$arg ";
+ next;
+ }
+ last if $extralibs;
+ push(@path_h, $arg);
+}
+
+usage "Must supply header file or module name\n"
+ unless (@path_h or $opt_n);
+
+my $fmask;
+my $tmask;
+
+$fmask = qr{$opt_M} if defined $opt_M;
+$tmask = qr{$opt_o} if defined $opt_o;
+my $tmask_all = $tmask && $opt_o eq '.';
+
+if ($opt_x) {
+ eval {require C::Scan; 1}
+ or die <<EOD;
+C::Scan required if you use -x option.
+To install C::Scan, execute
+ perl -MCPAN -e "install C::Scan"
+EOD
+ unless ($tmask_all) {
+ $C::Scan::VERSION >= 0.70
+ or die <<EOD;
+C::Scan v. 0.70 or later required unless you use -o . option.
+You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
+To install C::Scan, execute
+ perl -MCPAN -e "install C::Scan"
+EOD
+ }
+ if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) {
+ die <<EOD;
+C::Scan v. 0.73 or later required to use -m or -a options.
+You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}.
+To install C::Scan, execute
+ perl -MCPAN -e "install C::Scan"
+EOD
+ }
+}
+elsif ($opt_o or $opt_F) {
+ warn <<EOD if $opt_o;
+Option -o does not make sense without -x.
+EOD
+ warn <<EOD if $opt_F and $opt_X ;
+Option -F does not make sense with -X.
+EOD
+}
+
+my @path_h_ini = @path_h;
+my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names);
+
+my $module = $opt_n;
+
+if( @path_h ){
+ use File::Spec;
+ my @paths;
+ my $pre_sub_tri_graphs = 1;
+ if ($^O eq 'VMS') { # Consider overrides of default location
+ # XXXX This is not equivalent to what the older version did:
+ # it was looking at $hadsys header-file per header-file...
+ my($hadsys) = grep s!^sys/!!i , @path_h;
+ @paths = qw( Sys$Library VAXC$Include );
+ push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]');
+ push @paths, qw( DECC$Library_Include DECC$System_Include );
+ }
+ else {
+ @paths = (File::Spec->curdir(), $Config{usrinc},
+ (split ' ', $Config{locincpth}), '/usr/include');
+ }
+ foreach my $path_h (@path_h) {
+ $name ||= $path_h;
+ $module ||= do {
+ $name =~ s/\.h$//;
+ if ( $name !~ /::/ ) {
+ $name =~ s#^.*/##;
+ $name = "\u$name";
+ }
+ $name;
+ };
+
+ if( $path_h =~ s#::#/#g && $opt_n ){
+ warn "Nesting of headerfile ignored with -n\n";
+ }
+ $path_h .= ".h" unless $path_h =~ /\.h$/;
+ my $fullpath = $path_h;
+ $path_h =~ s/,.*$// if $opt_x;
+ $fullpath{$path_h} = $fullpath;
+
+ # Minor trickery: we can't chdir() before we processed the headers
+ # (so know the name of the extension), but the header may be in the
+ # extension directory...
+ my $tmp_path_h = $path_h;
+ my $rel_path_h = $path_h;
+ my @dirs = @paths;
+ if (not -f $path_h) {
+ my $found;
+ for my $dir (@paths) {
+ $found++, last
+ if -f ($path_h = File::Spec->catfile($dir, $tmp_path_h));
+ }
+ if ($found) {
+ $rel_path_h = $path_h;
+ $fullpath{$path_h} = $fullpath;
+ } else {
+ (my $epath = $module) =~ s,::,/,g;
+ $epath = File::Spec->catdir('ext', $epath) if -d 'ext';
+ $rel_path_h = File::Spec->catfile($epath, $tmp_path_h);
+ $path_h = $tmp_path_h; # Used during -x
+ push @dirs, $epath;
+ }
+ }
+
+ if (!$opt_c) {
+ die "Can't find $tmp_path_h in @dirs\n"
+ if ( ! $opt_f && ! -f "$rel_path_h" );
+ # Scan the header file (we should deal with nested header files)
+ # Record the names of simple #define constants into const_names
+ # Function prototypes are processed below.
+ open(CH, "<$rel_path_h") || die "Can't open $rel_path_h: $!\n";
+ defines:
+ while (<CH>) {
+ if ($pre_sub_tri_graphs) {
+ # Preprocess all tri-graphs
+ # including things stuck in quoted string constants.
+ s/\?\?=/#/g; # | ??=| #|
+ s/\?\?\!/|/g; # | ??!| ||
+ s/\?\?'/^/g; # | ??'| ^|
+ s/\?\?\(/[/g; # | ??(| [|
+ s/\?\?\)/]/g; # | ??)| ]|
+ s/\?\?\-/~/g; # | ??-| ~|
+ s/\?\?\//\\/g; # | ??/| \|
+ s/\?\?</{/g; # | ??<| {|
+ s/\?\?>/}/g; # | ??>| }|
+ }
+ if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^"\s])(.*)/) {
+ my $def = $1;
+ my $rest = $2;
+ $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments
+ $rest =~ s/^\s+//;
+ $rest =~ s/\s+$//;
+ # Cannot do: (-1) and ((LHANDLE)3) are OK:
+ #print("Skip non-wordy $def => $rest\n"),
+ # next defines if $rest =~ /[^\w\$]/;
+ if ($rest =~ /"/) {
+ print("Skip stringy $def => $rest\n") if $opt_d;
+ next defines;
+ }
+ print "Matched $_ ($def)\n" if $opt_d;
+ $seen_define{$def} = $rest;
+ $_ = $def;
+ next if /^_.*_h_*$/i; # special case, but for what?
+ if (defined $opt_p) {
+ if (!/^$opt_p(\d)/) {
+ ++$prefix{$_} if s/^$opt_p//;
+ }
+ else {
+ warn "can't remove $opt_p prefix from '$_'!\n";
+ }
+ }
+ $prefixless{$def} = $_;
+ if (!$fmask or /$fmask/) {
+ print "... Passes mask of -M.\n" if $opt_d and $fmask;
+ $const_names{$_}++;
+ }
+ }
+ }
+ if (defined $opt_e and !$opt_e) {
+ close(CH);
+ }
+ else {
+ # Work from miniperl too - on "normal" systems
+ my $SEEK_SET = eval 'use Fcntl qw/SEEK_SET/; SEEK_SET' or 0;
+ seek CH, 0, $SEEK_SET;
+ my $src = do { local $/; <CH> };
+ close CH;
+ no warnings 'uninitialized';
+
+ # Remove C and C++ comments
+ $src =~ s#/\*[^*]*\*+([^/*][^*]*\*+)*/|("(\\.|[^"\\])*"|'(\\.|[^'\\])*'|.[^/"'\\]*)#$2#gs;
+ $src =~ s#//.*$##gm;
+
+ while ($src =~ /\benum\s*([\w_]*)\s*\{\s([^}]+)\}/gsc) {
+ my ($enum_name, $enum_body) = ($1, $2);
+ # skip enums matching $opt_e
+ next if $opt_e && $enum_name =~ /$opt_e/;
+ my $val = 0;
+ for my $item (split /,/, $enum_body) {
+ next if $item =~ /\A\s*\Z/;
+ my ($key, $declared_val) = $item =~ /(\w+)\s*(?:=\s*(.*))?/;
+ $val = defined($declared_val) && length($declared_val) ? $declared_val : 1 + $val;
+ $seen_define{$key} = $val;
+ $const_names{$key} = { name => $key, macro => 1 };
+ }
+ } # while (...)
+ } # if (!defined $opt_e or $opt_e)
+ }
+ }
+}
+
+# Save current directory so that C::Scan can use it
+my $cwd = File::Spec->rel2abs( File::Spec->curdir );
+
+# As Ilya suggested, use a name that contains - and then it can't clash with
+# the names of any packages. A directory 'fallback' will clash with any
+# new pragmata down the fallback:: tree, but that seems unlikely.
+my $constscfname = 'const-c.inc';
+my $constsxsfname = 'const-xs.inc';
+my $fallbackdirname = 'fallback';
+
+my $ext = chdir 'ext' ? 'ext/' : '';
+
+my @modparts = split(/::/,$module);
+my $modpname = join('-', @modparts);
+my $modfname = pop @modparts;
+my $modpmdir = join '/', 'lib', @modparts;
+my $modpmname = join '/', $modpmdir, $modfname.'.pm';
+
+if ($opt_O) {
+ warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname;
+}
+else {
+ die "Won't overwrite existing $ext$modpname\n" if -e $modpname;
+}
+-d "$modpname" || mkpath([$modpname], 0, 0775);
+chdir($modpname) || die "Can't chdir $ext$modpname: $!\n";
+
+my %types_seen;
+my %std_types;
+my $fdecls = [];
+my $fdecls_parsed = [];
+my $typedef_rex;
+my %typedefs_pre;
+my %known_fnames;
+my %structs;
+
+my @fnames;
+my @fnames_no_prefix;
+my %vdecl_hash;
+my @vdecls;
+
+if( ! $opt_X ){ # use XS, unless it was disabled
+ unless ($skip_ppport) {
+ require Devel::PPPort;
+ warn "Writing $ext$modpname/ppport.h\n";
+ Devel::PPPort::WriteFile('ppport.h')
+ || die "Can't create $ext$modpname/ppport.h: $!\n";
+ }
+ open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n";
+ if ($opt_x) {
+ warn "Scanning typemaps...\n";
+ get_typemap();
+ my @td;
+ my @good_td;
+ my $addflags = $opt_F || '';
+
+ foreach my $filename (@path_h) {
+ my $c;
+ my $filter;
+
+ if ($fullpath{$filename} =~ /,/) {
+ $filename = $`;
+ $filter = $';
+ }
+ warn "Scanning $filename for functions...\n";
+ my @styles = $Config{gccversion} ? qw(C++ C9X GNU) : qw(C++ C9X);
+ $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter,
+ 'add_cppflags' => $addflags, 'c_styles' => \@styles;
+ $c->set('includeDirs' => ["$Config::Config{archlib}/CORE", $cwd]);
+
+ $c->get('keywords')->{'__restrict'} = 1;
+
+ push @$fdecls_parsed, @{ $c->get('parsed_fdecls') };
+ push(@$fdecls, @{$c->get('fdecls')});
+
+ push @td, @{$c->get('typedefs_maybe')};
+ if ($opt_a) {
+ my $structs = $c->get('typedef_structs');
+ @structs{keys %$structs} = values %$structs;
+ }
+
+ if ($opt_m) {
+ %vdecl_hash = %{ $c->get('vdecl_hash') };
+ @vdecls = sort keys %vdecl_hash;
+ for (local $_ = 0; $_ < @vdecls; ++$_) {
+ my $var = $vdecls[$_];
+ my($type, $post) = @{ $vdecl_hash{$var} };
+ if (defined $post) {
+ warn "Can't handle variable '$type $var $post', skipping.\n";
+ splice @vdecls, $_, 1;
+ redo;
+ }
+ $type = normalize_type($type);
+ $vdecl_hash{$var} = $type;
+ }
+ }
+
+ unless ($tmask_all) {
+ warn "Scanning $filename for typedefs...\n";
+ my $td = $c->get('typedef_hash');
+ # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d;
+ my @f_good_td = grep $td->{$_}[1] eq '', keys %$td;
+ push @good_td, @f_good_td;
+ @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td};
+ }
+ }
+ { local $" = '|';
+ $typedef_rex = qr(\b(?<!struct )(?:@good_td)\b) if @good_td;
+ }
+ %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT
+ if ($fmask) {
+ my @good;
+ for my $i (0..$#$fdecls_parsed) {
+ next unless $fdecls_parsed->[$i][1] =~ /$fmask/; # [1] is NAME
+ push @good, $i;
+ print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n"
+ if $opt_d;
+ }
+ $fdecls = [@$fdecls[@good]];
+ $fdecls_parsed = [@$fdecls_parsed[@good]];
+ }
+ @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME
+ # Sort declarations:
+ {
+ my %h = map( ($_->[1], $_), @$fdecls_parsed);
+ $fdecls_parsed = [ @h{@fnames} ];
+ }
+ @fnames_no_prefix = @fnames;
+ @fnames_no_prefix
+ = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix
+ if defined $opt_p;
+ # Remove macros which expand to typedefs
+ print "Typedefs are @td.\n" if $opt_d;
+ my %td = map {($_, $_)} @td;
+ # Add some other possible but meaningless values for macros
+ for my $k (qw(char double float int long short unsigned signed void)) {
+ $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned ');
+ }
+ # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@;
+ my $n = 0;
+ my %bad_macs;
+ while (keys %td > $n) {
+ $n = keys %td;
+ my ($k, $v);
+ while (($k, $v) = each %seen_define) {
+ # print("found '$k'=>'$v'\n"),
+ $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v};
+ }
+ }
+ # Now %bad_macs contains names of bad macros
+ for my $k (keys %bad_macs) {
+ delete $const_names{$prefixless{$k}};
+ print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d;
+ }
+ }
+}
+my (@const_specs, @const_names);
+
+for (sort(keys(%const_names))) {
+ my $v = $const_names{$_};
+
+ push(@const_specs, ref($v) ? $v : $_);
+ push(@const_names, $_);
+}
+
+-d $modpmdir || mkpath([$modpmdir], 0, 0775);
+open(PM, ">$modpmname") || die "Can't create $ext$modpname/$modpmname: $!\n";
+
+$" = "\n\t";
+warn "Writing $ext$modpname/$modpmname\n";
+
+print PM <<"END";
+package $module;
+
+use $compat_version;
+END
+
+print PM <<"END" unless $skip_strict;
+use strict;
+END
+
+print PM "use warnings;\n" unless $skip_warnings or $compat_version < 5.006;
+
+unless( $opt_X || $opt_c || $opt_A ){
+ # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and
+ # will want Carp.
+ print PM <<'END';
+use Carp;
+END
+}
+
+print PM <<'END' unless $skip_exporter;
+
+require Exporter;
+END
+
+my $use_Dyna = (not $opt_X and $compat_version < 5.006 and not $use_xsloader);
+print PM <<"END" if $use_Dyna; # use DynaLoader, unless XS was disabled
+require DynaLoader;
+END
+
+
+# Are we using AutoLoader or not?
+unless ($skip_autoloader) { # no autoloader whatsoever.
+ unless ($opt_c) { # we're doing the AUTOLOAD
+ print PM "use AutoLoader;\n";
+ }
+ else {
+ print PM "use AutoLoader qw(AUTOLOAD);\n"
+ }
+}
+
+if ( $compat_version < 5.006 ) {
+ my $vars = '$VERSION @ISA';
+ $vars .= ' @EXPORT @EXPORT_OK %EXPORT_TAGS' unless $skip_exporter;
+ $vars .= ' $AUTOLOAD' unless $opt_X || $opt_c || $opt_A;
+ $vars .= ' $XS_VERSION' if $opt_B && !$opt_X;
+ print PM "use vars qw($vars);";
+}
+
+# Determine @ISA.
+my @modISA;
+push @modISA, 'Exporter' unless $skip_exporter;
+push @modISA, 'DynaLoader' if $use_Dyna; # no XS
+my $myISA = "our \@ISA = qw(@modISA);";
+$myISA =~ s/^our // if $compat_version < 5.006;
+
+print PM "\n$myISA\n\n";
+
+my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls);
+
+my $tmp='';
+$tmp .= <<"END" unless $skip_exporter;
+# 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.
+
+# This allows declaration use $module ':all';
+# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( 'all' => [ qw(
+ @exported_names
+) ] );
+
+our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } );
+
+our \@EXPORT = qw(
+ @const_names
+);
+
+END
+
+$tmp .= "our \$VERSION = '$TEMPLATE_VERSION';\n";
+if ($opt_B) {
+ $tmp .= "our \$XS_VERSION = \$VERSION;\n" unless $opt_X;
+ $tmp .= "\$VERSION = eval \$VERSION; # see L<perlmodstyle>\n";
+}
+$tmp .= "\n";
+
+$tmp =~ s/^our //mg if $compat_version < 5.006;
+print PM $tmp;
+
+if (@vdecls) {
+ printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n";
+}
+
+
+print PM autoload ($module, $compat_version) unless $opt_c or $opt_X;
+
+if( ! $opt_X ){ # print bootstrap, unless XS is disabled
+ if ($use_Dyna) {
+ $tmp = <<"END";
+bootstrap $module \$VERSION;
+END
+ } else {
+ $tmp = <<"END";
+require XSLoader;
+XSLoader::load('$module', \$VERSION);
+END
+ }
+ $tmp =~ s:\$VERSION:\$XS_VERSION:g if $opt_B;
+ print PM $tmp;
+}
+
+# tying the variables can happen only after bootstrap
+if (@vdecls) {
+ printf PM <<END;
+{
+@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]}
+}
+
+END
+}
+
+my $after;
+if( $opt_P ){ # if POD is disabled
+ $after = '__END__';
+}
+else {
+ $after = '=cut';
+}
+
+print PM <<"END";
+
+# Preloaded methods go here.
+END
+
+print PM <<"END" unless $opt_A;
+
+# Autoload methods go after $after, and are processed by the autosplit program.
+END
+
+print PM <<"END";
+
+1;
+__END__
+END
+
+my ($email,$author,$licence);
+
+eval {
+ my $username;
+ ($username,$author) = (getpwuid($>))[0,6];
+ if (defined $username && defined $author) {
+ $author =~ s/,.*$//; # in case of sub fields
+ my $domain = $Config{'mydomain'};
+ $domain =~ s/^\.//;
+ $email = "$username\@$domain";
+ }
+ };
+
+$author =~ s/'/\\'/g if defined $author;
+$author ||= "A. U. Thor";
+$email ||= 'a.u.thor@a.galaxy.far.far.away';
+
+$licence = sprintf << "DEFAULT", $^V;
+Copyright (C) ${\(1900 + (localtime) [5])} by $author
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version %vd or,
+at your option, any later version of Perl 5 you may have available.
+DEFAULT
+
+my $revhist = '';
+$revhist = <<EOT if $opt_C;
+#
+#=head1 HISTORY
+#
+#=over 8
+#
+#=item $TEMPLATE_VERSION
+#
+#Original version; created by h2xs $H2XS_VERSION with options
+#
+# @ARGS
+#
+#=back
+#
+EOT
+
+my $exp_doc = $skip_exporter ? '' : <<EOD;
+#
+#=head2 EXPORT
+#
+#None by default.
+#
+EOD
+
+if (@const_names and not $opt_P) {
+ $exp_doc .= <<EOD unless $skip_exporter;
+#=head2 Exportable constants
+#
+# @{[join "\n ", @const_names]}
+#
+EOD
+}
+
+if (defined $fdecls and @$fdecls and not $opt_P) {
+ $exp_doc .= <<EOD unless $skip_exporter;
+#=head2 Exportable functions
+#
+EOD
+
+# $exp_doc .= <<EOD if $opt_p;
+#When accessing these functions from Perl, prefix C<$opt_p> should be removed.
+#
+#EOD
+ $exp_doc .= <<EOD unless $skip_exporter;
+# @{[join "\n ", @known_fnames{@fnames}]}
+#
+EOD
+}
+
+my $meth_doc = '';
+
+if ($opt_x && $opt_a) {
+ my($name, $struct);
+ $meth_doc .= accessor_docs($name, $struct)
+ while ($name, $struct) = each %structs;
+}
+
+# Prefix the default licence with hash symbols.
+# Is this just cargo cult - it seems that the first thing that happens to this
+# block is that all the hashes are then s///g out.
+my $licence_hash = $licence;
+$licence_hash =~ s/^/#/gm;
+
+my $pod;
+$pod = <<"END" unless $opt_P;
+## Below is stub documentation for your module. You'd better edit it!
+#
+#=head1 NAME
+#
+#$module - Perl extension for blah blah blah
+#
+#=head1 SYNOPSIS
+#
+# use $module;
+# blah blah blah
+#
+#=head1 DESCRIPTION
+#
+#Stub documentation for $module, created by h2xs. It looks like the
+#author of the extension was negligent enough to leave the stub
+#unedited.
+#
+#Blah blah blah.
+$exp_doc$meth_doc$revhist
+#
+#=head1 SEE ALSO
+#
+#Mention other useful documentation such as the documentation of
+#related modules or operating system documentation (such as man pages
+#in UNIX), or any relevant external documentation such as RFCs or
+#standards.
+#
+#If you have a mailing list set up for your module, mention it here.
+#
+#If you have a web site set up for your module, mention it here.
+#
+#=head1 AUTHOR
+#
+#$author, E<lt>${email}E<gt>
+#
+#=head1 COPYRIGHT AND LICENSE
+#
+$licence_hash
+#
+#=cut
+END
+
+$pod =~ s/^\#//gm unless $opt_P;
+print PM $pod unless $opt_P;
+
+close PM;
+
+
+if( ! $opt_X ){ # print XS, unless it is disabled
+warn "Writing $ext$modpname/$modfname.xs\n";
+
+print XS <<"END";
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+END
+
+print XS <<"END" unless $skip_ppport;
+#include "ppport.h"
+
+END
+
+if( @path_h ){
+ foreach my $path_h (@path_h_ini) {
+ my($h) = $path_h;
+ $h =~ s#^/usr/include/##;
+ if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
+ print XS qq{#include <$h>\n};
+ }
+ print XS "\n";
+}
+
+print XS <<"END" if $opt_g;
+
+/* Global Data */
+
+#define MY_CXT_KEY "${module}::_guts" XS_VERSION
+
+typedef struct {
+ /* Put Global Data in here */
+ int dummy; /* you can access this elsewhere as MY_CXT.dummy */
+} my_cxt_t;
+
+START_MY_CXT
+
+END
+
+my %pointer_typedefs;
+my %struct_typedefs;
+
+sub td_is_pointer {
+ my $type = shift;
+ my $out = $pointer_typedefs{$type};
+ return $out if defined $out;
+ my $otype = $type;
+ $out = ($type =~ /\*$/);
+ # This converts only the guys which do not have trailing part in the typedef
+ if (not $out
+ and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+ $type = normalize_type($type);
+ print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n"
+ if $opt_d;
+ $out = td_is_pointer($type);
+ }
+ return ($pointer_typedefs{$otype} = $out);
+}
+
+sub td_is_struct {
+ my $type = shift;
+ my $out = $struct_typedefs{$type};
+ return $out if defined $out;
+ my $otype = $type;
+ $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type);
+ # This converts only the guys which do not have trailing part in the typedef
+ if (not $out
+ and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+ $type = normalize_type($type);
+ print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n"
+ if $opt_d;
+ $out = td_is_struct($type);
+ }
+ return ($struct_typedefs{$otype} = $out);
+}
+
+print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls;
+
+if( ! $opt_c ) {
+ # We write the "sample" files used when this module is built by perl without
+ # ExtUtils::Constant.
+ # h2xs will later check that these are the same as those generated by the
+ # code embedded into Makefile.PL
+ unless (-d $fallbackdirname) {
+ mkdir "$fallbackdirname" or die "Cannot mkdir $fallbackdirname: $!\n";
+ }
+ warn "Writing $ext$modpname/$fallbackdirname/$constscfname\n";
+ warn "Writing $ext$modpname/$fallbackdirname/$constsxsfname\n";
+ my $cfallback = File::Spec->catfile($fallbackdirname, $constscfname);
+ my $xsfallback = File::Spec->catfile($fallbackdirname, $constsxsfname);
+ WriteConstants ( C_FILE => $cfallback,
+ XS_FILE => $xsfallback,
+ DEFAULT_TYPE => $opt_t,
+ NAME => $module,
+ NAMES => \@const_specs,
+ );
+ print XS "#include \"$constscfname\"\n";
+}
+
+
+my $prefix = defined $opt_p ? "PREFIX = $opt_p" : '';
+
+# Now switch from C to XS by issuing the first MODULE declaration:
+print XS <<"END";
+
+MODULE = $module PACKAGE = $module $prefix
+
+END
+
+# If a constant() function was #included then output a corresponding
+# XS declaration:
+print XS "INCLUDE: $constsxsfname\n" unless $opt_c;
+
+print XS <<"END" if $opt_g;
+
+BOOT:
+{
+ MY_CXT_INIT;
+ /* If any of the fields in the my_cxt_t struct need
+ to be initialised, do it here.
+ */
+}
+
+END
+
+foreach (sort keys %const_xsub) {
+ print XS <<"END";
+char *
+$_()
+
+ CODE:
+#ifdef $_
+ RETVAL = $_;
+#else
+ croak("Your vendor has not defined the $module macro $_");
+#endif
+
+ OUTPUT:
+ RETVAL
+
+END
+}
+
+my %seen_decl;
+my %typemap;
+
+sub print_decl {
+ my $fh = shift;
+ my $decl = shift;
+ my ($type, $name, $args) = @$decl;
+ return if $seen_decl{$name}++; # Need to do the same for docs as well?
+
+ my @argnames = map {$_->[1]} @$args;
+ my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args;
+ if ($opt_k) {
+ s/^\s*const\b\s*// for @argtypes;
+ }
+ my @argarrays = map { $_->[4] || '' } @$args;
+ my $numargs = @$args;
+ if ($numargs and $argtypes[-1] eq '...') {
+ $numargs--;
+ $argnames[-1] = '...';
+ }
+ local $" = ', ';
+ $type = normalize_type($type, 1);
+
+ print $fh <<"EOP";
+
+$type
+$name(@argnames)
+EOP
+
+ for my $arg (0 .. $numargs - 1) {
+ print $fh <<"EOP";
+ $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
+EOP
+ }
+}
+
+sub print_tievar_subs {
+ my($fh, $name, $type) = @_;
+ print $fh <<END;
+I32
+_get_$name(IV index, SV *sv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(sv);
+ PUTBACK;
+ (void)call_pv("$module\::_get_$name", G_DISCARD);
+ return (I32)0;
+}
+
+I32
+_set_$name(IV index, SV *sv) {
+ dSP;
+ PUSHMARK(SP);
+ XPUSHs(sv);
+ PUTBACK;
+ (void)call_pv("$module\::_set_$name", G_DISCARD);
+ return (I32)0;
+}
+
+END
+}
+
+sub print_tievar_xsubs {
+ my($fh, $name, $type) = @_;
+ print $fh <<END;
+void
+_tievar_$name(sv)
+ SV* sv
+ PREINIT:
+ struct ufuncs uf;
+ CODE:
+ uf.uf_val = &_get_$name;
+ uf.uf_set = &_set_$name;
+ uf.uf_index = (IV)&_get_$name;
+ sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf));
+
+void
+_get_$name(THIS)
+ $type THIS = NO_INIT
+ CODE:
+ THIS = $name;
+ OUTPUT:
+ SETMAGIC: DISABLE
+ THIS
+
+void
+_set_$name(THIS)
+ $type THIS
+ CODE:
+ $name = THIS;
+
+END
+}
+
+sub print_accessors {
+ my($fh, $name, $struct) = @_;
+ return unless defined $struct && $name !~ /\s|_ANON/;
+ $name = normalize_type($name);
+ my $ptrname = normalize_type("$name *");
+ print $fh <<"EOF";
+
+MODULE = $module PACKAGE = ${name} $prefix
+
+$name *
+_to_ptr(THIS)
+ $name THIS = NO_INIT
+ PROTOTYPE: \$
+ CODE:
+ if (sv_derived_from(ST(0), "$name")) {
+ STRLEN len;
+ char *s = SvPV((SV*)SvRV(ST(0)), len);
+ if (len != sizeof(THIS))
+ croak("Size \%d of packed data != expected \%d",
+ len, sizeof(THIS));
+ RETVAL = ($name *)s;
+ }
+ else
+ croak("THIS is not of type $name");
+ OUTPUT:
+ RETVAL
+
+$name
+new(CLASS)
+ char *CLASS = NO_INIT
+ PROTOTYPE: \$
+ CODE:
+ Zero((void*)&RETVAL, sizeof(RETVAL), char);
+ OUTPUT:
+ RETVAL
+
+MODULE = $module PACKAGE = ${name}Ptr $prefix
+
+EOF
+ my @items = @$struct;
+ while (@items) {
+ my $item = shift @items;
+ if ($item->[0] =~ /_ANON/) {
+ if (defined $item->[2]) {
+ push @items, map [
+ @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
+ ], @{ $structs{$item->[0]} };
+ } else {
+ push @items, @{ $structs{$item->[0]} };
+ }
+ } else {
+ my $type = normalize_type($item->[0]);
+ my $ttype = $structs{$type} ? normalize_type("$type *") : $type;
+ print $fh <<"EOF";
+$ttype
+$item->[2](THIS, __value = NO_INIT)
+ $ptrname THIS
+ $type __value
+ PROTOTYPE: \$;\$
+ CODE:
+ if (items > 1)
+ THIS->$item->[-1] = __value;
+ RETVAL = @{[
+ $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])"
+ ]};
+ OUTPUT:
+ RETVAL
+
+EOF
+ }
+ }
+}
+
+sub accessor_docs {
+ my($name, $struct) = @_;
+ return unless defined $struct && $name !~ /\s|_ANON/;
+ $name = normalize_type($name);
+ my $ptrname = $name . 'Ptr';
+ my @items = @$struct;
+ my @list;
+ while (@items) {
+ my $item = shift @items;
+ if ($item->[0] =~ /_ANON/) {
+ if (defined $item->[2]) {
+ push @items, map [
+ @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]",
+ ], @{ $structs{$item->[0]} };
+ } else {
+ push @items, @{ $structs{$item->[0]} };
+ }
+ } else {
+ push @list, $item->[2];
+ }
+ }
+ my $methods = (join '(...)>, C<', @list) . '(...)';
+
+ my $pod = <<"EOF";
+#
+#=head2 Object and class methods for C<$name>/C<$ptrname>
+#
+#The principal Perl representation of a C object of type C<$name> is an
+#object of class C<$ptrname> which is a reference to an integer
+#representation of a C pointer. To create such an object, one may use
+#a combination
+#
+# my \$buffer = $name->new();
+# my \$obj = \$buffer->_to_ptr();
+#
+#This exersizes the following two methods, and an additional class
+#C<$name>, the internal representation of which is a reference to a
+#packed string with the C structure. Keep in mind that \$buffer should
+#better survive longer than \$obj.
+#
+#=over
+#
+#=item C<\$object_of_type_$name-E<gt>_to_ptr()>
+#
+#Converts an object of type C<$name> to an object of type C<$ptrname>.
+#
+#=item C<$name-E<gt>new()>
+#
+#Creates an empty object of type C<$name>. The corresponding packed
+#string is zeroed out.
+#
+#=item C<$methods>
+#
+#return the current value of the corresponding element if called
+#without additional arguments. Set the element to the supplied value
+#(and return the new value) if called with an additional argument.
+#
+#Applicable to objects of type C<$ptrname>.
+#
+#=back
+#
+EOF
+ $pod =~ s/^\#//gm;
+ return $pod;
+}
+
+# Should be called before any actual call to normalize_type().
+sub get_typemap {
+ # We do not want to read ./typemap by obvios reasons.
+ my @tm = qw(../../../typemap ../../typemap ../typemap);
+ my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap";
+ unshift @tm, $stdtypemap;
+ my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
+
+ # Start with useful default values
+ $typemap{float} = 'T_NV';
+
+ foreach my $typemap (@tm) {
+ next unless -e $typemap ;
+ # skip directories, binary files etc.
+ warn " Scanning $typemap\n";
+ warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
+ unless -T $typemap ;
+ open(TYPEMAP, $typemap)
+ or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
+ my $mode = 'Typemap';
+ while (<TYPEMAP>) {
+ next if /^\s*\#/;
+ if (/^INPUT\s*$/) { $mode = 'Input'; next; }
+ elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; }
+ elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; }
+ elsif ($mode eq 'Typemap') {
+ next if /^\s*($|\#)/ ;
+ my ($type, $image);
+ if ( ($type, $image) =
+ /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o
+ # This may reference undefined functions:
+ and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) {
+ $typemap{normalize_type($type)} = $image;
+ }
+ }
+ }
+ close(TYPEMAP) or die "Cannot close $typemap: $!";
+ }
+ %std_types = %types_seen;
+ %types_seen = ();
+}
+
+
+sub normalize_type { # Second arg: do not strip const's before \*
+ my $type = shift;
+ my $do_keep_deep_const = shift;
+ # If $do_keep_deep_const this is heuristical only
+ my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : '');
+ my $ignore_mods
+ = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*";
+ if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately!
+ $type =~ s/$ignore_mods//go;
+ }
+ else {
+ $type =~ s/$ignore_mods//go;
+ }
+ $type =~ s/([^\s\w])/ $1 /g;
+ $type =~ s/\s+$//;
+ $type =~ s/^\s+//;
+ $type =~ s/\s+/ /g;
+ $type =~ s/\* (?=\*)/*/g;
+ $type =~ s/\. \. \./.../g;
+ $type =~ s/ ,/,/g;
+ $types_seen{$type}++
+ unless $type eq '...' or $type eq 'void' or $std_types{$type};
+ $type;
+}
+
+my $need_opaque;
+
+sub assign_typemap_entry {
+ my $type = shift;
+ my $otype = $type;
+ my $entry;
+ if ($tmask and $type =~ /$tmask/) {
+ print "Type $type matches -o mask\n" if $opt_d;
+ $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+ }
+ elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) {
+ $type = normalize_type $type;
+ print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d;
+ $entry = assign_typemap_entry($type);
+ }
+ # XXX good do better if our UV happens to be long long
+ return "T_NV" if $type =~ /^(unsigned\s+)?long\s+(long|double)\z/;
+ $entry ||= $typemap{$otype}
+ || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ");
+ $typemap{$otype} = $entry;
+ $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT";
+ return $entry;
+}
+
+for (@vdecls) {
+ print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_});
+}
+
+if ($opt_x) {
+ for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) }
+ if ($opt_a) {
+ while (my($name, $struct) = each %structs) {
+ print_accessors(\*XS, $name, $struct);
+ }
+ }
+}
+
+close XS;
+
+if (%types_seen) {
+ my $type;
+ warn "Writing $ext$modpname/typemap\n";
+ open TM, ">typemap" or die "Cannot open typemap file for write: $!";
+
+ for $type (sort keys %types_seen) {
+ my $entry = assign_typemap_entry $type;
+ print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n"
+ }
+
+ print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry
+#############################################################################
+INPUT
+T_OPAQUE_STRUCT
+ if (sv_derived_from($arg, \"${ntype}\")) {
+ STRLEN len;
+ char *s = SvPV((SV*)SvRV($arg), len);
+
+ if (len != sizeof($var))
+ croak(\"Size %d of packed data != expected %d\",
+ len, sizeof($var));
+ $var = *($type *)s;
+ }
+ else
+ croak(\"$var is not of type ${ntype}\")
+#############################################################################
+OUTPUT
+T_OPAQUE_STRUCT
+ sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var));
+EOP
+
+ close TM or die "Cannot close typemap file for write: $!";
+}
+
+} # if( ! $opt_X )
+
+warn "Writing $ext$modpname/Makefile.PL\n";
+open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n";
+
+my $prereq_pm = '';
+
+if ( $compat_version < 5.00702 and $new_test )
+{
+ $prereq_pm .= q%'Test::More' => 0, %;
+}
+
+if ( $compat_version < 5.00600 and !$opt_X and $use_xsloader)
+{
+ $prereq_pm .= q%'XSLoader' => 0, %;
+}
+
+print PL <<"END";
+use $compat_version;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => '$module',
+ VERSION_FROM => '$modpmname', # finds \$VERSION
+ PREREQ_PM => {$prereq_pm}, # e.g., Module::Name => 1.1
+ (\$] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => '$modpmname', # retrieve abstract from module
+ AUTHOR => '$author <$email>') : ()),
+END
+if (!$opt_X) { # print C stuff, unless XS is disabled
+ $opt_F = '' unless defined $opt_F;
+ my $I = (((glob '*.h') || (glob '*.hh')) ? '-I.' : '');
+ my $Ihelp = ($I ? '-I. ' : '');
+ my $Icomment = ($I ? '' : <<EOC);
+ # Insert -I. if you add *.h files later:
+EOC
+
+ print PL <<END;
+ LIBS => ['$extralibs'], # e.g., '-lm'
+ DEFINE => '$opt_F', # e.g., '-DHAVE_SOMETHING'
+$Icomment INC => '$I', # e.g., '${Ihelp}-I/usr/include/other'
+END
+
+ my $C = grep {$_ ne "$modfname.c"}
+ (glob '*.c'), (glob '*.cc'), (glob '*.C');
+ my $Cpre = ($C ? '' : '# ');
+ my $Ccomment = ($C ? '' : <<EOC);
+ # Un-comment this if you add C files to link with later:
+EOC
+
+ print PL <<END;
+$Ccomment ${Cpre}OBJECT => '\$(O_FILES)', # link all the C files too
+END
+} # ' # Grr
+print PL ");\n";
+if (!$opt_c) {
+ my $generate_code =
+ WriteMakefileSnippet ( C_FILE => $constscfname,
+ XS_FILE => $constsxsfname,
+ DEFAULT_TYPE => $opt_t,
+ NAME => $module,
+ NAMES => \@const_specs,
+ );
+ print PL <<"END";
+if (eval {require ExtUtils::Constant; 1}) {
+ # If you edit these definitions to change the constants used by this module,
+ # you will need to use the generated $constscfname and $constsxsfname
+ # files to replace their "fallback" counterparts before distributing your
+ # changes.
+$generate_code
+}
+else {
+ use File::Copy;
+ use File::Spec;
+ foreach my \$file ('$constscfname', '$constsxsfname') {
+ my \$fallback = File::Spec->catfile('$fallbackdirname', \$file);
+ copy (\$fallback, \$file) or die "Can't copy \$fallback to \$file: \$!";
+ }
+}
+END
+
+ eval $generate_code;
+ if ($@) {
+ warn <<"EOM";
+Attempting to test constant code in $ext$modpname/Makefile.PL:
+$generate_code
+__END__
+gave unexpected error $@
+Please report the circumstances of this bug in h2xs version $H2XS_VERSION
+using the perlbug script.
+EOM
+ } else {
+ my $fail;
+
+ foreach my $file ($constscfname, $constsxsfname) {
+ my $fallback = File::Spec->catfile($fallbackdirname, $file);
+ if (compare($file, $fallback)) {
+ warn << "EOM";
+Files "$ext$modpname/$fallbackdirname/$file" and "$ext$modpname/$file" differ.
+EOM
+ $fail++;
+ }
+ }
+ if ($fail) {
+ warn fill ('','', <<"EOM") . "\n";
+It appears that the code in $ext$modpname/Makefile.PL does not autogenerate
+the files $ext$modpname/$constscfname and $ext$modpname/$constsxsfname
+correctly.
+
+Please report the circumstances of this bug in h2xs version $H2XS_VERSION
+using the perlbug script.
+EOM
+ } else {
+ unlink $constscfname, $constsxsfname;
+ }
+ }
+}
+close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n";
+
+# Create a simple README since this is a CPAN requirement
+# and it doesnt hurt to have one
+warn "Writing $ext$modpname/README\n";
+open(RM, ">README") || die "Can't create $ext$modpname/README:$!\n";
+my $thisyear = (gmtime)[5] + 1900;
+my $rmhead = "$modpname version $TEMPLATE_VERSION";
+my $rmheadeq = "=" x length($rmhead);
+
+my $rm_prereq;
+
+if ( $compat_version < 5.00702 and $new_test )
+{
+ $rm_prereq = 'Test::More';
+}
+else
+{
+ $rm_prereq = 'blah blah blah';
+}
+
+print RM <<_RMEND_;
+$rmhead
+$rmheadeq
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the
+README file from a module distribution so that people browsing the
+archive can use it get an idea of the modules uses. It is usually a
+good idea to provide version information here so that people can
+decide whether fixes for the module are worth downloading.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ $rm_prereq
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+$licence
+
+_RMEND_
+close(RM) || die "Can't close $ext$modpname/README: $!\n";
+
+my $testdir = "t";
+my $testfile = "$testdir/$modpname.t";
+unless (-d "$testdir") {
+ mkdir "$testdir" or die "Cannot mkdir $testdir: $!\n";
+}
+warn "Writing $ext$modpname/$testfile\n";
+my $tests = @const_names ? 2 : 1;
+
+open EX, ">$testfile" or die "Can't create $ext$modpname/$testfile: $!\n";
+
+print EX <<_END_;
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl $modpname.t'
+
+#########################
+
+# change 'tests => $tests' to 'tests => last_test_to_print';
+
+_END_
+
+my $test_mod = 'Test::More';
+
+if ( $old_test or ($compat_version < 5.007 and not $new_test ))
+{
+ my $test_mod = 'Test';
+
+ print EX <<_END_;
+use Test;
+BEGIN { plan tests => $tests };
+use $module;
+ok(1); # If we made it this far, we're ok.
+
+_END_
+
+ if (@const_names) {
+ my $const_names = join " ", @const_names;
+ print EX <<'_END_';
+
+my $fail;
+foreach my $constname (qw(
+_END_
+
+ print EX wrap ("\t", "\t", $const_names);
+ print EX (")) {\n");
+
+ print EX <<_END_;
+ next if (eval "my \\\$a = \$constname; 1");
+ if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
+ print "# pass: \$\@";
+ } else {
+ print "# fail: \$\@";
+ \$fail = 1;
+ }
+}
+if (\$fail) {
+ print "not ok 2\\n";
+} else {
+ print "ok 2\\n";
+}
+
+_END_
+ }
+}
+else
+{
+ print EX <<_END_;
+use Test::More tests => $tests;
+BEGIN { use_ok('$module') };
+
+_END_
+
+ if (@const_names) {
+ my $const_names = join " ", @const_names;
+ print EX <<'_END_';
+
+my $fail = 0;
+foreach my $constname (qw(
+_END_
+
+ print EX wrap ("\t", "\t", $const_names);
+ print EX (")) {\n");
+
+ print EX <<_END_;
+ next if (eval "my \\\$a = \$constname; 1");
+ if (\$\@ =~ /^Your vendor has not defined $module macro \$constname/) {
+ print "# pass: \$\@";
+ } else {
+ print "# fail: \$\@";
+ \$fail = 1;
+ }
+
+}
+
+ok( \$fail == 0 , 'Constants' );
+_END_
+ }
+}
+
+print EX <<_END_;
+#########################
+
+# Insert your test code below, the $test_mod module is use()ed here so read
+# its man page ( perldoc $test_mod ) for help writing this test script.
+
+_END_
+
+close(EX) || die "Can't close $ext$modpname/$testfile: $!\n";
+
+unless ($opt_C) {
+ warn "Writing $ext$modpname/Changes\n";
+ $" = ' ';
+ open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n";
+ @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS;
+ print EX <<EOP;
+Revision history for Perl extension $module.
+
+$TEMPLATE_VERSION @{[scalar localtime]}
+\t- original version; created by h2xs $H2XS_VERSION with options
+\t\t@ARGS
+
+EOP
+ close(EX) || die "Can't close $ext$modpname/Changes: $!\n";
+}
+
+warn "Writing $ext$modpname/MANIFEST\n";
+open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!";
+my @files = grep { -f } (<*>, <t/*>, <$fallbackdirname/*>, <$modpmdir/*>);
+if (!@files) {
+ eval {opendir(D,'.');};
+ unless ($@) { @files = readdir(D); closedir(D); }
+}
+if (!@files) { @files = map {chomp && $_} `ls`; }
+if ($^O eq 'VMS') {
+ foreach (@files) {
+ # Clip trailing '.' for portability -- non-VMS OSs don't expect it
+ s%\.$%%;
+ # Fix up for case-sensitive file systems
+ s/$modfname/$modfname/i && next;
+ $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
+ $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
+ }
+}
+print MANI join("\n",@files), "\n";
+close MANI;
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/instmodsh b/Master/tlpkg/tlperl/bin/instmodsh new file mode 100755 index 00000000000..5874aa61c7a --- /dev/null +++ b/Master/tlpkg/tlperl/bin/instmodsh @@ -0,0 +1,192 @@ +#!/usr/bin/perl -w + +use strict; +use IO::File; +use ExtUtils::Packlist; +use ExtUtils::Installed; + +use vars qw($Inst @Modules); + + +=head1 NAME + +instmodsh - A shell to examine installed modules + +=head1 SYNOPSIS + + instmodsh + +=head1 DESCRIPTION + +A little interface to ExtUtils::Installed to examine installed modules, +validate your packlists and even create a tarball from an installed module. + +=head1 SEE ALSO + +ExtUtils::Installed + +=cut + + +my $Module_Help = <<EOF; +Available commands are: + f [all|prog|doc] - List installed files of a given type + d [all|prog|doc] - List the directories used by a module + v - Validate the .packlist - check for missing files + t <tarfile> - Create a tar archive of the module + h - Display module help + q - Quit the module +EOF + +my %Module_Commands = ( + f => \&list_installed, + d => \&list_directories, + v => \&validate_packlist, + t => \&create_archive, + h => \&module_help, + ); + +sub do_module($) { + my ($module) = @_; + + print($Module_Help); + MODULE_CMD: while (1) { + print("$module cmd? "); + + my $reply = <STDIN>; chomp($reply); + my($cmd) = $reply =~ /^(\w)\b/; + + last if $cmd eq 'q'; + + if( $Module_Commands{$cmd} ) { + $Module_Commands{$cmd}->($reply, $module); + } + elsif( $cmd eq 'q' ) { + last MODULE_CMD; + } + else { + module_help(); + } + } +} + + +sub list_installed { + my($reply, $module) = @_; + + my $class = (split(' ', $reply))[1]; + $class = 'all' unless $class; + + my @files; + if (eval { @files = $Inst->files($module, $class); }) { + print("$class files in $module are:\n ", + join("\n ", @files), "\n"); + } + else { + print($@); + } +}; + + +sub list_directories { + my($reply, $module) = @_; + + my $class = (split(' ', $reply))[1]; + $class = 'all' unless $class; + + my @dirs; + if (eval { @dirs = $Inst->directories($module, $class); }) { + print("$class directories in $module are:\n ", + join("\n ", @dirs), "\n"); + } + else { + print($@); + } +} + + +sub create_archive { + my($reply, $module) = @_; + + my $file = (split(' ', $reply))[1]; + + if( !(defined $file and length $file) ) { + print "No tar file specified\n"; + } + elsif( eval { require Archive::Tar } ) { + Archive::Tar->create_archive($file, 0, $Inst->files($module)); + } + else { + my($first, @rest) = $Inst->files($module); + system('tar', 'cvf', $file, $first); + for my $f (@rest) { + system('tar', 'rvf', $file, $f); + } + print "Can't use tar\n" if $?; + } +} + + +sub validate_packlist { + my($reply, $module) = @_; + + if (my @missing = $Inst->validate($module)) { + print("Files missing from $module are:\n ", + join("\n ", @missing), "\n"); + } + else { + print("$module has no missing files\n"); + } +} + +sub module_help { + print $Module_Help; +} + + + +############################################################################## + +sub toplevel() +{ +my $help = <<EOF; +Available commands are: + l - List all installed modules + m <module> - Select a module + q - Quit the program +EOF +print($help); +while (1) + { + print("cmd? "); + my $reply = <STDIN>; chomp($reply); + CASE: + { + $reply eq 'l' and do + { + print("Installed modules are:\n ", join("\n ", @Modules), "\n"); + last CASE; + }; + $reply =~ /^m\s+/ and do + { + do_module((split(' ', $reply))[1]); + last CASE; + }; + $reply eq 'q' and do + { + exit(0); + }; + # Default + print($help); + } + } +} + + +############################################################################### + +$Inst = ExtUtils::Installed->new(); +@Modules = $Inst->modules(); +toplevel(); + +############################################################################### diff --git a/Master/tlpkg/tlperl/bin/instmodsh.bat b/Master/tlpkg/tlperl/bin/instmodsh.bat new file mode 100755 index 00000000000..c72c0f22199 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/instmodsh.bat @@ -0,0 +1,208 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+use strict;
+use IO::File;
+use ExtUtils::Packlist;
+use ExtUtils::Installed;
+
+use vars qw($Inst @Modules);
+
+
+=head1 NAME
+
+instmodsh - A shell to examine installed modules
+
+=head1 SYNOPSIS
+
+ instmodsh
+
+=head1 DESCRIPTION
+
+A little interface to ExtUtils::Installed to examine installed modules,
+validate your packlists and even create a tarball from an installed module.
+
+=head1 SEE ALSO
+
+ExtUtils::Installed
+
+=cut
+
+
+my $Module_Help = <<EOF;
+Available commands are:
+ f [all|prog|doc] - List installed files of a given type
+ d [all|prog|doc] - List the directories used by a module
+ v - Validate the .packlist - check for missing files
+ t <tarfile> - Create a tar archive of the module
+ h - Display module help
+ q - Quit the module
+EOF
+
+my %Module_Commands = (
+ f => \&list_installed,
+ d => \&list_directories,
+ v => \&validate_packlist,
+ t => \&create_archive,
+ h => \&module_help,
+ );
+
+sub do_module($) {
+ my ($module) = @_;
+
+ print($Module_Help);
+ MODULE_CMD: while (1) {
+ print("$module cmd? ");
+
+ my $reply = <STDIN>; chomp($reply);
+ my($cmd) = $reply =~ /^(\w)\b/;
+
+ last if $cmd eq 'q';
+
+ if( $Module_Commands{$cmd} ) {
+ $Module_Commands{$cmd}->($reply, $module);
+ }
+ elsif( $cmd eq 'q' ) {
+ last MODULE_CMD;
+ }
+ else {
+ module_help();
+ }
+ }
+}
+
+
+sub list_installed {
+ my($reply, $module) = @_;
+
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' unless $class;
+
+ my @files;
+ if (eval { @files = $Inst->files($module, $class); }) {
+ print("$class files in $module are:\n ",
+ join("\n ", @files), "\n");
+ }
+ else {
+ print($@);
+ }
+};
+
+
+sub list_directories {
+ my($reply, $module) = @_;
+
+ my $class = (split(' ', $reply))[1];
+ $class = 'all' unless $class;
+
+ my @dirs;
+ if (eval { @dirs = $Inst->directories($module, $class); }) {
+ print("$class directories in $module are:\n ",
+ join("\n ", @dirs), "\n");
+ }
+ else {
+ print($@);
+ }
+}
+
+
+sub create_archive {
+ my($reply, $module) = @_;
+
+ my $file = (split(' ', $reply))[1];
+
+ if( !(defined $file and length $file) ) {
+ print "No tar file specified\n";
+ }
+ elsif( eval { require Archive::Tar } ) {
+ Archive::Tar->create_archive($file, 0, $Inst->files($module));
+ }
+ else {
+ my($first, @rest) = $Inst->files($module);
+ system('tar', 'cvf', $file, $first);
+ for my $f (@rest) {
+ system('tar', 'rvf', $file, $f);
+ }
+ print "Can't use tar\n" if $?;
+ }
+}
+
+
+sub validate_packlist {
+ my($reply, $module) = @_;
+
+ if (my @missing = $Inst->validate($module)) {
+ print("Files missing from $module are:\n ",
+ join("\n ", @missing), "\n");
+ }
+ else {
+ print("$module has no missing files\n");
+ }
+}
+
+sub module_help {
+ print $Module_Help;
+}
+
+
+
+##############################################################################
+
+sub toplevel()
+{
+my $help = <<EOF;
+Available commands are:
+ l - List all installed modules
+ m <module> - Select a module
+ q - Quit the program
+EOF
+print($help);
+while (1)
+ {
+ print("cmd? ");
+ my $reply = <STDIN>; chomp($reply);
+ CASE:
+ {
+ $reply eq 'l' and do
+ {
+ print("Installed modules are:\n ", join("\n ", @Modules), "\n");
+ last CASE;
+ };
+ $reply =~ /^m\s+/ and do
+ {
+ do_module((split(' ', $reply))[1]);
+ last CASE;
+ };
+ $reply eq 'q' and do
+ {
+ exit(0);
+ };
+ # Default
+ print($help);
+ }
+ }
+}
+
+
+###############################################################################
+
+$Inst = ExtUtils::Installed->new();
+@Modules = $Inst->modules();
+toplevel();
+
+###############################################################################
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/json_xs b/Master/tlpkg/tlperl/bin/json_xs new file mode 100755 index 00000000000..8509f64cf9e --- /dev/null +++ b/Master/tlpkg/tlperl/bin/json_xs @@ -0,0 +1,179 @@ +#!/opt/bin/perl + +=head1 NAME + +json_xs - JSON::XS commandline utility + +=head1 SYNOPSIS + + json_xs [-v] [-f inputformat] [-t outputformat] + +=head1 DESCRIPTION + +F<json_xs> converts between some input and output formats (one of them is +JSON). + +The default input format is C<json> and the default output format is +C<json-pretty>. + +=head1 OPTIONS + +=over 4 + +=item -v + +Be slightly more verbose. + +=item -f fromformat + +Read a file in the given format from STDIN. + +C<fromformat> can be one of: + +=over 4 + +=item json - a json text encoded, either utf-8, utf16-be/le, utf32-be/le + +=item storable - a Storable frozen value + +=item storable-file - a Storable file (Storable has two incompatible formats) + +=item clzf - Compress::LZF format (requires that module to be installed) + +=item yaml - YAML (avoid at all costs, requires the YAML module :) + +=back + +=item -t toformat + +Write the file in the given format to STDOUT. + +C<fromformat> can be one of: + +=over 4 + +=item json, json-utf-8 - json, utf-8 encoded + +=item json-pretty - as above, but pretty-printed + +=item json-utf-16le, json-utf-16be - little endian/big endian utf-16 + +=item json-utf-32le, json-utf-32be - little endian/big endian utf-32 + +=item storable - a Storable frozen value in network format + +=item storable-file - a Storable file in network format (Storable has two incompatible formats) + +=item clzf - Compress::LZF format + +=item yaml - YAML + +=back + +=back + +=head1 EXAMPLES + + json_xs -t null <isitreally.json + +"JSON Lint" - tries to parse the file F<isitreally.json> as JSON - if it +is valid JSON, the command outputs nothing, otherwise it will print an +error message and exit with non-zero exit status. + + <src.json json_xs >pretty.json + +Prettify the JSON file F<src.json> to F<dst.json>. + + json_xs -f storable-file <file + +Read the serialised Storable file F<file> and print a human-readable JSON +version of it to STDOUT. + + json_xs -f storable-file -t yaml <file + +Same as above, but write YAML instead (not using JSON at all :) + + lwp-request http://cpantesters.perl.org/show/JSON-XS.json | json_xs + +Fetch the cpan-testers result summary C<JSON::XS> and pretty-print it. + +=head1 AUTHOR + +Copyright (C) 2008 Marc Lehmann <json@schmorp.de> + +=cut + +use strict; + +use Getopt::Long; +use Storable (); +use Encode; + +use JSON::XS; + +my $opt_verbose; +my $opt_from = "json"; +my $opt_to = "json-pretty"; + +Getopt::Long::Configure ("bundling", "no_ignore_case", "require_order"); + +GetOptions( + "v" => \$opt_verbose, + "f=s" => \$opt_from, + "t=s" => \$opt_to, +) or die "Usage: $0 [-v] -f fromformat [-t toformat]\n"; + +my %F = ( + "json" => sub { + my $enc = + /^\x00\x00\x00/s ? "utf-32be" + : /^\x00.\x00/s ? "utf-16be" + : /^.\x00\x00\x00/s ? "utf-32le" + : /^.\x00.\x00/s ? "utf-16le" + : "utf-8"; + warn "input text encoding is $enc\n" if $opt_verbose; + JSON::XS->new->decode (decode $enc, $_) + }, + "storable" => sub { Storable::thaw $_ }, + "storable-file" => sub { open my $fh, "<", \$_; Storable::fd_retrieve $fh }, + "clzf" => sub { require Compress::LZF; Compress::LZF::sthaw ($_) }, + "yaml" => sub { require YAML; YAML::Load ($_) }, +); + +my %T = ( + "null" => sub { "" }, + "json" => sub { encode_json $_ }, + "json-utf-8" => sub { encode_json $_ }, + "json-pretty" => sub { JSON::XS->new->utf8->pretty->encode ($_) }, + "json-utf-16le" => sub { encode "utf-16le", JSON::XS->new->encode ($_) }, + "json-utf-16be" => sub { encode "utf-16be", JSON::XS->new->encode ($_) }, + "json-utf-32le" => sub { encode "utf-32le", JSON::XS->new->encode ($_) }, + "json-utf-32be" => sub { encode "utf-32be", JSON::XS->new->encode ($_) }, + + "storable" => sub { Storable::nfreeze $_ }, + "storable-file" => sub { open my $fh, ">", \my $buf; Storable::nstore_fd $_, $fh; $buf }, + + "clzf" => sub { require Compress::LZF; Compress::LZF::sfreeze_cr ($_) }, + "yaml" => sub { require YAML; YAML::Dump ($_) }, +); + +$F{$opt_from} + or die "$opt_from: not a valid fromformat\n"; + +$T{$opt_to} + or die "$opt_from: not a valid toformat\n"; + +{ + local $/; + binmode STDIN; # stupid perl sometimes thinks its funny + $_ = <STDIN>; +} + +$_ = $F{$opt_from}->(); +$_ = $T{$opt_to}->(); + +binmode STDOUT; +print $_; + + + diff --git a/Master/tlpkg/tlperl/bin/json_xs.bat b/Master/tlpkg/tlperl/bin/json_xs.bat new file mode 100755 index 00000000000..306e47e0650 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/json_xs.bat @@ -0,0 +1,195 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/opt/bin/perl
+#line 15
+
+=head1 NAME
+
+json_xs - JSON::XS commandline utility
+
+=head1 SYNOPSIS
+
+ json_xs [-v] [-f inputformat] [-t outputformat]
+
+=head1 DESCRIPTION
+
+F<json_xs> converts between some input and output formats (one of them is
+JSON).
+
+The default input format is C<json> and the default output format is
+C<json-pretty>.
+
+=head1 OPTIONS
+
+=over 4
+
+=item -v
+
+Be slightly more verbose.
+
+=item -f fromformat
+
+Read a file in the given format from STDIN.
+
+C<fromformat> can be one of:
+
+=over 4
+
+=item json - a json text encoded, either utf-8, utf16-be/le, utf32-be/le
+
+=item storable - a Storable frozen value
+
+=item storable-file - a Storable file (Storable has two incompatible formats)
+
+=item clzf - Compress::LZF format (requires that module to be installed)
+
+=item yaml - YAML (avoid at all costs, requires the YAML module :)
+
+=back
+
+=item -t toformat
+
+Write the file in the given format to STDOUT.
+
+C<fromformat> can be one of:
+
+=over 4
+
+=item json, json-utf-8 - json, utf-8 encoded
+
+=item json-pretty - as above, but pretty-printed
+
+=item json-utf-16le, json-utf-16be - little endian/big endian utf-16
+
+=item json-utf-32le, json-utf-32be - little endian/big endian utf-32
+
+=item storable - a Storable frozen value in network format
+
+=item storable-file - a Storable file in network format (Storable has two incompatible formats)
+
+=item clzf - Compress::LZF format
+
+=item yaml - YAML
+
+=back
+
+=back
+
+=head1 EXAMPLES
+
+ json_xs -t null <isitreally.json
+
+"JSON Lint" - tries to parse the file F<isitreally.json> as JSON - if it
+is valid JSON, the command outputs nothing, otherwise it will print an
+error message and exit with non-zero exit status.
+
+ <src.json json_xs >pretty.json
+
+Prettify the JSON file F<src.json> to F<dst.json>.
+
+ json_xs -f storable-file <file
+
+Read the serialised Storable file F<file> and print a human-readable JSON
+version of it to STDOUT.
+
+ json_xs -f storable-file -t yaml <file
+
+Same as above, but write YAML instead (not using JSON at all :)
+
+ lwp-request http://cpantesters.perl.org/show/JSON-XS.json | json_xs
+
+Fetch the cpan-testers result summary C<JSON::XS> and pretty-print it.
+
+=head1 AUTHOR
+
+Copyright (C) 2008 Marc Lehmann <json@schmorp.de>
+
+=cut
+
+use strict;
+
+use Getopt::Long;
+use Storable ();
+use Encode;
+
+use JSON::XS;
+
+my $opt_verbose;
+my $opt_from = "json";
+my $opt_to = "json-pretty";
+
+Getopt::Long::Configure ("bundling", "no_ignore_case", "require_order");
+
+GetOptions(
+ "v" => \$opt_verbose,
+ "f=s" => \$opt_from,
+ "t=s" => \$opt_to,
+) or die "Usage: $0 [-v] -f fromformat [-t toformat]\n";
+
+my %F = (
+ "json" => sub {
+ my $enc =
+ /^\x00\x00\x00/s ? "utf-32be"
+ : /^\x00.\x00/s ? "utf-16be"
+ : /^.\x00\x00\x00/s ? "utf-32le"
+ : /^.\x00.\x00/s ? "utf-16le"
+ : "utf-8";
+ warn "input text encoding is $enc\n" if $opt_verbose;
+ JSON::XS->new->decode (decode $enc, $_)
+ },
+ "storable" => sub { Storable::thaw $_ },
+ "storable-file" => sub { open my $fh, "<", \$_; Storable::fd_retrieve $fh },
+ "clzf" => sub { require Compress::LZF; Compress::LZF::sthaw ($_) },
+ "yaml" => sub { require YAML; YAML::Load ($_) },
+);
+
+my %T = (
+ "null" => sub { "" },
+ "json" => sub { encode_json $_ },
+ "json-utf-8" => sub { encode_json $_ },
+ "json-pretty" => sub { JSON::XS->new->utf8->pretty->encode ($_) },
+ "json-utf-16le" => sub { encode "utf-16le", JSON::XS->new->encode ($_) },
+ "json-utf-16be" => sub { encode "utf-16be", JSON::XS->new->encode ($_) },
+ "json-utf-32le" => sub { encode "utf-32le", JSON::XS->new->encode ($_) },
+ "json-utf-32be" => sub { encode "utf-32be", JSON::XS->new->encode ($_) },
+
+ "storable" => sub { Storable::nfreeze $_ },
+ "storable-file" => sub { open my $fh, ">", \my $buf; Storable::nstore_fd $_, $fh; $buf },
+
+ "clzf" => sub { require Compress::LZF; Compress::LZF::sfreeze_cr ($_) },
+ "yaml" => sub { require YAML; YAML::Dump ($_) },
+);
+
+$F{$opt_from}
+ or die "$opt_from: not a valid fromformat\n";
+
+$T{$opt_to}
+ or die "$opt_from: not a valid toformat\n";
+
+{
+ local $/;
+ binmode STDIN; # stupid perl sometimes thinks its funny
+ $_ = <STDIN>;
+}
+
+$_ = $F{$opt_from}->();
+$_ = $T{$opt_to}->();
+
+binmode STDOUT;
+print $_;
+
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/largeprimes b/Master/tlpkg/tlperl/bin/largeprimes new file mode 100755 index 00000000000..498bfbe9462 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/largeprimes @@ -0,0 +1,68 @@ +#!/usr/bin/perl -sI.. -I../lib/ -Ilib/ +## +## largeprimes -- generates large provable primes, uniformally distributed +## in random intervals, with maurer's recursive algorithm. +## +## Copyright (c) 1998, Vipul Ved Prakash. All rights reserved. +## This code is free software; you can redistribute it and/or modify +## it under the same terms as Perl itself. +## +## $Id$ + + +use Crypt::Primes; + +unless ( $bitsize ) { + print "$0 -bitsize=bits -num=number_of_primes -v=verbosity\n\n"; + exit 0; +} + +for ( $i=0; $i <= $num; $i++ ) { + my $prime = Crypt::Primes::maurer Size => $bitsize, + Verbosity => $v, + Generator => $generator; + my $g = 0; + if ( ref $prime eq 'HASH') { + $g = $prime->{Generator}; + $prime = $prime->{Prime}; + } + + if ($t) { print "$prime\n" } else { + print "\n" if $v; + print "random $bitsize bit prime: $prime"; + print ", $g" if $g; + print "\n"; + } +} + +=head1 NAME + +largeprimes -- generate large, random primes using Crypt::Primes. + +=head1 SYNOPSIS + + largeprimes -bitsize=128 -v + largeprimes -bitsize=512 -v=2 + largeprimes -bitsize=512 -v -num=10 + largeprimes -bitsize=1024 -generator -v + +=head1 DESCRIPTION + +largeprimes generates a provable prime of specified bitsize and prints it on +STDOUT. For more details see Crypt::Primes(3) manpage. + +=head1 SEE ALSO + +Crypt::Primes(3) + +=head1 AUTHOR + +Vipul Ved Prakash, mail@vipul.net + +=head1 LICENSE + +Artistic. + +=cut + + diff --git a/Master/tlpkg/tlperl/bin/largeprimes.bat b/Master/tlpkg/tlperl/bin/largeprimes.bat new file mode 100755 index 00000000000..81b48044af1 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/largeprimes.bat @@ -0,0 +1,84 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -sI.. -I../lib/ -Ilib/
+#line 15
+##
+## largeprimes -- generates large provable primes, uniformally distributed
+## in random intervals, with maurer's recursive algorithm.
+##
+## Copyright (c) 1998, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id$
+
+
+use Crypt::Primes;
+
+unless ( $bitsize ) {
+ print "$0 -bitsize=bits -num=number_of_primes -v=verbosity\n\n";
+ exit 0;
+}
+
+for ( $i=0; $i <= $num; $i++ ) {
+ my $prime = Crypt::Primes::maurer Size => $bitsize,
+ Verbosity => $v,
+ Generator => $generator;
+ my $g = 0;
+ if ( ref $prime eq 'HASH') {
+ $g = $prime->{Generator};
+ $prime = $prime->{Prime};
+ }
+
+ if ($t) { print "$prime\n" } else {
+ print "\n" if $v;
+ print "random $bitsize bit prime: $prime";
+ print ", $g" if $g;
+ print "\n";
+ }
+}
+
+=head1 NAME
+
+largeprimes -- generate large, random primes using Crypt::Primes.
+
+=head1 SYNOPSIS
+
+ largeprimes -bitsize=128 -v
+ largeprimes -bitsize=512 -v=2
+ largeprimes -bitsize=512 -v -num=10
+ largeprimes -bitsize=1024 -generator -v
+
+=head1 DESCRIPTION
+
+largeprimes generates a provable prime of specified bitsize and prints it on
+STDOUT. For more details see Crypt::Primes(3) manpage.
+
+=head1 SEE ALSO
+
+Crypt::Primes(3)
+
+=head1 AUTHOR
+
+Vipul Ved Prakash, mail@vipul.net
+
+=head1 LICENSE
+
+Artistic.
+
+=cut
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/libnetcfg.bat b/Master/tlpkg/tlperl/bin/libnetcfg.bat new file mode 100755 index 00000000000..aacd5fe7490 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/libnetcfg.bat @@ -0,0 +1,737 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+=head1 NAME
+
+libnetcfg - configure libnet
+
+=head1 DESCRIPTION
+
+The libnetcfg utility can be used to configure the libnet.
+Starting from perl 5.8 libnet is part of the standard Perl
+distribution, but the libnetcfg can be used for any libnet
+installation.
+
+=head1 USAGE
+
+Without arguments libnetcfg displays the current configuration.
+
+ $ libnetcfg
+ # old config ./libnet.cfg
+ daytime_hosts ntp1.none.such
+ ftp_int_passive 0
+ ftp_testhost ftp.funet.fi
+ inet_domain none.such
+ nntp_hosts nntp.none.such
+ ph_hosts
+ pop3_hosts pop.none.such
+ smtp_hosts smtp.none.such
+ snpp_hosts
+ test_exist 1
+ test_hosts 1
+ time_hosts ntp.none.such
+ # libnetcfg -h for help
+ $
+
+It tells where the old configuration file was found (if found).
+
+The C<-h> option will show a usage message.
+
+To change the configuration you will need to use either the C<-c> or
+the C<-d> options.
+
+The default name of the old configuration file is by default
+"libnet.cfg", unless otherwise specified using the -i option,
+C<-i oldfile>, and it is searched first from the current directory,
+and then from your module path.
+
+The default name of the new configuration file is "libnet.cfg", and by
+default it is written to the current directory, unless otherwise
+specified using the -o option, C<-o newfile>.
+
+=head1 SEE ALSO
+
+L<Net::Config>, L<Net::libnetFAQ>
+
+=head1 AUTHORS
+
+Graham Barr, the original Configure script of libnet.
+
+Jarkko Hietaniemi, conversion into libnetcfg for inclusion into Perl 5.8.
+
+=cut
+
+# $Id: Configure,v 1.8 1997/03/04 09:22:32 gbarr Exp $
+
+use strict;
+use IO::File;
+use Getopt::Std;
+use ExtUtils::MakeMaker qw(prompt);
+use File::Spec;
+
+use vars qw($opt_d $opt_c $opt_h $opt_o $opt_i);
+
+##
+##
+##
+
+my %cfg = ();
+my @cfg = ();
+
+my($libnet_cfg_in,$libnet_cfg_out,$msg,$ans,$def,$have_old);
+
+##
+##
+##
+
+sub valid_host
+{
+ my $h = shift;
+
+ defined($h) && (($cfg{'test_exist'} == 0) || gethostbyname($h));
+}
+
+##
+##
+##
+
+sub test_hostnames (\@)
+{
+ my $hlist = shift;
+ my @h = ();
+ my $host;
+ my $err = 0;
+
+ foreach $host (@$hlist)
+ {
+ if(valid_host($host))
+ {
+ push(@h, $host);
+ next;
+ }
+ warn "Bad hostname: '$host'\n";
+ $err++;
+ }
+ @$hlist = @h;
+ $err ? join(" ",@h) : undef;
+}
+
+##
+##
+##
+
+sub Prompt
+{
+ my($prompt,$def) = @_;
+
+ $def = "" unless defined $def;
+
+ chomp($prompt);
+
+ if($opt_d)
+ {
+ print $prompt,," [",$def,"]\n";
+ return $def;
+ }
+ prompt($prompt,$def);
+}
+
+##
+##
+##
+
+sub get_host_list
+{
+ my($prompt,$def) = @_;
+
+ $def = join(" ",@$def) if ref($def);
+
+ my @hosts;
+
+ do
+ {
+ my $ans = Prompt($prompt,$def);
+
+ $ans =~ s/(\A\s+|\s+\Z)//g;
+
+ @hosts = split(/\s+/, $ans);
+ }
+ while(@hosts && defined($def = test_hostnames(@hosts)));
+
+ \@hosts;
+}
+
+##
+##
+##
+
+sub get_hostname
+{
+ my($prompt,$def) = @_;
+
+ my $host;
+
+ while(1)
+ {
+ my $ans = Prompt($prompt,$def);
+ $host = ($ans =~ /(\S*)/)[0];
+ last
+ if(!length($host) || valid_host($host));
+
+ $def =""
+ if $def eq $host;
+
+ print <<"EDQ";
+
+*** ERROR:
+ Hostname `$host' does not seem to exist, please enter again
+ or a single space to clear any default
+
+EDQ
+ }
+
+ length $host
+ ? $host
+ : undef;
+}
+
+##
+##
+##
+
+sub get_bool ($$)
+{
+ my($prompt,$def) = @_;
+
+ chomp($prompt);
+
+ my $val = Prompt($prompt,$def ? "yes" : "no");
+
+ $val =~ /^y/i ? 1 : 0;
+}
+
+##
+##
+##
+
+sub get_netmask ($$)
+{
+ my($prompt,$def) = @_;
+
+ chomp($prompt);
+
+ my %list;
+ @list{@$def} = ();
+
+MASK:
+ while(1) {
+ my $bad = 0;
+ my $ans = Prompt($prompt) or last;
+
+ if($ans eq '*') {
+ %list = ();
+ next;
+ }
+
+ if($ans eq '=') {
+ print "\n",( %list ? join("\n", sort keys %list) : 'none'),"\n\n";
+ next;
+ }
+
+ unless ($ans =~ m{^\s*(?:(-?\s*)(\d+(?:\.\d+){0,3})/(\d+))}) {
+ warn "Bad netmask '$ans'\n";
+ next;
+ }
+
+ my($remove,$bits,@ip) = ($1,$3,split(/\./, $2),0,0,0);
+ if ( $ip[0] < 1 || $bits < 1 || $bits > 32) {
+ warn "Bad netmask '$ans'\n";
+ next MASK;
+ }
+ foreach my $byte (@ip) {
+ if ( $byte > 255 ) {
+ warn "Bad netmask '$ans'\n";
+ next MASK;
+ }
+ }
+
+ my $mask = sprintf("%d.%d.%d.%d/%d",@ip[0..3],$bits);
+
+ if ($remove) {
+ delete $list{$mask};
+ }
+ else {
+ $list{$mask} = 1;
+ }
+
+ }
+
+ [ keys %list ];
+}
+
+##
+##
+##
+
+sub default_hostname
+{
+ my $host;
+ my @host;
+
+ foreach $host (@_)
+ {
+ if(defined($host) && valid_host($host))
+ {
+ return $host
+ unless wantarray;
+ push(@host,$host);
+ }
+ }
+
+ return wantarray ? @host : undef;
+}
+
+##
+##
+##
+
+getopts('dcho:i:');
+
+$libnet_cfg_in = "libnet.cfg"
+ unless(defined($libnet_cfg_in = $opt_i));
+
+$libnet_cfg_out = "libnet.cfg"
+ unless(defined($libnet_cfg_out = $opt_o));
+
+my %oldcfg = ();
+
+$Net::Config::CONFIGURE = 1; # Suppress load of user overrides
+if( -f $libnet_cfg_in )
+ {
+ %oldcfg = ( %{ do $libnet_cfg_in } );
+ }
+elsif (eval { require Net::Config })
+ {
+ $have_old = 1;
+ %oldcfg = %Net::Config::NetConfig;
+ }
+
+map { $cfg{lc $_} = $cfg{$_}; delete $cfg{$_} if /[A-Z]/ } keys %cfg;
+
+#---------------------------------------------------------------------------
+
+if ($opt_h) {
+ print <<EOU;
+$0: Usage: $0 [-c] [-d] [-i oldconfigile] [-o newconfigfile] [-h]
+Without options, the old configuration is shown.
+
+ -c change the configuration
+ -d use defaults from the old config (implies -c, non-interactive)
+ -i use a specific file as the old config file
+ -o use a specific file as the new config file
+ -h show this help
+
+The default name of the old configuration file is by default
+"libnet.cfg", unless otherwise specified using the -i option,
+C<-i oldfile>, and it is searched first from the current directory,
+and then from your module path.
+
+The default name of the new configuration file is "libnet.cfg", and by
+default it is written to the current directory, unless otherwise
+specified using the -o option.
+
+EOU
+ exit(0);
+}
+
+#---------------------------------------------------------------------------
+
+{
+ my $oldcfgfile;
+ my @inc;
+ push @inc, $ENV{PERL5LIB} if exists $ENV{PERL5LIB};
+ push @inc, $ENV{PERLLIB} if exists $ENV{PERLLIB};
+ push @inc, @INC;
+ for (@inc) {
+ my $trycfgfile = File::Spec->catfile($_, $libnet_cfg_in);
+ if (-f $trycfgfile && -r $trycfgfile) {
+ $oldcfgfile = $trycfgfile;
+ last;
+ }
+ }
+ print "# old config $oldcfgfile\n" if defined $oldcfgfile;
+ for (sort keys %oldcfg) {
+ printf "%-20s %s\n", $_,
+ ref $oldcfg{$_} ? @{$oldcfg{$_}} : $oldcfg{$_};
+ }
+ unless ($opt_c || $opt_d) {
+ print "# $0 -h for help\n";
+ exit(0);
+ }
+}
+
+#---------------------------------------------------------------------------
+
+$oldcfg{'test_exist'} = 1 unless exists $oldcfg{'test_exist'};
+$oldcfg{'test_hosts'} = 1 unless exists $oldcfg{'test_hosts'};
+
+#---------------------------------------------------------------------------
+
+if($have_old && !$opt_d)
+ {
+ $msg = <<EDQ;
+
+Ah, I see you already have installed libnet before.
+
+Do you want to modify/update your configuration (y|n) ?
+EDQ
+
+ $opt_d = 1
+ unless get_bool($msg,0);
+ }
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+This script will prompt you to enter hostnames that can be used as
+defaults for some of the modules in the libnet distribution.
+
+To ensure that you do not enter an invalid hostname, I can perform a
+lookup on each hostname you enter. If your internet connection is via
+a dialup line then you may not want me to perform these lookups, as
+it will require you to be on-line.
+
+Do you want me to perform hostname lookups (y|n) ?
+EDQ
+
+$cfg{'test_exist'} = get_bool($msg, $oldcfg{'test_exist'});
+
+print <<EDQ unless $cfg{'test_exist'};
+
+*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+
+OK I will not check if the hostnames you give are valid
+so be very cafeful
+
+*** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
+EDQ
+
+
+#---------------------------------------------------------------------------
+
+print <<EDQ;
+
+The following questions all require a list of host names, separated
+with spaces. If you do not have a host available for any of the
+services, then enter a single space, followed by <CR>. To accept the
+default, hit <CR>
+
+EDQ
+
+$msg = 'Enter a list of available NNTP hosts :';
+
+$def = $oldcfg{'nntp_hosts'} ||
+ [ default_hostname($ENV{NNTPSERVER},$ENV{NEWSHOST},'news') ];
+
+$cfg{'nntp_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available SMTP hosts :';
+
+$def = $oldcfg{'smtp_hosts'} ||
+ [ default_hostname(split(/:/,$ENV{SMTPHOSTS} || ""), 'mailhost') ];
+
+$cfg{'smtp_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available POP3 hosts :';
+
+$def = $oldcfg{'pop3_hosts'} || [];
+
+$cfg{'pop3_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available SNPP hosts :';
+
+$def = $oldcfg{'snpp_hosts'} || [];
+
+$cfg{'snpp_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available PH Hosts :' ;
+
+$def = $oldcfg{'ph_hosts'} ||
+ [ default_hostname('dirserv') ];
+
+$cfg{'ph_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available TIME Hosts :' ;
+
+$def = $oldcfg{'time_hosts'} || [];
+
+$cfg{'time_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = 'Enter a list of available DAYTIME Hosts :' ;
+
+$def = $oldcfg{'daytime_hosts'} || $oldcfg{'time_hosts'};
+
+$cfg{'daytime_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+Do you have a firewall/ftp proxy between your machine and the internet
+
+If you use a SOCKS firewall answer no
+
+(y|n) ?
+EDQ
+
+if(get_bool($msg,0)) {
+
+ $msg = <<'EDQ';
+What series of FTP commands do you need to send to your
+firewall to connect to an external host.
+
+user/pass => external user & password
+fwuser/fwpass => firewall user & password
+
+0) None
+1) -----------------------
+ USER user@remote.host
+ PASS pass
+2) -----------------------
+ USER fwuser
+ PASS fwpass
+ USER user@remote.host
+ PASS pass
+3) -----------------------
+ USER fwuser
+ PASS fwpass
+ SITE remote.site
+ USER user
+ PASS pass
+4) -----------------------
+ USER fwuser
+ PASS fwpass
+ OPEN remote.site
+ USER user
+ PASS pass
+5) -----------------------
+ USER user@fwuser@remote.site
+ PASS pass@fwpass
+6) -----------------------
+ USER fwuser@remote.site
+ PASS fwpass
+ USER user
+ PASS pass
+7) -----------------------
+ USER user@remote.host
+ PASS pass
+ AUTH fwuser
+ RESP fwpass
+
+Choice:
+EDQ
+ $def = exists $oldcfg{'ftp_firewall_type'} ? $oldcfg{'ftp_firewall_type'} : 1;
+ $ans = Prompt($msg,$def);
+ $cfg{'ftp_firewall_type'} = 0+$ans;
+ $def = $oldcfg{'ftp_firewall'} || $ENV{FTP_FIREWALL};
+
+ $cfg{'ftp_firewall'} = get_hostname("FTP proxy hostname :", $def);
+}
+else {
+ delete $cfg{'ftp_firewall'};
+}
+
+
+#---------------------------------------------------------------------------
+
+if (defined $cfg{'ftp_firewall'})
+ {
+ print <<EDQ;
+
+By default Net::FTP assumes that it only needs to use a firewall if it
+cannot resolve the name of the host given. This only works if your DNS
+system is setup to only resolve internal hostnames. If this is not the
+case and your DNS will resolve external hostnames, then another method
+is needed. Net::Config can do this if you provide the netmasks that
+describe your internal network. Each netmask should be entered in the
+form x.x.x.x/y, for example 127.0.0.0/8 or 214.8.16.32/24
+
+EDQ
+$def = [];
+if(ref($oldcfg{'local_netmask'}))
+ {
+ $def = $oldcfg{'local_netmask'};
+ print "Your current netmasks are :\n\n\t",
+ join("\n\t",@{$def}),"\n\n";
+ }
+
+print "
+Enter one netmask at each prompt, prefix with a - to remove a netmask
+from the list, enter a '*' to clear the whole list, an '=' to show the
+current list and an empty line to continue with Configure.
+
+";
+
+ my $mask = get_netmask("netmask :",$def);
+ $cfg{'local_netmask'} = $mask if ref($mask) && @$mask;
+ }
+
+#---------------------------------------------------------------------------
+
+###$msg =<<EDQ;
+###
+###SOCKS is a commonly used firewall protocol. If you use SOCKS firewalls
+###then enter a list of hostames
+###
+###Enter a list of available SOCKS hosts :
+###EDQ
+###
+###$def = $cfg{'socks_hosts'} ||
+### [ default_hostname($ENV{SOCKS5_SERVER},
+### $ENV{SOCKS_SERVER},
+### $ENV{SOCKS4_SERVER}) ];
+###
+###$cfg{'socks_hosts'} = get_host_list($msg,$def);
+
+#---------------------------------------------------------------------------
+
+print <<EDQ;
+
+Normally when FTP needs a data connection the client tells the server
+a port to connect to, and the server initiates a connection to the client.
+
+Some setups, in particular firewall setups, can/do not work using this
+protocol. In these situations the client must make the connection to the
+server, this is called a passive transfer.
+EDQ
+
+if (defined $cfg{'ftp_firewall'}) {
+ $msg = "\nShould all FTP connections via a firewall/proxy be passive (y|n) ?";
+
+ $def = $oldcfg{'ftp_ext_passive'} || 0;
+
+ $cfg{'ftp_ext_passive'} = get_bool($msg,$def);
+
+ $msg = "\nShould all other FTP connections be passive (y|n) ?";
+
+}
+else {
+ $msg = "\nShould all FTP connections be passive (y|n) ?";
+}
+
+$def = $oldcfg{'ftp_int_passive'} || 0;
+
+$cfg{'ftp_int_passive'} = get_bool($msg,$def);
+
+
+#---------------------------------------------------------------------------
+
+$def = $oldcfg{'inet_domain'} || $ENV{LOCALDOMAIN};
+
+$ans = Prompt("\nWhat is your local internet domain name :",$def);
+
+$cfg{'inet_domain'} = ($ans =~ /(\S+)/)[0];
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+If you specified some default hosts above, it is possible for me to
+do some basic tests when you run `make test'
+
+This will cause `make test' to be quite a bit slower and, if your
+internet connection is via dialup, will require you to be on-line
+unless the hosts are local.
+
+Do you want me to run these tests (y|n) ?
+EDQ
+
+$cfg{'test_hosts'} = get_bool($msg,$oldcfg{'test_hosts'});
+
+#---------------------------------------------------------------------------
+
+$msg = <<EDQ;
+
+To allow Net::FTP to be tested I will need a hostname. This host
+should allow anonymous access and have a /pub directory
+
+What host can I use :
+EDQ
+
+$cfg{'ftp_testhost'} = get_hostname($msg,$oldcfg{'ftp_testhost'})
+ if $cfg{'test_hosts'};
+
+
+print "\n";
+
+#---------------------------------------------------------------------------
+
+my $fh = IO::File->new($libnet_cfg_out, "w") or
+ die "Cannot create `$libnet_cfg_out': $!";
+
+print "Writing $libnet_cfg_out\n";
+
+print $fh "{\n";
+
+my $key;
+foreach $key (keys %cfg) {
+ my $val = $cfg{$key};
+ if(!defined($val)) {
+ $val = "undef";
+ }
+ elsif(ref($val)) {
+ $val = '[' . join(",",
+ map {
+ my $v = "undef";
+ if(defined $_) {
+ ($v = $_) =~ s/'/\'/sog;
+ $v = "'" . $v . "'";
+ }
+ $v;
+ } @$val ) . ']';
+ }
+ else {
+ $val =~ s/'/\'/sog;
+ $val = "'" . $val . "'" if $val =~ /\D/;
+ }
+ print $fh "\t'",$key,"' => ",$val,",\n";
+}
+
+print $fh "}\n";
+
+$fh->close;
+
+############################################################################
+############################################################################
+
+exit 0;
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/libpng3.dll b/Master/tlpkg/tlperl/bin/libpng3.dll Binary files differnew file mode 100755 index 00000000000..649ec648979 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/libpng3.dll diff --git a/Master/tlpkg/tlperl/bin/lwp-download b/Master/tlpkg/tlperl/bin/lwp-download new file mode 100755 index 00000000000..a85ac551d9f --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-download @@ -0,0 +1,320 @@ +#!/usr/bin/perl -w + +=head1 NAME + +lwp-download - Fetch large files from the web + +=head1 SYNOPSIS + +B<lwp-download> [B<-a>] <I<url>> [<I<local path>>] + +=head1 DESCRIPTION + +The B<lwp-download> program will save the file at I<url> to a local +file. + +If I<local path> is not specified, then the current directory is +assumed. + +If I<local path> is a directory, then the basename of the file to save +is picked up from the Content-Disposition header or the URL of the +response. If the file already exists, then B<lwp-download> will +prompt before it overwrites and will fail if its standard input is not +a terminal. This form of invocation will also fail is no acceptable +filename can be derived from the sources mentioned above. + +If I<local path> is not a directory, then it is simply used as the +path to save into. + +The I<lwp-download> program is implemented using the I<libwww-perl> +library. It is better suited to down load big files than the +I<lwp-request> program because it does not store the file in memory. +Another benefit is that it will keep you updated about its progress +and that you don't have much options to worry about. + +Use the C<-a> option to save the file in text (ascii) mode. Might +make a difference on dosish systems. + +=head1 EXAMPLE + +Fetch the newest and greatest perl version: + + $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz + Saving to 'latest.tar.gz'... + 11.4 MB received in 8 seconds (1.43 MB/sec) + +=head1 AUTHOR + +Gisle Aas <gisle@aas.no> + +=cut + +#' get emacs out of quote mode + +use strict; + +use LWP::UserAgent (); +use LWP::MediaTypes qw(guess_media_type media_suffix); +use URI (); +use HTTP::Date (); + +my $progname = $0; +$progname =~ s,.*/,,; # only basename left in progname +$progname =~ s,.*\\,, if $^O eq "MSWin32"; +$progname =~ s/\.\w*$//; # strip extension if any + +#parse option +use Getopt::Std; +my %opt; +unless (getopts('a', \%opt)) { + usage(); +} + +my $url = URI->new(shift || usage()); +my $argfile = shift; +usage() if defined($argfile) && !length($argfile); +my $VERSION = "5.827"; + +my $ua = LWP::UserAgent->new( + agent => "lwp-download/$VERSION ", + keep_alive => 1, + env_proxy => 1, +); + +my $file; # name of file we download into +my $length; # total number of bytes to download +my $flength; # formatted length +my $size = 0; # number of bytes received +my $start_t; # start time of download +my $last_dur; # time of last callback + +my $shown = 0; # have we called the show() function yet + +$SIG{INT} = sub { die "Interrupted\n"; }; + +$| = 1; # autoflush + +my $res = $ua->request(HTTP::Request->new(GET => $url), + sub { + unless(defined $file) { + my $res = $_[1]; + + my $directory; + if (defined $argfile && -d $argfile) { + ($directory, $argfile) = ($argfile, undef); + } + + unless (defined $argfile) { + # find a suitable name to use + $file = $res->filename; + + # if this fails we try to make something from the URL + unless ($file) { + my $req = $res->request; # not always there + my $rurl = $req ? $req->uri : $url; + + $file = ($rurl->path_segments)[-1]; + if (!defined($file) || !length($file)) { + $file = "index"; + my $suffix = media_suffix($res->content_type); + $file .= ".$suffix" if $suffix; + } + elsif ($rurl->scheme eq 'ftp' || + $file =~ /\.t[bg]z$/ || + $file =~ /\.tar(\.(Z|gz|bz2?))?$/ + ) { + # leave the filename as it was + } + else { + my $ct = guess_media_type($file); + unless ($ct eq $res->content_type) { + # need a better suffix for this type + my $suffix = media_suffix($res->content_type); + $file .= ".$suffix" if $suffix; + } + } + } + + # validate that we don't have a harmful filename now. The server + # might try to trick us into doing something bad. + if (!length($file) || + $file =~ s/([^a-zA-Z0-9_\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge) + { + die "Will not save <$url> as \"$file\".\nPlease override file name on the command line.\n"; + } + + if (defined $directory) { + require File::Spec; + $file = File::Spec->catfile($directory, $file); + } + + # Check if the file is already present + if (-l $file) { + die "Will not save <$url> to link \"$file\".\nPlease override file name on the command line.\n"; + } + elsif (-f _) { + die "Will not save <$url> as \"$file\" without verification.\nEither run from terminal or override file name on the command line.\n" + unless -t; + $shown = 1; + print "Overwrite $file? [y] "; + my $ans = <STDIN>; + unless (defined($ans) && $ans =~ /^y?\n/) { + if (defined $ans) { + print "Ok, aborting.\n"; + } + else { + print "\nAborting.\n"; + } + exit 1; + } + $shown = 0; + } + elsif (-e _) { + die "Will not save <$url> as \"$file\". Path exists.\n"; + } + else { + print "Saving to '$file'...\n"; + } + } + else { + $file = $argfile; + } + open(FILE, ">$file") || die "Can't open $file: $!\n"; + binmode FILE unless $opt{a}; + $length = $res->content_length; + $flength = fbytes($length) if defined $length; + $start_t = time; + $last_dur = 0; + } + + print FILE $_[0] or die "Can't write to $file: $!\n"; + $size += length($_[0]); + + if (defined $length) { + my $dur = time - $start_t; + if ($dur != $last_dur) { # don't update too often + $last_dur = $dur; + my $perc = $size / $length; + my $speed; + $speed = fbytes($size/$dur) . "/sec" if $dur > 3; + my $secs_left = fduration($dur/$perc - $dur); + $perc = int($perc*100); + my $show = "$perc% of $flength"; + $show .= " (at $speed, $secs_left remaining)" if $speed; + show($show, 1); + } + } + else { + show( fbytes($size) . " received"); + } + } +); + +if (fileno(FILE)) { + close(FILE) || die "Can't write to $file: $!\n"; + + show(""); # clear text + print "\r"; + print fbytes($size); + print " of ", fbytes($length) if defined($length) && $length != $size; + print " received"; + my $dur = time - $start_t; + if ($dur) { + my $speed = fbytes($size/$dur) . "/sec"; + print " in ", fduration($dur), " ($speed)"; + } + print "\n"; + + if (my $mtime = $res->last_modified) { + utime time, $mtime, $file; + } + + if ($res->header("X-Died") || !$res->is_success) { + if (my $died = $res->header("X-Died")) { + print "$died\n"; + } + if (-t) { + print "Transfer aborted. Delete $file? [n] "; + my $ans = <STDIN>; + if (defined($ans) && $ans =~ /^y\n/) { + unlink($file) && print "Deleted.\n"; + } + elsif ($length > $size) { + print "Truncated file kept: ", fbytes($length - $size), " missing\n"; + } + else { + print "File kept.\n"; + } + exit 1; + } + else { + print "Transfer aborted, $file kept\n"; + } + } + exit 0; +} + +# Did not manage to create any file +print "\n" if $shown; +if (my $xdied = $res->header("X-Died")) { + print "$progname: Aborted\n$xdied\n"; +} +else { + print "$progname: ", $res->status_line, "\n"; +} +exit 1; + + +sub fbytes +{ + my $n = int(shift); + if ($n >= 1024 * 1024) { + return sprintf "%.3g MB", $n / (1024.0 * 1024); + } + elsif ($n >= 1024) { + return sprintf "%.3g KB", $n / 1024.0; + } + else { + return "$n bytes"; + } +} + +sub fduration +{ + use integer; + my $secs = int(shift); + my $hours = $secs / (60*60); + $secs -= $hours * 60*60; + my $mins = $secs / 60; + $secs %= 60; + if ($hours) { + return "$hours hours $mins minutes"; + } + elsif ($mins >= 2) { + return "$mins minutes"; + } + else { + $secs += $mins * 60; + return "$secs seconds"; + } +} + + +BEGIN { + my @ani = qw(- \ | /); + my $ani = 0; + + sub show + { + my($mess, $show_ani) = @_; + print "\r$mess" . (" " x (75 - length $mess)); + print $show_ani ? "$ani[$ani++]\b" : " "; + $ani %= @ani; + $shown++; + } +} + +sub usage +{ + die "Usage: $progname [-a] <url> [<lpath>]\n"; +} diff --git a/Master/tlpkg/tlperl/bin/lwp-download.bat b/Master/tlpkg/tlperl/bin/lwp-download.bat new file mode 100755 index 00000000000..ec045baf4e9 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-download.bat @@ -0,0 +1,336 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+=head1 NAME
+
+lwp-download - Fetch large files from the web
+
+=head1 SYNOPSIS
+
+B<lwp-download> [B<-a>] <I<url>> [<I<local path>>]
+
+=head1 DESCRIPTION
+
+The B<lwp-download> program will save the file at I<url> to a local
+file.
+
+If I<local path> is not specified, then the current directory is
+assumed.
+
+If I<local path> is a directory, then the basename of the file to save
+is picked up from the Content-Disposition header or the URL of the
+response. If the file already exists, then B<lwp-download> will
+prompt before it overwrites and will fail if its standard input is not
+a terminal. This form of invocation will also fail is no acceptable
+filename can be derived from the sources mentioned above.
+
+If I<local path> is not a directory, then it is simply used as the
+path to save into.
+
+The I<lwp-download> program is implemented using the I<libwww-perl>
+library. It is better suited to down load big files than the
+I<lwp-request> program because it does not store the file in memory.
+Another benefit is that it will keep you updated about its progress
+and that you don't have much options to worry about.
+
+Use the C<-a> option to save the file in text (ascii) mode. Might
+make a difference on dosish systems.
+
+=head1 EXAMPLE
+
+Fetch the newest and greatest perl version:
+
+ $ lwp-download http://www.perl.com/CPAN/src/latest.tar.gz
+ Saving to 'latest.tar.gz'...
+ 11.4 MB received in 8 seconds (1.43 MB/sec)
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
+
+#' get emacs out of quote mode
+
+use strict;
+
+use LWP::UserAgent ();
+use LWP::MediaTypes qw(guess_media_type media_suffix);
+use URI ();
+use HTTP::Date ();
+
+my $progname = $0;
+$progname =~ s,.*/,,; # only basename left in progname
+$progname =~ s,.*\\,, if $^O eq "MSWin32";
+$progname =~ s/\.\w*$//; # strip extension if any
+
+#parse option
+use Getopt::Std;
+my %opt;
+unless (getopts('a', \%opt)) {
+ usage();
+}
+
+my $url = URI->new(shift || usage());
+my $argfile = shift;
+usage() if defined($argfile) && !length($argfile);
+my $VERSION = "5.827";
+
+my $ua = LWP::UserAgent->new(
+ agent => "lwp-download/$VERSION ",
+ keep_alive => 1,
+ env_proxy => 1,
+);
+
+my $file; # name of file we download into
+my $length; # total number of bytes to download
+my $flength; # formatted length
+my $size = 0; # number of bytes received
+my $start_t; # start time of download
+my $last_dur; # time of last callback
+
+my $shown = 0; # have we called the show() function yet
+
+$SIG{INT} = sub { die "Interrupted\n"; };
+
+$| = 1; # autoflush
+
+my $res = $ua->request(HTTP::Request->new(GET => $url),
+ sub {
+ unless(defined $file) {
+ my $res = $_[1];
+
+ my $directory;
+ if (defined $argfile && -d $argfile) {
+ ($directory, $argfile) = ($argfile, undef);
+ }
+
+ unless (defined $argfile) {
+ # find a suitable name to use
+ $file = $res->filename;
+
+ # if this fails we try to make something from the URL
+ unless ($file) {
+ my $req = $res->request; # not always there
+ my $rurl = $req ? $req->uri : $url;
+
+ $file = ($rurl->path_segments)[-1];
+ if (!defined($file) || !length($file)) {
+ $file = "index";
+ my $suffix = media_suffix($res->content_type);
+ $file .= ".$suffix" if $suffix;
+ }
+ elsif ($rurl->scheme eq 'ftp' ||
+ $file =~ /\.t[bg]z$/ ||
+ $file =~ /\.tar(\.(Z|gz|bz2?))?$/
+ ) {
+ # leave the filename as it was
+ }
+ else {
+ my $ct = guess_media_type($file);
+ unless ($ct eq $res->content_type) {
+ # need a better suffix for this type
+ my $suffix = media_suffix($res->content_type);
+ $file .= ".$suffix" if $suffix;
+ }
+ }
+ }
+
+ # validate that we don't have a harmful filename now. The server
+ # might try to trick us into doing something bad.
+ if (!length($file) ||
+ $file =~ s/([^a-zA-Z0-9_\.\-\+\~])/sprintf "\\x%02x", ord($1)/ge)
+ {
+ die "Will not save <$url> as \"$file\".\nPlease override file name on the command line.\n";
+ }
+
+ if (defined $directory) {
+ require File::Spec;
+ $file = File::Spec->catfile($directory, $file);
+ }
+
+ # Check if the file is already present
+ if (-l $file) {
+ die "Will not save <$url> to link \"$file\".\nPlease override file name on the command line.\n";
+ }
+ elsif (-f _) {
+ die "Will not save <$url> as \"$file\" without verification.\nEither run from terminal or override file name on the command line.\n"
+ unless -t;
+ $shown = 1;
+ print "Overwrite $file? [y] ";
+ my $ans = <STDIN>;
+ unless (defined($ans) && $ans =~ /^y?\n/) {
+ if (defined $ans) {
+ print "Ok, aborting.\n";
+ }
+ else {
+ print "\nAborting.\n";
+ }
+ exit 1;
+ }
+ $shown = 0;
+ }
+ elsif (-e _) {
+ die "Will not save <$url> as \"$file\". Path exists.\n";
+ }
+ else {
+ print "Saving to '$file'...\n";
+ }
+ }
+ else {
+ $file = $argfile;
+ }
+ open(FILE, ">$file") || die "Can't open $file: $!\n";
+ binmode FILE unless $opt{a};
+ $length = $res->content_length;
+ $flength = fbytes($length) if defined $length;
+ $start_t = time;
+ $last_dur = 0;
+ }
+
+ print FILE $_[0] or die "Can't write to $file: $!\n";
+ $size += length($_[0]);
+
+ if (defined $length) {
+ my $dur = time - $start_t;
+ if ($dur != $last_dur) { # don't update too often
+ $last_dur = $dur;
+ my $perc = $size / $length;
+ my $speed;
+ $speed = fbytes($size/$dur) . "/sec" if $dur > 3;
+ my $secs_left = fduration($dur/$perc - $dur);
+ $perc = int($perc*100);
+ my $show = "$perc% of $flength";
+ $show .= " (at $speed, $secs_left remaining)" if $speed;
+ show($show, 1);
+ }
+ }
+ else {
+ show( fbytes($size) . " received");
+ }
+ }
+);
+
+if (fileno(FILE)) {
+ close(FILE) || die "Can't write to $file: $!\n";
+
+ show(""); # clear text
+ print "\r";
+ print fbytes($size);
+ print " of ", fbytes($length) if defined($length) && $length != $size;
+ print " received";
+ my $dur = time - $start_t;
+ if ($dur) {
+ my $speed = fbytes($size/$dur) . "/sec";
+ print " in ", fduration($dur), " ($speed)";
+ }
+ print "\n";
+
+ if (my $mtime = $res->last_modified) {
+ utime time, $mtime, $file;
+ }
+
+ if ($res->header("X-Died") || !$res->is_success) {
+ if (my $died = $res->header("X-Died")) {
+ print "$died\n";
+ }
+ if (-t) {
+ print "Transfer aborted. Delete $file? [n] ";
+ my $ans = <STDIN>;
+ if (defined($ans) && $ans =~ /^y\n/) {
+ unlink($file) && print "Deleted.\n";
+ }
+ elsif ($length > $size) {
+ print "Truncated file kept: ", fbytes($length - $size), " missing\n";
+ }
+ else {
+ print "File kept.\n";
+ }
+ exit 1;
+ }
+ else {
+ print "Transfer aborted, $file kept\n";
+ }
+ }
+ exit 0;
+}
+
+# Did not manage to create any file
+print "\n" if $shown;
+if (my $xdied = $res->header("X-Died")) {
+ print "$progname: Aborted\n$xdied\n";
+}
+else {
+ print "$progname: ", $res->status_line, "\n";
+}
+exit 1;
+
+
+sub fbytes
+{
+ my $n = int(shift);
+ if ($n >= 1024 * 1024) {
+ return sprintf "%.3g MB", $n / (1024.0 * 1024);
+ }
+ elsif ($n >= 1024) {
+ return sprintf "%.3g KB", $n / 1024.0;
+ }
+ else {
+ return "$n bytes";
+ }
+}
+
+sub fduration
+{
+ use integer;
+ my $secs = int(shift);
+ my $hours = $secs / (60*60);
+ $secs -= $hours * 60*60;
+ my $mins = $secs / 60;
+ $secs %= 60;
+ if ($hours) {
+ return "$hours hours $mins minutes";
+ }
+ elsif ($mins >= 2) {
+ return "$mins minutes";
+ }
+ else {
+ $secs += $mins * 60;
+ return "$secs seconds";
+ }
+}
+
+
+BEGIN {
+ my @ani = qw(- \ | /);
+ my $ani = 0;
+
+ sub show
+ {
+ my($mess, $show_ani) = @_;
+ print "\r$mess" . (" " x (75 - length $mess));
+ print $show_ani ? "$ani[$ani++]\b" : " ";
+ $ani %= @ani;
+ $shown++;
+ }
+}
+
+sub usage
+{
+ die "Usage: $progname [-a] <url> [<lpath>]\n";
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/lwp-dump b/Master/tlpkg/tlperl/bin/lwp-dump new file mode 100755 index 00000000000..1805eb56138 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-dump @@ -0,0 +1,107 @@ +#!/usr/bin/perl -w + +use strict; +use LWP::UserAgent (); +use Getopt::Long qw(GetOptions); + +my $VERSION = "5.827"; + +GetOptions(\my %opt, + 'parse-head', + 'max-length=n', + 'keep-client-headers', + 'method=s', + 'agent=s', +) || usage(); + +my $url = shift || usage(); +@ARGV && usage(); + +sub usage { + (my $progname = $0) =~ s,.*/,,; + die <<"EOT"; +Usage: $progname [options] <url> + +Recognized options are: + --agent <str> + --keep-client-headers + --max-length <n> + --method <str> + --parse-head + +EOT +} + +my $ua = LWP::UserAgent->new( + parse_head => $opt{'parse-head'} || 0, + keep_alive => 1, + env_proxy => 1, + agent => $opt{agent} || "lwp-dump/$VERSION ", +); + +my $req = HTTP::Request->new($opt{method} || 'GET' => $url); +my $res = $ua->simple_request($req); +$res->remove_header(grep /^Client-/, $res->header_field_names) + unless $opt{'keep-client-headers'} or + ($res->header("Client-Warning") || "") eq "Internal response"; + +$res->dump(maxlength => $opt{'max-length'}); + +__END__ + +=head1 NAME + +lwp-dump - See what headers and content is returned for a URL + +=head1 SYNOPSIS + +B<lwp-dump> [ I<options> ] I<URL> + +=head1 DESCRIPTION + +The B<lwp-dump> program will get the resource indentified by the URL and then +dump the response object to STDOUT. This will display the headers returned and +the initial part of the content, escaped so that it's safe to display even +binary content. The escapes syntax used is the same as for Perl's double +quoted strings. If there is no content the string "(no content)" is shown in +its place. + +The following options are recognized: + +=over + +=item B<--agent> I<str> + +Override the user agent string passed to the server. + +=item B<--keep-client-headers> + +LWP internally generate various C<Client-*> headers that are stripped by +B<lwp-dump> in order to show the headers exactly as the server provided them. +This option will suppress this. + +=item B<--max-length> I<n> + +How much of the content to show. The default is 512. Set this +to 0 for unlimited. + +If the content is longer then the string is chopped at the +limit and the string "...\n(### more bytes not shown)" +appended. + +=item B<--method> I<str> + +Use the given method for the request instead of the default "GET". + +=item B<--parse-head> + +By default B<lwp-dump> will not try to initialize headers by looking at the +head section of HTML documents. This option enables this. This corresponds to +L<LWP::UserAgent/"parse_head">. + +=back + +=head1 SEE ALSO + +L<lwp-request>, L<LWP>, L<HTTP::Message/"dump"> + diff --git a/Master/tlpkg/tlperl/bin/lwp-dump.bat b/Master/tlpkg/tlperl/bin/lwp-dump.bat new file mode 100755 index 00000000000..fcd6ac64baf --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-dump.bat @@ -0,0 +1,123 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+use strict;
+use LWP::UserAgent ();
+use Getopt::Long qw(GetOptions);
+
+my $VERSION = "5.827";
+
+GetOptions(\my %opt,
+ 'parse-head',
+ 'max-length=n',
+ 'keep-client-headers',
+ 'method=s',
+ 'agent=s',
+) || usage();
+
+my $url = shift || usage();
+@ARGV && usage();
+
+sub usage {
+ (my $progname = $0) =~ s,.*/,,;
+ die <<"EOT";
+Usage: $progname [options] <url>
+
+Recognized options are:
+ --agent <str>
+ --keep-client-headers
+ --max-length <n>
+ --method <str>
+ --parse-head
+
+EOT
+}
+
+my $ua = LWP::UserAgent->new(
+ parse_head => $opt{'parse-head'} || 0,
+ keep_alive => 1,
+ env_proxy => 1,
+ agent => $opt{agent} || "lwp-dump/$VERSION ",
+);
+
+my $req = HTTP::Request->new($opt{method} || 'GET' => $url);
+my $res = $ua->simple_request($req);
+$res->remove_header(grep /^Client-/, $res->header_field_names)
+ unless $opt{'keep-client-headers'} or
+ ($res->header("Client-Warning") || "") eq "Internal response";
+
+$res->dump(maxlength => $opt{'max-length'});
+
+__END__
+
+=head1 NAME
+
+lwp-dump - See what headers and content is returned for a URL
+
+=head1 SYNOPSIS
+
+B<lwp-dump> [ I<options> ] I<URL>
+
+=head1 DESCRIPTION
+
+The B<lwp-dump> program will get the resource indentified by the URL and then
+dump the response object to STDOUT. This will display the headers returned and
+the initial part of the content, escaped so that it's safe to display even
+binary content. The escapes syntax used is the same as for Perl's double
+quoted strings. If there is no content the string "(no content)" is shown in
+its place.
+
+The following options are recognized:
+
+=over
+
+=item B<--agent> I<str>
+
+Override the user agent string passed to the server.
+
+=item B<--keep-client-headers>
+
+LWP internally generate various C<Client-*> headers that are stripped by
+B<lwp-dump> in order to show the headers exactly as the server provided them.
+This option will suppress this.
+
+=item B<--max-length> I<n>
+
+How much of the content to show. The default is 512. Set this
+to 0 for unlimited.
+
+If the content is longer then the string is chopped at the
+limit and the string "...\n(### more bytes not shown)"
+appended.
+
+=item B<--method> I<str>
+
+Use the given method for the request instead of the default "GET".
+
+=item B<--parse-head>
+
+By default B<lwp-dump> will not try to initialize headers by looking at the
+head section of HTML documents. This option enables this. This corresponds to
+L<LWP::UserAgent/"parse_head">.
+
+=back
+
+=head1 SEE ALSO
+
+L<lwp-request>, L<LWP>, L<HTTP::Message/"dump">
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/lwp-mirror b/Master/tlpkg/tlperl/bin/lwp-mirror new file mode 100755 index 00000000000..13da7971242 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-mirror @@ -0,0 +1,103 @@ +#!/usr/bin/perl -w + +# Simple mirror utility using LWP + +=head1 NAME + +lwp-mirror - Simple mirror utility + +=head1 SYNOPSIS + + lwp-mirror [-v] [-t timeout] <url> <local file> + +=head1 DESCRIPTION + +This program can be used to mirror a document from a WWW server. The +document is only transfered if the remote copy is newer than the local +copy. If the local copy is newer nothing happens. + +Use the C<-v> option to print the version number of this program. + +The timeout value specified with the C<-t> option. The timeout value +is the time that the program will wait for response from the remote +server before it fails. The default unit for the timeout value is +seconds. You might append "m" or "h" to the timeout value to make it +minutes or hours, respectively. + +Because this program is implemented using the LWP library, it only +supports the protocols that LWP supports. + +=head1 SEE ALSO + +L<lwp-request>, L<LWP> + +=head1 AUTHOR + +Gisle Aas <gisle@aas.no> + +=cut + + +use LWP::Simple qw(mirror is_success status_message $ua); +use Getopt::Std; + +$progname = $0; +$progname =~ s,.*/,,; # use basename only +$progname =~ s/\.\w*$//; #strip extension if any + +$VERSION = "5.810"; + +$opt_h = undef; # print usage +$opt_v = undef; # print version +$opt_t = undef; # timeout + +unless (getopts("hvt:")) { + usage(); +} + +if ($opt_v) { + require LWP; + my $DISTNAME = 'libwww-perl-' . LWP::Version(); + die <<"EOT"; +This is lwp-mirror version $VERSION ($DISTNAME) + +Copyright 1995-1999, Gisle Aas. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. +EOT +} + +$url = shift or usage(); +$file = shift or usage(); +usage() if $opt_h or @ARGV; + +if (defined $opt_t) { + $opt_t =~ /^(\d+)([smh])?/; + die "$progname: Illegal timeout value!\n" unless defined $1; + $timeout = $1; + $timeout *= 60 if ($2 eq "m"); + $timeout *= 3600 if ($2 eq "h"); + $ua->timeout($timeout); +} + +$rc = mirror($url, $file); + +if ($rc == 304) { + print STDERR "$progname: $file is up to date\n" +} +elsif (!is_success($rc)) { + print STDERR "$progname: $rc ", status_message($rc), " ($url)\n"; + exit 1; +} +exit; + + +sub usage +{ + die <<"EOT"; +Usage: $progname [-options] <url> <file> + -v print version number of program + -t <timeout> Set timeout value +EOT +} diff --git a/Master/tlpkg/tlperl/bin/lwp-mirror.bat b/Master/tlpkg/tlperl/bin/lwp-mirror.bat new file mode 100755 index 00000000000..87beb3aa103 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-mirror.bat @@ -0,0 +1,119 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+# Simple mirror utility using LWP
+
+=head1 NAME
+
+lwp-mirror - Simple mirror utility
+
+=head1 SYNOPSIS
+
+ lwp-mirror [-v] [-t timeout] <url> <local file>
+
+=head1 DESCRIPTION
+
+This program can be used to mirror a document from a WWW server. The
+document is only transfered if the remote copy is newer than the local
+copy. If the local copy is newer nothing happens.
+
+Use the C<-v> option to print the version number of this program.
+
+The timeout value specified with the C<-t> option. The timeout value
+is the time that the program will wait for response from the remote
+server before it fails. The default unit for the timeout value is
+seconds. You might append "m" or "h" to the timeout value to make it
+minutes or hours, respectively.
+
+Because this program is implemented using the LWP library, it only
+supports the protocols that LWP supports.
+
+=head1 SEE ALSO
+
+L<lwp-request>, L<LWP>
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
+
+
+use LWP::Simple qw(mirror is_success status_message $ua);
+use Getopt::Std;
+
+$progname = $0;
+$progname =~ s,.*/,,; # use basename only
+$progname =~ s/\.\w*$//; #strip extension if any
+
+$VERSION = "5.810";
+
+$opt_h = undef; # print usage
+$opt_v = undef; # print version
+$opt_t = undef; # timeout
+
+unless (getopts("hvt:")) {
+ usage();
+}
+
+if ($opt_v) {
+ require LWP;
+ my $DISTNAME = 'libwww-perl-' . LWP::Version();
+ die <<"EOT";
+This is lwp-mirror version $VERSION ($DISTNAME)
+
+Copyright 1995-1999, Gisle Aas.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+EOT
+}
+
+$url = shift or usage();
+$file = shift or usage();
+usage() if $opt_h or @ARGV;
+
+if (defined $opt_t) {
+ $opt_t =~ /^(\d+)([smh])?/;
+ die "$progname: Illegal timeout value!\n" unless defined $1;
+ $timeout = $1;
+ $timeout *= 60 if ($2 eq "m");
+ $timeout *= 3600 if ($2 eq "h");
+ $ua->timeout($timeout);
+}
+
+$rc = mirror($url, $file);
+
+if ($rc == 304) {
+ print STDERR "$progname: $file is up to date\n"
+}
+elsif (!is_success($rc)) {
+ print STDERR "$progname: $rc ", status_message($rc), " ($url)\n";
+ exit 1;
+}
+exit;
+
+
+sub usage
+{
+ die <<"EOT";
+Usage: $progname [-options] <url> <file>
+ -v print version number of program
+ -t <timeout> Set timeout value
+EOT
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/lwp-request b/Master/tlpkg/tlperl/bin/lwp-request new file mode 100755 index 00000000000..ee9dbf88ea7 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-request @@ -0,0 +1,531 @@ +#!/usr/bin/perl -w + +# Simple user agent using LWP library. + +=head1 NAME + +lwp-request, GET, POST, HEAD - Simple command line user agent + +=head1 SYNOPSIS + +B<lwp-request> [B<-afPuUsSedvhx>] [B<-m> I<method>] [B<-b> I<base URL>] [B<-t> I<timeout>] + [B<-i> I<if-modified-since>] [B<-c> I<content-type>] + [B<-C> I<credentials>] [B<-p> I<proxy-url>] [B<-o> I<format>] I<url>... + +=head1 DESCRIPTION + +This program can be used to send requests to WWW servers and your +local file system. The request content for POST and PUT +methods is read from stdin. The content of the response is printed on +stdout. Error messages are printed on stderr. The program returns a +status value indicating the number of URLs that failed. + +The options are: + +=over 4 + +=item -m <method> + +Set which method to use for the request. If this option is not used, +then the method is derived from the name of the program. + +=item -f + +Force request through, even if the program believes that the method is +illegal. The server might reject the request eventually. + +=item -b <uri> + +This URI will be used as the base URI for resolving all relative URIs +given as argument. + +=item -t <timeout> + +Set the timeout value for the requests. The timeout is the amount of +time that the program will wait for a response from the remote server +before it fails. The default unit for the timeout value is seconds. +You might append "m" or "h" to the timeout value to make it minutes or +hours, respectively. The default timeout is '3m', i.e. 3 minutes. + +=item -i <time> + +Set the If-Modified-Since header in the request. If I<time> is the +name of a file, use the modification timestamp for this file. If +I<time> is not a file, it is parsed as a literal date. Take a look at +L<HTTP::Date> for recognized formats. + +=item -c <content-type> + +Set the Content-Type for the request. This option is only allowed for +requests that take a content, i.e. POST and PUT. You can +force methods to take content by using the C<-f> option together with +C<-c>. The default Content-Type for POST is +C<application/x-www-form-urlencoded>. The default Content-type for +the others is C<text/plain>. + +=item -p <proxy-url> + +Set the proxy to be used for the requests. The program also loads +proxy settings from the environment. You can disable this with the +C<-P> option. + +=item -P + +Don't load proxy settings from environment. + +=item -H <header> + +Send this HTTP header with each request. You can specify several, e.g.: + + lwp-request \ + -H 'Referer: http://other.url/' \ + -H 'Host: somehost' \ + http://this.url/ + +=item -C <username>:<password> + +Provide credentials for documents that are protected by Basic +Authentication. If the document is protected and you did not specify +the username and password with this option, then you will be prompted +to provide these values. + +=back + +The following options controls what is displayed by the program: + +=over 4 + +=item -u + +Print request method and absolute URL as requests are made. + +=item -U + +Print request headers in addition to request method and absolute URL. + +=item -s + +Print response status code. This option is always on for HEAD requests. + +=item -S + +Print response status chain. This shows redirect and authorization +requests that are handled by the library. + +=item -e + +Print response headers. This option is always on for HEAD requests. + +=item -d + +Do B<not> print the content of the response. + +=item -o <format> + +Process HTML content in various ways before printing it. If the +content type of the response is not HTML, then this option has no +effect. The legal format values are; I<text>, I<ps>, I<links>, +I<html> and I<dump>. + +If you specify the I<text> format then the HTML will be formatted as +plain latin1 text. If you specify the I<ps> format then it will be +formatted as Postscript. + +The I<links> format will output all links found in the HTML document. +Relative links will be expanded to absolute ones. + +The I<html> format will reformat the HTML code and the I<dump> format +will just dump the HTML syntax tree. + +Note that the C<HTML-Tree> distribution needs to be installed for this +option to work. In addition the C<HTML-Format> distribution needs to +be installed for I<-o text> or I<-o ps> to work. + +=item -v + +Print the version number of the program and quit. + +=item -h + +Print usage message and quit. + +=item -a + +Set text(ascii) mode for content input and output. If this option is not +used, content input and output is done in binary mode. + +=back + +Because this program is implemented using the LWP library, it will +only support the protocols that LWP supports. + +=head1 SEE ALSO + +L<lwp-mirror>, L<LWP> + +=head1 COPYRIGHT + +Copyright 1995-1999 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 AUTHOR + +Gisle Aas <gisle@aas.no> + +=cut + +$progname = $0; +$progname =~ s,.*[\\/],,; # use basename only +$progname =~ s/\.\w*$//; # strip extension, if any + +$VERSION = "5.834"; + + +require LWP; + +use URI; +use URI::Heuristic qw(uf_uri); + +use HTTP::Status qw(status_message); +use HTTP::Date qw(time2str str2time); + + +# This table lists the methods that are allowed. It should really be +# a superset for all methods supported for every scheme that may be +# supported by the library. Currently it might be a bit too HTTP +# specific. You might use the -f option to force a method through. +# +# "" = No content in request, "C" = Needs content in request +# +%allowed_methods = ( + GET => "", + HEAD => "", + POST => "C", + PUT => "C", + DELETE => "", + TRACE => "", + OPTIONS => "", +); + + +# We make our own specialization of LWP::UserAgent that asks for +# user/password if document is protected. +{ + package RequestAgent; + @ISA = qw(LWP::UserAgent); + + sub new + { + my $self = LWP::UserAgent::new(@_); + $self->agent("lwp-request/$main::VERSION "); + $self; + } + + sub get_basic_credentials + { + my($self, $realm, $uri) = @_; + if ($main::options{'C'}) { + return split(':', $main::options{'C'}, 2); + } + elsif (-t) { + my $netloc = $uri->host_port; + print STDERR "Enter username for $realm at $netloc: "; + my $user = <STDIN>; + chomp($user); + return (undef, undef) unless length $user; + print STDERR "Password: "; + system("stty -echo"); + my $password = <STDIN>; + system("stty echo"); + print STDERR "\n"; # because we disabled echo + chomp($password); + return ($user, $password); + } + else { + return (undef, undef) + } + } +} + +$method = uc(lc($progname) eq "lwp-request" ? "GET" : $progname); + +# Parse command line +use Getopt::Long; + +my @getopt_args = ( + 'a', # content i/o in text(ascii) mode + 'm=s', # set method + 'f', # make request even if method is not in %allowed_methods + 'b=s', # base url + 't=s', # timeout + 'i=s', # if-modified-since + 'c=s', # content type for POST + 'C=s', # credentials for basic authorization + 'H=s@', # extra headers, form "Header: value string" + # + 'u', # display method, URL and headers of request + 'U', # display request headers also + 's', # display status code + 'S', # display whole chain of status codes + 'e', # display response headers (default for HEAD) + 'd', # don't display content + # + 'h', # print usage + 'v', # print version + # + 'p=s', # proxy URL + 'P', # don't load proxy setting from environment + # + 'o=s', # output format +); + +Getopt::Long::config("noignorecase", "bundling"); +unless (GetOptions(\%options, @getopt_args)) { + usage(); +} +if ($options{'v'}) { + require LWP; + my $DISTNAME = 'libwww-perl-' . LWP::Version(); + die <<"EOT"; +This is lwp-request version $VERSION ($DISTNAME) + +Copyright 1995-1999, Gisle Aas. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. +EOT +} + +usage() if $options{'h'} || !@ARGV; + +# Create the user agent object +$ua = RequestAgent->new; + +# Load proxy settings from *_proxy environment variables. +$ua->env_proxy unless $options{'P'}; + +$method = uc($options{'m'}) if defined $options{'m'}; + +if ($options{'f'}) { + if ($options{'c'}) { + $allowed_methods{$method} = "C"; # force content + } + else { + $allowed_methods{$method} = ""; + } +} +elsif (!defined $allowed_methods{$method}) { + die "$progname: $method is not an allowed method\n"; +} + +if ($method eq "HEAD") { + $options{'s'} = 1; + $options{'e'} = 1 unless $options{'d'}; + $options{'d'} = 1; +} + +if (defined $options{'t'}) { + $options{'t'} =~ /^(\d+)([smh])?/; + die "$progname: Illegal timeout value!\n" unless defined $1; + $timeout = $1; + if (defined $2) { + $timeout *= 60 if $2 eq "m"; + $timeout *= 3600 if $2 eq "h"; + } + $ua->timeout($timeout); +} + +if (defined $options{'i'}) { + if (-e $options{'i'}) { + $time = (stat _)[9]; + } + else { + $time = str2time($options{'i'}); + die "$progname: Illegal time syntax for -i option\n" + unless defined $time; + } + $options{'i'} = time2str($time); +} + +$content = undef; +if ($allowed_methods{$method} eq "C") { + # This request needs some content + unless (defined $options{'c'}) { + # set default content type + $options{'c'} = ($method eq "POST") ? + "application/x-www-form-urlencoded" + : "text/plain"; + } + else { + die "$progname: Illegal Content-type format\n" + unless $options{'c'} =~ m,^[\w\-]+/[\w\-.+]+(?:\s*;.*)?$, + } + print STDERR "Please enter content ($options{'c'}) to be ${method}ed:\n" + if -t; + binmode STDIN unless -t or $options{'a'}; + $content = join("", <STDIN>); +} +else { + die "$progname: Can't set Content-type for $method requests\n" + if defined $options{'c'}; +} + +# Set up a request. We will use the same request object for all URLs. +$request = HTTP::Request->new($method); +$request->header('If-Modified-Since', $options{'i'}) if defined $options{'i'}; +for my $user_header (@{ $options{'H'} || [] }) { + my ($header_name, $header_value) = split /:\s*/, $user_header, 2; + $request->header($header_name, $header_value); + $ua->agent($header_value) if lc($header_name) eq "user-agent"; # Ugh! +} +#$request->header('Accept', '*/*'); +if ($options{'c'}) { # will always be set for request that wants content + $request->header('Content-Type', $options{'c'}); + $request->header('Content-Length', length $content); # Not really needed + $request->content($content); +} + +$errors = 0; + +# Ok, now we perform the requests, one URL at a time +while ($url = shift) { + # Create the URL object, but protect us against bad URLs + eval { + if ($url =~ /^\w+:/ || $options{'b'}) { # is there any scheme specification + $url = URI->new($url, $options{'b'}); + $url = $url->abs($options{'b'}) if $options{'b'}; + } + else { + $url = uf_uri($url); + } + }; + if ($@) { + $@ =~ s/ at .* line \d+.*//; + print STDERR $@; + $errors++; + next; + } + + $ua->proxy($url->scheme, $options{'p'}) if $options{'p'}; + + # Send the request and get a response back from the server + $request->uri($url); + $response = $ua->request($request); + + if ($options{'u'} || $options{'U'}) { + my $url = $response->request->uri->as_string; + print "$method $url\n"; + print $response->request->headers_as_string, "\n" if $options{'U'}; + } + + if ($options{'S'}) { + for my $r ($response->redirects, $response) { + my $method = $r->request->method; + my $url = $r->request->uri->as_string; + print "$method $url --> ", $r->status_line, "\n"; + } + } + elsif ($options{'s'}) { + print $response->status_line, "\n"; + } + + if ($options{'e'}) { + # Display headers + print $response->headers_as_string; + print "\n"; # separate headers and content + } + + unless ($options{'d'}) { + if ($options{'o'} && + $response->content_type eq 'text/html') { + eval { + require HTML::Parse; + }; + if ($@) { + if ($@ =~ m,^Can't locate HTML/Parse.pm in \@INC,) { + die "The HTML-Tree distribution need to be installed for the -o option to be used.\n"; + } + else { + die $@; + } + } + my $html = HTML::Parse::parse_html($response->content); + { + $options{'o'} eq 'ps' && do { + require HTML::FormatPS; + my $f = HTML::FormatPS->new; + print $f->format($html); + last; + }; + $options{'o'} eq 'text' && do { + require HTML::FormatText; + my $f = HTML::FormatText->new; + print $f->format($html); + last; + }; + $options{'o'} eq 'html' && do { + print $html->as_HTML; + last; + }; + $options{'o'} eq 'links' && do { + my $base = $response->base; + $base = $options{'b'} if $options{'b'}; + for ( @{ $html->extract_links } ) { + my($link, $elem) = @$_; + my $tag = uc $elem->tag; + $link = URI->new($link)->abs($base)->as_string; + print "$tag\t$link\n"; + } + last; + }; + $options{'o'} eq 'dump' && do { + $html->dump; + last; + }; + # It is bad to not notice this before now :-( + die "Illegal -o option value ($options{'o'})\n"; + } + } + else { + binmode STDOUT unless $options{'a'}; + print $response->content; + } + } + + $errors++ unless $response->is_success; +} + +exit $errors; + + +sub usage +{ + die <<"EOT"; +Usage: $progname [-options] <url>... + -m <method> use method for the request (default is '$method') + -f make request even if $progname believes method is illegal + -b <base> Use the specified URL as base + -t <timeout> Set timeout value + -i <time> Set the If-Modified-Since header on the request + -c <conttype> use this content-type for POST, PUT, CHECKIN + -a Use text mode for content I/O + -p <proxyurl> use this as a proxy + -P don't load proxy settings from environment + -H <header> send this HTTP header (you can specify several) + -C <username>:<password> + provide credentials for basic authentication + + -u Display method and URL before any response + -U Display request headers (implies -u) + -s Display response status code + -S Display response status chain + -e Display response headers + -d Do not display content + -o <format> Process HTML content in various ways + + -v Show program version + -h Print this message +EOT +} diff --git a/Master/tlpkg/tlperl/bin/lwp-request.bat b/Master/tlpkg/tlperl/bin/lwp-request.bat new file mode 100755 index 00000000000..0b447c29fd0 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-request.bat @@ -0,0 +1,547 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+# Simple user agent using LWP library.
+
+=head1 NAME
+
+lwp-request, GET, POST, HEAD - Simple command line user agent
+
+=head1 SYNOPSIS
+
+B<lwp-request> [B<-afPuUsSedvhx>] [B<-m> I<method>] [B<-b> I<base URL>] [B<-t> I<timeout>]
+ [B<-i> I<if-modified-since>] [B<-c> I<content-type>]
+ [B<-C> I<credentials>] [B<-p> I<proxy-url>] [B<-o> I<format>] I<url>...
+
+=head1 DESCRIPTION
+
+This program can be used to send requests to WWW servers and your
+local file system. The request content for POST and PUT
+methods is read from stdin. The content of the response is printed on
+stdout. Error messages are printed on stderr. The program returns a
+status value indicating the number of URLs that failed.
+
+The options are:
+
+=over 4
+
+=item -m <method>
+
+Set which method to use for the request. If this option is not used,
+then the method is derived from the name of the program.
+
+=item -f
+
+Force request through, even if the program believes that the method is
+illegal. The server might reject the request eventually.
+
+=item -b <uri>
+
+This URI will be used as the base URI for resolving all relative URIs
+given as argument.
+
+=item -t <timeout>
+
+Set the timeout value for the requests. The timeout is the amount of
+time that the program will wait for a response from the remote server
+before it fails. The default unit for the timeout value is seconds.
+You might append "m" or "h" to the timeout value to make it minutes or
+hours, respectively. The default timeout is '3m', i.e. 3 minutes.
+
+=item -i <time>
+
+Set the If-Modified-Since header in the request. If I<time> is the
+name of a file, use the modification timestamp for this file. If
+I<time> is not a file, it is parsed as a literal date. Take a look at
+L<HTTP::Date> for recognized formats.
+
+=item -c <content-type>
+
+Set the Content-Type for the request. This option is only allowed for
+requests that take a content, i.e. POST and PUT. You can
+force methods to take content by using the C<-f> option together with
+C<-c>. The default Content-Type for POST is
+C<application/x-www-form-urlencoded>. The default Content-type for
+the others is C<text/plain>.
+
+=item -p <proxy-url>
+
+Set the proxy to be used for the requests. The program also loads
+proxy settings from the environment. You can disable this with the
+C<-P> option.
+
+=item -P
+
+Don't load proxy settings from environment.
+
+=item -H <header>
+
+Send this HTTP header with each request. You can specify several, e.g.:
+
+ lwp-request \
+ -H 'Referer: http://other.url/' \
+ -H 'Host: somehost' \
+ http://this.url/
+
+=item -C <username>:<password>
+
+Provide credentials for documents that are protected by Basic
+Authentication. If the document is protected and you did not specify
+the username and password with this option, then you will be prompted
+to provide these values.
+
+=back
+
+The following options controls what is displayed by the program:
+
+=over 4
+
+=item -u
+
+Print request method and absolute URL as requests are made.
+
+=item -U
+
+Print request headers in addition to request method and absolute URL.
+
+=item -s
+
+Print response status code. This option is always on for HEAD requests.
+
+=item -S
+
+Print response status chain. This shows redirect and authorization
+requests that are handled by the library.
+
+=item -e
+
+Print response headers. This option is always on for HEAD requests.
+
+=item -d
+
+Do B<not> print the content of the response.
+
+=item -o <format>
+
+Process HTML content in various ways before printing it. If the
+content type of the response is not HTML, then this option has no
+effect. The legal format values are; I<text>, I<ps>, I<links>,
+I<html> and I<dump>.
+
+If you specify the I<text> format then the HTML will be formatted as
+plain latin1 text. If you specify the I<ps> format then it will be
+formatted as Postscript.
+
+The I<links> format will output all links found in the HTML document.
+Relative links will be expanded to absolute ones.
+
+The I<html> format will reformat the HTML code and the I<dump> format
+will just dump the HTML syntax tree.
+
+Note that the C<HTML-Tree> distribution needs to be installed for this
+option to work. In addition the C<HTML-Format> distribution needs to
+be installed for I<-o text> or I<-o ps> to work.
+
+=item -v
+
+Print the version number of the program and quit.
+
+=item -h
+
+Print usage message and quit.
+
+=item -a
+
+Set text(ascii) mode for content input and output. If this option is not
+used, content input and output is done in binary mode.
+
+=back
+
+Because this program is implemented using the LWP library, it will
+only support the protocols that LWP supports.
+
+=head1 SEE ALSO
+
+L<lwp-mirror>, L<LWP>
+
+=head1 COPYRIGHT
+
+Copyright 1995-1999 Gisle Aas.
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Gisle Aas <gisle@aas.no>
+
+=cut
+
+$progname = $0;
+$progname =~ s,.*[\\/],,; # use basename only
+$progname =~ s/\.\w*$//; # strip extension, if any
+
+$VERSION = "5.834";
+
+
+require LWP;
+
+use URI;
+use URI::Heuristic qw(uf_uri);
+
+use HTTP::Status qw(status_message);
+use HTTP::Date qw(time2str str2time);
+
+
+# This table lists the methods that are allowed. It should really be
+# a superset for all methods supported for every scheme that may be
+# supported by the library. Currently it might be a bit too HTTP
+# specific. You might use the -f option to force a method through.
+#
+# "" = No content in request, "C" = Needs content in request
+#
+%allowed_methods = (
+ GET => "",
+ HEAD => "",
+ POST => "C",
+ PUT => "C",
+ DELETE => "",
+ TRACE => "",
+ OPTIONS => "",
+);
+
+
+# We make our own specialization of LWP::UserAgent that asks for
+# user/password if document is protected.
+{
+ package RequestAgent;
+ @ISA = qw(LWP::UserAgent);
+
+ sub new
+ {
+ my $self = LWP::UserAgent::new(@_);
+ $self->agent("lwp-request/$main::VERSION ");
+ $self;
+ }
+
+ sub get_basic_credentials
+ {
+ my($self, $realm, $uri) = @_;
+ if ($main::options{'C'}) {
+ return split(':', $main::options{'C'}, 2);
+ }
+ elsif (-t) {
+ my $netloc = $uri->host_port;
+ print STDERR "Enter username for $realm at $netloc: ";
+ my $user = <STDIN>;
+ chomp($user);
+ return (undef, undef) unless length $user;
+ print STDERR "Password: ";
+ system("stty -echo");
+ my $password = <STDIN>;
+ system("stty echo");
+ print STDERR "\n"; # because we disabled echo
+ chomp($password);
+ return ($user, $password);
+ }
+ else {
+ return (undef, undef)
+ }
+ }
+}
+
+$method = uc(lc($progname) eq "lwp-request" ? "GET" : $progname);
+
+# Parse command line
+use Getopt::Long;
+
+my @getopt_args = (
+ 'a', # content i/o in text(ascii) mode
+ 'm=s', # set method
+ 'f', # make request even if method is not in %allowed_methods
+ 'b=s', # base url
+ 't=s', # timeout
+ 'i=s', # if-modified-since
+ 'c=s', # content type for POST
+ 'C=s', # credentials for basic authorization
+ 'H=s@', # extra headers, form "Header: value string"
+ #
+ 'u', # display method, URL and headers of request
+ 'U', # display request headers also
+ 's', # display status code
+ 'S', # display whole chain of status codes
+ 'e', # display response headers (default for HEAD)
+ 'd', # don't display content
+ #
+ 'h', # print usage
+ 'v', # print version
+ #
+ 'p=s', # proxy URL
+ 'P', # don't load proxy setting from environment
+ #
+ 'o=s', # output format
+);
+
+Getopt::Long::config("noignorecase", "bundling");
+unless (GetOptions(\%options, @getopt_args)) {
+ usage();
+}
+if ($options{'v'}) {
+ require LWP;
+ my $DISTNAME = 'libwww-perl-' . LWP::Version();
+ die <<"EOT";
+This is lwp-request version $VERSION ($DISTNAME)
+
+Copyright 1995-1999, Gisle Aas.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+EOT
+}
+
+usage() if $options{'h'} || !@ARGV;
+
+# Create the user agent object
+$ua = RequestAgent->new;
+
+# Load proxy settings from *_proxy environment variables.
+$ua->env_proxy unless $options{'P'};
+
+$method = uc($options{'m'}) if defined $options{'m'};
+
+if ($options{'f'}) {
+ if ($options{'c'}) {
+ $allowed_methods{$method} = "C"; # force content
+ }
+ else {
+ $allowed_methods{$method} = "";
+ }
+}
+elsif (!defined $allowed_methods{$method}) {
+ die "$progname: $method is not an allowed method\n";
+}
+
+if ($method eq "HEAD") {
+ $options{'s'} = 1;
+ $options{'e'} = 1 unless $options{'d'};
+ $options{'d'} = 1;
+}
+
+if (defined $options{'t'}) {
+ $options{'t'} =~ /^(\d+)([smh])?/;
+ die "$progname: Illegal timeout value!\n" unless defined $1;
+ $timeout = $1;
+ if (defined $2) {
+ $timeout *= 60 if $2 eq "m";
+ $timeout *= 3600 if $2 eq "h";
+ }
+ $ua->timeout($timeout);
+}
+
+if (defined $options{'i'}) {
+ if (-e $options{'i'}) {
+ $time = (stat _)[9];
+ }
+ else {
+ $time = str2time($options{'i'});
+ die "$progname: Illegal time syntax for -i option\n"
+ unless defined $time;
+ }
+ $options{'i'} = time2str($time);
+}
+
+$content = undef;
+if ($allowed_methods{$method} eq "C") {
+ # This request needs some content
+ unless (defined $options{'c'}) {
+ # set default content type
+ $options{'c'} = ($method eq "POST") ?
+ "application/x-www-form-urlencoded"
+ : "text/plain";
+ }
+ else {
+ die "$progname: Illegal Content-type format\n"
+ unless $options{'c'} =~ m,^[\w\-]+/[\w\-.+]+(?:\s*;.*)?$,
+ }
+ print STDERR "Please enter content ($options{'c'}) to be ${method}ed:\n"
+ if -t;
+ binmode STDIN unless -t or $options{'a'};
+ $content = join("", <STDIN>);
+}
+else {
+ die "$progname: Can't set Content-type for $method requests\n"
+ if defined $options{'c'};
+}
+
+# Set up a request. We will use the same request object for all URLs.
+$request = HTTP::Request->new($method);
+$request->header('If-Modified-Since', $options{'i'}) if defined $options{'i'};
+for my $user_header (@{ $options{'H'} || [] }) {
+ my ($header_name, $header_value) = split /:\s*/, $user_header, 2;
+ $request->header($header_name, $header_value);
+ $ua->agent($header_value) if lc($header_name) eq "user-agent"; # Ugh!
+}
+#$request->header('Accept', '*/*');
+if ($options{'c'}) { # will always be set for request that wants content
+ $request->header('Content-Type', $options{'c'});
+ $request->header('Content-Length', length $content); # Not really needed
+ $request->content($content);
+}
+
+$errors = 0;
+
+# Ok, now we perform the requests, one URL at a time
+while ($url = shift) {
+ # Create the URL object, but protect us against bad URLs
+ eval {
+ if ($url =~ /^\w+:/ || $options{'b'}) { # is there any scheme specification
+ $url = URI->new($url, $options{'b'});
+ $url = $url->abs($options{'b'}) if $options{'b'};
+ }
+ else {
+ $url = uf_uri($url);
+ }
+ };
+ if ($@) {
+ $@ =~ s/ at .* line \d+.*//;
+ print STDERR $@;
+ $errors++;
+ next;
+ }
+
+ $ua->proxy($url->scheme, $options{'p'}) if $options{'p'};
+
+ # Send the request and get a response back from the server
+ $request->uri($url);
+ $response = $ua->request($request);
+
+ if ($options{'u'} || $options{'U'}) {
+ my $url = $response->request->uri->as_string;
+ print "$method $url\n";
+ print $response->request->headers_as_string, "\n" if $options{'U'};
+ }
+
+ if ($options{'S'}) {
+ for my $r ($response->redirects, $response) {
+ my $method = $r->request->method;
+ my $url = $r->request->uri->as_string;
+ print "$method $url --> ", $r->status_line, "\n";
+ }
+ }
+ elsif ($options{'s'}) {
+ print $response->status_line, "\n";
+ }
+
+ if ($options{'e'}) {
+ # Display headers
+ print $response->headers_as_string;
+ print "\n"; # separate headers and content
+ }
+
+ unless ($options{'d'}) {
+ if ($options{'o'} &&
+ $response->content_type eq 'text/html') {
+ eval {
+ require HTML::Parse;
+ };
+ if ($@) {
+ if ($@ =~ m,^Can't locate HTML/Parse.pm in \@INC,) {
+ die "The HTML-Tree distribution need to be installed for the -o option to be used.\n";
+ }
+ else {
+ die $@;
+ }
+ }
+ my $html = HTML::Parse::parse_html($response->content);
+ {
+ $options{'o'} eq 'ps' && do {
+ require HTML::FormatPS;
+ my $f = HTML::FormatPS->new;
+ print $f->format($html);
+ last;
+ };
+ $options{'o'} eq 'text' && do {
+ require HTML::FormatText;
+ my $f = HTML::FormatText->new;
+ print $f->format($html);
+ last;
+ };
+ $options{'o'} eq 'html' && do {
+ print $html->as_HTML;
+ last;
+ };
+ $options{'o'} eq 'links' && do {
+ my $base = $response->base;
+ $base = $options{'b'} if $options{'b'};
+ for ( @{ $html->extract_links } ) {
+ my($link, $elem) = @$_;
+ my $tag = uc $elem->tag;
+ $link = URI->new($link)->abs($base)->as_string;
+ print "$tag\t$link\n";
+ }
+ last;
+ };
+ $options{'o'} eq 'dump' && do {
+ $html->dump;
+ last;
+ };
+ # It is bad to not notice this before now :-(
+ die "Illegal -o option value ($options{'o'})\n";
+ }
+ }
+ else {
+ binmode STDOUT unless $options{'a'};
+ print $response->content;
+ }
+ }
+
+ $errors++ unless $response->is_success;
+}
+
+exit $errors;
+
+
+sub usage
+{
+ die <<"EOT";
+Usage: $progname [-options] <url>...
+ -m <method> use method for the request (default is '$method')
+ -f make request even if $progname believes method is illegal
+ -b <base> Use the specified URL as base
+ -t <timeout> Set timeout value
+ -i <time> Set the If-Modified-Since header on the request
+ -c <conttype> use this content-type for POST, PUT, CHECKIN
+ -a Use text mode for content I/O
+ -p <proxyurl> use this as a proxy
+ -P don't load proxy settings from environment
+ -H <header> send this HTTP header (you can specify several)
+ -C <username>:<password>
+ provide credentials for basic authentication
+
+ -u Display method and URL before any response
+ -U Display request headers (implies -u)
+ -s Display response status code
+ -S Display response status chain
+ -e Display response headers
+ -d Do not display content
+ -o <format> Process HTML content in various ways
+
+ -v Show program version
+ -h Print this message
+EOT
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/lwp-rget b/Master/tlpkg/tlperl/bin/lwp-rget new file mode 100755 index 00000000000..2ac798f4bb0 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-rget @@ -0,0 +1,607 @@ +#!/usr/bin/perl -w + +=head1 NAME + +lwp-rget - Retrieve web documents recursively + +=head1 SYNOPSIS + + lwp-rget [--verbose] [--auth=USER:PASS] [--depth=N] [--hier] [--iis] + [--keepext=mime/type[,mime/type]] [--limit=N] [--nospace] + [--prefix=URL] [--referer=URL] [--sleep=N] [--tolower] <URL> + lwp-rget --version + +=head1 DESCRIPTION + +This program will retrieve a document and store it in a local file. It +will follow any links found in the document and store these documents +as well, patching links so that they refer to these local copies. +This process continues until there are no more unvisited links or the +process is stopped by the one or more of the limits which can be +controlled by the command line arguments. + +This program is useful if you want to make a local copy of a +collection of documents or want to do web reading off-line. + +All documents are stored as plain files in the current directory. The +file names chosen are derived from the last component of URL paths. + +The options are: + +=over 3 + +=item --auth=USER:PASS<n> + +Set the authentication credentials to user "USER" and password "PASS" if +any restricted parts of the web site are hit. If there are restricted +parts of the web site and authentication credentials are not available, +those pages will not be downloaded. + +=item --depth=I<n> + +Limit the recursive level. Embedded images are always loaded, even if +they fall outside the I<--depth>. This means that one can use +I<--depth=0> in order to fetch a single document together with all +inline graphics. + +The default depth is 5. + +=item --hier + +Download files into a hierarchy that mimics the web site structure. +The default is to put all files in the current directory. + +=item --referer=I<URI> + +Set the value of the Referer header for the initial request. The +special value C<"NONE"> can be used to suppress the Referer header in +any of subsequent requests. The Referer header will always be suppressed +in all normal C<http> requests if the referring page was transmitted over +C<https> as recommended in RFC 2616. + +=item --iis + +Sends an "Accept: */*" on all URL requests as a workaround for a bug in +IIS 2.0. If no Accept MIME header is present, IIS 2.0 returns with a +"406 No acceptable objects were found" error. Also converts any back +slashes (\\) in URLs to forward slashes (/). + +=item --keepext=I<mime/type[,mime/type]> + +Keeps the current extension for the list MIME types. Useful when +downloading text/plain documents that shouldn't all be translated to +*.txt files. + +=item --limit=I<n> + +Limit the number of documents to get. The default limit is 50. + +=item --nospace + +Changes spaces in all URLs to underscore characters (_). Useful when +downloading files from sites serving URLs with spaces in them. Does not +remove spaces from fragments, e.g., "file.html#somewhere in here". + +=item --prefix=I<url_prefix> + +Limit the links to follow. Only URLs that start the prefix string are +followed. + +The default prefix is set as the "directory" of the initial URL to +follow. For instance if we start lwp-rget with the URL +C<http://www.sn.no/foo/bar.html>, then prefix will be set to +C<http://www.sn.no/foo/>. + +Use C<--prefix=''> if you don't want the fetching to be limited by any +prefix. + +=item --sleep=I<n> + +Sleep I<n> seconds before retrieving each document. This options allows +you to go slowly, not loading the server you visiting too much. + +=item --tolower + +Translates all links to lowercase. Useful when downloading files from +IIS since it does not serve files in a case sensitive manner. + +=item --verbose + +Make more noise while running. + +=item --quiet + +Don't make any noise. + +=item --version + +Print program version number and quit. + +=item --help + +Print the usage message and quit. + +=back + +Before the program exits the name of the file, where the initial URL +is stored, is printed on stdout. All used filenames are also printed +on stderr as they are loaded. This printing can be suppressed with +the I<--quiet> option. + +=head1 SEE ALSO + +L<lwp-request>, L<LWP> + +=head1 AUTHOR + +Gisle Aas <aas@sn.no> + +=cut + +use strict; + +use Getopt::Long qw(GetOptions); +use URI::URL qw(url); +use LWP::MediaTypes qw(media_suffix); +use HTML::Entities (); + +use vars qw($VERSION); +use vars qw($MAX_DEPTH $MAX_DOCS $PREFIX $REFERER $VERBOSE $QUIET $SLEEP $HIER $AUTH $IIS $TOLOWER $NOSPACE %KEEPEXT); + +my $progname = $0; +$progname =~ s|.*/||; # only basename left +$progname =~ s/\.\w*$//; #strip extension if any + +$VERSION = "5.827"; + +#$Getopt::Long::debug = 1; +#$Getopt::Long::ignorecase = 0; + +# Defaults +$MAX_DEPTH = 5; +$MAX_DOCS = 50; + +GetOptions('version' => \&print_version, + 'help' => \&usage, + 'depth=i' => \$MAX_DEPTH, + 'limit=i' => \$MAX_DOCS, + 'verbose!' => \$VERBOSE, + 'quiet!' => \$QUIET, + 'sleep=i' => \$SLEEP, + 'prefix:s' => \$PREFIX, + 'referer:s'=> \$REFERER, + 'hier' => \$HIER, + 'auth=s' => \$AUTH, + 'iis' => \$IIS, + 'tolower' => \$TOLOWER, + 'nospace' => \$NOSPACE, + 'keepext=s' => \$KEEPEXT{'OPT'}, + ) || usage(); + +sub print_version { + require LWP; + my $DISTNAME = 'libwww-perl-' . LWP::Version(); + print <<"EOT"; +This is lwp-rget version $VERSION ($DISTNAME) + +Copyright 1996-1998, Gisle Aas. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. +EOT + exit 0; +} + +my $start_url = shift || usage(); +usage() if @ARGV; + +require LWP::UserAgent; +my $ua = new LWP::UserAgent; +$ua->agent("$progname/$VERSION "); +$ua->env_proxy; + +unless (defined $PREFIX) { + $PREFIX = url($start_url); # limit to URLs below this one + eval { + $PREFIX->eparams(undef); + $PREFIX->equery(undef); + }; + + $_ = $PREFIX->epath; + s|[^/]+$||; + $PREFIX->epath($_); + $PREFIX = $PREFIX->as_string; +} + +%KEEPEXT = map { lc($_) => 1 } split(/\s*,\s*/, ($KEEPEXT{'OPT'}||0)); + +my $SUPPRESS_REFERER; +$SUPPRESS_REFERER++ if ($REFERER || "") eq "NONE"; + +print <<"" if $VERBOSE; +START = $start_url +MAX_DEPTH = $MAX_DEPTH +MAX_DOCS = $MAX_DOCS +PREFIX = $PREFIX + +my $no_docs = 0; +my %seen = (); # mapping from URL => local_file + +my $filename = fetch($start_url, undef, $REFERER); +print "$filename\n" unless $QUIET; + +sub fetch +{ + my($url, $type, $referer, $depth) = @_; + + # Fix http://sitename.com/../blah/blah.html to + # http://sitename.com/blah/blah.html + $url = $url->as_string if (ref($url)); + while ($url =~ s#(https?://[^/]+/)\.\.\/#$1#) {} + + # Fix backslashes (\) in URL if $IIS defined + $url = fix_backslashes($url) if (defined $IIS); + + $url = url($url); + $type ||= 'a'; + # Might be the background attribute + $type = 'img' if ($type eq 'body' || $type eq 'td'); + $depth ||= 0; + + # Print the URL before we start checking... + my $out = (" " x $depth) . $url . " "; + $out .= "." x (60 - length($out)); + print STDERR $out . " " if $VERBOSE; + + # Can't get mailto things + if ($url->scheme eq 'mailto') { + print STDERR "*skipping mailto*\n" if $VERBOSE; + return $url->as_string; + } + + # The $plain_url is a URL without the fragment part + my $plain_url = $url->clone; + $plain_url->frag(undef); + + # Check PREFIX, but not for <IMG ...> links + if ($type ne 'img' and $url->as_string !~ /^\Q$PREFIX/o) { + print STDERR "*outsider*\n" if $VERBOSE; + return $url->as_string; + } + + # Translate URL to lowercase if $TOLOWER defined + $plain_url = to_lower($plain_url) if (defined $TOLOWER); + + # If we already have it, then there is nothing to be done + my $seen = $seen{$plain_url->as_string}; + if ($seen) { + my $frag = $url->frag; + $seen .= "#$frag" if defined($frag); + $seen = protect_frag_spaces($seen); + print STDERR "$seen (again)\n" if $VERBOSE; + return $seen; + } + + # Too much or too deep + if ($depth > $MAX_DEPTH and $type ne 'img') { + print STDERR "*too deep*\n" if $VERBOSE; + return $url; + } + if ($no_docs > $MAX_DOCS) { + print STDERR "*too many*\n" if $VERBOSE; + return $url; + } + + # Fetch document + $no_docs++; + sleep($SLEEP) if $SLEEP; + my $req = HTTP::Request->new(GET => $url); + # See: http://ftp.sunet.se/pub/NT/mirror-microsoft/kb/Q163/7/74.TXT + $req->header ('Accept', '*/*') if (defined $IIS); # GIF/JPG from IIS 2.0 + $req->authorization_basic(split (/:/, $AUTH)) if (defined $AUTH); + if ($referer && !$SUPPRESS_REFERER) { + if ($req->uri->scheme eq 'http') { + # RFC 2616, section 15.1.3 + $referer = url($referer) unless ref($referer); + undef $referer if ($referer->scheme || '') eq 'https'; + } + $req->referer($referer) if $referer; + } + my $res = $ua->request($req); + + # Check outcome + if ($res->is_success) { + my $doc = $res->content; + my $ct = $res->content_type; + my $name = find_name($res->request->uri, $ct); + print STDERR "$name\n" unless $QUIET; + $seen{$plain_url->as_string} = $name; + + # If the file is HTML, then we look for internal links + if ($ct eq "text/html") { + # Save an unprosessed version of the HTML document. This + # both reserves the name used, and it also ensures that we + # don't loose everything if this program is killed before + # we finish. + save($name, $doc); + my $base = $res->base; + + # Follow and substitute links... + $doc =~ +s/ + ( + <(img|a|body|area|frame|td)\b # some interesting tag + [^>]+ # still inside tag (not strictly correct) + \b(?:src|href|background) # some link attribute + \s*=\s* # = + ) + (?: # scope of OR-ing + (")([^"]*)" | # value in double quotes OR + (')([^']*)' | # value in single quotes OR + ([^\s>]+) # quoteless value + ) +/ + new_link($1, lc($2), $3||$5, HTML::Entities::decode($4||$6||$7), + $base, $name, "$url", $depth+1) +/giex; + # XXX + # The regular expression above is not strictly correct. + # It is not really possible to parse HTML with a single + # regular expression, but it is faster. Tags that might + # confuse us include: + # <a alt="href" href=link.html> + # <a alt=">" href="link.html"> + # + } + save($name, $doc); + return $name; + } + else { + print STDERR $res->code . " " . $res->message . "\n" if $VERBOSE; + $seen{$plain_url->as_string} = $url->as_string; + return $url->as_string; + } +} + +sub new_link +{ + my($pre, $type, $quote, $url, $base, $localbase, $referer, $depth) = @_; + + $url = protect_frag_spaces($url); + + $url = fetch(url($url, $base)->abs, $type, $referer, $depth); + $url = url("file:$url", "file:$localbase")->rel + unless $url =~ /^[.+\-\w]+:/; + + $url = unprotect_frag_spaces($url); + + return $pre . $quote . $url . $quote; +} + + +sub protect_frag_spaces +{ + my ($url) = @_; + + $url = $url->as_string if (ref($url)); + + if ($url =~ m/^([^#]*#)(.+)$/) + { + my ($base, $frag) = ($1, $2); + $frag =~ s/ /%20/g; + $url = $base . $frag; + } + + return $url; +} + + +sub unprotect_frag_spaces +{ + my ($url) = @_; + + $url = $url->as_string if (ref($url)); + + if ($url =~ m/^([^#]*#)(.+)$/) + { + my ($base, $frag) = ($1, $2); + $frag =~ s/%20/ /g; + $url = $base . $frag; + } + + return $url; +} + + +sub fix_backslashes +{ + my ($url) = @_; + my ($base, $frag); + + $url = $url->as_string if (ref($url)); + + if ($url =~ m/([^#]+)(#.*)/) + { + ($base, $frag) = ($1, $2); + } + else + { + $base = $url; + $frag = ""; + } + + $base =~ tr/\\/\//; + $base =~ s/%5[cC]/\//g; # URL-encoded back slash is %5C + + return $base . $frag; +} + + +sub to_lower +{ + my ($url) = @_; + my $was_object = 0; + + if (ref($url)) + { + $url = $url->as_string; + $was_object = 1; + } + + if ($url =~ m/([^#]+)(#.*)/) + { + $url = lc($1) . $2; + } + else + { + $url = lc($url); + } + + if ($was_object == 1) + { + return url($url); + } + else + { + return $url; + } +} + + +sub translate_spaces +{ + my ($url) = @_; + my ($base, $frag); + + $url = $url->as_string if (ref($url)); + + if ($url =~ m/([^#]+)(#.*)/) + { + ($base, $frag) = ($1, $2); + } + else + { + $base = $url; + $frag = ""; + } + + $base =~ s/^ *//; # Remove initial spaces from base + $base =~ s/ *$//; # Remove trailing spaces from base + + $base =~ tr/ /_/; + $base =~ s/%20/_/g; # URL-encoded space is %20 + + return $base . $frag; +} + + +sub mkdirp +{ + my($directory, $mode) = @_; + my @dirs = split(/\//, $directory); + my $path = shift(@dirs); # build it as we go + my $result = 1; # assume it will work + + unless (-d $path) { + $result &&= mkdir($path, $mode); + } + + foreach (@dirs) { + $path .= "/$_"; + if ( ! -d $path) { + $result &&= mkdir($path, $mode); + } + } + + return $result; +} + + +sub find_name +{ + my($url, $type) = @_; + #print "find_name($url, $type)\n"; + + # Translate spaces in URL to underscores (_) if $NOSPACE defined + $url = translate_spaces($url) if (defined $NOSPACE); + + # Translate URL to lowercase if $TOLOWER defined + $url = to_lower($url) if (defined $TOLOWER); + + $url = url($url) unless ref($url); + + my $path = $url->path; + + # trim path until only the basename is left + $path =~ s|(.*/)||; + my $dirname = ".$1"; + if (!$HIER) { + $dirname = ""; + } + elsif (! -d $dirname) { + mkdirp($dirname, 0775); + } + + my $extra = ""; # something to make the name unique + my $suffix; + + if ($KEEPEXT{lc($type)}) { + $suffix = ($path =~ m/\.(.*)/) ? $1 : ""; + } + else { + $suffix = media_suffix($type); + } + + $path =~ s|\..*||; # trim suffix + $path = "index" unless length $path; + + while (1) { + # Construct a new file name + my $file = $dirname . $path . $extra; + $file .= ".$suffix" if $suffix; + # Check if it is unique + return $file unless -f $file; + + # Try something extra + unless ($extra) { + $extra = "001"; + next; + } + $extra++; + } +} + + +sub save +{ + my $name = shift; + #print "save($name,...)\n"; + open(FILE, ">$name") || die "Can't save $name: $!"; + binmode FILE; + print FILE $_[0]; + close(FILE); +} + + +sub usage +{ + print <<""; exit 1; +Usage: $progname [options] <URL> +Allowed options are: + --auth=USER:PASS Set authentication credentials for web site + --depth=N Maximum depth to traverse (default is $MAX_DEPTH) + --hier Download into hierarchy (not all files into cwd) + --referer=URI Set initial referer header (or "NONE") + --iis Workaround IIS 2.0 bug by sending "Accept: */*" MIME + header; translates backslashes (\\) to forward slashes (/) + --keepext=type Keep file extension for MIME types (comma-separated list) + --limit=N A limit on the number documents to get (default is $MAX_DOCS) + --nospace Translate spaces URLs (not #fragments) to underscores (_) + --version Print version number and quit + --verbose More output + --quiet No output + --sleep=SECS Sleep between gets, ie. go slowly + --prefix=PREFIX Limit URLs to follow to those which begin with PREFIX + --tolower Translate all URLs to lowercase (useful with IIS servers) + +} diff --git a/Master/tlpkg/tlperl/bin/lwp-rget.bat b/Master/tlpkg/tlperl/bin/lwp-rget.bat new file mode 100755 index 00000000000..34b097d1f2c --- /dev/null +++ b/Master/tlpkg/tlperl/bin/lwp-rget.bat @@ -0,0 +1,623 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -w
+#line 15
+
+=head1 NAME
+
+lwp-rget - Retrieve web documents recursively
+
+=head1 SYNOPSIS
+
+ lwp-rget [--verbose] [--auth=USER:PASS] [--depth=N] [--hier] [--iis]
+ [--keepext=mime/type[,mime/type]] [--limit=N] [--nospace]
+ [--prefix=URL] [--referer=URL] [--sleep=N] [--tolower] <URL>
+ lwp-rget --version
+
+=head1 DESCRIPTION
+
+This program will retrieve a document and store it in a local file. It
+will follow any links found in the document and store these documents
+as well, patching links so that they refer to these local copies.
+This process continues until there are no more unvisited links or the
+process is stopped by the one or more of the limits which can be
+controlled by the command line arguments.
+
+This program is useful if you want to make a local copy of a
+collection of documents or want to do web reading off-line.
+
+All documents are stored as plain files in the current directory. The
+file names chosen are derived from the last component of URL paths.
+
+The options are:
+
+=over 3
+
+=item --auth=USER:PASS<n>
+
+Set the authentication credentials to user "USER" and password "PASS" if
+any restricted parts of the web site are hit. If there are restricted
+parts of the web site and authentication credentials are not available,
+those pages will not be downloaded.
+
+=item --depth=I<n>
+
+Limit the recursive level. Embedded images are always loaded, even if
+they fall outside the I<--depth>. This means that one can use
+I<--depth=0> in order to fetch a single document together with all
+inline graphics.
+
+The default depth is 5.
+
+=item --hier
+
+Download files into a hierarchy that mimics the web site structure.
+The default is to put all files in the current directory.
+
+=item --referer=I<URI>
+
+Set the value of the Referer header for the initial request. The
+special value C<"NONE"> can be used to suppress the Referer header in
+any of subsequent requests. The Referer header will always be suppressed
+in all normal C<http> requests if the referring page was transmitted over
+C<https> as recommended in RFC 2616.
+
+=item --iis
+
+Sends an "Accept: */*" on all URL requests as a workaround for a bug in
+IIS 2.0. If no Accept MIME header is present, IIS 2.0 returns with a
+"406 No acceptable objects were found" error. Also converts any back
+slashes (\\) in URLs to forward slashes (/).
+
+=item --keepext=I<mime/type[,mime/type]>
+
+Keeps the current extension for the list MIME types. Useful when
+downloading text/plain documents that shouldn't all be translated to
+*.txt files.
+
+=item --limit=I<n>
+
+Limit the number of documents to get. The default limit is 50.
+
+=item --nospace
+
+Changes spaces in all URLs to underscore characters (_). Useful when
+downloading files from sites serving URLs with spaces in them. Does not
+remove spaces from fragments, e.g., "file.html#somewhere in here".
+
+=item --prefix=I<url_prefix>
+
+Limit the links to follow. Only URLs that start the prefix string are
+followed.
+
+The default prefix is set as the "directory" of the initial URL to
+follow. For instance if we start lwp-rget with the URL
+C<http://www.sn.no/foo/bar.html>, then prefix will be set to
+C<http://www.sn.no/foo/>.
+
+Use C<--prefix=''> if you don't want the fetching to be limited by any
+prefix.
+
+=item --sleep=I<n>
+
+Sleep I<n> seconds before retrieving each document. This options allows
+you to go slowly, not loading the server you visiting too much.
+
+=item --tolower
+
+Translates all links to lowercase. Useful when downloading files from
+IIS since it does not serve files in a case sensitive manner.
+
+=item --verbose
+
+Make more noise while running.
+
+=item --quiet
+
+Don't make any noise.
+
+=item --version
+
+Print program version number and quit.
+
+=item --help
+
+Print the usage message and quit.
+
+=back
+
+Before the program exits the name of the file, where the initial URL
+is stored, is printed on stdout. All used filenames are also printed
+on stderr as they are loaded. This printing can be suppressed with
+the I<--quiet> option.
+
+=head1 SEE ALSO
+
+L<lwp-request>, L<LWP>
+
+=head1 AUTHOR
+
+Gisle Aas <aas@sn.no>
+
+=cut
+
+use strict;
+
+use Getopt::Long qw(GetOptions);
+use URI::URL qw(url);
+use LWP::MediaTypes qw(media_suffix);
+use HTML::Entities ();
+
+use vars qw($VERSION);
+use vars qw($MAX_DEPTH $MAX_DOCS $PREFIX $REFERER $VERBOSE $QUIET $SLEEP $HIER $AUTH $IIS $TOLOWER $NOSPACE %KEEPEXT);
+
+my $progname = $0;
+$progname =~ s|.*/||; # only basename left
+$progname =~ s/\.\w*$//; #strip extension if any
+
+$VERSION = "5.827";
+
+#$Getopt::Long::debug = 1;
+#$Getopt::Long::ignorecase = 0;
+
+# Defaults
+$MAX_DEPTH = 5;
+$MAX_DOCS = 50;
+
+GetOptions('version' => \&print_version,
+ 'help' => \&usage,
+ 'depth=i' => \$MAX_DEPTH,
+ 'limit=i' => \$MAX_DOCS,
+ 'verbose!' => \$VERBOSE,
+ 'quiet!' => \$QUIET,
+ 'sleep=i' => \$SLEEP,
+ 'prefix:s' => \$PREFIX,
+ 'referer:s'=> \$REFERER,
+ 'hier' => \$HIER,
+ 'auth=s' => \$AUTH,
+ 'iis' => \$IIS,
+ 'tolower' => \$TOLOWER,
+ 'nospace' => \$NOSPACE,
+ 'keepext=s' => \$KEEPEXT{'OPT'},
+ ) || usage();
+
+sub print_version {
+ require LWP;
+ my $DISTNAME = 'libwww-perl-' . LWP::Version();
+ print <<"EOT";
+This is lwp-rget version $VERSION ($DISTNAME)
+
+Copyright 1996-1998, Gisle Aas.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+EOT
+ exit 0;
+}
+
+my $start_url = shift || usage();
+usage() if @ARGV;
+
+require LWP::UserAgent;
+my $ua = new LWP::UserAgent;
+$ua->agent("$progname/$VERSION ");
+$ua->env_proxy;
+
+unless (defined $PREFIX) {
+ $PREFIX = url($start_url); # limit to URLs below this one
+ eval {
+ $PREFIX->eparams(undef);
+ $PREFIX->equery(undef);
+ };
+
+ $_ = $PREFIX->epath;
+ s|[^/]+$||;
+ $PREFIX->epath($_);
+ $PREFIX = $PREFIX->as_string;
+}
+
+%KEEPEXT = map { lc($_) => 1 } split(/\s*,\s*/, ($KEEPEXT{'OPT'}||0));
+
+my $SUPPRESS_REFERER;
+$SUPPRESS_REFERER++ if ($REFERER || "") eq "NONE";
+
+print <<"" if $VERBOSE;
+START = $start_url
+MAX_DEPTH = $MAX_DEPTH
+MAX_DOCS = $MAX_DOCS
+PREFIX = $PREFIX
+
+my $no_docs = 0;
+my %seen = (); # mapping from URL => local_file
+
+my $filename = fetch($start_url, undef, $REFERER);
+print "$filename\n" unless $QUIET;
+
+sub fetch
+{
+ my($url, $type, $referer, $depth) = @_;
+
+ # Fix http://sitename.com/../blah/blah.html to
+ # http://sitename.com/blah/blah.html
+ $url = $url->as_string if (ref($url));
+ while ($url =~ s#(https?://[^/]+/)\.\.\/#$1#) {}
+
+ # Fix backslashes (\) in URL if $IIS defined
+ $url = fix_backslashes($url) if (defined $IIS);
+
+ $url = url($url);
+ $type ||= 'a';
+ # Might be the background attribute
+ $type = 'img' if ($type eq 'body' || $type eq 'td');
+ $depth ||= 0;
+
+ # Print the URL before we start checking...
+ my $out = (" " x $depth) . $url . " ";
+ $out .= "." x (60 - length($out));
+ print STDERR $out . " " if $VERBOSE;
+
+ # Can't get mailto things
+ if ($url->scheme eq 'mailto') {
+ print STDERR "*skipping mailto*\n" if $VERBOSE;
+ return $url->as_string;
+ }
+
+ # The $plain_url is a URL without the fragment part
+ my $plain_url = $url->clone;
+ $plain_url->frag(undef);
+
+ # Check PREFIX, but not for <IMG ...> links
+ if ($type ne 'img' and $url->as_string !~ /^\Q$PREFIX/o) {
+ print STDERR "*outsider*\n" if $VERBOSE;
+ return $url->as_string;
+ }
+
+ # Translate URL to lowercase if $TOLOWER defined
+ $plain_url = to_lower($plain_url) if (defined $TOLOWER);
+
+ # If we already have it, then there is nothing to be done
+ my $seen = $seen{$plain_url->as_string};
+ if ($seen) {
+ my $frag = $url->frag;
+ $seen .= "#$frag" if defined($frag);
+ $seen = protect_frag_spaces($seen);
+ print STDERR "$seen (again)\n" if $VERBOSE;
+ return $seen;
+ }
+
+ # Too much or too deep
+ if ($depth > $MAX_DEPTH and $type ne 'img') {
+ print STDERR "*too deep*\n" if $VERBOSE;
+ return $url;
+ }
+ if ($no_docs > $MAX_DOCS) {
+ print STDERR "*too many*\n" if $VERBOSE;
+ return $url;
+ }
+
+ # Fetch document
+ $no_docs++;
+ sleep($SLEEP) if $SLEEP;
+ my $req = HTTP::Request->new(GET => $url);
+ # See: http://ftp.sunet.se/pub/NT/mirror-microsoft/kb/Q163/7/74.TXT
+ $req->header ('Accept', '*/*') if (defined $IIS); # GIF/JPG from IIS 2.0
+ $req->authorization_basic(split (/:/, $AUTH)) if (defined $AUTH);
+ if ($referer && !$SUPPRESS_REFERER) {
+ if ($req->uri->scheme eq 'http') {
+ # RFC 2616, section 15.1.3
+ $referer = url($referer) unless ref($referer);
+ undef $referer if ($referer->scheme || '') eq 'https';
+ }
+ $req->referer($referer) if $referer;
+ }
+ my $res = $ua->request($req);
+
+ # Check outcome
+ if ($res->is_success) {
+ my $doc = $res->content;
+ my $ct = $res->content_type;
+ my $name = find_name($res->request->uri, $ct);
+ print STDERR "$name\n" unless $QUIET;
+ $seen{$plain_url->as_string} = $name;
+
+ # If the file is HTML, then we look for internal links
+ if ($ct eq "text/html") {
+ # Save an unprosessed version of the HTML document. This
+ # both reserves the name used, and it also ensures that we
+ # don't loose everything if this program is killed before
+ # we finish.
+ save($name, $doc);
+ my $base = $res->base;
+
+ # Follow and substitute links...
+ $doc =~
+s/
+ (
+ <(img|a|body|area|frame|td)\b # some interesting tag
+ [^>]+ # still inside tag (not strictly correct)
+ \b(?:src|href|background) # some link attribute
+ \s*=\s* # =
+ )
+ (?: # scope of OR-ing
+ (")([^"]*)" | # value in double quotes OR
+ (')([^']*)' | # value in single quotes OR
+ ([^\s>]+) # quoteless value
+ )
+/
+ new_link($1, lc($2), $3||$5, HTML::Entities::decode($4||$6||$7),
+ $base, $name, "$url", $depth+1)
+/giex;
+ # XXX
+ # The regular expression above is not strictly correct.
+ # It is not really possible to parse HTML with a single
+ # regular expression, but it is faster. Tags that might
+ # confuse us include:
+ # <a alt="href" href=link.html>
+ # <a alt=">" href="link.html">
+ #
+ }
+ save($name, $doc);
+ return $name;
+ }
+ else {
+ print STDERR $res->code . " " . $res->message . "\n" if $VERBOSE;
+ $seen{$plain_url->as_string} = $url->as_string;
+ return $url->as_string;
+ }
+}
+
+sub new_link
+{
+ my($pre, $type, $quote, $url, $base, $localbase, $referer, $depth) = @_;
+
+ $url = protect_frag_spaces($url);
+
+ $url = fetch(url($url, $base)->abs, $type, $referer, $depth);
+ $url = url("file:$url", "file:$localbase")->rel
+ unless $url =~ /^[.+\-\w]+:/;
+
+ $url = unprotect_frag_spaces($url);
+
+ return $pre . $quote . $url . $quote;
+}
+
+
+sub protect_frag_spaces
+{
+ my ($url) = @_;
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/^([^#]*#)(.+)$/)
+ {
+ my ($base, $frag) = ($1, $2);
+ $frag =~ s/ /%20/g;
+ $url = $base . $frag;
+ }
+
+ return $url;
+}
+
+
+sub unprotect_frag_spaces
+{
+ my ($url) = @_;
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/^([^#]*#)(.+)$/)
+ {
+ my ($base, $frag) = ($1, $2);
+ $frag =~ s/%20/ /g;
+ $url = $base . $frag;
+ }
+
+ return $url;
+}
+
+
+sub fix_backslashes
+{
+ my ($url) = @_;
+ my ($base, $frag);
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/([^#]+)(#.*)/)
+ {
+ ($base, $frag) = ($1, $2);
+ }
+ else
+ {
+ $base = $url;
+ $frag = "";
+ }
+
+ $base =~ tr/\\/\//;
+ $base =~ s/%5[cC]/\//g; # URL-encoded back slash is %5C
+
+ return $base . $frag;
+}
+
+
+sub to_lower
+{
+ my ($url) = @_;
+ my $was_object = 0;
+
+ if (ref($url))
+ {
+ $url = $url->as_string;
+ $was_object = 1;
+ }
+
+ if ($url =~ m/([^#]+)(#.*)/)
+ {
+ $url = lc($1) . $2;
+ }
+ else
+ {
+ $url = lc($url);
+ }
+
+ if ($was_object == 1)
+ {
+ return url($url);
+ }
+ else
+ {
+ return $url;
+ }
+}
+
+
+sub translate_spaces
+{
+ my ($url) = @_;
+ my ($base, $frag);
+
+ $url = $url->as_string if (ref($url));
+
+ if ($url =~ m/([^#]+)(#.*)/)
+ {
+ ($base, $frag) = ($1, $2);
+ }
+ else
+ {
+ $base = $url;
+ $frag = "";
+ }
+
+ $base =~ s/^ *//; # Remove initial spaces from base
+ $base =~ s/ *$//; # Remove trailing spaces from base
+
+ $base =~ tr/ /_/;
+ $base =~ s/%20/_/g; # URL-encoded space is %20
+
+ return $base . $frag;
+}
+
+
+sub mkdirp
+{
+ my($directory, $mode) = @_;
+ my @dirs = split(/\//, $directory);
+ my $path = shift(@dirs); # build it as we go
+ my $result = 1; # assume it will work
+
+ unless (-d $path) {
+ $result &&= mkdir($path, $mode);
+ }
+
+ foreach (@dirs) {
+ $path .= "/$_";
+ if ( ! -d $path) {
+ $result &&= mkdir($path, $mode);
+ }
+ }
+
+ return $result;
+}
+
+
+sub find_name
+{
+ my($url, $type) = @_;
+ #print "find_name($url, $type)\n";
+
+ # Translate spaces in URL to underscores (_) if $NOSPACE defined
+ $url = translate_spaces($url) if (defined $NOSPACE);
+
+ # Translate URL to lowercase if $TOLOWER defined
+ $url = to_lower($url) if (defined $TOLOWER);
+
+ $url = url($url) unless ref($url);
+
+ my $path = $url->path;
+
+ # trim path until only the basename is left
+ $path =~ s|(.*/)||;
+ my $dirname = ".$1";
+ if (!$HIER) {
+ $dirname = "";
+ }
+ elsif (! -d $dirname) {
+ mkdirp($dirname, 0775);
+ }
+
+ my $extra = ""; # something to make the name unique
+ my $suffix;
+
+ if ($KEEPEXT{lc($type)}) {
+ $suffix = ($path =~ m/\.(.*)/) ? $1 : "";
+ }
+ else {
+ $suffix = media_suffix($type);
+ }
+
+ $path =~ s|\..*||; # trim suffix
+ $path = "index" unless length $path;
+
+ while (1) {
+ # Construct a new file name
+ my $file = $dirname . $path . $extra;
+ $file .= ".$suffix" if $suffix;
+ # Check if it is unique
+ return $file unless -f $file;
+
+ # Try something extra
+ unless ($extra) {
+ $extra = "001";
+ next;
+ }
+ $extra++;
+ }
+}
+
+
+sub save
+{
+ my $name = shift;
+ #print "save($name,...)\n";
+ open(FILE, ">$name") || die "Can't save $name: $!";
+ binmode FILE;
+ print FILE $_[0];
+ close(FILE);
+}
+
+
+sub usage
+{
+ print <<""; exit 1;
+Usage: $progname [options] <URL>
+Allowed options are:
+ --auth=USER:PASS Set authentication credentials for web site
+ --depth=N Maximum depth to traverse (default is $MAX_DEPTH)
+ --hier Download into hierarchy (not all files into cwd)
+ --referer=URI Set initial referer header (or "NONE")
+ --iis Workaround IIS 2.0 bug by sending "Accept: */*" MIME
+ header; translates backslashes (\\) to forward slashes (/)
+ --keepext=type Keep file extension for MIME types (comma-separated list)
+ --limit=N A limit on the number documents to get (default is $MAX_DOCS)
+ --nospace Translate spaces URLs (not #fragments) to underscores (_)
+ --version Print version number and quit
+ --verbose More output
+ --quiet No output
+ --sleep=SECS Sleep between gets, ie. go slowly
+ --prefix=PREFIX Limit URLs to follow to those which begin with PREFIX
+ --tolower Translate all URLs to lowercase (useful with IIS servers)
+
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/makerandom b/Master/tlpkg/tlperl/bin/makerandom new file mode 100755 index 00000000000..29b21c6608c --- /dev/null +++ b/Master/tlpkg/tlperl/bin/makerandom @@ -0,0 +1,50 @@ +#!/usr/bin/perl -sI../lib -Ilib/ +## +## makerandom - interface to crypt::random +## +## Copyright (c) 1998, Vipul Ved Prakash. All rights reserved. +## This code is free software; you can redistribute it and/or modify +## it under the same terms as Perl itself. +## +## $Id: makerandom,v 1.1.1.1 2001/06/21 15:34:49 vipul Exp $ + +use Crypt::Random qw( makerandom makerandom_itv ); + +unless ( $size || $lower ) { + my $name = $0; + $name =~ s:.*/::; + print "usage: $name [options] \ + -size=bitsize \ + -strength=[01] \ + -dev=device \ + -lower=lower_bound \ + -upper=upper_bound \ + -num=quantity\n\n"; + exit 0; +} + + +$strength = 0 unless $strength; +my $i = 1; + $num = 1 unless $num; + +while ( $i++ <= $num ) { + +my $r; + +if ( $size ) { + $r = makerandom Size => $size, + Strength => $strength, + Device => $dev; +} + +if ( $lower ) { + $r = makerandom_itv Lower => $lower, + Upper => $upper, + Strength => $strength, + Device => $dev; +} + +print "$r\n"; + +} diff --git a/Master/tlpkg/tlperl/bin/makerandom.bat b/Master/tlpkg/tlperl/bin/makerandom.bat new file mode 100755 index 00000000000..672a5dd6812 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/makerandom.bat @@ -0,0 +1,66 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl -sI../lib -Ilib/
+#line 15
+##
+## makerandom - interface to crypt::random
+##
+## Copyright (c) 1998, Vipul Ved Prakash. All rights reserved.
+## This code is free software; you can redistribute it and/or modify
+## it under the same terms as Perl itself.
+##
+## $Id: makerandom,v 1.1.1.1 2001/06/21 15:34:49 vipul Exp $
+
+use Crypt::Random qw( makerandom makerandom_itv );
+
+unless ( $size || $lower ) {
+ my $name = $0;
+ $name =~ s:.*/::;
+ print "usage: $name [options] \
+ -size=bitsize \
+ -strength=[01] \
+ -dev=device \
+ -lower=lower_bound \
+ -upper=upper_bound \
+ -num=quantity\n\n";
+ exit 0;
+}
+
+
+$strength = 0 unless $strength;
+my $i = 1;
+ $num = 1 unless $num;
+
+while ( $i++ <= $num ) {
+
+my $r;
+
+if ( $size ) {
+ $r = makerandom Size => $size,
+ Strength => $strength,
+ Device => $dev;
+}
+
+if ( $lower ) {
+ $r = makerandom_itv Lower => $lower,
+ Upper => $upper,
+ Strength => $strength,
+ Device => $dev;
+}
+
+print "$r\n";
+
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/parinstallppd b/Master/tlpkg/tlperl/bin/parinstallppd new file mode 100755 index 00000000000..ea4c6385a66 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/parinstallppd @@ -0,0 +1,124 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Getopt::Long qw/GetOptions/; +use PAR::Dist::InstallPPD; + +our $VERSION = '0.02'; + +=pod + +=head1 NAME + +parinstallppd - Install PPD/PPM packages using PAR + +=head1 SYNOPSIS + +parinstallppd --help + +parinstallppd [-v ...] -u PPD-URI-OR-FILE + +=head1 DESCRIPTION + +This script converts packages for the I<Perl Package Manager> +which is specific to ActiveState's perl distributions to F<.par> +files and installs those using L<PAR::Dist>. + +It works much the same way as the L<ppd2par> tool but with an additional +installation step after the conversion. + +=head2 Parameters + + -u --uri + Set the place to fetch the .ppd file from. Can be an URL + (http://..., https://..., ftp://...) or a local file. + -v --verbose + Sets the verbose mode. + + --sa --selectarch + Regexp for selecting the implementation based on architecture. + Defaults to the currently running architecture. + --sp --selectperl + Regexp for selecting the implementation based on perl version. + Defaults to the currently running perl version (e.g. 5.8.8) and falls + back to the main version (e.g. 5.8) and then other sub-versions + (e.g. 5.8.7) + +=head1 SEE ALSO + +This tool is implemented using the L<PAR::Dist::InstallPPD> module. Please +refer to that module's documentation for details on how this all works. + +PAR has a mailing list, <par@perl.org>, that you can write to; send +an empty mail to <par-subscribe@perl.org> to join the list and +participate in the discussion. + +Please send bug reports to <bug-par-dist-fromcpan@rt.cpan.org>. + +The official PAR website may be of help, too: http://par.perl.org + +For details on the I<Perl Package Manager>, please refer to ActiveState's +website at L<http://activestate.com>. + +=head1 AUTHOR + +Steffen Mueller, E<lt>smueller at cpan dot orgE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2006 by Steffen Mueller + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut + +my $usage = <<"HERE"; +$0 --help # for help + +$0 [-v --no-docs] -u PPD-URI-OR-FILE + +This script converts packages for the I<Perl Package Manager> +which is specific to ActiveState's perl distributions to F<.par> +files and installs those using L<PAR::Dist>. + +It works much the same way as the L<ppd2par> tool but with an additional +installation step after the conversion. + +-u --uri + Set the place to fetch the .ppd file from. Can be an URL + (http://..., https://..., ftp://...) or a local file. +-v --verbose + Sets the verbose mode. + +--sa --selectarch + Regexp for selecting the implementation based on architecture. + Defaults to the currently running architecture. +--sp --selectperl + Regexp for selecting the implementation based on perl version. + Defaults to the currently running perl version (e.g. 5.8.8) and + falls back to the main version (e.g. 5.8) and then other + sub-versions (e.g. 5.8.7) +HERE + +my $uri; +my $v = 0; +my $sperl; +my $sarch; +GetOptions( + 'sa|selectarch=s' => \$sarch, + 'sp|selectperl=s' => \$sperl, + 'h|help' => sub { print $usage; exit(1) }, + 'u|uri=s' => \$uri, + 'v|verbose' => \$v, +); + +par_install_ppd( + uri => $uri, + ($v ? (verbose => 1 ) : ()), + ($sarch ? (selectarch => $sarch ) : ()), + ($sperl ? (selectperl => $sperl ) : ()), +); + diff --git a/Master/tlpkg/tlperl/bin/parinstallppd.bat b/Master/tlpkg/tlperl/bin/parinstallppd.bat new file mode 100755 index 00000000000..1a7478353b7 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/parinstallppd.bat @@ -0,0 +1,140 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+use strict;
+use warnings;
+
+use Getopt::Long qw/GetOptions/;
+use PAR::Dist::InstallPPD;
+
+our $VERSION = '0.02';
+
+=pod
+
+=head1 NAME
+
+parinstallppd - Install PPD/PPM packages using PAR
+
+=head1 SYNOPSIS
+
+parinstallppd --help
+
+parinstallppd [-v ...] -u PPD-URI-OR-FILE
+
+=head1 DESCRIPTION
+
+This script converts packages for the I<Perl Package Manager>
+which is specific to ActiveState's perl distributions to F<.par>
+files and installs those using L<PAR::Dist>.
+
+It works much the same way as the L<ppd2par> tool but with an additional
+installation step after the conversion.
+
+=head2 Parameters
+
+ -u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+ -v --verbose
+ Sets the verbose mode.
+
+ --sa --selectarch
+ Regexp for selecting the implementation based on architecture.
+ Defaults to the currently running architecture.
+ --sp --selectperl
+ Regexp for selecting the implementation based on perl version.
+ Defaults to the currently running perl version (e.g. 5.8.8) and falls
+ back to the main version (e.g. 5.8) and then other sub-versions
+ (e.g. 5.8.7)
+
+=head1 SEE ALSO
+
+This tool is implemented using the L<PAR::Dist::InstallPPD> module. Please
+refer to that module's documentation for details on how this all works.
+
+PAR has a mailing list, <par@perl.org>, that you can write to; send
+an empty mail to <par-subscribe@perl.org> to join the list and
+participate in the discussion.
+
+Please send bug reports to <bug-par-dist-fromcpan@rt.cpan.org>.
+
+The official PAR website may be of help, too: http://par.perl.org
+
+For details on the I<Perl Package Manager>, please refer to ActiveState's
+website at L<http://activestate.com>.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006 by Steffen Mueller
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
+
+my $usage = <<"HERE";
+$0 --help # for help
+
+$0 [-v --no-docs] -u PPD-URI-OR-FILE
+
+This script converts packages for the I<Perl Package Manager>
+which is specific to ActiveState's perl distributions to F<.par>
+files and installs those using L<PAR::Dist>.
+
+It works much the same way as the L<ppd2par> tool but with an additional
+installation step after the conversion.
+
+-u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+-v --verbose
+ Sets the verbose mode.
+
+--sa --selectarch
+ Regexp for selecting the implementation based on architecture.
+ Defaults to the currently running architecture.
+--sp --selectperl
+ Regexp for selecting the implementation based on perl version.
+ Defaults to the currently running perl version (e.g. 5.8.8) and
+ falls back to the main version (e.g. 5.8) and then other
+ sub-versions (e.g. 5.8.7)
+HERE
+
+my $uri;
+my $v = 0;
+my $sperl;
+my $sarch;
+GetOptions(
+ 'sa|selectarch=s' => \$sarch,
+ 'sp|selectperl=s' => \$sperl,
+ 'h|help' => sub { print $usage; exit(1) },
+ 'u|uri=s' => \$uri,
+ 'v|verbose' => \$v,
+);
+
+par_install_ppd(
+ uri => $uri,
+ ($v ? (verbose => 1 ) : ()),
+ ($sarch ? (selectarch => $sarch ) : ()),
+ ($sperl ? (selectperl => $sperl ) : ()),
+);
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/perl.exe b/Master/tlpkg/tlperl/bin/perl.exe Binary files differnew file mode 100755 index 00000000000..e66a18bb962 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perl.exe diff --git a/Master/tlpkg/tlperl/bin/perl5.10.1.exe b/Master/tlpkg/tlperl/bin/perl5.10.1.exe Binary files differnew file mode 100755 index 00000000000..e66a18bb962 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perl5.10.1.exe diff --git a/Master/tlpkg/tlperl/bin/perl510.dll b/Master/tlpkg/tlperl/bin/perl510.dll Binary files differnew file mode 100755 index 00000000000..4a533b76803 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perl510.dll diff --git a/Master/tlpkg/tlperl/bin/perlbug.bat b/Master/tlpkg/tlperl/bin/perlbug.bat new file mode 100755 index 00000000000..2d37b78d2ba --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perlbug.bat @@ -0,0 +1,1478 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+my $config_tag1 = '5.10.1 - Wed Jan 27 23:29:27 2010';
+
+my $patchlevel_date = 1250639291;
+my $patch_tags = '';
+my @patches = (
+ ''
+);
+
+use warnings;
+no warnings 'once'; # Eventually, the $::opt_ stuff should get cleaned up
+use strict;
+use Config;
+use File::Spec; # keep perlbug Perl 5.005 compatible
+use Getopt::Std;
+use File::Basename 'basename';
+
+sub paraprint;
+
+BEGIN {
+ eval { require Mail::Send;};
+ $::HaveSend = ($@ eq "");
+ eval { require Mail::Util; } ;
+ $::HaveUtil = ($@ eq "");
+ # use secure tempfiles wherever possible
+ eval { require File::Temp; };
+ $::HaveTemp = ($@ eq "");
+ eval { require Module::CoreList; };
+ $::HaveCoreList = ($@ eq "");
+};
+
+my $Version = "1.39";
+
+# Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
+# Changed in 1.07 to see more sendmail execs, and added pipe output.
+# Changed in 1.08 to use correct address for sendmail.
+# Changed in 1.09 to close the REP file before calling it up in the editor.
+# Also removed some old comments duplicated elsewhere.
+# Changed in 1.10 to run under VMS without Mail::Send; also fixed
+# temp filename generation.
+# Changed in 1.11 to clean up some text and removed Mail::Send deactivator.
+# Changed in 1.12 to check for editor errors, make save/send distinction
+# clearer and add $ENV{REPLYTO}.
+# Changed in 1.13 to hopefully make it more difficult to accidentally
+# send mail
+# Changed in 1.14 to make the prompts a little more clear on providing
+# helpful information. Also let file read fail gracefully.
+# Changed in 1.15 to add warnings to stop people using perlbug for non-bugs.
+# Also report selected environment variables.
+# Changed in 1.16 to include @INC, and allow user to re-edit if no changes.
+# Changed in 1.17 Win32 support added. GSAR 97-04-12
+# Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18
+# Changed in 1.19 '-ok' default not '-v'
+# add local patch information
+# warn on '-ok' if this is an old system; add '-okay'
+# Changed in 1.20 Added patchlevel.h reading and version/config checks
+# Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05
+# Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10
+# Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt
+# Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
+# Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
+# Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
+# Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
+# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
+# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000
+# Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000
+# Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000
+# Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000
+# Changed in 1.33 Don't require -t STDOUT for -ok.
+# Changed in 1.34 Added Message-Id RFOLEY 18-06-2002
+# Changed in 1.35 Use File::Temp (patch from Solar Designer) NWCLARK 28-02-2004
+# Changed in 1.36 Initial Module::CoreList support Alexandr Ciornii 11-07-2007
+# Changed in 1.37 Killed some string evals, rewrote most prose JESSE 2008-06-08
+# Changed in 1.38 Actually enforce the CoreList check,
+# Record the module the user enters if they do so
+# Refactor prompts to use common code JESSE 2008-06-08
+# Changed in 1.39 Trap mail sending failures (simple ones) so JESSE 2008-06-08
+# users might be able to recover their bug reports
+# Refactor mail sending routines
+# Unify message building code
+# Unify message header building
+# Fix "module" prompting to not squish "category" prompting
+# use warnings; (except 'once' warnings)
+# Unified report fingerprint/change detection code
+# Removed some labeled 'gotos'
+#TODO:
+# make sure failure (transmission-wise) of Mail::Send is accounted for.
+# (This may work now. Unsure of the original author's issue -JESSE 2008-06-08)
+# - Test -b option
+
+my( $file, $usefile, $cc, $address, $bugaddress, $testaddress, $thanksaddress,
+ $filename, $messageid, $domain, $subject, $from, $verbose, $ed, $outfile,
+ $fh, $me, $body, $andcc, %REP, $ok, $thanks, $progname,
+ $Is_MacOS, $Is_MSWin32, $Is_Linux, $Is_VMS, $Is_OpenBSD,
+ $report_about_module, $category, $severity,
+
+);
+
+my $perl_version = $^V ? sprintf("%vd", $^V) : $];
+
+my $config_tag2 = "$perl_version - $Config{cf_time}";
+
+Init();
+
+if ($::opt_h) { Help(); exit; }
+if ($::opt_d) { Dump(*STDOUT); exit; }
+if (!-t STDIN && !($ok and not $::opt_n)) {
+ paraprint <<"EOF";
+Please use $progname interactively. If you want to
+include a file, you can use the -f switch.
+EOF
+ die "\n";
+}
+
+Query();
+Edit() unless $usefile || ($ok and not $::opt_n);
+NowWhat();
+if ($outfile) {
+ save_message_to_disk($outfile);
+} else {
+ Send();
+ if ($thanks) {
+ print "\nThank you for taking the time to send a thank-you message!\n\n";
+ } else {
+ print "\nThank you for taking the time to file a bug report!\n\n";
+ }
+}
+
+exit;
+
+sub ask_for_alternatives { # (category|severity)
+ my $name = shift;
+ my %alts = (
+ 'category' => {
+ 'default' => 'core',
+ 'ok' => 'install',
+ # Inevitably some of these will end up in RT whatever we do:
+ 'thanks' => 'thanks',
+ 'opts' => [qw(core docs install library utilities)], # patch, notabug
+ },
+ 'severity' => {
+ 'default' => 'low',
+ 'ok' => 'none',
+ 'thanks' => 'none',
+ 'opts' => [qw(critical high medium low wishlist none)], # zero
+ },
+ );
+ die "Invalid alternative ($name) requested\n" unless grep(/^$name$/, keys %alts);
+ my $alt = "";
+ my $what = $ok || $thanks;
+ if ($what) {
+ $alt = $alts{$name}{$what};
+ } else {
+ my @alts = @{$alts{$name}{'opts'}};
+ print "\n\n";
+ paraprint <<EOF;
+Please pick a $name from the following list:
+
+ @alts
+EOF
+ my $err = 0;
+ do {
+ if ($err++ > 5) {
+ die "Invalid $name: aborting.\n";
+ }
+ $alt = _prompt('', "\u$name", $alts{$name}{'default'});
+ $alt ||= $alts{$name}{'default'};
+ } while !((($alt) = grep(/^$alt/i, @alts)));
+ }
+ lc $alt;
+}
+
+sub Init {
+ # -------- Setup --------
+
+ $Is_MSWin32 = $^O eq 'MSWin32';
+ $Is_VMS = $^O eq 'VMS';
+ $Is_Linux = lc($^O) eq 'linux';
+ $Is_OpenBSD = lc($^O) eq 'openbsd';
+ $Is_MacOS = $^O eq 'MacOS';
+
+ @ARGV = split m/\s+/,
+ MacPerl::Ask('Provide command line args here (-h for help):')
+ if $Is_MacOS && $MacPerl::Version =~ /App/;
+
+ if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:T")) { Help(); exit; };
+
+ # This comment is needed to notify metaconfig that we are
+ # using the $perladmin, $cf_by, and $cf_time definitions.
+
+ # -------- Configuration ---------
+
+ # perlbug address
+ $bugaddress = 'perlbug@perl.org';
+
+ # Test address
+ $testaddress = 'perlbug-test@perl.org';
+
+ # Thanks address
+ $thanksaddress = 'perl-thanks@perl.org';
+
+ if (basename ($0) =~ /^perlthanks/i) {
+ # invoked as perlthanks
+ $::opt_T = 1;
+ $::opt_C = 1; # don't send a copy to the local admin
+ }
+
+ if ($::opt_T) {
+ $thanks = 'thanks';
+ }
+
+ $progname = $thanks ? 'perlthanks' : 'perlbug';
+ # Target address
+ $address = $::opt_a || ($::opt_t ? $testaddress
+ : $thanks ? $thanksaddress : $bugaddress);
+
+ # Users address, used in message and in Reply-To header
+ $from = $::opt_r || "";
+
+ # Include verbose configuration information
+ $verbose = $::opt_v || 0;
+
+ # Subject of bug-report message
+ $subject = $::opt_s || "";
+
+ # Send a file
+ $usefile = ($::opt_f || 0);
+
+ # File to send as report
+ $file = $::opt_f || "";
+
+ # File to output to
+ $outfile = $::opt_F || "";
+
+ # Body of report
+ $body = $::opt_b || "";
+
+ # Editor
+ $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
+ || ($Is_VMS && "edit/tpu")
+ || ($Is_MSWin32 && "notepad")
+ || ($Is_MacOS && '')
+ || "vi";
+
+ # Not OK - provide build failure template by finessing OK report
+ if ($::opt_n) {
+ if (substr($::opt_n, 0, 2) eq 'ok' ) {
+ $::opt_o = substr($::opt_n, 1);
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # OK - send "OK" report for build on this system
+ $ok = '';
+ if ($::opt_o) {
+ if ($::opt_o eq 'k' or $::opt_o eq 'kay') {
+ my $age = time - $patchlevel_date;
+ if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) {
+ my $date = localtime $patchlevel_date;
+ print <<"EOF";
+"perlbug -ok" and "perlbug -nok" do not report on Perl versions which
+are more than 60 days old. This Perl version was constructed on
+$date. If you really want to report this, use
+"perlbug -okay" or "perlbug -nokay".
+EOF
+ exit();
+ }
+ # force these options
+ unless ($::opt_n) {
+ $::opt_S = 1; # don't prompt for send
+ $::opt_b = 1; # we have a body
+ $body = "Perl reported to build OK on this system.\n";
+ }
+ $::opt_C = 1; # don't send a copy to the local admin
+ $::opt_s = 1; # we have a subject line
+ $subject = ($::opt_n ? 'Not ' : '')
+ . "OK: perl $perl_version ${patch_tags}on"
+ ." $::Config{'archname'} $::Config{'osvers'} $subject";
+ $ok = 'ok';
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # Possible administrator addresses, in order of confidence
+ # (Note that cf_email is not mentioned to metaconfig, since
+ # we don't really want it. We'll just take it if we have to.)
+ #
+ # This has to be after the $ok stuff above because of the way
+ # that $::opt_C is forced.
+ $cc = $::opt_C ? "" : (
+ $::opt_c || $::Config{'perladmin'}
+ || $::Config{'cf_email'} || $::Config{'cf_by'}
+ );
+
+ if ($::HaveUtil) {
+ $domain = Mail::Util::maildomain();
+ } elsif ($Is_MSWin32) {
+ $domain = $ENV{'USERDOMAIN'};
+ } else {
+ require Sys::Hostname;
+ $domain = Sys::Hostname::hostname();
+ }
+
+ # Message-Id - rjsf
+ $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>";
+
+ # My username
+ $me = $Is_MSWin32 ? $ENV{'USERNAME'}
+ : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
+ : $Is_MacOS ? $ENV{'USER'}
+ : eval { getpwuid($<) }; # May be missing
+
+ $from = $::Config{'cf_email'}
+ if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me &&
+ ($me eq $::Config{'cf_by'});
+} # sub Init
+
+sub Query {
+ # Explain what perlbug is
+ unless ($ok) {
+ if ($thanks) {
+ paraprint <<'EOF';
+This program provides an easy way to send a thank-you message back to the
+authors and maintainers of perl.
+
+If you wish to submit a bug report, please run it without the -T flag
+(or run the program perlbug rather than perlthanks)
+EOF
+ } else {
+ paraprint <<"EOF";
+This program provides an easy way to create a message reporting a
+bug in the core perl distribution (along with tests or patches)
+to the volunteers who maintain perl at $address. To send a thank-you
+note to $thanksaddress instead of a bug report, please run 'perlthanks'.
+
+Please do not use $0 to send test messages, test whether perl
+works, or to report bugs in perl modules from CPAN.
+
+For help using perl, try posting to the Usenet newsgroup
+comp.lang.perl.misc.
+EOF
+ }
+ }
+
+ # Prompt for subject of message, if needed
+
+ if ($subject && TrivialSubject($subject)) {
+ $subject = '';
+ }
+
+ unless ($subject) {
+ print
+"First of all, please provide a subject for the message.\n";
+ if ( not $thanks) {
+ paraprint <<EOF;
+This should be a concise description of your bug or problem
+which will help the volunteers working to improve perl to categorize
+and resolve the issue. Be as specific and descriptive as
+you can. A subject like "perl bug" or "perl problem" will make it
+much less likely that your issue gets the attention it deserves.
+EOF
+ }
+
+ my $err = 0;
+ do {
+ $subject = _prompt('','Subject');
+ if ($err++ == 5) {
+ if ($thanks) {
+ $subject = 'Thanks for Perl';
+ } else {
+ die "Aborting.\n";
+ }
+ }
+ } while (TrivialSubject($subject));
+ }
+
+ # Prompt for return address, if needed
+ unless ($from) {
+ # Try and guess return address
+ my $guess;
+
+ $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
+ if ($Is_MacOS) {
+ require Mac::InternetConfig;
+ $guess = $Mac::InternetConfig::InternetConfig{
+ Mac::InternetConfig::kICEmail()
+ };
+ }
+
+ unless ($guess) {
+ # move $domain to where we can use it elsewhere
+ if ($domain) {
+ if ($Is_VMS && !$::Config{'d_socket'}) {
+ $guess = "$domain\:\:$me";
+ } else {
+ $guess = "$me\@$domain" if $domain;
+ }
+ }
+ }
+
+ if ($guess) {
+ unless ($ok) {
+ paraprint <<EOF;
+Perl's developers may need your email address to contact you for
+further information about your issue or to inform you when it is
+resolved. If the default shown is not your email address, please
+correct it.
+EOF
+ }
+ } else {
+ paraprint <<EOF;
+Please enter your full internet email address so that Perl's
+developers can contact you with questions about your issue or to
+inform you that it has been resolved.
+EOF
+ }
+
+ if ($ok && $guess) {
+ # use it
+ $from = $guess;
+ } else {
+ # verify it
+ $from = _prompt('','Your address',$guess);
+ $from = $guess if $from eq '';
+ }
+ }
+
+ if ($from eq $cc or $me eq $cc) {
+ # Try not to copy ourselves
+ $cc = "yourself";
+ }
+
+ # Prompt for administrator address, unless an override was given
+ if( !$::opt_C and !$::opt_c ) {
+ my $description = <<EOF;
+$0 can send a copy of this report to your local perl
+administrator. If the address below is wrong, please correct it,
+or enter 'none' or 'yourself' to not send a copy.
+EOF
+ my $entry = _prompt($description, "Local perl administrator", $cc);
+
+ if ($entry ne "") {
+ $cc = $entry;
+ $cc = '' if $me eq $cc;
+ }
+ }
+
+ $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i;
+ if ($cc) {
+ $andcc = " and $cc"
+ } else {
+ $andcc = ''
+ }
+
+ # Prompt for editor, if no override is given
+editor:
+ unless ($::opt_e || $::opt_f || $::opt_b) {
+
+ my $description;
+
+ chomp (my $common_end = <<"EOF");
+You will probably want to use a text editor to enter the body of
+your report. If "$ed" is the editor you want to use, then just press
+Enter, otherwise type in the name of the editor you would like to
+use.
+
+If you have already composed the body of your report, you may enter
+"file", and $0 will prompt you to enter the name of the file
+containing your report.
+EOF
+
+ if ($thanks) {
+ $description = <<"EOF";
+It's now time to compose your thank-you message.
+
+Some information about your local perl configuration will automatically
+be included at the end of your message, because we're curious about
+the different ways that people build and use perl. If you'd rather
+not share this information, you're welcome to delete it.
+
+$common_end
+EOF
+ } else {
+ $description = <<"EOF";
+It's now time to compose your bug report. Try to make the report
+concise but descriptive. Please include any detail which you think
+might be relevant or might help the volunteers working to improve
+perl. If you are reporting something that does not work as you think
+it should, please try to include examples of the actual result and of
+what you expected.
+
+Some information about your local perl configuration will automatically
+be included at the end of your report. If you are using an unusual
+version of perl, it would be useful if you could confirm that you
+can replicate the problem on a standard build of perl as well.
+
+$common_end
+EOF
+ }
+
+ my $entry = _prompt($description, "Editor", $ed);
+ $usefile = 0;
+ if ($entry eq "file") {
+ $usefile = 1;
+ } elsif ($entry ne "") {
+ $ed = $entry;
+ }
+ }
+ if ($::HaveCoreList && !$ok && !$thanks) {
+ my $description = <<EOF;
+If your bug is about a Perl module rather than a core language
+feature, please enter its name here. If it's not, just hit Enter
+to skip this question.
+EOF
+
+ my $entry = '';
+ while ($entry eq '') {
+ $entry = _prompt($description, 'Module');
+ my $first_release = Module::CoreList->first_release($entry);
+ if ($entry and not $first_release) {
+ paraprint <<EOF;
+$entry is not a "core" Perl module. Please check that you entered
+its name correctly. If it is correct, quit this program, try searching
+for $entry on http://rt.cpan.org, and report your issue there.
+EOF
+
+ $entry = '';
+ } elsif ($entry) {
+ $category ||= 'library';
+ $report_about_module = $entry;
+ last;
+ } else {
+ last;
+ }
+ }
+ }
+
+ # Prompt for category of bug
+ $category ||= ask_for_alternatives('category');
+
+ # Prompt for severity of bug
+ $severity ||= ask_for_alternatives('severity');
+
+ # Generate scratch file to edit report in
+ $filename = filename();
+
+ # Prompt for file to read report from, if needed
+ if ($usefile and !$file) {
+filename:
+ my $description = <<EOF;
+What is the name of the file that contains your report?
+EOF
+ my $entry = _prompt($description, "Filename");
+
+ if ($entry eq "") {
+ paraprint <<EOF;
+It seems you didn't enter a filename. Please choose to use a text
+editor or enter a filename.
+EOF
+ goto editor;
+ }
+
+ unless (-f $entry and -r $entry) {
+ paraprint <<EOF;
+'$entry' doesn't seem to be a readable file. You may have mistyped
+its name or may not have permission to read it.
+
+If you don't want to use a file as the content of your report, just
+hit Enter and you'll be able to select a text editor instead.
+EOF
+ goto filename;
+ }
+ $file = $entry;
+ }
+
+ # Generate report
+ open(REP,">$filename") or die "Unable to create report file '$filename': $!\n";
+ my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug')
+ : $::opt_n ? "build failure" : "success";
+
+ print REP <<EOF;
+This is a $reptype report for perl from $from,
+generated with the help of perlbug $Version running under perl $perl_version.
+
+EOF
+
+ if ($body) {
+ print REP $body;
+ } elsif ($usefile) {
+ open(F, "<$file")
+ or die "Unable to read report file from '$file': $!\n";
+ while (<F>) {
+ print REP $_
+ }
+ close(F) or die "Error closing '$file': $!";
+ } else {
+ if ($thanks) {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please enter your thank-you message here]
+
+
+
+[You're welcome to delete anything below this line]
+-----------------------------------------------------------------
+EOF
+ } else {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please describe your issue here]
+
+
+
+[Please do not change anything below this line]
+-----------------------------------------------------------------
+EOF
+ }
+ }
+ Dump(*REP);
+ close(REP) or die "Error closing report file: $!";
+
+ # Set up an initial report fingerprint so we can compare it later
+ _fingerprint_lines_in_report();
+
+} # sub Query
+
+sub Dump {
+ local(*OUT) = @_;
+
+ print OUT <<EFF;
+---
+Flags:
+ category=$category
+ severity=$severity
+EFF
+
+ if ($report_about_module ) {
+ print OUT <<EFF;
+ module=$report_about_module
+EFF
+ }
+ if ($::opt_A) {
+ print OUT <<EFF;
+ ack=no
+EFF
+ }
+ print OUT <<EFF;
+---
+EFF
+ print OUT "This perlbug was built using Perl $config_tag1\n",
+ "It is being executed now by Perl $config_tag2.\n\n"
+ if $config_tag2 ne $config_tag1;
+
+ print OUT <<EOF;
+Site configuration information for perl $perl_version:
+
+EOF
+ if ($::Config{cf_by} and $::Config{cf_time}) {
+ print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n";
+ }
+ print OUT Config::myconfig;
+
+ if (@patches) {
+ print OUT join "\n ", "Locally applied patches:", @patches;
+ print OUT "\n";
+ };
+
+ print OUT <<EOF;
+
+---
+\@INC for perl $perl_version:
+EOF
+ for my $i (@INC) {
+ print OUT " $i\n";
+ }
+
+ print OUT <<EOF;
+
+---
+Environment for perl $perl_version:
+EOF
+ my @env =
+ qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
+ push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
+ push @env, grep /^(?:PERL|LC_|LANG|CYGWIN)/, keys %ENV;
+ my %env;
+ @env{@env} = @env;
+ for my $env (sort keys %env) {
+ print OUT " $env",
+ exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
+ "\n";
+ }
+ if ($verbose) {
+ print OUT "\nComplete configuration data for perl $perl_version:\n\n";
+ my $value;
+ foreach (sort keys %::Config) {
+ $value = $::Config{$_};
+ $value =~ s/'/\\'/g;
+ print OUT "$_='$value'\n";
+ }
+ }
+} # sub Dump
+
+sub Edit {
+ # Edit the report
+ if ($usefile || $body) {
+ my $description = "Please make sure that the name of the editor you want to use is correct.";
+ my $entry = _prompt($description, 'Editor', $ed);
+ $ed = $entry unless $entry eq '';
+ }
+
+ _edit_file($ed);
+}
+
+sub _edit_file {
+ my $editor = shift;
+
+ my $report_written = 0;
+
+ while ( !$report_written ) {
+ if ($Is_MacOS) {
+ require ExtUtils::MakeMaker;
+ ExtUtils::MM_MacOS::launch_file($filename);
+ _prompt('', "Press Enter when done." );
+ } else { # we're not on oldschool mac os
+ my $exit_status = system("$editor $filename");
+ if ($exit_status) {
+ my $desc = <<EOF;
+The editor you chose ('$editor') could not be run!
+
+If you mistyped its name, please enter it now, otherwise just press Enter.
+EOF
+ my $entry = _prompt( $desc, 'Editor', $editor );
+ if ( $entry ne "" ) {
+ $editor = $entry;
+ next;
+ } else {
+ paraprint <<EOF;
+You may want to save your report to a file, so you can edit and
+mail it later.
+EOF
+ return;
+ }
+ }
+ }
+ return if ( $ok and not $::opt_n ) || $body;
+
+ # Check that we have a report that has some, eh, report in it.
+
+ unless ( _fingerprint_lines_in_report() ) {
+ my $description = <<EOF;
+It looks like you didn't enter a report. You may [r]etry your edit
+or [c]ancel this report.
+EOF
+ my $action = _prompt( $description, "Action (Retry/Cancel) " );
+ if ( $action =~ /^[re]/i ) { # <R>etry <E>dit
+ next;
+ } elsif ( $action =~ /^[cq]/i ) { # <C>ancel, <Q>uit
+ Cancel(); # cancel exits
+ }
+ }
+ # Ok. the user did what they needed to;
+ return;
+
+ }
+}
+
+
+sub Cancel {
+ 1 while unlink($filename); # remove all versions under VMS
+ print "\nQuitting without sending your message.\n";
+ exit(0);
+}
+
+sub NowWhat {
+ # Report is done, prompt for further action
+ if( !$::opt_S ) {
+ while(1) {
+ my $menu = <<EOF;
+
+
+You have finished composing your message. At this point, you have
+a few options. You can:
+
+ * [Se]end the message to $address$andcc,
+ * [D]isplay the message on the screen,
+ * [R]e-edit the message
+ * Display or change the message's [su]bject
+ * Save the message to a [f]ile to mail at another time
+ * [Q]uit without sending a message
+
+EOF
+ retry:
+ print $menu;
+ my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)");;
+ print "\n";
+ if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
+ if ( SaveMessage() ) { exit }
+ } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
+ # Display the message
+ open(REP, "<$filename") or die "Couldn't open file '$filename': $!\n";
+ while (<REP>) { print $_ }
+ close(REP) or die "Error closing report file '$filename': $!";
+ } elsif ($action =~ /^su/i) { # <Su>bject
+ my $reply = _prompt( "Subject: $subject", "If the above subject is fine, press Enter. Otherwise, type a replacement now\nSubject");
+ if ($reply ne '') {
+ unless (TrivialSubject($reply)) {
+ $subject = $reply;
+ print "Subject: $subject\n";
+ }
+ }
+ } elsif ($action =~ /^se/i) { # <S>end
+ # Send the message
+ my $reply = _prompt( "Are you certain you want to send this message?", 'Please type "yes" if you are','no');
+ if ($reply =~ /^yes$/) {
+ last;
+ } else {
+ paraprint <<EOF;
+You didn't type "yes", so your message has not yet been sent.
+EOF
+ }
+ } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit
+ # edit the message
+ Edit();
+ } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
+ Cancel();
+ } elsif ($action =~ /^s/i) {
+ paraprint <<EOF;
+The command you entered was ambiguous. Please type "send", "save" or "subject".
+EOF
+ }
+ }
+ }
+} # sub NowWhat
+
+sub TrivialSubject {
+ my $subject = shift;
+ if ($subject =~
+ /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
+ length($subject) < 4 ||
+ $subject !~ /\s/) {
+ print "\nThe subject you entered wasn't very descriptive. Please try again.\n\n";
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub SaveMessage {
+ my $file_save = $outfile || "$progname.rep";
+ my $file = _prompt( '', "Name of file to save message in", $file_save );
+ save_message_to_disk($file) || return undef;
+ print "\n";
+ paraprint <<EOF;
+A copy of your message has been saved in '$file' for you to
+send to '$address' with your normal mail client.
+EOF
+}
+
+sub Send {
+
+ # Message has been accepted for transmission -- Send the message
+
+ # on linux certain "mail" implementations won't accept the subject
+ # as "~s subject" and thus the Subject header will be corrupted
+ # so don't use Mail::Send to be safe
+ eval {
+ if ( $::HaveSend && !$Is_Linux && !$Is_OpenBSD ) {
+ _send_message_mailsend();
+ } elsif ($Is_VMS) {
+ _send_message_vms();
+ } else {
+ _send_message_sendmail();
+ }
+ };
+
+ if ( my $error = $@ ) {
+ paraprint <<EOF;
+$0 has detected an error while trying to send your message: $error.
+
+Your message may not have been sent. You will now have a chance to save a copy to disk.
+EOF
+ SaveMessage();
+ return;
+ }
+
+ 1 while unlink($filename); # remove all versions under VMS
+} # sub Send
+
+sub Help {
+ print <<EOF;
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run "$0" interactively from a command
+line without any special arguments and follow the prompts.
+
+Advanced usage:
+
+$0 [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
+ [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
+$0 [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay]
+
+
+Options:
+
+ -v Include Verbose configuration data in the report
+ -f File containing the body of the report. Use this to
+ quickly send a prepared message.
+ -F File to output the resulting mail message to, instead of mailing.
+ -S Send without asking for confirmation.
+ -a Address to send the report to. Defaults to '$address'.
+ -c Address to send copy of report to. Defaults to '$cc'.
+ -C Don't send copy to administrator.
+ -s Subject to include with the message. You will be prompted
+ if you don't supply one on the command line.
+ -b Body of the report. If not included on the command line, or
+ in a file with -f, you will get a chance to edit the message.
+ -r Your return address. The program will ask you to confirm
+ this if you don't give it here.
+ -e Editor to use.
+ -t Test mode. The target address defaults to '$testaddress'.
+ -T Thank-you mode. The target address defaults to '$thanksaddress'.
+ -d Data mode. This prints out your configuration data, without mailing
+ anything. You can use this with -v to get more complete data.
+ -A Don't send a bug received acknowledgement to the return address.
+ -ok Report successful build on this system to perl porters
+ (use alone or with -v). Only use -ok if *everything* was ok:
+ if there were *any* problems at all, use -nok.
+ -okay As -ok but allow report from old builds.
+ -nok Report unsuccessful build on this system to perl porters
+ (use alone or with -v). You must describe what went wrong
+ in the body of the report which you will be asked to edit.
+ -nokay As -nok but allow report from old builds.
+ -h Print this help message.
+
+EOF
+}
+
+sub filename {
+ if ($::HaveTemp) {
+ # Good. Use a secure temp file
+ my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
+ close($fh);
+ return $filename;
+ } else {
+ # Bah. Fall back to doing things less securely.
+ my $dir = File::Spec->tmpdir();
+ $filename = "bugrep0$$";
+ $filename++ while -e File::Spec->catfile($dir, $filename);
+ $filename = File::Spec->catfile($dir, $filename);
+ }
+}
+
+sub paraprint {
+ my @paragraphs = split /\n{2,}/, "@_";
+ for (@paragraphs) { # implicit local $_
+ s/(\S)\s*\n/$1 /g;
+ write;
+ print "\n";
+ }
+}
+
+sub _prompt {
+ my ($explanation, $prompt, $default) = (@_);
+ if ($explanation) {
+ print "\n\n";
+ paraprint $explanation;
+ }
+ print $prompt. ($default ? " [$default]" :''). ": ";
+ my $result = scalar(<>);
+ chomp($result);
+ $result =~ s/^\s*(.*?)\s*$/$1/s;
+ if ($default && $result eq '') {
+ return $default;
+ } else {
+ return $result;
+ }
+}
+
+sub _build_header {
+ my %attr = (@_);
+
+ my $head = '';
+ for my $header (keys %attr) {
+ $head .= "$header: ".$attr{$header}."\n";
+ }
+ return $head;
+}
+
+sub _message_headers {
+ my %headers = ( To => $address, Subject => $subject );
+ $headers{'Cc'} = $cc if ($cc);
+ $headers{'Message-Id'} = $messageid if ($messageid);
+ $headers{'Reply-To'} = $from if ($from);
+ return \%headers;
+}
+
+sub build_complete_message {
+ my $content = _build_header(%{_message_headers()}) . "\n\n";
+ open( REP, "<$filename" ) or die "Couldn't open file '$filename': $!\n";
+ while (<REP>) { $content .= $_; }
+ close(REP) or die "Error closing report file '$filename': $!";
+ return $content;
+}
+
+sub save_message_to_disk {
+ my $file = shift;
+
+ open OUTFILE, ">$file" or do { warn "Couldn't open '$file': $!\n"; return undef};
+ print OUTFILE build_complete_message();
+ close(OUTFILE) or do { warn "Error closing $file: $!"; return undef };
+ print "\nMessage saved.\n";
+ return 1;
+}
+
+sub _send_message_vms {
+ if ( ( $address =~ /@/ and $address !~ /^\w+%"/ )
+ or ( $cc =~ /@/ and $cc !~ /^\w+%"/ ) ) {
+ my $prefix;
+ foreach ( qw[ IN MX SMTP UCX PONY WINS ], '' ) {
+ $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"};
+ }
+ $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/;
+ $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/;
+ }
+ $subject =~ s/"/""/g;
+ $address =~ s/"/""/g;
+ $cc =~ s/"/""/g;
+ my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
+ if ($sts) {
+ die "Can't spawn off mail (leaving bug report in $filename): $sts";
+ }
+}
+
+sub _send_message_mailsend {
+ my $msg = Mail::Send->new();
+ my %headers = %{_message_headers()};
+ for my $key ( keys %headers) {
+ $msg->add($key => $headers{$key});
+ }
+
+ $fh = $msg->open;
+ open(REP, "<$filename") or die "Couldn't open '$filename': $!\n";
+ while (<REP>) { print $fh $_ }
+ close(REP) or die "Error closing $filename: $!";
+ $fh->close;
+
+ print "\nMessage sent.\n";
+}
+
+sub _probe_for_sendmail {
+ my $sendmail = "";
+ for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) {
+ $sendmail = $_, last if -e $_;
+ }
+ if ( $^O eq 'os2' and $sendmail eq "" ) {
+ my $path = $ENV{PATH};
+ $path =~ s:\\:/:;
+ my @path = split /$Config{'path_sep'}/, $path;
+ for (@path) {
+ $sendmail = "$_/sendmail", last if -e "$_/sendmail";
+ $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe";
+ }
+ }
+ return $sendmail;
+}
+
+sub _send_message_sendmail {
+ my $sendmail = _probe_for_sendmail();
+ unless ($sendmail) {
+ paraprint(<<"EOF"), die "\n";
+It appears that there is no program which looks like "sendmail" on
+your system and that the Mail::Send library from CPAN isn't available.
+Because of this, there's no easy way to automatically send your
+message.
+
+A copy of your message has been saved in '$filename' for you to
+send to '$address' with your normal mail client.
+EOF
+ }
+
+ open( SENDMAIL, "|$sendmail -t -oi" )
+ || die "'|$sendmail -t -oi' failed: $!";
+ print SENDMAIL build_complete_message();
+ if ( close(SENDMAIL) ) {
+ print "\nMessage sent\n";
+ } else {
+ warn "\nSendmail returned status '", $? >> 8, "'\n";
+ }
+}
+
+
+
+# a strange way to check whether any significant editing
+# has been done: check whether any new non-empty lines
+# have been added.
+
+sub _fingerprint_lines_in_report {
+ my $new_lines = 0;
+ # read in the report template once so that
+ # we can track whether the user does any editing.
+ # yes, *all* whitespace is ignored.
+
+ open(REP, "<$filename") or die "Unable to open report file '$filename': $!\n";
+ while (my $line = <REP>) {
+ $line =~ s/\s+//g;
+ $new_lines++ if (!$REP{$line});
+
+ }
+ close(REP) or die "Error closing report file '$filename': $!";
+ # returns the number of lines with content that wasn't there when last we looked
+ return $new_lines;
+}
+
+
+
+format STDOUT =
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
+$_
+.
+
+__END__
+
+=head1 NAME
+
+perlbug - how to submit bug reports on Perl
+
+=head1 SYNOPSIS
+
+B<perlbug>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]>
+S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]>
+S<[ B<-r> I<returnaddress> ]>
+S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]>
+S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
+ S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
+
+B<perlthanks>
+
+=head1 DESCRIPTION
+
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run it interactively from a command
+line without any special arguments and follow the prompts.
+
+If you have found a bug with a non-standard port (one that was not
+part of the I<standard distribution>), a binary distribution, or a
+non-core module (such as Tk, DBI, etc), then please see the
+documentation that came with that distribution to determine the
+correct place to report bugs.
+
+If you are unable to send your report using B<perlbug> (most likely
+because your system doesn't have a way to send mail that perlbug
+recognizes), you may be able to use this tool to compose your report
+and save it to a file which you can then send to B<perlbug@perl.org>
+using your regular mail client.
+
+In extreme cases, B<perlbug> may not work well enough on your system
+to guide you through composing a bug report. In those cases, you
+may be able to use B<perlbug -d> to get system configuration
+information to include in a manually composed bug report to
+B<perlbug@perl.org>.
+
+
+When reporting a bug, please run through this checklist:
+
+=over 4
+
+=item What version of Perl you are running?
+
+Type C<perl -v> at the command line to find out.
+
+=item Are you running the latest released version of perl?
+
+Look at http://www.perl.org/ to find out. If you are not using the
+latest released version, please try to replicate your bug on the
+latest stable release.
+
+Note that reports about bugs in old versions of Perl, especially
+those which indicate you haven't also tested the current stable
+release of Perl, are likely to receive less attention from the
+volunteers who build and maintain Perl than reports about bugs in
+the current release.
+
+This tool isn't apropriate for reporting bugs in any version
+prior to Perl 5.0.
+
+=item Are you sure what you have is a bug?
+
+A significant number of the bug reports we get turn out to be
+documented features in Perl. Make sure the issue you've run into
+isn't intentional by glancing through the documentation that comes
+with the Perl distribution.
+
+Given the sheer volume of Perl documentation, this isn't a trivial
+undertaking, but if you can point to documentation that suggests
+the behaviour you're seeing is I<wrong>, your issue is likely to
+receive more attention. You may want to start with B<perldoc>
+L<perltrap> for pointers to common traps that new (and experienced)
+Perl programmers run into.
+
+If you're unsure of the meaning of an error message you've run
+across, B<perldoc> L<perldiag> for an explanation. If the message
+isn't in perldiag, it probably isn't generated by Perl. You may
+have luck consulting your operating system documentation instead.
+
+If you are on a non-UNIX platform B<perldoc> L<perlport>, as some
+features may be unimplemented or work differently.
+
+You may be able to figure out what's going wrong using the Perl
+debugger. For information about how to use the debugger B<perldoc>
+L<perldebug>.
+
+=item Do you have a proper test case?
+
+The easier it is to reproduce your bug, the more likely it will be
+fixed -- if nobody can duplicate your problem, it probably won't be
+addressed.
+
+A good test case has most of these attributes: short, simple code;
+few dependencies on external commands, modules, or libraries; no
+platform-dependent code (unless it's a platform-specific bug);
+clear, simple documentation.
+
+A good test case is almost always a good candidate to be included in
+Perl's test suite. If you have the time, consider writing your test case so
+that it can be easily included into the standard test suite.
+
+=item Have you included all relevant information?
+
+Be sure to include the B<exact> error messages, if any.
+"Perl gave an error" is not an exact error message.
+
+If you get a core dump (or equivalent), you may use a debugger
+(B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug
+report.
+
+NOTE: unless your Perl has been compiled with debug info
+(often B<-g>), the stack trace is likely to be somewhat hard to use
+because it will most probably contain only the function names and not
+their arguments. If possible, recompile your Perl with debug info and
+reproduce the crash and the stack trace.
+
+=item Can you describe the bug in plain English?
+
+The easier it is to understand a reproducible bug, the more likely
+it will be fixed. Any insight you can provide into the problem
+will help a great deal. In other words, try to analyze the problem
+(to the extent you can) and report your discoveries.
+
+=item Can you fix the bug yourself?
+
+A bug report which I<includes a patch to fix it> will almost
+definitely be fixed. When sending a patch, please use the C<diff>
+program with the C<-u> option to generate "unified" diff files.
+Bug reports with patches are likely to receive significantly more
+attention and interest than those without patches.
+
+Your patch may be returned with requests for changes, or requests for more
+detailed explanations about your fix.
+
+Here are a few hints for creating high-quality patches:
+
+Make sure the patch is not reversed (the first argument to diff is
+typically the original file, the second argument your changed file).
+Make sure you test your patch by applying it with the C<patch>
+program before you send it on its way. Try to follow the same style
+as the code you are trying to patch. Make sure your patch really
+does work (C<make test>, if the thing you're patching is covered
+by Perl's test suite).
+
+=item Can you use C<perlbug> to submit the report?
+
+B<perlbug> will, amongst other things, ensure your report includes
+crucial information about your version of perl. If C<perlbug> is
+unable to mail your report after you have typed it in, you may have
+to compose the message yourself, add the output produced by C<perlbug
+-d> and email it to B<perlbug@perl.org>. If, for some reason, you
+cannot run C<perlbug> at all on your system, be sure to include the
+entire output produced by running C<perl -V> (note the uppercase V).
+
+Whether you use C<perlbug> or send the email manually, please make
+your Subject line informative. "a bug" is not informative. Neither
+is "perl crashes" nor is "HELP!!!". These don't help. A compact
+description of what's wrong is fine.
+
+=item Can you use C<perlbug> to submit a thank-you note?
+
+Yes, you can do this by either using the C<-T> option, or by invoking
+the program as C<perlthanks>. Thank-you notes are good. It makes people
+smile.
+
+=back
+
+Having done your bit, please be prepared to wait, to be told the
+bug is in your code, or possibly to get no reply at all. The
+volunteers who maintain Perl are busy folks, so if your problem is
+an obvious bug in your own code, is difficult to understand or is
+a duplicate of an existing report, you may not receive a personal
+reply.
+
+If it is important to you that your bug be fixed, do monitor the
+perl5-porters@perl.org mailing list and the commit logs to development
+versions of Perl, and encourage the maintainers with kind words or
+offers of frosty beverages. (Please do be kind to the maintainers.
+Harassing or flaming them is likely to have the opposite effect of
+the one you want.)
+
+Feel free to update the ticket about your bug on http://rt.perl.org
+if a new version of Perl is released and your bug is still present.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-a>
+
+Address to send the report to. Defaults to B<perlbug@perl.org>.
+
+=item B<-A>
+
+Don't send a bug received acknowledgement to the reply address.
+Generally it is only a sensible to use this option if you are a
+perl maintainer actively watching perl porters for your message to
+arrive.
+
+=item B<-b>
+
+Body of the report. If not included on the command line, or
+in a file with B<-f>, you will get a chance to edit the message.
+
+=item B<-C>
+
+Don't send copy to administrator.
+
+=item B<-c>
+
+Address to send copy of report to. Defaults to the address of the
+local perl administrator (recorded when perl was built).
+
+=item B<-d>
+
+Data mode (the default if you redirect or pipe output). This prints out
+your configuration data, without mailing anything. You can use this
+with B<-v> to get more complete data.
+
+=item B<-e>
+
+Editor to use.
+
+=item B<-f>
+
+File containing the body of the report. Use this to quickly send a
+prepared message.
+
+=item B<-F>
+
+File to output the results to instead of sending as an email. Useful
+particularly when running perlbug on a machine with no direct internet
+connection.
+
+=item B<-h>
+
+Prints a brief summary of the options.
+
+=item B<-ok>
+
+Report successful build on this system to perl porters. Forces B<-S>
+and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only
+prompts for a return address if it cannot guess it (for use with
+B<make>). Honors return address specified with B<-r>. You can use this
+with B<-v> to get more complete data. Only makes a report if this
+system is less than 60 days old.
+
+=item B<-okay>
+
+As B<-ok> except it will report on older systems.
+
+=item B<-nok>
+
+Report unsuccessful build on this system. Forces B<-C>. Forces and
+supplies a value for B<-s>, then requires you to edit the report
+and say what went wrong. Alternatively, a prepared report may be
+supplied using B<-f>. Only prompts for a return address if it
+cannot guess it (for use with B<make>). Honors return address
+specified with B<-r>. You can use this with B<-v> to get more
+complete data. Only makes a report if this system is less than 60
+days old.
+
+=item B<-nokay>
+
+As B<-nok> except it will report on older systems.
+
+=item B<-r>
+
+Your return address. The program will ask you to confirm its default
+if you don't use this option.
+
+=item B<-S>
+
+Send without asking for confirmation.
+
+=item B<-s>
+
+Subject to include with the message. You will be prompted if you don't
+supply one on the command line.
+
+=item B<-t>
+
+Test mode. The target address defaults to B<perlbug-test@perl.org>.
+
+=item B<-T>
+
+Send a thank-you note instead of a bug report.
+
+=item B<-v>
+
+Include verbose configuration data in the report.
+
+=back
+
+=head1 AUTHORS
+
+Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently
+I<doc>tored by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>),
+Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington
+(E<lt>gnat@frii.comE<gt>), Charles F. Randall (E<lt>cfr@pobox.comE<gt>),
+Mike Guy (E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop
+(E<lt>domo@computer.orgE<gt>), Hugo van der Sanden (E<lt>hv@crypt.org<gt>),
+Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
+(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
+Richard Foley (E<lt>richard.foley@rfi.netE<gt>), and Jesse Vincent
+(E<lt>jesse@bestpractical.com<gt>).
+
+=head1 SEE ALSO
+
+perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1),
+diff(1), patch(1), dbx(1), gdb(1)
+
+=head1 BUGS
+
+None known (guess what must have been used to report them?)
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/perldoc b/Master/tlpkg/tlperl/bin/perldoc new file mode 100755 index 00000000000..48f9b79ba42 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perldoc @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +require 5; +BEGIN { $^W = 1 if $ENV{'PERLDOCDEBUG'} } +use Pod::Perldoc; +exit( Pod::Perldoc->run() ); + diff --git a/Master/tlpkg/tlperl/bin/perldoc.bat b/Master/tlpkg/tlperl/bin/perldoc.bat new file mode 100755 index 00000000000..a6fc80ed1da --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perldoc.bat @@ -0,0 +1,23 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+require 5;
+BEGIN { $^W = 1 if $ENV{'PERLDOCDEBUG'} }
+use Pod::Perldoc;
+exit( Pod::Perldoc->run() );
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/perlglob.bat b/Master/tlpkg/tlperl/bin/perlglob.bat new file mode 100755 index 00000000000..f4a81850873 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perlglob.bat @@ -0,0 +1,69 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+use File::DosGlob;
+$| = 1;
+while (@ARGV) {
+ my $arg = shift;
+ my @m = File::DosGlob::doglob(1,$arg);
+ print (@m ? join("\0", sort @m) : $arg);
+ print "\0" if @ARGV;
+}
+__END__
+
+=head1 NAME
+
+perlglob.bat - a more capable perlglob.exe replacement
+
+=head1 SYNOPSIS
+
+ @perlfiles = glob "..\\pe?l/*.p?";
+ print <..\\pe?l/*.p?>;
+
+ # more efficient version
+ > perl -MFile::DosGlob=glob -e "print <../pe?l/*.p?>"
+
+=head1 DESCRIPTION
+
+This file is a portable replacement for perlglob.exe. It
+is largely compatible with perlglob.exe (the Microsoft setargv.obj
+version) in all but one respect--it understands wildcards in
+directory components.
+
+It prints null-separated filenames to standard output.
+
+For details of the globbing features implemented, see
+L<File::DosGlob>.
+
+While one may replace perlglob.exe with this, usage by overriding
+CORE::glob with File::DosGlob::glob should be much more efficient,
+because it avoids launching a separate process, and is therefore
+strongly recommended. See L<perlsub> for details of overriding
+builtins.
+
+=head1 AUTHOR
+
+Gurusamy Sarathy <gsar@activestate.com>
+
+=head1 SEE ALSO
+
+perl
+
+File::DosGlob
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/perlglob.exe b/Master/tlpkg/tlperl/bin/perlglob.exe Binary files differnew file mode 100755 index 00000000000..ba5b1d47623 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perlglob.exe diff --git a/Master/tlpkg/tlperl/bin/perlivp.bat b/Master/tlpkg/tlperl/bin/perlivp.bat new file mode 100755 index 00000000000..c44e6a85615 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perlivp.bat @@ -0,0 +1,456 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# perlivp v5.10.1
+
+sub usage {
+ warn "@_\n" if @_;
+ print << " EOUSAGE";
+Usage:
+
+ $0 [-a] [-p] [-v] | [-h]
+
+ -a Run all tests (default is to skip .ph tests)
+ -p Print a preface before each test telling what it will test.
+ -v Verbose mode in which extra information about test results
+ is printed. Test failures always print out some extra information
+ regardless of whether or not this switch is set.
+ -h Prints this help message.
+ EOUSAGE
+ exit;
+}
+
+use vars qw(%opt); # allow testing with older versions (do not use our)
+
+@opt{ qw/? H h P p V v/ } = qw(0 0 0 0 0 0 0);
+
+while ($ARGV[0] =~ /^-/) {
+ $ARGV[0] =~ s/^-//;
+ for my $flag (split(//,$ARGV[0])) {
+ usage() if '?' =~ /\Q$flag/;
+ usage() if 'h' =~ /\Q$flag/;
+ usage() if 'H' =~ /\Q$flag/;
+ usage("unknown flag: `$flag'") unless 'HhPpVva' =~ /\Q$flag/;
+ warn "$0: `$flag' flag already set\n" if $opt{$flag}++;
+ }
+ shift;
+}
+
+$opt{p}++ if $opt{P};
+$opt{v}++ if $opt{V};
+
+my $pass__total = 0;
+my $error_total = 0;
+my $tests_total = 0;
+
+my $perlpath = 'C:\strawberry\perl\bin\perl.exe';
+my $useithreads = 'define';
+
+print "## Checking Perl binary via variable `\$perlpath' = $perlpath.\n" if $opt{'p'};
+
+if (-x $perlpath) {
+ print "## Perl binary `$perlpath' appears executable.\n" if $opt{'v'};
+ print "ok 1\n";
+ $pass__total++;
+}
+else {
+ print "# Perl binary `$perlpath' does not appear executable.\n";
+ print "not ok 1\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking Perl version via variable `\$]'.\n" if $opt{'p'};
+
+my $ivp_VERSION = "5.010001";
+
+if ($ivp_VERSION eq $]) {
+ print "## Perl version `$]' appears installed as expected.\n" if $opt{'v'};
+ print "ok 2\n";
+ $pass__total++;
+}
+else {
+ print "# Perl version `$]' installed, expected $ivp_VERSION.\n";
+ print "not ok 2\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking roots of the Perl library directory tree via variable `\@INC'.\n" if $opt{'p'};
+
+my $INC_total = 0;
+my $INC_there = 0;
+foreach (@INC) {
+ next if $_ eq '.'; # skip -d test here
+ if ($^O eq 'MacOS') {
+ next if $_ eq ':'; # skip -d test here
+ next if $_ eq 'Dev:Pseudo:'; # why is this in @INC?
+ }
+ if (-d $_) {
+ print "## Perl \@INC directory `$_' exists.\n" if $opt{'v'};
+ $INC_there++;
+ }
+ else {
+ print "# Perl \@INC directory `$_' does not appear to exist.\n";
+ }
+ $INC_total++;
+}
+if ($INC_total == $INC_there) {
+ print "ok 3\n";
+ $pass__total++;
+}
+else {
+ print "not ok 3\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking installations of modules necessary for ivp.\n" if $opt{'p'};
+
+my $needed_total = 0;
+my $needed_there = 0;
+foreach (qw(Config.pm ExtUtils/Installed.pm)) {
+ $@ = undef;
+ $needed_total++;
+ eval "require \"$_\";";
+ if (!$@) {
+ print "## Module `$_' appears to be installed.\n" if $opt{'v'};
+ $needed_there++;
+ }
+ else {
+ print "# Needed module `$_' does not appear to be properly installed.\n";
+ }
+ $@ = undef;
+}
+if ($needed_total == $needed_there) {
+ print "ok 4\n";
+ $pass__total++;
+}
+else {
+ print "not ok 4\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking installations of extensions built with perl.\n" if $opt{'p'};
+
+use Config;
+
+my $extensions_total = 0;
+my $extensions_there = 0;
+if (defined($Config{'extensions'})) {
+ my @extensions = split(/\s+/,$Config{'extensions'});
+ foreach (@extensions) {
+ next if ($_ eq '');
+ if ( $useithreads !~ /define/i ) {
+ next if ($_ eq 'threads');
+ next if ($_ eq 'threads/shared');
+ }
+ # that's a distribution name, not a module name
+ next if $_ eq 'IO/Compress';
+ next if $_ eq 'Devel/DProf';
+ # test modules
+ next if $_ eq 'XS/APItest';
+ next if $_ eq 'XS/Typemap';
+ # VMS$ perl -e "eval ""require \""Devel/DProf.pm\"";"" print $@"
+ # \NT> perl -e "eval \"require 'Devel/DProf.pm'\"; print $@"
+ # DProf: run perl with -d to use DProf.
+ # Compilation failed in require at (eval 1) line 1.
+ eval " require \"$_.pm\"; ";
+ if (!$@) {
+ print "## Module `$_' appears to be installed.\n" if $opt{'v'};
+ $extensions_there++;
+ }
+ else {
+ print "# Required module `$_' does not appear to be properly installed.\n";
+ $@ = undef;
+ }
+ $extensions_total++;
+ }
+
+ # A silly name for a module (that hopefully won't ever exist).
+ # Note that this test serves more as a check of the validity of the
+ # actuall required module tests above.
+ my $unnecessary = 'bLuRfle';
+
+ if (!grep(/$unnecessary/, @extensions)) {
+ $@ = undef;
+ eval " require \"$unnecessary.pm\"; ";
+ if ($@) {
+ print "## Unnecessary module `$unnecessary' does not appear to be installed.\n" if $opt{'v'};
+ }
+ else {
+ print "# Unnecessary module `$unnecessary' appears to be installed.\n";
+ $extensions_there++;
+ }
+ }
+ $@ = undef;
+}
+if ($extensions_total == $extensions_there) {
+ print "ok 5\n";
+ $pass__total++;
+}
+else {
+ print "not ok 5\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+print "## Checking installations of later additional extensions.\n" if $opt{'p'};
+
+use ExtUtils::Installed;
+
+my $installed_total = 0;
+my $installed_there = 0;
+my $version_check = 0;
+my $installed = ExtUtils::Installed -> new();
+my @modules = $installed -> modules();
+my @missing = ();
+my $version = undef;
+for (@modules) {
+ $installed_total++;
+ # Consider it there if it contains one or more files,
+ # and has zero missing files,
+ # and has a defined version
+ $version = undef;
+ $version = $installed -> version($_);
+ if ($version) {
+ print "## $_; $version\n" if $opt{'v'};
+ $version_check++;
+ }
+ else {
+ print "# $_; NO VERSION\n" if $opt{'v'};
+ }
+ $version = undef;
+ @missing = ();
+ @missing = $installed -> validate($_);
+
+ # .bs files are optional
+ @missing = grep { ! /\.bs$/ } @missing;
+ # man files are often compressed
+ @missing = grep { ! ( -s "$_.gz" || -s "$_.bz2" ) } @missing;
+
+ if ($#missing >= 0) {
+ print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
+ print '# ',join(' ',@missing),"\n";
+ }
+ elsif ($#missing == -1) {
+ $installed_there++;
+ }
+ @missing = ();
+}
+if (($installed_total == $installed_there) &&
+ ($installed_total == $version_check)) {
+ print "ok 6\n";
+ $pass__total++;
+}
+else {
+ print "not ok 6\n";
+ $error_total++;
+}
+$tests_total++;
+
+
+if ($opt{'a'}) {
+print "## Checking installations of *.h -> *.ph header files.\n" if $opt{'p'};
+my $ph_there = 0;
+my $var = undef;
+my $val = undef;
+my $h_file = undef;
+# Just about "any" C implementation ought to have a stdio.h (even if
+# Config.pm may not list a i_stdio var).
+my @ph_files = qw(stdio.ph);
+# Add the ones that we know that perl thinks are there:
+while (($var, $val) = each %Config) {
+ if ($var =~ m/i_(.+)/ && $val eq 'define') {
+ $h_file = $1;
+ # Some header and symbol names don't match for hysterical raisins.
+ $h_file = 'arpa/inet' if $h_file eq 'arpainet';
+ $h_file = 'netinet/in' if $h_file eq 'niin';
+ $h_file = 'netinet/tcp' if $h_file eq 'netinettcp';
+ $h_file = 'sys/resource' if $h_file eq 'sysresrc';
+ $h_file = 'sys/select' if $h_file eq 'sysselct';
+ $h_file = 'sys/security' if $h_file eq 'syssecrt';
+ $h_file = 'rpcsvc/dbm' if $h_file eq 'rpcsvcdbm';
+ # This ought to distinguish syslog from sys/syslog.
+ # (NB syslog.ph is heavily used for the DBI pre-requisites).
+ $h_file =~ s{^sys(\w.+)}{sys/$1} unless $h_file eq 'syslog';
+ push(@ph_files, "$h_file.ph");
+ }
+}
+#foreach (qw(stdio.ph syslog.ph)) {
+foreach (@ph_files) {
+ $@ = undef;
+ eval "require \"$_\";";
+ if (!$@) {
+ print "## Perl header `$_' appears to be installed.\n" if $opt{'v'};
+ $ph_there++;
+ }
+ else {
+ print "# Perl header `$_' does not appear to be properly installed.\n";
+ }
+ $@ = undef;
+}
+
+if (scalar(@ph_files) == $ph_there) {
+ print "ok 7\n";
+ $pass__total++;
+}
+else {
+ print "not ok 7\n";
+ $error_total++;
+}
+$tests_total++;
+}
+else {
+ print "## Skip checking of *.ph header files.\n" if $opt{'p'};
+}
+
+# Final report (rather than feed ousrselves to Test::Harness::runtests()
+# we simply format some output on our own to keep things simple and
+# easier to "fix" - at least for now.
+
+if ($error_total == 0 && $tests_total) {
+ print "All tests successful.\n";
+} elsif ($tests_total==0){
+ die "FAILED--no tests were run for some reason.\n";
+} else {
+ my $rate = 0.0;
+ if ($tests_total > 0) { $rate = sprintf "%.2f", 100.0 * ($pass__total / $tests_total); }
+ printf " %d/%d subtests failed, %.2f%% okay.\n",
+ $error_total, $tests_total, $rate;
+}
+
+=head1 NAME
+
+perlivp - Perl Installation Verification Procedure
+
+=head1 SYNOPSIS
+
+B<perlivp> [B<-a>] [B<-p>] [B<-v>] [B<-h>]
+
+=head1 DESCRIPTION
+
+The B<perlivp> program is set up at Perl source code build time to test the
+Perl version it was built under. It can be used after running:
+
+ make install
+
+(or your platform's equivalent procedure) to verify that B<perl> and its
+libraries have been installed correctly. A correct installation is verified
+by output that looks like:
+
+ ok 1
+ ok 2
+
+etc.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-h> help
+
+Prints out a brief help message.
+
+=item B<-a> run all tests
+
+Normally tests for optional features are skipped. With -a all tests
+are executed.
+
+=item B<-p> print preface
+
+Gives a description of each test prior to performing it.
+
+=item B<-v> verbose
+
+Gives more detailed information about each test, after it has been performed.
+Note that any failed tests ought to print out some extra information whether
+or not -v is thrown.
+
+=back
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item * print "# Perl binary `$perlpath' does not appear executable.\n";
+
+Likely to occur for a perl binary that was not properly installed.
+Correct by conducting a proper installation.
+
+=item * print "# Perl version `$]' installed, expected $ivp_VERSION.\n";
+
+Likely to occur for a perl that was not properly installed.
+Correct by conducting a proper installation.
+
+=item * print "# Perl \@INC directory `$_' does not appear to exist.\n";
+
+Likely to occur for a perl library tree that was not properly installed.
+Correct by conducting a proper installation.
+
+=item * print "# Needed module `$_' does not appear to be properly installed.\n";
+
+One of the two modules that is used by perlivp was not present in the
+installation. This is a serious error since it adversely affects perlivp's
+ability to function. You may be able to correct this by performing a
+proper perl installation.
+
+=item * print "# Required module `$_' does not appear to be properly installed.\n";
+
+An attempt to C<eval "require $module"> failed, even though the list of
+extensions indicated that it should succeed. Correct by conducting a proper
+installation.
+
+=item * print "# Unnecessary module `bLuRfle' appears to be installed.\n";
+
+This test not coming out ok could indicate that you have in fact installed
+a bLuRfle.pm module or that the C<eval " require \"$module_name.pm\"; ">
+test may give misleading results with your installation of perl. If yours
+is the latter case then please let the author know.
+
+=item * print "# file",+($#missing == 0) ? '' : 's'," missing from installation:\n";
+
+One or more files turned up missing according to a run of
+C<ExtUtils::Installed -E<gt> validate()> over your installation.
+Correct by conducting a proper installation.
+
+=item * print "# Perl header `$_' does not appear to be properly installed.\n";
+
+Correct by running B<h2ph> over your system's C header files. If necessary,
+edit the resulting *.ph files to eliminate perl syntax errors.
+
+=back
+
+For further information on how to conduct a proper installation consult the
+INSTALL file that comes with the perl source and the README file for your
+platform.
+
+=head1 AUTHOR
+
+Peter Prymmer
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/perlthanks.bat b/Master/tlpkg/tlperl/bin/perlthanks.bat new file mode 100755 index 00000000000..2d37b78d2ba --- /dev/null +++ b/Master/tlpkg/tlperl/bin/perlthanks.bat @@ -0,0 +1,1478 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+my $config_tag1 = '5.10.1 - Wed Jan 27 23:29:27 2010';
+
+my $patchlevel_date = 1250639291;
+my $patch_tags = '';
+my @patches = (
+ ''
+);
+
+use warnings;
+no warnings 'once'; # Eventually, the $::opt_ stuff should get cleaned up
+use strict;
+use Config;
+use File::Spec; # keep perlbug Perl 5.005 compatible
+use Getopt::Std;
+use File::Basename 'basename';
+
+sub paraprint;
+
+BEGIN {
+ eval { require Mail::Send;};
+ $::HaveSend = ($@ eq "");
+ eval { require Mail::Util; } ;
+ $::HaveUtil = ($@ eq "");
+ # use secure tempfiles wherever possible
+ eval { require File::Temp; };
+ $::HaveTemp = ($@ eq "");
+ eval { require Module::CoreList; };
+ $::HaveCoreList = ($@ eq "");
+};
+
+my $Version = "1.39";
+
+# Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
+# Changed in 1.07 to see more sendmail execs, and added pipe output.
+# Changed in 1.08 to use correct address for sendmail.
+# Changed in 1.09 to close the REP file before calling it up in the editor.
+# Also removed some old comments duplicated elsewhere.
+# Changed in 1.10 to run under VMS without Mail::Send; also fixed
+# temp filename generation.
+# Changed in 1.11 to clean up some text and removed Mail::Send deactivator.
+# Changed in 1.12 to check for editor errors, make save/send distinction
+# clearer and add $ENV{REPLYTO}.
+# Changed in 1.13 to hopefully make it more difficult to accidentally
+# send mail
+# Changed in 1.14 to make the prompts a little more clear on providing
+# helpful information. Also let file read fail gracefully.
+# Changed in 1.15 to add warnings to stop people using perlbug for non-bugs.
+# Also report selected environment variables.
+# Changed in 1.16 to include @INC, and allow user to re-edit if no changes.
+# Changed in 1.17 Win32 support added. GSAR 97-04-12
+# Changed in 1.18 add '-ok' option for reporting build success. CFR 97-06-18
+# Changed in 1.19 '-ok' default not '-v'
+# add local patch information
+# warn on '-ok' if this is an old system; add '-okay'
+# Changed in 1.20 Added patchlevel.h reading and version/config checks
+# Changed in 1.21 Added '-nok' for reporting build failure DFD 98-05-05
+# Changed in 1.22 Heavy reformatting & minor bugfixes HVDS 98-05-10
+# Changed in 1.23 Restore -ok(ay): say 'success'; don't prompt
+# Changed in 1.24 Added '-F<file>' to save report HVDS 98-07-01
+# Changed in 1.25 Warn on failure to open save file. HVDS 98-07-12
+# Changed in 1.26 Don't require -t STDIN for -ok. HVDS 98-07-15
+# Changed in 1.27 Added Mac OS and File::Spec support CNANDOR 99-07-27
+# Changed in 1.28 Additional questions for Perlbugtron RFOLEY 20.03.2000
+# Changed in 1.29 Perlbug(tron): auto(-ok), short prompts RFOLEY 05-05-2000
+# Changed in 1.30 Added warnings on failure to open files MSTEVENS 13-07-2000
+# Changed in 1.31 Add checks on close().Fix my $var unless. TJENNESS 26-07-2000
+# Changed in 1.32 Use File::Spec->tmpdir TJENNESS 20-08-2000
+# Changed in 1.33 Don't require -t STDOUT for -ok.
+# Changed in 1.34 Added Message-Id RFOLEY 18-06-2002
+# Changed in 1.35 Use File::Temp (patch from Solar Designer) NWCLARK 28-02-2004
+# Changed in 1.36 Initial Module::CoreList support Alexandr Ciornii 11-07-2007
+# Changed in 1.37 Killed some string evals, rewrote most prose JESSE 2008-06-08
+# Changed in 1.38 Actually enforce the CoreList check,
+# Record the module the user enters if they do so
+# Refactor prompts to use common code JESSE 2008-06-08
+# Changed in 1.39 Trap mail sending failures (simple ones) so JESSE 2008-06-08
+# users might be able to recover their bug reports
+# Refactor mail sending routines
+# Unify message building code
+# Unify message header building
+# Fix "module" prompting to not squish "category" prompting
+# use warnings; (except 'once' warnings)
+# Unified report fingerprint/change detection code
+# Removed some labeled 'gotos'
+#TODO:
+# make sure failure (transmission-wise) of Mail::Send is accounted for.
+# (This may work now. Unsure of the original author's issue -JESSE 2008-06-08)
+# - Test -b option
+
+my( $file, $usefile, $cc, $address, $bugaddress, $testaddress, $thanksaddress,
+ $filename, $messageid, $domain, $subject, $from, $verbose, $ed, $outfile,
+ $fh, $me, $body, $andcc, %REP, $ok, $thanks, $progname,
+ $Is_MacOS, $Is_MSWin32, $Is_Linux, $Is_VMS, $Is_OpenBSD,
+ $report_about_module, $category, $severity,
+
+);
+
+my $perl_version = $^V ? sprintf("%vd", $^V) : $];
+
+my $config_tag2 = "$perl_version - $Config{cf_time}";
+
+Init();
+
+if ($::opt_h) { Help(); exit; }
+if ($::opt_d) { Dump(*STDOUT); exit; }
+if (!-t STDIN && !($ok and not $::opt_n)) {
+ paraprint <<"EOF";
+Please use $progname interactively. If you want to
+include a file, you can use the -f switch.
+EOF
+ die "\n";
+}
+
+Query();
+Edit() unless $usefile || ($ok and not $::opt_n);
+NowWhat();
+if ($outfile) {
+ save_message_to_disk($outfile);
+} else {
+ Send();
+ if ($thanks) {
+ print "\nThank you for taking the time to send a thank-you message!\n\n";
+ } else {
+ print "\nThank you for taking the time to file a bug report!\n\n";
+ }
+}
+
+exit;
+
+sub ask_for_alternatives { # (category|severity)
+ my $name = shift;
+ my %alts = (
+ 'category' => {
+ 'default' => 'core',
+ 'ok' => 'install',
+ # Inevitably some of these will end up in RT whatever we do:
+ 'thanks' => 'thanks',
+ 'opts' => [qw(core docs install library utilities)], # patch, notabug
+ },
+ 'severity' => {
+ 'default' => 'low',
+ 'ok' => 'none',
+ 'thanks' => 'none',
+ 'opts' => [qw(critical high medium low wishlist none)], # zero
+ },
+ );
+ die "Invalid alternative ($name) requested\n" unless grep(/^$name$/, keys %alts);
+ my $alt = "";
+ my $what = $ok || $thanks;
+ if ($what) {
+ $alt = $alts{$name}{$what};
+ } else {
+ my @alts = @{$alts{$name}{'opts'}};
+ print "\n\n";
+ paraprint <<EOF;
+Please pick a $name from the following list:
+
+ @alts
+EOF
+ my $err = 0;
+ do {
+ if ($err++ > 5) {
+ die "Invalid $name: aborting.\n";
+ }
+ $alt = _prompt('', "\u$name", $alts{$name}{'default'});
+ $alt ||= $alts{$name}{'default'};
+ } while !((($alt) = grep(/^$alt/i, @alts)));
+ }
+ lc $alt;
+}
+
+sub Init {
+ # -------- Setup --------
+
+ $Is_MSWin32 = $^O eq 'MSWin32';
+ $Is_VMS = $^O eq 'VMS';
+ $Is_Linux = lc($^O) eq 'linux';
+ $Is_OpenBSD = lc($^O) eq 'openbsd';
+ $Is_MacOS = $^O eq 'MacOS';
+
+ @ARGV = split m/\s+/,
+ MacPerl::Ask('Provide command line args here (-h for help):')
+ if $Is_MacOS && $MacPerl::Version =~ /App/;
+
+ if (!getopts("Adhva:s:b:f:F:r:e:SCc:to:n:T")) { Help(); exit; };
+
+ # This comment is needed to notify metaconfig that we are
+ # using the $perladmin, $cf_by, and $cf_time definitions.
+
+ # -------- Configuration ---------
+
+ # perlbug address
+ $bugaddress = 'perlbug@perl.org';
+
+ # Test address
+ $testaddress = 'perlbug-test@perl.org';
+
+ # Thanks address
+ $thanksaddress = 'perl-thanks@perl.org';
+
+ if (basename ($0) =~ /^perlthanks/i) {
+ # invoked as perlthanks
+ $::opt_T = 1;
+ $::opt_C = 1; # don't send a copy to the local admin
+ }
+
+ if ($::opt_T) {
+ $thanks = 'thanks';
+ }
+
+ $progname = $thanks ? 'perlthanks' : 'perlbug';
+ # Target address
+ $address = $::opt_a || ($::opt_t ? $testaddress
+ : $thanks ? $thanksaddress : $bugaddress);
+
+ # Users address, used in message and in Reply-To header
+ $from = $::opt_r || "";
+
+ # Include verbose configuration information
+ $verbose = $::opt_v || 0;
+
+ # Subject of bug-report message
+ $subject = $::opt_s || "";
+
+ # Send a file
+ $usefile = ($::opt_f || 0);
+
+ # File to send as report
+ $file = $::opt_f || "";
+
+ # File to output to
+ $outfile = $::opt_F || "";
+
+ # Body of report
+ $body = $::opt_b || "";
+
+ # Editor
+ $ed = $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT}
+ || ($Is_VMS && "edit/tpu")
+ || ($Is_MSWin32 && "notepad")
+ || ($Is_MacOS && '')
+ || "vi";
+
+ # Not OK - provide build failure template by finessing OK report
+ if ($::opt_n) {
+ if (substr($::opt_n, 0, 2) eq 'ok' ) {
+ $::opt_o = substr($::opt_n, 1);
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # OK - send "OK" report for build on this system
+ $ok = '';
+ if ($::opt_o) {
+ if ($::opt_o eq 'k' or $::opt_o eq 'kay') {
+ my $age = time - $patchlevel_date;
+ if ($::opt_o eq 'k' and $age > 60 * 24 * 60 * 60 ) {
+ my $date = localtime $patchlevel_date;
+ print <<"EOF";
+"perlbug -ok" and "perlbug -nok" do not report on Perl versions which
+are more than 60 days old. This Perl version was constructed on
+$date. If you really want to report this, use
+"perlbug -okay" or "perlbug -nokay".
+EOF
+ exit();
+ }
+ # force these options
+ unless ($::opt_n) {
+ $::opt_S = 1; # don't prompt for send
+ $::opt_b = 1; # we have a body
+ $body = "Perl reported to build OK on this system.\n";
+ }
+ $::opt_C = 1; # don't send a copy to the local admin
+ $::opt_s = 1; # we have a subject line
+ $subject = ($::opt_n ? 'Not ' : '')
+ . "OK: perl $perl_version ${patch_tags}on"
+ ." $::Config{'archname'} $::Config{'osvers'} $subject";
+ $ok = 'ok';
+ } else {
+ Help();
+ exit();
+ }
+ }
+
+ # Possible administrator addresses, in order of confidence
+ # (Note that cf_email is not mentioned to metaconfig, since
+ # we don't really want it. We'll just take it if we have to.)
+ #
+ # This has to be after the $ok stuff above because of the way
+ # that $::opt_C is forced.
+ $cc = $::opt_C ? "" : (
+ $::opt_c || $::Config{'perladmin'}
+ || $::Config{'cf_email'} || $::Config{'cf_by'}
+ );
+
+ if ($::HaveUtil) {
+ $domain = Mail::Util::maildomain();
+ } elsif ($Is_MSWin32) {
+ $domain = $ENV{'USERDOMAIN'};
+ } else {
+ require Sys::Hostname;
+ $domain = Sys::Hostname::hostname();
+ }
+
+ # Message-Id - rjsf
+ $messageid = "<$::Config{'version'}_${$}_".time."\@$domain>";
+
+ # My username
+ $me = $Is_MSWin32 ? $ENV{'USERNAME'}
+ : $^O eq 'os2' ? $ENV{'USER'} || $ENV{'LOGNAME'}
+ : $Is_MacOS ? $ENV{'USER'}
+ : eval { getpwuid($<) }; # May be missing
+
+ $from = $::Config{'cf_email'}
+ if !$from && $::Config{'cf_email'} && $::Config{'cf_by'} && $me &&
+ ($me eq $::Config{'cf_by'});
+} # sub Init
+
+sub Query {
+ # Explain what perlbug is
+ unless ($ok) {
+ if ($thanks) {
+ paraprint <<'EOF';
+This program provides an easy way to send a thank-you message back to the
+authors and maintainers of perl.
+
+If you wish to submit a bug report, please run it without the -T flag
+(or run the program perlbug rather than perlthanks)
+EOF
+ } else {
+ paraprint <<"EOF";
+This program provides an easy way to create a message reporting a
+bug in the core perl distribution (along with tests or patches)
+to the volunteers who maintain perl at $address. To send a thank-you
+note to $thanksaddress instead of a bug report, please run 'perlthanks'.
+
+Please do not use $0 to send test messages, test whether perl
+works, or to report bugs in perl modules from CPAN.
+
+For help using perl, try posting to the Usenet newsgroup
+comp.lang.perl.misc.
+EOF
+ }
+ }
+
+ # Prompt for subject of message, if needed
+
+ if ($subject && TrivialSubject($subject)) {
+ $subject = '';
+ }
+
+ unless ($subject) {
+ print
+"First of all, please provide a subject for the message.\n";
+ if ( not $thanks) {
+ paraprint <<EOF;
+This should be a concise description of your bug or problem
+which will help the volunteers working to improve perl to categorize
+and resolve the issue. Be as specific and descriptive as
+you can. A subject like "perl bug" or "perl problem" will make it
+much less likely that your issue gets the attention it deserves.
+EOF
+ }
+
+ my $err = 0;
+ do {
+ $subject = _prompt('','Subject');
+ if ($err++ == 5) {
+ if ($thanks) {
+ $subject = 'Thanks for Perl';
+ } else {
+ die "Aborting.\n";
+ }
+ }
+ } while (TrivialSubject($subject));
+ }
+
+ # Prompt for return address, if needed
+ unless ($from) {
+ # Try and guess return address
+ my $guess;
+
+ $guess = $ENV{'REPLY-TO'} || $ENV{'REPLYTO'} || '';
+ if ($Is_MacOS) {
+ require Mac::InternetConfig;
+ $guess = $Mac::InternetConfig::InternetConfig{
+ Mac::InternetConfig::kICEmail()
+ };
+ }
+
+ unless ($guess) {
+ # move $domain to where we can use it elsewhere
+ if ($domain) {
+ if ($Is_VMS && !$::Config{'d_socket'}) {
+ $guess = "$domain\:\:$me";
+ } else {
+ $guess = "$me\@$domain" if $domain;
+ }
+ }
+ }
+
+ if ($guess) {
+ unless ($ok) {
+ paraprint <<EOF;
+Perl's developers may need your email address to contact you for
+further information about your issue or to inform you when it is
+resolved. If the default shown is not your email address, please
+correct it.
+EOF
+ }
+ } else {
+ paraprint <<EOF;
+Please enter your full internet email address so that Perl's
+developers can contact you with questions about your issue or to
+inform you that it has been resolved.
+EOF
+ }
+
+ if ($ok && $guess) {
+ # use it
+ $from = $guess;
+ } else {
+ # verify it
+ $from = _prompt('','Your address',$guess);
+ $from = $guess if $from eq '';
+ }
+ }
+
+ if ($from eq $cc or $me eq $cc) {
+ # Try not to copy ourselves
+ $cc = "yourself";
+ }
+
+ # Prompt for administrator address, unless an override was given
+ if( !$::opt_C and !$::opt_c ) {
+ my $description = <<EOF;
+$0 can send a copy of this report to your local perl
+administrator. If the address below is wrong, please correct it,
+or enter 'none' or 'yourself' to not send a copy.
+EOF
+ my $entry = _prompt($description, "Local perl administrator", $cc);
+
+ if ($entry ne "") {
+ $cc = $entry;
+ $cc = '' if $me eq $cc;
+ }
+ }
+
+ $cc = '' if $cc =~ /^(none|yourself|me|myself|ourselves)$/i;
+ if ($cc) {
+ $andcc = " and $cc"
+ } else {
+ $andcc = ''
+ }
+
+ # Prompt for editor, if no override is given
+editor:
+ unless ($::opt_e || $::opt_f || $::opt_b) {
+
+ my $description;
+
+ chomp (my $common_end = <<"EOF");
+You will probably want to use a text editor to enter the body of
+your report. If "$ed" is the editor you want to use, then just press
+Enter, otherwise type in the name of the editor you would like to
+use.
+
+If you have already composed the body of your report, you may enter
+"file", and $0 will prompt you to enter the name of the file
+containing your report.
+EOF
+
+ if ($thanks) {
+ $description = <<"EOF";
+It's now time to compose your thank-you message.
+
+Some information about your local perl configuration will automatically
+be included at the end of your message, because we're curious about
+the different ways that people build and use perl. If you'd rather
+not share this information, you're welcome to delete it.
+
+$common_end
+EOF
+ } else {
+ $description = <<"EOF";
+It's now time to compose your bug report. Try to make the report
+concise but descriptive. Please include any detail which you think
+might be relevant or might help the volunteers working to improve
+perl. If you are reporting something that does not work as you think
+it should, please try to include examples of the actual result and of
+what you expected.
+
+Some information about your local perl configuration will automatically
+be included at the end of your report. If you are using an unusual
+version of perl, it would be useful if you could confirm that you
+can replicate the problem on a standard build of perl as well.
+
+$common_end
+EOF
+ }
+
+ my $entry = _prompt($description, "Editor", $ed);
+ $usefile = 0;
+ if ($entry eq "file") {
+ $usefile = 1;
+ } elsif ($entry ne "") {
+ $ed = $entry;
+ }
+ }
+ if ($::HaveCoreList && !$ok && !$thanks) {
+ my $description = <<EOF;
+If your bug is about a Perl module rather than a core language
+feature, please enter its name here. If it's not, just hit Enter
+to skip this question.
+EOF
+
+ my $entry = '';
+ while ($entry eq '') {
+ $entry = _prompt($description, 'Module');
+ my $first_release = Module::CoreList->first_release($entry);
+ if ($entry and not $first_release) {
+ paraprint <<EOF;
+$entry is not a "core" Perl module. Please check that you entered
+its name correctly. If it is correct, quit this program, try searching
+for $entry on http://rt.cpan.org, and report your issue there.
+EOF
+
+ $entry = '';
+ } elsif ($entry) {
+ $category ||= 'library';
+ $report_about_module = $entry;
+ last;
+ } else {
+ last;
+ }
+ }
+ }
+
+ # Prompt for category of bug
+ $category ||= ask_for_alternatives('category');
+
+ # Prompt for severity of bug
+ $severity ||= ask_for_alternatives('severity');
+
+ # Generate scratch file to edit report in
+ $filename = filename();
+
+ # Prompt for file to read report from, if needed
+ if ($usefile and !$file) {
+filename:
+ my $description = <<EOF;
+What is the name of the file that contains your report?
+EOF
+ my $entry = _prompt($description, "Filename");
+
+ if ($entry eq "") {
+ paraprint <<EOF;
+It seems you didn't enter a filename. Please choose to use a text
+editor or enter a filename.
+EOF
+ goto editor;
+ }
+
+ unless (-f $entry and -r $entry) {
+ paraprint <<EOF;
+'$entry' doesn't seem to be a readable file. You may have mistyped
+its name or may not have permission to read it.
+
+If you don't want to use a file as the content of your report, just
+hit Enter and you'll be able to select a text editor instead.
+EOF
+ goto filename;
+ }
+ $file = $entry;
+ }
+
+ # Generate report
+ open(REP,">$filename") or die "Unable to create report file '$filename': $!\n";
+ my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug')
+ : $::opt_n ? "build failure" : "success";
+
+ print REP <<EOF;
+This is a $reptype report for perl from $from,
+generated with the help of perlbug $Version running under perl $perl_version.
+
+EOF
+
+ if ($body) {
+ print REP $body;
+ } elsif ($usefile) {
+ open(F, "<$file")
+ or die "Unable to read report file from '$file': $!\n";
+ while (<F>) {
+ print REP $_
+ }
+ close(F) or die "Error closing '$file': $!";
+ } else {
+ if ($thanks) {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please enter your thank-you message here]
+
+
+
+[You're welcome to delete anything below this line]
+-----------------------------------------------------------------
+EOF
+ } else {
+ print REP <<'EOF';
+
+-----------------------------------------------------------------
+[Please describe your issue here]
+
+
+
+[Please do not change anything below this line]
+-----------------------------------------------------------------
+EOF
+ }
+ }
+ Dump(*REP);
+ close(REP) or die "Error closing report file: $!";
+
+ # Set up an initial report fingerprint so we can compare it later
+ _fingerprint_lines_in_report();
+
+} # sub Query
+
+sub Dump {
+ local(*OUT) = @_;
+
+ print OUT <<EFF;
+---
+Flags:
+ category=$category
+ severity=$severity
+EFF
+
+ if ($report_about_module ) {
+ print OUT <<EFF;
+ module=$report_about_module
+EFF
+ }
+ if ($::opt_A) {
+ print OUT <<EFF;
+ ack=no
+EFF
+ }
+ print OUT <<EFF;
+---
+EFF
+ print OUT "This perlbug was built using Perl $config_tag1\n",
+ "It is being executed now by Perl $config_tag2.\n\n"
+ if $config_tag2 ne $config_tag1;
+
+ print OUT <<EOF;
+Site configuration information for perl $perl_version:
+
+EOF
+ if ($::Config{cf_by} and $::Config{cf_time}) {
+ print OUT "Configured by $::Config{cf_by} at $::Config{cf_time}.\n\n";
+ }
+ print OUT Config::myconfig;
+
+ if (@patches) {
+ print OUT join "\n ", "Locally applied patches:", @patches;
+ print OUT "\n";
+ };
+
+ print OUT <<EOF;
+
+---
+\@INC for perl $perl_version:
+EOF
+ for my $i (@INC) {
+ print OUT " $i\n";
+ }
+
+ print OUT <<EOF;
+
+---
+Environment for perl $perl_version:
+EOF
+ my @env =
+ qw(PATH LD_LIBRARY_PATH LANG PERL_BADLANG SHELL HOME LOGDIR LANGUAGE);
+ push @env, $Config{ldlibpthname} if $Config{ldlibpthname} ne '';
+ push @env, grep /^(?:PERL|LC_|LANG|CYGWIN)/, keys %ENV;
+ my %env;
+ @env{@env} = @env;
+ for my $env (sort keys %env) {
+ print OUT " $env",
+ exists $ENV{$env} ? "=$ENV{$env}" : ' (unset)',
+ "\n";
+ }
+ if ($verbose) {
+ print OUT "\nComplete configuration data for perl $perl_version:\n\n";
+ my $value;
+ foreach (sort keys %::Config) {
+ $value = $::Config{$_};
+ $value =~ s/'/\\'/g;
+ print OUT "$_='$value'\n";
+ }
+ }
+} # sub Dump
+
+sub Edit {
+ # Edit the report
+ if ($usefile || $body) {
+ my $description = "Please make sure that the name of the editor you want to use is correct.";
+ my $entry = _prompt($description, 'Editor', $ed);
+ $ed = $entry unless $entry eq '';
+ }
+
+ _edit_file($ed);
+}
+
+sub _edit_file {
+ my $editor = shift;
+
+ my $report_written = 0;
+
+ while ( !$report_written ) {
+ if ($Is_MacOS) {
+ require ExtUtils::MakeMaker;
+ ExtUtils::MM_MacOS::launch_file($filename);
+ _prompt('', "Press Enter when done." );
+ } else { # we're not on oldschool mac os
+ my $exit_status = system("$editor $filename");
+ if ($exit_status) {
+ my $desc = <<EOF;
+The editor you chose ('$editor') could not be run!
+
+If you mistyped its name, please enter it now, otherwise just press Enter.
+EOF
+ my $entry = _prompt( $desc, 'Editor', $editor );
+ if ( $entry ne "" ) {
+ $editor = $entry;
+ next;
+ } else {
+ paraprint <<EOF;
+You may want to save your report to a file, so you can edit and
+mail it later.
+EOF
+ return;
+ }
+ }
+ }
+ return if ( $ok and not $::opt_n ) || $body;
+
+ # Check that we have a report that has some, eh, report in it.
+
+ unless ( _fingerprint_lines_in_report() ) {
+ my $description = <<EOF;
+It looks like you didn't enter a report. You may [r]etry your edit
+or [c]ancel this report.
+EOF
+ my $action = _prompt( $description, "Action (Retry/Cancel) " );
+ if ( $action =~ /^[re]/i ) { # <R>etry <E>dit
+ next;
+ } elsif ( $action =~ /^[cq]/i ) { # <C>ancel, <Q>uit
+ Cancel(); # cancel exits
+ }
+ }
+ # Ok. the user did what they needed to;
+ return;
+
+ }
+}
+
+
+sub Cancel {
+ 1 while unlink($filename); # remove all versions under VMS
+ print "\nQuitting without sending your message.\n";
+ exit(0);
+}
+
+sub NowWhat {
+ # Report is done, prompt for further action
+ if( !$::opt_S ) {
+ while(1) {
+ my $menu = <<EOF;
+
+
+You have finished composing your message. At this point, you have
+a few options. You can:
+
+ * [Se]end the message to $address$andcc,
+ * [D]isplay the message on the screen,
+ * [R]e-edit the message
+ * Display or change the message's [su]bject
+ * Save the message to a [f]ile to mail at another time
+ * [Q]uit without sending a message
+
+EOF
+ retry:
+ print $menu;
+ my $action = _prompt('', "Action (Send/Display/Edit/Subject/Save to File)");;
+ print "\n";
+ if ($action =~ /^(f|sa)/i) { # <F>ile/<Sa>ve
+ if ( SaveMessage() ) { exit }
+ } elsif ($action =~ /^(d|l|sh)/i ) { # <D>isplay, <L>ist, <Sh>ow
+ # Display the message
+ open(REP, "<$filename") or die "Couldn't open file '$filename': $!\n";
+ while (<REP>) { print $_ }
+ close(REP) or die "Error closing report file '$filename': $!";
+ } elsif ($action =~ /^su/i) { # <Su>bject
+ my $reply = _prompt( "Subject: $subject", "If the above subject is fine, press Enter. Otherwise, type a replacement now\nSubject");
+ if ($reply ne '') {
+ unless (TrivialSubject($reply)) {
+ $subject = $reply;
+ print "Subject: $subject\n";
+ }
+ }
+ } elsif ($action =~ /^se/i) { # <S>end
+ # Send the message
+ my $reply = _prompt( "Are you certain you want to send this message?", 'Please type "yes" if you are','no');
+ if ($reply =~ /^yes$/) {
+ last;
+ } else {
+ paraprint <<EOF;
+You didn't type "yes", so your message has not yet been sent.
+EOF
+ }
+ } elsif ($action =~ /^[er]/i) { # <E>dit, <R>e-edit
+ # edit the message
+ Edit();
+ } elsif ($action =~ /^[qc]/i) { # <C>ancel, <Q>uit
+ Cancel();
+ } elsif ($action =~ /^s/i) {
+ paraprint <<EOF;
+The command you entered was ambiguous. Please type "send", "save" or "subject".
+EOF
+ }
+ }
+ }
+} # sub NowWhat
+
+sub TrivialSubject {
+ my $subject = shift;
+ if ($subject =~
+ /^(y(es)?|no?|help|perl( (bug|problem))?|bug|problem)$/i ||
+ length($subject) < 4 ||
+ $subject !~ /\s/) {
+ print "\nThe subject you entered wasn't very descriptive. Please try again.\n\n";
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub SaveMessage {
+ my $file_save = $outfile || "$progname.rep";
+ my $file = _prompt( '', "Name of file to save message in", $file_save );
+ save_message_to_disk($file) || return undef;
+ print "\n";
+ paraprint <<EOF;
+A copy of your message has been saved in '$file' for you to
+send to '$address' with your normal mail client.
+EOF
+}
+
+sub Send {
+
+ # Message has been accepted for transmission -- Send the message
+
+ # on linux certain "mail" implementations won't accept the subject
+ # as "~s subject" and thus the Subject header will be corrupted
+ # so don't use Mail::Send to be safe
+ eval {
+ if ( $::HaveSend && !$Is_Linux && !$Is_OpenBSD ) {
+ _send_message_mailsend();
+ } elsif ($Is_VMS) {
+ _send_message_vms();
+ } else {
+ _send_message_sendmail();
+ }
+ };
+
+ if ( my $error = $@ ) {
+ paraprint <<EOF;
+$0 has detected an error while trying to send your message: $error.
+
+Your message may not have been sent. You will now have a chance to save a copy to disk.
+EOF
+ SaveMessage();
+ return;
+ }
+
+ 1 while unlink($filename); # remove all versions under VMS
+} # sub Send
+
+sub Help {
+ print <<EOF;
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run "$0" interactively from a command
+line without any special arguments and follow the prompts.
+
+Advanced usage:
+
+$0 [-v] [-a address] [-s subject] [-b body | -f inpufile ] [ -F outputfile ]
+ [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
+$0 [-v] [-r returnaddress] [-A] [-ok | -okay | -nok | -nokay]
+
+
+Options:
+
+ -v Include Verbose configuration data in the report
+ -f File containing the body of the report. Use this to
+ quickly send a prepared message.
+ -F File to output the resulting mail message to, instead of mailing.
+ -S Send without asking for confirmation.
+ -a Address to send the report to. Defaults to '$address'.
+ -c Address to send copy of report to. Defaults to '$cc'.
+ -C Don't send copy to administrator.
+ -s Subject to include with the message. You will be prompted
+ if you don't supply one on the command line.
+ -b Body of the report. If not included on the command line, or
+ in a file with -f, you will get a chance to edit the message.
+ -r Your return address. The program will ask you to confirm
+ this if you don't give it here.
+ -e Editor to use.
+ -t Test mode. The target address defaults to '$testaddress'.
+ -T Thank-you mode. The target address defaults to '$thanksaddress'.
+ -d Data mode. This prints out your configuration data, without mailing
+ anything. You can use this with -v to get more complete data.
+ -A Don't send a bug received acknowledgement to the return address.
+ -ok Report successful build on this system to perl porters
+ (use alone or with -v). Only use -ok if *everything* was ok:
+ if there were *any* problems at all, use -nok.
+ -okay As -ok but allow report from old builds.
+ -nok Report unsuccessful build on this system to perl porters
+ (use alone or with -v). You must describe what went wrong
+ in the body of the report which you will be asked to edit.
+ -nokay As -nok but allow report from old builds.
+ -h Print this help message.
+
+EOF
+}
+
+sub filename {
+ if ($::HaveTemp) {
+ # Good. Use a secure temp file
+ my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
+ close($fh);
+ return $filename;
+ } else {
+ # Bah. Fall back to doing things less securely.
+ my $dir = File::Spec->tmpdir();
+ $filename = "bugrep0$$";
+ $filename++ while -e File::Spec->catfile($dir, $filename);
+ $filename = File::Spec->catfile($dir, $filename);
+ }
+}
+
+sub paraprint {
+ my @paragraphs = split /\n{2,}/, "@_";
+ for (@paragraphs) { # implicit local $_
+ s/(\S)\s*\n/$1 /g;
+ write;
+ print "\n";
+ }
+}
+
+sub _prompt {
+ my ($explanation, $prompt, $default) = (@_);
+ if ($explanation) {
+ print "\n\n";
+ paraprint $explanation;
+ }
+ print $prompt. ($default ? " [$default]" :''). ": ";
+ my $result = scalar(<>);
+ chomp($result);
+ $result =~ s/^\s*(.*?)\s*$/$1/s;
+ if ($default && $result eq '') {
+ return $default;
+ } else {
+ return $result;
+ }
+}
+
+sub _build_header {
+ my %attr = (@_);
+
+ my $head = '';
+ for my $header (keys %attr) {
+ $head .= "$header: ".$attr{$header}."\n";
+ }
+ return $head;
+}
+
+sub _message_headers {
+ my %headers = ( To => $address, Subject => $subject );
+ $headers{'Cc'} = $cc if ($cc);
+ $headers{'Message-Id'} = $messageid if ($messageid);
+ $headers{'Reply-To'} = $from if ($from);
+ return \%headers;
+}
+
+sub build_complete_message {
+ my $content = _build_header(%{_message_headers()}) . "\n\n";
+ open( REP, "<$filename" ) or die "Couldn't open file '$filename': $!\n";
+ while (<REP>) { $content .= $_; }
+ close(REP) or die "Error closing report file '$filename': $!";
+ return $content;
+}
+
+sub save_message_to_disk {
+ my $file = shift;
+
+ open OUTFILE, ">$file" or do { warn "Couldn't open '$file': $!\n"; return undef};
+ print OUTFILE build_complete_message();
+ close(OUTFILE) or do { warn "Error closing $file: $!"; return undef };
+ print "\nMessage saved.\n";
+ return 1;
+}
+
+sub _send_message_vms {
+ if ( ( $address =~ /@/ and $address !~ /^\w+%"/ )
+ or ( $cc =~ /@/ and $cc !~ /^\w+%"/ ) ) {
+ my $prefix;
+ foreach ( qw[ IN MX SMTP UCX PONY WINS ], '' ) {
+ $prefix = "$_%", last if $ENV{"MAIL\$PROTOCOL_$_"};
+ }
+ $address = qq[${prefix}"$address"] unless $address =~ /^\w+%"/;
+ $cc = qq[${prefix}"$cc"] unless !$cc || $cc =~ /^\w+%"/;
+ }
+ $subject =~ s/"/""/g;
+ $address =~ s/"/""/g;
+ $cc =~ s/"/""/g;
+ my $sts = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
+ if ($sts) {
+ die "Can't spawn off mail (leaving bug report in $filename): $sts";
+ }
+}
+
+sub _send_message_mailsend {
+ my $msg = Mail::Send->new();
+ my %headers = %{_message_headers()};
+ for my $key ( keys %headers) {
+ $msg->add($key => $headers{$key});
+ }
+
+ $fh = $msg->open;
+ open(REP, "<$filename") or die "Couldn't open '$filename': $!\n";
+ while (<REP>) { print $fh $_ }
+ close(REP) or die "Error closing $filename: $!";
+ $fh->close;
+
+ print "\nMessage sent.\n";
+}
+
+sub _probe_for_sendmail {
+ my $sendmail = "";
+ for (qw(/usr/lib/sendmail /usr/sbin/sendmail /usr/ucblib/sendmail)) {
+ $sendmail = $_, last if -e $_;
+ }
+ if ( $^O eq 'os2' and $sendmail eq "" ) {
+ my $path = $ENV{PATH};
+ $path =~ s:\\:/:;
+ my @path = split /$Config{'path_sep'}/, $path;
+ for (@path) {
+ $sendmail = "$_/sendmail", last if -e "$_/sendmail";
+ $sendmail = "$_/sendmail.exe", last if -e "$_/sendmail.exe";
+ }
+ }
+ return $sendmail;
+}
+
+sub _send_message_sendmail {
+ my $sendmail = _probe_for_sendmail();
+ unless ($sendmail) {
+ paraprint(<<"EOF"), die "\n";
+It appears that there is no program which looks like "sendmail" on
+your system and that the Mail::Send library from CPAN isn't available.
+Because of this, there's no easy way to automatically send your
+message.
+
+A copy of your message has been saved in '$filename' for you to
+send to '$address' with your normal mail client.
+EOF
+ }
+
+ open( SENDMAIL, "|$sendmail -t -oi" )
+ || die "'|$sendmail -t -oi' failed: $!";
+ print SENDMAIL build_complete_message();
+ if ( close(SENDMAIL) ) {
+ print "\nMessage sent\n";
+ } else {
+ warn "\nSendmail returned status '", $? >> 8, "'\n";
+ }
+}
+
+
+
+# a strange way to check whether any significant editing
+# has been done: check whether any new non-empty lines
+# have been added.
+
+sub _fingerprint_lines_in_report {
+ my $new_lines = 0;
+ # read in the report template once so that
+ # we can track whether the user does any editing.
+ # yes, *all* whitespace is ignored.
+
+ open(REP, "<$filename") or die "Unable to open report file '$filename': $!\n";
+ while (my $line = <REP>) {
+ $line =~ s/\s+//g;
+ $new_lines++ if (!$REP{$line});
+
+ }
+ close(REP) or die "Error closing report file '$filename': $!";
+ # returns the number of lines with content that wasn't there when last we looked
+ return $new_lines;
+}
+
+
+
+format STDOUT =
+^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
+$_
+.
+
+__END__
+
+=head1 NAME
+
+perlbug - how to submit bug reports on Perl
+
+=head1 SYNOPSIS
+
+B<perlbug>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-a> I<address> ]> S<[ B<-s> I<subject> ]>
+S<[ B<-b> I<body> | B<-f> I<inputfile> ]> S<[ B<-F> I<outputfile> ]>
+S<[ B<-r> I<returnaddress> ]>
+S<[ B<-e> I<editor> ]> S<[ B<-c> I<adminaddress> | B<-C> ]>
+S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]>
+
+B<perlbug> S<[ B<-v> ]> S<[ B<-r> I<returnaddress> ]>
+ S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]>
+
+B<perlthanks>
+
+=head1 DESCRIPTION
+
+
+This program is designed to help you generate and send bug reports
+(and thank-you notes) about perl5 and the modules which ship with it.
+
+In most cases, you can just run it interactively from a command
+line without any special arguments and follow the prompts.
+
+If you have found a bug with a non-standard port (one that was not
+part of the I<standard distribution>), a binary distribution, or a
+non-core module (such as Tk, DBI, etc), then please see the
+documentation that came with that distribution to determine the
+correct place to report bugs.
+
+If you are unable to send your report using B<perlbug> (most likely
+because your system doesn't have a way to send mail that perlbug
+recognizes), you may be able to use this tool to compose your report
+and save it to a file which you can then send to B<perlbug@perl.org>
+using your regular mail client.
+
+In extreme cases, B<perlbug> may not work well enough on your system
+to guide you through composing a bug report. In those cases, you
+may be able to use B<perlbug -d> to get system configuration
+information to include in a manually composed bug report to
+B<perlbug@perl.org>.
+
+
+When reporting a bug, please run through this checklist:
+
+=over 4
+
+=item What version of Perl you are running?
+
+Type C<perl -v> at the command line to find out.
+
+=item Are you running the latest released version of perl?
+
+Look at http://www.perl.org/ to find out. If you are not using the
+latest released version, please try to replicate your bug on the
+latest stable release.
+
+Note that reports about bugs in old versions of Perl, especially
+those which indicate you haven't also tested the current stable
+release of Perl, are likely to receive less attention from the
+volunteers who build and maintain Perl than reports about bugs in
+the current release.
+
+This tool isn't apropriate for reporting bugs in any version
+prior to Perl 5.0.
+
+=item Are you sure what you have is a bug?
+
+A significant number of the bug reports we get turn out to be
+documented features in Perl. Make sure the issue you've run into
+isn't intentional by glancing through the documentation that comes
+with the Perl distribution.
+
+Given the sheer volume of Perl documentation, this isn't a trivial
+undertaking, but if you can point to documentation that suggests
+the behaviour you're seeing is I<wrong>, your issue is likely to
+receive more attention. You may want to start with B<perldoc>
+L<perltrap> for pointers to common traps that new (and experienced)
+Perl programmers run into.
+
+If you're unsure of the meaning of an error message you've run
+across, B<perldoc> L<perldiag> for an explanation. If the message
+isn't in perldiag, it probably isn't generated by Perl. You may
+have luck consulting your operating system documentation instead.
+
+If you are on a non-UNIX platform B<perldoc> L<perlport>, as some
+features may be unimplemented or work differently.
+
+You may be able to figure out what's going wrong using the Perl
+debugger. For information about how to use the debugger B<perldoc>
+L<perldebug>.
+
+=item Do you have a proper test case?
+
+The easier it is to reproduce your bug, the more likely it will be
+fixed -- if nobody can duplicate your problem, it probably won't be
+addressed.
+
+A good test case has most of these attributes: short, simple code;
+few dependencies on external commands, modules, or libraries; no
+platform-dependent code (unless it's a platform-specific bug);
+clear, simple documentation.
+
+A good test case is almost always a good candidate to be included in
+Perl's test suite. If you have the time, consider writing your test case so
+that it can be easily included into the standard test suite.
+
+=item Have you included all relevant information?
+
+Be sure to include the B<exact> error messages, if any.
+"Perl gave an error" is not an exact error message.
+
+If you get a core dump (or equivalent), you may use a debugger
+(B<dbx>, B<gdb>, etc) to produce a stack trace to include in the bug
+report.
+
+NOTE: unless your Perl has been compiled with debug info
+(often B<-g>), the stack trace is likely to be somewhat hard to use
+because it will most probably contain only the function names and not
+their arguments. If possible, recompile your Perl with debug info and
+reproduce the crash and the stack trace.
+
+=item Can you describe the bug in plain English?
+
+The easier it is to understand a reproducible bug, the more likely
+it will be fixed. Any insight you can provide into the problem
+will help a great deal. In other words, try to analyze the problem
+(to the extent you can) and report your discoveries.
+
+=item Can you fix the bug yourself?
+
+A bug report which I<includes a patch to fix it> will almost
+definitely be fixed. When sending a patch, please use the C<diff>
+program with the C<-u> option to generate "unified" diff files.
+Bug reports with patches are likely to receive significantly more
+attention and interest than those without patches.
+
+Your patch may be returned with requests for changes, or requests for more
+detailed explanations about your fix.
+
+Here are a few hints for creating high-quality patches:
+
+Make sure the patch is not reversed (the first argument to diff is
+typically the original file, the second argument your changed file).
+Make sure you test your patch by applying it with the C<patch>
+program before you send it on its way. Try to follow the same style
+as the code you are trying to patch. Make sure your patch really
+does work (C<make test>, if the thing you're patching is covered
+by Perl's test suite).
+
+=item Can you use C<perlbug> to submit the report?
+
+B<perlbug> will, amongst other things, ensure your report includes
+crucial information about your version of perl. If C<perlbug> is
+unable to mail your report after you have typed it in, you may have
+to compose the message yourself, add the output produced by C<perlbug
+-d> and email it to B<perlbug@perl.org>. If, for some reason, you
+cannot run C<perlbug> at all on your system, be sure to include the
+entire output produced by running C<perl -V> (note the uppercase V).
+
+Whether you use C<perlbug> or send the email manually, please make
+your Subject line informative. "a bug" is not informative. Neither
+is "perl crashes" nor is "HELP!!!". These don't help. A compact
+description of what's wrong is fine.
+
+=item Can you use C<perlbug> to submit a thank-you note?
+
+Yes, you can do this by either using the C<-T> option, or by invoking
+the program as C<perlthanks>. Thank-you notes are good. It makes people
+smile.
+
+=back
+
+Having done your bit, please be prepared to wait, to be told the
+bug is in your code, or possibly to get no reply at all. The
+volunteers who maintain Perl are busy folks, so if your problem is
+an obvious bug in your own code, is difficult to understand or is
+a duplicate of an existing report, you may not receive a personal
+reply.
+
+If it is important to you that your bug be fixed, do monitor the
+perl5-porters@perl.org mailing list and the commit logs to development
+versions of Perl, and encourage the maintainers with kind words or
+offers of frosty beverages. (Please do be kind to the maintainers.
+Harassing or flaming them is likely to have the opposite effect of
+the one you want.)
+
+Feel free to update the ticket about your bug on http://rt.perl.org
+if a new version of Perl is released and your bug is still present.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-a>
+
+Address to send the report to. Defaults to B<perlbug@perl.org>.
+
+=item B<-A>
+
+Don't send a bug received acknowledgement to the reply address.
+Generally it is only a sensible to use this option if you are a
+perl maintainer actively watching perl porters for your message to
+arrive.
+
+=item B<-b>
+
+Body of the report. If not included on the command line, or
+in a file with B<-f>, you will get a chance to edit the message.
+
+=item B<-C>
+
+Don't send copy to administrator.
+
+=item B<-c>
+
+Address to send copy of report to. Defaults to the address of the
+local perl administrator (recorded when perl was built).
+
+=item B<-d>
+
+Data mode (the default if you redirect or pipe output). This prints out
+your configuration data, without mailing anything. You can use this
+with B<-v> to get more complete data.
+
+=item B<-e>
+
+Editor to use.
+
+=item B<-f>
+
+File containing the body of the report. Use this to quickly send a
+prepared message.
+
+=item B<-F>
+
+File to output the results to instead of sending as an email. Useful
+particularly when running perlbug on a machine with no direct internet
+connection.
+
+=item B<-h>
+
+Prints a brief summary of the options.
+
+=item B<-ok>
+
+Report successful build on this system to perl porters. Forces B<-S>
+and B<-C>. Forces and supplies values for B<-s> and B<-b>. Only
+prompts for a return address if it cannot guess it (for use with
+B<make>). Honors return address specified with B<-r>. You can use this
+with B<-v> to get more complete data. Only makes a report if this
+system is less than 60 days old.
+
+=item B<-okay>
+
+As B<-ok> except it will report on older systems.
+
+=item B<-nok>
+
+Report unsuccessful build on this system. Forces B<-C>. Forces and
+supplies a value for B<-s>, then requires you to edit the report
+and say what went wrong. Alternatively, a prepared report may be
+supplied using B<-f>. Only prompts for a return address if it
+cannot guess it (for use with B<make>). Honors return address
+specified with B<-r>. You can use this with B<-v> to get more
+complete data. Only makes a report if this system is less than 60
+days old.
+
+=item B<-nokay>
+
+As B<-nok> except it will report on older systems.
+
+=item B<-r>
+
+Your return address. The program will ask you to confirm its default
+if you don't use this option.
+
+=item B<-S>
+
+Send without asking for confirmation.
+
+=item B<-s>
+
+Subject to include with the message. You will be prompted if you don't
+supply one on the command line.
+
+=item B<-t>
+
+Test mode. The target address defaults to B<perlbug-test@perl.org>.
+
+=item B<-T>
+
+Send a thank-you note instead of a bug report.
+
+=item B<-v>
+
+Include verbose configuration data in the report.
+
+=back
+
+=head1 AUTHORS
+
+Kenneth Albanowski (E<lt>kjahds@kjahds.comE<gt>), subsequently
+I<doc>tored by Gurusamy Sarathy (E<lt>gsar@activestate.comE<gt>),
+Tom Christiansen (E<lt>tchrist@perl.comE<gt>), Nathan Torkington
+(E<lt>gnat@frii.comE<gt>), Charles F. Randall (E<lt>cfr@pobox.comE<gt>),
+Mike Guy (E<lt>mjtg@cam.a.ukE<gt>), Dominic Dunlop
+(E<lt>domo@computer.orgE<gt>), Hugo van der Sanden (E<lt>hv@crypt.org<gt>),
+Jarkko Hietaniemi (E<lt>jhi@iki.fiE<gt>), Chris Nandor
+(E<lt>pudge@pobox.comE<gt>), Jon Orwant (E<lt>orwant@media.mit.eduE<gt>,
+Richard Foley (E<lt>richard.foley@rfi.netE<gt>), and Jesse Vincent
+(E<lt>jesse@bestpractical.com<gt>).
+
+=head1 SEE ALSO
+
+perl(1), perldebug(1), perldiag(1), perlport(1), perltrap(1),
+diff(1), patch(1), dbx(1), gdb(1)
+
+=head1 BUGS
+
+None known (guess what must have been used to report them?)
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/piconv b/Master/tlpkg/tlperl/bin/piconv new file mode 100755 index 00000000000..9fdebd193cf --- /dev/null +++ b/Master/tlpkg/tlperl/bin/piconv @@ -0,0 +1,299 @@ +#!./perl +# $Id: piconv,v 2.4 2009/07/08 13:34:15 dankogai Exp $ +# +use 5.8.0; +use strict; +use Encode ; +use Encode::Alias; +my %Scheme = map {$_ => 1} qw(from_to decode_encode perlio); + +use File::Basename; +my $name = basename($0); + +use Getopt::Long qw(:config no_ignore_case); + +my %Opt; + +help() + unless + GetOptions(\%Opt, + 'from|f=s', + 'to|t=s', + 'list|l', + 'string|s=s', + 'check|C=i', + 'c', + 'perlqq|p', + 'htmlcref', + 'xmlcref', + 'debug|D', + 'scheme|S=s', + 'resolve|r=s', + 'help', + ); + +$Opt{help} and help(); +$Opt{list} and list_encodings(); +my $locale = $ENV{LC_CTYPE} || $ENV{LC_ALL} || $ENV{LANG}; +defined $Opt{resolve} and resolve_encoding($Opt{resolve}); +$Opt{from} || $Opt{to} || help(); +my $from = $Opt{from} || $locale or help("from_encoding unspecified"); +my $to = $Opt{to} || $locale or help("to_encoding unspecified"); +$Opt{string} and Encode::from_to($Opt{string}, $from, $to) and print $Opt{string} and exit; +my $scheme = do { + if (defined $Opt{scheme}) { + if (!exists $Scheme{$Opt{scheme}}) { + warn "Unknown scheme '$Opt{scheme}', fallback to 'from_to'.\n"; + 'from_to'; + } else { + $Opt{scheme}; + } + } else { + 'from_to'; + } +}; + +$Opt{check} ||= $Opt{c}; +$Opt{perlqq} and $Opt{check} = Encode::PERLQQ; +$Opt{htmlcref} and $Opt{check} = Encode::HTMLCREF; +$Opt{xmlcref} and $Opt{check} = Encode::XMLCREF; + +if ($Opt{debug}){ + my $cfrom = Encode->getEncoding($from)->name; + my $cto = Encode->getEncoding($to)->name; + print <<"EOT"; +Scheme: $scheme +From: $from => $cfrom +To: $to => $cto +EOT +} + +my %use_bom = map { $_ => 1 } qw/UTF-16 UTF-32/; + +# we do not use <> (or ARGV) for the sake of binmode() +@ARGV or push @ARGV, \*STDIN; + +unless ( $scheme eq 'perlio' ) { + binmode STDOUT; + my $need2slurp = $use_bom{ find_encoding($to)->name }; + for my $argv (@ARGV) { + my $ifh = ref $argv ? $argv : undef; + $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next; + $ifh or open $ifh, "<", $argv or next; + binmode $ifh; + if ( $scheme eq 'from_to' ) { # default + if ($need2slurp){ + local $/; + $_ = <$ifh>; + Encode::from_to( $_, $from, $to, $Opt{check} ); + print; + }else{ + while (<$ifh>) { + Encode::from_to( $_, $from, $to, $Opt{check} ); + print; + } + } + } + elsif ( $scheme eq 'decode_encode' ) { # step-by-step + if ($need2slurp){ + local $/; + $_ = <$ifh>; + my $decoded = decode( $from, $_, $Opt{check} ); + my $encoded = encode( $to, $decoded ); + print $encoded; + }else{ + while (<$ifh>) { + my $decoded = decode( $from, $_, $Opt{check} ); + my $encoded = encode( $to, $decoded ); + print $encoded; + } + } + } + else { # won't reach + die "$name: unknown scheme: $scheme"; + } + } +} +else { + + # NI-S favorite + binmode STDOUT => "raw:encoding($to)"; + for my $argv (@ARGV) { + my $ifh = ref $argv ? $argv : undef; + $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next; + $ifh or open $ifh, "<", $argv or next; + binmode $ifh => "raw:encoding($from)"; + print while (<$ifh>); + } +} + +sub list_encodings { + print join( "\n", Encode->encodings(":all") ), "\n"; + exit 0; +} + +sub resolve_encoding { + if ( my $alias = Encode::resolve_alias( $_[0] ) ) { + print $alias, "\n"; + exit 0; + } + else { + warn "$name: $_[0] is not known to Encode\n"; + exit 1; + } +} + +sub help { + my $message = shift; + $message and print STDERR "$name error: $message\n"; + print STDERR <<"EOT"; +$name [-f from_encoding] [-t to_encoding] [-s string] [files...] +$name -l +$name -r encoding_alias + -l,--list + lists all available encodings + -r,--resolve encoding_alias + resolve encoding to its (Encode) canonical name + -f,--from from_encoding + when omitted, the current locale will be used + -t,--to to_encoding + when omitted, the current locale will be used + -s,--string string + "string" will be the input instead of STDIN or files +The following are mainly of interest to Encode hackers: + -D,--debug show debug information + -C N | -c check the validity of the input + -S,--scheme scheme use the scheme for conversion +Those are handy when you can only see ascii characters: + -p,--perlqq + --htmlcref + --xmlcref +EOT + exit; +} + +__END__ + +=head1 NAME + +piconv -- iconv(1), reinvented in perl + +=head1 SYNOPSIS + + piconv [-f from_encoding] [-t to_encoding] [-s string] [files...] + piconv -l + piconv [-C N|-c|-p] + piconv -S scheme ... + piconv -r encoding + piconv -D ... + piconv -h + +=head1 DESCRIPTION + +B<piconv> is perl version of B<iconv>, a character encoding converter +widely available for various Unixen today. This script was primarily +a technology demonstrator for Perl 5.8.0, but you can use piconv in the +place of iconv for virtually any case. + +piconv converts the character encoding of either STDIN or files +specified in the argument and prints out to STDOUT. + +Here is the list of options. Each option can be in short format (-f) +or long (--from). + +=over 4 + +=item -f,--from from_encoding + +Specifies the encoding you are converting from. Unlike B<iconv>, +this option can be omitted. In such cases, the current locale is used. + +=item -t,--to to_encoding + +Specifies the encoding you are converting to. Unlike B<iconv>, +this option can be omitted. In such cases, the current locale is used. + +Therefore, when both -f and -t are omitted, B<piconv> just acts +like B<cat>. + +=item -s,--string I<string> + +uses I<string> instead of file for the source of text. + +=item -l,--list + +Lists all available encodings, one per line, in case-insensitive +order. Note that only the canonical names are listed; many aliases +exist. For example, the names are case-insensitive, and many standard +and common aliases work, such as "latin1" for "ISO-8859-1", or "ibm850" +instead of "cp850", or "winlatin1" for "cp1252". See L<Encode::Supported> +for a full discussion. + +=item -C,--check I<N> + +Check the validity of the stream if I<N> = 1. When I<N> = -1, something +interesting happens when it encounters an invalid character. + +=item -c + +Same as C<-C 1>. + +=item -p,--perlqq + +=item --htmlcref + +=item --xmlcref + +Applies PERLQQ, HTMLCREF, XMLCREF, respectively. Try + + piconv -f utf8 -t ascii --perlqq + +To see what it does. + +=item -h,--help + +Show usage. + +=item -D,--debug + +Invokes debugging mode. Primarily for Encode hackers. + +=item -S,--scheme scheme + +Selects which scheme is to be used for conversion. Available schemes +are as follows: + +=over 4 + +=item from_to + +Uses Encode::from_to for conversion. This is the default. + +=item decode_encode + +Input strings are decode()d then encode()d. A straight two-step +implementation. + +=item perlio + +The new perlIO layer is used. NI-S' favorite. + +You should use this option if you are using UTF-16 and others which +linefeed is not $/. + +=back + +Like the I<-D> option, this is also for Encode hackers. + +=back + +=head1 SEE ALSO + +L<iconv(1)> +L<locale(3)> +L<Encode> +L<Encode::Supported> +L<Encode::Alias> +L<PerlIO> + +=cut diff --git a/Master/tlpkg/tlperl/bin/piconv.bat b/Master/tlpkg/tlperl/bin/piconv.bat new file mode 100755 index 00000000000..a255687f2af --- /dev/null +++ b/Master/tlpkg/tlperl/bin/piconv.bat @@ -0,0 +1,315 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!./perl
+#line 15
+# $Id: piconv,v 2.4 2009/07/08 13:34:15 dankogai Exp $
+#
+use 5.8.0;
+use strict;
+use Encode ;
+use Encode::Alias;
+my %Scheme = map {$_ => 1} qw(from_to decode_encode perlio);
+
+use File::Basename;
+my $name = basename($0);
+
+use Getopt::Long qw(:config no_ignore_case);
+
+my %Opt;
+
+help()
+ unless
+ GetOptions(\%Opt,
+ 'from|f=s',
+ 'to|t=s',
+ 'list|l',
+ 'string|s=s',
+ 'check|C=i',
+ 'c',
+ 'perlqq|p',
+ 'htmlcref',
+ 'xmlcref',
+ 'debug|D',
+ 'scheme|S=s',
+ 'resolve|r=s',
+ 'help',
+ );
+
+$Opt{help} and help();
+$Opt{list} and list_encodings();
+my $locale = $ENV{LC_CTYPE} || $ENV{LC_ALL} || $ENV{LANG};
+defined $Opt{resolve} and resolve_encoding($Opt{resolve});
+$Opt{from} || $Opt{to} || help();
+my $from = $Opt{from} || $locale or help("from_encoding unspecified");
+my $to = $Opt{to} || $locale or help("to_encoding unspecified");
+$Opt{string} and Encode::from_to($Opt{string}, $from, $to) and print $Opt{string} and exit;
+my $scheme = do {
+ if (defined $Opt{scheme}) {
+ if (!exists $Scheme{$Opt{scheme}}) {
+ warn "Unknown scheme '$Opt{scheme}', fallback to 'from_to'.\n";
+ 'from_to';
+ } else {
+ $Opt{scheme};
+ }
+ } else {
+ 'from_to';
+ }
+};
+
+$Opt{check} ||= $Opt{c};
+$Opt{perlqq} and $Opt{check} = Encode::PERLQQ;
+$Opt{htmlcref} and $Opt{check} = Encode::HTMLCREF;
+$Opt{xmlcref} and $Opt{check} = Encode::XMLCREF;
+
+if ($Opt{debug}){
+ my $cfrom = Encode->getEncoding($from)->name;
+ my $cto = Encode->getEncoding($to)->name;
+ print <<"EOT";
+Scheme: $scheme
+From: $from => $cfrom
+To: $to => $cto
+EOT
+}
+
+my %use_bom = map { $_ => 1 } qw/UTF-16 UTF-32/;
+
+# we do not use <> (or ARGV) for the sake of binmode()
+@ARGV or push @ARGV, \*STDIN;
+
+unless ( $scheme eq 'perlio' ) {
+ binmode STDOUT;
+ my $need2slurp = $use_bom{ find_encoding($to)->name };
+ for my $argv (@ARGV) {
+ my $ifh = ref $argv ? $argv : undef;
+ $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
+ $ifh or open $ifh, "<", $argv or next;
+ binmode $ifh;
+ if ( $scheme eq 'from_to' ) { # default
+ if ($need2slurp){
+ local $/;
+ $_ = <$ifh>;
+ Encode::from_to( $_, $from, $to, $Opt{check} );
+ print;
+ }else{
+ while (<$ifh>) {
+ Encode::from_to( $_, $from, $to, $Opt{check} );
+ print;
+ }
+ }
+ }
+ elsif ( $scheme eq 'decode_encode' ) { # step-by-step
+ if ($need2slurp){
+ local $/;
+ $_ = <$ifh>;
+ my $decoded = decode( $from, $_, $Opt{check} );
+ my $encoded = encode( $to, $decoded );
+ print $encoded;
+ }else{
+ while (<$ifh>) {
+ my $decoded = decode( $from, $_, $Opt{check} );
+ my $encoded = encode( $to, $decoded );
+ print $encoded;
+ }
+ }
+ }
+ else { # won't reach
+ die "$name: unknown scheme: $scheme";
+ }
+ }
+}
+else {
+
+ # NI-S favorite
+ binmode STDOUT => "raw:encoding($to)";
+ for my $argv (@ARGV) {
+ my $ifh = ref $argv ? $argv : undef;
+ $ifh or open $ifh, "<", $argv or warn "Can't open $argv: $!" and next;
+ $ifh or open $ifh, "<", $argv or next;
+ binmode $ifh => "raw:encoding($from)";
+ print while (<$ifh>);
+ }
+}
+
+sub list_encodings {
+ print join( "\n", Encode->encodings(":all") ), "\n";
+ exit 0;
+}
+
+sub resolve_encoding {
+ if ( my $alias = Encode::resolve_alias( $_[0] ) ) {
+ print $alias, "\n";
+ exit 0;
+ }
+ else {
+ warn "$name: $_[0] is not known to Encode\n";
+ exit 1;
+ }
+}
+
+sub help {
+ my $message = shift;
+ $message and print STDERR "$name error: $message\n";
+ print STDERR <<"EOT";
+$name [-f from_encoding] [-t to_encoding] [-s string] [files...]
+$name -l
+$name -r encoding_alias
+ -l,--list
+ lists all available encodings
+ -r,--resolve encoding_alias
+ resolve encoding to its (Encode) canonical name
+ -f,--from from_encoding
+ when omitted, the current locale will be used
+ -t,--to to_encoding
+ when omitted, the current locale will be used
+ -s,--string string
+ "string" will be the input instead of STDIN or files
+The following are mainly of interest to Encode hackers:
+ -D,--debug show debug information
+ -C N | -c check the validity of the input
+ -S,--scheme scheme use the scheme for conversion
+Those are handy when you can only see ascii characters:
+ -p,--perlqq
+ --htmlcref
+ --xmlcref
+EOT
+ exit;
+}
+
+__END__
+
+=head1 NAME
+
+piconv -- iconv(1), reinvented in perl
+
+=head1 SYNOPSIS
+
+ piconv [-f from_encoding] [-t to_encoding] [-s string] [files...]
+ piconv -l
+ piconv [-C N|-c|-p]
+ piconv -S scheme ...
+ piconv -r encoding
+ piconv -D ...
+ piconv -h
+
+=head1 DESCRIPTION
+
+B<piconv> is perl version of B<iconv>, a character encoding converter
+widely available for various Unixen today. This script was primarily
+a technology demonstrator for Perl 5.8.0, but you can use piconv in the
+place of iconv for virtually any case.
+
+piconv converts the character encoding of either STDIN or files
+specified in the argument and prints out to STDOUT.
+
+Here is the list of options. Each option can be in short format (-f)
+or long (--from).
+
+=over 4
+
+=item -f,--from from_encoding
+
+Specifies the encoding you are converting from. Unlike B<iconv>,
+this option can be omitted. In such cases, the current locale is used.
+
+=item -t,--to to_encoding
+
+Specifies the encoding you are converting to. Unlike B<iconv>,
+this option can be omitted. In such cases, the current locale is used.
+
+Therefore, when both -f and -t are omitted, B<piconv> just acts
+like B<cat>.
+
+=item -s,--string I<string>
+
+uses I<string> instead of file for the source of text.
+
+=item -l,--list
+
+Lists all available encodings, one per line, in case-insensitive
+order. Note that only the canonical names are listed; many aliases
+exist. For example, the names are case-insensitive, and many standard
+and common aliases work, such as "latin1" for "ISO-8859-1", or "ibm850"
+instead of "cp850", or "winlatin1" for "cp1252". See L<Encode::Supported>
+for a full discussion.
+
+=item -C,--check I<N>
+
+Check the validity of the stream if I<N> = 1. When I<N> = -1, something
+interesting happens when it encounters an invalid character.
+
+=item -c
+
+Same as C<-C 1>.
+
+=item -p,--perlqq
+
+=item --htmlcref
+
+=item --xmlcref
+
+Applies PERLQQ, HTMLCREF, XMLCREF, respectively. Try
+
+ piconv -f utf8 -t ascii --perlqq
+
+To see what it does.
+
+=item -h,--help
+
+Show usage.
+
+=item -D,--debug
+
+Invokes debugging mode. Primarily for Encode hackers.
+
+=item -S,--scheme scheme
+
+Selects which scheme is to be used for conversion. Available schemes
+are as follows:
+
+=over 4
+
+=item from_to
+
+Uses Encode::from_to for conversion. This is the default.
+
+=item decode_encode
+
+Input strings are decode()d then encode()d. A straight two-step
+implementation.
+
+=item perlio
+
+The new perlIO layer is used. NI-S' favorite.
+
+You should use this option if you are using UTF-16 and others which
+linefeed is not $/.
+
+=back
+
+Like the I<-D> option, this is also for Encode hackers.
+
+=back
+
+=head1 SEE ALSO
+
+L<iconv(1)>
+L<locale(3)>
+L<Encode>
+L<Encode::Supported>
+L<Encode::Alias>
+L<PerlIO>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pip b/Master/tlpkg/tlperl/bin/pip new file mode 100755 index 00000000000..f7f5a41df7d --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pip @@ -0,0 +1,23 @@ +#!/usr/bin/perl + +use 5.00503; +use strict; +use pip; + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '1.16'; +} + +eval { + pip::main( @ARGV ); +}; + +if ( $@ ) { + my $errstr = $@; + $errstr =~ s/\sat line\b.+$//; + print "Unexpected Error: $errstr\n"; + exit(255); +} + +exit(0); diff --git a/Master/tlpkg/tlperl/bin/pip.bat b/Master/tlpkg/tlperl/bin/pip.bat new file mode 100755 index 00000000000..eea5b74873c --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pip.bat @@ -0,0 +1,39 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use 5.00503;
+use strict;
+use pip;
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.16';
+}
+
+eval {
+ pip::main( @ARGV );
+};
+
+if ( $@ ) {
+ my $errstr = $@;
+ $errstr =~ s/\sat line\b.+$//;
+ print "Unexpected Error: $errstr\n";
+ exit(255);
+}
+
+exit(0);
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pl2bat.bat b/Master/tlpkg/tlperl/bin/pl2bat.bat new file mode 100755 index 00000000000..64887875c96 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pl2bat.bat @@ -0,0 +1,430 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -x -S "$0" ${1+"$@"}'
+ if 0; # In case running under some shell
+
+require 5;
+use Getopt::Std;
+use Config;
+
+$0 =~ s|.*[/\\]||;
+
+my $usage = <<EOT;
+Usage: $0 [-h]
+ or: $0 [-w] [-u] [-a argstring] [-s stripsuffix] [files]
+ or: $0 [-w] [-u] [-n ntargs] [-o otherargs] [-s stripsuffix] [files]
+ -n ntargs arguments to invoke perl with in generated file
+ when run from Windows NT. Defaults to
+ '-x -S %0 %*'.
+ -o otherargs arguments to invoke perl with in generated file
+ other than when run from Windows NT. Defaults
+ to '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9'.
+ -a argstring arguments to invoke perl with in generated file
+ ignoring operating system (for compatibility
+ with previous pl2bat versions).
+ -u update files that may have already been processed
+ by (some version of) pl2bat.
+ -w include "-w" on the /^#!.*perl/ line (unless
+ a /^#!.*perl/ line was already present).
+ -s stripsuffix strip this suffix from file before appending ".bat"
+ Not case-sensitive
+ Can be a regex if it begins with `/'
+ Defaults to "/\.plx?/"
+ -h show this help
+EOT
+
+my %OPT = ();
+warn($usage), exit(0) if !getopts('whun:o:a:s:',\%OPT) or $OPT{'h'};
+# NOTE: %0 is already enclosed in doublequotes by cmd.exe, as appropriate
+$OPT{'n'} = '-x -S %0 %*' unless exists $OPT{'n'};
+$OPT{'o'} = '-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9' unless exists $OPT{'o'};
+$OPT{'s'} = '/\\.plx?/' unless exists $OPT{'s'};
+$OPT{'s'} = ($OPT{'s'} =~ m#^/([^/]*[^/\$]|)\$?/?$# ? $1 : "\Q$OPT{'s'}\E");
+
+my $head;
+if( defined( $OPT{'a'} ) ) {
+ $head = <<EOT;
+ \@rem = '--*-Perl-*--
+ \@echo off
+ perl $OPT{'a'}
+ goto endofperl
+ \@rem ';
+EOT
+} else {
+ $head = <<EOT;
+ \@rem = '--*-Perl-*--
+ \@echo off
+ if "%OS%" == "Windows_NT" goto WinNT
+ perl $OPT{'o'}
+ goto endofperl
+ :WinNT
+ perl $OPT{'n'}
+ if NOT "%COMSPEC%" == "%SystemRoot%\\system32\\cmd.exe" goto endofperl
+ if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+ if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+ goto endofperl
+ \@rem ';
+EOT
+}
+$head =~ s/^\t//gm;
+my $headlines = 2 + ($head =~ tr/\n/\n/);
+my $tail = "\n__END__\n:endofperl\n";
+
+@ARGV = ('-') unless @ARGV;
+
+foreach ( @ARGV ) {
+ process($_);
+}
+
+sub process {
+ my( $file )= @_;
+ my $myhead = $head;
+ my $linedone = 0;
+ my $taildone = 0;
+ my $linenum = 0;
+ my $skiplines = 0;
+ my $line;
+ my $start= $Config{startperl};
+ $start= "#!perl" unless $start =~ /^#!.*perl/;
+ open( FILE, $file ) or die "$0: Can't open $file: $!";
+ @file = <FILE>;
+ foreach $line ( @file ) {
+ $linenum++;
+ if ( $line =~ /^:endofperl\b/ ) {
+ if( ! exists $OPT{'u'} ) {
+ warn "$0: $file has already been converted to a batch file!\n";
+ return;
+ }
+ $taildone++;
+ }
+ if ( not $linedone and $line =~ /^#!.*perl/ ) {
+ if( exists $OPT{'u'} ) {
+ $skiplines = $linenum - 1;
+ $line .= "#line ".(1+$headlines)."\n";
+ } else {
+ $line .= "#line ".($linenum+$headlines)."\n";
+ }
+ $linedone++;
+ }
+ if ( $line =~ /^#\s*line\b/ and $linenum == 2 + $skiplines ) {
+ $line = "";
+ }
+ }
+ close( FILE );
+ $file =~ s/$OPT{'s'}$//oi;
+ $file .= '.bat' unless $file =~ /\.bat$/i or $file =~ /^-$/;
+ open( FILE, ">$file" ) or die "Can't open $file: $!";
+ print FILE $myhead;
+ print FILE $start, ( $OPT{'w'} ? " -w" : "" ),
+ "\n#line ", ($headlines+1), "\n" unless $linedone;
+ print FILE @file[$skiplines..$#file];
+ print FILE $tail unless $taildone;
+ close( FILE );
+}
+__END__
+
+=head1 NAME
+
+pl2bat - wrap perl code into a batch file
+
+=head1 SYNOPSIS
+
+B<pl2bat> B<-h>
+
+B<pl2bat> [B<-w>] S<[B<-a> I<argstring>]> S<[B<-s> I<stripsuffix>]> [files]
+
+B<pl2bat> [B<-w>] S<[B<-n> I<ntargs>]> S<[B<-o> I<otherargs>]> S<[B<-s> I<stripsuffix>]> [files]
+
+=head1 DESCRIPTION
+
+This utility converts a perl script into a batch file that can be
+executed on DOS-like operating systems. This is intended to allow
+you to use a Perl script like regular programs and batch files where
+you just enter the name of the script [probably minus the extension]
+plus any command-line arguments and the script is found in your B<PATH>
+and run.
+
+=head2 ADVANTAGES
+
+There are several alternatives to this method of running a Perl script.
+They each have disadvantages that help you understand the motivation
+for using B<pl2bat>.
+
+=over
+
+=item 1
+
+ C:> perl x:/path/to/script.pl [args]
+
+=item 2
+
+ C:> perl -S script.pl [args]
+
+=item 3
+
+ C:> perl -S script [args]
+
+=item 4
+
+ C:> ftype Perl=perl.exe "%1" %*
+ C:> assoc .pl=Perl
+ then
+ C:> script.pl [args]
+
+=item 5
+
+ C:> ftype Perl=perl.exe "%1" %*
+ C:> assoc .pl=Perl
+ C:> set PathExt=%PathExt%;.PL
+ then
+ C:> script [args]
+
+=back
+
+B<1> and B<2> are the most basic invocation methods that should work on
+any system [DOS-like or not]. They require extra typing and require
+that the script user know that the script is written in Perl. This
+is a pain when you have lots of scripts, some written in Perl and some
+not. It can be quite difficult to keep track of which scripts need to
+be run through Perl and which do not. Even worse, scripts often get
+rewritten from simple batch files into more powerful Perl scripts in
+which case these methods would require all existing users of the scripts
+be updated.
+
+B<3> works on modern Win32 versions of Perl. It allows the user to
+omit the ".pl" or ".bat" file extension, which is a minor improvement.
+
+B<4> and B<5> work on some Win32 operating systems with some command
+shells. One major disadvantage with both is that you can't use them
+in pipelines nor with file redirection. For example, none of the
+following will work properly if you used method B<4> or B<5>:
+
+ C:> script.pl <infile
+ C:> script.pl >outfile
+ C:> echo y | script.pl
+ C:> script.pl | more
+
+This is due to a Win32 bug which Perl has no control over. This bug
+is the major motivation for B<pl2bat> [which was originally written
+for DOS] being used on Win32 systems.
+
+Note also that B<5> works on a smaller range of combinations of Win32
+systems and command shells while B<4> requires that the user know
+that the script is a Perl script [because the ".pl" extension must
+be entered]. This makes it hard to standardize on either of these
+methods.
+
+=head2 DISADVANTAGES
+
+There are several potential traps you should be aware of when you
+use B<pl2bat>.
+
+The generated batch file is initially processed as a batch file each
+time it is run. This means that, to use it from within another batch
+file you should precede it with C<call> or else the calling batch
+file will not run any commands after the script:
+
+ call script [args]
+
+Except under Windows NT, if you specify more than 9 arguments to
+the generated batch file then the 10th and subsequent arguments
+are silently ignored.
+
+Except when using F<CMD.EXE> under Windows NT, if F<perl.exe> is not
+in your B<PATH>, then trying to run the script will give you a generic
+"Command not found"-type of error message that will probably make you
+think that the script itself is not in your B<PATH>. When using
+F<CMD.EXE> under Windows NT, the generic error message is followed by
+"You do not have Perl in your PATH", to make this clearer.
+
+On most DOS-like operating systems, the only way to exit a batch file
+is to "fall off the end" of the file. B<pl2bat> implements this by
+doing C<goto :endofperl> and adding C<__END__> and C<:endofperl> as
+the last two lines of the generated batch file. This means:
+
+=over
+
+=item No line of your script should start with a colon.
+
+In particular, for this version of B<pl2bat>, C<:endofperl>,
+C<:WinNT>, and C<:script_failed_so_exit_with_non_zero_val> should not
+be used.
+
+=item Care must be taken when using C<__END__> and the C<DATA> file handle.
+
+One approach is:
+
+ . #!perl
+ . while( <DATA> ) {
+ . last if /^__END__$/;
+ . [...]
+ . }
+ . __END__
+ . lines of data
+ . to be processed
+ . __END__
+ . :endofperl
+
+The dots in the first column are only there to prevent F<cmd.exe> to interpret
+the C<:endofperl> line in this documentation. Otherwise F<pl2bat.bat> itself
+wouldn't work. See the previous item. :-)
+
+=item The batch file always "succeeds"
+
+The following commands illustrate the problem:
+
+ C:> echo exit(99); >fail.pl
+ C:> pl2bat fail.pl
+ C:> perl -e "print system('perl fail.pl')"
+ 99
+ C:> perl -e "print system('fail.bat')"
+ 0
+
+So F<fail.bat> always reports that it completed successfully. Actually,
+under Windows NT, we have:
+
+ C:> perl -e "print system('fail.bat')"
+ 1
+
+So, for Windows NT, F<fail.bat> fails when the Perl script fails, but
+the return code is always C<1>, not the return code from the Perl script.
+
+=back
+
+=head2 FUNCTION
+
+By default, the ".pl" suffix will be stripped before adding a ".bat" suffix
+to the supplied file names. This can be controlled with the C<-s> option.
+
+The default behavior is to have the batch file compare the C<OS>
+environment variable against C<"Windows_NT">. If they match, it
+uses the C<%*> construct to refer to all the command line arguments
+that were given to it, so you'll need to make sure that works on your
+variant of the command shell. It is known to work in the F<CMD.EXE> shell
+under Windows NT. 4DOS/NT users will want to put a C<ParameterChar = *>
+line in their initialization file, or execute C<setdos /p*> in
+the shell startup file.
+
+On Windows95 and other platforms a nine-argument limit is imposed
+on command-line arguments given to the generated batch file, since
+they may not support C<%*> in batch files.
+
+These can be overridden using the C<-n> and C<-o> options or the
+deprecated C<-a> option.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-n> I<ntargs>
+
+Arguments to invoke perl with in generated batch file when run from
+Windows NT (or Windows 98, probably). Defaults to S<'-x -S %0 %*'>.
+
+=item B<-o> I<otherargs>
+
+Arguments to invoke perl with in generated batch file except when
+run from Windows NT (ie. when run from DOS, Windows 3.1, or Windows 95).
+Defaults to S<'-x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9'>.
+
+=item B<-a> I<argstring>
+
+Arguments to invoke perl with in generated batch file. Specifying
+B<-a> prevents the batch file from checking the C<OS> environment
+variable to determine which operating system it is being run from.
+
+=item B<-s> I<stripsuffix>
+
+Strip a suffix string from file name before appending a ".bat"
+suffix. The suffix is not case-sensitive. It can be a regex if
+it begins with `/' (the trailing '/' is optional and a trailing
+C<$> is always assumed). Defaults to C</.plx?/>.
+
+=item B<-w>
+
+If no line matching C</^#!.*perl/> is found in the script, then such
+a line is inserted just after the new preamble. The exact line
+depends on C<$Config{startperl}> [see L<Config>]. With the B<-w>
+option, C<" -w"> is added after the value of C<$Config{startperl}>.
+If a line matching C</^#!.*perl/> already exists in the script,
+then it is not changed and the B<-w> option is ignored.
+
+=item B<-u>
+
+If the script appears to have already been processed by B<pl2bat>,
+then the script is skipped and not processed unless B<-u> was
+specified. If B<-u> is specified, the existing preamble is replaced.
+
+=item B<-h>
+
+Show command line usage.
+
+=back
+
+=head1 EXAMPLES
+
+ C:\> pl2bat foo.pl bar.PM
+ [..creates foo.bat, bar.PM.bat..]
+
+ C:\> pl2bat -s "/\.pl|\.pm/" foo.pl bar.PM
+ [..creates foo.bat, bar.bat..]
+
+ C:\> pl2bat < somefile > another.bat
+
+ C:\> pl2bat > another.bat
+ print scalar reverse "rekcah lrep rehtona tsuj\n";
+ ^Z
+ [..another.bat is now a certified japh application..]
+
+ C:\> ren *.bat *.pl
+ C:\> pl2bat -u *.pl
+ [..updates the wrapping of some previously wrapped scripts..]
+
+ C:\> pl2bat -u -s .bat *.bat
+ [..same as previous example except more dangerous..]
+
+=head1 BUGS
+
+C<$0> will contain the full name, including the ".bat" suffix
+when the generated batch file runs. If you don't like this,
+see runperl.bat for an alternative way to invoke perl scripts.
+
+Default behavior is to invoke Perl with the B<-S> flag, so Perl will
+search the B<PATH> to find the script. This may have undesirable
+effects.
+
+On really old versions of Win32 Perl, you can't run the script
+via
+
+ C:> script.bat [args]
+
+and must use
+
+ C:> script [args]
+
+A loop should be used to build up the argument list when not on
+Windows NT so more than 9 arguments can be processed.
+
+See also L</Disadvantages>.
+
+=head1 SEE ALSO
+
+perl, perlwin32, runperl.bat
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pl2pm.bat b/Master/tlpkg/tlperl/bin/pl2pm.bat new file mode 100755 index 00000000000..ec126bdf156 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pl2pm.bat @@ -0,0 +1,394 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+=head1 NAME
+
+pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules.
+
+=head1 SYNOPSIS
+
+B<pl2pm> F<files>
+
+=head1 DESCRIPTION
+
+B<pl2pm> is a tool to aid in the conversion of Perl4-style .pl
+library files to Perl5-style library modules. Usually, your old .pl
+file will still work fine and you should only use this tool if you
+plan to update your library to use some of the newer Perl 5 features,
+such as AutoLoading.
+
+=head1 LIMITATIONS
+
+It's just a first step, but it's usually a good first step.
+
+=head1 AUTHOR
+
+Larry Wall <larry@wall.org>
+
+=cut
+
+use strict;
+use warnings;
+
+my %keyword = ();
+
+while (<DATA>) {
+ chomp;
+ $keyword{$_} = 1;
+}
+
+local $/;
+
+while (<>) {
+ my $newname = $ARGV;
+ $newname =~ s/\.pl$/.pm/ || next;
+ $newname =~ s#(.*/)?(\w+)#$1\u$2#;
+ if (-f $newname) {
+ warn "Won't overwrite existing $newname\n";
+ next;
+ }
+ my $oldpack = $2;
+ my $newpack = "\u$2";
+ my @export = ();
+
+ s/\bstd(in|out|err)\b/\U$&/g;
+ s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
+ if (/sub\s+\w+'/) {
+ @export = m/sub\s+\w+'(\w+)/g;
+ s/(sub\s+)main'(\w+)/$1$2/g;
+ }
+ else {
+ @export = m/sub\s+([A-Za-z]\w*)/g;
+ }
+ my @export_ok = grep($keyword{$_}, @export);
+ @export = grep(!$keyword{$_}, @export);
+
+ my %export = ();
+ @export{@export} = (1) x @export;
+
+ s/(^\s*);#/$1#/g;
+ s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
+ s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
+ s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;
+ s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;
+ if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
+ s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
+ s/\$\[\s*\+\s*//g;
+ s/\s*\+\s*\$\[//g;
+ s/\$\[/0/g;
+ }
+ s/open\s+(\w+)/open($1)/g;
+
+ my $export_ok = '';
+ my $carp ='';
+
+
+ if (s/\bdie\b/croak/g) {
+ $carp = "use Carp;\n";
+ s/croak "([^"]*)\\n"/croak "$1"/g;
+ }
+
+ if (@export_ok) {
+ $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
+ }
+
+ if ( open(PM, ">$newname") ) {
+ print PM <<"END";
+package $newpack;
+use 5.006;
+require Exporter;
+$carp
+\@ISA = qw(Exporter);
+\@EXPORT = qw(@export);
+$export_ok
+$_
+END
+ }
+ else {
+ warn "Can't create $newname: $!\n";
+ }
+}
+
+sub xlate {
+ my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
+
+ my $xlated ;
+ if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
+ $xlated = "${pack}'$ident";
+ }
+ elsif ($pack eq '' || $pack eq 'main') {
+ if ($export->{$ident}) {
+ $xlated = "$prefix$ident";
+ }
+ else {
+ $xlated = "$prefix${pack}::$ident";
+ }
+ }
+ elsif ($pack eq $oldpack) {
+ $xlated = "$prefix${newpack}::$ident";
+ }
+ else {
+ $xlated = "$prefix${pack}::$ident";
+ }
+
+ return $xlated;
+}
+__END__
+AUTOLOAD
+BEGIN
+CHECK
+CORE
+DESTROY
+END
+INIT
+UNITCHECK
+abs
+accept
+alarm
+and
+atan2
+bind
+binmode
+bless
+caller
+chdir
+chmod
+chomp
+chop
+chown
+chr
+chroot
+close
+closedir
+cmp
+connect
+continue
+cos
+crypt
+dbmclose
+dbmopen
+defined
+delete
+die
+do
+dump
+each
+else
+elsif
+endgrent
+endhostent
+endnetent
+endprotoent
+endpwent
+endservent
+eof
+eq
+eval
+exec
+exists
+exit
+exp
+fcntl
+fileno
+flock
+for
+foreach
+fork
+format
+formline
+ge
+getc
+getgrent
+getgrgid
+getgrnam
+gethostbyaddr
+gethostbyname
+gethostent
+getlogin
+getnetbyaddr
+getnetbyname
+getnetent
+getpeername
+getpgrp
+getppid
+getpriority
+getprotobyname
+getprotobynumber
+getprotoent
+getpwent
+getpwnam
+getpwuid
+getservbyname
+getservbyport
+getservent
+getsockname
+getsockopt
+glob
+gmtime
+goto
+grep
+gt
+hex
+if
+index
+int
+ioctl
+join
+keys
+kill
+last
+lc
+lcfirst
+le
+length
+link
+listen
+local
+localtime
+lock
+log
+lstat
+lt
+m
+map
+mkdir
+msgctl
+msgget
+msgrcv
+msgsnd
+my
+ne
+next
+no
+not
+oct
+open
+opendir
+or
+ord
+our
+pack
+package
+pipe
+pop
+pos
+print
+printf
+prototype
+push
+q
+qq
+qr
+quotemeta
+qw
+qx
+rand
+read
+readdir
+readline
+readlink
+readpipe
+recv
+redo
+ref
+rename
+require
+reset
+return
+reverse
+rewinddir
+rindex
+rmdir
+s
+scalar
+seek
+seekdir
+select
+semctl
+semget
+semop
+send
+setgrent
+sethostent
+setnetent
+setpgrp
+setpriority
+setprotoent
+setpwent
+setservent
+setsockopt
+shift
+shmctl
+shmget
+shmread
+shmwrite
+shutdown
+sin
+sleep
+socket
+socketpair
+sort
+splice
+split
+sprintf
+sqrt
+srand
+stat
+study
+sub
+substr
+symlink
+syscall
+sysopen
+sysread
+sysseek
+system
+syswrite
+tell
+telldir
+tie
+tied
+time
+times
+tr
+truncate
+uc
+ucfirst
+umask
+undef
+unless
+unlink
+unpack
+unshift
+untie
+until
+use
+utime
+values
+vec
+wait
+waitpid
+wantarray
+warn
+while
+write
+x
+xor
+y
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pler b/Master/tlpkg/tlperl/bin/pler new file mode 100755 index 00000000000..01002aa034b --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pler @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +use 5.00503; +use strict; + +# On some platforms (mostly Windows), we get errors because +# of Term::Cap issues. To avoid this, set TERM=dumb if the +# user does not have a TERM value already. +# This doesn't remove all possible errors, just the most +# annoying and common ones. +BEGIN { + $ENV{TERM} ||= 'dumb'; +} + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '1.05'; +} + +use pler (); + +unless ( $VERSION eq $pler::VERSION ) { + die "Error: Version mismatch (launch script $VERSION using module $pler::VERSION)"; +} +pler::main(@ARGV); + +exit(0); diff --git a/Master/tlpkg/tlperl/bin/pler.bat b/Master/tlpkg/tlperl/bin/pler.bat new file mode 100755 index 00000000000..924a81f64fd --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pler.bat @@ -0,0 +1,43 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use 5.00503;
+use strict;
+
+# On some platforms (mostly Windows), we get errors because
+# of Term::Cap issues. To avoid this, set TERM=dumb if the
+# user does not have a TERM value already.
+# This doesn't remove all possible errors, just the most
+# annoying and common ones.
+BEGIN {
+ $ENV{TERM} ||= 'dumb';
+}
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.05';
+}
+
+use pler ();
+
+unless ( $VERSION eq $pler::VERSION ) {
+ die "Error: Version mismatch (launch script $VERSION using module $pler::VERSION)";
+}
+pler::main(@ARGV);
+
+exit(0);
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pod2html.bat b/Master/tlpkg/tlperl/bin/pod2html.bat new file mode 100755 index 00000000000..75cf111f655 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pod2html.bat @@ -0,0 +1,160 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+=pod
+
+=head1 NAME
+
+pod2html - convert .pod files to .html files
+
+=head1 SYNOPSIS
+
+ pod2html --help --htmlroot=<name> --infile=<name> --outfile=<name>
+ --podpath=<name>:...:<name> --podroot=<name>
+ --libpods=<name>:...:<name> --recurse --norecurse --verbose
+ --index --noindex --title=<name>
+
+=head1 DESCRIPTION
+
+Converts files from pod format (see L<perlpod>) to HTML format.
+
+=head1 ARGUMENTS
+
+pod2html takes the following arguments:
+
+=over 4
+
+=item help
+
+ --help
+
+Displays the usage message.
+
+=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 infile
+
+ --infile=name
+
+Specify the pod file to convert. Input is taken from STDIN if no
+infile is specified.
+
+=item outfile
+
+ --outfile=name
+
+Specify the HTML file to create. Output goes to STDOUT if no outfile
+is specified.
+
+=item podroot
+
+ --podroot=name
+
+Specify the base directory for finding library pods.
+
+=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 libpods
+
+ --libpods=name:...:name
+
+List of page names (eg, "perlfunc") which contain linkable C<=item>s.
+
+=item netscape
+
+ --netscape
+
+Use Netscape HTML directives when applicable.
+
+=item nonetscape
+
+ --nonetscape
+
+Do not use Netscape HTML directives (default).
+
+=item index
+
+ --index
+
+Generate an index at the top of the HTML file (default behaviour).
+
+=item noindex
+
+ --noindex
+
+Do not generate an index at the top of the HTML file.
+
+
+=item recurse
+
+ --recurse
+
+Recurse into subdirectories specified in podpath (default behaviour).
+
+=item norecurse
+
+ --norecurse
+
+Do not recurse into subdirectories specified in podpath.
+
+=item title
+
+ --title=title
+
+Specify the title of the resulting HTML file.
+
+=item verbose
+
+ --verbose
+
+Display progress messages.
+
+=back
+
+=head1 AUTHOR
+
+Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
+
+=head1 BUGS
+
+See L<Pod::Html> for a list of known bugs in the translator.
+
+=head1 SEE ALSO
+
+L<perlpod>, L<Pod::Html>
+
+=head1 COPYRIGHT
+
+This program is distributed under the Artistic License.
+
+=cut
+
+use Pod::Html;
+
+pod2html @ARGV;
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pod2latex.bat b/Master/tlpkg/tlperl/bin/pod2latex.bat new file mode 100755 index 00000000000..3cc895461a4 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pod2latex.bat @@ -0,0 +1,398 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2latex conversion program
+
+use strict;
+use Pod::LaTeX;
+use Pod::Find qw/ pod_find /;
+use Pod::Usage;
+use Getopt::Long;
+use File::Basename;
+use Symbol;
+
+my $VERSION = "1.01";
+
+# return the entire contents of a text file
+# whose name is given as argument
+sub _get {
+ my $fn = shift;
+ my $infh = gensym;
+ open $infh, $fn
+ or die "Could not open file $fn: $!\n";
+ local $/;
+ return <$infh>;
+}
+
+# Read command line arguments
+
+my %options = (
+ "help" => 0,
+ "man" => 0,
+ "sections" => [],
+ "full" => 0,
+ "out" => undef,
+ "verbose" => 0,
+ "modify" => 0,
+ "h1level" => 1, # section is equivalent to H1
+ "preamble" => [],
+ "postamble" => [],
+ );
+# "prefile" is just like "preamble", but the argument
+# comes from the file named by the argument
+$options{"prefile"} = sub { shift; push @{$options{"preamble"}}, _get(shift) };
+# the same between "postfile" and "postamble"
+$options{"postfile"} = sub { shift; push @{$options{"postamble"}}, _get(shift) };
+
+GetOptions(\%options,
+ "help",
+ "man",
+ "verbose",
+ "full",
+ "sections=s@",
+ "out=s",
+ "modify",
+ "h1level=i",
+ "preamble=s@",
+ "postamble=s@",
+ "prefile=s",
+ "postfile=s"
+ ) || pod2usage(2);
+
+pod2usage(1) if ($options{help});
+pod2usage(-verbose => 2) if ($options{man});
+
+
+# Read all the files from the command line
+my @files = @ARGV;
+
+# Now find which ones are real pods and convert
+# directories to their contents.
+
+# Extract the pods from each arg since some of them might
+# be directories
+# This is not as efficient as using pod_find to search through
+# everything at once but it allows us to preserve the order
+# supplied by the user
+
+my @pods;
+foreach my $arg (@files) {
+ my %pods = pod_find($arg);
+ push(@pods, sort keys %pods);
+}
+
+# Abort if nothing to do
+if ($#pods == -1) {
+ warn "None of the supplied Pod files actually exist\n";
+ exit;
+}
+
+# Only want to override the preamble and postamble if we have
+# been given values.
+my %User;
+$User{UserPreamble} = join("\n", @{$options{'preamble'}})
+ if ($options{preamble} && @{$options{preamble}});
+$User{UserPostamble} = join("\n", @{$options{'postamble'}})
+ if ($options{postamble} && @{$options{postamble}});
+
+
+
+# If $options{'out'} is set we are processing to a single output file
+my $multi_documents;
+if (exists $options{'out'} && defined $options{'out'}) {
+ $multi_documents = 0;
+} else {
+ $multi_documents = 1;
+}
+
+# If the output file is not specified it is assumed that
+# a single output file is required per input file using
+# a .tex extension rather than any exisiting extension
+
+if ($multi_documents) {
+
+ # Case where we just generate one input per output
+
+ foreach my $pod (@pods) {
+
+ if (-f $pod) {
+
+ my $output = $pod;
+ $output = basename($output, '.pm', '.pod','.pl') . '.tex';
+
+ # Create a new parser object
+ my $parser = new Pod::LaTeX(
+ AddPreamble => $options{'full'},
+ AddPostamble => $options{'full'},
+ MakeIndex => $options{'full'},
+ TableOfContents => $options{'full'},
+ ReplaceNAMEwithSection => $options{'modify'},
+ UniqueLabels => $options{'modify'},
+ Head1Level => $options{'h1level'},
+ LevelNoNum => $options{'h1level'} + 1,
+ %User,
+ );
+
+ # Select sections if supplied
+ $parser->select(@{ $options{'sections'}})
+ if @{$options{'sections'}};
+
+ # Derive the input file from the output file
+ $parser->parse_from_file($pod, $output);
+
+ print "Written output to $output\n" if $options{'verbose'};
+
+ } else {
+ warn "File $pod not found\n";
+ }
+
+ }
+} else {
+
+ # Case where we want everything to be in a single document
+
+ # Need to open the output file ourselves
+ my $output = $options{'out'};
+ $output .= '.tex' unless $output =~ /\.tex$/;
+
+ # Use auto-vivified file handle in perl 5.6
+ my $outfh = gensym;
+ open ($outfh, ">$output") || die "Could not open output file: $!\n";
+
+ # Flag to indicate whether we have converted at least one file
+ # indicates how many files have been converted
+ my $converted = 0;
+
+ # Loop over the input files
+ foreach my $pod (@pods) {
+
+ if (-f $pod) {
+
+ warn "Converting $pod\n" if $options{'verbose'};
+
+ # Open the file (need the handle)
+ # Use auto-vivified handle in perl 5.6
+ my $podfh = gensym;
+ open ($podfh, "<$pod") || die "Could not open pod file $pod: $!\n";
+
+ # if this is the first file to be converted we may want to add
+ # a preamble (controlled by command line option)
+ my $preamble = 0;
+ $preamble = 1 if ($converted == 0 && $options{'full'});
+
+ # if this is the last file to be converted may want to add
+ # a postamble (controlled by command line option)
+ # relies on a previous pass to check existence of all pods we
+ # are converting.
+ my $postamble = ( ($converted == $#pods && $options{'full'}) ? 1 : 0 );
+
+ # Open parser object
+ # May want to start with a preamble for the first one and
+ # end with an index for the last
+ my $parser = new Pod::LaTeX(
+ MakeIndex => $options{'full'},
+ TableOfContents => $preamble,
+ ReplaceNAMEwithSection => $options{'modify'},
+ UniqueLabels => $options{'modify'},
+ StartWithNewPage => $options{'full'},
+ AddPreamble => $preamble,
+ AddPostamble => $postamble,
+ Head1Level => $options{'h1level'},
+ LevelNoNum => $options{'h1level'} + 1,
+ %User
+ );
+
+ # Store the file name for error messages
+ # This is a kluge that breaks the data hiding of the object
+ $parser->{_INFILE} = $pod;
+
+ # Select sections if supplied
+ $parser->select(@{ $options{'sections'}})
+ if @{$options{'sections'}};
+
+ # Parse it
+ $parser->parse_from_filehandle($podfh, $outfh);
+
+ # We have converted at least one file
+ $converted++;
+
+ } else {
+ warn "File $pod not found\n";
+ }
+
+ }
+
+ # Should unlink the file if we didn't convert anything!
+ # dont check for return status of unlink
+ # since there is not a lot to be done if the unlink failed
+ # and the program does not rely upon it.
+ unlink "$output" unless $converted;
+
+ # If verbose
+ warn "Converted $converted files\n" if $options{'verbose'};
+
+}
+
+exit;
+
+__END__
+
+=head1 NAME
+
+pod2latex - convert pod documentation to latex format
+
+=head1 SYNOPSIS
+
+ pod2latex *.pm
+
+ pod2latex -out mytex.tex *.pod
+
+ pod2latex -full -sections 'DESCRIPTION|NAME' SomeDir
+
+ pod2latex -prefile h.tex -postfile t.tex my.pod
+
+=head1 DESCRIPTION
+
+C<pod2latex> is a program to convert POD format documentation
+(L<perlpod>) into latex. It can process multiple input documents at a
+time and either generate a latex file per input document or a single
+combined output file.
+
+=head1 OPTIONS AND ARGUMENTS
+
+This section describes the supported command line options. Minimum
+matching is supported.
+
+=over 4
+
+=item B<-out>
+
+Name of the output file to be used. If there are multiple input pods
+it is assumed that the intention is to write all translated output
+into a single file. C<.tex> is appended if not present. If the
+argument is not supplied, a single document will be created for each
+input file.
+
+=item B<-full>
+
+Creates a complete C<latex> file that can be processed immediately
+(unless C<=for/=begin> directives are used that rely on extra packages).
+Table of contents and index generation commands are included in the
+wrapper C<latex> code.
+
+=item B<-sections>
+
+Specify pod sections to include (or remove if negated) in the
+translation. See L<Pod::Select/"SECTION SPECIFICATIONS"> for the
+format to use for I<section-spec>. This option may be given multiple
+times on the command line.This is identical to the similar option in
+the C<podselect()> command.
+
+=item B<-modify>
+
+This option causes the output C<latex> to be slightly
+modified from the input pod such that when a C<=head1 NAME>
+is encountered a section is created containing the actual
+pod name (rather than B<NAME>) and all subsequent C<=head1>
+directives are treated as subsections. This has the advantage
+that the description of a module will be in its own section
+which is helpful for including module descriptions in documentation.
+Also forces C<latex> label and index entries to be prefixed by the
+name of the module.
+
+=item B<-h1level>
+
+Specifies the C<latex> section that is equivalent to a C<H1> pod
+directive. This is an integer between 0 and 5 with 0 equivalent to a
+C<latex> chapter, 1 equivalent to a C<latex> section etc. The default
+is 1 (C<H1> equivalent to a latex section).
+
+=item B<-help>
+
+Print a brief help message and exit.
+
+=item B<-man>
+
+Print the manual page and exit.
+
+=item B<-verbose>
+
+Print information messages as each document is processed.
+
+=item B<-preamble>
+
+A user-supplied preamble for the LaTeX code. Multiple values
+are supported and appended in order separated by "\n".
+See B<-prefile> for reading the preamble from a file.
+
+=item B<-postamble>
+
+A user supplied postamble for the LaTeX code. Multiple values
+are supported and appended in order separated by "\n".
+See B<-postfile> for reading the postamble from a file.
+
+=item B<-prefile>
+
+A user-supplied preamble for the LaTeX code to be read from the
+named file. Multiple values are supported and appended in
+order. See B<-preamble>.
+
+=item B<-postfile>
+
+A user-supplied postamble for the LaTeX code to be read from the
+named file. Multiple values are supported and appended in
+order. See B<-postamble>.
+
+=back
+
+=head1 BUGS
+
+Known bugs are:
+
+=over 4
+
+=item *
+
+Cross references between documents are not resolved when multiple
+pod documents are converted into a single output C<latex> file.
+
+=item *
+
+Functions and variables are not automatically recognized
+and they will therefore not be marked up in any special way
+unless instructed by an explicit pod command.
+
+=back
+
+=head1 SEE ALSO
+
+L<Pod::LaTeX>
+
+=head1 AUTHOR
+
+Tim Jenness E<lt>tjenness@cpan.orgE<gt>
+
+This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+Copyright (C) 2000, 2003, 2004 Tim Jenness. All Rights Reserved.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pod2man b/Master/tlpkg/tlperl/bin/pod2man new file mode 100755 index 00000000000..1eff3ca275f --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pod2man @@ -0,0 +1,549 @@ +#!perl
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2man -- Convert POD data to formatted *roff input.
+#
+# Copyright 1999, 2000, 2001, 2004, 2006, 2008 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.
+
+require 5.004;
+
+use Getopt::Long qw(GetOptions);
+use Pod::Man ();
+use Pod::Usage qw(pod2usage);
+
+use strict;
+
+# Silence -w warnings.
+use vars qw($running_under_some_shell);
+
+# Insert -- into @ARGV before any single dash argument to hide it from
+# Getopt::Long; we want to interpret it as meaning stdin.
+my $stdin;
+@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
+
+# Parse our options, trying to retain backward compatibility with pod2man but
+# allowing short forms as well. --lax is currently ignored.
+my %options;
+$options{errors} = 'pod';
+Getopt::Long::config ('bundling_override');
+GetOptions (\%options, 'center|c=s', 'date|d=s', 'fixed=s', 'fixedbold=s',
+ 'fixeditalic=s', 'fixedbolditalic=s', 'help|h', 'lax|l',
+ 'name|n=s', 'official|o', 'quotes|q=s', 'release|r:s',
+ 'section|s=s', 'stderr', 'verbose|v', 'utf8|u') or exit 1;
+pod2usage (0) if $options{help};
+
+# Official sets --center, but don't override things explicitly set.
+if ($options{official} && !defined $options{center}) {
+ $options{center} = 'Perl Programmers Reference Guide';
+}
+
+# Verbose is only our flag, not a Pod::Man flag.
+my $verbose = $options{verbose};
+delete $options{verbose};
+
+# This isn't a valid Pod::Man option and is only accepted for backward
+# compatibility.
+delete $options{lax};
+
+# Initialize and run the formatter, pulling a pair of input and output off at
+# a time.
+my $parser = Pod::Man->new (%options);
+my @files;
+do {
+ @files = splice (@ARGV, 0, 2);
+ print " $files[1]\n" if $verbose;
+ $parser->parse_from_file (@files);
+} while (@ARGV);
+
+__END__
+
+=head1 NAME
+
+pod2man - Convert POD data to formatted *roff input
+
+=for stopwords
+en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris
+URL troff troff-specific formatters uppercased Christiansen
+
+=head1 SYNOPSIS
+
+pod2man [B<--center>=I<string>] [B<--date>=I<string>]
+ [B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
+ [B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--official>]
+ [B<--quotes>=I<quotes>] [B<--release>[=I<version>]]
+ [B<--section>=I<manext>] [B<--stderr>] [B<--utf8>] [B<--verbose>]
+ [I<input> [I<output>] ...]
+
+pod2man B<--help>
+
+=head1 DESCRIPTION
+
+B<pod2man> is a front-end for Pod::Man, using it to generate *roff input
+from POD source. The resulting *roff code is suitable for display on a
+terminal using nroff(1), normally via man(1), or printing using troff(1).
+
+I<input> is the file to read for POD source (the POD can be embedded in
+code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
+given, is the file to which to write the formatted output. If I<output>
+isn't given, the formatted output is written to C<STDOUT>. Several POD
+files can be processed in the same B<pod2man> invocation (saving module
+load and compile times) by providing multiple pairs of I<input> and
+I<output> files on the command line.
+
+B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can
+be used to set the headers and footers to use; if not given, Pod::Man will
+assume various defaults. See below or L<Pod::Man> for details.
+
+B<pod2man> assumes that your *roff formatters have a fixed-width font
+named C<CW>. If yours is called something else (like C<CR>), use
+B<--fixed> 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, and therefore pod2man also
+takes care of formatting func(), func(n), 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," and
+takes care of several other troff-specific tweaks. See L<Pod::Man> for
+complete information.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-c> I<string>, B<--center>=I<string>
+
+Sets the centered page header to I<string>. The default is "User
+Contributed Perl Documentation", but also see B<--official> below.
+
+=item B<-d> I<string>, B<--date>=I<string>
+
+Set the left-hand footer string to this value. By default, the modification
+date of the input file will be used, or the current date if input comes from
+C<STDIN>.
+
+=item B<--fixed>=I<font>
+
+The fixed-width font to use for verbatim text and code. Defaults to
+C<CW>. Some systems may want C<CR> instead. Only matters for troff(1)
+output.
+
+=item B<--fixedbold>=I<font>
+
+Bold version of the fixed-width font. Defaults to C<CB>. Only matters
+for troff(1) output.
+
+=item B<--fixeditalic>=I<font>
+
+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 C<CI>. Only matters for troff(1) output.
+
+=item B<--fixedbolditalic>=I<font>
+
+Bold italic (probably actually oblique) version of the fixed-width font.
+Pod::Man doesn't assume you have this, and defaults to C<CB>. Some
+systems (such as Solaris) have this font available as C<CX>. Only matters
+for troff(1) output.
+
+=item B<-h>, B<--help>
+
+Print out usage information.
+
+=item B<-l>, B<--lax>
+
+No longer used. B<pod2man> used to check its input for validity as a
+manual page, but this should now be done by L<podchecker(1)> instead.
+Accepted for backward compatibility; this option no longer does anything.
+
+=item B<-n> I<name>, B<--name>=I<name>
+
+Set the name of the manual page to I<name>. 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.
+
+Note that this option is probably not useful when converting multiple POD
+files at once. The convention for Unix man pages for commands is for the
+man page title to be in all-uppercase even if the command isn't.
+
+=item B<-o>, B<--official>
+
+Set the default header to indicate that this page is part of the standard
+Perl release, if B<--center> is not also given.
+
+=item B<-q> I<quotes>, B<--quotes>=I<quotes>
+
+Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
+I<quotes> is a single character, it is used as both the left and right
+quote; if I<quotes> is two characters, the first character is used as the
+left quote and the second as the right quoted; and if I<quotes> is four
+characters, the first two are used as the left quote and the second two as
+the right quote.
+
+I<quotes> 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 B<-r>, B<--release>
+
+Set the centered footer. By default, this is the version of Perl you run
+B<pod2man> 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 B<--release> to
+the last modified date and B<--date> to the version number.
+
+=item B<-s>, B<--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 C<.pm>, in
+which case section 3 will be selected.
+
+=item B<--stderr>
+
+By default, B<pod2man> puts any errors detected in the POD input in a POD
+ERRORS section in the output manual page. If B<--stderr> is given, errors
+are sent to standard error instead and the POD ERRORS section is
+suppressed.
+
+=item B<-u>, B<--utf8>
+
+By default, B<pod2man> produces the most conservative possible *roff
+output to try to ensure that it will work with as many different *roff
+implementations as possible. Many *roff implementations cannot handle
+non-ASCII characters, so this means all non-ASCII characters are converted
+either to a *roff escape sequence that tries to create a properly accented
+character (at least for troff output) or to C<X>.
+
+This option says to instead output literal UTF-8 characters. If your
+*roff implementation can handle it, this is the best output format to use
+and avoids corruption of documents containing non-ASCII characters.
+However, be warned that *roff source with literal UTF-8 characters is not
+supported by many implementations and may even result in segfaults and
+other bad behavior.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item B<-v>, B<--verbose>
+
+Print out the name of each output file as it is being generated.
+
+=back
+
+=head1 DIAGNOSTICS
+
+If B<pod2man> fails with errors, see L<Pod::Man> and L<Pod::Simple> for
+information about what those errors might mean.
+
+=head1 EXAMPLES
+
+ pod2man program > program.1
+ pod2man SomeModule.pm /usr/perl/man/man3/SomeModule.3
+ pod2man --section=7 note.pod > note.7
+
+If you would like to print out a lot of man page continuously, you probably
+want to set the C and D registers to set contiguous page numbering and
+even/odd paging, at least on some versions of man(7).
+
+ troff -man -rC1 -rD1 perl.1 perldata.1 perlsyn.1 ...
+
+To get index entries on C<STDERR>, turn on the F register, as in:
+
+ troff -man -rF1 perl.1
+
+The indexing merely outputs messages via C<.tm> for each major page,
+section, subsection, item, and any C<XE<lt>E<gt>> directives. See
+L<Pod::Man> for more details.
+
+=head1 BUGS
+
+Lots of this documentation is duplicated from L<Pod::Man>.
+
+=head1 NOTES
+
+For those not sure of the proper layout of a man page, here are some notes
+on writing a proper man page.
+
+The name of the program being documented is conventionally written in bold
+(using BE<lt>E<gt>) wherever it occurs, as are all program options.
+Arguments should be written in italics (IE<lt>E<gt>). Functions are
+traditionally written in italics; if you write a function as function(),
+Pod::Man will take care of this for you. Literal code or commands should
+be in CE<lt>E<gt>. References to other man pages should be in the form
+C<manpage(section)>, and Pod::Man will automatically format those
+appropriately. As an exception, it's traditional not to use this form when
+referring to module documentation; use C<LE<lt>Module::NameE<gt>> instead.
+
+References to other programs or functions are normally in the form of man
+page references so that cross-referencing tools can provide the user with
+links and the like. It's possible to overdo this, though, so be careful not
+to clutter your documentation with too much markup.
+
+The major headers should be set out using a C<=head1> directive, and are
+historically written in the rather startling ALL UPPER CASE format, although
+this is not mandatory. Minor headers may be included using C<=head2>, and
+are typically in mixed case.
+
+The standard sections of a manual page are:
+
+=over 4
+
+=item NAME
+
+Mandatory section; should be a comma-separated list of programs or functions
+documented by this POD page, such as:
+
+ foo, bar - programs to do something
+
+Manual page indexers are often extremely picky about the format of this
+section, so don't put anything in it except this line. A single dash, and
+only a single dash, should separate the list of programs or functions from
+the description. Do not use any markup such as CE<lt>E<gt> or
+BE<lt>E<gt>. Functions should not be qualified with C<()> or the like.
+The description should ideally fit on a single line, even if a man program
+replaces the dash with a few tabs.
+
+=item SYNOPSIS
+
+A short usage summary for programs and functions. This section is mandatory
+for section 3 pages.
+
+=item DESCRIPTION
+
+Extended description and discussion of the program or functions, or the body
+of the documentation for man pages that document something else. If
+particularly long, it's a good idea to break this up into subsections
+C<=head2> directives like:
+
+ =head2 Normal Usage
+
+ =head2 Advanced Features
+
+ =head2 Writing Configuration Files
+
+or whatever is appropriate for your documentation.
+
+=item OPTIONS
+
+Detailed description of each of the command-line options taken by the
+program. This should be separate from the description for the use of things
+like L<Pod::Usage|Pod::Usage>. This is normally presented as a list, with
+each option as a separate C<=item>. The specific option string should be
+enclosed in BE<lt>E<gt>. Any values that the option takes should be
+enclosed in IE<lt>E<gt>. For example, the section for the option
+B<--section>=I<manext> would be introduced with:
+
+ =item B<--section>=I<manext>
+
+Synonymous options (like both the short and long forms) are separated by a
+comma and a space on the same C<=item> line, or optionally listed as their
+own item with a reference to the canonical name. For example, since
+B<--section> can also be written as B<-s>, the above would be:
+
+ =item B<-s> I<manext>, B<--section>=I<manext>
+
+(Writing the short option first is arguably easier to read, since the long
+option is long enough to draw the eye to it anyway and the short option can
+otherwise get lost in visual noise.)
+
+=item RETURN VALUE
+
+What the program or function returns, if successful. This section can be
+omitted for programs whose precise exit codes aren't important, provided
+they return 0 on success as is standard. It should always be present for
+functions.
+
+=item ERRORS
+
+Exceptions, error return codes, exit statuses, and errno settings.
+Typically used for function documentation; program documentation uses
+DIAGNOSTICS instead. The general rule of thumb is that errors printed to
+C<STDOUT> or C<STDERR> and intended for the end user are documented in
+DIAGNOSTICS while errors passed internal to the calling program and
+intended for other programmers are documented in ERRORS. When documenting
+a function that sets errno, a full list of the possible errno values
+should be given here.
+
+=item DIAGNOSTICS
+
+All possible messages the program can print out--and what they mean. You
+may wish to follow the same documentation style as the Perl documentation;
+see perldiag(1) for more details (and look at the POD source as well).
+
+If applicable, please include details on what the user should do to correct
+the error; documenting an error as indicating "the input buffer is too
+small" without telling the user how to increase the size of the input buffer
+(or at least telling them that it isn't possible) aren't very useful.
+
+=item EXAMPLES
+
+Give some example uses of the program or function. Don't skimp; users often
+find this the most useful part of the documentation. The examples are
+generally given as verbatim paragraphs.
+
+Don't just present an example without explaining what it does. Adding a
+short paragraph saying what the example will do can increase the value of
+the example immensely.
+
+=item ENVIRONMENT
+
+Environment variables that the program cares about, normally presented as a
+list using C<=over>, C<=item>, and C<=back>. For example:
+
+ =over 6
+
+ =item HOME
+
+ Used to determine the user's home directory. F<.foorc> in this
+ directory is read for configuration details, if it exists.
+
+ =back
+
+Since environment variables are normally in all uppercase, no additional
+special formatting is generally needed; they're glaring enough as it is.
+
+=item FILES
+
+All files used by the program or function, normally presented as a list, and
+what it uses them for. File names should be enclosed in FE<lt>E<gt>. It's
+particularly important to document files that will be potentially modified.
+
+=item CAVEATS
+
+Things to take special care with, sometimes called WARNINGS.
+
+=item BUGS
+
+Things that are broken or just don't work quite right.
+
+=item RESTRICTIONS
+
+Bugs you don't plan to fix. :-)
+
+=item NOTES
+
+Miscellaneous commentary.
+
+=item AUTHOR
+
+Who wrote it (use AUTHORS for multiple people). Including your current
+e-mail address (or some e-mail address to which bug reports should be sent)
+so that users have a way of contacting you is a good idea. Remember that
+program documentation tends to roam the wild for far longer than you expect
+and pick an e-mail address that's likely to last if possible.
+
+=item HISTORY
+
+Programs derived from other sources sometimes have this, or you might keep
+a modification log here. If the log gets overly long or detailed,
+consider maintaining it in a separate file, though.
+
+=item COPYRIGHT AND LICENSE
+
+For copyright
+
+ Copyright YEAR(s) by YOUR NAME(s)
+
+(No, (C) is not needed. No, "all rights reserved" is not needed.)
+
+For licensing the easiest way is to use the same licensing as Perl itself:
+
+ This library is free software; you may redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+This makes it easy for people to use your module with Perl. Note that
+this licensing is neither an endorsement or a requirement, you are of
+course free to choose any licensing.
+
+=item SEE ALSO
+
+Other man pages to check out, like man(1), man(7), makewhatis(8), or
+catman(8). Normally a simple list of man pages separated by commas, or a
+paragraph giving the name of a reference work. Man page references, if they
+use the standard C<name(section)> form, don't have to be enclosed in
+LE<lt>E<gt> (although it's recommended), but other things in this section
+probably should be when appropriate.
+
+If the package has a mailing list, include a URL or subscription
+instructions here.
+
+If the package has a web site, include a URL here.
+
+=back
+
+In addition, some systems use CONFORMING TO to note conformance to relevant
+standards and MT-LEVEL to note safeness for use in threaded programs or
+signal handlers. These headings are primarily useful when documenting parts
+of a C library. Documentation of object-oriented libraries or modules may
+use CONSTRUCTORS and METHODS sections for detailed documentation of the
+parts of the library and save the DESCRIPTION section for an overview; other
+large modules may use FUNCTIONS for similar reasons. Some people use
+OVERVIEW to summarize the description if it's quite long.
+
+Section ordering varies, although NAME should I<always> be the first section
+(you'll break some man page systems otherwise), and NAME, SYNOPSIS,
+DESCRIPTION, and OPTIONS generally always occur first and in that order if
+present. In general, SEE ALSO, AUTHOR, and similar material should be left
+for last. Some systems also move WARNINGS and NOTES to last. The order
+given above should be reasonable for most purposes.
+
+Finally, as a general note, try not to use an excessive amount of markup.
+As documented here and in L<Pod::Man>, you can safely leave Perl variables,
+function names, man page references, and the like unadorned by markup and
+the POD translators will figure it out for you. This makes it much easier
+to later edit the documentation. Note that many existing translators
+(including this one currently) will do the wrong thing with e-mail addresses
+when wrapped in LE<lt>E<gt>, so don't do that.
+
+For additional information that may be more accurate for your specific
+system, see either L<man(5)> or L<man(7)> depending on your system manual
+section numbering conventions.
+
+=head1 SEE ALSO
+
+L<Pod::Man>, L<Pod::Simple>, L<man(1)>, L<nroff(1)>, L<perlpod(1)>,
+L<podchecker(1)>, L<troff(1)>, L<man(7)>
+
+The man page documenting the an macro set may be L<man(5)> instead of
+L<man(7)> on your system.
+
+The current version of this script 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 Larry Wall and Tom Christiansen. Large portions of this
+documentation, particularly the sections on the anatomy of a proper man
+page, are taken from the B<pod2man> documentation by Tom.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2004, 2006, 2008 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/tlperl/bin/pod2man.bat b/Master/tlpkg/tlperl/bin/pod2man.bat new file mode 100755 index 00000000000..f2555659bc3 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pod2man.bat @@ -0,0 +1,565 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2man -- Convert POD data to formatted *roff input.
+#
+# Copyright 1999, 2000, 2001, 2004, 2006, 2008 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.
+
+require 5.004;
+
+use Getopt::Long qw(GetOptions);
+use Pod::Man ();
+use Pod::Usage qw(pod2usage);
+
+use strict;
+
+# Silence -w warnings.
+use vars qw($running_under_some_shell);
+
+# Insert -- into @ARGV before any single dash argument to hide it from
+# Getopt::Long; we want to interpret it as meaning stdin.
+my $stdin;
+@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
+
+# Parse our options, trying to retain backward compatibility with pod2man but
+# allowing short forms as well. --lax is currently ignored.
+my %options;
+$options{errors} = 'pod';
+Getopt::Long::config ('bundling_override');
+GetOptions (\%options, 'center|c=s', 'date|d=s', 'fixed=s', 'fixedbold=s',
+ 'fixeditalic=s', 'fixedbolditalic=s', 'help|h', 'lax|l',
+ 'name|n=s', 'official|o', 'quotes|q=s', 'release|r:s',
+ 'section|s=s', 'stderr', 'verbose|v', 'utf8|u') or exit 1;
+pod2usage (0) if $options{help};
+
+# Official sets --center, but don't override things explicitly set.
+if ($options{official} && !defined $options{center}) {
+ $options{center} = 'Perl Programmers Reference Guide';
+}
+
+# Verbose is only our flag, not a Pod::Man flag.
+my $verbose = $options{verbose};
+delete $options{verbose};
+
+# This isn't a valid Pod::Man option and is only accepted for backward
+# compatibility.
+delete $options{lax};
+
+# Initialize and run the formatter, pulling a pair of input and output off at
+# a time.
+my $parser = Pod::Man->new (%options);
+my @files;
+do {
+ @files = splice (@ARGV, 0, 2);
+ print " $files[1]\n" if $verbose;
+ $parser->parse_from_file (@files);
+} while (@ARGV);
+
+__END__
+
+=head1 NAME
+
+pod2man - Convert POD data to formatted *roff input
+
+=for stopwords
+en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris
+URL troff troff-specific formatters uppercased Christiansen
+
+=head1 SYNOPSIS
+
+pod2man [B<--center>=I<string>] [B<--date>=I<string>]
+ [B<--fixed>=I<font>] [B<--fixedbold>=I<font>] [B<--fixeditalic>=I<font>]
+ [B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--official>]
+ [B<--quotes>=I<quotes>] [B<--release>[=I<version>]]
+ [B<--section>=I<manext>] [B<--stderr>] [B<--utf8>] [B<--verbose>]
+ [I<input> [I<output>] ...]
+
+pod2man B<--help>
+
+=head1 DESCRIPTION
+
+B<pod2man> is a front-end for Pod::Man, using it to generate *roff input
+from POD source. The resulting *roff code is suitable for display on a
+terminal using nroff(1), normally via man(1), or printing using troff(1).
+
+I<input> is the file to read for POD source (the POD can be embedded in
+code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
+given, is the file to which to write the formatted output. If I<output>
+isn't given, the formatted output is written to C<STDOUT>. Several POD
+files can be processed in the same B<pod2man> invocation (saving module
+load and compile times) by providing multiple pairs of I<input> and
+I<output> files on the command line.
+
+B<--section>, B<--release>, B<--center>, B<--date>, and B<--official> can
+be used to set the headers and footers to use; if not given, Pod::Man will
+assume various defaults. See below or L<Pod::Man> for details.
+
+B<pod2man> assumes that your *roff formatters have a fixed-width font
+named C<CW>. If yours is called something else (like C<CR>), use
+B<--fixed> 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, and therefore pod2man also
+takes care of formatting func(), func(n), 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," and
+takes care of several other troff-specific tweaks. See L<Pod::Man> for
+complete information.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-c> I<string>, B<--center>=I<string>
+
+Sets the centered page header to I<string>. The default is "User
+Contributed Perl Documentation", but also see B<--official> below.
+
+=item B<-d> I<string>, B<--date>=I<string>
+
+Set the left-hand footer string to this value. By default, the modification
+date of the input file will be used, or the current date if input comes from
+C<STDIN>.
+
+=item B<--fixed>=I<font>
+
+The fixed-width font to use for verbatim text and code. Defaults to
+C<CW>. Some systems may want C<CR> instead. Only matters for troff(1)
+output.
+
+=item B<--fixedbold>=I<font>
+
+Bold version of the fixed-width font. Defaults to C<CB>. Only matters
+for troff(1) output.
+
+=item B<--fixeditalic>=I<font>
+
+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 C<CI>. Only matters for troff(1) output.
+
+=item B<--fixedbolditalic>=I<font>
+
+Bold italic (probably actually oblique) version of the fixed-width font.
+Pod::Man doesn't assume you have this, and defaults to C<CB>. Some
+systems (such as Solaris) have this font available as C<CX>. Only matters
+for troff(1) output.
+
+=item B<-h>, B<--help>
+
+Print out usage information.
+
+=item B<-l>, B<--lax>
+
+No longer used. B<pod2man> used to check its input for validity as a
+manual page, but this should now be done by L<podchecker(1)> instead.
+Accepted for backward compatibility; this option no longer does anything.
+
+=item B<-n> I<name>, B<--name>=I<name>
+
+Set the name of the manual page to I<name>. 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.
+
+Note that this option is probably not useful when converting multiple POD
+files at once. The convention for Unix man pages for commands is for the
+man page title to be in all-uppercase even if the command isn't.
+
+=item B<-o>, B<--official>
+
+Set the default header to indicate that this page is part of the standard
+Perl release, if B<--center> is not also given.
+
+=item B<-q> I<quotes>, B<--quotes>=I<quotes>
+
+Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
+I<quotes> is a single character, it is used as both the left and right
+quote; if I<quotes> is two characters, the first character is used as the
+left quote and the second as the right quoted; and if I<quotes> is four
+characters, the first two are used as the left quote and the second two as
+the right quote.
+
+I<quotes> 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 B<-r>, B<--release>
+
+Set the centered footer. By default, this is the version of Perl you run
+B<pod2man> 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 B<--release> to
+the last modified date and B<--date> to the version number.
+
+=item B<-s>, B<--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 C<.pm>, in
+which case section 3 will be selected.
+
+=item B<--stderr>
+
+By default, B<pod2man> puts any errors detected in the POD input in a POD
+ERRORS section in the output manual page. If B<--stderr> is given, errors
+are sent to standard error instead and the POD ERRORS section is
+suppressed.
+
+=item B<-u>, B<--utf8>
+
+By default, B<pod2man> produces the most conservative possible *roff
+output to try to ensure that it will work with as many different *roff
+implementations as possible. Many *roff implementations cannot handle
+non-ASCII characters, so this means all non-ASCII characters are converted
+either to a *roff escape sequence that tries to create a properly accented
+character (at least for troff output) or to C<X>.
+
+This option says to instead output literal UTF-8 characters. If your
+*roff implementation can handle it, this is the best output format to use
+and avoids corruption of documents containing non-ASCII characters.
+However, be warned that *roff source with literal UTF-8 characters is not
+supported by many implementations and may even result in segfaults and
+other bad behavior.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item B<-v>, B<--verbose>
+
+Print out the name of each output file as it is being generated.
+
+=back
+
+=head1 DIAGNOSTICS
+
+If B<pod2man> fails with errors, see L<Pod::Man> and L<Pod::Simple> for
+information about what those errors might mean.
+
+=head1 EXAMPLES
+
+ pod2man program > program.1
+ pod2man SomeModule.pm /usr/perl/man/man3/SomeModule.3
+ pod2man --section=7 note.pod > note.7
+
+If you would like to print out a lot of man page continuously, you probably
+want to set the C and D registers to set contiguous page numbering and
+even/odd paging, at least on some versions of man(7).
+
+ troff -man -rC1 -rD1 perl.1 perldata.1 perlsyn.1 ...
+
+To get index entries on C<STDERR>, turn on the F register, as in:
+
+ troff -man -rF1 perl.1
+
+The indexing merely outputs messages via C<.tm> for each major page,
+section, subsection, item, and any C<XE<lt>E<gt>> directives. See
+L<Pod::Man> for more details.
+
+=head1 BUGS
+
+Lots of this documentation is duplicated from L<Pod::Man>.
+
+=head1 NOTES
+
+For those not sure of the proper layout of a man page, here are some notes
+on writing a proper man page.
+
+The name of the program being documented is conventionally written in bold
+(using BE<lt>E<gt>) wherever it occurs, as are all program options.
+Arguments should be written in italics (IE<lt>E<gt>). Functions are
+traditionally written in italics; if you write a function as function(),
+Pod::Man will take care of this for you. Literal code or commands should
+be in CE<lt>E<gt>. References to other man pages should be in the form
+C<manpage(section)>, and Pod::Man will automatically format those
+appropriately. As an exception, it's traditional not to use this form when
+referring to module documentation; use C<LE<lt>Module::NameE<gt>> instead.
+
+References to other programs or functions are normally in the form of man
+page references so that cross-referencing tools can provide the user with
+links and the like. It's possible to overdo this, though, so be careful not
+to clutter your documentation with too much markup.
+
+The major headers should be set out using a C<=head1> directive, and are
+historically written in the rather startling ALL UPPER CASE format, although
+this is not mandatory. Minor headers may be included using C<=head2>, and
+are typically in mixed case.
+
+The standard sections of a manual page are:
+
+=over 4
+
+=item NAME
+
+Mandatory section; should be a comma-separated list of programs or functions
+documented by this POD page, such as:
+
+ foo, bar - programs to do something
+
+Manual page indexers are often extremely picky about the format of this
+section, so don't put anything in it except this line. A single dash, and
+only a single dash, should separate the list of programs or functions from
+the description. Do not use any markup such as CE<lt>E<gt> or
+BE<lt>E<gt>. Functions should not be qualified with C<()> or the like.
+The description should ideally fit on a single line, even if a man program
+replaces the dash with a few tabs.
+
+=item SYNOPSIS
+
+A short usage summary for programs and functions. This section is mandatory
+for section 3 pages.
+
+=item DESCRIPTION
+
+Extended description and discussion of the program or functions, or the body
+of the documentation for man pages that document something else. If
+particularly long, it's a good idea to break this up into subsections
+C<=head2> directives like:
+
+ =head2 Normal Usage
+
+ =head2 Advanced Features
+
+ =head2 Writing Configuration Files
+
+or whatever is appropriate for your documentation.
+
+=item OPTIONS
+
+Detailed description of each of the command-line options taken by the
+program. This should be separate from the description for the use of things
+like L<Pod::Usage|Pod::Usage>. This is normally presented as a list, with
+each option as a separate C<=item>. The specific option string should be
+enclosed in BE<lt>E<gt>. Any values that the option takes should be
+enclosed in IE<lt>E<gt>. For example, the section for the option
+B<--section>=I<manext> would be introduced with:
+
+ =item B<--section>=I<manext>
+
+Synonymous options (like both the short and long forms) are separated by a
+comma and a space on the same C<=item> line, or optionally listed as their
+own item with a reference to the canonical name. For example, since
+B<--section> can also be written as B<-s>, the above would be:
+
+ =item B<-s> I<manext>, B<--section>=I<manext>
+
+(Writing the short option first is arguably easier to read, since the long
+option is long enough to draw the eye to it anyway and the short option can
+otherwise get lost in visual noise.)
+
+=item RETURN VALUE
+
+What the program or function returns, if successful. This section can be
+omitted for programs whose precise exit codes aren't important, provided
+they return 0 on success as is standard. It should always be present for
+functions.
+
+=item ERRORS
+
+Exceptions, error return codes, exit statuses, and errno settings.
+Typically used for function documentation; program documentation uses
+DIAGNOSTICS instead. The general rule of thumb is that errors printed to
+C<STDOUT> or C<STDERR> and intended for the end user are documented in
+DIAGNOSTICS while errors passed internal to the calling program and
+intended for other programmers are documented in ERRORS. When documenting
+a function that sets errno, a full list of the possible errno values
+should be given here.
+
+=item DIAGNOSTICS
+
+All possible messages the program can print out--and what they mean. You
+may wish to follow the same documentation style as the Perl documentation;
+see perldiag(1) for more details (and look at the POD source as well).
+
+If applicable, please include details on what the user should do to correct
+the error; documenting an error as indicating "the input buffer is too
+small" without telling the user how to increase the size of the input buffer
+(or at least telling them that it isn't possible) aren't very useful.
+
+=item EXAMPLES
+
+Give some example uses of the program or function. Don't skimp; users often
+find this the most useful part of the documentation. The examples are
+generally given as verbatim paragraphs.
+
+Don't just present an example without explaining what it does. Adding a
+short paragraph saying what the example will do can increase the value of
+the example immensely.
+
+=item ENVIRONMENT
+
+Environment variables that the program cares about, normally presented as a
+list using C<=over>, C<=item>, and C<=back>. For example:
+
+ =over 6
+
+ =item HOME
+
+ Used to determine the user's home directory. F<.foorc> in this
+ directory is read for configuration details, if it exists.
+
+ =back
+
+Since environment variables are normally in all uppercase, no additional
+special formatting is generally needed; they're glaring enough as it is.
+
+=item FILES
+
+All files used by the program or function, normally presented as a list, and
+what it uses them for. File names should be enclosed in FE<lt>E<gt>. It's
+particularly important to document files that will be potentially modified.
+
+=item CAVEATS
+
+Things to take special care with, sometimes called WARNINGS.
+
+=item BUGS
+
+Things that are broken or just don't work quite right.
+
+=item RESTRICTIONS
+
+Bugs you don't plan to fix. :-)
+
+=item NOTES
+
+Miscellaneous commentary.
+
+=item AUTHOR
+
+Who wrote it (use AUTHORS for multiple people). Including your current
+e-mail address (or some e-mail address to which bug reports should be sent)
+so that users have a way of contacting you is a good idea. Remember that
+program documentation tends to roam the wild for far longer than you expect
+and pick an e-mail address that's likely to last if possible.
+
+=item HISTORY
+
+Programs derived from other sources sometimes have this, or you might keep
+a modification log here. If the log gets overly long or detailed,
+consider maintaining it in a separate file, though.
+
+=item COPYRIGHT AND LICENSE
+
+For copyright
+
+ Copyright YEAR(s) by YOUR NAME(s)
+
+(No, (C) is not needed. No, "all rights reserved" is not needed.)
+
+For licensing the easiest way is to use the same licensing as Perl itself:
+
+ This library is free software; you may redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+This makes it easy for people to use your module with Perl. Note that
+this licensing is neither an endorsement or a requirement, you are of
+course free to choose any licensing.
+
+=item SEE ALSO
+
+Other man pages to check out, like man(1), man(7), makewhatis(8), or
+catman(8). Normally a simple list of man pages separated by commas, or a
+paragraph giving the name of a reference work. Man page references, if they
+use the standard C<name(section)> form, don't have to be enclosed in
+LE<lt>E<gt> (although it's recommended), but other things in this section
+probably should be when appropriate.
+
+If the package has a mailing list, include a URL or subscription
+instructions here.
+
+If the package has a web site, include a URL here.
+
+=back
+
+In addition, some systems use CONFORMING TO to note conformance to relevant
+standards and MT-LEVEL to note safeness for use in threaded programs or
+signal handlers. These headings are primarily useful when documenting parts
+of a C library. Documentation of object-oriented libraries or modules may
+use CONSTRUCTORS and METHODS sections for detailed documentation of the
+parts of the library and save the DESCRIPTION section for an overview; other
+large modules may use FUNCTIONS for similar reasons. Some people use
+OVERVIEW to summarize the description if it's quite long.
+
+Section ordering varies, although NAME should I<always> be the first section
+(you'll break some man page systems otherwise), and NAME, SYNOPSIS,
+DESCRIPTION, and OPTIONS generally always occur first and in that order if
+present. In general, SEE ALSO, AUTHOR, and similar material should be left
+for last. Some systems also move WARNINGS and NOTES to last. The order
+given above should be reasonable for most purposes.
+
+Finally, as a general note, try not to use an excessive amount of markup.
+As documented here and in L<Pod::Man>, you can safely leave Perl variables,
+function names, man page references, and the like unadorned by markup and
+the POD translators will figure it out for you. This makes it much easier
+to later edit the documentation. Note that many existing translators
+(including this one currently) will do the wrong thing with e-mail addresses
+when wrapped in LE<lt>E<gt>, so don't do that.
+
+For additional information that may be more accurate for your specific
+system, see either L<man(5)> or L<man(7)> depending on your system manual
+section numbering conventions.
+
+=head1 SEE ALSO
+
+L<Pod::Man>, L<Pod::Simple>, L<man(1)>, L<nroff(1)>, L<perlpod(1)>,
+L<podchecker(1)>, L<troff(1)>, L<man(7)>
+
+The man page documenting the an macro set may be L<man(5)> instead of
+L<man(7)> on your system.
+
+The current version of this script 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 Larry Wall and Tom Christiansen. Large portions of this
+documentation, particularly the sections on the anatomy of a proper man
+page, are taken from the B<pod2man> documentation by Tom.
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 1999, 2000, 2001, 2004, 2006, 2008 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
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pod2text b/Master/tlpkg/tlperl/bin/pod2text new file mode 100755 index 00000000000..d1f230fd90d --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pod2text @@ -0,0 +1,273 @@ +#!perl
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2text -- Convert POD data to formatted ASCII text.
+#
+# Copyright 1999, 2000, 2001, 2004, 2006, 2008 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.
+#
+# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
+# invoked by perldoc -t among other things.
+
+require 5.004;
+
+use Getopt::Long qw(GetOptions);
+use Pod::Text ();
+use Pod::Usage qw(pod2usage);
+
+use strict;
+
+# Silence -w warnings.
+use vars qw($running_under_some_shell);
+
+# Take an initial pass through our options, looking for one of the form
+# -<number>. We turn that into -w <number> for compatibility with the
+# original pod2text script.
+for (my $i = 0; $i < @ARGV; $i++) {
+ last if $ARGV[$i] =~ /^--$/;
+ if ($ARGV[$i] =~ /^-(\d+)$/) {
+ splice (@ARGV, $i++, 1, '-w', $1);
+ }
+}
+
+# Insert -- into @ARGV before any single dash argument to hide it from
+# Getopt::Long; we want to interpret it as meaning stdin (which Pod::Simple
+# does correctly).
+my $stdin;
+@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
+
+# Parse our options. Use the same names as Pod::Text for simplicity, and
+# default to sentence boundaries turned off for compatibility.
+my %options;
+$options{sentence} = 0;
+Getopt::Long::config ('bundling');
+GetOptions (\%options, 'alt|a', 'code', 'color|c', 'help|h', 'indent|i=i',
+ 'loose|l', 'margin|left-margin|m=i', 'overstrike|o',
+ 'quotes|q=s', 'sentence|s', 'stderr', 'termcap|t', 'utf8|u',
+ 'width|w=i')
+ or exit 1;
+pod2usage (1) if $options{help};
+
+# Figure out what formatter we're going to use. -c overrides -t.
+my $formatter = 'Pod::Text';
+if ($options{color}) {
+ $formatter = 'Pod::Text::Color';
+ eval { require Term::ANSIColor };
+ if ($@) { die "-c (--color) requires Term::ANSIColor be installed\n" }
+ require Pod::Text::Color;
+} elsif ($options{termcap}) {
+ $formatter = 'Pod::Text::Termcap';
+ require Pod::Text::Termcap;
+} elsif ($options{overstrike}) {
+ $formatter = 'Pod::Text::Overstrike';
+ require Pod::Text::Overstrike;
+}
+delete @options{'color', 'termcap', 'overstrike'};
+
+# Initialize and run the formatter.
+my $parser = $formatter->new (%options);
+do {
+ my ($input, $output) = splice (@ARGV, 0, 2);
+ $parser->parse_from_file ($input, $output);
+} while (@ARGV);
+
+__END__
+
+=head1 NAME
+
+pod2text - Convert POD data to formatted ASCII text
+
+=for stopwords
+-aclostu --alt --stderr Allbery --overstrike overstrike --termcap --utf8
+UTF-8
+
+=head1 SYNOPSIS
+
+pod2text [B<-aclostu>] [B<--code>] [B<-i> I<indent>] S<[B<-q> I<quotes>]>
+ [B<--stderr>] S<[B<-w> I<width>]> [I<input> [I<output> ...]]
+
+pod2text B<-h>
+
+=head1 DESCRIPTION
+
+B<pod2text> is a front-end for Pod::Text and its subclasses. It uses them
+to generate formatted ASCII text from POD source. It can optionally use
+either termcap sequences or ANSI color escape sequences to format the text.
+
+I<input> is the file to read for POD source (the POD can be embedded in
+code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
+given, is the file to which to write the formatted output. If I<output>
+isn't given, the formatted output is written to C<STDOUT>. Several POD
+files can be processed in the same B<pod2text> invocation (saving module
+load and compile times) by providing multiple pairs of I<input> and
+I<output> files on the command line.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>, B<--alt>
+
+Use 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.
+
+=item B<--code>
+
+Include any non-POD text from the input file in the output as well. Useful
+for viewing code documented with POD blocks with the POD rendered and the
+code left intact.
+
+=item B<-c>, B<--color>
+
+Format the output with ANSI color escape sequences. Using this option
+requires that Term::ANSIColor be installed on your system.
+
+=item B<-i> I<indent>, B<--indent=>I<indent>
+
+Set the number of spaces to indent regular text, and the default indentation
+for C<=over> blocks. Defaults to 4 spaces if this option isn't given.
+
+=item B<-h>, B<--help>
+
+Print out usage information and exit.
+
+=item B<-l>, B<--loose>
+
+Print a blank line after a C<=head1> heading. Normally, no blank line is
+printed after C<=head1>, although one is still printed after C<=head2>,
+because this is the expected formatting for manual pages; if you're
+formatting arbitrary text documents, using this option is recommended.
+
+=item B<-m> I<width>, B<--left-margin>=I<width>, B<--margin>=I<width>
+
+The width of the left margin in spaces. Defaults to 0. This is the margin
+for all text, including headings, not the amount by which regular text is
+indented; for the latter, see B<-i> option.
+
+=item B<-o>, B<--overstrike>
+
+Format the output with overstrike printing. Bold text is rendered as
+character, backspace, character. Italics and file names are rendered as
+underscore, backspace, character. Many pagers, such as B<less>, know how
+to convert this to bold or underlined text.
+
+=item B<-q> I<quotes>, B<--quotes>=I<quotes>
+
+Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
+I<quotes> is a single character, it is used as both the left and right
+quote; if I<quotes> is two characters, the first character is used as the
+left quote and the second as the right quoted; and if I<quotes> is four
+characters, the first two are used as the left quote and the second two as
+the right quote.
+
+I<quotes> may also be set to the special value C<none>, in which case no
+quote marks are added around CE<lt>> text.
+
+=item B<-s>, B<--sentence>
+
+Assume each sentence ends with two spaces and try to preserve that spacing.
+Without this option, all consecutive whitespace in non-verbatim paragraphs
+is compressed into a single space.
+
+=item B<--stderr>
+
+By default, B<pod2text> puts any errors detected in the POD input in a POD
+ERRORS section in the output manual page. If B<--stderr> is given, errors
+are sent to standard error instead and the POD ERRORS section is
+suppressed.
+
+=item B<-t>, B<--termcap>
+
+Try to determine the width of the screen and the bold and underline
+sequences for the terminal from termcap, and use that information in
+formatting the output. Output will be wrapped at two columns less than the
+width of your terminal device. Using this option requires that your system
+have a termcap file somewhere where Term::Cap can find it and requires that
+your system support termios. With this option, the output of B<pod2text>
+will contain terminal control sequences for your current terminal type.
+
+=item B<-u>, B<--utf8>
+
+By default, B<pod2text> tries to use the same output encoding as its input
+encoding (to be backward-compatible with older versions). This option
+says to instead force the output encoding to UTF-8.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item B<-w>, B<--width=>I<width>, B<->I<width>
+
+The column at which to wrap text on the right-hand side. Defaults to 76,
+unless B<-t> is given, in which case it's two columns less than the width of
+your terminal device.
+
+=back
+
+=head1 DIAGNOSTICS
+
+If B<pod2text> fails with errors, see L<Pod::Text> and L<Pod::Simple> for
+information about what those errors might mean. Internally, it can also
+produce the following diagnostics:
+
+=over 4
+
+=item -c (--color) requires Term::ANSIColor be installed
+
+(F) B<-c> or B<--color> were given, but Term::ANSIColor could not be
+loaded.
+
+=item Unknown option: %s
+
+(F) An unknown command line option was given.
+
+=back
+
+In addition, other L<Getopt::Long> error messages may result from invalid
+command-line options.
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item COLUMNS
+
+If B<-t> is given, B<pod2text> will take the current width of your screen
+from this environment variable, if available. It overrides terminal width
+information in TERMCAP.
+
+=item TERMCAP
+
+If B<-t> is given, B<pod2text> will use the contents of this environment
+variable if available to determine the correct formatting sequences for your
+current terminal device.
+
+=back
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Text::Color>, L<Pod::Text::Overstrike>,
+L<Pod::Text::Termcap>, L<Pod::Simple>, L<perlpod(1)>
+
+The current version of this script 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, 2000, 2001, 2004, 2006, 2008 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/tlperl/bin/pod2text.bat b/Master/tlpkg/tlperl/bin/pod2text.bat new file mode 100755 index 00000000000..2ef787155af --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pod2text.bat @@ -0,0 +1,289 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+# pod2text -- Convert POD data to formatted ASCII text.
+#
+# Copyright 1999, 2000, 2001, 2004, 2006, 2008 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.
+#
+# The driver script for Pod::Text, Pod::Text::Termcap, and Pod::Text::Color,
+# invoked by perldoc -t among other things.
+
+require 5.004;
+
+use Getopt::Long qw(GetOptions);
+use Pod::Text ();
+use Pod::Usage qw(pod2usage);
+
+use strict;
+
+# Silence -w warnings.
+use vars qw($running_under_some_shell);
+
+# Take an initial pass through our options, looking for one of the form
+# -<number>. We turn that into -w <number> for compatibility with the
+# original pod2text script.
+for (my $i = 0; $i < @ARGV; $i++) {
+ last if $ARGV[$i] =~ /^--$/;
+ if ($ARGV[$i] =~ /^-(\d+)$/) {
+ splice (@ARGV, $i++, 1, '-w', $1);
+ }
+}
+
+# Insert -- into @ARGV before any single dash argument to hide it from
+# Getopt::Long; we want to interpret it as meaning stdin (which Pod::Simple
+# does correctly).
+my $stdin;
+@ARGV = map { $_ eq '-' && !$stdin++ ? ('--', $_) : $_ } @ARGV;
+
+# Parse our options. Use the same names as Pod::Text for simplicity, and
+# default to sentence boundaries turned off for compatibility.
+my %options;
+$options{sentence} = 0;
+Getopt::Long::config ('bundling');
+GetOptions (\%options, 'alt|a', 'code', 'color|c', 'help|h', 'indent|i=i',
+ 'loose|l', 'margin|left-margin|m=i', 'overstrike|o',
+ 'quotes|q=s', 'sentence|s', 'stderr', 'termcap|t', 'utf8|u',
+ 'width|w=i')
+ or exit 1;
+pod2usage (1) if $options{help};
+
+# Figure out what formatter we're going to use. -c overrides -t.
+my $formatter = 'Pod::Text';
+if ($options{color}) {
+ $formatter = 'Pod::Text::Color';
+ eval { require Term::ANSIColor };
+ if ($@) { die "-c (--color) requires Term::ANSIColor be installed\n" }
+ require Pod::Text::Color;
+} elsif ($options{termcap}) {
+ $formatter = 'Pod::Text::Termcap';
+ require Pod::Text::Termcap;
+} elsif ($options{overstrike}) {
+ $formatter = 'Pod::Text::Overstrike';
+ require Pod::Text::Overstrike;
+}
+delete @options{'color', 'termcap', 'overstrike'};
+
+# Initialize and run the formatter.
+my $parser = $formatter->new (%options);
+do {
+ my ($input, $output) = splice (@ARGV, 0, 2);
+ $parser->parse_from_file ($input, $output);
+} while (@ARGV);
+
+__END__
+
+=head1 NAME
+
+pod2text - Convert POD data to formatted ASCII text
+
+=for stopwords
+-aclostu --alt --stderr Allbery --overstrike overstrike --termcap --utf8
+UTF-8
+
+=head1 SYNOPSIS
+
+pod2text [B<-aclostu>] [B<--code>] [B<-i> I<indent>] S<[B<-q> I<quotes>]>
+ [B<--stderr>] S<[B<-w> I<width>]> [I<input> [I<output> ...]]
+
+pod2text B<-h>
+
+=head1 DESCRIPTION
+
+B<pod2text> is a front-end for Pod::Text and its subclasses. It uses them
+to generate formatted ASCII text from POD source. It can optionally use
+either termcap sequences or ANSI color escape sequences to format the text.
+
+I<input> is the file to read for POD source (the POD can be embedded in
+code). If I<input> isn't given, it defaults to C<STDIN>. I<output>, if
+given, is the file to which to write the formatted output. If I<output>
+isn't given, the formatted output is written to C<STDOUT>. Several POD
+files can be processed in the same B<pod2text> invocation (saving module
+load and compile times) by providing multiple pairs of I<input> and
+I<output> files on the command line.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>, B<--alt>
+
+Use 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.
+
+=item B<--code>
+
+Include any non-POD text from the input file in the output as well. Useful
+for viewing code documented with POD blocks with the POD rendered and the
+code left intact.
+
+=item B<-c>, B<--color>
+
+Format the output with ANSI color escape sequences. Using this option
+requires that Term::ANSIColor be installed on your system.
+
+=item B<-i> I<indent>, B<--indent=>I<indent>
+
+Set the number of spaces to indent regular text, and the default indentation
+for C<=over> blocks. Defaults to 4 spaces if this option isn't given.
+
+=item B<-h>, B<--help>
+
+Print out usage information and exit.
+
+=item B<-l>, B<--loose>
+
+Print a blank line after a C<=head1> heading. Normally, no blank line is
+printed after C<=head1>, although one is still printed after C<=head2>,
+because this is the expected formatting for manual pages; if you're
+formatting arbitrary text documents, using this option is recommended.
+
+=item B<-m> I<width>, B<--left-margin>=I<width>, B<--margin>=I<width>
+
+The width of the left margin in spaces. Defaults to 0. This is the margin
+for all text, including headings, not the amount by which regular text is
+indented; for the latter, see B<-i> option.
+
+=item B<-o>, B<--overstrike>
+
+Format the output with overstrike printing. Bold text is rendered as
+character, backspace, character. Italics and file names are rendered as
+underscore, backspace, character. Many pagers, such as B<less>, know how
+to convert this to bold or underlined text.
+
+=item B<-q> I<quotes>, B<--quotes>=I<quotes>
+
+Sets the quote marks used to surround CE<lt>> text to I<quotes>. If
+I<quotes> is a single character, it is used as both the left and right
+quote; if I<quotes> is two characters, the first character is used as the
+left quote and the second as the right quoted; and if I<quotes> is four
+characters, the first two are used as the left quote and the second two as
+the right quote.
+
+I<quotes> may also be set to the special value C<none>, in which case no
+quote marks are added around CE<lt>> text.
+
+=item B<-s>, B<--sentence>
+
+Assume each sentence ends with two spaces and try to preserve that spacing.
+Without this option, all consecutive whitespace in non-verbatim paragraphs
+is compressed into a single space.
+
+=item B<--stderr>
+
+By default, B<pod2text> puts any errors detected in the POD input in a POD
+ERRORS section in the output manual page. If B<--stderr> is given, errors
+are sent to standard error instead and the POD ERRORS section is
+suppressed.
+
+=item B<-t>, B<--termcap>
+
+Try to determine the width of the screen and the bold and underline
+sequences for the terminal from termcap, and use that information in
+formatting the output. Output will be wrapped at two columns less than the
+width of your terminal device. Using this option requires that your system
+have a termcap file somewhere where Term::Cap can find it and requires that
+your system support termios. With this option, the output of B<pod2text>
+will contain terminal control sequences for your current terminal type.
+
+=item B<-u>, B<--utf8>
+
+By default, B<pod2text> tries to use the same output encoding as its input
+encoding (to be backward-compatible with older versions). This option
+says to instead force the output encoding to UTF-8.
+
+Be aware that, when using this option, the input encoding of your POD
+source must be properly declared unless it is US-ASCII or Latin-1. POD
+input without an C<=encoding> command will be assumed to be in Latin-1,
+and if it's actually in UTF-8, the output will be double-encoded. See
+L<perlpod(1)> for more information on the C<=encoding> command.
+
+=item B<-w>, B<--width=>I<width>, B<->I<width>
+
+The column at which to wrap text on the right-hand side. Defaults to 76,
+unless B<-t> is given, in which case it's two columns less than the width of
+your terminal device.
+
+=back
+
+=head1 DIAGNOSTICS
+
+If B<pod2text> fails with errors, see L<Pod::Text> and L<Pod::Simple> for
+information about what those errors might mean. Internally, it can also
+produce the following diagnostics:
+
+=over 4
+
+=item -c (--color) requires Term::ANSIColor be installed
+
+(F) B<-c> or B<--color> were given, but Term::ANSIColor could not be
+loaded.
+
+=item Unknown option: %s
+
+(F) An unknown command line option was given.
+
+=back
+
+In addition, other L<Getopt::Long> error messages may result from invalid
+command-line options.
+
+=head1 ENVIRONMENT
+
+=over 4
+
+=item COLUMNS
+
+If B<-t> is given, B<pod2text> will take the current width of your screen
+from this environment variable, if available. It overrides terminal width
+information in TERMCAP.
+
+=item TERMCAP
+
+If B<-t> is given, B<pod2text> will use the contents of this environment
+variable if available to determine the correct formatting sequences for your
+current terminal device.
+
+=back
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Text::Color>, L<Pod::Text::Overstrike>,
+L<Pod::Text::Termcap>, L<Pod::Simple>, L<perlpod(1)>
+
+The current version of this script 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, 2000, 2001, 2004, 2006, 2008 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
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pod2usage.bat b/Master/tlpkg/tlperl/bin/pod2usage.bat new file mode 100755 index 00000000000..94d50856f08 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pod2usage.bat @@ -0,0 +1,157 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -S $0 "$@"'
+ if 0;
+
+#############################################################################
+# pod2usage -- command to print usage messages from embedded pod docs
+#
+# Copyright (c) 1996-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.
+#############################################################################
+
+use strict;
+#use diagnostics;
+
+=head1 NAME
+
+pod2usage - print usage messages from embedded pod docs in files
+
+=head1 SYNOPSIS
+
+=over 12
+
+=item B<pod2usage>
+
+[B<-help>]
+[B<-man>]
+[B<-exit>S< >I<exitval>]
+[B<-output>S< >I<outfile>]
+[B<-verbose> I<level>]
+[B<-pathlist> I<dirlist>]
+I<file>
+
+=back
+
+=head1 OPTIONS AND ARGUMENTS
+
+=over 8
+
+=item B<-help>
+
+Print a brief help message and exit.
+
+=item B<-man>
+
+Print this command's manual page and exit.
+
+=item B<-exit> I<exitval>
+
+The exit status value to return.
+
+=item B<-output> I<outfile>
+
+The output file to print to. If the special names "-" or ">&1" or ">&STDOUT"
+are used then standard output is used. If ">&2" or ">&STDERR" is used then
+standard error is used.
+
+=item B<-verbose> I<level>
+
+The desired level of verbosity to use:
+
+ 1 : print SYNOPSIS only
+ 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections
+ 3 : print the entire manpage (similar to running pod2text)
+
+=item B<-pathlist> I<dirlist>
+
+Specifies one or more directories to search for the input file if it
+was not supplied with an absolute path. Each directory path in the given
+list should be separated by a ':' on Unix (';' on MSWin32 and DOS).
+
+=item I<file>
+
+The pathname of a file containing pod documentation to be output in
+usage message format (defaults to standard input).
+
+=back
+
+=head1 DESCRIPTION
+
+B<pod2usage> will read the given input file looking for pod
+documentation and will print the corresponding usage message.
+If no input file is specified then standard input is read.
+
+B<pod2usage> invokes the B<pod2usage()> function in the B<Pod::Usage>
+module. Please see L<Pod::Usage/pod2usage()>.
+
+=head1 SEE ALSO
+
+L<Pod::Usage>, L<pod2text(1)>
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>
+
+Based on code for B<pod2text(1)> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
+use Pod::Usage;
+use Getopt::Long;
+
+## Define options
+my %options = ();
+my @opt_specs = (
+ 'help',
+ 'man',
+ 'exit=i',
+ 'output=s',
+ 'pathlist=s',
+ 'verbose=i',
+);
+
+## Parse options
+GetOptions(\%options, @opt_specs) || pod2usage(2);
+pod2usage(1) if ($options{help});
+pod2usage(VERBOSE => 2) if ($options{man});
+
+## Dont default to STDIN if connected to a terminal
+pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
+
+@ARGV = ('-') unless (@ARGV);
+if (@ARGV > 1) {
+ print STDERR "pod2usage: Too many filenames given\n\n";
+ pod2usage(2);
+}
+
+my %usage = ();
+$usage{-input} = shift(@ARGV);
+$usage{-exitval} = $options{'exit'} if (defined $options{'exit'});
+$usage{-output} = $options{'output'} if (defined $options{'output'});
+$usage{-verbose} = $options{'verbose'} if (defined $options{'verbose'});
+$usage{-pathlist} = $options{'pathlist'} if (defined $options{'pathlist'});
+
+pod2usage(\%usage);
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/podchecker.bat b/Master/tlpkg/tlperl/bin/podchecker.bat new file mode 100755 index 00000000000..4763503eca9 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/podchecker.bat @@ -0,0 +1,161 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -S $0 "$@"'
+ if 0;
+#############################################################################
+# podchecker -- command to invoke the podchecker function in Pod::Checker
+#
+# Copyright (c) 1998-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.
+#############################################################################
+
+use strict;
+#use diagnostics;
+
+=head1 NAME
+
+podchecker - check the syntax of POD format documentation files
+
+=head1 SYNOPSIS
+
+B<podchecker> [B<-help>] [B<-man>] [B<-(no)warnings>] [I<file>S< >...]
+
+=head1 OPTIONS AND ARGUMENTS
+
+=over 8
+
+=item B<-help>
+
+Print a brief help message and exit.
+
+=item B<-man>
+
+Print the manual page and exit.
+
+=item B<-warnings> B<-nowarnings>
+
+Turn on/off printing of warnings. Repeating B<-warnings> increases the
+warning level, i.e. more warnings are printed. Currently increasing to
+level two causes flagging of unescaped "E<lt>,E<gt>" characters.
+
+=item I<file>
+
+The pathname of a POD file to syntax-check (defaults to standard input).
+
+=back
+
+=head1 DESCRIPTION
+
+B<podchecker> will read the given input files looking for POD
+syntax errors in the POD documentation and will print any errors
+it find to STDERR. At the end, it will print a status message
+indicating the number of errors found.
+
+Directories are ignored, an appropriate warning message is printed.
+
+B<podchecker> invokes the B<podchecker()> function exported by B<Pod::Checker>
+Please see L<Pod::Checker/podchecker()> for more details.
+
+=head1 RETURN VALUE
+
+B<podchecker> returns a 0 (zero) exit status if all specified
+POD files are ok.
+
+=head1 ERRORS
+
+B<podchecker> returns the exit status 1 if at least one of
+the given POD files has syntax errors.
+
+The status 2 indicates that at least one of the specified
+files does not contain I<any> POD commands.
+
+Status 1 overrides status 2. If you want unambiguous
+results, call B<podchecker> with one single argument only.
+
+=head1 SEE ALSO
+
+L<Pod::Parser> and L<Pod::Checker>
+
+=head1 AUTHORS
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>,
+Marek Rouchal E<lt>marekr@cpan.orgE<gt>
+
+Based on code for B<Pod::Text::pod2text(1)> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
+
+use Pod::Checker;
+use Pod::Usage;
+use Getopt::Long;
+
+## Define options
+my %options;
+
+## Parse options
+GetOptions(\%options, qw(help man warnings+ nowarnings)) || pod2usage(2);
+pod2usage(1) if ($options{help});
+pod2usage(-verbose => 2) if ($options{man});
+
+if($options{nowarnings}) {
+ $options{warnings} = 0;
+}
+elsif(!defined $options{warnings}) {
+ $options{warnings} = 1; # default is warnings on
+}
+
+## Dont default to STDIN if connected to a terminal
+pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
+
+## Invoke podchecker()
+my $status = 0;
+@ARGV = qw(-) unless(@ARGV);
+for my $podfile (@ARGV) {
+ if($podfile eq '-') {
+ $podfile = '<&STDIN';
+ }
+ elsif(-d $podfile) {
+ warn "podchecker: Warning: Ignoring directory '$podfile'\n";
+ next;
+ }
+ my $errors =
+ podchecker($podfile, undef, '-warnings' => $options{warnings});
+ if($errors > 0) {
+ # errors occurred
+ $status = 1;
+ printf STDERR ("%s has %d pod syntax %s.\n",
+ $podfile, $errors,
+ ($errors == 1) ? 'error' : 'errors');
+ }
+ elsif($errors < 0) {
+ # no pod found
+ $status = 2 unless($status);
+ print STDERR "$podfile does not contain any pod commands.\n";
+ }
+ else {
+ print STDERR "$podfile pod syntax OK.\n";
+ }
+}
+exit $status;
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/podselect.bat b/Master/tlpkg/tlperl/bin/podselect.bat new file mode 100755 index 00000000000..d9d05ec85c8 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/podselect.bat @@ -0,0 +1,120 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec perl -S $0 "$@"'
+ if 0;
+
+#############################################################################
+# podselect -- command to invoke the podselect function in Pod::Select
+#
+# Copyright (c) 1996-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.
+#############################################################################
+
+use strict;
+#use diagnostics;
+
+=head1 NAME
+
+podselect - print selected sections of pod documentation on standard output
+
+=head1 SYNOPSIS
+
+B<podselect> [B<-help>] [B<-man>] [B<-section>S< >I<section-spec>]
+[I<file>S< >...]
+
+=head1 OPTIONS AND ARGUMENTS
+
+=over 8
+
+=item B<-help>
+
+Print a brief help message and exit.
+
+=item B<-man>
+
+Print the manual page and exit.
+
+=item B<-section>S< >I<section-spec>
+
+Specify a section to include in the output.
+See L<Pod::Parser/"SECTION SPECIFICATIONS">
+for the format to use for I<section-spec>.
+This option may be given multiple times on the command line.
+
+=item I<file>
+
+The pathname of a file from which to select sections of pod
+documentation (defaults to standard input).
+
+=back
+
+=head1 DESCRIPTION
+
+B<podselect> will read the given input files looking for pod
+documentation and will print out (in raw pod format) all sections that
+match one ore more of the given section specifications. If no section
+specifications are given than all pod sections encountered are output.
+
+B<podselect> invokes the B<podselect()> function exported by B<Pod::Select>
+Please see L<Pod::Select/podselect()> for more details.
+
+=head1 SEE ALSO
+
+L<Pod::Parser> and L<Pod::Select>
+
+=head1 AUTHOR
+
+Please report bugs using L<http://rt.cpan.org>.
+
+Brad Appleton E<lt>bradapp@enteract.comE<gt>
+
+Based on code for B<Pod::Text::pod2text(1)> written by
+Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+
+=cut
+
+use Pod::Select;
+use Pod::Usage;
+use Getopt::Long;
+
+## Define options
+my %options = (
+ 'help' => 0,
+ 'man' => 0,
+ 'sections' => [],
+);
+
+## Parse options
+GetOptions(\%options, 'help', 'man', 'sections|select=s@') || pod2usage(2);
+pod2usage(1) if ($options{help});
+pod2usage(-verbose => 2) if ($options{man});
+
+## Dont default to STDIN if connected to a terminal
+pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
+
+## Invoke podselect().
+if (@{ $options{'sections'} } > 0) {
+ podselect({ -sections => $options{'sections'} }, @ARGV);
+}
+else {
+ podselect(@ARGV);
+}
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/ppd2par b/Master/tlpkg/tlperl/bin/ppd2par new file mode 100755 index 00000000000..64bcb5dc3c7 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ppd2par @@ -0,0 +1,167 @@ +#!/usr/bin/perl +use strict; +use warnings; + +use Getopt::Long qw/GetOptions/; +use PAR::Dist::FromPPD; + +our $VERSION = '0.01'; + +=pod + +=head1 NAME + +ppd2par - Create PAR distributions from PPD XML files + +=head1 SYNOPSIS + +ppd2par --help + +ppd2par [-v -o DIR ...] -u PPD-URI-OR-FILE + +=head1 DESCRIPTION + +This script creates PAR distributions from packages for the +I<Perl Package Manager> which is specific to ActiveState's +perl distributions. In order to do this, F<ppd2par> parses +a PPD document (which is XML). The PPD document +contains meta data and URIs for the actual F<.tar.gz> packages +of the PPM package. + +=head2 Parameters + + -u --uri + Set the place to fetch the .ppd file from. Can be an URL + (http://..., https://..., ftp://...) or a local file. + -v --verbose + Sets the verbose mode. + -o --out + Sets the output directory. (default: .) + --no-docs + Strip all documentation (man pages, html documentation) from the + resulting PAR distribution. + (This step is carried out at the end. If something goes wrong, + it will be skipped.) + +You can also set various bits of meta data by hand: + + -n --distname + Distribution name + --dv --distversion + Distribution version (Note: This is not -v!) + -p --perlversion + Perl version (can be set to 'any_version') + -a --arch + Architecture string (can be set to 'any_arch') + --sa --selectarch + Regexp for selecting the implementation based on architecture + --sp --selectperl + Regexp for selecting the implementation based on perl version + +=head1 SEE ALSO + +This tool is implemented using the L<PAR::Dist::FromPPD> module. Please +refer to that module's documentation for details on how this all works. + +PAR has a mailing list, <par@perl.org>, that you can write to; send +an empty mail to <par-subscribe@perl.org> to join the list and +participate in the discussion. + +Please send bug reports to <bug-par-dist-fromcpan@rt.cpan.org>. + +The official PAR website may be of help, too: http://par.perl.org + +For details on the I<Perl Package Manager>, please refer to ActiveState's +website at L<http://activestate.com>. + +=head1 AUTHOR + +Steffen Mueller, E<lt>smueller at cpan dot orgE<gt> + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2006 by Steffen Mueller + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut + +my $usage = <<"HERE"; +$0 --help # for help + +$0 [-v -o DIR --no-docs] -u PPD-URI-OR-FILE + +This script creates PAR distributions from packages for the +Perl Package Manager which is specific to ActiveState's +perl distributions. In order to do this, it parses +a PPD document (which is XML). The PPD document +contains meta data and URIs for the actual .tar.gz packages +of the PPM package. + +-u --uri + Set the place to fetch the .ppd file from. Can be an URL + (http://..., https://..., ftp://...) or a local file. +-v --verbose + Sets the verbose mode. +-o --out + Sets the output directory. (default: .) +--no-docs + Strip all documentation (man pages, html documentation) from the + resulting PAR distribution. + (This step is carried out at the end. If something goes wrong, + it will be skipped.) + +You can also set various bits of meta data by hand: +-n --distname + Distribution name +--dv --distversion + Distribution version (Note: This is not -v!) +-p --perlversion + Perl version (can be set to 'any_version') +-a --arch + Architecture string (can be set to 'any_arch') +--sa --selectarch + Regexp for selecting the implementation based on architecture +--sp --selectperl + Regexp for selecting the implementation based on perl version +HERE + +my $uri; +my $outdir = '.'; +my $v = 0; +my $nodocs = 0; +my $distname; +my $distversion; +my $arch; +my $perl; +my $sperl; +my $sarch; +GetOptions( + 'n|distname=s' => \$distname, + 'dv|distversion=s' => \$distversion, + 'a|arch=s' => \$arch, + 'p|perlversion=s' => \$perl, + 'sa|selectarch=s' => \$sarch, + 'sp|selectperl=s' => \$sperl, + 'h|help' => sub { print $usage; exit(1) }, + 'o|out=s' => \$outdir, + 'u|uri=s' => \$uri, + 'v|verbose' => \$v, + 'no-docs' => \$nodocs, +); + +ppd_to_par( + uri => $uri, + ($v ? (verbose => 1 ) : ()), + (defined($outdir) ? (out => $outdir ) : ()), + ($nodocs ? (strip_docs => 1 ) : ()), + ($distname ? (distname => $distname ) : ()), + ($distversion ? (distversion => $distversion ) : ()), + ($arch ? (arch => $arch ) : ()), + ($perl ? (perlversion => $perl ) : ()), + ($sarch ? (selectarch => $sarch ) : ()), + ($sperl ? (selectperl => $sperl ) : ()), +); + diff --git a/Master/tlpkg/tlperl/bin/ppd2par.bat b/Master/tlpkg/tlperl/bin/ppd2par.bat new file mode 100755 index 00000000000..eecd3c79243 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ppd2par.bat @@ -0,0 +1,183 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+use strict;
+use warnings;
+
+use Getopt::Long qw/GetOptions/;
+use PAR::Dist::FromPPD;
+
+our $VERSION = '0.01';
+
+=pod
+
+=head1 NAME
+
+ppd2par - Create PAR distributions from PPD XML files
+
+=head1 SYNOPSIS
+
+ppd2par --help
+
+ppd2par [-v -o DIR ...] -u PPD-URI-OR-FILE
+
+=head1 DESCRIPTION
+
+This script creates PAR distributions from packages for the
+I<Perl Package Manager> which is specific to ActiveState's
+perl distributions. In order to do this, F<ppd2par> parses
+a PPD document (which is XML). The PPD document
+contains meta data and URIs for the actual F<.tar.gz> packages
+of the PPM package.
+
+=head2 Parameters
+
+ -u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+ -v --verbose
+ Sets the verbose mode.
+ -o --out
+ Sets the output directory. (default: .)
+ --no-docs
+ Strip all documentation (man pages, html documentation) from the
+ resulting PAR distribution.
+ (This step is carried out at the end. If something goes wrong,
+ it will be skipped.)
+
+You can also set various bits of meta data by hand:
+
+ -n --distname
+ Distribution name
+ --dv --distversion
+ Distribution version (Note: This is not -v!)
+ -p --perlversion
+ Perl version (can be set to 'any_version')
+ -a --arch
+ Architecture string (can be set to 'any_arch')
+ --sa --selectarch
+ Regexp for selecting the implementation based on architecture
+ --sp --selectperl
+ Regexp for selecting the implementation based on perl version
+
+=head1 SEE ALSO
+
+This tool is implemented using the L<PAR::Dist::FromPPD> module. Please
+refer to that module's documentation for details on how this all works.
+
+PAR has a mailing list, <par@perl.org>, that you can write to; send
+an empty mail to <par-subscribe@perl.org> to join the list and
+participate in the discussion.
+
+Please send bug reports to <bug-par-dist-fromcpan@rt.cpan.org>.
+
+The official PAR website may be of help, too: http://par.perl.org
+
+For details on the I<Perl Package Manager>, please refer to ActiveState's
+website at L<http://activestate.com>.
+
+=head1 AUTHOR
+
+Steffen Mueller, E<lt>smueller at cpan dot orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006 by Steffen Mueller
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
+
+my $usage = <<"HERE";
+$0 --help # for help
+
+$0 [-v -o DIR --no-docs] -u PPD-URI-OR-FILE
+
+This script creates PAR distributions from packages for the
+Perl Package Manager which is specific to ActiveState's
+perl distributions. In order to do this, it parses
+a PPD document (which is XML). The PPD document
+contains meta data and URIs for the actual .tar.gz packages
+of the PPM package.
+
+-u --uri
+ Set the place to fetch the .ppd file from. Can be an URL
+ (http://..., https://..., ftp://...) or a local file.
+-v --verbose
+ Sets the verbose mode.
+-o --out
+ Sets the output directory. (default: .)
+--no-docs
+ Strip all documentation (man pages, html documentation) from the
+ resulting PAR distribution.
+ (This step is carried out at the end. If something goes wrong,
+ it will be skipped.)
+
+You can also set various bits of meta data by hand:
+-n --distname
+ Distribution name
+--dv --distversion
+ Distribution version (Note: This is not -v!)
+-p --perlversion
+ Perl version (can be set to 'any_version')
+-a --arch
+ Architecture string (can be set to 'any_arch')
+--sa --selectarch
+ Regexp for selecting the implementation based on architecture
+--sp --selectperl
+ Regexp for selecting the implementation based on perl version
+HERE
+
+my $uri;
+my $outdir = '.';
+my $v = 0;
+my $nodocs = 0;
+my $distname;
+my $distversion;
+my $arch;
+my $perl;
+my $sperl;
+my $sarch;
+GetOptions(
+ 'n|distname=s' => \$distname,
+ 'dv|distversion=s' => \$distversion,
+ 'a|arch=s' => \$arch,
+ 'p|perlversion=s' => \$perl,
+ 'sa|selectarch=s' => \$sarch,
+ 'sp|selectperl=s' => \$sperl,
+ 'h|help' => sub { print $usage; exit(1) },
+ 'o|out=s' => \$outdir,
+ 'u|uri=s' => \$uri,
+ 'v|verbose' => \$v,
+ 'no-docs' => \$nodocs,
+);
+
+ppd_to_par(
+ uri => $uri,
+ ($v ? (verbose => 1 ) : ()),
+ (defined($outdir) ? (out => $outdir ) : ()),
+ ($nodocs ? (strip_docs => 1 ) : ()),
+ ($distname ? (distname => $distname ) : ()),
+ ($distversion ? (distversion => $distversion ) : ()),
+ ($arch ? (arch => $arch ) : ()),
+ ($perl ? (perlversion => $perl ) : ()),
+ ($sarch ? (selectarch => $sarch ) : ()),
+ ($sperl ? (selectperl => $sperl ) : ()),
+);
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/ppm.bat b/Master/tlpkg/tlperl/bin/ppm.bat new file mode 100755 index 00000000000..a02cf726d6c --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ppm.bat @@ -0,0 +1,1066 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use Getopt::Long;
+use File::Basename;
+use Config;
+use strict;
+
+use PPM;
+
+$PPM::VERSION = '0.01_01';
+
+my %help;
+
+# mapping of POD sections to command topics
+my %topic = (
+ 'Error Recovery' => 'genconfig',
+ 'Installing' => 'install',
+ 'Querying' => 'query',
+ 'Removing' => 'remove',
+ 'Searching' => 'search',
+ 'Summarizing' => 'summary',
+ 'Verifying' => 'verify',
+ 'Synopsis' => 'usage',
+ 'Options' => 'set',
+);
+
+$help{'help'} = <<'EOT';
+Commands:
+ exit - leave the program.
+ help [command] - prints this screen, or help on 'command'.
+ install PACKAGES - installs specified PACKAGES.
+ quit - leave the program.
+ query [options] - query information about installed packages.
+ remove PACKAGES - removes the specified PACKAGES from the system.
+ search [options] - search information about available packages.
+ set [options] - set/display current options.
+ verify [options] - verifies current install is up to date.
+ version - displays PPM version number
+
+EOT
+
+# Build the rest of the online help from the POD
+$/ = "\n=";
+while (<DATA>) {
+ next unless my ($topic,$text) = /^(?:item|head[12]) ([^\n]+)\n\n(.*)=/s;
+ next unless $topic{$topic};
+ ($help{$topic{$topic}} = "\n$text"); # =~ s/\n *([^\n])/\n $1/sg;
+}
+$/ = "\n";
+
+# Need to do this here, because the user's config file is probably
+# hosed.
+if ($#ARGV == 0 && $ARGV[0] eq 'genconfig') {
+ &genconfig;
+ exit 0;
+}
+
+if ($#ARGV == 0 && $ARGV[0] eq 'getconfig') {
+ print $PPM::PPMdat;
+ exit 0;
+}
+
+my %options = PPM::GetPPMOptions();
+my $location;
+
+my $moremsg = "[Press return to continue or 'q' to quit] ";
+my $interactive = 0;
+
+my %repositories = PPM::ListOfRepositories();
+
+my $prefix_pattern = $^O eq "MSWin32" ? '(--|-|\+|/)' : '(--|-|\+)';
+
+$PPM::PPMShell = 1;
+
+Getopt::Long::Configure("prefix_pattern=$prefix_pattern");
+
+if ($#ARGV == -1 || ($#ARGV == 0 && $ARGV[0] =~ /^${prefix_pattern}location/)) {
+ my $prompt = 'PPM> ';
+ $interactive = 1;
+ GetOptions("location=s" => \$location);
+
+ print "PPM interactive shell ($PPM::VERSION) - type 'help' for available commands.\n";
+ $| = 1;
+ while () {
+ print $prompt;
+ last unless defined ($_ = <> );
+ chomp;
+ s/^\s+//;
+ @ARGV = split(/\s+/, $_);
+ next unless @ARGV;
+ # exit/quit
+ if (command($ARGV[0], "qu|it") or command($ARGV[0], "|exit")) {
+ print "Quit!\n";
+ last;
+ }
+ exec_command();
+ }
+ exit 0;
+}
+
+exit exec_command();
+
+sub exec_command
+{
+ my $cmd = lc shift @ARGV;
+
+ for (@ARGV) {
+ s/::/-/g;
+ }
+
+ # help
+ if (command($cmd, "|help")) {
+ help(@ARGV);
+ }
+ # query
+ elsif (command($cmd, "qu|ery")) {
+ GetOptions("case!" => \my $case, "abstract" => \my $abstract,
+ "author" => \my $author );
+
+ my %summary = InstalledPackageProperties();
+ if (@ARGV) {
+ my $searchtag;
+ if ($abstract || $author) {
+ $searchtag = ($abstract ? 'ABSTRACT' : 'AUTHOR');
+ }
+ my $RE = shift @ARGV;
+ eval { $RE =~ /$RE/ };
+ if ($@) {
+ print "'$RE': invalid regular expression.\n";
+ return 1;
+ }
+ $case = !$options{'IGNORECASE'} unless defined $case;
+ $RE = "(?i)$RE" if ($case == 0);
+ foreach(keys %summary) {
+ if ($searchtag) {
+ delete $summary{$_} unless $summary{$_}{$searchtag} =~ /$RE/;
+ }
+ else {
+ delete $summary{$_} unless /$RE/;
+ }
+ }
+ }
+ print_formatted(1, %summary);
+ }
+ # install
+ elsif (command($cmd, "in|stall")) {
+ my $location = $location;
+ GetOptions("location=s" => \$location);
+ unless (@ARGV) {
+ if (!$interactive && -d "blib" && -f "Makefile") {
+ return if InstallPackage(location => $location);
+ print "Error installing blib: $PPM::PPMERR\n";
+ return 1;
+ }
+ print "Package not specified.\n";
+ return 1;
+ }
+
+ my %installed = InstalledPackageProperties();
+ foreach my $package (@ARGV) {
+ $package =~ s/::/-/g;
+ if (my $pkg = (grep {/^$package$/i} keys %installed)[0]) {
+ my $version = $installed{$pkg}{'VERSION'};
+ $version =~ s/(,0)*$//;
+ $version =~ tr/,/./;
+ print "Version $version of '$pkg' is already installed.\n" .
+ "Remove it, or use 'verify --upgrade $pkg'.\n";
+ next;
+ }
+ elsif ($interactive && $options{'CONFIRM'}) {
+ print "Install package '$package?' (y/N): ";
+ next unless <> =~ /^[yY]/;
+ }
+ print "Installing package '$package'...\n";
+ if(!InstallPackage("package" => $package, "location" => $location)) {
+ print "Error installing package '$package': $PPM::PPMERR\n";
+ }
+ }
+ }
+ # remove
+ elsif (command($cmd, "|remove")) {
+ unless (@ARGV) {
+ print "Package not specified.\n";
+ return 1;
+ }
+ foreach my $package (@ARGV) {
+ $package =~ s/::/-/g;
+ if ($interactive && $options{'CONFIRM'}) {
+ print "Remove package '$package?' (y/N): ";
+ next unless <> =~ /[yY]/;
+ }
+ unless (RemovePackage("package" => $package)) {
+ print "Error removing $package: $PPM::PPMERR\n";
+ }
+ }
+ }
+ # search
+ elsif (command($cmd, "se|arch")) {
+ my (%summary, $searchtag);
+ my $location = $location;
+ GetOptions("case!" => \my $case, "location=s" => \$location,
+ "abstract" => \my $abstract, "author" => \my $author );
+ my $searchRE = shift @ARGV;
+ if (defined $searchRE) {
+ eval { $searchRE =~ /$searchRE/ };
+ if ($@) {
+ print "'$searchRE': invalid regular expression.\n";
+ return 1;
+ }
+ }
+ $case = !$options{'IGNORECASE'} unless defined $case;
+ if ($abstract || $author) {
+ $searchtag = ($abstract ? 'ABSTRACT' : 'AUTHOR');
+ }
+ %summary = search_PPDs("location" => $location, "ignorecase" => !$case,
+ "searchtag" => $searchtag, "searchRE" => $searchRE);
+ foreach (keys %summary) {
+ print "Packages available from $_:\n";
+ print_formatted(2, %{$summary{$_}});
+ }
+ }
+ # set
+ elsif (command($cmd, "se|t")) {
+ unless (set(@ARGV) || $interactive) {
+ PPM::SetPPMOptions("options" => \%options, "save" => 1);
+ }
+ }
+ # verify
+ elsif (command($cmd, "ver|ify")) {
+ my $location = $location;
+ GetOptions("force" => \my $force, "location=s" => \$location,
+ "upgrade" => \my $upgrade);
+ if ($interactive && $upgrade && $options{'CONFIRM'}) {
+ printf "Upgrade package%s? (y/N): ", @ARGV == 1 ? " '$ARGV[0]'" : "s";
+ return unless <> =~ /^[yY]/;
+ }
+ verify_packages("packages" => \@ARGV, "location" => $location,
+ "upgrade" => $upgrade, "force" => $force);
+ }
+ elsif (command($cmd, "ver|sion")) {
+ print "$PPM::VERSION\n";
+ }
+ elsif ($cmd eq "purge") {
+ my %summary = InstalledPackageProperties();
+ foreach(keys %summary) {
+ print "Purging $_\n";
+ RemovePackage("package" => $_, "force" => 1);
+ }
+ }
+ elsif ($cmd eq 'refresh') {
+ my %summary = InstalledPackageProperties();
+ foreach(keys %summary) {
+ print "Refreshing $_\n";
+ InstallPackage("package" => $_);
+ }
+ }
+ else {
+ print "Unknown or ambiguous command '$cmd'; type 'help' for commands.\n";
+ }
+}
+
+sub help {
+ my $topic = @_ && $help{lc $_[0]} ? lc $_[0] : 'help';
+ my $help = $help{$topic};
+ $help =~ s/^(\s*)ppm\s+/$1/mg if $interactive;
+ print $help;
+}
+
+sub more
+{
+ my ($lines) = shift @_;
+ if (++$$lines >= $options{'MORE'}) {
+ print $moremsg;
+ $_ = <>;
+ $$lines = $_ eq "q\n" ? -1 : 1;
+ }
+}
+
+# This nasty piece of business splits $pattern into a required prefix
+# and a "match any of this substring" suffix. E.g. "in|stall" will
+# match a $cmd of "ins", "inst", ..., "install".
+sub command
+{
+ my ($cmd, $pattern) = @_;
+ my @pattern = split(/\|/, $pattern);
+ if ($pattern[1]) {
+ my @optchars = split(//, $pattern[1]);
+ # build up a "foo(b|ba|bar)" string
+ $pattern = "$pattern[0](";
+ $pattern[1] = shift @optchars;
+ $pattern[1] .= "|$pattern[1]$_" foreach @optchars;
+ $pattern .= "$pattern[1])";
+ }
+ return ($cmd =~ /^${pattern}$/i);
+}
+
+# This routine prints the output for query and search
+# in a nicely formatted way, if $options{'VERBOSE'} is set.
+sub print_formatted
+{
+ my ($lines, %summary) = @_;
+ my $package;
+
+ unless ($options{'VERBOSE'}) {
+ foreach $package (sort keys %summary) {
+ print "$package\n";
+ &more(\$lines) if $options{'MORE'} && $interactive;
+ last if $lines == -1;
+ }
+ return;
+ }
+
+ my ($maxname, $maxversion) = (0, 0);
+ # find the longest package name and version strings, so we can
+ # format them nicely
+ $maxname < length($_) and $maxname = length($_) for keys %summary;
+ foreach $package (keys %summary) {
+ $summary{$package}{'VERSION'} =~ s/(,0)*$//;
+ $summary{$package}{'VERSION'} =~ tr/,/./;
+ $maxversion = length $summary{$package}{'VERSION'} > $maxversion ?
+ length $summary{$package}{'VERSION'} : $maxversion;
+ }
+ my $columns = $ENV{COLUMNS} ? $ENV{COLUMNS} : 80;
+ my $namefield = "@" . "<" x ($maxname - 1);
+ my $versionfield = "@" . "<" x ($maxversion - 1);
+ my $abstractfield = "^" . "<" x ($columns - (6 + $maxname + $maxversion));
+ my $abstractpad = " " x ($maxname + $maxversion + 3);
+
+ foreach $package (sort keys %summary) {
+ eval "format STDOUT = \n"
+ . "$namefield [$versionfield] $abstractfield\n"
+ . '$package, $summary{$package}{VERSION}, $summary{$package}{ABSTRACT}'
+ . "\n"
+ . "$abstractpad $abstractfield~~\n"
+ . '$summary{$package}{ABSTRACT}'
+ . "\n"
+ . ".\n";
+
+ my $diff = $-;
+ write;
+ $diff -= $-;
+ $lines += ($diff - 1) if $diff > 1;
+ &more(\$lines) if $options{'MORE'} && $interactive;
+ last if $lines == -1;
+ }
+}
+
+sub set
+{
+ my $option = lc shift @_;
+
+ unless ($option) {
+ print "Commands will " . ($options{'CONFIRM'} ? "" : "not ") .
+ "be confirmed.\n";
+ print "Temporary files will " . ($options{'CLEAN'} ? "" : "not ") .
+ "be deleted.\n";
+ print "Download status will " . (($options{'DOWNLOADSTATUS'} > 0) ?
+ "be updated every $options{'DOWNLOADSTATUS'} bytes.\n" :
+ "not be updated.\n");
+ print "Case-" . ($options{'IGNORECASE'} ? "in" : "") .
+ "sensitive searches will be performed.\n";
+ print "Package installations will " .
+ ($options{'FORCE_INSTALL'} ? "" : "not ") .
+ "continue if a dependency cannot be installed.\n";
+ print "Tracing info will " . (($options{'TRACE'} > 0 ) ?
+ "be written to '$options{'TRACEFILE'}'.\n" : "not be written.\n");
+ print "Screens will " . ($options{'MORE'} > 0 ?
+ "pause after $options{'MORE'} lines.\n" : "not pause.\n");
+ print "Query/search results will " .
+ ($options{'VERBOSE'} ? "" : "not ") . "be verbose.\n";
+ if (defined $location) { print "Current PPD repository: $location\n"; }
+ else {
+ print "Current PPD repository paths:\n";
+ foreach $_ (keys %repositories) {
+ print "\t$_: $repositories{$_}\n";
+ }
+ }
+ print "Packages will be installed under: $options{'ROOT'}\n"
+ if ($options{'ROOT'});
+ print "Packages will be built under: $options{'BUILDDIR'}\n"
+ if ($options{'BUILDDIR'});
+ return;
+ }
+
+ my $value = shift @_;
+ if (command($option, "r|epository")) {
+ if ($value =~ /${prefix_pattern}remove/i) {
+ $value = join(" ", @_);
+ print "Location not specified.\n" and return 1
+ unless (defined $value);
+ PPM::RemoveRepository("repository" => $value);
+ %repositories = PPM::ListOfRepositories();
+ }
+ else {
+ my $location = shift @_;
+ print "Repository not specified.\n" and return 1
+ unless (defined $value and defined $location);
+ PPM::AddRepository("repository" => $value,
+ "location" => $location);
+ %repositories = PPM::ListOfRepositories();
+ }
+ }
+ else {
+ if (command($option, "c|onfirm")) {
+ $options{'CONFIRM'} = defined $value ?
+ ($value != 0) : ($options{'CONFIRM'} ? 0 : 1);
+ print "Commands will " . ($options{'CONFIRM'} ? "" : "not ") .
+ "be confirmed.\n";
+ }
+ elsif (command($option, "|save")) {
+ PPM::SetPPMOptions("options" => \%options, "save" => 1);
+ return 0;
+ }
+ elsif (command($option, "c|ase")) {
+ $options{'IGNORECASE'} = defined $value ?
+ ($value == 0) : ($options{'IGNORECASE'} ? 0 : 1);
+ print "Case-" . ($options{'IGNORECASE'} ? "in" : "") .
+ "sensitive searches will be performed.\n";
+ }
+ elsif (command($option, "r|oot")) {
+ my $old_root;
+ print "Directory not specified.\n" and return 1 unless ($value);
+ print "$PPM::PPMERR" and return 1
+ unless ($old_root = PPM::chroot("location" => $value));
+ $options{'ROOT'} = $value;
+ print "Root is now $value [was $old_root].\n";
+ }
+ elsif (command($option, "|build")) {
+ print "Directory not specified.\n" and return 1 unless ($value);
+ print "Directory '$value' does not exist.\n" and return 1
+ unless (-d $value);
+ $options{'BUILDDIR'} = $value;
+ print "Build directory is now $value.\n";
+ }
+ elsif (command($option, "|force_install")) {
+ $options{'FORCE_INSTALL'} = defined $value ? ($value != 0) :
+ ($options{'FORCE_INSTALL'} ? 0 : 1);
+ print "Package installations will " .
+ ($options{'FORCE_INSTALL'} ? "" : "not ") .
+ "continue if a dependency cannot be installed.\n";
+ }
+ elsif (command($option, "c|lean")) {
+ $options{'CLEAN'} = defined $value ?
+ ($value != 0) : ($options{'CLEAN'} ? 0 : 1);
+ print "Temporary files will " . ($options{'CLEAN'} ? "" : "not ") .
+ "be deleted.\n";
+ }
+ elsif (command($option, "|downloadstatus")) {
+ print "Numeric value must be given.\n" and return 1
+ unless (defined $value && $value =~ /^\d+$/);
+ $options{'DOWNLOADSTATUS'} = $value;
+ print "Download status will " . (($options{'DOWNLOADSTATUS'} > 0) ?
+ "be updated every $options{'DOWNLOADSTATUS'} bytes.\n" :
+ "not be updated.\n");
+ }
+ elsif (command($option, "|more")) {
+ print "Numeric value must be given.\n" and return 1
+ unless (defined $value && $value =~ /^\d+$/);
+ $options{'MORE'} = $value;
+ print "Screens will " . ($options{'MORE'} > 0 ?
+ "pause after $options{'MORE'} lines.\n" : "not pause.\n");
+ }
+ elsif (command($option, "trace|file")) {
+ print "Filename not specified.\n" and return 1 unless ($value);
+ $options{'TRACEFILE'} = $value;
+ print "Tracing info will be written to $options{'TRACEFILE'}.\n";
+ }
+ elsif (command($option, "trace")) {
+ print "Numeric value between 0 and 4 must be given.\n" and return 1
+ unless (defined $value &&
+ $value =~ /^\d+$/ && $value >= 0 && $value <= 4);
+ $options{'TRACE'} = $value;
+ print "Tracing info will " . ($options{'TRACE'} > 0 ?
+ "be written to $options{'TRACEFILE'}.\n" : "not be written.\n");
+ }
+ elsif (command($option, "|verbose")) {
+ $options{'VERBOSE'} = defined $value ?
+ ($value != 0) : ($options{'VERBOSE'} ? 0 : 1);
+ print "Query/search results will " .
+ ($options{'VERBOSE'} ? "" : "not ") . "be verbose.\n";
+ }
+ else {
+ print "Unknown or ambiguous option '$option'; see 'help set' for available options.\n";
+ return 1;
+ }
+ PPM::SetPPMOptions("options" => \%options);
+ }
+ return;
+}
+
+sub search_PPDs
+{
+ my %argv = @_;
+ my @locations = $argv{'location'} || $location;
+ my $searchtag = $argv{'searchtag'};
+ my $ignorecase = defined $argv{'ignorecase'} ?
+ $argv{'ignorecase'} : $options{'IGNORECASE'};
+ my $searchRE = $argv{'searchRE'};
+ if (defined $searchRE) {
+ eval { $searchRE =~ /$searchRE/ };
+ if ($@) {
+ print "'$searchRE': invalid regular expression.\n";
+ return;
+ }
+ $searchRE = "(?i)$searchRE" if $ignorecase;
+ }
+
+ my %packages;
+ unless (defined $locations[0]) {
+ my %reps = PPM::ListOfRepositories;
+ @locations = values %reps;
+ }
+ foreach my $loc (@locations) {
+ my %summary;
+
+ # see if the repository has server-side searching
+ if (defined $searchRE && (%summary = ServerSearch('location' => $loc,
+ 'searchRE' => $searchRE, 'searchtag' => $searchtag))) {
+ # XXX: clean this up
+ foreach my $package (keys %{$summary{$loc}}) {
+ $packages{$loc}{$package} = \%{$summary{$loc}{$package}};
+ }
+ next;
+ }
+
+ # see if a summary file is available
+ %summary = RepositorySummary("location" => $loc);
+ if (%summary) {
+ foreach my $package (keys %{$summary{$loc}}) {
+ next if (defined $searchtag &&
+ $summary{$loc}{$package}{$searchtag} !~ /$searchRE/);
+ next if (!defined $searchtag &&
+ defined $searchRE && $package !~ /$searchRE/);
+ $packages{$loc}{$package} = \%{$summary{$loc}{$package}};
+ }
+ }
+ else {
+ my %ppds = PPM::RepositoryPackages("location" => $loc);
+ # No summary: oh my, nothing but 'Net
+ foreach my $package (@{$ppds{$loc}}) {
+ my %package_details = RepositoryPackageProperties(
+ "package" => $package, "location" => $loc);
+ next unless %package_details;
+ next if (defined $searchtag &&
+ $package_details{$searchtag} !~ /$searchRE/);
+ next if (!defined $searchtag &&
+ defined $searchRE && $package !~ /$searchRE/);
+ $packages{$loc}{$package} = \%package_details;
+ }
+ }
+ }
+ return %packages;
+}
+
+sub verify_packages
+{
+ my %argv = @_;
+ my @packages = @{$argv{'packages'}};
+ my $upgrade = $argv{'upgrade'};
+ my $force = $argv{'force'};
+ my $location = $argv{'location'} || $location;
+ unless ($packages[0]) {
+ my %info = QueryInstalledPackages();
+ @packages = sort keys %info;
+ }
+
+ my $package = shift @packages;
+ while ($package) {
+ my $status = VerifyPackage("package" => $package,
+ "location" => $location, "upgrade" => $upgrade, "force" => $force);
+ if (defined $status) {
+ if ($status eq "0") {
+ print "Package \'$package\' is up to date.\n";
+ }
+ elsif ($upgrade) {
+ print "Package $package upgraded to version $status\n";
+ }
+ else {
+ print "An upgrade to package \'$package\' is available.\n";
+ }
+ }
+ else {
+ # Couldn't find a PPD to compare it with.
+ print "Package \'$package\' is up to date.\n";
+ }
+ $package = shift @packages;
+ }
+}
+
+sub genconfig
+{
+ my $repositories =
+ {'5.6' => {
+ 'ActiveState' =>
+ {location => 'http://ppm.ActiveState.com/cgibin/PPM/ppmserver.pl?urn:/PPMServer',
+ summaryfile => 'fetch_summary',
+ },
+ 'Bribes' =>
+ {location => 'http://www.bribes.org/perl/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'UWinnipeg' =>
+ {location => 'http://theoryx5.uwinnipeg.ca/cgi-bin/ppmserver?urn:/PPMServer',
+ summaryfile => 'fetch_summary',
+ },
+ },
+ '5.8' => {
+ 'ActiveState' =>
+ {location => 'http://ppm.activestate.com/PPMPackages/5.8-windows',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Bribes' =>
+ {location => 'http://www.bribes.org/perl/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'UWinnipeg' =>
+ {location => 'http://theoryx5.uwinnipeg.ca/ppms',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Trouchelle' =>
+ {location => 'http://trouchelle.com/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ },
+ '5.10' => {
+ 'ActiveState' =>
+ {location => 'http://ppm.activestate.com/PPMPackages/5.10-windows',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Bribes' =>
+ {location => 'http://www.bribes.org/perl/ppm',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'UWinnipeg' =>
+ {location => 'http://cpan.uwinnipeg.ca/PPMPackages/10xx',
+ summaryfile => 'searchsummary.ppm',
+ },
+ 'Trouchelle' =>
+ {location => 'http://trouchelle.com/ppm10',
+ summaryfile => 'package.xml',
+ },
+ },
+ };
+ my ($perl_version);
+ PERLV: {
+ ($] < 5.008) and do {
+ $perl_version = '5.6';
+ last PERLV;
+ };
+ ($] < 5.01) and do {
+ $perl_version = '5.8';
+ last PERLV;
+ };
+ $perl_version = '5.10';
+ }
+ my $reps = $repositories->{$perl_version};
+ my $PerlDir = $Config{'prefix'};
+
+print <<"EOF";
+<PPMCONFIG>
+ <PPMVER>2,1,8,0</PPMVER>
+ <PLATFORM CPU="x86" OSVALUE="$Config{'osname'}" OSVERSION="0,0,0,0" />
+ <OPTIONS BUILDDIR="$ENV{'TEMP'}" CLEAN="1" CONFIRM="1" DOWNLOADSTATUS="16384" FORCEINSTALL="1" IGNORECASE="1" MORE="0" ROOT="$PerlDir" TRACE="0" TRACEFILE="PPM.LOG" VERBOSE="1" />
+EOF
+ foreach my $name(sort keys %$reps) {
+ my $loc = $reps->{$name}->{location};
+ my $sf = $reps->{$name}->{summaryfile};
+ print << "EOF";
+ <REPOSITORY LOCATION="$loc" NAME="$name" SUMMARYFILE="$sf" />
+EOF
+ }
+ print <<"EOF";
+ <PPMPRECIOUS>Compress-Zlib;Archive-Tar;Digest-MD5;File-CounterFile;Font-AFM;HTML-Parser;HTML-Tree;MIME-Base64;URI;XML-Element;libwww-perl;XML-Parser;SOAP-Lite;PPM;libnet;libwin32</PPMPRECIOUS>
+</PPMCONFIG>
+EOF
+}
+
+__DATA__
+
+=head1 NAME
+
+PPM - Perl Package Manager: locate, install, upgrade software packages.
+
+=head1 SYNOPSIS
+
+ ppm genconfig
+ ppm help [command]
+ ppm install [--location=location] package1 [... packageN]
+ ppm query [--case|nocase] [--abstract|author] PATTERN
+ ppm remove package1 [... packageN]
+ ppm search [--case|nocase] [--location=location] [--abstract|author] PATTERN
+ ppm set [option]
+ ppm verify [--location=location] [--upgrade] [--force] [package1 ... packageN]
+ ppm version
+ ppm [--location=location]
+
+=head1 DESCRIPTION
+
+ppm is a utility intended to simplify the tasks of locating, installing,
+upgrading and removing software packages. It is a front-end to the
+functionality provided in PPM.pm. It can determine if the most recent
+version of a software package is installed on a system, and can install
+or upgrade that package from a local or remote host.
+
+ppm runs in one of two modes: an interactive shell from which commands
+may be entered; and command-line mode, in which one specific action is
+performed per invocation of the program.
+
+ppm uses files containing an extended form of the Open Software
+Description (OSD) specification for information about software packages.
+These description files, which are written in Extensible Markup
+Language (XML) code, are referred to as 'PPD' files. Information about
+OSD can be found at the W3C web site (at the time of this writing,
+http://www.w3.org/TR/NOTE-OSD.html). The extensions to OSD used by ppm
+are documented in PPM.ppd.
+
+=head1 Using PPM
+
+=over 4
+
+=item Interactive mode
+
+If ppm is invoked with no command specified, it is started in interactive
+mode. If the '--location' argument is specified, it is used as the
+search location, otherwise the repositories specified in the PPM data file
+are used.
+
+The syntax of PPM commands is the same in interactive mode as it is in
+command-line mode. The 'help' command lists the available commands.
+
+ppm commands may be abbreviated to their shortest unique form.
+
+=item Installing
+
+ ppm install [--location=location] package1 [... packageN]
+
+Installs the specified software packages. Attempts to install from the
+URL or directory 'location' if the '--location' option is specfied.
+
+The 'package' arguments may be either package names ('foo'), pathnames
+(p:/packages/foo.ppd) or URLs (http://www.ActiveState.com/packages/foo.ppd)
+to specific PPD files.
+
+In the case where a package name is specified, and the '--location'
+option is not used, ppm will refer to the default repository locations.
+
+See also: 'confirm' option.
+
+=item Removing
+
+ ppm remove package1 [... packageN]
+
+Reads information from the PPD file for the named software package and
+removes the package from the system.
+
+See also: 'confirm' option.
+
+=item Verifying
+
+ ppm verify [--location=location] [--upgrade] [--force] [package1 ... packageN]
+
+Verifies that the currently installed packages are up to date. If no
+packages are specified as arguments, all installed packages will be verified.
+
+If the '--upgrade' option is specified, any package for which an upgrade
+is available will be upgraded.
+
+If the '--location' option is specified, upgrades will be looked for at
+the specified URL or directory.
+
+If the '--force' option is specified, all currently installed packages will
+be reinstalled regardless of whether they are out of date or not.
+
+See also: 'confirm' option.
+
+=item Querying
+
+ ppm query [--case|nocase] [--abstract|author] PATTERN
+
+Searches for 'PATTERN' (a regular expression) in the name of any installed
+package. If a search is successful, information about the matching
+package(s) is displayed. If 'PATTERN' is omitted, information about
+all installed packages will be displayed.
+
+If either '--abstract' or '--author' is specified, PATTERN will be
+searched for in the <ABSTRACT> or <AUTHOR> tags of the installed packages.
+
+The '--case' and '--nocase' options can be used to override the default
+case-sensitivity search settings.
+
+See also: 'case' option.
+
+=item Searching
+
+ ppm search [--case|nocase] [--location=location] [--abstract|author] PATTERN
+
+Displays a list of any packages matching 'PATTERN' (a regular expression)
+available from the specified location. If 'PATTERN' is omitted, information
+about all available packages will be displayed.
+
+If the '--location' option is specified, the specified URL or directory
+will be searched. If '--location' is not specified, the repository location
+as specified in the PPM data file will be searched.
+
+If either '--abstract' or '--author' is specified, PATTERN will be
+searched for in the <ABSTRACT> or <AUTHOR> tags of the available packages.
+
+The '--case' and '--nocase' options can be used to override the default
+case-sensitivity search settings.
+
+See also: 'case' option.
+
+=item Error Recovery
+
+ ppm genconfig
+ ppm getconfig
+
+The genconfig command will print a valid PPM config file (ppm.xml) to STDOUT.
+This can be useful if the PPM config file ever gets damaged leaving PPM
+unusable.
+
+If required, this command should be run from a shell prompt:
+
+ C:\Perl\site\lib> ppm genconfig > ppm.xml
+
+The getconfig command prints the location of the PPM configuration file
+used at PPM startup.
+
+=item Options
+
+ ppm set [option value]
+
+Sets or displays current options. With no arguments, current option
+settings are displayed.
+
+Available options:
+
+ build DIRECTORY
+ - Changes the package build directory.
+
+ case [1|0]
+ - Sets case-sensitive searches. If one of '1' or '0' is
+ not specified, the current setting is toggled.
+
+ clean [1|0]
+ - Sets removal of temporary files from package's build
+ area, on successful installation of a package. If one of
+ '1' or '0' is not specified, the current setting is
+ toggled.
+
+ confirm [1|0]
+ - Sets confirmation of 'install', 'remove' and 'upgrade'.
+ If one of '1' or '0' is not specified, the current
+ setting is toggled.
+
+ downloadstatus NUMBER
+ - If non-zero, updates the download status after each NUMBER
+ of bytes transferred during an 'install'. This can be
+ reassuring when installing a large package (e.g. Tk) over
+ a low-speed connection.
+
+ force_install [1|0]
+ - Continue installing a package even if a dependency cannot
+ be installed.
+
+ more NUMBER
+ - Causes output to pause after NUMBER lines have been
+ displayed. Specifying '0' turns off this capability.
+
+ set repository --remove NAME
+ - Removes the repository 'NAME' from the list of repositories.
+
+ set repository NAME LOCATION
+ - Adds a repository to the list of PPD repositories for this
+ session. 'NAME' is the name by which this repository will
+ be referred; 'LOCATION' is a URL or directory name.
+
+ root DIRECTORY
+ - Changes the install root directory. Packages will be
+ installed under this new root.
+
+ save
+ - Saves the current options as default options for future
+ sessions.
+
+ trace
+ - Tracing level--default is 1, maximum is 4, 0 indicates
+ no tracing.
+
+ tracefile
+ - File to contain tracing information, default is 'PPM.LOG'.
+
+ verbose [1|0]
+ - Display additional package information for 'query' and
+ 'search' commands.
+
+=back
+
+=head1 EXAMPLES
+
+=over 4
+
+=item ppm
+
+Starts ppm in interactive mode, using the repository locations specified
+in the PPM data file. A session might look like this:
+
+ [show all available packages]
+ PPM> search
+ Packages available from P:\PACKAGES:
+ bar [2.91 ] supplies bar methods for perl5.
+ bax [0.072] module for manipulation of bax archives.
+ baz [1.03 ] Interface to baz library
+ foo [2.23 ] Foo parser class
+
+ [list what has already been installed]
+ PPM> query
+ bax [0.071] module for manipulation of bax archives.
+ baz [1.02 ] Interface to baz library
+
+ [install a package]
+ PPM> install foo
+ Install package foo? (y/N): y
+ [...]
+
+ [toggle confirmations]
+ PPM> set confirm
+ Commands will not be confirmed.
+
+ [see if 'baz' is up-to-date]
+ PPM> verify baz
+ An upgrade to package 'baz' is available.
+
+ [upgrade 'baz']
+ PPM> verify --upgrade baz
+ [...]
+
+ [forced upgrade of 'baz']
+ PPM> verify --upgrade --force baz
+ [...]
+
+ [toggle case-sensitive searches]
+ PPM> set case
+ Case-sensitive searches will be performed.
+
+ [display all available packages beginning with 'b']
+ PPM> search ^b
+ bar [2.91 ] supplies bar methods for perl5.
+ bax [0.072] module for manipulation of bax archives.
+ baz [1.03 ] Interface to baz library
+
+ [search for installed packages containing 'baz' in the ABSTRACT tag]
+ PPM> query --abstract baz
+ Matching packages found at P:\PACKAGES:
+ baz [1.03 ] Interface to baz library
+ PPM> quit
+
+=item ppm install http://www.ActiveState.com/packages/foo.ppd
+
+Installs the software package 'foo' based on the information in the PPD
+obtained from the specified URL.
+
+=item ppm verify --upgrade foo
+
+Compares the currently installed version of the software package 'foo'
+to the one available according to the PPD obtained from the location
+specified for this package in the PPM data file, and upgrades
+to a newer version if available.
+
+=item ppm verify --location=P:\PACKAGES --upgrade foo
+
+Compares the currently installed version of the software package 'foo'
+to the one available according to the PPD obtained from the specified
+directory, and upgrades to a newer version if available.
+
+=item ppm verify --upgrade --force
+
+Forces verification and reinstalls every installed package on the system,
+using upgrade locations specified in the PPM data file.
+
+=item ppm search --location=http://ppm.ActiveState.com/PPMpackages/5.6
+
+Displays the packages with PPD files available at the specified location.
+
+=item ppm search --location=P:\PACKAGES --author ActiveState
+
+Searches the specified location for any package with an <AUTHOR> tag
+containing the string 'ActiveState'. On a successful search, the package
+name and the matching string are displayed.
+
+=back
+
+=head1 ENVIRONMENT VARIABLES
+
+=over 4
+
+=item HTTP_proxy
+
+If the environment variable 'HTTP_proxy' is set, then it will
+be used as the address of a proxy server for accessing the Internet.
+
+The value should be of the form: 'http://proxy:port'.
+
+=back
+
+=head1 FILES
+
+The following files are fully described in the 'Files' section of PPM:ppm.
+
+=over 4
+
+=item package.ppd
+
+A description of a software package, in extended Open Software Description
+(OSD) format. More information on this file format can be found in
+PPM::ppd.
+
+=item ppm.xml - PPM data file.
+
+An XML format file containing information about the local system,
+specifics regarding the locations from which PPM obtains PPD files, and
+the installation details for any package installed by ppm.
+
+This file usually resides in '[perl]/site/lib'. If the environment
+variable 'PPM_DAT' is set, its value will be used as the full pathname
+to a PPM data file. If all else fails, ppm will look for a data file
+in the current directory.
+
+=back
+
+=head1 AUTHOR
+
+Murray Nesbitt, E<lt>F<murray@cpan.org>E<gt>
+
+=head1 CREDITS
+
+=over 4
+
+=item *
+
+The "geek-pit" at ActiveState.
+
+=item *
+
+Paul Kulchenko for his SOAP-Lite package, and for his enthusiastic
+assistance in getting PPM to work with SOAP-Lite.
+
+=back
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/ppm.pl b/Master/tlpkg/tlperl/bin/ppm.pl new file mode 100755 index 00000000000..9773e9470c1 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ppm.pl @@ -0,0 +1,1050 @@ +#!/usr/bin/perl + +use Getopt::Long; +use File::Basename; +use Config; +use strict; + +use PPM; + +$PPM::VERSION = '0.01_01'; + +my %help; + +# mapping of POD sections to command topics +my %topic = ( + 'Error Recovery' => 'genconfig', + 'Installing' => 'install', + 'Querying' => 'query', + 'Removing' => 'remove', + 'Searching' => 'search', + 'Summarizing' => 'summary', + 'Verifying' => 'verify', + 'Synopsis' => 'usage', + 'Options' => 'set', +); + +$help{'help'} = <<'EOT'; +Commands: + exit - leave the program. + help [command] - prints this screen, or help on 'command'. + install PACKAGES - installs specified PACKAGES. + quit - leave the program. + query [options] - query information about installed packages. + remove PACKAGES - removes the specified PACKAGES from the system. + search [options] - search information about available packages. + set [options] - set/display current options. + verify [options] - verifies current install is up to date. + version - displays PPM version number + +EOT + +# Build the rest of the online help from the POD +$/ = "\n="; +while (<DATA>) { + next unless my ($topic,$text) = /^(?:item|head[12]) ([^\n]+)\n\n(.*)=/s; + next unless $topic{$topic}; + ($help{$topic{$topic}} = "\n$text"); # =~ s/\n *([^\n])/\n $1/sg; +} +$/ = "\n"; + +# Need to do this here, because the user's config file is probably +# hosed. +if ($#ARGV == 0 && $ARGV[0] eq 'genconfig') { + &genconfig; + exit 0; +} + +if ($#ARGV == 0 && $ARGV[0] eq 'getconfig') { + print $PPM::PPMdat; + exit 0; +} + +my %options = PPM::GetPPMOptions(); +my $location; + +my $moremsg = "[Press return to continue or 'q' to quit] "; +my $interactive = 0; + +my %repositories = PPM::ListOfRepositories(); + +my $prefix_pattern = $^O eq "MSWin32" ? '(--|-|\+|/)' : '(--|-|\+)'; + +$PPM::PPMShell = 1; + +Getopt::Long::Configure("prefix_pattern=$prefix_pattern"); + +if ($#ARGV == -1 || ($#ARGV == 0 && $ARGV[0] =~ /^${prefix_pattern}location/)) { + my $prompt = 'PPM> '; + $interactive = 1; + GetOptions("location=s" => \$location); + + print "PPM interactive shell ($PPM::VERSION) - type 'help' for available commands.\n"; + $| = 1; + while () { + print $prompt; + last unless defined ($_ = <> ); + chomp; + s/^\s+//; + @ARGV = split(/\s+/, $_); + next unless @ARGV; + # exit/quit + if (command($ARGV[0], "qu|it") or command($ARGV[0], "|exit")) { + print "Quit!\n"; + last; + } + exec_command(); + } + exit 0; +} + +exit exec_command(); + +sub exec_command +{ + my $cmd = lc shift @ARGV; + + for (@ARGV) { + s/::/-/g; + } + + # help + if (command($cmd, "|help")) { + help(@ARGV); + } + # query + elsif (command($cmd, "qu|ery")) { + GetOptions("case!" => \my $case, "abstract" => \my $abstract, + "author" => \my $author ); + + my %summary = InstalledPackageProperties(); + if (@ARGV) { + my $searchtag; + if ($abstract || $author) { + $searchtag = ($abstract ? 'ABSTRACT' : 'AUTHOR'); + } + my $RE = shift @ARGV; + eval { $RE =~ /$RE/ }; + if ($@) { + print "'$RE': invalid regular expression.\n"; + return 1; + } + $case = !$options{'IGNORECASE'} unless defined $case; + $RE = "(?i)$RE" if ($case == 0); + foreach(keys %summary) { + if ($searchtag) { + delete $summary{$_} unless $summary{$_}{$searchtag} =~ /$RE/; + } + else { + delete $summary{$_} unless /$RE/; + } + } + } + print_formatted(1, %summary); + } + # install + elsif (command($cmd, "in|stall")) { + my $location = $location; + GetOptions("location=s" => \$location); + unless (@ARGV) { + if (!$interactive && -d "blib" && -f "Makefile") { + return if InstallPackage(location => $location); + print "Error installing blib: $PPM::PPMERR\n"; + return 1; + } + print "Package not specified.\n"; + return 1; + } + + my %installed = InstalledPackageProperties(); + foreach my $package (@ARGV) { + $package =~ s/::/-/g; + if (my $pkg = (grep {/^$package$/i} keys %installed)[0]) { + my $version = $installed{$pkg}{'VERSION'}; + $version =~ s/(,0)*$//; + $version =~ tr/,/./; + print "Version $version of '$pkg' is already installed.\n" . + "Remove it, or use 'verify --upgrade $pkg'.\n"; + next; + } + elsif ($interactive && $options{'CONFIRM'}) { + print "Install package '$package?' (y/N): "; + next unless <> =~ /^[yY]/; + } + print "Installing package '$package'...\n"; + if(!InstallPackage("package" => $package, "location" => $location)) { + print "Error installing package '$package': $PPM::PPMERR\n"; + } + } + } + # remove + elsif (command($cmd, "|remove")) { + unless (@ARGV) { + print "Package not specified.\n"; + return 1; + } + foreach my $package (@ARGV) { + $package =~ s/::/-/g; + if ($interactive && $options{'CONFIRM'}) { + print "Remove package '$package?' (y/N): "; + next unless <> =~ /[yY]/; + } + unless (RemovePackage("package" => $package)) { + print "Error removing $package: $PPM::PPMERR\n"; + } + } + } + # search + elsif (command($cmd, "se|arch")) { + my (%summary, $searchtag); + my $location = $location; + GetOptions("case!" => \my $case, "location=s" => \$location, + "abstract" => \my $abstract, "author" => \my $author ); + my $searchRE = shift @ARGV; + if (defined $searchRE) { + eval { $searchRE =~ /$searchRE/ }; + if ($@) { + print "'$searchRE': invalid regular expression.\n"; + return 1; + } + } + $case = !$options{'IGNORECASE'} unless defined $case; + if ($abstract || $author) { + $searchtag = ($abstract ? 'ABSTRACT' : 'AUTHOR'); + } + %summary = search_PPDs("location" => $location, "ignorecase" => !$case, + "searchtag" => $searchtag, "searchRE" => $searchRE); + foreach (keys %summary) { + print "Packages available from $_:\n"; + print_formatted(2, %{$summary{$_}}); + } + } + # set + elsif (command($cmd, "se|t")) { + unless (set(@ARGV) || $interactive) { + PPM::SetPPMOptions("options" => \%options, "save" => 1); + } + } + # verify + elsif (command($cmd, "ver|ify")) { + my $location = $location; + GetOptions("force" => \my $force, "location=s" => \$location, + "upgrade" => \my $upgrade); + if ($interactive && $upgrade && $options{'CONFIRM'}) { + printf "Upgrade package%s? (y/N): ", @ARGV == 1 ? " '$ARGV[0]'" : "s"; + return unless <> =~ /^[yY]/; + } + verify_packages("packages" => \@ARGV, "location" => $location, + "upgrade" => $upgrade, "force" => $force); + } + elsif (command($cmd, "ver|sion")) { + print "$PPM::VERSION\n"; + } + elsif ($cmd eq "purge") { + my %summary = InstalledPackageProperties(); + foreach(keys %summary) { + print "Purging $_\n"; + RemovePackage("package" => $_, "force" => 1); + } + } + elsif ($cmd eq 'refresh') { + my %summary = InstalledPackageProperties(); + foreach(keys %summary) { + print "Refreshing $_\n"; + InstallPackage("package" => $_); + } + } + else { + print "Unknown or ambiguous command '$cmd'; type 'help' for commands.\n"; + } +} + +sub help { + my $topic = @_ && $help{lc $_[0]} ? lc $_[0] : 'help'; + my $help = $help{$topic}; + $help =~ s/^(\s*)ppm\s+/$1/mg if $interactive; + print $help; +} + +sub more +{ + my ($lines) = shift @_; + if (++$$lines >= $options{'MORE'}) { + print $moremsg; + $_ = <>; + $$lines = $_ eq "q\n" ? -1 : 1; + } +} + +# This nasty piece of business splits $pattern into a required prefix +# and a "match any of this substring" suffix. E.g. "in|stall" will +# match a $cmd of "ins", "inst", ..., "install". +sub command +{ + my ($cmd, $pattern) = @_; + my @pattern = split(/\|/, $pattern); + if ($pattern[1]) { + my @optchars = split(//, $pattern[1]); + # build up a "foo(b|ba|bar)" string + $pattern = "$pattern[0]("; + $pattern[1] = shift @optchars; + $pattern[1] .= "|$pattern[1]$_" foreach @optchars; + $pattern .= "$pattern[1])"; + } + return ($cmd =~ /^${pattern}$/i); +} + +# This routine prints the output for query and search +# in a nicely formatted way, if $options{'VERBOSE'} is set. +sub print_formatted +{ + my ($lines, %summary) = @_; + my $package; + + unless ($options{'VERBOSE'}) { + foreach $package (sort keys %summary) { + print "$package\n"; + &more(\$lines) if $options{'MORE'} && $interactive; + last if $lines == -1; + } + return; + } + + my ($maxname, $maxversion) = (0, 0); + # find the longest package name and version strings, so we can + # format them nicely + $maxname < length($_) and $maxname = length($_) for keys %summary; + foreach $package (keys %summary) { + $summary{$package}{'VERSION'} =~ s/(,0)*$//; + $summary{$package}{'VERSION'} =~ tr/,/./; + $maxversion = length $summary{$package}{'VERSION'} > $maxversion ? + length $summary{$package}{'VERSION'} : $maxversion; + } + my $columns = $ENV{COLUMNS} ? $ENV{COLUMNS} : 80; + my $namefield = "@" . "<" x ($maxname - 1); + my $versionfield = "@" . "<" x ($maxversion - 1); + my $abstractfield = "^" . "<" x ($columns - (6 + $maxname + $maxversion)); + my $abstractpad = " " x ($maxname + $maxversion + 3); + + foreach $package (sort keys %summary) { + eval "format STDOUT = \n" + . "$namefield [$versionfield] $abstractfield\n" + . '$package, $summary{$package}{VERSION}, $summary{$package}{ABSTRACT}' + . "\n" + . "$abstractpad $abstractfield~~\n" + . '$summary{$package}{ABSTRACT}' + . "\n" + . ".\n"; + + my $diff = $-; + write; + $diff -= $-; + $lines += ($diff - 1) if $diff > 1; + &more(\$lines) if $options{'MORE'} && $interactive; + last if $lines == -1; + } +} + +sub set +{ + my $option = lc shift @_; + + unless ($option) { + print "Commands will " . ($options{'CONFIRM'} ? "" : "not ") . + "be confirmed.\n"; + print "Temporary files will " . ($options{'CLEAN'} ? "" : "not ") . + "be deleted.\n"; + print "Download status will " . (($options{'DOWNLOADSTATUS'} > 0) ? + "be updated every $options{'DOWNLOADSTATUS'} bytes.\n" : + "not be updated.\n"); + print "Case-" . ($options{'IGNORECASE'} ? "in" : "") . + "sensitive searches will be performed.\n"; + print "Package installations will " . + ($options{'FORCE_INSTALL'} ? "" : "not ") . + "continue if a dependency cannot be installed.\n"; + print "Tracing info will " . (($options{'TRACE'} > 0 ) ? + "be written to '$options{'TRACEFILE'}'.\n" : "not be written.\n"); + print "Screens will " . ($options{'MORE'} > 0 ? + "pause after $options{'MORE'} lines.\n" : "not pause.\n"); + print "Query/search results will " . + ($options{'VERBOSE'} ? "" : "not ") . "be verbose.\n"; + if (defined $location) { print "Current PPD repository: $location\n"; } + else { + print "Current PPD repository paths:\n"; + foreach $_ (keys %repositories) { + print "\t$_: $repositories{$_}\n"; + } + } + print "Packages will be installed under: $options{'ROOT'}\n" + if ($options{'ROOT'}); + print "Packages will be built under: $options{'BUILDDIR'}\n" + if ($options{'BUILDDIR'}); + return; + } + + my $value = shift @_; + if (command($option, "r|epository")) { + if ($value =~ /${prefix_pattern}remove/i) { + $value = join(" ", @_); + print "Location not specified.\n" and return 1 + unless (defined $value); + PPM::RemoveRepository("repository" => $value); + %repositories = PPM::ListOfRepositories(); + } + else { + my $location = shift @_; + print "Repository not specified.\n" and return 1 + unless (defined $value and defined $location); + PPM::AddRepository("repository" => $value, + "location" => $location); + %repositories = PPM::ListOfRepositories(); + } + } + else { + if (command($option, "c|onfirm")) { + $options{'CONFIRM'} = defined $value ? + ($value != 0) : ($options{'CONFIRM'} ? 0 : 1); + print "Commands will " . ($options{'CONFIRM'} ? "" : "not ") . + "be confirmed.\n"; + } + elsif (command($option, "|save")) { + PPM::SetPPMOptions("options" => \%options, "save" => 1); + return 0; + } + elsif (command($option, "c|ase")) { + $options{'IGNORECASE'} = defined $value ? + ($value == 0) : ($options{'IGNORECASE'} ? 0 : 1); + print "Case-" . ($options{'IGNORECASE'} ? "in" : "") . + "sensitive searches will be performed.\n"; + } + elsif (command($option, "r|oot")) { + my $old_root; + print "Directory not specified.\n" and return 1 unless ($value); + print "$PPM::PPMERR" and return 1 + unless ($old_root = PPM::chroot("location" => $value)); + $options{'ROOT'} = $value; + print "Root is now $value [was $old_root].\n"; + } + elsif (command($option, "|build")) { + print "Directory not specified.\n" and return 1 unless ($value); + print "Directory '$value' does not exist.\n" and return 1 + unless (-d $value); + $options{'BUILDDIR'} = $value; + print "Build directory is now $value.\n"; + } + elsif (command($option, "|force_install")) { + $options{'FORCE_INSTALL'} = defined $value ? ($value != 0) : + ($options{'FORCE_INSTALL'} ? 0 : 1); + print "Package installations will " . + ($options{'FORCE_INSTALL'} ? "" : "not ") . + "continue if a dependency cannot be installed.\n"; + } + elsif (command($option, "c|lean")) { + $options{'CLEAN'} = defined $value ? + ($value != 0) : ($options{'CLEAN'} ? 0 : 1); + print "Temporary files will " . ($options{'CLEAN'} ? "" : "not ") . + "be deleted.\n"; + } + elsif (command($option, "|downloadstatus")) { + print "Numeric value must be given.\n" and return 1 + unless (defined $value && $value =~ /^\d+$/); + $options{'DOWNLOADSTATUS'} = $value; + print "Download status will " . (($options{'DOWNLOADSTATUS'} > 0) ? + "be updated every $options{'DOWNLOADSTATUS'} bytes.\n" : + "not be updated.\n"); + } + elsif (command($option, "|more")) { + print "Numeric value must be given.\n" and return 1 + unless (defined $value && $value =~ /^\d+$/); + $options{'MORE'} = $value; + print "Screens will " . ($options{'MORE'} > 0 ? + "pause after $options{'MORE'} lines.\n" : "not pause.\n"); + } + elsif (command($option, "trace|file")) { + print "Filename not specified.\n" and return 1 unless ($value); + $options{'TRACEFILE'} = $value; + print "Tracing info will be written to $options{'TRACEFILE'}.\n"; + } + elsif (command($option, "trace")) { + print "Numeric value between 0 and 4 must be given.\n" and return 1 + unless (defined $value && + $value =~ /^\d+$/ && $value >= 0 && $value <= 4); + $options{'TRACE'} = $value; + print "Tracing info will " . ($options{'TRACE'} > 0 ? + "be written to $options{'TRACEFILE'}.\n" : "not be written.\n"); + } + elsif (command($option, "|verbose")) { + $options{'VERBOSE'} = defined $value ? + ($value != 0) : ($options{'VERBOSE'} ? 0 : 1); + print "Query/search results will " . + ($options{'VERBOSE'} ? "" : "not ") . "be verbose.\n"; + } + else { + print "Unknown or ambiguous option '$option'; see 'help set' for available options.\n"; + return 1; + } + PPM::SetPPMOptions("options" => \%options); + } + return; +} + +sub search_PPDs +{ + my %argv = @_; + my @locations = $argv{'location'} || $location; + my $searchtag = $argv{'searchtag'}; + my $ignorecase = defined $argv{'ignorecase'} ? + $argv{'ignorecase'} : $options{'IGNORECASE'}; + my $searchRE = $argv{'searchRE'}; + if (defined $searchRE) { + eval { $searchRE =~ /$searchRE/ }; + if ($@) { + print "'$searchRE': invalid regular expression.\n"; + return; + } + $searchRE = "(?i)$searchRE" if $ignorecase; + } + + my %packages; + unless (defined $locations[0]) { + my %reps = PPM::ListOfRepositories; + @locations = values %reps; + } + foreach my $loc (@locations) { + my %summary; + + # see if the repository has server-side searching + if (defined $searchRE && (%summary = ServerSearch('location' => $loc, + 'searchRE' => $searchRE, 'searchtag' => $searchtag))) { + # XXX: clean this up + foreach my $package (keys %{$summary{$loc}}) { + $packages{$loc}{$package} = \%{$summary{$loc}{$package}}; + } + next; + } + + # see if a summary file is available + %summary = RepositorySummary("location" => $loc); + if (%summary) { + foreach my $package (keys %{$summary{$loc}}) { + next if (defined $searchtag && + $summary{$loc}{$package}{$searchtag} !~ /$searchRE/); + next if (!defined $searchtag && + defined $searchRE && $package !~ /$searchRE/); + $packages{$loc}{$package} = \%{$summary{$loc}{$package}}; + } + } + else { + my %ppds = PPM::RepositoryPackages("location" => $loc); + # No summary: oh my, nothing but 'Net + foreach my $package (@{$ppds{$loc}}) { + my %package_details = RepositoryPackageProperties( + "package" => $package, "location" => $loc); + next unless %package_details; + next if (defined $searchtag && + $package_details{$searchtag} !~ /$searchRE/); + next if (!defined $searchtag && + defined $searchRE && $package !~ /$searchRE/); + $packages{$loc}{$package} = \%package_details; + } + } + } + return %packages; +} + +sub verify_packages +{ + my %argv = @_; + my @packages = @{$argv{'packages'}}; + my $upgrade = $argv{'upgrade'}; + my $force = $argv{'force'}; + my $location = $argv{'location'} || $location; + unless ($packages[0]) { + my %info = QueryInstalledPackages(); + @packages = sort keys %info; + } + + my $package = shift @packages; + while ($package) { + my $status = VerifyPackage("package" => $package, + "location" => $location, "upgrade" => $upgrade, "force" => $force); + if (defined $status) { + if ($status eq "0") { + print "Package \'$package\' is up to date.\n"; + } + elsif ($upgrade) { + print "Package $package upgraded to version $status\n"; + } + else { + print "An upgrade to package \'$package\' is available.\n"; + } + } + else { + # Couldn't find a PPD to compare it with. + print "Package \'$package\' is up to date.\n"; + } + $package = shift @packages; + } +} + +sub genconfig +{ + my $repositories = + {'5.6' => { + 'ActiveState' => + {location => 'http://ppm.ActiveState.com/cgibin/PPM/ppmserver.pl?urn:/PPMServer', + summaryfile => 'fetch_summary', + }, + 'Bribes' => + {location => 'http://www.bribes.org/perl/ppm', + summaryfile => 'searchsummary.ppm', + }, + 'UWinnipeg' => + {location => 'http://theoryx5.uwinnipeg.ca/cgi-bin/ppmserver?urn:/PPMServer', + summaryfile => 'fetch_summary', + }, + }, + '5.8' => { + 'ActiveState' => + {location => 'http://ppm.activestate.com/PPMPackages/5.8-windows', + summaryfile => 'searchsummary.ppm', + }, + 'Bribes' => + {location => 'http://www.bribes.org/perl/ppm', + summaryfile => 'searchsummary.ppm', + }, + 'UWinnipeg' => + {location => 'http://theoryx5.uwinnipeg.ca/ppms', + summaryfile => 'searchsummary.ppm', + }, + 'Trouchelle' => + {location => 'http://trouchelle.com/ppm', + summaryfile => 'searchsummary.ppm', + }, + }, + '5.10' => { + 'ActiveState' => + {location => 'http://ppm.activestate.com/PPMPackages/5.10-windows', + summaryfile => 'searchsummary.ppm', + }, + 'Bribes' => + {location => 'http://www.bribes.org/perl/ppm', + summaryfile => 'searchsummary.ppm', + }, + 'UWinnipeg' => + {location => 'http://cpan.uwinnipeg.ca/PPMPackages/10xx', + summaryfile => 'searchsummary.ppm', + }, + 'Trouchelle' => + {location => 'http://trouchelle.com/ppm10', + summaryfile => 'package.xml', + }, + }, + }; + my ($perl_version); + PERLV: { + ($] < 5.008) and do { + $perl_version = '5.6'; + last PERLV; + }; + ($] < 5.01) and do { + $perl_version = '5.8'; + last PERLV; + }; + $perl_version = '5.10'; + } + my $reps = $repositories->{$perl_version}; + my $PerlDir = $Config{'prefix'}; + +print <<"EOF"; +<PPMCONFIG> + <PPMVER>2,1,8,0</PPMVER> + <PLATFORM CPU="x86" OSVALUE="$Config{'osname'}" OSVERSION="0,0,0,0" /> + <OPTIONS BUILDDIR="$ENV{'TEMP'}" CLEAN="1" CONFIRM="1" DOWNLOADSTATUS="16384" FORCEINSTALL="1" IGNORECASE="1" MORE="0" ROOT="$PerlDir" TRACE="0" TRACEFILE="PPM.LOG" VERBOSE="1" /> +EOF + foreach my $name(sort keys %$reps) { + my $loc = $reps->{$name}->{location}; + my $sf = $reps->{$name}->{summaryfile}; + print << "EOF"; + <REPOSITORY LOCATION="$loc" NAME="$name" SUMMARYFILE="$sf" /> +EOF + } + print <<"EOF"; + <PPMPRECIOUS>Compress-Zlib;Archive-Tar;Digest-MD5;File-CounterFile;Font-AFM;HTML-Parser;HTML-Tree;MIME-Base64;URI;XML-Element;libwww-perl;XML-Parser;SOAP-Lite;PPM;libnet;libwin32</PPMPRECIOUS> +</PPMCONFIG> +EOF +} + +__DATA__ + +=head1 NAME + +PPM - Perl Package Manager: locate, install, upgrade software packages. + +=head1 SYNOPSIS + + ppm genconfig + ppm help [command] + ppm install [--location=location] package1 [... packageN] + ppm query [--case|nocase] [--abstract|author] PATTERN + ppm remove package1 [... packageN] + ppm search [--case|nocase] [--location=location] [--abstract|author] PATTERN + ppm set [option] + ppm verify [--location=location] [--upgrade] [--force] [package1 ... packageN] + ppm version + ppm [--location=location] + +=head1 DESCRIPTION + +ppm is a utility intended to simplify the tasks of locating, installing, +upgrading and removing software packages. It is a front-end to the +functionality provided in PPM.pm. It can determine if the most recent +version of a software package is installed on a system, and can install +or upgrade that package from a local or remote host. + +ppm runs in one of two modes: an interactive shell from which commands +may be entered; and command-line mode, in which one specific action is +performed per invocation of the program. + +ppm uses files containing an extended form of the Open Software +Description (OSD) specification for information about software packages. +These description files, which are written in Extensible Markup +Language (XML) code, are referred to as 'PPD' files. Information about +OSD can be found at the W3C web site (at the time of this writing, +http://www.w3.org/TR/NOTE-OSD.html). The extensions to OSD used by ppm +are documented in PPM.ppd. + +=head1 Using PPM + +=over 4 + +=item Interactive mode + +If ppm is invoked with no command specified, it is started in interactive +mode. If the '--location' argument is specified, it is used as the +search location, otherwise the repositories specified in the PPM data file +are used. + +The syntax of PPM commands is the same in interactive mode as it is in +command-line mode. The 'help' command lists the available commands. + +ppm commands may be abbreviated to their shortest unique form. + +=item Installing + + ppm install [--location=location] package1 [... packageN] + +Installs the specified software packages. Attempts to install from the +URL or directory 'location' if the '--location' option is specfied. + +The 'package' arguments may be either package names ('foo'), pathnames +(p:/packages/foo.ppd) or URLs (http://www.ActiveState.com/packages/foo.ppd) +to specific PPD files. + +In the case where a package name is specified, and the '--location' +option is not used, ppm will refer to the default repository locations. + +See also: 'confirm' option. + +=item Removing + + ppm remove package1 [... packageN] + +Reads information from the PPD file for the named software package and +removes the package from the system. + +See also: 'confirm' option. + +=item Verifying + + ppm verify [--location=location] [--upgrade] [--force] [package1 ... packageN] + +Verifies that the currently installed packages are up to date. If no +packages are specified as arguments, all installed packages will be verified. + +If the '--upgrade' option is specified, any package for which an upgrade +is available will be upgraded. + +If the '--location' option is specified, upgrades will be looked for at +the specified URL or directory. + +If the '--force' option is specified, all currently installed packages will +be reinstalled regardless of whether they are out of date or not. + +See also: 'confirm' option. + +=item Querying + + ppm query [--case|nocase] [--abstract|author] PATTERN + +Searches for 'PATTERN' (a regular expression) in the name of any installed +package. If a search is successful, information about the matching +package(s) is displayed. If 'PATTERN' is omitted, information about +all installed packages will be displayed. + +If either '--abstract' or '--author' is specified, PATTERN will be +searched for in the <ABSTRACT> or <AUTHOR> tags of the installed packages. + +The '--case' and '--nocase' options can be used to override the default +case-sensitivity search settings. + +See also: 'case' option. + +=item Searching + + ppm search [--case|nocase] [--location=location] [--abstract|author] PATTERN + +Displays a list of any packages matching 'PATTERN' (a regular expression) +available from the specified location. If 'PATTERN' is omitted, information +about all available packages will be displayed. + +If the '--location' option is specified, the specified URL or directory +will be searched. If '--location' is not specified, the repository location +as specified in the PPM data file will be searched. + +If either '--abstract' or '--author' is specified, PATTERN will be +searched for in the <ABSTRACT> or <AUTHOR> tags of the available packages. + +The '--case' and '--nocase' options can be used to override the default +case-sensitivity search settings. + +See also: 'case' option. + +=item Error Recovery + + ppm genconfig + ppm getconfig + +The genconfig command will print a valid PPM config file (ppm.xml) to STDOUT. +This can be useful if the PPM config file ever gets damaged leaving PPM +unusable. + +If required, this command should be run from a shell prompt: + + C:\Perl\site\lib> ppm genconfig > ppm.xml + +The getconfig command prints the location of the PPM configuration file +used at PPM startup. + +=item Options + + ppm set [option value] + +Sets or displays current options. With no arguments, current option +settings are displayed. + +Available options: + + build DIRECTORY + - Changes the package build directory. + + case [1|0] + - Sets case-sensitive searches. If one of '1' or '0' is + not specified, the current setting is toggled. + + clean [1|0] + - Sets removal of temporary files from package's build + area, on successful installation of a package. If one of + '1' or '0' is not specified, the current setting is + toggled. + + confirm [1|0] + - Sets confirmation of 'install', 'remove' and 'upgrade'. + If one of '1' or '0' is not specified, the current + setting is toggled. + + downloadstatus NUMBER + - If non-zero, updates the download status after each NUMBER + of bytes transferred during an 'install'. This can be + reassuring when installing a large package (e.g. Tk) over + a low-speed connection. + + force_install [1|0] + - Continue installing a package even if a dependency cannot + be installed. + + more NUMBER + - Causes output to pause after NUMBER lines have been + displayed. Specifying '0' turns off this capability. + + set repository --remove NAME + - Removes the repository 'NAME' from the list of repositories. + + set repository NAME LOCATION + - Adds a repository to the list of PPD repositories for this + session. 'NAME' is the name by which this repository will + be referred; 'LOCATION' is a URL or directory name. + + root DIRECTORY + - Changes the install root directory. Packages will be + installed under this new root. + + save + - Saves the current options as default options for future + sessions. + + trace + - Tracing level--default is 1, maximum is 4, 0 indicates + no tracing. + + tracefile + - File to contain tracing information, default is 'PPM.LOG'. + + verbose [1|0] + - Display additional package information for 'query' and + 'search' commands. + +=back + +=head1 EXAMPLES + +=over 4 + +=item ppm + +Starts ppm in interactive mode, using the repository locations specified +in the PPM data file. A session might look like this: + + [show all available packages] + PPM> search + Packages available from P:\PACKAGES: + bar [2.91 ] supplies bar methods for perl5. + bax [0.072] module for manipulation of bax archives. + baz [1.03 ] Interface to baz library + foo [2.23 ] Foo parser class + + [list what has already been installed] + PPM> query + bax [0.071] module for manipulation of bax archives. + baz [1.02 ] Interface to baz library + + [install a package] + PPM> install foo + Install package foo? (y/N): y + [...] + + [toggle confirmations] + PPM> set confirm + Commands will not be confirmed. + + [see if 'baz' is up-to-date] + PPM> verify baz + An upgrade to package 'baz' is available. + + [upgrade 'baz'] + PPM> verify --upgrade baz + [...] + + [forced upgrade of 'baz'] + PPM> verify --upgrade --force baz + [...] + + [toggle case-sensitive searches] + PPM> set case + Case-sensitive searches will be performed. + + [display all available packages beginning with 'b'] + PPM> search ^b + bar [2.91 ] supplies bar methods for perl5. + bax [0.072] module for manipulation of bax archives. + baz [1.03 ] Interface to baz library + + [search for installed packages containing 'baz' in the ABSTRACT tag] + PPM> query --abstract baz + Matching packages found at P:\PACKAGES: + baz [1.03 ] Interface to baz library + PPM> quit + +=item ppm install http://www.ActiveState.com/packages/foo.ppd + +Installs the software package 'foo' based on the information in the PPD +obtained from the specified URL. + +=item ppm verify --upgrade foo + +Compares the currently installed version of the software package 'foo' +to the one available according to the PPD obtained from the location +specified for this package in the PPM data file, and upgrades +to a newer version if available. + +=item ppm verify --location=P:\PACKAGES --upgrade foo + +Compares the currently installed version of the software package 'foo' +to the one available according to the PPD obtained from the specified +directory, and upgrades to a newer version if available. + +=item ppm verify --upgrade --force + +Forces verification and reinstalls every installed package on the system, +using upgrade locations specified in the PPM data file. + +=item ppm search --location=http://ppm.ActiveState.com/PPMpackages/5.6 + +Displays the packages with PPD files available at the specified location. + +=item ppm search --location=P:\PACKAGES --author ActiveState + +Searches the specified location for any package with an <AUTHOR> tag +containing the string 'ActiveState'. On a successful search, the package +name and the matching string are displayed. + +=back + +=head1 ENVIRONMENT VARIABLES + +=over 4 + +=item HTTP_proxy + +If the environment variable 'HTTP_proxy' is set, then it will +be used as the address of a proxy server for accessing the Internet. + +The value should be of the form: 'http://proxy:port'. + +=back + +=head1 FILES + +The following files are fully described in the 'Files' section of PPM:ppm. + +=over 4 + +=item package.ppd + +A description of a software package, in extended Open Software Description +(OSD) format. More information on this file format can be found in +PPM::ppd. + +=item ppm.xml - PPM data file. + +An XML format file containing information about the local system, +specifics regarding the locations from which PPM obtains PPD files, and +the installation details for any package installed by ppm. + +This file usually resides in '[perl]/site/lib'. If the environment +variable 'PPM_DAT' is set, its value will be used as the full pathname +to a PPM data file. If all else fails, ppm will look for a data file +in the current directory. + +=back + +=head1 AUTHOR + +Murray Nesbitt, E<lt>F<murray@cpan.org>E<gt> + +=head1 CREDITS + +=over 4 + +=item * + +The "geek-pit" at ActiveState. + +=item * + +Paul Kulchenko for his SOAP-Lite package, and for his enthusiastic +assistance in getting PPM to work with SOAP-Lite. + +=back + +=cut diff --git a/Master/tlpkg/tlperl/bin/prove b/Master/tlpkg/tlperl/bin/prove new file mode 100755 index 00000000000..bb419ed2db7 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/prove @@ -0,0 +1,338 @@ +#!C:\strawberry\perl\bin\perl.exe -w
+
+use strict;
+use App::Prove;
+
+my $app = App::Prove->new;
+$app->process_args(@ARGV);
+exit( $app->run ? 0 : 1 );
+
+__END__
+
+=head1 NAME
+
+prove - Run tests through a TAP harness.
+
+=head1 USAGE
+
+ prove [options] [files or directories]
+
+=head1 OPTIONS
+
+Boolean options:
+
+ -v, --verbose Print all test lines.
+ -l, --lib Add 'lib' to the path for your tests (-Ilib).
+ -b, --blib Add 'blib/lib' and 'blib/arch' to the path for
+ your tests
+ -s, --shuffle Run the tests in random order.
+ -c, --color Colored test output (default).
+ --nocolor Do not color test output.
+ --count Show the X/Y test count when not verbose
+ (default)
+ --nocount Disable the X/Y test count.
+ -D --dry Dry run. Show test that would have run.
+ --ext Set the extension for tests (default '.t')
+ -f, --failures Show failed tests.
+ -o, --comments Show comments.
+ --ignore-exit Ignore exit status from test scripts.
+ -m, --merge Merge test scripts' STDERR with their STDOUT.
+ -r, --recurse Recursively descend into directories.
+ --reverse Run the tests in reverse order.
+ -q, --quiet Suppress some test output while running tests.
+ -Q, --QUIET Only print summary results.
+ -p, --parse Show full list of TAP parse errors, if any.
+ --directives Only show results with TODO or SKIP directives.
+ --timer Print elapsed time after each test.
+ --normalize Normalize TAP output in verbose output
+ -T Enable tainting checks.
+ -t Enable tainting warnings.
+ -W Enable fatal warnings.
+ -w Enable warnings.
+ -h, --help Display this help
+ -?, Display this help
+ -H, --man Longer manpage for prove
+ --norc Don't process default .proverc
+
+Options that take arguments:
+
+ -I Library paths to include.
+ -P Load plugin (searches App::Prove::Plugin::*.)
+ -M Load a module.
+ -e, --exec Interpreter to run the tests ('' for compiled
+ tests.)
+ --harness Define test harness to use. See TAP::Harness.
+ --formatter Result formatter to use. See FORMATTERS.
+ --source Load and/or configure a SourceHandler. See
+ SOURCE HANDLERS.
+ -a, --archive out.tgz Store the resulting TAP in an archive file.
+ -j, --jobs N Run N test jobs in parallel (try 9.)
+ --state=opts Control prove's persistent state.
+ --rc=rcfile Process options from rcfile
+
+=head1 NOTES
+
+=head2 .proverc
+
+If F<~/.proverc> or F<./.proverc> exist they will be read and any
+options they contain processed before the command line options. Options
+in F<.proverc> are specified in the same way as command line options:
+
+ # .proverc
+ --state=hot,fast,save
+ -j9
+
+Additional option files may be specified with the C<--rc> option.
+Default option file processing is disabled by the C<--norc> option.
+
+Under Windows and VMS the option file is named F<_proverc> rather than
+F<.proverc> and is sought only in the current directory.
+
+=head2 Reading from C<STDIN>
+
+If you have a list of tests (or URLs, or anything else you want to test) in a
+file, you can add them to your tests by using a '-':
+
+ prove - < my_list_of_things_to_test.txt
+
+See the C<README> in the C<examples> directory of this distribution.
+
+=head2 Default Test Directory
+
+If no files or directories are supplied, C<prove> looks for all files
+matching the pattern C<t/*.t>.
+
+=head2 Colored Test Output
+
+Colored test output is the default, but if output is not to a
+terminal, color is disabled. You can override this by adding the
+C<--color> switch.
+
+Color support requires L<Term::ANSIColor> on Unix-like platforms and
+L<Win32::Console> windows. If the necessary module is not installed
+colored output will not be available.
+
+=head2 Exit Code
+
+If the tests fail C<prove> will exit with non-zero status.
+
+=head2 Arguments to Tests
+
+It is possible to supply arguments to tests. To do so separate them from
+prove's own arguments with the arisdottle, '::'. For example
+
+ prove -v t/mytest.t :: --url http://example.com
+
+would run F<t/mytest.t> with the options '--url http://example.com'.
+When running multiple tests they will each receive the same arguments.
+
+=head2 C<--exec>
+
+Normally you can just pass a list of Perl tests and the harness will know how
+to execute them. However, if your tests are not written in Perl or if you
+want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
+switch:
+
+ prove --exec '/usr/bin/ruby -w' t/
+ prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
+ prove --exec '/path/to/my/customer/exec'
+
+=head2 C<--merge>
+
+If you need to make sure your diagnostics are displayed in the correct
+order relative to test results you can use the C<--merge> option to
+merge the test scripts' STDERR into their STDOUT.
+
+This guarantees that STDOUT (where the test results appear) and STDOUT
+(where the diagnostics appear) will stay in sync. The harness will
+display any diagnostics your tests emit on STDERR.
+
+Caveat: this is a bit of a kludge. In particular note that if anything
+that appears on STDERR looks like a test result the test harness will
+get confused. Use this option only if you understand the consequences
+and can live with the risk.
+
+=head2 C<--state>
+
+You can ask C<prove> to remember the state of previous test runs and
+select and/or order the tests to be run based on that saved state.
+
+The C<--state> switch requires an argument which must be a comma
+separated list of one or more of the following options.
+
+=over
+
+=item C<last>
+
+Run the same tests as the last time the state was saved. This makes it
+possible, for example, to recreate the ordering of a shuffled test.
+
+ # Run all tests in random order
+ $ prove -b --state=save --shuffle
+
+ # Run them again in the same order
+ $ prove -b --state=last
+
+=item C<failed>
+
+Run only the tests that failed on the last run.
+
+ # Run all tests
+ $ prove -b --state=save
+
+ # Run failures
+ $ prove -b --state=failed
+
+If you also specify the C<save> option newly passing tests will be
+excluded from subsequent runs.
+
+ # Repeat until no more failures
+ $ prove -b --state=failed,save
+
+=item C<passed>
+
+Run only the passed tests from last time. Useful to make sure that no
+new problems have been introduced.
+
+=item C<all>
+
+Run all tests in normal order. Multple options may be specified, so to
+run all tests with the failures from last time first:
+
+ $ prove -b --state=failed,all,save
+
+=item C<hot>
+
+Run the tests that most recently failed first. The last failure time of
+each test is stored. The C<hot> option causes tests to be run in most-recent-
+failure order.
+
+ $ prove -b --state=hot,save
+
+Tests that have never failed will not be selected. To run all tests with
+the most recently failed first use
+
+ $ prove -b --state=hot,all,save
+
+This combination of options may also be specified thus
+
+ $ prove -b --state=adrian
+
+=item C<todo>
+
+Run any tests with todos.
+
+=item C<slow>
+
+Run the tests in slowest to fastest order. This is useful in conjunction
+with the C<-j> parallel testing switch to ensure that your slowest tests
+start running first.
+
+ $ prove -b --state=slow -j9
+
+=item C<fast>
+
+Run test tests in fastest to slowest order.
+
+=item C<new>
+
+Run the tests in newest to oldest order based on the modification times
+of the test scripts.
+
+=item C<old>
+
+Run the tests in oldest to newest order.
+
+=item C<fresh>
+
+Run those test scripts that have been modified since the last test run.
+
+=item C<save>
+
+Save the state on exit. The state is stored in a file called F<.prove>
+(F<_prove> on Windows and VMS) in the current directory.
+
+=back
+
+The C<--state> switch may be used more than once.
+
+ $ prove -b --state=hot --state=all,save
+
+=head2 @INC
+
+prove introduces a separation between "options passed to the perl which
+runs prove" and "options passed to the perl which runs tests"; this
+distinction is by design. Thus the perl which is running a test starts
+with the default C<@INC>. Additional library directories can be added
+via the C<PERL5LIB> environment variable, via -Ifoo in C<PERL5OPT> or
+via the C<-Ilib> option to F<prove>.
+
+=head2 Taint Mode
+
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
+
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> prove passes the names of any directories found
+in C<PERL5LIB> as -I switches. The net effect of this is that
+C<PERL5LIB> is honoured even when prove is run in taint mode.
+
+
+=head1 FORMATTERS
+
+You can load a custom L<TAP::Parser::Formatter>:
+
+ prove --formatter MyFormatter
+
+=head1 SOURCE HANDLERS
+
+You can load custom L<TAP::Parser::SourceHandler>s, to change the way the
+parser interprets particular I<sources> of TAP.
+
+ prove --source MyHandler --source YetAnother t
+
+If you want to provide config to the source you can use:
+
+ prove --source MyCustom \
+ --source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \
+ --source File --file-option extensions=.txt --file-option extensions=.tmp t
+
+Each C<--$source-option> option must specify a key/value pair separated by an
+C<=>. If an option can take multiple values, just specify it multiple times,
+as with the C<extensions=> examples above.
+
+All C<--sources> are combined into a hash, and passed to L<TAP::Harness/new>'s
+C<sources> parameter.
+
+See L<TAP::Parser::IteratorFactory> for more details on how configuration is
+passed to I<SourceHandlers>.
+
+=head1 PLUGINS
+
+Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the
+plugin name:
+
+ prove -PMyPlugin=fou,du,fafa
+
+Please check individual plugin documentation for more details.
+
+=head2 Available Plugins
+
+For an up-to-date list of plugins available, please check CPAN:
+
+L<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
+
+=head2 Writing Plugins
+
+Please see L<App::Prove/PLUGINS>.
+
+=cut
+
+# vim:ts=4:sw=4:et:sta
diff --git a/Master/tlpkg/tlperl/bin/prove.bat b/Master/tlpkg/tlperl/bin/prove.bat new file mode 100755 index 00000000000..ef4ca66182b --- /dev/null +++ b/Master/tlpkg/tlperl/bin/prove.bat @@ -0,0 +1,354 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!C:\strawberry\perl\bin\perl.exe -w
+#line 15
+
+use strict;
+use App::Prove;
+
+my $app = App::Prove->new;
+$app->process_args(@ARGV);
+exit( $app->run ? 0 : 1 );
+
+__END__
+
+=head1 NAME
+
+prove - Run tests through a TAP harness.
+
+=head1 USAGE
+
+ prove [options] [files or directories]
+
+=head1 OPTIONS
+
+Boolean options:
+
+ -v, --verbose Print all test lines.
+ -l, --lib Add 'lib' to the path for your tests (-Ilib).
+ -b, --blib Add 'blib/lib' and 'blib/arch' to the path for
+ your tests
+ -s, --shuffle Run the tests in random order.
+ -c, --color Colored test output (default).
+ --nocolor Do not color test output.
+ --count Show the X/Y test count when not verbose
+ (default)
+ --nocount Disable the X/Y test count.
+ -D --dry Dry run. Show test that would have run.
+ --ext Set the extension for tests (default '.t')
+ -f, --failures Show failed tests.
+ -o, --comments Show comments.
+ --ignore-exit Ignore exit status from test scripts.
+ -m, --merge Merge test scripts' STDERR with their STDOUT.
+ -r, --recurse Recursively descend into directories.
+ --reverse Run the tests in reverse order.
+ -q, --quiet Suppress some test output while running tests.
+ -Q, --QUIET Only print summary results.
+ -p, --parse Show full list of TAP parse errors, if any.
+ --directives Only show results with TODO or SKIP directives.
+ --timer Print elapsed time after each test.
+ --normalize Normalize TAP output in verbose output
+ -T Enable tainting checks.
+ -t Enable tainting warnings.
+ -W Enable fatal warnings.
+ -w Enable warnings.
+ -h, --help Display this help
+ -?, Display this help
+ -H, --man Longer manpage for prove
+ --norc Don't process default .proverc
+
+Options that take arguments:
+
+ -I Library paths to include.
+ -P Load plugin (searches App::Prove::Plugin::*.)
+ -M Load a module.
+ -e, --exec Interpreter to run the tests ('' for compiled
+ tests.)
+ --harness Define test harness to use. See TAP::Harness.
+ --formatter Result formatter to use. See FORMATTERS.
+ --source Load and/or configure a SourceHandler. See
+ SOURCE HANDLERS.
+ -a, --archive out.tgz Store the resulting TAP in an archive file.
+ -j, --jobs N Run N test jobs in parallel (try 9.)
+ --state=opts Control prove's persistent state.
+ --rc=rcfile Process options from rcfile
+
+=head1 NOTES
+
+=head2 .proverc
+
+If F<~/.proverc> or F<./.proverc> exist they will be read and any
+options they contain processed before the command line options. Options
+in F<.proverc> are specified in the same way as command line options:
+
+ # .proverc
+ --state=hot,fast,save
+ -j9
+
+Additional option files may be specified with the C<--rc> option.
+Default option file processing is disabled by the C<--norc> option.
+
+Under Windows and VMS the option file is named F<_proverc> rather than
+F<.proverc> and is sought only in the current directory.
+
+=head2 Reading from C<STDIN>
+
+If you have a list of tests (or URLs, or anything else you want to test) in a
+file, you can add them to your tests by using a '-':
+
+ prove - < my_list_of_things_to_test.txt
+
+See the C<README> in the C<examples> directory of this distribution.
+
+=head2 Default Test Directory
+
+If no files or directories are supplied, C<prove> looks for all files
+matching the pattern C<t/*.t>.
+
+=head2 Colored Test Output
+
+Colored test output is the default, but if output is not to a
+terminal, color is disabled. You can override this by adding the
+C<--color> switch.
+
+Color support requires L<Term::ANSIColor> on Unix-like platforms and
+L<Win32::Console> windows. If the necessary module is not installed
+colored output will not be available.
+
+=head2 Exit Code
+
+If the tests fail C<prove> will exit with non-zero status.
+
+=head2 Arguments to Tests
+
+It is possible to supply arguments to tests. To do so separate them from
+prove's own arguments with the arisdottle, '::'. For example
+
+ prove -v t/mytest.t :: --url http://example.com
+
+would run F<t/mytest.t> with the options '--url http://example.com'.
+When running multiple tests they will each receive the same arguments.
+
+=head2 C<--exec>
+
+Normally you can just pass a list of Perl tests and the harness will know how
+to execute them. However, if your tests are not written in Perl or if you
+want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
+switch:
+
+ prove --exec '/usr/bin/ruby -w' t/
+ prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
+ prove --exec '/path/to/my/customer/exec'
+
+=head2 C<--merge>
+
+If you need to make sure your diagnostics are displayed in the correct
+order relative to test results you can use the C<--merge> option to
+merge the test scripts' STDERR into their STDOUT.
+
+This guarantees that STDOUT (where the test results appear) and STDOUT
+(where the diagnostics appear) will stay in sync. The harness will
+display any diagnostics your tests emit on STDERR.
+
+Caveat: this is a bit of a kludge. In particular note that if anything
+that appears on STDERR looks like a test result the test harness will
+get confused. Use this option only if you understand the consequences
+and can live with the risk.
+
+=head2 C<--state>
+
+You can ask C<prove> to remember the state of previous test runs and
+select and/or order the tests to be run based on that saved state.
+
+The C<--state> switch requires an argument which must be a comma
+separated list of one or more of the following options.
+
+=over
+
+=item C<last>
+
+Run the same tests as the last time the state was saved. This makes it
+possible, for example, to recreate the ordering of a shuffled test.
+
+ # Run all tests in random order
+ $ prove -b --state=save --shuffle
+
+ # Run them again in the same order
+ $ prove -b --state=last
+
+=item C<failed>
+
+Run only the tests that failed on the last run.
+
+ # Run all tests
+ $ prove -b --state=save
+
+ # Run failures
+ $ prove -b --state=failed
+
+If you also specify the C<save> option newly passing tests will be
+excluded from subsequent runs.
+
+ # Repeat until no more failures
+ $ prove -b --state=failed,save
+
+=item C<passed>
+
+Run only the passed tests from last time. Useful to make sure that no
+new problems have been introduced.
+
+=item C<all>
+
+Run all tests in normal order. Multple options may be specified, so to
+run all tests with the failures from last time first:
+
+ $ prove -b --state=failed,all,save
+
+=item C<hot>
+
+Run the tests that most recently failed first. The last failure time of
+each test is stored. The C<hot> option causes tests to be run in most-recent-
+failure order.
+
+ $ prove -b --state=hot,save
+
+Tests that have never failed will not be selected. To run all tests with
+the most recently failed first use
+
+ $ prove -b --state=hot,all,save
+
+This combination of options may also be specified thus
+
+ $ prove -b --state=adrian
+
+=item C<todo>
+
+Run any tests with todos.
+
+=item C<slow>
+
+Run the tests in slowest to fastest order. This is useful in conjunction
+with the C<-j> parallel testing switch to ensure that your slowest tests
+start running first.
+
+ $ prove -b --state=slow -j9
+
+=item C<fast>
+
+Run test tests in fastest to slowest order.
+
+=item C<new>
+
+Run the tests in newest to oldest order based on the modification times
+of the test scripts.
+
+=item C<old>
+
+Run the tests in oldest to newest order.
+
+=item C<fresh>
+
+Run those test scripts that have been modified since the last test run.
+
+=item C<save>
+
+Save the state on exit. The state is stored in a file called F<.prove>
+(F<_prove> on Windows and VMS) in the current directory.
+
+=back
+
+The C<--state> switch may be used more than once.
+
+ $ prove -b --state=hot --state=all,save
+
+=head2 @INC
+
+prove introduces a separation between "options passed to the perl which
+runs prove" and "options passed to the perl which runs tests"; this
+distinction is by design. Thus the perl which is running a test starts
+with the default C<@INC>. Additional library directories can be added
+via the C<PERL5LIB> environment variable, via -Ifoo in C<PERL5OPT> or
+via the C<-Ilib> option to F<prove>.
+
+=head2 Taint Mode
+
+Normally when a Perl program is run in taint mode the contents of the
+C<PERL5LIB> environment variable do not appear in C<@INC>.
+
+Because C<PERL5LIB> is often used during testing to add build
+directories to C<@INC> prove passes the names of any directories found
+in C<PERL5LIB> as -I switches. The net effect of this is that
+C<PERL5LIB> is honoured even when prove is run in taint mode.
+
+
+=head1 FORMATTERS
+
+You can load a custom L<TAP::Parser::Formatter>:
+
+ prove --formatter MyFormatter
+
+=head1 SOURCE HANDLERS
+
+You can load custom L<TAP::Parser::SourceHandler>s, to change the way the
+parser interprets particular I<sources> of TAP.
+
+ prove --source MyHandler --source YetAnother t
+
+If you want to provide config to the source you can use:
+
+ prove --source MyCustom \
+ --source Perl --perl-option 'foo=bar baz' --perl-option avg=0.278 \
+ --source File --file-option extensions=.txt --file-option extensions=.tmp t
+
+Each C<--$source-option> option must specify a key/value pair separated by an
+C<=>. If an option can take multiple values, just specify it multiple times,
+as with the C<extensions=> examples above.
+
+All C<--sources> are combined into a hash, and passed to L<TAP::Harness/new>'s
+C<sources> parameter.
+
+See L<TAP::Parser::IteratorFactory> for more details on how configuration is
+passed to I<SourceHandlers>.
+
+=head1 PLUGINS
+
+Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the
+plugin name:
+
+ prove -PMyPlugin=fou,du,fafa
+
+Please check individual plugin documentation for more details.
+
+=head2 Available Plugins
+
+For an up-to-date list of plugins available, please check CPAN:
+
+L<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
+
+=head2 Writing Plugins
+
+Please see L<App::Prove/PLUGINS>.
+
+=cut
+
+# vim:ts=4:sw=4:et:sta
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/psed.bat b/Master/tlpkg/tlperl/bin/psed.bat new file mode 100755 index 00000000000..aaf9845505b --- /dev/null +++ b/Master/tlpkg/tlperl/bin/psed.bat @@ -0,0 +1,2018 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+my $startperl;
+my $perlpath;
+($startperl = <<'/../') =~ s/\s*\z//;
+#!perl
+/../
+($perlpath = <<'/../') =~ s/\s*\z//;
+C:\strawberry\perl\bin\perl.exe
+/../
+
+$0 =~ s/^.*?(\w+)[\.\w]*$/$1/;
+
+# (p)sed - a stream editor
+# History: Aug 12 2000: Original version.
+# Mar 25 2002: Rearrange generated Perl program.
+# Jul 23 2007: Fix bug in regex stripping (M.Thorland)
+
+use strict;
+use integer;
+use Symbol;
+
+=head1 NAME
+
+psed - a stream editor
+
+=head1 SYNOPSIS
+
+ psed [-an] script [file ...]
+ psed [-an] [-e script] [-f script-file] [file ...]
+
+ s2p [-an] [-e script] [-f script-file]
+
+=head1 DESCRIPTION
+
+A stream editor reads the input stream consisting of the specified files
+(or standard input, if none are given), processes is line by line by
+applying a script consisting of edit commands, and writes resulting lines
+to standard output. The filename `C<->' may be used to read standard input.
+
+The edit script is composed from arguments of B<-e> options and
+script-files, in the given order. A single script argument may be specified
+as the first parameter.
+
+If this program is invoked with the name F<s2p>, it will act as a
+sed-to-Perl translator. See L<"sed Script Translation">.
+
+B<sed> returns an exit code of 0 on success or >0 if an error occurred.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>
+
+A file specified as argument to the B<w> edit command is by default
+opened before input processing starts. Using B<-a>, opening of such
+files is delayed until the first line is actually written to the file.
+
+=item B<-e> I<script>
+
+The editing commands defined by I<script> are appended to the script.
+Multiple commands must be separated by newlines.
+
+=item B<-f> I<script-file>
+
+Editing commands from the specified I<script-file> are read and appended
+to the script.
+
+=item B<-n>
+
+By default, a line is written to standard output after the editing script
+has been applied to it. The B<-n> option suppresses automatic printing.
+
+=back
+
+=head1 COMMANDS
+
+B<sed> command syntax is defined as
+
+Z<> Z<> Z<> Z<>[I<address>[B<,>I<address>]][B<!>]I<function>[I<argument>]
+
+with whitespace being permitted before or after addresses, and between
+the function character and the argument. The I<address>es and the
+address inverter (C<!>) are used to restrict the application of a
+command to the selected line(s) of input.
+
+Each command must be on a line of its own, except where noted in
+the synopses below.
+
+The edit cycle performed on each input line consist of reading the line
+(without its trailing newline character) into the I<pattern space>,
+applying the applicable commands of the edit script, writing the final
+contents of the pattern space and a newline to the standard output.
+A I<hold space> is provided for saving the contents of the
+pattern space for later use.
+
+=head2 Addresses
+
+A sed address is either a line number or a pattern, which may be combined
+arbitrarily to construct ranges. Lines are numbered across all input files.
+
+Any address may be followed by an exclamation mark (`C<!>'), selecting
+all lines not matching that address.
+
+=over 4
+
+=item I<number>
+
+The line with the given number is selected.
+
+=item B<$>
+
+A dollar sign (C<$>) is the line number of the last line of the input stream.
+
+=item B</>I<regular expression>B</>
+
+A pattern address is a basic regular expression (see
+L<"Basic Regular Expressions">), between the delimiting character C</>.
+Any other character except C<\> or newline may be used to delimit a
+pattern address when the initial delimiter is prefixed with a
+backslash (`C<\>').
+
+=back
+
+If no address is given, the command selects every line.
+
+If one address is given, it selects the line (or lines) matching the
+address.
+
+Two addresses select a range that begins whenever the first address
+matches, and ends (including that line) when the second address matches.
+If the first (second) address is a matching pattern, the second
+address is not applied to the very same line to determine the end of
+the range. Likewise, if the second address is a matching pattern, the
+first address is not applied to the very same line to determine the
+begin of another range. If both addresses are line numbers,
+and the second line number is less than the first line number, then
+only the first line is selected.
+
+
+=head2 Functions
+
+The maximum permitted number of addresses is indicated with each
+function synopsis below.
+
+The argument I<text> consists of one or more lines following the command.
+Embedded newlines in I<text> must be preceded with a backslash. Other
+backslashes in I<text> are deleted and the following character is taken
+literally.
+
+=over 4
+
+=cut
+
+my %ComTab;
+my %GenKey;
+#--------------------------------------------------------------------------
+$ComTab{'a'}=[ 1, 'txt', \&Emit, '{ push( @Q, <<'."'TheEnd' ) }\n" ]; #ok
+
+=item [1addr]B<a\> I<text>
+
+Write I<text> (which must start on the line following the command)
+to standard output immediately before reading the next line
+of input, either by executing the B<N> function or by beginning a new cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'b'}=[ 2, 'str', \&Branch, '{ goto XXX; }' ]; #ok
+
+=item [2addr]B<b> [I<label>]
+
+Branch to the B<:> function with the specified I<label>. If no label
+is given, branch to the end of the script.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'c'}=[ 2, 'txt', \&Change, <<'-X-' ]; #ok
+{ print <<'TheEnd'; } $doPrint = 0; goto EOS;
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<c\> I<text>
+
+The line, or range of lines, selected by the address is deleted.
+The I<text> (which must start on the line following the command)
+is written to standard output. With an address range, this occurs at
+the end of the range.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'d'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ $doPrint = 0;
+ goto EOS;
+}
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<d>
+
+Deletes the pattern space and starts the next cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'D'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ s/^.*\n?//;
+ if(length($_)){ goto BOS } else { goto EOS }
+}
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<D>
+
+Deletes the pattern space through the first embedded newline or to the end.
+If the pattern space becomes empty, a new cycle is started, otherwise
+execution of the script is restarted.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'g'}=[ 2, '', \&Emit, '{ $_ = $Hold };' ]; #ok
+
+=item [2addr]B<g>
+
+Replace the contents of the pattern space with the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'G'}=[ 2, '', \&Emit, '{ $_ .= "\n"; $_ .= $Hold };' ]; #ok
+
+=item [2addr]B<G>
+
+Append a newline and the contents of the hold space to the pattern space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'h'}=[ 2, '', \&Emit, '{ $Hold = $_ }' ]; #ok
+
+=item [2addr]B<h>
+
+Replace the contents of the hold space with the pattern space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'H'}=[ 2, '', \&Emit, '{ $Hold .= "\n"; $Hold .= $_; }' ]; #ok
+
+=item [2addr]B<H>
+
+Append a newline and the contents of the pattern space to the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'i'}=[ 1, 'txt', \&Emit, '{ print <<'."'TheEnd' }\n" ]; #ok
+
+=item [1addr]B<i\> I<text>
+
+Write the I<text> (which must start on the line following the command)
+to standard output.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'l'}=[ 2, '', \&Emit, '{ _l() }' ]; #okUTF8
+
+=item [2addr]B<l>
+
+Print the contents of the pattern space: non-printable characters are
+shown in C-style escaped form; long lines are split and have a trailing
+`C<\>' at the point of the split; the true end of a line is marked with
+a `C<$>'. Escapes are: `\a', `\t', `\n', `\f', `\r', `\e' for
+BEL, HT, LF, FF, CR, ESC, respectively, and `\' followed by a three-digit
+octal number for all other non-printable characters.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'n'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ print $_, "\n" if $doPrint;
+ printQ() if @Q;
+ $CondReg = 0;
+ last CYCLE unless getsARGV();
+ chomp();
+}
+-X-
+
+=item [2addr]B<n>
+
+If automatic printing is enabled, write the pattern space to the standard
+output. Replace the pattern space with the next line of input. If
+there is no more input, processing is terminated.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'N'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ printQ() if @Q;
+ $CondReg = 0;
+ last CYCLE unless getsARGV( $h );
+ chomp( $h );
+ $_ .= "\n$h";
+}
+-X-
+
+=item [2addr]B<N>
+
+Append a newline and the next line of input to the pattern space. If
+there is no more input, processing is terminated.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'p'}=[ 2, '', \&Emit, '{ print $_, "\n"; }' ]; #ok
+
+=item [2addr]B<p>
+
+Print the pattern space to the standard output. (Use the B<-n> option
+to suppress automatic printing at the end of a cycle if you want to
+avoid double printing of lines.)
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'P'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ if( /^(.*)/ ){ print $1, "\n"; } }
+-X-
+
+=item [2addr]B<P>
+
+Prints the pattern space through the first embedded newline or to the end.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'q'}=[ 1, '', \&Emit, <<'-X-' ]; #ok
+{ print $_, "\n" if $doPrint;
+ last CYCLE;
+}
+-X-
+
+=item [1addr]B<q>
+
+Branch to the end of the script and quit without starting a new cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'r'}=[ 1, 'str', \&Emit, "{ _r( '-X-' ) }" ]; #ok
+
+=item [1addr]B<r> I<file>
+
+Copy the contents of the I<file> to standard output immediately before
+the next attempt to read a line of input. Any error encountered while
+reading I<file> is silently ignored.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'s'}=[ 2, 'sub', \&Emit, '' ]; #ok
+
+=item [2addr]B<s/>I<regular expression>B</>I<replacement>B</>I<flags>
+
+Substitute the I<replacement> string for the first substring in
+the pattern space that matches the I<regular expression>.
+Any character other than backslash or newline can be used instead of a
+slash to delimit the regular expression and the replacement.
+To use the delimiter as a literal character within the regular expression
+and the replacement, precede the character by a backslash (`C<\>').
+
+Literal newlines may be embedded in the replacement string by
+preceding a newline with a backslash.
+
+Within the replacement, an ampersand (`C<&>') is replaced by the string
+matching the regular expression. The strings `C<\1>' through `C<\9>' are
+replaced by the corresponding subpattern (see L<"Basic Regular Expressions">).
+To get a literal `C<&>' or `C<\>' in the replacement text, precede it
+by a backslash.
+
+The following I<flags> modify the behaviour of the B<s> command:
+
+=over 8
+
+=item B<g>
+
+The replacement is performed for all matching, non-overlapping substrings
+of the pattern space.
+
+=item B<1>..B<9>
+
+Replace only the n-th matching substring of the pattern space.
+
+=item B<p>
+
+If the substitution was made, print the new value of the pattern space.
+
+=item B<w> I<file>
+
+If the substitution was made, write the new value of the pattern space
+to the specified file.
+
+=back
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'t'}=[ 2, 'str', \&Branch, '{ goto XXX if _t() }' ]; #ok
+
+=item [2addr]B<t> [I<label>]
+
+Branch to the B<:> function with the specified I<label> if any B<s>
+substitutions have been made since the most recent reading of an input line
+or execution of a B<t> function. If no label is given, branch to the end of
+the script.
+
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'w'}=[ 2, 'str', \&Write, "{ _w( '-X-' ) }" ]; #ok
+
+=item [2addr]B<w> I<file>
+
+The contents of the pattern space are written to the I<file>.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'x'}=[ 2, '', \&Emit, '{ ($Hold, $_) = ($_, $Hold) }' ]; #ok
+
+=item [2addr]B<x>
+
+Swap the contents of the pattern space and the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'y'}=[ 2, 'tra', \&Emit, '' ]; #ok
+=item [2addr]B<y>B</>I<string1>B</>I<string2>B</>
+
+In the pattern space, replace all characters occuring in I<string1> by the
+character at the corresponding position in I<string2>. It is possible
+to use any character (other than a backslash or newline) instead of a
+slash to delimit the strings. Within I<string1> and I<string2>, a
+backslash followed by any character other than a newline is that literal
+character, and a backslash followed by an `n' is replaced by a newline
+character.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'='}=[ 1, '', \&Emit, '{ print "$.\n" }' ]; #ok
+
+=item [1addr]B<=>
+
+Prints the current line number on the standard output.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{':'}=[ 0, 'str', \&Label, '' ]; #ok
+
+=item [0addr]B<:> [I<label>]
+
+The command specifies the position of the I<label>. It has no other effect.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'{'}=[ 2, '', \&BeginBlock, '{' ]; #ok
+$ComTab{'}'}=[ 0, '', \&EndBlock, ';}' ]; #ok
+# ';' to avoid warning on empty {}-block
+
+=item [2addr]B<{> [I<command>]
+
+=item [0addr]B<}>
+
+These two commands begin and end a command list. The first command may
+be given on the same line as the opening B<{> command. The commands
+within the list are jointly selected by the address(es) given on the
+B<{> command (but may still have individual addresses).
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'#'}=[ 0, 'str', \&Comment, '' ]; #ok
+
+=item [0addr]B<#> [I<comment>]
+
+The entire line is ignored (treated as a comment). If, however, the first
+two characters in the script are `C<#n>', automatic printing of output is
+suppressed, as if the B<-n> option were given on the command line.
+
+=back
+
+=cut
+
+use vars qw{ $isEOF $Hold %wFiles @Q $CondReg $doPrint };
+
+my $useDEBUG = exists( $ENV{PSEDDEBUG} );
+my $useEXTBRE = $ENV{PSEDEXTBRE} || '';
+$useEXTBRE =~ s/[^<>wWyB]//g; # gawk RE's handle these
+
+my $doAutoPrint = 1; # automatic printing of pattern space (-n => 0)
+my $doOpenWrite = 1; # open w command output files at start (-a => 0)
+my $svOpenWrite = 0; # save $doOpenWrite
+
+# lower case $0 below as a VMSism. The VMS build procedure creates the
+# s2p file traditionally in upper case on the disk. When VMS is in a
+# case preserved or case sensitive mode, $0 will be returned in the exact
+# case which will be on the disk, and that is not predictable at this time.
+
+my $doGenerate = lc($0) eq 's2p';
+
+# Collected and compiled script
+#
+my( @Commands, %Defined, @BlockStack, %Label, $labNum, $Code, $Func );
+$Code = '';
+
+##################
+# Compile Time
+#
+# Labels
+#
+# Error handling
+#
+sub Warn($;$){
+ my( $msg, $loc ) = @_;
+ $loc ||= '';
+ $loc .= ': ' if length( $loc );
+ warn( "$0: $loc$msg\n" );
+}
+
+$labNum = 0;
+sub newLabel(){
+ return 'L_'.++$labNum;
+}
+
+# safeHere: create safe here delimiter and modify opcode and argument
+#
+sub safeHere($$){
+ my( $codref, $argref ) = @_;
+ my $eod = 'EOD000';
+ while( $$argref =~ /^$eod$/m ){
+ $eod++;
+ }
+ $$codref =~ s/TheEnd/$eod/e;
+ $$argref .= "$eod\n";
+}
+
+# Emit: create address logic and emit command
+#
+sub Emit($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $cond = '';
+ if( defined( $addr1 ) ){
+ if( defined( $addr2 ) ){
+ $addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
+ } else {
+ $addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
+ }
+ $cond = $negated ? "unless( $addr1 )\n" : "if( $addr1 )\n";
+ }
+
+ if( $opcode eq '' ){
+ $Code .= "$cond$arg\n";
+
+ } elsif( $opcode =~ s/-X-/$arg/e ){
+ $Code .= "$cond$opcode\n";
+
+ } elsif( $opcode =~ /TheEnd/ ){
+ safeHere( \$opcode, \$arg );
+ $Code .= "$cond$opcode$arg";
+
+ } else {
+ $Code .= "$cond$opcode\n";
+ }
+ 0;
+}
+
+# Write (w command, w flag): store pathname
+#
+sub Write($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $path, $fl ) = @_;
+ $wFiles{$path} = '';
+ Emit( $addr1, $addr2, $negated, $opcode, $path, $fl );
+}
+
+
+# Label (: command): label definition
+#
+sub Label($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
+ my $rc = 0;
+ $lab =~ s/\s+//;
+ if( length( $lab ) ){
+ my $h;
+ if( ! exists( $Label{$lab} ) ){
+ $h = $Label{$lab}{name} = newLabel();
+ } else {
+ $h = $Label{$lab}{name};
+ if( exists( $Label{$lab}{defined} ) ){
+ my $dl = $Label{$lab}{defined};
+ Warn( "duplicate label $lab (first defined at $dl)", $fl );
+ $rc = 1;
+ }
+ }
+ $Label{$lab}{defined} = $fl;
+ $Code .= "$h:;\n";
+ }
+ $rc;
+}
+
+# BeginBlock ({ command): push block start
+#
+sub BeginBlock($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ push( @BlockStack, [ $fl, $addr1, $addr2, $negated ] );
+ Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
+}
+
+# EndBlock (} command): check proper nesting
+#
+sub EndBlock($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $rc;
+ my $jcom = pop( @BlockStack );
+ if( defined( $jcom ) ){
+ $rc = Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
+ } else {
+ Warn( "unexpected `}'", $fl );
+ $rc = 1;
+ }
+ $rc;
+}
+
+# Branch (t, b commands): check or create label, substitute default
+#
+sub Branch($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
+ $lab =~ s/\s+//; # no spaces at end
+ my $h;
+ if( length( $lab ) ){
+ if( ! exists( $Label{$lab} ) ){
+ $h = $Label{$lab}{name} = newLabel();
+ } else {
+ $h = $Label{$lab}{name};
+ }
+ push( @{$Label{$lab}{used}}, $fl );
+ } else {
+ $h = 'EOS';
+ }
+ $opcode =~ s/XXX/$h/e;
+ Emit( $addr1, $addr2, $negated, $opcode, '', $fl );
+}
+
+# Change (c command): is special due to range end watching
+#
+sub Change($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $kwd = $negated ? 'unless' : 'if';
+ if( defined( $addr2 ) ){
+ $addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
+ if( ! $negated ){
+ $addr1 = '$icnt = ('.$addr1.')';
+ $opcode = 'if( $icnt =~ /E0$/ )' . $opcode;
+ }
+ } else {
+ $addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
+ }
+ safeHere( \$opcode, \$arg );
+ $Code .= "$kwd( $addr1 ){\n $opcode$arg}\n";
+ 0;
+}
+
+
+# Comment (# command): A no-op. Who would've thought that!
+#
+sub Comment($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+### $Code .= "# $arg\n";
+ 0;
+}
+
+# stripRegex from the current command. If we're in the first
+# part of s///, trailing spaces have to be kept as the initial
+# part of the replacement string.
+#
+sub stripRegex($$;$){
+ my( $del, $sref, $sub ) = @_;
+ my $regex = $del;
+ print "stripRegex:$del:$$sref:\n" if $useDEBUG;
+ while( $$sref =~ s{^(.*?)(\\*)\Q$del\E(\s*)}{}s ){
+ my $sl = $2;
+ $regex .= $1.$sl.$del;
+ if( length( $sl ) % 2 == 0 ){
+ if( $sub && (length( $3 ) > 0) ){
+ $$sref = $3 . $$sref;
+ }
+ return $regex;
+ }
+ $regex .= $3;
+ }
+ undef();
+}
+
+# stripTrans: take a <del> terminated string from y command
+# honoring and cleaning up of \-escaped <del>'s
+#
+sub stripTrans($$){
+ my( $del, $sref ) = @_;
+ my $t = '';
+ print "stripTrans:$del:$$sref:\n" if $useDEBUG;
+ while( $$sref =~ s{^(.*?)(\\*)\Q$del\E}{}s ){
+ my $sl = $2;
+ $t .= $1;
+ if( length( $sl ) % 2 == 0 ){
+ $t .= $sl;
+ $t =~ s/\\\\/\\/g;
+ return $t;
+ }
+ chop( $sl );
+ $t .= $sl.$del.$3;
+ }
+ undef();
+}
+
+# makey - construct Perl y/// from sed y///
+#
+sub makey($$$){
+ my( $fr, $to, $fl ) = @_;
+ my $error = 0;
+
+ # Ensure that any '-' is up front.
+ # Diagnose duplicate contradicting mappings
+ my %tr;
+ for( my $i = 0; $i < length($fr); $i++ ){
+ my $fc = substr($fr,$i,1);
+ my $tc = substr($to,$i,1);
+ if( exists( $tr{$fc} ) && $tr{$fc} ne $tc ){
+ Warn( "ambiguous translation for character `$fc' in `y' command",
+ $fl );
+ $error++;
+ }
+ $tr{$fc} = $tc;
+ }
+ $fr = $to = '';
+ if( exists( $tr{'-'} ) ){
+ ( $fr, $to ) = ( '-', $tr{'-'} );
+ delete( $tr{'-'} );
+ } else {
+ $fr = $to = '';
+ }
+ # might just as well sort it...
+ for my $fc ( sort keys( %tr ) ){
+ $fr .= $fc;
+ $to .= $tr{$fc};
+ }
+ # make embedded delimiters and newlines safe
+ $fr =~ s/([{}])/\$1/g;
+ $to =~ s/([{}])/\$1/g;
+ $fr =~ s/\n/\\n/g;
+ $to =~ s/\n/\\n/g;
+ return $error ? undef() : "{ y{$fr}{$to}; }";
+}
+
+######
+# makes - construct Perl s/// from sed s///
+#
+sub makes($$$$$$$){
+ my( $regex, $subst, $path, $global, $print, $nmatch, $fl ) = @_;
+
+ # make embedded newlines safe
+ $regex =~ s/\n/\\n/g;
+ $subst =~ s/\n/\\n/g;
+
+ my $code;
+ # n-th occurrence
+ #
+ if( length( $nmatch ) ){
+ $code = <<TheEnd;
+{ \$n = $nmatch;
+ while( --\$n && ( \$s = m ${regex}g ) ){}
+ \$s = ( substr( \$_, pos() ) =~ s ${regex}${subst}s ) if \$s;
+ \$CondReg ||= \$s;
+TheEnd
+ } else {
+ $code = <<TheEnd;
+{ \$s = s ${regex}${subst}s${global};
+ \$CondReg ||= \$s;
+TheEnd
+ }
+ if( $print ){
+ $code .= ' print $_, "\n" if $s;'."\n";
+ }
+ if( defined( $path ) ){
+ $wFiles{$path} = '';
+ $code .= " _w( '$path' ) if \$s;\n";
+ $GenKey{'w'} = 1;
+ }
+ $code .= "}";
+}
+
+=head1 BASIC REGULAR EXPRESSIONS
+
+A I<Basic Regular Expression> (BRE), as defined in POSIX 1003.2, consists
+of I<atoms>, for matching parts of a string, and I<bounds>, specifying
+repetitions of a preceding atom.
+
+=head2 Atoms
+
+The possible atoms of a BRE are: B<.>, matching any single character;
+B<^> and B<$>, matching the null string at the beginning or end
+of a string, respectively; a I<bracket expressions>, enclosed
+in B<[> and B<]> (see below); and any single character with no
+other significance (matching that character). A B<\> before one
+of: B<.>, B<^>, B<$>, B<[>, B<*>, B<\>, matching the character
+after the backslash. A sequence of atoms enclosed in B<\(> and B<\)>
+becomes an atom and establishes the target for a I<backreference>,
+consisting of the substring that actually matches the enclosed atoms.
+Finally, B<\> followed by one of the digits B<0> through B<9> is a
+backreference.
+
+A B<^> that is not first, or a B<$> that is not last does not have
+a special significance and need not be preceded by a backslash to
+become literal. The same is true for a B<]>, that does not terminate
+a bracket expression.
+
+An unescaped backslash cannot be last in a BRE.
+
+=head2 Bounds
+
+The BRE bounds are: B<*>, specifying 0 or more matches of the preceding
+atom; B<\{>I<count>B<\}>, specifying that many repetitions;
+B<\{>I<minimum>B<,\}>, giving a lower limit; and
+B<\{>I<minimum>B<,>I<maximum>B<\}> finally defines a lower and upper
+bound.
+
+A bound appearing as the first item in a BRE is taken literally.
+
+=head2 Bracket Expressions
+
+A I<bracket expression> is a list of characters, character ranges
+and character classes enclosed in B<[> and B<]> and matches any
+single character from the represented set of characters.
+
+A character range is written as two characters separated by B<-> and
+represents all characters (according to the character collating sequence)
+that are not less than the first and not greater than the second.
+(Ranges are very collating-sequence-dependent, and portable programs
+should avoid relying on them.)
+
+A character class is one of the class names
+
+ alnum digit punct
+ alpha graph space
+ blank lower upper
+ cntrl print xdigit
+
+enclosed in B<[:> and B<:]> and represents the set of characters
+as defined in ctype(3).
+
+If the first character after B<[> is B<^>, the sense of matching is
+inverted.
+
+To include a literal `C<^>', place it anywhere else but first. To
+include a literal 'C<]>' place it first or immediately after an
+initial B<^>. To include a literal `C<->' make it the first (or
+second after B<^>) or last character, or the second endpoint of
+a range.
+
+The special bracket expression constructs C<[[:E<lt>:]]> and C<[[:E<gt>:]]>
+match the null string at the beginning and end of a word respectively.
+(Note that neither is identical to Perl's `\b' atom.)
+
+=head2 Additional Atoms
+
+Since some sed implementations provide additional regular expression
+atoms (not defined in POSIX 1003.2), B<psed> is capable of translating
+the following backslash escapes:
+
+=over 4
+
+=item B<\E<lt>> This is the same as C<[[:E<gt>:]]>.
+
+=item B<\E<gt>> This is the same as C<[[:E<lt>:]]>.
+
+=item B<\w> This is an abbreviation for C<[[:alnum:]_]>.
+
+=item B<\W> This is an abbreviation for C<[^[:alnum:]_]>.
+
+=item B<\y> Match the empty string at a word boundary.
+
+=item B<\B> Match the empty string between any two either word or non-word characters.
+
+=back
+
+To enable this feature, the environment variable PSEDEXTBRE must be set
+to a string containing the requested characters, e.g.:
+C<PSEDEXTBRE='E<lt>E<gt>wW'>.
+
+=cut
+
+#####
+# bre2p - convert BRE to Perl RE
+#
+sub peek(\$$){
+ my( $pref, $ic ) = @_;
+ $ic < length($$pref)-1 ? substr( $$pref, $ic+1, 1 ) : '';
+}
+
+sub bre2p($$$){
+ my( $del, $pat, $fl ) = @_;
+ my $led = $del;
+ $led =~ tr/{([</})]>/;
+ $led = '' if $led eq $del;
+
+ $pat = substr( $pat, 1, length($pat) - 2 );
+ my $res = '';
+ my $bracklev = 0;
+ my $backref = 0;
+ my $parlev = 0;
+ for( my $ic = 0; $ic < length( $pat ); $ic++ ){
+ my $c = substr( $pat, $ic, 1 );
+ if( $c eq '\\' ){
+ ### backslash escapes
+ my $nc = peek($pat,$ic);
+ if( $nc eq '' ){
+ Warn( "`\\' cannot be last in pattern", $fl );
+ return undef();
+ }
+ $ic++;
+ if( $nc eq $del ){ ## \<pattern del> => \<pattern del>
+ $res .= "\\$del";
+
+ } elsif( $nc =~ /([[.*\\n])/ ){
+ ## check for \-escaped magics and \n:
+ ## \[ \. \* \\ \n stay as they are
+ $res .= '\\'.$nc;
+
+ } elsif( $nc eq '(' ){ ## \( => (
+ $parlev++;
+ $res .= '(';
+
+ } elsif( $nc eq ')' ){ ## \) => )
+ $parlev--;
+ $backref++;
+ if( $parlev < 0 ){
+ Warn( "unmatched `\\)'", $fl );
+ return undef();
+ }
+ $res .= ')';
+
+ } elsif( $nc eq '{' ){ ## repetition factor \{<i>[,[<j>]]\}
+ my $endpos = index( $pat, '\\}', $ic );
+ if( $endpos < 0 ){
+ Warn( "unmatched `\\{'", $fl );
+ return undef();
+ }
+ my $rep = substr( $pat, $ic+1, $endpos-($ic+1) );
+ $ic = $endpos + 1;
+
+ if( $res =~ /^\^?$/ ){
+ $res .= "\\{$rep\}";
+ } elsif( $rep =~ /^(\d+)(,?)(\d*)?$/ ){
+ my $min = $1;
+ my $com = $2 || '';
+ my $max = $3;
+ if( length( $max ) ){
+ if( $max < $min ){
+ Warn( "maximum less than minimum in `\\{$rep\\}'",
+ $fl );
+ return undef();
+ }
+ } else {
+ $max = '';
+ }
+ # simplify some
+ if( $min == 0 && $max eq '1' ){
+ $res .= '?';
+ } elsif( $min == 1 && "$com$max" eq ',' ){
+ $res .= '+';
+ } elsif( $min == 0 && "$com$max" eq ',' ){
+ $res .= '*';
+ } else {
+ $res .= "{$min$com$max}";
+ }
+ } else {
+ Warn( "invalid repeat clause `\\{$rep\\}'", $fl );
+ return undef();
+ }
+
+ } elsif( $nc =~ /^[1-9]$/ ){
+ ## \1 .. \9 => \1 .. \9, but check for a following digit
+ if( $nc > $backref ){
+ Warn( "invalid backreference ($nc)", $fl );
+ return undef();
+ }
+ $res .= "\\$nc";
+ if( peek($pat,$ic) =~ /[0-9]/ ){
+ $res .= '(?:)';
+ }
+
+ } elsif( $useEXTBRE && ( $nc =~ /[$useEXTBRE]/ ) ){
+ ## extensions - at most <>wWyB - not in POSIX
+ if( $nc eq '<' ){ ## \< => \b(?=\w), be precise
+ $res .= '\\b(?<=\\W)';
+ } elsif( $nc eq '>' ){ ## \> => \b(?=\W), be precise
+ $res .= '\\b(?=\\W)';
+ } elsif( $nc eq 'y' ){ ## \y => \b
+ $res .= '\\b';
+ } else { ## \B, \w, \W remain the same
+ $res .= "\\$nc";
+ }
+ } elsif( $nc eq $led ){
+ ## \<closing bracketing-delimiter> - keep '\'
+ $res .= "\\$nc";
+
+ } else { ## \ <char> => <char> ("as if `\' were not present")
+ $res .= $nc;
+ }
+
+ } elsif( $c eq '.' ){ ## . => .
+ $res .= $c;
+
+ } elsif( $c eq '*' ){ ## * => * but \* if there's nothing preceding it
+ if( $res =~ /^\^?$/ ){
+ $res .= '\\*';
+ } elsif( substr( $res, -1, 1 ) ne '*' ){
+ $res .= $c;
+ }
+
+ } elsif( $c eq '[' ){
+ ## parse []: [^...] [^]...] [-...]
+ my $add = '[';
+ if( peek($pat,$ic) eq '^' ){
+ $ic++;
+ $add .= '^';
+ }
+ my $nc = peek($pat,$ic);
+ if( $nc eq ']' || $nc eq '-' ){
+ $add .= $nc;
+ $ic++;
+ }
+ # check that [ is not trailing
+ if( $ic >= length( $pat ) - 1 ){
+ Warn( "unmatched `['", $fl );
+ return undef();
+ }
+ # look for [:...:] and x-y
+ my $rstr = substr( $pat, $ic+1 );
+ if( $rstr =~ /^((?:\[:\(\w+|[><]\):\]|[^]-](?:-[^]])?)*)/ ){
+ my $cnt = $1;
+ $ic += length( $cnt );
+ $cnt =~ s/([\\\$])/\\$1/g; # `\', `$' are magic in Perl []
+ # try some simplifications
+ my $red = $cnt;
+ if( $red =~ s/0-9// ){
+ $cnt = $red.'\d';
+ if( $red =~ s/A-Z// && $red =~ s/a-z// && $red =~ s/_// ){
+ $cnt = $red.'\w';
+ }
+ }
+ $add .= $cnt;
+
+ # POSIX 1003.2 has this (optional) for begin/end word
+ $add = '\\b(?=\\W)' if $add eq '[[:<:]]';
+ $add = '\\b(?<=\\W)' if $add eq '[[:>:]]';
+
+ }
+
+ ## may have a trailing `-' before `]'
+ if( $ic < length($pat) - 1 &&
+ substr( $pat, $ic+1 ) =~ /^(-?])/ ){
+ $ic += length( $1 );
+ $add .= $1;
+ # another simplification
+ $add =~ s/^\[(\^?)(\\[dw])]$/ $1 eq '^' ? uc($2) : $2 /e;
+ $res .= $add;
+ } else {
+ Warn( "unmatched `['", $fl );
+ return undef();
+ }
+
+ } elsif( $c eq $led ){ ## unescaped <closing bracketing-delimiter>
+ $res .= "\\$c";
+
+ } elsif( $c eq ']' ){ ## unmatched ] is not magic
+ $res .= ']';
+
+ } elsif( $c =~ /[|+?{}()]/ ){ ## not magic in BRE, but in Perl: \-quote
+ $res .= "\\$c";
+
+ } elsif( $c eq '^' ){ ## not magic unless 1st, but in Perl: \-quote
+ $res .= length( $res ) ? '\\^' : '^';
+
+ } elsif( $c eq '$' ){ ## not magic unless last, but in Perl: \-quote
+ $res .= $ic == length( $pat ) - 1 ? '$' : '\\$';
+
+ } else {
+ $res .= $c;
+ }
+ }
+
+ if( $parlev ){
+ Warn( "unmatched `\\('", $fl );
+ return undef();
+ }
+
+ # final cleanup: eliminate raw HTs
+ $res =~ s/\t/\\t/g;
+ return $del . $res . ( $led ? $led : $del );
+}
+
+
+#####
+# sub2p - convert sed substitution to Perl substitution
+#
+sub sub2p($$$){
+ my( $del, $subst, $fl ) = @_;
+ my $led = $del;
+ $led =~ tr/{([</})]>/;
+ $led = '' if $led eq $del;
+
+ $subst = substr( $subst, 1, length($subst) - 2 );
+ my $res = '';
+
+ for( my $ic = 0; $ic < length( $subst ); $ic++ ){
+ my $c = substr( $subst, $ic, 1 );
+ if( $c eq '\\' ){
+ ### backslash escapes
+ my $nc = peek($subst,$ic);
+ if( $nc eq '' ){
+ Warn( "`\\' cannot be last in substitution", $fl );
+ return undef();
+ }
+ $ic++;
+ if( $nc =~ /[\\$del$led]/ ){ ## \ and delimiter
+ $res .= '\\' . $nc;
+ } elsif( $nc =~ /[1-9]/ ){ ## \1 - \9 => ${1} - ${9}
+ $res .= '${' . $nc . '}';
+ } else { ## everything else (includes &): omit \
+ $res .= $nc;
+ }
+ } elsif( $c eq '&' ){ ## & => $&
+ $res .= '$&';
+ } elsif( $c =~ /[\$\@$led]/ ){ ## magic in Perl's substitution string
+ $res .= '\\' . $c;
+ } else {
+ $res .= $c;
+ }
+ }
+
+ # final cleanup: eliminate raw HTs
+ $res =~ s/\t/\\t/g;
+ return ( $led ? $del : $led ) . $res . ( $led ? $led : $del );
+}
+
+
+sub Parse(){
+ my $error = 0;
+ my( $pdef, $pfil, $plin );
+ for( my $icom = 0; $icom < @Commands; $icom++ ){
+ my $cmd = $Commands[$icom];
+ print "Parse:$cmd:\n" if $useDEBUG;
+ $cmd =~ s/^\s+//;
+ next unless length( $cmd );
+ my $scom = $icom;
+ if( exists( $Defined{$icom} ) ){
+ $pdef = $Defined{$icom};
+ if( $pdef =~ /^ #(\d+)/ ){
+ $pfil = 'expression #';
+ $plin = $1;
+ } else {
+ $pfil = "$pdef l.";
+ $plin = 1;
+ }
+ } else {
+ $plin++;
+ }
+ my $fl = "$pfil$plin";
+
+ # insert command as comment in gnerated code
+ #
+ $Code .= "# $cmd\n" if $doGenerate;
+
+ # The Address(es)
+ #
+ my( $negated, $naddr, $addr1, $addr2 );
+ $naddr = 0;
+ if( $cmd =~ s/^(\d+)\s*// ){
+ $addr1 = "$1"; $naddr++;
+ } elsif( $cmd =~ s/^\$\s*// ){
+ $addr1 = 'eofARGV()'; $naddr++;
+ } elsif( $cmd =~ s{^(/)}{} || $cmd =~ s{^\\(.)}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd );
+ if( defined( $regex ) ){
+ $addr1 = 'm '.bre2p( $del, $regex, $fl ).'s';
+ $naddr++;
+ } else {
+ Warn( "malformed regex, 1st address", $fl );
+ $error++;
+ next;
+ }
+ }
+ if( defined( $addr1 ) && $cmd =~ s/,\s*// ){
+ if( $cmd =~ s/^(\d+)\s*// ){
+ $addr2 = "$1"; $naddr++;
+ } elsif( $cmd =~ s/^\$\s*// ){
+ $addr2 = 'eofARGV()'; $naddr++;
+ } elsif( $cmd =~ s{^(/)}{} || $cmd =~ s{^\\(.)}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd );
+ if( defined( $regex ) ){
+ $addr2 = 'm '. bre2p( $del, $regex, $fl ).'s';
+ $naddr++;
+ } else {
+ Warn( "malformed regex, 2nd address", $fl );
+ $error++;
+ next;
+ }
+ } else {
+ Warn( "invalid address after `,'", $fl );
+ $error++;
+ next;
+ }
+ }
+
+ # address modifier `!'
+ #
+ $negated = $cmd =~ s/^!\s*//;
+ if( defined( $addr1 ) ){
+ print "Parse: addr1=$addr1" if $useDEBUG;
+ if( defined( $addr2 ) ){
+ print ", addr2=$addr2 " if $useDEBUG;
+ # both numeric and addr1 > addr2 => eliminate addr2
+ undef( $addr2 ) if $addr1 =~ /^\d+$/ &&
+ $addr2 =~ /^\d+$/ && $addr1 > $addr2;
+ }
+ }
+ print 'negated' if $useDEBUG && $negated;
+ print " command:$cmd\n" if $useDEBUG;
+
+ # The Command
+ #
+ if( $cmd !~ s/^([:#={}abcdDgGhHilnNpPqrstwxy])\s*// ){
+ my $h = substr( $cmd, 0, 1 );
+ Warn( "unknown command `$h'", $fl );
+ $error++;
+ next;
+ }
+ my $key = $1;
+
+ my $tabref = $ComTab{$key};
+ $GenKey{$key} = 1;
+ if( $naddr > $tabref->[0] ){
+ Warn( "excess address(es)", $fl );
+ $error++;
+ next;
+ }
+
+ my $arg = '';
+ if( $tabref->[1] eq 'str' ){
+ # take remainder - don't care if it is empty
+ $arg = $cmd;
+ $cmd = '';
+
+ } elsif( $tabref->[1] eq 'txt' ){
+ # multi-line text
+ my $goon = $cmd =~ /(.*)\\$/;
+ if( length( $1 ) ){
+ Warn( "extra characters after command ($cmd)", $fl );
+ $error++;
+ }
+ while( $goon ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd = $Commands[$icom];
+ $Code .= "# $cmd\n" if $doGenerate;
+ $goon = $cmd =~ s/\\$//;
+ $cmd =~ s/\\(.)/$1/g;
+ $arg .= "\n" if length( $arg );
+ $arg .= $cmd;
+ }
+ $arg .= "\n" if length( $arg );
+ $cmd = '';
+
+ } elsif( $tabref->[1] eq 'sub' ){
+ # s///
+ if( ! length( $cmd ) ){
+ Warn( "`s' command requires argument", $fl );
+ $error++;
+ next;
+ }
+ if( $cmd =~ s{^([^\\\n])}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd, "s" );
+ if( ! defined( $regex ) ){
+ Warn( "malformed regular expression", $fl );
+ $error++;
+ next;
+ }
+ $regex = bre2p( $del, $regex, $fl );
+
+ # a trailing \ indicates embedded NL (in replacement string)
+ while( $cmd =~ s/(?<!\\)\\$/\n/ ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd .= $Commands[$icom];
+ $Code .= "# $Commands[$icom]\n" if $doGenerate;
+ }
+
+ my $subst = stripRegex( $del, \$cmd );
+ if( ! defined( $regex ) ){
+ Warn( "malformed substitution expression", $fl );
+ $error++;
+ next;
+ }
+ $subst = sub2p( $del, $subst, $fl );
+
+ # parse s/// modifier: g|p|0-9|w <file>
+ my( $global, $nmatch, $print, $write ) =
+ ( '', '', 0, undef );
+ while( $cmd =~ s/^([gp0-9])// ){
+ $1 eq 'g' ? ( $global = 'g' ) :
+ $1 eq 'p' ? ( $print = $1 ) : ( $nmatch .= $1 );
+ }
+ $write = $1 if $cmd =~ s/w\s*(.*)$//;
+ ### $nmatch =~ s/^(\d)\1*$/$1/; ### may be dangerous?
+ if( $global && length( $nmatch ) || length( $nmatch ) > 1 ){
+ Warn( "conflicting flags `$global$nmatch'", $fl );
+ $error++;
+ next;
+ }
+
+ $arg = makes( $regex, $subst,
+ $write, $global, $print, $nmatch, $fl );
+ if( ! defined( $arg ) ){
+ $error++;
+ next;
+ }
+
+ } else {
+ Warn( "improper delimiter in s command", $fl );
+ $error++;
+ next;
+ }
+
+ } elsif( $tabref->[1] eq 'tra' ){
+ # y///
+ # a trailing \ indicates embedded newline
+ while( $cmd =~ s/(?<!\\)\\$/\n/ ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd .= $Commands[$icom];
+ $Code .= "# $Commands[$icom]\n" if $doGenerate;
+ }
+ if( ! length( $cmd ) ){
+ Warn( "`y' command requires argument", $fl );
+ $error++;
+ next;
+ }
+ my $d = substr( $cmd, 0, 1 ); $cmd = substr( $cmd, 1 );
+ if( $d eq '\\' ){
+ Warn( "`\\' not valid as delimiter in `y' command", $fl );
+ $error++;
+ next;
+ }
+ my $fr = stripTrans( $d, \$cmd );
+ if( ! defined( $fr ) || ! length( $cmd ) ){
+ Warn( "malformed `y' command argument", $fl );
+ $error++;
+ next;
+ }
+ my $to = stripTrans( $d, \$cmd );
+ if( ! defined( $to ) ){
+ Warn( "malformed `y' command argument", $fl );
+ $error++;
+ next;
+ }
+ if( length($fr) != length($to) ){
+ Warn( "string lengths in `y' command differ", $fl );
+ $error++;
+ next;
+ }
+ if( ! defined( $arg = makey( $fr, $to, $fl ) ) ){
+ $error++;
+ next;
+ }
+
+ }
+
+ # $cmd must be now empty - exception is {
+ if( $cmd !~ /^\s*$/ ){
+ if( $key eq '{' ){
+ # dirty hack to process command on '{' line
+ $Commands[$icom--] = $cmd;
+ } else {
+ Warn( "extra characters after command ($cmd)", $fl );
+ $error++;
+ next;
+ }
+ }
+
+ # Make Code
+ #
+ if( &{$tabref->[2]}( $addr1, $addr2, $negated,
+ $tabref->[3], $arg, $fl ) ){
+ $error++;
+ }
+ }
+
+ while( @BlockStack ){
+ my $bl = pop( @BlockStack );
+ Warn( "start of unterminated `{'", $bl );
+ $error++;
+ }
+
+ for my $lab ( keys( %Label ) ){
+ if( ! exists( $Label{$lab}{defined} ) ){
+ for my $used ( @{$Label{$lab}{used}} ){
+ Warn( "undefined label `$lab'", $used );
+ $error++;
+ }
+ }
+ }
+
+ exit( 1 ) if $error;
+}
+
+
+##############
+#### MAIN ####
+##############
+
+sub usage(){
+ print STDERR "Usage: sed [-an] command [file...]\n";
+ print STDERR " [-an] [-e command] [-f script-file] [file...]\n";
+}
+
+###################
+# Here we go again...
+#
+my $expr = 0;
+while( @ARGV && $ARGV[0] =~ /^-(.)(.*)$/ ){
+ my $opt = $1;
+ my $arg = $2;
+ shift( @ARGV );
+ if( $opt eq 'e' ){
+ if( length( $arg ) ){
+ push( @Commands, split( "\n", $arg ) );
+ } elsif( @ARGV ){
+ push( @Commands, shift( @ARGV ) );
+ } else {
+ Warn( "option -e requires an argument" );
+ usage();
+ exit( 1 );
+ }
+ $expr++;
+ $Defined{$#Commands} = " #$expr";
+ next;
+ }
+ if( $opt eq 'f' ){
+ my $path;
+ if( length( $arg ) ){
+ $path = $arg;
+ } elsif( @ARGV ){
+ $path = shift( @ARGV );
+ } else {
+ Warn( "option -f requires an argument" );
+ usage();
+ exit( 1 );
+ }
+ my $fst = $#Commands + 1;
+ open( SCRIPT, "<$path" ) || die( "$0: $path: could not open ($!)\n" );
+ my $cmd;
+ while( defined( $cmd = <SCRIPT> ) ){
+ chomp( $cmd );
+ push( @Commands, $cmd );
+ }
+ close( SCRIPT );
+ if( $#Commands >= $fst ){
+ $Defined{$fst} = "$path";
+ }
+ next;
+ }
+ if( $opt eq '-' && $arg eq '' ){
+ last;
+ }
+ if( $opt eq 'h' || $opt eq '?' ){
+ usage();
+ exit( 0 );
+ }
+ if( $opt eq 'n' ){
+ $doAutoPrint = 0;
+ } elsif( $opt eq 'a' ){
+ $doOpenWrite = 0;
+ } else {
+ Warn( "illegal option `$opt'" );
+ usage();
+ exit( 1 );
+ }
+ if( length( $arg ) ){
+ unshift( @ARGV, "-$arg" );
+ }
+}
+
+# A singleton command may be the 1st argument when there are no options.
+#
+if( @Commands == 0 ){
+ if( @ARGV == 0 ){
+ Warn( "no script command given" );
+ usage();
+ exit( 1 );
+ }
+ push( @Commands, split( "\n", shift( @ARGV ) ) );
+ $Defined{0} = ' #1';
+}
+
+print STDERR "Files: @ARGV\n" if $useDEBUG;
+
+# generate leading code
+#
+$Func = <<'[TheEnd]';
+
+# openARGV: open 1st input file
+#
+sub openARGV(){
+ unshift( @ARGV, '-' ) unless @ARGV;
+ my $file = shift( @ARGV );
+ open( ARG, "<$file" )
+ || die( "$0: can't open $file for reading ($!)\n" );
+ $isEOF = 0;
+}
+
+# getsARGV: Read another input line into argument (default: $_).
+# Move on to next input file, and reset EOF flag $isEOF.
+sub getsARGV(;\$){
+ my $argref = @_ ? shift() : \$_;
+ while( $isEOF || ! defined( $$argref = <ARG> ) ){
+ close( ARG );
+ return 0 unless @ARGV;
+ my $file = shift( @ARGV );
+ open( ARG, "<$file" )
+ || die( "$0: can't open $file for reading ($!)\n" );
+ $isEOF = 0;
+ }
+ 1;
+}
+
+# eofARGV: end-of-file test
+#
+sub eofARGV(){
+ return @ARGV == 0 && ( $isEOF = eof( ARG ) );
+}
+
+# makeHandle: Generates another file handle for some file (given by its path)
+# to be written due to a w command or an s command's w flag.
+sub makeHandle($){
+ my( $path ) = @_;
+ my $handle;
+ if( ! exists( $wFiles{$path} ) || $wFiles{$path} eq '' ){
+ $handle = $wFiles{$path} = gensym();
+ if( $doOpenWrite ){
+ if( ! open( $handle, ">$path" ) ){
+ die( "$0: can't open $path for writing: ($!)\n" );
+ }
+ }
+ } else {
+ $handle = $wFiles{$path};
+ }
+ return $handle;
+}
+
+# printQ: Print queued output which is either a string or a reference
+# to a pathname.
+sub printQ(){
+ for my $q ( @Q ){
+ if( ref( $q ) ){
+ # flush open w files so that reading this file gets it all
+ if( exists( $wFiles{$$q} ) && $wFiles{$$q} ne '' ){
+ open( $wFiles{$$q}, ">>$$q" );
+ }
+ # copy file to stdout: slow, but safe
+ if( open( RF, "<$$q" ) ){
+ while( defined( my $line = <RF> ) ){
+ print $line;
+ }
+ close( RF );
+ }
+ } else {
+ print $q;
+ }
+ }
+ undef( @Q );
+}
+
+[TheEnd]
+
+# generate the sed loop
+#
+$Code .= <<'[TheEnd]';
+sub openARGV();
+sub getsARGV(;\$);
+sub eofARGV();
+sub printQ();
+
+# Run: the sed loop reading input and applying the script
+#
+sub Run(){
+ my( $h, $icnt, $s, $n );
+ # hack (not unbreakable :-/) to avoid // matching an empty string
+ my $z = "\000"; $z =~ /$z/;
+ # Initialize.
+ openARGV();
+ $Hold = '';
+ $CondReg = 0;
+ $doPrint = $doAutoPrint;
+CYCLE:
+ while( getsARGV() ){
+ chomp();
+ $CondReg = 0; # cleared on t
+BOS:;
+[TheEnd]
+
+ # parse - avoid opening files when doing s2p
+ #
+ ( $svOpenWrite, $doOpenWrite ) = ( $doOpenWrite, $svOpenWrite )
+ if $doGenerate;
+ Parse();
+ ( $svOpenWrite, $doOpenWrite ) = ( $doOpenWrite, $svOpenWrite )
+ if $doGenerate;
+
+ # append trailing code
+ #
+ $Code .= <<'[TheEnd]';
+EOS: if( $doPrint ){
+ print $_, "\n";
+ } else {
+ $doPrint = $doAutoPrint;
+ }
+ printQ() if @Q;
+ }
+
+ exit( 0 );
+}
+[TheEnd]
+
+
+# append optional functions, prepend prototypes
+#
+my $Proto = "# prototypes\n";
+if( $GenKey{'l'} ){
+ $Proto .= "sub _l();\n";
+ $Func .= <<'[TheEnd]';
+# _l: l command processing
+#
+sub _l(){
+ my $h = $_;
+ my $mcpl = 70;
+ # transform non printing chars into escape notation
+ $h =~ s/\\/\\\\/g;
+ if( $h =~ /[^[:print:]]/ ){
+ $h =~ s/\a/\\a/g;
+ $h =~ s/\f/\\f/g;
+ $h =~ s/\n/\\n/g;
+ $h =~ s/\t/\\t/g;
+ $h =~ s/\r/\\r/g;
+ $h =~ s/\e/\\e/g;
+ $h =~ s/([^[:print:]])/sprintf("\\%03o", ord($1))/ge;
+ }
+ # split into lines of length $mcpl
+ while( length( $h ) > $mcpl ){
+ my $l = substr( $h, 0, $mcpl-1 );
+ $h = substr( $h, $mcpl );
+ # remove incomplete \-escape from end of line
+ if( $l =~ s/(?<!\\)(\\[0-7]{0,2})$// ){
+ $h = $1 . $h;
+ }
+ print $l, "\\\n";
+ }
+ print "$h\$\n";
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'r'} ){
+ $Proto .= "sub _r(\$);\n";
+ $Func .= <<'[TheEnd]';
+# _r: r command processing: Save a reference to the pathname.
+#
+sub _r($){
+ my $path = shift();
+ push( @Q, \$path );
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'t'} ){
+ $Proto .= "sub _t();\n";
+ $Func .= <<'[TheEnd]';
+# _t: t command - condition register test/reset
+#
+sub _t(){
+ my $res = $CondReg;
+ $CondReg = 0;
+ $res;
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'w'} ){
+ $Proto .= "sub _w(\$);\n";
+ $Func .= <<'[TheEnd]';
+# _w: w command and s command's w flag - write to file
+#
+sub _w($){
+ my $path = shift();
+ my $handle = $wFiles{$path};
+ if( ! $doOpenWrite && ! defined( fileno( $handle ) ) ){
+ open( $handle, ">$path" )
+ || die( "$0: $path: cannot open ($!)\n" );
+ }
+ print $handle $_, "\n";
+}
+
+[TheEnd]
+}
+
+$Code = $Proto . $Code;
+
+# magic "#n" - same as -n option
+#
+$doAutoPrint = 0 if substr( $Commands[0], 0, 2 ) eq '#n';
+
+# eval code - check for errors
+#
+print "Code:\n$Code$Func" if $useDEBUG;
+eval $Code . $Func;
+if( $@ ){
+ print "Code:\n$Code$Func";
+ die( "$0: internal error - generated incorrect Perl code: $@\n" );
+}
+
+if( $doGenerate ){
+
+ # write full Perl program
+ #
+
+ # bang line, declarations, prototypes
+ print <<TheEnd;
+#!$perlpath -w
+eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+ if 0;
+\$0 =~ s/^.*?(\\w+)\[\\.\\w+\]*\$/\$1/;
+
+use strict;
+use Symbol;
+use vars qw{ \$isEOF \$Hold \%wFiles \@Q \$CondReg
+ \$doAutoPrint \$doOpenWrite \$doPrint };
+\$doAutoPrint = $doAutoPrint;
+\$doOpenWrite = $doOpenWrite;
+TheEnd
+
+ my $wf = "'" . join( "', '", keys( %wFiles ) ) . "'";
+ if( $wf ne "''" ){
+ print <<TheEnd;
+sub makeHandle(\$);
+for my \$p ( $wf ){
+ exit( 1 ) unless makeHandle( \$p );
+}
+TheEnd
+ }
+
+ print $Code;
+ print "Run();\n";
+ print $Func;
+ exit( 0 );
+
+} else {
+
+ # execute: make handles (and optionally open) all w files; run!
+ for my $p ( keys( %wFiles ) ){
+ exit( 1 ) unless makeHandle( $p );
+ }
+ Run();
+}
+
+
+=head1 ENVIRONMENT
+
+The environment variable C<PSEDEXTBRE> may be set to extend BREs.
+See L<"Additional Atoms">.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item ambiguous translation for character `%s' in `y' command
+
+The indicated character appears twice, with different translations.
+
+=item `[' cannot be last in pattern
+
+A `[' in a BRE indicates the beginning of a I<bracket expression>.
+
+=item `\' cannot be last in pattern
+
+A `\' in a BRE is used to make the subsequent character literal.
+
+=item `\' cannot be last in substitution
+
+A `\' in a subsitution string is used to make the subsequent character literal.
+
+=item conflicting flags `%s'
+
+In an B<s> command, either the `g' flag and an n-th occurrence flag, or
+multiple n-th occurrence flags are specified. Note that only the digits
+`1' through `9' are permitted.
+
+=item duplicate label %s (first defined at %s)
+
+=item excess address(es)
+
+The command has more than the permitted number of addresses.
+
+=item extra characters after command (%s)
+
+=item illegal option `%s'
+
+=item improper delimiter in s command
+
+The BRE and substitution may not be delimited with `\' or newline.
+
+=item invalid address after `,'
+
+=item invalid backreference (%s)
+
+The specified backreference number exceeds the number of backreferences
+in the BRE.
+
+=item invalid repeat clause `\{%s\}'
+
+The repeat clause does not contain a valid integer value, or pair of
+values.
+
+=item malformed regex, 1st address
+
+=item malformed regex, 2nd address
+
+=item malformed regular expression
+
+=item malformed substitution expression
+
+=item malformed `y' command argument
+
+The first or second string of a B<y> command is syntactically incorrect.
+
+=item maximum less than minimum in `\{%s\}'
+
+=item no script command given
+
+There must be at least one B<-e> or one B<-f> option specifying a
+script or script file.
+
+=item `\' not valid as delimiter in `y' command
+
+=item option -e requires an argument
+
+=item option -f requires an argument
+
+=item `s' command requires argument
+
+=item start of unterminated `{'
+
+=item string lengths in `y' command differ
+
+The translation table strings in a B<y> command must have equal lengths.
+
+=item undefined label `%s'
+
+=item unexpected `}'
+
+A B<}> command without a preceding B<{> command was encountered.
+
+=item unexpected end of script
+
+The end of the script was reached although a text line after a
+B<a>, B<c> or B<i> command indicated another line.
+
+=item unknown command `%s'
+
+=item unterminated `['
+
+A BRE contains an unterminated bracket expression.
+
+=item unterminated `\('
+
+A BRE contains an unterminated backreference.
+
+=item `\{' without closing `\}'
+
+A BRE contains an unterminated bounds specification.
+
+=item `\)' without preceding `\('
+
+=item `y' command requires argument
+
+=back
+
+=head1 EXAMPLE
+
+The basic material for the preceding section was generated by running
+the sed script
+
+ #no autoprint
+ s/^.*Warn( *"\([^"]*\)".*$/\1/
+ t process
+ b
+ :process
+ s/$!/%s/g
+ s/$[_[:alnum:]]\{1,\}/%s/g
+ s/\\\\/\\/g
+ s/^/=item /
+ p
+
+on the program's own text, and piping the output into C<sort -u>.
+
+
+=head1 SED SCRIPT TRANSLATION
+
+If this program is invoked with the name F<s2p> it will act as a
+sed-to-Perl translator. After option processing (all other
+arguments are ignored), a Perl program is printed on standard
+output, which will process the input stream (as read from all
+arguments) in the way defined by the sed script and the option setting
+used for the translation.
+
+=head1 SEE ALSO
+
+perl(1), re_format(7)
+
+=head1 BUGS
+
+The B<l> command will show escape characters (ESC) as `C<\e>', but
+a vertical tab (VT) in octal.
+
+Trailing spaces are truncated from labels in B<:>, B<t> and B<b> commands.
+
+The meaning of an empty regular expression (`C<//>'), as defined by B<sed>,
+is "the last pattern used, at run time". This deviates from the Perl
+interpretation, which will re-use the "last last successfully executed
+regular expression". Since keeping track of pattern usage would create
+terribly cluttered code, and differences would only appear in obscure
+context (where other B<sed> implementations appear to deviate, too),
+the Perl semantics was adopted. Note that common usage of this feature,
+such as in C</abc/s//xyz/>, will work as expected.
+
+Collating elements (of bracket expressions in BREs) are not implemented.
+
+=head1 STANDARDS
+
+This B<sed> implementation conforms to the IEEE Std1003.2-1992 ("POSIX.2")
+definition of B<sed>, and is compatible with the I<OpenBSD>
+implementation, except where otherwise noted (see L<"BUGS">).
+
+=head1 AUTHOR
+
+This Perl implementation of I<sed> was written by Wolfgang Laun,
+I<Wolfgang.Laun@alcatel.at>.
+
+=head1 COPYRIGHT and LICENSE
+
+This program is free and open software. You may use, modify,
+distribute, and sell this program (and any modified variants) in any
+way you wish, provided you do not restrict others from doing the same.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pstruct.bat b/Master/tlpkg/tlperl/bin/pstruct.bat new file mode 100755 index 00000000000..84937d17f3c --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pstruct.bat @@ -0,0 +1,1383 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+#
+#
+# c2ph (aka pstruct)
+# Tom Christiansen, <tchrist@convex.com>
+#
+# As pstruct, dump C structures as generated from 'cc -g -S' stabs.
+# As c2ph, do this PLUS generate perl code for getting at the structures.
+#
+# See the usage message for more. If this isn't enough, read the code.
+#
+
+=head1 NAME
+
+c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
+
+=head1 SYNOPSIS
+
+ c2ph [-dpnP] [var=val] [files ...]
+
+=head2 OPTIONS
+
+ Options:
+
+ -w wide; short for: type_width=45 member_width=35 offset_width=8
+ -x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+ -n do not generate perl code (default when invoked as pstruct)
+ -p generate perl code (default when invoked as c2ph)
+ -v generate perl code, with C decls as comments
+
+ -i do NOT recompute sizes for intrinsic datatypes
+ -a dump information on intrinsics also
+
+ -t trace execution
+ -d spew reams of debugging output
+
+ -slist give comma-separated list a structures to dump
+
+=head1 DESCRIPTION
+
+The following is the old c2ph.doc documentation by Tom Christiansen
+<tchrist@perl.com>
+Date: 25 Jul 91 08:10:21 GMT
+
+Once upon a time, I wrote a program called pstruct. It was a perl
+program that tried to parse out C structures and display their member
+offsets for you. This was especially useful for people looking at
+binary dumps or poking around the kernel.
+
+Pstruct was not a pretty program. Neither was it particularly robust.
+The problem, you see, was that the C compiler was much better at parsing
+C than I could ever hope to be.
+
+So I got smart: I decided to be lazy and let the C compiler parse the C,
+which would spit out debugger stabs for me to read. These were much
+easier to parse. It's still not a pretty program, but at least it's more
+robust.
+
+Pstruct takes any .c or .h files, or preferably .s ones, since that's
+the format it is going to massage them into anyway, and spits out
+listings like this:
+
+ struct tty {
+ int tty.t_locker 000 4
+ int tty.t_mutex_index 004 4
+ struct tty * tty.t_tp_virt 008 4
+ struct clist tty.t_rawq 00c 20
+ int tty.t_rawq.c_cc 00c 4
+ int tty.t_rawq.c_cmax 010 4
+ int tty.t_rawq.c_cfx 014 4
+ int tty.t_rawq.c_clx 018 4
+ struct tty * tty.t_rawq.c_tp_cpu 01c 4
+ struct tty * tty.t_rawq.c_tp_iop 020 4
+ unsigned char * tty.t_rawq.c_buf_cpu 024 4
+ unsigned char * tty.t_rawq.c_buf_iop 028 4
+ struct clist tty.t_canq 02c 20
+ int tty.t_canq.c_cc 02c 4
+ int tty.t_canq.c_cmax 030 4
+ int tty.t_canq.c_cfx 034 4
+ int tty.t_canq.c_clx 038 4
+ struct tty * tty.t_canq.c_tp_cpu 03c 4
+ struct tty * tty.t_canq.c_tp_iop 040 4
+ unsigned char * tty.t_canq.c_buf_cpu 044 4
+ unsigned char * tty.t_canq.c_buf_iop 048 4
+ struct clist tty.t_outq 04c 20
+ int tty.t_outq.c_cc 04c 4
+ int tty.t_outq.c_cmax 050 4
+ int tty.t_outq.c_cfx 054 4
+ int tty.t_outq.c_clx 058 4
+ struct tty * tty.t_outq.c_tp_cpu 05c 4
+ struct tty * tty.t_outq.c_tp_iop 060 4
+ unsigned char * tty.t_outq.c_buf_cpu 064 4
+ unsigned char * tty.t_outq.c_buf_iop 068 4
+ (*int)() tty.t_oproc_cpu 06c 4
+ (*int)() tty.t_oproc_iop 070 4
+ (*int)() tty.t_stopproc_cpu 074 4
+ (*int)() tty.t_stopproc_iop 078 4
+ struct thread * tty.t_rsel 07c 4
+
+etc.
+
+
+Actually, this was generated by a particular set of options. You can control
+the formatting of each column, whether you prefer wide or fat, hex or decimal,
+leading zeroes or whatever.
+
+All you need to be able to use this is a C compiler than generates
+BSD/GCC-style stabs. The B<-g> option on native BSD compilers and GCC
+should get this for you.
+
+To learn more, just type a bogus option, like B<-\?>, and a long usage message
+will be provided. There are a fair number of possibilities.
+
+If you're only a C programmer, than this is the end of the message for you.
+You can quit right now, and if you care to, save off the source and run it
+when you feel like it. Or not.
+
+
+
+But if you're a perl programmer, then for you I have something much more
+wondrous than just a structure offset printer.
+
+You see, if you call pstruct by its other incybernation, c2ph, you have a code
+generator that translates C code into perl code! Well, structure and union
+declarations at least, but that's quite a bit.
+
+Prior to this point, anyone programming in perl who wanted to interact
+with C programs, like the kernel, was forced to guess the layouts of
+the C structures, and then hardwire these into his program. Of course,
+when you took your wonderfully crafted program to a system where the
+sgtty structure was laid out differently, your program broke. Which is
+a shame.
+
+We've had Larry's h2ph translator, which helped, but that only works on
+cpp symbols, not real C, which was also very much needed. What I offer
+you is a symbolic way of getting at all the C structures. I've couched
+them in terms of packages and functions. Consider the following program:
+
+ #!/usr/local/bin/perl
+
+ require 'syscall.ph';
+ require 'sys/time.ph';
+ require 'sys/resource.ph';
+
+ $ru = "\0" x &rusage'sizeof();
+
+ syscall(&SYS_getrusage, &RUSAGE_SELF, $ru) && die "getrusage: $!";
+
+ @ru = unpack($t = &rusage'typedef(), $ru);
+
+ $utime = $ru[ &rusage'ru_utime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_utime + &timeval'tv_usec ]) / 1e6;
+
+ $stime = $ru[ &rusage'ru_stime + &timeval'tv_sec ]
+ + ($ru[ &rusage'ru_stime + &timeval'tv_usec ]) / 1e6;
+
+ printf "you have used %8.3fs+%8.3fu seconds.\n", $utime, $stime;
+
+
+As you see, the name of the package is the name of the structure. Regular
+fields are just their own names. Plus the following accessor functions are
+provided for your convenience:
+
+ struct This takes no arguments, and is merely the number of first-level
+ elements in the structure. You would use this for indexing
+ into arrays of structures, perhaps like this
+
+
+ $usec = $u[ &user'u_utimer
+ + (&ITIMER_VIRTUAL * &itimerval'struct)
+ + &itimerval'it_value
+ + &timeval'tv_usec
+ ];
+
+ sizeof Returns the bytes in the structure, or the member if
+ you pass it an argument, such as
+
+ &rusage'sizeof(&rusage'ru_utime)
+
+ typedef This is the perl format definition for passing to pack and
+ unpack. If you ask for the typedef of a nothing, you get
+ the whole structure, otherwise you get that of the member
+ you ask for. Padding is taken care of, as is the magic to
+ guarantee that a union is unpacked into all its aliases.
+ Bitfields are not quite yet supported however.
+
+ offsetof This function is the byte offset into the array of that
+ member. You may wish to use this for indexing directly
+ into the packed structure with vec() if you're too lazy
+ to unpack it.
+
+ typeof Not to be confused with the typedef accessor function, this
+ one returns the C type of that field. This would allow
+ you to print out a nice structured pretty print of some
+ structure without knoning anything about it beforehand.
+ No args to this one is a noop. Someday I'll post such
+ a thing to dump out your u structure for you.
+
+
+The way I see this being used is like basically this:
+
+ % h2ph <some_include_file.h > /usr/lib/perl/tmp.ph
+ % c2ph some_include_file.h >> /usr/lib/perl/tmp.ph
+ % install
+
+It's a little tricker with c2ph because you have to get the includes right.
+I can't know this for your system, but it's not usually too terribly difficult.
+
+The code isn't pretty as I mentioned -- I never thought it would be a 1000-
+line program when I started, or I might not have begun. :-) But I would have
+been less cavalier in how the parts of the program communicated with each
+other, etc. It might also have helped if I didn't have to divine the makeup
+of the stabs on the fly, and then account for micro differences between my
+compiler and gcc.
+
+Anyway, here it is. Should run on perl v4 or greater. Maybe less.
+
+
+ --tom
+
+=cut
+
+$RCSID = '$Id: c2ph,v 1.7 95/10/28 10:41:47 tchrist Exp Locker: tchrist $';
+
+use File::Temp;
+
+######################################################################
+
+# some handy data definitions. many of these can be reset later.
+
+$bitorder = 'b'; # ascending; set to B for descending bit fields
+
+%intrinsics =
+%template = (
+ 'char', 'c',
+ 'unsigned char', 'C',
+ 'short', 's',
+ 'short int', 's',
+ 'unsigned short', 'S',
+ 'unsigned short int', 'S',
+ 'short unsigned int', 'S',
+ 'int', 'i',
+ 'unsigned int', 'I',
+ 'long', 'l',
+ 'long int', 'l',
+ 'unsigned long', 'L',
+ 'unsigned long', 'L',
+ 'long unsigned int', 'L',
+ 'unsigned long int', 'L',
+ 'long long', 'q',
+ 'long long int', 'q',
+ 'unsigned long long', 'Q',
+ 'unsigned long long int', 'Q',
+ 'float', 'f',
+ 'double', 'd',
+ 'pointer', 'p',
+ 'null', 'x',
+ 'neganull', 'X',
+ 'bit', $bitorder,
+);
+
+&buildscrunchlist;
+delete $intrinsics{'neganull'};
+delete $intrinsics{'bit'};
+delete $intrinsics{'null'};
+
+# use -s to recompute sizes
+%sizeof = (
+ 'char', '1',
+ 'unsigned char', '1',
+ 'short', '2',
+ 'short int', '2',
+ 'unsigned short', '2',
+ 'unsigned short int', '2',
+ 'short unsigned int', '2',
+ 'int', '4',
+ 'unsigned int', '4',
+ 'long', '4',
+ 'long int', '4',
+ 'unsigned long', '4',
+ 'unsigned long int', '4',
+ 'long unsigned int', '4',
+ 'long long', '8',
+ 'long long int', '8',
+ 'unsigned long long', '8',
+ 'unsigned long long int', '8',
+ 'float', '4',
+ 'double', '8',
+ 'pointer', '4',
+);
+
+($type_width, $member_width, $offset_width, $size_width) = (20, 20, 6, 5);
+
+($offset_fmt, $size_fmt) = ('d', 'd');
+
+$indent = 2;
+
+$CC = 'cc';
+$CFLAGS = '-gstabs -S';
+$DEFINES = '';
+
+$perl++ if $0 =~ m#/?c2ph$#;
+
+require 'getopts.pl';
+
+use File::Temp 'tempdir';
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+&Getopts('aixdpvtnws:') || &usage(0);
+
+$opt_d && $debug++;
+$opt_t && $trace++;
+$opt_p && $perl++;
+$opt_v && $verbose++;
+$opt_n && ($perl = 0);
+
+if ($opt_w) {
+ ($type_width, $member_width, $offset_width) = (45, 35, 8);
+}
+if ($opt_x) {
+ ($offset_fmt, $offset_width, $size_fmt, $size_width) = ( 'x', '08', 'x', 04 );
+}
+
+eval '$'.$1.'$2;' while $ARGV[0] =~ /^([A-Za-z_]+=)(.*)/ && shift;
+
+sub PLUMBER {
+ select(STDERR);
+ print "oops, apperent pager foulup\n";
+ $isatty++;
+ &usage(1);
+}
+
+sub usage {
+ local($oops) = @_;
+ unless (-t STDOUT) {
+ select(STDERR);
+ } elsif (!$oops) {
+ $isatty++;
+ $| = 1;
+ print "hit <RETURN> for further explanation: ";
+ <STDIN>;
+ open (PIPE, "|". ($ENV{PAGER} || 'more'));
+ $SIG{PIPE} = PLUMBER;
+ select(PIPE);
+ }
+
+ print "usage: $0 [-dpnP] [var=val] [files ...]\n";
+
+ exit unless $isatty;
+
+ print <<EOF;
+
+Options:
+
+-w wide; short for: type_width=45 member_width=35 offset_width=8
+-x hex; short for: offset_fmt=x offset_width=08 size_fmt=x size_width=04
+
+-n do not generate perl code (default when invoked as pstruct)
+-p generate perl code (default when invoked as c2ph)
+-v generate perl code, with C decls as comments
+
+-i do NOT recompute sizes for intrinsic datatypes
+-a dump information on intrinsics also
+
+-t trace execution
+-d spew reams of debugging output
+
+-slist give comma-separated list a structures to dump
+
+
+Var Name Default Value Meaning
+
+EOF
+
+ &defvar('CC', 'which_compiler to call');
+ &defvar('CFLAGS', 'how to generate *.s files with stabs');
+ &defvar('DEFINES','any extra cflags or cpp defines, like -I, -D, -U');
+
+ print "\n";
+
+ &defvar('type_width', 'width of type field (column 1)');
+ &defvar('member_width', 'width of member field (column 2)');
+ &defvar('offset_width', 'width of offset field (column 3)');
+ &defvar('size_width', 'width of size field (column 4)');
+
+ print "\n";
+
+ &defvar('offset_fmt', 'sprintf format type for offset');
+ &defvar('size_fmt', 'sprintf format type for size');
+
+ print "\n";
+
+ &defvar('indent', 'how far to indent each nesting level');
+
+ print <<'EOF';
+
+ If any *.[ch] files are given, these will be catted together into
+ a temporary *.c file and sent through:
+ $CC $CFLAGS $DEFINES
+ and the resulting *.s groped for stab information. If no files are
+ supplied, then stdin is read directly with the assumption that it
+ contains stab information. All other lines will be ignored. At
+ most one *.s file should be supplied.
+
+EOF
+ close PIPE;
+ exit 1;
+}
+
+sub defvar {
+ local($var, $msg) = @_;
+ printf "%-16s%-15s %s\n", $var, eval "\$$var", $msg;
+}
+
+sub safedir {
+ $SAFEDIR = File::Temp::tempdir("c2ph.XXXXXX", TMPDIR => 1, CLEANUP => 1)
+ unless (defined($SAFEDIR));
+}
+
+undef $SAFEDIR;
+
+$recurse = 1;
+
+if (@ARGV) {
+ if (grep(!/\.[csh]$/,@ARGV)) {
+ warn "Only *.[csh] files expected!\n";
+ &usage;
+ }
+ elsif (grep(/\.s$/,@ARGV)) {
+ if (@ARGV > 1) {
+ warn "Only one *.s file allowed!\n";
+ &usage;
+ }
+ }
+ elsif (@ARGV == 1 && $ARGV[0] =~ /\.c$/) {
+ local($dir, $file) = $ARGV[0] =~ m#(.*/)?(.*)$#;
+ $chdir = "cd $dir && " if $dir;
+ &system("$chdir$CC $CFLAGS $DEFINES $file") && exit 1;
+ $ARGV[0] =~ s/\.c$/.s/;
+ }
+ else {
+ &safedir;
+ $TMP = "$SAFEDIR/c2ph.$$.c";
+ &system("cat @ARGV > $TMP") && exit 1;
+ &system("cd $SAFEDIR && $CC $CFLAGS $DEFINES $TMP") && exit 1;
+ unlink $TMP;
+ $TMP =~ s/\.c$/.s/;
+ @ARGV = ($TMP);
+ }
+}
+
+if ($opt_s) {
+ for (split(/[\s,]+/, $opt_s)) {
+ $interested{$_}++;
+ }
+}
+
+
+$| = 1 if $debug;
+
+main: {
+
+ if ($trace) {
+ if (-t && !@ARGV) {
+ print STDERR "reading from your keyboard: ";
+ } else {
+ print STDERR "reading from " . (@ARGV ? "@ARGV" : "<STDIN>").": ";
+ }
+ }
+
+STAB: while (<>) {
+ if ($trace && !($. % 10)) {
+ $lineno = $..'';
+ print STDERR $lineno, "\b" x length($lineno);
+ }
+ next unless /^\s*\.stabs\s+/;
+ $line = $_;
+ s/^\s*\.stabs\s+//;
+ if (s/\\\\"[d,]+$//) {
+ $saveline .= $line;
+ $savebar = $_;
+ next STAB;
+ }
+ if ($saveline) {
+ s/^"//;
+ $_ = $savebar . $_;
+ $line = $saveline;
+ }
+ &stab;
+ $savebar = $saveline = undef;
+ }
+ print STDERR "$.\n" if $trace;
+ unlink $TMP if $TMP;
+
+ &compute_intrinsics if $perl && !$opt_i;
+
+ print STDERR "resolving types\n" if $trace;
+
+ &resolve_types;
+ &adjust_start_addrs;
+
+ $sum = 2 + $type_width + $member_width;
+ $pmask1 = "%-${type_width}s %-${member_width}s";
+ $pmask2 = "%-${sum}s %${offset_width}${offset_fmt}%s %${size_width}${size_fmt}%s";
+
+
+
+ if ($perl) {
+ # resolve template -- should be in stab define order, but even this isn't enough.
+ print STDERR "\nbuilding type templates: " if $trace;
+ for $i (reverse 0..$#type) {
+ next unless defined($name = $type[$i]);
+ next unless defined $struct{$name};
+ ($iname = $name) =~ s/\..*//;
+ $build_recursed = 0;
+ &build_template($name) unless defined $template{&psou($name)} ||
+ $opt_s && !$interested{$iname};
+ }
+ print STDERR "\n\n" if $trace;
+ }
+
+ print STDERR "dumping structs: " if $trace;
+
+ local($iam);
+
+
+
+ foreach $name (sort keys %struct) {
+ ($iname = $name) =~ s/\..*//;
+ next if $opt_s && !$interested{$iname};
+ print STDERR "$name " if $trace;
+
+ undef @sizeof;
+ undef @typedef;
+ undef @offsetof;
+ undef @indices;
+ undef @typeof;
+ undef @fieldnames;
+
+ $mname = &munge($name);
+
+ $fname = &psou($name);
+
+ print "# " if $perl && $verbose;
+ $pcode = '';
+ print "$fname {\n" if !$perl || $verbose;
+ $template{$fname} = &scrunch($template{$fname}) if $perl;
+ &pstruct($name,$name,0);
+ print "# " if $perl && $verbose;
+ print "}\n" if !$perl || $verbose;
+ print "\n" if $perl && $verbose;
+
+ if ($perl) {
+ print "$pcode";
+
+ printf("\nsub %-32s { %4d; }\n\n", "${mname}'struct", $countof{$name});
+
+ print <<EOF;
+sub ${mname}'typedef {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'typedef[\$${mname}'index]
+ : \$${mname}'typedef;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'sizeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}'index
+ ? \$${mname}'sizeof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'offsetof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'offsetof[\$${mname}'index]
+ : \$${mname}'sizeof;
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'typeof {
+ local(\$${mname}'index) = shift;
+ defined \$${mname}index
+ ? \$${mname}'typeof[\$${mname}'index]
+ : '$name';
+}
+EOF
+
+ print <<EOF;
+sub ${mname}'fieldnames {
+ \@${mname}'fieldnames;
+}
+EOF
+
+ $iam = ($isastruct{$name} && 's') || ($isaunion{$name} && 'u');
+
+ print <<EOF;
+sub ${mname}'isastruct {
+ '$iam';
+}
+EOF
+
+ print "\$${mname}'typedef = '" . &scrunch($template{$fname})
+ . "';\n";
+
+ print "\$${mname}'sizeof = $sizeof{$name};\n\n";
+
+
+ print "\@${mname}'indices = (", &squishseq(@indices), ");\n";
+
+ print "\n";
+
+ print "\@${mname}'typedef[\@${mname}'indices] = (",
+ join("\n\t", '', @typedef), "\n );\n\n";
+ print "\@${mname}'sizeof[\@${mname}'indices] = (",
+ join("\n\t", '', @sizeof), "\n );\n\n";
+ print "\@${mname}'offsetof[\@${mname}'indices] = (",
+ join("\n\t", '', @offsetof), "\n );\n\n";
+ print "\@${mname}'typeof[\@${mname}'indices] = (",
+ join("\n\t", '', @typeof), "\n );\n\n";
+ print "\@${mname}'fieldnames[\@${mname}'indices] = (",
+ join("\n\t", '', @fieldnames), "\n );\n\n";
+
+ $template_printed{$fname}++;
+ $size_printed{$fname}++;
+ }
+ print "\n";
+ }
+
+ print STDERR "\n" if $trace;
+
+ unless ($perl && $opt_a) {
+ print "\n1;\n" if $perl;
+ exit;
+ }
+
+
+
+ foreach $name (sort bysizevalue keys %intrinsics) {
+ next if $size_printed{$name};
+ print '$',&munge($name),"'sizeof = ", $sizeof{$name}, ";\n";
+ }
+
+ print "\n";
+
+ sub bysizevalue { $sizeof{$a} <=> $sizeof{$b}; }
+
+
+ foreach $name (sort keys %intrinsics) {
+ print '$',&munge($name),"'typedef = '", $template{$name}, "';\n";
+ }
+
+ print "\n1;\n" if $perl;
+
+ exit;
+}
+
+########################################################################################
+
+
+sub stab {
+ next unless $continued || /:[\$\w]+(\(\d+,\d+\))?=[\*\$\w]+/; # (\d+,\d+) is for sun
+ s/"// || next;
+ s/",([x\d]+),([x\d]+),([x\d]+),.*// || next;
+
+ next if /^\s*$/;
+
+ $size = $3 if $3;
+ $_ = $continued . $_ if length($continued);
+ if (s/\\\\$//) {
+ # if last 2 chars of string are '\\' then stab is continued
+ # in next stab entry
+ chop;
+ $continued = $_;
+ next;
+ }
+ $continued = '';
+
+
+ $line = $_;
+
+ if (($name, $pdecl) = /^([\$ \w]+):[tT]((\d+)(=[rufs*](\d+))+)$/) {
+ print "$name is a typedef for some funky pointers: $pdecl\n" if $debug;
+ &pdecl($pdecl);
+ next;
+ }
+
+
+
+ if (/(([ \w]+):t(\d+|\(\d+,\d+\)))=r?(\d+|\(\d+,\d+\))(;\d+;\d+;)?/) {
+ local($ident) = $2;
+ push(@intrinsics, $ident);
+ $typeno = &typeno($3);
+ $type[$typeno] = $ident;
+ print STDERR "intrinsic $ident in new type $typeno\n" if $debug;
+ next;
+ }
+
+ if (($name, $typeordef, $typeno, $extra, $struct, $_)
+ = /^([\$ \w]+):([ustT])(\d+|\(\d+,\d+\))(=[rufs*](\d+))?(.*)$/)
+ {
+ $typeno = &typeno($typeno); # sun foolery
+ }
+ elsif (/^[\$\w]+:/) {
+ next; # variable
+ }
+ else {
+ warn "can't grok stab: <$_> in: $line " if $_;
+ next;
+ }
+
+ #warn "got size $size for $name\n";
+ $sizeof{$name} = $size if $size;
+
+ s/;[-\d]*;[-\d]*;$//; # we don't care about ranges
+
+ $typenos{$name} = $typeno;
+
+ unless (defined $type[$typeno]) {
+ &panic("type 0??") unless $typeno;
+ $type[$typeno] = $name unless defined $type[$typeno];
+ printf "new type $typeno is $name" if $debug;
+ if ($extra =~ /\*/ && defined $type[$struct]) {
+ print ", a typedef for a pointer to " , $type[$struct] if $debug;
+ }
+ } else {
+ printf "%s is type %d", $name, $typeno if $debug;
+ print ", a typedef for " , $type[$typeno] if $debug;
+ }
+ print "\n" if $debug;
+ #next unless $extra =~ /[su*]/;
+
+ #$type[$struct] = $name;
+
+ if ($extra =~ /[us*]/) {
+ &sou($name, $extra);
+ $_ = &sdecl($name, $_, 0);
+ }
+ elsif (/^=ar/) {
+ print "it's a bare array typedef -- that's pretty sick\n" if $debug;
+ $_ = "$typeno$_";
+ $scripts = '';
+ $_ = &adecl($_,1);
+
+ }
+ elsif (s/((\w+):t(\d+|\(\d+,\d+\)))?=r?(;\d+;\d+;)?//) { # the ?'s are for gcc
+ push(@intrinsics, $2);
+ $typeno = &typeno($3);
+ $type[$typeno] = $2;
+ print STDERR "intrinsic $2 in new type $typeno\n" if $debug;
+ }
+ elsif (s/^=e//) { # blessed be thy compiler; mine won't do this
+ &edecl;
+ }
+ else {
+ warn "Funny remainder for $name on line $_ left in $line " if $_;
+ }
+}
+
+sub typeno { # sun thinks types are (0,27) instead of just 27
+ local($_) = @_;
+ s/\(\d+,(\d+)\)/$1/;
+ $_;
+}
+
+sub pstruct {
+ local($what,$prefix,$base) = @_;
+ local($field, $fieldname, $typeno, $count, $offset, $entry);
+ local($fieldtype);
+ local($type, $tname);
+ local($mytype, $mycount, $entry2);
+ local($struct_count) = 0;
+ local($pad, $revpad, $length, $prepad, $lastoffset, $lastlength, $fmt);
+ local($bits,$bytes);
+ local($template);
+
+
+ local($mname) = &munge($name);
+
+ sub munge {
+ local($_) = @_;
+ s/[\s\$\.]/_/g;
+ $_;
+ }
+
+ local($sname) = &psou($what);
+
+ $nesting++;
+
+ for $field (split(/;/, $struct{$what})) {
+ $pad = $prepad = 0;
+ $entry = '';
+ ($fieldname, $typeno, $count, $offset, $length) = split(/,/, $field);
+
+ $type = $type[$typeno];
+
+ $type =~ /([^[]*)(\[.*\])?/;
+ $mytype = $1;
+ $count .= $2;
+ $fieldtype = &psou($mytype);
+
+ local($fname) = &psou($name);
+
+ if ($build_templates) {
+
+ $pad = ($offset - ($lastoffset + $lastlength))/8
+ if defined $lastoffset;
+
+ if (! $finished_template{$sname}) {
+ if ($isaunion{$what}) {
+ $template{$sname} .= 'X' x $revpad . ' ' if $revpad;
+ } else {
+ $template{$sname} .= 'x' x $pad . ' ' if $pad;
+ }
+ }
+
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+
+ if (! $finished_template{$sname}) {
+ $template{$sname} .= $template;
+ }
+
+ $revpad = $length/8 if $isaunion{$what};
+
+ ($lastoffset, $lastlength) = ($offset, $length);
+
+ } else {
+ print '# ' if $perl && $verbose;
+ $entry = sprintf($pmask1,
+ ' ' x ($nesting * $indent) . $fieldtype,
+ "$prefix.$fieldname" . $count);
+
+ $entry =~ s/(\*+)( )/$2$1/;
+
+ printf $pmask2,
+ $entry,
+ ($base+$offset)/8,
+ ($bits = ($base+$offset)%8) ? ".$bits" : " ",
+ $length/8,
+ ($bits = $length % 8) ? ".$bits": ""
+ if !$perl || $verbose;
+
+ if ($perl) {
+ $template = &fetch_template($type);
+ &repeat_template($template,$count);
+ }
+
+ if ($perl && $nesting == 1) {
+
+ push(@sizeof, int($length/8) .",\t# $fieldname");
+ push(@offsetof, int($offset/8) .",\t# $fieldname");
+ local($little) = &scrunch($template);
+ push(@typedef, "'$little', \t# $fieldname");
+ $type =~ s/(struct|union) //;
+ push(@typeof, "'$mytype" . ($count ? $count : '') .
+ "',\t# $fieldname");
+ push(@fieldnames, "'$fieldname',");
+ }
+
+ print ' ', ' ' x $indent x $nesting, $template
+ if $perl && $verbose;
+
+ print "\n" if !$perl || $verbose;
+
+ }
+ if ($perl) {
+ local($mycount) = defined $struct{$mytype} ? $countof{$mytype} : 1;
+ $mycount *= &scripts2count($count) if $count;
+ if ($nesting==1 && !$build_templates) {
+ $pcode .= sprintf("sub %-32s { %4d; }\n",
+ "${mname}'${fieldname}", $struct_count);
+ push(@indices, $struct_count);
+ }
+ $struct_count += $mycount;
+ }
+
+
+ &pstruct($type, "$prefix.$fieldname", $base+$offset)
+ if $recurse && defined $struct{$type};
+ }
+
+ $countof{$what} = $struct_count unless defined $countof{$whati};
+
+ $template{$sname} .= '$' if $build_templates;
+ $finished_template{$sname}++;
+
+ if ($build_templates && !defined $sizeof{$name}) {
+ local($fmt) = &scrunch($template{$sname});
+ print STDERR "no size for $name, punting with $fmt..." if $debug;
+ eval '$sizeof{$name} = length(pack($fmt, ()))';
+ if ($@) {
+ chop $@;
+ warn "couldn't get size for \$name: $@";
+ } else {
+ print STDERR $sizeof{$name}, "\n" if $debUg;
+ }
+ }
+
+ --$nesting;
+}
+
+
+sub psize {
+ local($me) = @_;
+ local($amstruct) = $struct{$me} ? 'struct ' : '';
+
+ print '$sizeof{\'', $amstruct, $me, '\'} = ';
+ printf "%d;\n", $sizeof{$me};
+}
+
+sub pdecl {
+ local($pdecl) = @_;
+ local(@pdecls);
+ local($tname);
+
+ warn "pdecl: $pdecl\n" if $debug;
+
+ $pdecl =~ s/\(\d+,(\d+)\)/$1/g;
+ $pdecl =~ s/\*//g;
+ @pdecls = split(/=/, $pdecl);
+ $typeno = $pdecls[0];
+ $tname = pop @pdecls;
+
+ if ($tname =~ s/^f//) { $tname = "$tname&"; }
+ #else { $tname = "$tname*"; }
+
+ for (reverse @pdecls) {
+ $tname .= s/^f// ? "&" : "*";
+ #$tname =~ s/^f(.*)/$1&/;
+ print "type[$_] is $tname\n" if $debug;
+ $type[$_] = $tname unless defined $type[$_];
+ }
+}
+
+
+
+sub adecl {
+ ($arraytype, $unknown, $lower, $upper) = ();
+ #local($typeno);
+ # global $typeno, @type
+ local($_, $typedef) = @_;
+
+ while (s/^((\d+|\(\d+,\d+\))=)?ar(\d+|\(\d+,\d+\));//) {
+ ($arraytype, $unknown) = ($2, $3);
+ $arraytype = &typeno($arraytype);
+ $unknown = &typeno($unknown);
+ if (s/^(\d+);(\d+);//) {
+ ($lower, $upper) = ($1, $2);
+ $scripts .= '[' . ($upper+1) . ']';
+ } else {
+ warn "can't find array bounds: $_";
+ }
+ }
+ if (s/^([(,)\d*f=]*),(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ $whatis = $1;
+ if ($whatis =~ /^(\d+|\(\d+,\d+\))=/) {
+ $typeno = &typeno($1);
+ &pdecl($whatis);
+ } else {
+ $typeno = &typeno($whatis);
+ }
+ } elsif (s/^(\d+)(=[*suf]\d*)//) {
+ local($whatis) = $2;
+
+ if ($whatis =~ /[f*]/) {
+ &pdecl($whatis);
+ } elsif ($whatis =~ /[su]/) { #
+ print "$prefix.$fieldname is an array$scripts anon structs; disgusting\n"
+ if $debug;
+ #$type[$typeno] = $name unless defined $type[$typeno];
+ ##printf "new type $typeno is $name" if $debug;
+ $typeno = $1;
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = $type[$typeno];
+ &sou($name, $whatis);
+ $_ = &sdecl($name, $_, $start+$offset);
+ 1;
+ $start = $start{$name};
+ $offset = $sizeof{$name};
+ $length = $offset;
+ } else {
+ warn "what's this? $whatis in $line ";
+ }
+ } elsif (/^\d+$/) {
+ $typeno = $_;
+ } else {
+ warn "bad array stab: $_ in $line ";
+ next STAB;
+ }
+ #local($wasdef) = defined($type[$typeno]) && $debug;
+ #if ($typedef) {
+ #print "redefining $type[$typeno] to " if $wasdef;
+ #$type[$typeno] = "$whatis$scripts"; # unless defined $type[$typeno];
+ #print "$type[$typeno]\n" if $wasdef;
+ #} else {
+ #$type[$arraytype] = $type[$typeno] unless defined $type[$arraytype];
+ #}
+ $type[$arraytype] = "$type[$typeno]$scripts" if defined $type[$typeno];
+ print "type[$arraytype] is $type[$arraytype]\n" if $debug;
+ print "$prefix.$fieldname is an array of $type[$arraytype]\n" if $debug;
+ $_;
+}
+
+
+
+sub sdecl {
+ local($prefix, $_, $offset) = @_;
+
+ local($fieldname, $scripts, $type, $arraytype, $unknown,
+ $whatis, $pdecl, $upper,$lower, $start,$length) = ();
+ local($typeno,$sou);
+
+
+SFIELD:
+ while (/^([^;]+);/) {
+ $scripts = '';
+ warn "sdecl $_\n" if $debug;
+ if (s/^([\$\w]+)://) {
+ $fieldname = $1;
+ } elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { #
+ $typeno = &typeno($1);
+ $type[$typeno] = "$prefix.$fieldname";
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$2);
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $offset += $sizeof{$name};
+ #print "done with anon, start is $start, offset is $offset\n";
+ #next SFIELD;
+ } else {
+ warn "weird field $_ of $line" if $debug;
+ next STAB;
+ #$fieldname = &gensym;
+ #$_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ }
+
+ if (/^(\d+|\(\d+,\d+\))=ar/) {
+ $_ = &adecl($_);
+ }
+ elsif (s/^(\d+|\(\d+,\d+\))?,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^(\d+)=xs\w+:,(\d+),(\d+);//) {
+ ($start, $length) = ($2, $3);
+ &panic("no length?") unless $length;
+ $typeno = &typeno($1) if $1;
+ }
+ elsif (s/^((\d+|\(\d+,\d+\))(=[*f](\d+|\(\d+,\d+\)))+),(\d+),(\d+);//) {
+ ($pdecl, $start, $length) = ($1,$5,$6);
+ &pdecl($pdecl);
+ }
+ elsif (s/(\d+)=([us])(\d+|\(\d+,\d+\))//) { # the dratted anon struct
+ ($typeno, $sou) = ($1, $2);
+ $typeno = &typeno($typeno);
+ if (defined($type[$typeno])) {
+ warn "now how did we get type $1 in $fieldname of $line?";
+ } else {
+ print "anon type $typeno is $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname" unless defined $type[$typeno];
+ };
+ local($name) = "$prefix.$fieldname";
+ &sou($name,$sou);
+ print "anon ".($isastruct{$name}) ? "struct":"union"." for $prefix.$fieldname\n" if $debug;
+ $type[$typeno] = "$prefix.$fieldname";
+ $_ = &sdecl("$prefix.$fieldname", $_, $start+$offset);
+ $start = $start{$name};
+ $length = $sizeof{$name};
+ }
+ else {
+ warn "can't grok stab for $name ($_) in line $line ";
+ next STAB;
+ }
+
+ &panic("no length for $prefix.$fieldname") unless $length;
+ $struct{$name} .= join(',', $fieldname, $typeno, $scripts, $start, $length) . ';';
+ }
+ if (s/;\d*,(\d+),(\d+);//) {
+ local($start, $size) = ($1, $2);
+ $sizeof{$prefix} = $size;
+ print "start of $prefix is $start, size of $sizeof{$prefix}\n" if $debug;
+ $start{$prefix} = $start;
+ }
+ $_;
+}
+
+sub edecl {
+ s/;$//;
+ $enum{$name} = $_;
+ $_ = '';
+}
+
+sub resolve_types {
+ local($sou);
+ for $i (0 .. $#type) {
+ next unless defined $type[$i];
+ $_ = $type[$i];
+ unless (/\d/) {
+ print "type[$i] $type[$i]\n" if $debug;
+ next;
+ }
+ print "type[$i] $_ ==> " if $debug;
+ s/^(\d+)(\**)\&\*(\**)/"$2($3".&type($1) . ')()'/e;
+ s/^(\d+)\&/&type($1)/e;
+ s/^(\d+)/&type($1)/e;
+ s/(\*+)([^*]+)(\*+)/$1$3$2/;
+ s/\((\*+)(\w+)(\*+)\)/$3($1$2)/;
+ s/^(\d+)([\*\[].*)/&type($1).$2/e;
+ #s/(\d+)(\*|(\[[\[\]\d\*]+]\])+)/&type($1).$2/ge;
+ $type[$i] = $_;
+ print "$_\n" if $debug;
+ }
+}
+sub type { &psou($type[$_[0]] || "<UNDEFINED>"); }
+
+sub adjust_start_addrs {
+ for (sort keys %start) {
+ ($basename = $_) =~ s/\.[^.]+$//;
+ $start{$_} += $start{$basename};
+ print "start: $_ @ $start{$_}\n" if $debug;
+ }
+}
+
+sub sou {
+ local($what, $_) = @_;
+ /u/ && $isaunion{$what}++;
+ /s/ && $isastruct{$what}++;
+}
+
+sub psou {
+ local($what) = @_;
+ local($prefix) = '';
+ if ($isaunion{$what}) {
+ $prefix = 'union ';
+ } elsif ($isastruct{$what}) {
+ $prefix = 'struct ';
+ }
+ $prefix . $what;
+}
+
+sub scrunch {
+ local($_) = @_;
+
+ return '' if $_ eq '';
+
+ study;
+
+ s/\$//g;
+ s/ / /g;
+ 1 while s/(\w) \1/$1$1/g;
+
+ # i wanna say this, but perl resists my efforts:
+ # s/(\w)(\1+)/$2 . length($1)/ge;
+
+ &quick_scrunch;
+
+ s/ $//;
+
+ $_;
+}
+
+sub buildscrunchlist {
+ $scrunch_code = "sub quick_scrunch {\n";
+ for (values %intrinsics) {
+ $scrunch_code .= "\ts/(${_}{2,})/'$_' . length(\$1)/ge;\n";
+ }
+ $scrunch_code .= "}\n";
+ print "$scrunch_code" if $debug;
+ eval $scrunch_code;
+ &panic("can't eval scrunch_code $@ \nscrunch_code") if $@;
+}
+
+sub fetch_template {
+ local($mytype) = @_;
+ local($fmt);
+ local($count) = 1;
+
+ &panic("why do you care?") unless $perl;
+
+ if ($mytype =~ s/(\[\d+\])+$//) {
+ $count .= $1;
+ }
+
+ if ($mytype =~ /\*/) {
+ $fmt = $template{'pointer'};
+ }
+ elsif (defined $template{$mytype}) {
+ $fmt = $template{$mytype};
+ }
+ elsif (defined $struct{$mytype}) {
+ if (!defined $template{&psou($mytype)}) {
+ &build_template($mytype) unless $mytype eq $name;
+ }
+ elsif ($template{&psou($mytype)} !~ /\$$/) {
+ #warn "incomplete template for $mytype\n";
+ }
+ $fmt = $template{&psou($mytype)} || '?';
+ }
+ else {
+ warn "unknown fmt for $mytype\n";
+ $fmt = '?';
+ }
+
+ $fmt x $count . ' ';
+}
+
+sub compute_intrinsics {
+ &safedir;
+ local($TMP) = "$SAFEDIR/c2ph-i.$$.c";
+ open (TMP, ">$TMP") || die "can't open $TMP: $!";
+ select(TMP);
+
+ print STDERR "computing intrinsic sizes: " if $trace;
+
+ undef %intrinsics;
+
+ print <<'EOF';
+main() {
+ char *mask = "%d %s\n";
+EOF
+
+ for $type (@intrinsics) {
+ next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
+ print <<"EOF";
+ printf(mask,sizeof($type), "$type");
+EOF
+ }
+
+ print <<'EOF';
+ printf(mask,sizeof(char *), "pointer");
+ exit(0);
+}
+EOF
+ close TMP;
+
+ select(STDOUT);
+ open(PIPE, "cd $SAFEDIR && $CC $TMP && $SAFEDIR/a.out|");
+ while (<PIPE>) {
+ chop;
+ split(' ',$_,2);;
+ print "intrinsic $_[1] is size $_[0]\n" if $debug;
+ $sizeof{$_[1]} = $_[0];
+ $intrinsics{$_[1]} = $template{$_[0]};
+ }
+ close(PIPE) || die "couldn't read intrinsics!";
+ unlink($TMP, "$SAFEDIR/a.out");
+ print STDERR "done\n" if $trace;
+}
+
+sub scripts2count {
+ local($_) = @_;
+
+ s/^\[//;
+ s/\]$//;
+ s/\]\[/*/g;
+ $_ = eval;
+ &panic("$_: $@") if $@;
+ $_;
+}
+
+sub system {
+ print STDERR "@_\n" if $trace;
+ system @_;
+}
+
+sub build_template {
+ local($name) = @_;
+
+ &panic("already got a template for $name") if defined $template{$name};
+
+ local($build_templates) = 1;
+
+ local($lparen) = '(' x $build_recursed;
+ local($rparen) = ')' x $build_recursed;
+
+ print STDERR "$lparen$name$rparen " if $trace;
+ $build_recursed++;
+ &pstruct($name,$name,0);
+ print STDERR "TEMPLATE for $name is ", $template{&psou($name)}, "\n" if $debug;
+ --$build_recursed;
+}
+
+
+sub panic {
+
+ select(STDERR);
+
+ print "\npanic: @_\n";
+
+ exit 1 if $] <= 4.003; # caller broken
+
+ local($i,$_);
+ local($p,$f,$l,$s,$h,$a,@a,@sub);
+ for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
+ @a = @DB'args;
+ for (@a) {
+ if (/^StB\000/ && length($_) == length($_main{'_main'})) {
+ $_ = sprintf("%s",$_);
+ }
+ else {
+ s/'/\\'/g;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ }
+ $w = $w ? '@ = ' : '$ = ';
+ $a = $h ? '(' . join(', ', @a) . ')' : '';
+ push(@sub, "$w&$s$a from file $f line $l\n");
+ last if $signal;
+ }
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ print $sub[$i];
+ }
+ exit 1;
+}
+
+sub squishseq {
+ local($num);
+ local($last) = -1e8;
+ local($string);
+ local($seq) = '..';
+
+ while (defined($num = shift)) {
+ if ($num == ($last + 1)) {
+ $string .= $seq unless $inseq++;
+ $last = $num;
+ next;
+ } elsif ($inseq) {
+ $string .= $last unless $last == -1e8;
+ }
+
+ $string .= ',' if defined $string;
+ $string .= $num;
+ $last = $num;
+ $inseq = 0;
+ }
+ $string .= $last if $inseq && $last != -e18;
+ $string;
+}
+
+sub repeat_template {
+ # local($template, $scripts) = @_; have to change caller's values
+
+ if ( $_[1] ) {
+ local($ncount) = &scripts2count($_[1]);
+ if ($_[0] =~ /^\s*c\s*$/i) {
+ $_[0] = "A$ncount ";
+ $_[1] = '';
+ } else {
+ $_[0] = $template x $ncount;
+ }
+ }
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/ptar b/Master/tlpkg/tlperl/bin/ptar new file mode 100755 index 00000000000..6a3c1bcd2ec --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ptar @@ -0,0 +1,114 @@ +#!/usr/bin/perl +use strict; + +use File::Find; +use Getopt::Std; +use Archive::Tar; +use Data::Dumper; + +my $opts = {}; +getopts('Ddcvzthxf:I', $opts) or die usage(); + +### show the help message ### +die usage() if $opts->{h}; + +### enable debugging (undocumented feature) +local $Archive::Tar::DEBUG = 1 if $opts->{d}; + +### enable insecure extracting. +local $Archive::Tar::INSECURE_EXTRACT_MODE = 1 if $opts->{I}; + +### sanity checks ### +unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) { + die "You need exactly one of 'x', 't' or 'c' options: " . usage(); +} + +my $compress = $opts->{z} ? 1 : 0; +my $verbose = $opts->{v} ? 1 : 0; +my $file = $opts->{f} ? $opts->{f} : 'default.tar'; +my $tar = Archive::Tar->new(); + + +if( $opts->{c} ) { + my @files; + find( sub { push @files, $File::Find::name; + print $File::Find::name.$/ if $verbose }, @ARGV ); + + if ($file eq '-') { + use IO::Handle; + $file = IO::Handle->new(); + $file->fdopen(fileno(STDOUT),"w"); + } + + Archive::Tar->create_archive( $file, $compress, @files ); + +} else { + if ($file eq '-') { + use IO::Handle; + $file = IO::Handle->new(); + $file->fdopen(fileno(STDIN),"r"); + } + + ### print the files we're finding? + my $print = $verbose || $opts->{'t'} || 0; + + my $iter = Archive::Tar->iter( $file ); + + while( my $f = $iter->() ) { + print $f->full_path . $/ if $print; + + ### data dumper output + print Dumper( $f ) if $opts->{'D'}; + + ### extract it + $f->extract if $opts->{'x'}; + } +} + +### pod & usage in one +sub usage { + my $usage .= << '=cut'; +=pod + +=head1 NAME + + ptar - a tar-like program written in perl + +=head1 DESCRIPTION + + ptar is a small, tar look-alike program that uses the perl module + Archive::Tar to extract, create and list tar archives. + +=head1 SYNOPSIS + + ptar -c [-v] [-z] [-f ARCHIVE_FILE | -] FILE FILE ... + ptar -x [-v] [-z] [-f ARCHIVE_FILE | -] + ptar -t [-z] [-f ARCHIVE_FILE | -] + ptar -h + +=head1 OPTIONS + + c Create ARCHIVE_FILE or STDOUT (-) from FILE + x Extract from ARCHIVE_FILE or STDIN (-) + t List the contents of ARCHIVE_FILE or STDIN (-) + f Name of the ARCHIVE_FILE to use. Default is './default.tar' + z Read/Write zlib compressed ARCHIVE_FILE (not always available) + v Print filenames as they are added or extraced from ARCHIVE_FILE + h Prints this help message + +=head1 SEE ALSO + + tar(1), L<Archive::Tar>. + +=cut + + ### strip the pod directives + $usage =~ s/=pod\n//g; + $usage =~ s/=head1 //g; + + ### add some newlines + $usage .= $/.$/; + + return $usage; +} + diff --git a/Master/tlpkg/tlperl/bin/ptar.bat b/Master/tlpkg/tlperl/bin/ptar.bat new file mode 100755 index 00000000000..6c439e086dc --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ptar.bat @@ -0,0 +1,130 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+use strict;
+
+use File::Find;
+use Getopt::Std;
+use Archive::Tar;
+use Data::Dumper;
+
+my $opts = {};
+getopts('Ddcvzthxf:I', $opts) or die usage();
+
+### show the help message ###
+die usage() if $opts->{h};
+
+### enable debugging (undocumented feature)
+local $Archive::Tar::DEBUG = 1 if $opts->{d};
+
+### enable insecure extracting.
+local $Archive::Tar::INSECURE_EXTRACT_MODE = 1 if $opts->{I};
+
+### sanity checks ###
+unless ( 1 == grep { defined $opts->{$_} } qw[x t c] ) {
+ die "You need exactly one of 'x', 't' or 'c' options: " . usage();
+}
+
+my $compress = $opts->{z} ? 1 : 0;
+my $verbose = $opts->{v} ? 1 : 0;
+my $file = $opts->{f} ? $opts->{f} : 'default.tar';
+my $tar = Archive::Tar->new();
+
+
+if( $opts->{c} ) {
+ my @files;
+ find( sub { push @files, $File::Find::name;
+ print $File::Find::name.$/ if $verbose }, @ARGV );
+
+ if ($file eq '-') {
+ use IO::Handle;
+ $file = IO::Handle->new();
+ $file->fdopen(fileno(STDOUT),"w");
+ }
+
+ Archive::Tar->create_archive( $file, $compress, @files );
+
+} else {
+ if ($file eq '-') {
+ use IO::Handle;
+ $file = IO::Handle->new();
+ $file->fdopen(fileno(STDIN),"r");
+ }
+
+ ### print the files we're finding?
+ my $print = $verbose || $opts->{'t'} || 0;
+
+ my $iter = Archive::Tar->iter( $file );
+
+ while( my $f = $iter->() ) {
+ print $f->full_path . $/ if $print;
+
+ ### data dumper output
+ print Dumper( $f ) if $opts->{'D'};
+
+ ### extract it
+ $f->extract if $opts->{'x'};
+ }
+}
+
+### pod & usage in one
+sub usage {
+ my $usage .= << '=cut';
+=pod
+
+=head1 NAME
+
+ ptar - a tar-like program written in perl
+
+=head1 DESCRIPTION
+
+ ptar is a small, tar look-alike program that uses the perl module
+ Archive::Tar to extract, create and list tar archives.
+
+=head1 SYNOPSIS
+
+ ptar -c [-v] [-z] [-f ARCHIVE_FILE | -] FILE FILE ...
+ ptar -x [-v] [-z] [-f ARCHIVE_FILE | -]
+ ptar -t [-z] [-f ARCHIVE_FILE | -]
+ ptar -h
+
+=head1 OPTIONS
+
+ c Create ARCHIVE_FILE or STDOUT (-) from FILE
+ x Extract from ARCHIVE_FILE or STDIN (-)
+ t List the contents of ARCHIVE_FILE or STDIN (-)
+ f Name of the ARCHIVE_FILE to use. Default is './default.tar'
+ z Read/Write zlib compressed ARCHIVE_FILE (not always available)
+ v Print filenames as they are added or extraced from ARCHIVE_FILE
+ h Prints this help message
+
+=head1 SEE ALSO
+
+ tar(1), L<Archive::Tar>.
+
+=cut
+
+ ### strip the pod directives
+ $usage =~ s/=pod\n//g;
+ $usage =~ s/=head1 //g;
+
+ ### add some newlines
+ $usage .= $/.$/;
+
+ return $usage;
+}
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/ptardiff b/Master/tlpkg/tlperl/bin/ptardiff new file mode 100755 index 00000000000..21e7d6cce59 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ptardiff @@ -0,0 +1,112 @@ +#!/usr/bin/perl + +use strict; +use Archive::Tar; +use Getopt::Std; + +my $opts = {}; +getopts('h:', $opts) or die usage(); + +die usages() if $opts->{h}; + +### need Text::Diff -- give a polite error (not a standard prereq) +unless ( eval { require Text::Diff; Text::Diff->import; 1 } ) { + die "\n\t This tool requires the 'Text::Diff' module to be installed\n"; +} + +my $arch = shift or die usage(); +my $tar = Archive::Tar->new( $arch ) or die "Couldn't read '$arch': $!"; + + +foreach my $file ( $tar->get_files ) { + next unless $file->is_file; + my $name = $file->name; + + diff( \($file->get_content), $name, + { FILENAME_A => $name, + MTIME_A => $file->mtime, + OUTPUT => \*STDOUT + } + ); +} + + + + +sub usage { + return q[ + +Usage: ptardiff ARCHIVE_FILE + ptardiff -h + + ptardiff is a small program that diffs an extracted archive + against an unextracted one, using the perl module Archive::Tar. + + This effectively lets you view changes made to an archives contents. + + Provide the progam with an ARCHIVE_FILE and it will look up all + the files with in the archive, scan the current working directory + for a file with the name and diff it against the contents of the + archive. + + +Options: + h Prints this help message + + +Sample Usage: + + $ tar -xzf Acme-Buffy-1.3.tar.gz + $ vi Acme-Buffy-1.3/README + + [...] + + $ ptardiff Acme-Buffy-1.3.tar.gz > README.patch + + +See Also: + tar(1) + ptar + Archive::Tar + + ] . $/; +} + + + +=head1 NAME + +ptardiff - program that diffs an extracted archive against an unextracted one + +=head1 DESCRIPTION + + ptardiff is a small program that diffs an extracted archive + against an unextracted one, using the perl module Archive::Tar. + + This effectively lets you view changes made to an archives contents. + + Provide the progam with an ARCHIVE_FILE and it will look up all + the files with in the archive, scan the current working directory + for a file with the name and diff it against the contents of the + archive. + +=head1 SYNOPSIS + + ptardiff ARCHIVE_FILE + ptardiff -h + + $ tar -xzf Acme-Buffy-1.3.tar.gz + $ vi Acme-Buffy-1.3/README + [...] + $ ptardiff Acme-Buffy-1.3.tar.gz > README.patch + + +=head1 OPTIONS + + h Prints this help message + +=head1 SEE ALSO + +tar(1), L<Archive::Tar>. + +=cut diff --git a/Master/tlpkg/tlperl/bin/ptardiff.bat b/Master/tlpkg/tlperl/bin/ptardiff.bat new file mode 100755 index 00000000000..85ac7896610 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ptardiff.bat @@ -0,0 +1,128 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use strict;
+use Archive::Tar;
+use Getopt::Std;
+
+my $opts = {};
+getopts('h:', $opts) or die usage();
+
+die usages() if $opts->{h};
+
+### need Text::Diff -- give a polite error (not a standard prereq)
+unless ( eval { require Text::Diff; Text::Diff->import; 1 } ) {
+ die "\n\t This tool requires the 'Text::Diff' module to be installed\n";
+}
+
+my $arch = shift or die usage();
+my $tar = Archive::Tar->new( $arch ) or die "Couldn't read '$arch': $!";
+
+
+foreach my $file ( $tar->get_files ) {
+ next unless $file->is_file;
+ my $name = $file->name;
+
+ diff( \($file->get_content), $name,
+ { FILENAME_A => $name,
+ MTIME_A => $file->mtime,
+ OUTPUT => \*STDOUT
+ }
+ );
+}
+
+
+
+
+sub usage {
+ return q[
+
+Usage: ptardiff ARCHIVE_FILE
+ ptardiff -h
+
+ ptardiff is a small program that diffs an extracted archive
+ against an unextracted one, using the perl module Archive::Tar.
+
+ This effectively lets you view changes made to an archives contents.
+
+ Provide the progam with an ARCHIVE_FILE and it will look up all
+ the files with in the archive, scan the current working directory
+ for a file with the name and diff it against the contents of the
+ archive.
+
+
+Options:
+ h Prints this help message
+
+
+Sample Usage:
+
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ vi Acme-Buffy-1.3/README
+
+ [...]
+
+ $ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
+
+
+See Also:
+ tar(1)
+ ptar
+ Archive::Tar
+
+ ] . $/;
+}
+
+
+
+=head1 NAME
+
+ptardiff - program that diffs an extracted archive against an unextracted one
+
+=head1 DESCRIPTION
+
+ ptardiff is a small program that diffs an extracted archive
+ against an unextracted one, using the perl module Archive::Tar.
+
+ This effectively lets you view changes made to an archives contents.
+
+ Provide the progam with an ARCHIVE_FILE and it will look up all
+ the files with in the archive, scan the current working directory
+ for a file with the name and diff it against the contents of the
+ archive.
+
+=head1 SYNOPSIS
+
+ ptardiff ARCHIVE_FILE
+ ptardiff -h
+
+ $ tar -xzf Acme-Buffy-1.3.tar.gz
+ $ vi Acme-Buffy-1.3/README
+ [...]
+ $ ptardiff Acme-Buffy-1.3.tar.gz > README.patch
+
+
+=head1 OPTIONS
+
+ h Prints this help message
+
+=head1 SEE ALSO
+
+tar(1), L<Archive::Tar>.
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/ptked b/Master/tlpkg/tlperl/bin/ptked new file mode 100755 index 00000000000..e0c537d96f4 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ptked @@ -0,0 +1,368 @@ +#!/usr/local/bin/perl -w +use strict; +use Socket; +use IO::Socket; +use Cwd; +use Getopt::Long; + +use vars qw($VERSION $portfile); +$VERSION = sprintf '4.%03d', q$Revision: #29 $ =~ /\D(\d+)\s*$/; + +my %opt; +INIT + { + my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'}; + $portfile = "$home/.ptkedsn"; + my $port = $ENV{'PTKEDPORT'}; + return if $^C; + GetOptions(\%opt,qw(server! encoding=s)); + unless (defined $port) + { + if (open(SN,"$portfile")) + { + $port = <SN>; + close(SN); + } + } + if (defined $port) + { + my $sock = IO::Socket::INET->new(PeerAddr => 'localhost', + PeerPort => $port, Proto => 'tcp'); + if ($sock) + { + binmode($sock); + $sock->autoflush; + foreach my $file (@ARGV) + { + unless (print $sock "$file\n") + { + die "Cannot print $file to socket:$!"; + } + print "Requested '$file'\n"; + } + $sock->close || die "Cannot close socket:$!"; + exit(0); + } + else + { + warn "Cannot connect to server on $port:$!"; + } + } + } + +use Tk; +use Tk::DropSite qw(XDND Sun); +use Tk::DragDrop qw(XDND Sun); +use Tk::widgets qw(TextUndo Scrollbar Menu Dialog); +# use Tk::ErrorDialog; + +{ + package Tk::TextUndoPtked; + @Tk::TextUndoPtked::ISA = qw(Tk::TextUndo); + Construct Tk::Widget 'TextUndoPtked'; + + sub Save { + my $w = shift; + $w->SUPER::Save(@_); + $w->toplevel->title($w->FileName); + } + + sub Load { + my $w = shift; + $w->SUPER::Load(@_); + $w->toplevel->title($w->FileName); + } + + sub MenuLabels { shift->SUPER::MenuLabels, 'Encoding' } + + sub Encoding + { + my ($w,$enc) = @_; + if (@_ > 1) + { + $enc = $w->getEncoding($enc) unless ref($enc); + $w->{ENCODING} = $enc; + $enc = $enc->name; + $w->{ENCODINGNAME} = $enc; + $w->PerlIO_layers(":encoding($enc)"); + } + return $w->{ENCODING}; + } + + sub EncodingMenuItems + { + my ($w) = @_; + my @menu; + my @encoding_defs = ( # use canonical encoding names for radiobutton value + ['Unicode (UTF-8)', 'utf-8-strict'], + ['Western (iso-8859-1)', 'iso-8859-1'], + ['Western (Windows-1252)', 'cp1252'], + ["Western with \x{20ac} (iso-8859-15)", 'iso-8859-15'], + ['Central European (Windows-1250)', 'cp1250'], + ); + if (!grep { $_->[1] eq Tk::SystemEncoding()->name } @encoding_defs) + { + unshift @encoding_defs, ['System', Tk::SystemEncoding()->name]; + } + + for my $encoding_def (@encoding_defs) + { + my($label, $encoding) = @$encoding_def; + push @menu, [ radiobutton => $label, + -command => [ $w, Encoding => $encoding ], + -variable => \$w->{ENCODINGNAME}, + -value => $encoding ]; + } + return [ @menu ]; + } + +} + +my $top = MainWindow->new(); + +if ($opt{'server'}) + { + my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp'); + die "Cannot open listen socket:$!" unless defined $sock; + binmode($sock); + + my $port = $sock->sockport; + $ENV{'PTKEDPORT'} = $port; + open(SN,">$portfile") || die "Cannot open $portfile:$!"; + print SN $port; + close(SN); + print "Accepting connections on $port\n"; + $top->fileevent($sock,'readable', + sub + { + print "accepting $sock\n"; + my $client = $sock->accept; + if (defined $client) + { + binmode($client); + print "Connection $client\n"; + $top->fileevent($client,'readable',[\&EditRequest,$client]); + } + }); + } + +Tk::Event::HandleSignals(); +$SIG{'INT'} = sub { $top->WmDeleteWindow }; + +$top->iconify; +$top->optionAdd('*TextUndoPtked.Background' => '#fff5e1'); +$top->fontCreate('ptked',-family => 'courier', -size => ($^O eq 'MSWin32' ? 11 : -12), + -weight => 'normal', -slant => 'roman'); +$top->optionAdd('*TextUndoPtked.Font' => 'ptked'); + +if (@ARGV) + { + foreach my $file (@ARGV) + { + Create_Edit($file); + } + } +else + { + Create_Edit(); + } + +sub EditRequest +{ + my ($client) = @_; + local $_; + while (<$client>) + { + chomp($_); + print "'$_'\n", + Create_Edit($_); + } + warn "Odd $!" unless eof($client); + $top->fileevent($client,'readable',''); + print "Close $client\n"; + $client->close; +} + +MainLoop; +unlink("$portfile"); +exit(0); + +sub Create_Edit +{ + my $path = shift; + my $ed = $top->Toplevel(-title => $path); + $ed->withdraw; + $top->{'Edits'}++; + $ed->OnDestroy([\&RemoveEdit,$top]); + my $t = $ed->Scrolled('TextUndoPtked', -wrap => 'none', + -scrollbars => 'se', # both required till optional fixed! + ); + $t->pack(-expand => 1, -fill => 'both'); + $t = $t->Subwidget('scrolled'); + + $t->Encoding($opt{encoding} || Tk::SystemEncoding()->name); + + my $menu = $t->menu; + $menu->cascade(-label => '~Help', -menuitems => [ + [Button => '~About...', -command => [\&About,$ed]], + ]); + $ed->configure(-menu => $menu); + my $dd = $t->DragDrop(-event => '<Meta-B1-Motion>'); + $t->bind(ref($t),'<Meta-B1-Motion>',\&Ouch); + $t->bind(ref($t),'<Meta-ButtonPress>',\&Ouch); + $t->bind(ref($t),'<Meta-ButtonRelease>',\&Ouch); + $dd->configure(-startcommand => + sub + { + return 1 unless (eval { $t->tagNextrange(sel => '1.0','end')}); + $dd->configure(-text => $t->get('sel.first','sel.last')); + }); + + $t->DropSite(-motioncommand => + sub + { my ($x,$y) = @_; + $t->markSet(insert => "\@$x,$y"); + }, + -dropcommand => [\&HandleDrop,$t], + ); + + + + $ed->protocol('WM_DELETE_WINDOW',[ConfirmExit => $t]); + $t->bind('<F3>',\&DoFind); + + $ed->idletasks; + if (defined $path && -e $path) + { + $t->Load($path); + } + else + { + $t->FileName($path); + } + $ed->deiconify; + $t->update; + $t->focus; +} + +sub Ouch +{ + warn join(',','Ouch',@_); +} + +sub RemoveEdit +{ + my $top = shift; + if (--$top->{'Edits'} == 0) + { + $top->destroy unless $opt{'s'}; + } +} + +sub HandleDrop +{my ($t,$seln,$x,$y) = @_; + # warn join(',',Drop => @_); + my $string; + Tk::catch { $string = $t->SelectionGet(-selection => $seln,'FILE_NAME') }; + if ($@) + { + Tk::catch { $string = $t->SelectionGet(-selection => $seln) }; + if ($@) + { + my @targets = $t->SelectionGet(-selection => $seln, 'TARGETS'); + $t->messageBox(-text => "Targets : ".join(' ',@targets)); + } + else + { + $t->markSet(insert => "\@$x,$y"); + $t->insert(insert => $string); + } + } + else + { + Create_Edit($string); + } +} + + +my $str; + +sub DoFind +{ + my $t = shift; + $str = shift if (@_); + my $posn = $t->index('insert+1c'); + $t->tag('remove','sel','1.0','end'); + local $_; + while ($t->compare($posn,'<','end')) + { + my ($line,$col) = split(/\./,$posn); + $_ = $t->get("$line.0","$posn lineend"); + pos($_) = $col; + if (/\G(.*)$str/g) + { + $col += length($1); + $posn = "$line.$col"; + $t->SetCursor($posn); + $t->tag('add','sel',$posn,"$line.".pos($_)); + $t->focus; + return; + } + $posn = $t->index("$posn lineend + 1c"); + } +} + +sub AskFind +{ + my ($t) = @_; + unless (exists $t->{'AskFind'}) + { + my $d = $t->{'AskFind'} = $t->Toplevel(-popover => 'cursor', -popanchor => 'nw'); + $d->title('Find...'); + $d->withdraw; + $d->transient($t->toplevel); + my $e = $d->Entry->pack; + $e->bind('<Return>', sub { $d->withdraw; DoFind($t,$e->get); }); + $d->protocol(WM_DELETE_WINDOW =>[withdraw => $d]); + } + $t->{'AskFind'}->Popup; + $t->update; + $t->{'AskFind'}->focusNext; +} + +sub About +{ + my $mw = shift; + + $mw->Dialog(-text => <<"END",-popover => $mw)->Show; +$0 version $VERSION +perl$]/Tk$Tk::VERSION + +Copyright © 1995-2004 Nick Ing-Simmons. All rights reserved. +This package is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. +END +} + +__END__ + +=head1 NAME + +ptked - an editor in Perl/Tk + +=head1 SYNOPSIS + +S< >B<ptked> [I<file-to-edit>] + +=head1 DESCRIPTION + +B<ptked> is a simple text editor based on perl/Tk's TextUndo widget. + +=cut + + + + + + + diff --git a/Master/tlpkg/tlperl/bin/ptked.bat b/Master/tlpkg/tlperl/bin/ptked.bat new file mode 100755 index 00000000000..390178b1916 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ptked.bat @@ -0,0 +1,384 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+use strict;
+use Socket;
+use IO::Socket;
+use Cwd;
+use Getopt::Long;
+
+use vars qw($VERSION $portfile);
+$VERSION = sprintf '4.%03d', q$Revision: #29 $ =~ /\D(\d+)\s*$/;
+
+my %opt;
+INIT
+ {
+ my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'};
+ $portfile = "$home/.ptkedsn";
+ my $port = $ENV{'PTKEDPORT'};
+ return if $^C;
+ GetOptions(\%opt,qw(server! encoding=s));
+ unless (defined $port)
+ {
+ if (open(SN,"$portfile"))
+ {
+ $port = <SN>;
+ close(SN);
+ }
+ }
+ if (defined $port)
+ {
+ my $sock = IO::Socket::INET->new(PeerAddr => 'localhost',
+ PeerPort => $port, Proto => 'tcp');
+ if ($sock)
+ {
+ binmode($sock);
+ $sock->autoflush;
+ foreach my $file (@ARGV)
+ {
+ unless (print $sock "$file\n")
+ {
+ die "Cannot print $file to socket:$!";
+ }
+ print "Requested '$file'\n";
+ }
+ $sock->close || die "Cannot close socket:$!";
+ exit(0);
+ }
+ else
+ {
+ warn "Cannot connect to server on $port:$!";
+ }
+ }
+ }
+
+use Tk;
+use Tk::DropSite qw(XDND Sun);
+use Tk::DragDrop qw(XDND Sun);
+use Tk::widgets qw(TextUndo Scrollbar Menu Dialog);
+# use Tk::ErrorDialog;
+
+{
+ package Tk::TextUndoPtked;
+ @Tk::TextUndoPtked::ISA = qw(Tk::TextUndo);
+ Construct Tk::Widget 'TextUndoPtked';
+
+ sub Save {
+ my $w = shift;
+ $w->SUPER::Save(@_);
+ $w->toplevel->title($w->FileName);
+ }
+
+ sub Load {
+ my $w = shift;
+ $w->SUPER::Load(@_);
+ $w->toplevel->title($w->FileName);
+ }
+
+ sub MenuLabels { shift->SUPER::MenuLabels, 'Encoding' }
+
+ sub Encoding
+ {
+ my ($w,$enc) = @_;
+ if (@_ > 1)
+ {
+ $enc = $w->getEncoding($enc) unless ref($enc);
+ $w->{ENCODING} = $enc;
+ $enc = $enc->name;
+ $w->{ENCODINGNAME} = $enc;
+ $w->PerlIO_layers(":encoding($enc)");
+ }
+ return $w->{ENCODING};
+ }
+
+ sub EncodingMenuItems
+ {
+ my ($w) = @_;
+ my @menu;
+ my @encoding_defs = ( # use canonical encoding names for radiobutton value
+ ['Unicode (UTF-8)', 'utf-8-strict'],
+ ['Western (iso-8859-1)', 'iso-8859-1'],
+ ['Western (Windows-1252)', 'cp1252'],
+ ["Western with \x{20ac} (iso-8859-15)", 'iso-8859-15'],
+ ['Central European (Windows-1250)', 'cp1250'],
+ );
+ if (!grep { $_->[1] eq Tk::SystemEncoding()->name } @encoding_defs)
+ {
+ unshift @encoding_defs, ['System', Tk::SystemEncoding()->name];
+ }
+
+ for my $encoding_def (@encoding_defs)
+ {
+ my($label, $encoding) = @$encoding_def;
+ push @menu, [ radiobutton => $label,
+ -command => [ $w, Encoding => $encoding ],
+ -variable => \$w->{ENCODINGNAME},
+ -value => $encoding ];
+ }
+ return [ @menu ];
+ }
+
+}
+
+my $top = MainWindow->new();
+
+if ($opt{'server'})
+ {
+ my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp');
+ die "Cannot open listen socket:$!" unless defined $sock;
+ binmode($sock);
+
+ my $port = $sock->sockport;
+ $ENV{'PTKEDPORT'} = $port;
+ open(SN,">$portfile") || die "Cannot open $portfile:$!";
+ print SN $port;
+ close(SN);
+ print "Accepting connections on $port\n";
+ $top->fileevent($sock,'readable',
+ sub
+ {
+ print "accepting $sock\n";
+ my $client = $sock->accept;
+ if (defined $client)
+ {
+ binmode($client);
+ print "Connection $client\n";
+ $top->fileevent($client,'readable',[\&EditRequest,$client]);
+ }
+ });
+ }
+
+Tk::Event::HandleSignals();
+$SIG{'INT'} = sub { $top->WmDeleteWindow };
+
+$top->iconify;
+$top->optionAdd('*TextUndoPtked.Background' => '#fff5e1');
+$top->fontCreate('ptked',-family => 'courier', -size => ($^O eq 'MSWin32' ? 11 : -12),
+ -weight => 'normal', -slant => 'roman');
+$top->optionAdd('*TextUndoPtked.Font' => 'ptked');
+
+if (@ARGV)
+ {
+ foreach my $file (@ARGV)
+ {
+ Create_Edit($file);
+ }
+ }
+else
+ {
+ Create_Edit();
+ }
+
+sub EditRequest
+{
+ my ($client) = @_;
+ local $_;
+ while (<$client>)
+ {
+ chomp($_);
+ print "'$_'\n",
+ Create_Edit($_);
+ }
+ warn "Odd $!" unless eof($client);
+ $top->fileevent($client,'readable','');
+ print "Close $client\n";
+ $client->close;
+}
+
+MainLoop;
+unlink("$portfile");
+exit(0);
+
+sub Create_Edit
+{
+ my $path = shift;
+ my $ed = $top->Toplevel(-title => $path);
+ $ed->withdraw;
+ $top->{'Edits'}++;
+ $ed->OnDestroy([\&RemoveEdit,$top]);
+ my $t = $ed->Scrolled('TextUndoPtked', -wrap => 'none',
+ -scrollbars => 'se', # both required till optional fixed!
+ );
+ $t->pack(-expand => 1, -fill => 'both');
+ $t = $t->Subwidget('scrolled');
+
+ $t->Encoding($opt{encoding} || Tk::SystemEncoding()->name);
+
+ my $menu = $t->menu;
+ $menu->cascade(-label => '~Help', -menuitems => [
+ [Button => '~About...', -command => [\&About,$ed]],
+ ]);
+ $ed->configure(-menu => $menu);
+ my $dd = $t->DragDrop(-event => '<Meta-B1-Motion>');
+ $t->bind(ref($t),'<Meta-B1-Motion>',\&Ouch);
+ $t->bind(ref($t),'<Meta-ButtonPress>',\&Ouch);
+ $t->bind(ref($t),'<Meta-ButtonRelease>',\&Ouch);
+ $dd->configure(-startcommand =>
+ sub
+ {
+ return 1 unless (eval { $t->tagNextrange(sel => '1.0','end')});
+ $dd->configure(-text => $t->get('sel.first','sel.last'));
+ });
+
+ $t->DropSite(-motioncommand =>
+ sub
+ { my ($x,$y) = @_;
+ $t->markSet(insert => "\@$x,$y");
+ },
+ -dropcommand => [\&HandleDrop,$t],
+ );
+
+
+
+ $ed->protocol('WM_DELETE_WINDOW',[ConfirmExit => $t]);
+ $t->bind('<F3>',\&DoFind);
+
+ $ed->idletasks;
+ if (defined $path && -e $path)
+ {
+ $t->Load($path);
+ }
+ else
+ {
+ $t->FileName($path);
+ }
+ $ed->deiconify;
+ $t->update;
+ $t->focus;
+}
+
+sub Ouch
+{
+ warn join(',','Ouch',@_);
+}
+
+sub RemoveEdit
+{
+ my $top = shift;
+ if (--$top->{'Edits'} == 0)
+ {
+ $top->destroy unless $opt{'s'};
+ }
+}
+
+sub HandleDrop
+{my ($t,$seln,$x,$y) = @_;
+ # warn join(',',Drop => @_);
+ my $string;
+ Tk::catch { $string = $t->SelectionGet(-selection => $seln,'FILE_NAME') };
+ if ($@)
+ {
+ Tk::catch { $string = $t->SelectionGet(-selection => $seln) };
+ if ($@)
+ {
+ my @targets = $t->SelectionGet(-selection => $seln, 'TARGETS');
+ $t->messageBox(-text => "Targets : ".join(' ',@targets));
+ }
+ else
+ {
+ $t->markSet(insert => "\@$x,$y");
+ $t->insert(insert => $string);
+ }
+ }
+ else
+ {
+ Create_Edit($string);
+ }
+}
+
+
+my $str;
+
+sub DoFind
+{
+ my $t = shift;
+ $str = shift if (@_);
+ my $posn = $t->index('insert+1c');
+ $t->tag('remove','sel','1.0','end');
+ local $_;
+ while ($t->compare($posn,'<','end'))
+ {
+ my ($line,$col) = split(/\./,$posn);
+ $_ = $t->get("$line.0","$posn lineend");
+ pos($_) = $col;
+ if (/\G(.*)$str/g)
+ {
+ $col += length($1);
+ $posn = "$line.$col";
+ $t->SetCursor($posn);
+ $t->tag('add','sel',$posn,"$line.".pos($_));
+ $t->focus;
+ return;
+ }
+ $posn = $t->index("$posn lineend + 1c");
+ }
+}
+
+sub AskFind
+{
+ my ($t) = @_;
+ unless (exists $t->{'AskFind'})
+ {
+ my $d = $t->{'AskFind'} = $t->Toplevel(-popover => 'cursor', -popanchor => 'nw');
+ $d->title('Find...');
+ $d->withdraw;
+ $d->transient($t->toplevel);
+ my $e = $d->Entry->pack;
+ $e->bind('<Return>', sub { $d->withdraw; DoFind($t,$e->get); });
+ $d->protocol(WM_DELETE_WINDOW =>[withdraw => $d]);
+ }
+ $t->{'AskFind'}->Popup;
+ $t->update;
+ $t->{'AskFind'}->focusNext;
+}
+
+sub About
+{
+ my $mw = shift;
+
+ $mw->Dialog(-text => <<"END",-popover => $mw)->Show;
+$0 version $VERSION
+perl$]/Tk$Tk::VERSION
+
+Copyright © 1995-2004 Nick Ing-Simmons. All rights reserved.
+This package is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+END
+}
+
+__END__
+
+=head1 NAME
+
+ptked - an editor in Perl/Tk
+
+=head1 SYNOPSIS
+
+S< >B<ptked> [I<file-to-edit>]
+
+=head1 DESCRIPTION
+
+B<ptked> is a simple text editor based on perl/Tk's TextUndo widget.
+
+=cut
+
+
+
+
+
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/ptksh b/Master/tlpkg/tlperl/bin/ptksh new file mode 100755 index 00000000000..a606f0b6a8f --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ptksh @@ -0,0 +1,730 @@ +#!perl -w +# +# PTKSH 2.0 +# +# A graphical user interface for testing Perl/Tk commands and scripts. +# +# VERSION HISTORY: +# ...truncated earlier stuff... +# 4/23/98 V1.7 Achim Bohnet -- some fixes to "o" command +# 6/08/98 V2.01 M. Beller -- merge in GUI code for "wish"-like interface +# +# 2.01d1 6/6/98 First development version +# +# 2.01d2 6/7/98 +# - apply A.B. patch for pod and -option +# - fix "use of uninitialized variable" in END{ } block (for -c option) +# - support h and ? only for help +# - misc. pod fixes (PITFALLS) +# - use default fonts and default colors ## NOT YET--still working on it +# - get rid of Data::Dumper for history +# +# 2.01d3 6/8/98 +# - Remove "use Data::Dumper" line +# - Put in hack for unix vs. win32 window manager focus problem +# - Achim's pod and histfile patch +# +# 2.01d4 6/18/98 +# - Slaven's patch to make <Home> work properly +# - Add help message to banner (per Steve Lydie) +# - Fix horizontal scrolling (turn off wrapping in console window) +# - Clarify <Up> in docs and help means "up arrow" +# - Use HOMEDRIVE/HOMEPATH on Win32 +# +# For more history look at the various Changes files in the Perl/Tk +# distribution. + +=head1 NAME + +ptksh - Perl/Tk script to provide a graphical user interface for testing Perl/Tk +commands and scripts. + +=head1 SYNOPSIS + + % ptksh ?scriptfile? + ... version information ... + ptksh> $b=$mw->Button(-text=>'Hi',-command=>sub{print 'Hi'}) + ptksh> $b->pack + ptksh> o $b + ... list of options ... + ptksh> help + ... help information ... + ptksh> exit + % + + +=head1 DESCRIPTION + +ptksh is a perl/Tk shell to enter perl commands +interactively. When one starts ptksh a L<MainWindow|Tk::MainWindow> +is automaticly created, along with a ptksh command window. +One can access the main window by typing commands using the +variable $mw at the 'ptksh> ' prompt of the command window. + +ptksh supports command line editing and history. Just type "<Up>" at +the command prompt to see a history list. The last 50 commands entered +are saved, then reloaded into history list the next time you start ptksh. + +ptksh supports some convenient commands for inspecting Tk widgets. See below. + +To exit ptksh use: C<exit>. + +ptksh is B<*not*> a full symbolic debugger. +To debug perl/Tk programs at a low level use the more powerful +L<perl debugger|perldebug>. (Just enter ``O tk'' on debuggers +command line to start the Tk eventloop.) + +=head1 FEATURES + +=head2 History + +Press <Up> (the Up Arrow) in the perlwish window to obtain a gui-based history list. +Press <Enter> on any history line to enter it into the perlwish window. +Then hit return. So, for example, repeat last command is <Up><Enter><Enter>. +You can quit the history window with <Escape>. NOTE: history is only saved +if exit is "graceful" (i.e. by the "exit" command from the console or by +quitting all main windows--NOT by interrupt). + +=head2 Debugging Support + +ptksh provides some convenience function to make browsing +in perl/Tk widget easier: + +=over 4 + +=item B<?>, or B<h> + +displays a short help summary. + +=item B<d>, or B<x> ?I<args>, ...? + +Dumps recursively arguments to stdout. (see L<Data::Dumper>). +You must have <Data::Dumper> installed to support this feature. + +B<x> was introduced for perl debugger compatibility. + +=item B<p> ?I<arg>, ...? + +appends "|\n" to each of it's arguments and prints it. +If value is B<undef>, '(undef)' is printed to stdout. + +=item B<o> I<$widget> ?I<-option> ...? + +prints the option(s) of I<$widget> one on each line. +If no options are given all options of the widget are +listed. See L<Tk::options> for more details on the +format and contents of the returned list. + +=item B<o> I<$widget> B</>I<regexp>B</> + +Lists options of I<$widget> matching the +L<regular expression|perlre> I<regexp>. + +=item B<u> ?I<class>? + +If no argument is given it lists the modules loaded +by the commands you executed or since the last time you +called C<u>. + +If argument is the empty string lists all modules that are +loaded by ptksh. + +If argument is a string, ``text'' it tries to do a ``use Tk::Text;''. + +=back + +=head2 Packages + +Ptksh compiles into package Tk::ptksh. Your code is eval'ed into package +main. The coolness of this is that your eval code should not interfere with +ptksh itself. + +=head2 Multiline Commands + +ptksh will accept multiline commands. Simply put a "\" character immediately +before the newline, and ptksh will continue your command onto the next line. + +=head2 Source File Support + +If you have a perl/Tk script that you want to do debugging on, try running the +command + + ptksh> do 'myscript'; + + -- or (at shell command prompt) -- + + % ptksh myscript + +Then use the perl/Tk commands to try out different operations on your script. + +=head1 ENVIRONMENT + +Looks for your .ptksh_history in the directory specified by +the $HOME environment variable ($HOMEPATH on Win32 systems). + +=head1 FILES + +=over 4 + +=item F<.ptksh_init> + +If found in current directory it is read in an evaluated +after the mainwindow I<$mw> is created. F<.ptksh_init> +can contain any valid perl code. + +=item F<~/.ptksh_history> + +Contains the last 50 lines entered in ptksh session(s). + +=back + +=head1 PITFALLS + +It is best not to use "my" in the commands you type into ptksh. +For example "my $v" will make $v local just to the command or commands +entered until <Return> is pressed. +For a related reason, there are no file-scopy "my" variables in the +ptksh code itself (else the user might trounce on them by accident). + +=head1 BUGS + +B<Tk::MainLoop> function interactively entered or sourced in a +init or script file will block ptksh. + +=head1 SEE ALSO + +L<Tk|Tk> +L<perldebug|perldebug> + +=head1 VERSION + +VERSION 2.03 + +=head1 AUTHORS + +Mike Beller <beller@penvision.com>, +Achim Bohnet <ach@mpe.mpg.de> + +Copyright (c) 1996 - 1998 Achim Bohnet and Mike Beller. All rights reserved. +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + +package Tk::ptksh; +require 5.004; +use strict; +use Tk; + +##### Constants + +use vars qw($NAME $VERSION $FONT @FONT $WIN32 $HOME $HISTFILE $HISTSAVE $PROMPT $INITFILE); + +$NAME = 'ptksh'; +$VERSION = '2.03'; +$WIN32 = 1 if $^O =~ /Win32/; +$HOME = $WIN32 ? ($ENV{HOMEDRIVE} . $ENV{HOMEPATH}) || 'C:\\' : $ENV{HOME} . "/"; +@FONT = ($WIN32 ? (-font => 'systemfixed') : () ); +#@FONT = ($WIN32 ? (-font => ['courier', 9, 'normal']) : () ); +$HISTFILE = "${HOME}.${NAME}_history"; +$HISTSAVE = 50; +$INITFILE = ".${NAME}_init"; +$PROMPT = "$NAME> "; + +sub Win32Fix { my $p = shift; $p =~ s'\\'/'g; $p =~ s'/$''; return $p } + +use vars qw($mw $st $t @hist $hist $list $isStartOfCommand); + +# NOTE: mainwindow creation order seems to impact who gets focus, and +# order is different on Win32 & *nix!! So hack is to create the windows +# in an order dependent on the OS! + +$mw = Tk::MainWindow->new unless $WIN32; # &&& hack to work around focus problem + +##### set up user's main window +package main; +$main::mw = Tk::MainWindow->new; +$main::mw->title('$mw'); +$main::mw->geometry("+1+1"); +package Tk::ptksh; + +##### Set up ptksh windows +$mw = Tk::MainWindow->new if $WIN32; # &&& hack to work around focus problem +$mw->title($NAME); +$st = $mw->Scrolled('Text', -scrollbars => 'osoe', + -wrap => 'none', + -width => 80, -height => 25, @FONT); +$t = $st->Subwidget('scrolled'); +$st->pack(-fill => 'both', -expand => 'true'); +# $mw_mapped assures that Center is only called exactly twice: first time +# will determine geometry of window, second time centering will work. +# I observed a couple of further <Map> events, which are now ignored +# and thus window creation seems to be faster now. +my $mw_mapped; +$mw->bind('<Map>', sub {return if $mw_mapped && $mw_mapped>=2; Center($mw); $mw_mapped++;} ); + +# Event bindings +$t->bindtags([$t, ref($t), $t->toplevel, 'all']); # take first crack at events +$t->bind('<Return>', \&EvalInput); +$t->bind('<BackSpace>', \&BackSpace); +$t->bind('<Escape>', \&HistKill); +$t->bind('<Up>', \&History); +$t->bind('<Control-a>', \&BeginLine); +$t->bind('<Home>', \&BeginLine); +$t->bind('<Any-KeyPress>', [\&Key, Tk::Ev('K'), Tk::Ev('A')]); + +my $default_font = $t->cget(-font); +my %default_font = $t->fontActual($default_font); +my $normal_font; +if (!$t->fontMetrics($default_font, '-fixed')) { + $normal_font = $t->fontCreate(%default_font, -family => "courier"); + $t->configure(-font => $normal_font); +} else { + $normal_font = $default_font; +} +my %normal_font = $t->fontActual($normal_font); +my $bold_font = $t->fontCreate(%normal_font, -weight => "bold"); + +# Set up different colors for the various window outputs +#$t->tagConfigure('prompt', -underline => 'true'); +$t->tagConfigure('prompt', -foreground => 'blue', -font => $bold_font); +$t->tagConfigure('result', -foreground => 'purple'); +$t->tagConfigure('error', -foreground => 'red'); +$t->tagConfigure('output', -foreground => 'blue'); + +# The tag 'limit' is the beginning of the input command line +$t->markSet('limit', 'insert'); +$t->markGravity('limit', 'left'); + +# redirect stdout +#tie (*STDOUT, 'Tk::Text', $t); +tie (*STDOUT, 'Tk::ptksh'); +#tie (*STDERR, 'Tk::ptksh'); + +# Print banner +print "$NAME V$VERSION"; +print " perl V$] Tk V$Tk::VERSION MainWindow -> \$mw\n"; +print "\n\t\@INC:\n"; +foreach (@INC) { print "\t $_\n" }; +print "Type 'h<Return>' at the prompt for help\n"; + +##### Read .ptkshinit +if ( -r $INITFILE) + { + print "Reading $INITFILE ...\n"; + package main; + do $Tk::ptksh::INITFILE; + package Tk::ptksh; + } + +###### Source the file if given as argument 0 +if (defined($ARGV[0]) && -r $ARGV[0]) + { + print "Reading $ARGV[0] ...\n"; + package main; + do $ARGV[0]; + package Tk::ptksh; + } + +##### Read history +@hist = (); +if ( -r $HISTFILE and open(HIST, $HISTFILE) ) { + print "Reading history ...\n"; + my $c = ""; + while (<HIST>) { + chomp; + $c .= $_; + if ($_ !~ /\\$/) { #end of command if no trailing "\" + push @hist, $c; + $c = ""; + } else { + chop $c; # kill trailing "\" + $c .= "\n"; + } + } + close HIST; +} + +##### Initial prompt +Prompt($PROMPT); +$Tk::ptksh::mw->focus; +$t->focus; +#$mw->after(1000, sub {print STDERR "now\n"; $mw->focus; $t->focus;}); + +##### Now enter main loop +#$mw->afterIdle(sub {Center($mw);}); +MainLoop(); + +####### Callbacks/etc. + +# EvalInput -- Eval the input area (between 'limit' and 'insert') +# in package main; +use vars qw($command $result); # use globals instead of "my" to avoid conflict w/ 'eval' +sub EvalInput { + # If return is hit when not inside the command entry range, reprompt + if ($t->compare('insert', '<=', 'limit')) { + $t->markSet('insert', 'end'); + Prompt($PROMPT); + Tk->break; + } + + # Support multi-line commands + if ($t->get('insert-1c', 'insert') eq "\\") { + $t->insert('insert', "\n"); + $t->insert('insert', "> ", 'prompt'); # must use this pattern for continue + $t->see('insert'); + Tk->break; + } + + # Get the command and strip out continuations + $command = $t->get('limit','end'); + $t->markSet('insert','end'); + $command =~ s/\\\n>\s/\n/mg; + + # Eval it + if ( $command !~ /^\s*$/) { + chomp $command; + push(@hist, $command) + unless @hist && ($command eq $hist[$#hist]); #could elim more redundancy + + $t->insert('insert', "\n"); + + $isStartOfCommand = 1; + + $command = PtkshCommand($command); + + exit if ($command eq 'exit'); + + package main; + no strict; + $Tk::ptksh::result = eval "local \$^W=0; $Tk::ptksh::command;"; + use strict; + package Tk::ptksh; + + if ($t->compare('insert', '!=', 'insert linestart')) { + $t->insert('insert', "\n"); + } + if ($@) { + $t->insert('insert', '## ' . $@, 'error'); + } else { + $result = "" if !defined($result); + $t->insert('insert', '# ' . $result, 'result'); + } + } + + Prompt($PROMPT); + + Tk->break; +} + +sub Prompt { + my $pr = shift; + + if ($t->compare('insert', '!=', 'insert linestart')) { + $t->insert('insert', "\n"); + } + + $t->insert('insert', $pr, 'prompt'); + $t->see('insert'); + $t->markSet('limit', 'insert'); + +} + +sub BackSpace { + if ($t->tagNextrange('sel', '1.0', 'end')) { + $t->delete('sel.first', 'sel.last'); + } elsif ($t->compare('insert', '>', 'limit')) { + $t->delete('insert-1c'); + $t->see('insert'); + } + Tk->break; +} + +sub BeginLine { + $t->SetCursor('limit'); + $t->break; +} + +sub Key { + my ($self, $k, $a) = @_; + #print "key event: ", $k, "\n"; + if ($t->compare('insert', '<', 'limit')) { + $t->markSet('insert', 'end'); + } + #$t->break; #for testing bindtags +} + +sub History { + Tk->break if defined($hist); + + $hist = $mw->Toplevel; + $hist->title('History'); + $list = $hist->ScrlListbox(-scrollbars => 'oe', + -width => 30, -height => 10, @FONT)->pack(qw(-fill both -expand 1)); + Center($hist); + $list->insert('end', @hist); + $list->see('end'); + $list->activate('end'); + $hist->bind('<Double-1>', \&HistPick); + $hist->bind('<Return>', \&HistPick); + $hist->bind('<Escape>', \&HistKill); + my $hist_mapped; # see above for $mw_mapped + $hist->bind('<Map>', sub {return if $hist_mapped && $hist_mapped>=2; Center($hist); $hist_mapped++;} ); + $hist->bind('<Destroy>', \&HistDestroy); + $hist->focus; + $list->focus; + $hist->grab; + #$mw->afterIdle(sub {Center($hist);}); + Tk->break; +} + +sub HistPick { + my $item = $list->get('active'); + return if (!$item); + $t->markSet('insert', 'end'); + $t->insert('insert',$item); + $t->see('insert'); + $mw->focus; + $t->focus; + HistKill(); +} + +sub HistKill { + if ($hist) { + $hist->grabRelease; + $hist->destroy; + } +} + +# Called from destroy event mapping +sub HistDestroy { + if (defined($hist) && (shift == $hist)) { + $hist = undef; + $mw->focus; + $t->focus; + } +} + +sub LastCommand { + if ($t->compare('insert', '==', 'limit')) { + $t->insert('insert', $hist[$#hist]); + $t->break; + } +} + +# Center a toplevel on screen or above parent +sub Center { + my $w = shift; + my ($x, $y); + + if ($w->parent) { + #print STDERR $w->screenwidth, " ", $w->width, "\n"; + $x = $w->parent->x + ($w->parent->width - $w->width)/2; + $y = $w->parent->y + ($w->parent->height - $w->height)/2; + } else { + #print STDERR $w->screenwidth, " ", $w->width, "\n"; + $x = ($w->screenwidth - $w->width)/2; + $y = ($w->screenheight - $w->height)/2; + } + $x = int($x); + $y = int($y); + my $g = "+$x+$y"; + #print STDERR "Setting geometry to $g\n"; + $w->geometry($g); +} + +# To deal with "TIE". +# We have to make sure the prints don't go into the command entry range. + +sub TIEHANDLE { # just to capture the tied calls + my $self = []; + return bless $self; + +} + +sub PRINT { + my ($bogus) = shift; + + $t->markSet('insert', 'end'); + + if ($isStartOfCommand) { # Then no prints have happened in this command yet so... + if ($t->compare('insert', '!=', 'insert linestart')) { + $t->insert('insert', "\n"); + } + # set flag so we know at least one print happened in this eval + $isStartOfCommand = 0; + } + + while (@_) { + $t->insert('end', shift, 'output'); + } + + $t->see('insert'); + + $t->markSet('limit', 'insert'); # don't interpret print as an input command +} + +sub PRINTF +{ + my $w = shift; + $w->PRINT(sprintf(shift,@_)); +} + +### +### Utility function +### + +sub _o + { + my $w = shift; + my $what = shift; + + $what =~ s/^\s+//; + $what =~ s/\s+$//; + my (@opt) = split " ", $what; + + print 'o(', join('|', @opt), ")\n"; + require Tk::Pretty; + + # check for regexp + if ($opt[0] =~ s|^/(.*)/$|$1|) + { + print "options matching /$opt[0]/:\n"; + foreach ($w->configure()) + { + print Tk::Pretty::Pretty($_),"\n" if $_->[0] =~ /\Q$opt[0]\E/; + } + return; + } + + # list of options (allow as bar words) + foreach (@opt) + { + s/^['"]//; + s/,$//; + s/['"]$//; + s/^([^-])/-$1/; + } + if (length $what) + { + foreach (@opt) + { + print Tk::Pretty::Pretty($w->configure($_)),"\n"; + } + } + else + { + foreach ($w->configure()) { print Tk::Pretty::Pretty($_),"\n" } + } + } + +sub _p { + foreach (@_) { print $_, "|\n"; } +} + +use vars qw($u_init %u_last $u_cnt); +$u_init = 0; +%u_last = (); +sub _u { + my $module = shift; + if (defined($module) and $module ne '') { + $module = "Tk/".ucfirst($module).".pm" unless $module =~ /^Tk/; + print " --- Loading $module ---\n"; + require "$module"; + print $@ if $@; + } else { + %u_last = () if defined $module; + $u_cnt = 0; + foreach (sort keys %INC) { + next if exists $u_last{$_}; + $u_cnt++; + $u_last{$_} = 1; + #next if m,^/, and m,\.ix$,; # Ignore autoloader files + #next if m,\.ix$,; # Ignore autoloader files + + if (length($_) < 20 ) { + printf "%-20s -> %s\n", $_, $INC{$_}; + } else { + print "$_ -> $INC{$_}\n"; + } + } + print STDERR "No modules loaded since last 'u' command (or startup)\n" + unless $u_cnt; + } +} + +sub _d + { + require Data::Dumper; + local $Data::Dumper::Deparse; + $Data::Dumper::Deparse = 1; + print Data::Dumper::Dumper(@_); + } + +sub _h + { + print <<'EOT'; + + ? or h print this message + d or x arg,... calls Data::Dumper::Dumper + p arg,... print args, each on a line and "|\n" + o $w /regexp/ print options of widget matching regexp + o $w [opt ...] print (all) options of widget + u xxx xxx = string : load Tk::Xxx + = '' : list all modules loaded + = undef : list modules loaded since last u call + (or after ptksh startup) + + Press <Up> (the "up arrow" key) for command history + Press <Escape> to leave command history window + Type "exit" to quit (saves history) + Type \<Return> for continuation of command to following line + +EOT +} + + +# Substitute our special commands into the command line +sub PtkshCommand { + $_ = shift; + + foreach ($_) { + last if s/^\?\s*$/Tk::ptksh::_h /; + last if s/^h\s*$/Tk::ptksh::_h /; + last if s/^u(\s+|$)/Tk::ptksh::_u /; + last if s/^[dx]\s+/Tk::ptksh::_d /; + last if s/^u\s+(\S+)/Tk::ptksh::_u('$1')/; + last if s/^p\s+(.*)$/Tk::ptksh::_p $1;/; + last if s/^o\s+(\S+)\s*?$/Tk::ptksh::_o $1;/; + last if s/^o\s+(\S+)\s*,?\s+(.*)?$/Tk::ptksh::_o $1, '$2';/; + } + %u_last = %INC unless $u_init++; + + # print STDERR "Command is: $_\n"; + + $_; +} + +### +### Save History -- use Data::Dumper to preserve multiline commands +### + +END { + if ($HISTFILE) { # because this is probably perl -c if $HISTFILE is not set + $#hist-- if $hist[-1] =~ /^(q$|x$|\s*exit\b)/; # chop off the exit command + + @hist = @hist[($#hist-$HISTSAVE)..($#hist)] if $#hist > $HISTSAVE; + + if( open HIST, ">$HISTFILE" ) { + while ($_ = shift(@hist)) { + s/\n/\\\n/mg; + print HIST "$_\n"; + } + close HIST; + } else { + print STDERR "Error: Unable to open history file '$HISTFILE'\n"; + } + } +} + +1; # just in case we decide to be "use"'able in the future. diff --git a/Master/tlpkg/tlperl/bin/ptksh.bat b/Master/tlpkg/tlperl/bin/ptksh.bat new file mode 100755 index 00000000000..ff42a69076f --- /dev/null +++ b/Master/tlpkg/tlperl/bin/ptksh.bat @@ -0,0 +1,746 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+#
+# PTKSH 2.0
+#
+# A graphical user interface for testing Perl/Tk commands and scripts.
+#
+# VERSION HISTORY:
+# ...truncated earlier stuff...
+# 4/23/98 V1.7 Achim Bohnet -- some fixes to "o" command
+# 6/08/98 V2.01 M. Beller -- merge in GUI code for "wish"-like interface
+#
+# 2.01d1 6/6/98 First development version
+#
+# 2.01d2 6/7/98
+# - apply A.B. patch for pod and -option
+# - fix "use of uninitialized variable" in END{ } block (for -c option)
+# - support h and ? only for help
+# - misc. pod fixes (PITFALLS)
+# - use default fonts and default colors ## NOT YET--still working on it
+# - get rid of Data::Dumper for history
+#
+# 2.01d3 6/8/98
+# - Remove "use Data::Dumper" line
+# - Put in hack for unix vs. win32 window manager focus problem
+# - Achim's pod and histfile patch
+#
+# 2.01d4 6/18/98
+# - Slaven's patch to make <Home> work properly
+# - Add help message to banner (per Steve Lydie)
+# - Fix horizontal scrolling (turn off wrapping in console window)
+# - Clarify <Up> in docs and help means "up arrow"
+# - Use HOMEDRIVE/HOMEPATH on Win32
+#
+# For more history look at the various Changes files in the Perl/Tk
+# distribution.
+
+=head1 NAME
+
+ptksh - Perl/Tk script to provide a graphical user interface for testing Perl/Tk
+commands and scripts.
+
+=head1 SYNOPSIS
+
+ % ptksh ?scriptfile?
+ ... version information ...
+ ptksh> $b=$mw->Button(-text=>'Hi',-command=>sub{print 'Hi'})
+ ptksh> $b->pack
+ ptksh> o $b
+ ... list of options ...
+ ptksh> help
+ ... help information ...
+ ptksh> exit
+ %
+
+
+=head1 DESCRIPTION
+
+ptksh is a perl/Tk shell to enter perl commands
+interactively. When one starts ptksh a L<MainWindow|Tk::MainWindow>
+is automaticly created, along with a ptksh command window.
+One can access the main window by typing commands using the
+variable $mw at the 'ptksh> ' prompt of the command window.
+
+ptksh supports command line editing and history. Just type "<Up>" at
+the command prompt to see a history list. The last 50 commands entered
+are saved, then reloaded into history list the next time you start ptksh.
+
+ptksh supports some convenient commands for inspecting Tk widgets. See below.
+
+To exit ptksh use: C<exit>.
+
+ptksh is B<*not*> a full symbolic debugger.
+To debug perl/Tk programs at a low level use the more powerful
+L<perl debugger|perldebug>. (Just enter ``O tk'' on debuggers
+command line to start the Tk eventloop.)
+
+=head1 FEATURES
+
+=head2 History
+
+Press <Up> (the Up Arrow) in the perlwish window to obtain a gui-based history list.
+Press <Enter> on any history line to enter it into the perlwish window.
+Then hit return. So, for example, repeat last command is <Up><Enter><Enter>.
+You can quit the history window with <Escape>. NOTE: history is only saved
+if exit is "graceful" (i.e. by the "exit" command from the console or by
+quitting all main windows--NOT by interrupt).
+
+=head2 Debugging Support
+
+ptksh provides some convenience function to make browsing
+in perl/Tk widget easier:
+
+=over 4
+
+=item B<?>, or B<h>
+
+displays a short help summary.
+
+=item B<d>, or B<x> ?I<args>, ...?
+
+Dumps recursively arguments to stdout. (see L<Data::Dumper>).
+You must have <Data::Dumper> installed to support this feature.
+
+B<x> was introduced for perl debugger compatibility.
+
+=item B<p> ?I<arg>, ...?
+
+appends "|\n" to each of it's arguments and prints it.
+If value is B<undef>, '(undef)' is printed to stdout.
+
+=item B<o> I<$widget> ?I<-option> ...?
+
+prints the option(s) of I<$widget> one on each line.
+If no options are given all options of the widget are
+listed. See L<Tk::options> for more details on the
+format and contents of the returned list.
+
+=item B<o> I<$widget> B</>I<regexp>B</>
+
+Lists options of I<$widget> matching the
+L<regular expression|perlre> I<regexp>.
+
+=item B<u> ?I<class>?
+
+If no argument is given it lists the modules loaded
+by the commands you executed or since the last time you
+called C<u>.
+
+If argument is the empty string lists all modules that are
+loaded by ptksh.
+
+If argument is a string, ``text'' it tries to do a ``use Tk::Text;''.
+
+=back
+
+=head2 Packages
+
+Ptksh compiles into package Tk::ptksh. Your code is eval'ed into package
+main. The coolness of this is that your eval code should not interfere with
+ptksh itself.
+
+=head2 Multiline Commands
+
+ptksh will accept multiline commands. Simply put a "\" character immediately
+before the newline, and ptksh will continue your command onto the next line.
+
+=head2 Source File Support
+
+If you have a perl/Tk script that you want to do debugging on, try running the
+command
+
+ ptksh> do 'myscript';
+
+ -- or (at shell command prompt) --
+
+ % ptksh myscript
+
+Then use the perl/Tk commands to try out different operations on your script.
+
+=head1 ENVIRONMENT
+
+Looks for your .ptksh_history in the directory specified by
+the $HOME environment variable ($HOMEPATH on Win32 systems).
+
+=head1 FILES
+
+=over 4
+
+=item F<.ptksh_init>
+
+If found in current directory it is read in an evaluated
+after the mainwindow I<$mw> is created. F<.ptksh_init>
+can contain any valid perl code.
+
+=item F<~/.ptksh_history>
+
+Contains the last 50 lines entered in ptksh session(s).
+
+=back
+
+=head1 PITFALLS
+
+It is best not to use "my" in the commands you type into ptksh.
+For example "my $v" will make $v local just to the command or commands
+entered until <Return> is pressed.
+For a related reason, there are no file-scopy "my" variables in the
+ptksh code itself (else the user might trounce on them by accident).
+
+=head1 BUGS
+
+B<Tk::MainLoop> function interactively entered or sourced in a
+init or script file will block ptksh.
+
+=head1 SEE ALSO
+
+L<Tk|Tk>
+L<perldebug|perldebug>
+
+=head1 VERSION
+
+VERSION 2.03
+
+=head1 AUTHORS
+
+Mike Beller <beller@penvision.com>,
+Achim Bohnet <ach@mpe.mpg.de>
+
+Copyright (c) 1996 - 1998 Achim Bohnet and Mike Beller. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+package Tk::ptksh;
+require 5.004;
+use strict;
+use Tk;
+
+##### Constants
+
+use vars qw($NAME $VERSION $FONT @FONT $WIN32 $HOME $HISTFILE $HISTSAVE $PROMPT $INITFILE);
+
+$NAME = 'ptksh';
+$VERSION = '2.03';
+$WIN32 = 1 if $^O =~ /Win32/;
+$HOME = $WIN32 ? ($ENV{HOMEDRIVE} . $ENV{HOMEPATH}) || 'C:\\' : $ENV{HOME} . "/";
+@FONT = ($WIN32 ? (-font => 'systemfixed') : () );
+#@FONT = ($WIN32 ? (-font => ['courier', 9, 'normal']) : () );
+$HISTFILE = "${HOME}.${NAME}_history";
+$HISTSAVE = 50;
+$INITFILE = ".${NAME}_init";
+$PROMPT = "$NAME> ";
+
+sub Win32Fix { my $p = shift; $p =~ s'\\'/'g; $p =~ s'/$''; return $p }
+
+use vars qw($mw $st $t @hist $hist $list $isStartOfCommand);
+
+# NOTE: mainwindow creation order seems to impact who gets focus, and
+# order is different on Win32 & *nix!! So hack is to create the windows
+# in an order dependent on the OS!
+
+$mw = Tk::MainWindow->new unless $WIN32; # &&& hack to work around focus problem
+
+##### set up user's main window
+package main;
+$main::mw = Tk::MainWindow->new;
+$main::mw->title('$mw');
+$main::mw->geometry("+1+1");
+package Tk::ptksh;
+
+##### Set up ptksh windows
+$mw = Tk::MainWindow->new if $WIN32; # &&& hack to work around focus problem
+$mw->title($NAME);
+$st = $mw->Scrolled('Text', -scrollbars => 'osoe',
+ -wrap => 'none',
+ -width => 80, -height => 25, @FONT);
+$t = $st->Subwidget('scrolled');
+$st->pack(-fill => 'both', -expand => 'true');
+# $mw_mapped assures that Center is only called exactly twice: first time
+# will determine geometry of window, second time centering will work.
+# I observed a couple of further <Map> events, which are now ignored
+# and thus window creation seems to be faster now.
+my $mw_mapped;
+$mw->bind('<Map>', sub {return if $mw_mapped && $mw_mapped>=2; Center($mw); $mw_mapped++;} );
+
+# Event bindings
+$t->bindtags([$t, ref($t), $t->toplevel, 'all']); # take first crack at events
+$t->bind('<Return>', \&EvalInput);
+$t->bind('<BackSpace>', \&BackSpace);
+$t->bind('<Escape>', \&HistKill);
+$t->bind('<Up>', \&History);
+$t->bind('<Control-a>', \&BeginLine);
+$t->bind('<Home>', \&BeginLine);
+$t->bind('<Any-KeyPress>', [\&Key, Tk::Ev('K'), Tk::Ev('A')]);
+
+my $default_font = $t->cget(-font);
+my %default_font = $t->fontActual($default_font);
+my $normal_font;
+if (!$t->fontMetrics($default_font, '-fixed')) {
+ $normal_font = $t->fontCreate(%default_font, -family => "courier");
+ $t->configure(-font => $normal_font);
+} else {
+ $normal_font = $default_font;
+}
+my %normal_font = $t->fontActual($normal_font);
+my $bold_font = $t->fontCreate(%normal_font, -weight => "bold");
+
+# Set up different colors for the various window outputs
+#$t->tagConfigure('prompt', -underline => 'true');
+$t->tagConfigure('prompt', -foreground => 'blue', -font => $bold_font);
+$t->tagConfigure('result', -foreground => 'purple');
+$t->tagConfigure('error', -foreground => 'red');
+$t->tagConfigure('output', -foreground => 'blue');
+
+# The tag 'limit' is the beginning of the input command line
+$t->markSet('limit', 'insert');
+$t->markGravity('limit', 'left');
+
+# redirect stdout
+#tie (*STDOUT, 'Tk::Text', $t);
+tie (*STDOUT, 'Tk::ptksh');
+#tie (*STDERR, 'Tk::ptksh');
+
+# Print banner
+print "$NAME V$VERSION";
+print " perl V$] Tk V$Tk::VERSION MainWindow -> \$mw\n";
+print "\n\t\@INC:\n";
+foreach (@INC) { print "\t $_\n" };
+print "Type 'h<Return>' at the prompt for help\n";
+
+##### Read .ptkshinit
+if ( -r $INITFILE)
+ {
+ print "Reading $INITFILE ...\n";
+ package main;
+ do $Tk::ptksh::INITFILE;
+ package Tk::ptksh;
+ }
+
+###### Source the file if given as argument 0
+if (defined($ARGV[0]) && -r $ARGV[0])
+ {
+ print "Reading $ARGV[0] ...\n";
+ package main;
+ do $ARGV[0];
+ package Tk::ptksh;
+ }
+
+##### Read history
+@hist = ();
+if ( -r $HISTFILE and open(HIST, $HISTFILE) ) {
+ print "Reading history ...\n";
+ my $c = "";
+ while (<HIST>) {
+ chomp;
+ $c .= $_;
+ if ($_ !~ /\\$/) { #end of command if no trailing "\"
+ push @hist, $c;
+ $c = "";
+ } else {
+ chop $c; # kill trailing "\"
+ $c .= "\n";
+ }
+ }
+ close HIST;
+}
+
+##### Initial prompt
+Prompt($PROMPT);
+$Tk::ptksh::mw->focus;
+$t->focus;
+#$mw->after(1000, sub {print STDERR "now\n"; $mw->focus; $t->focus;});
+
+##### Now enter main loop
+#$mw->afterIdle(sub {Center($mw);});
+MainLoop();
+
+####### Callbacks/etc.
+
+# EvalInput -- Eval the input area (between 'limit' and 'insert')
+# in package main;
+use vars qw($command $result); # use globals instead of "my" to avoid conflict w/ 'eval'
+sub EvalInput {
+ # If return is hit when not inside the command entry range, reprompt
+ if ($t->compare('insert', '<=', 'limit')) {
+ $t->markSet('insert', 'end');
+ Prompt($PROMPT);
+ Tk->break;
+ }
+
+ # Support multi-line commands
+ if ($t->get('insert-1c', 'insert') eq "\\") {
+ $t->insert('insert', "\n");
+ $t->insert('insert', "> ", 'prompt'); # must use this pattern for continue
+ $t->see('insert');
+ Tk->break;
+ }
+
+ # Get the command and strip out continuations
+ $command = $t->get('limit','end');
+ $t->markSet('insert','end');
+ $command =~ s/\\\n>\s/\n/mg;
+
+ # Eval it
+ if ( $command !~ /^\s*$/) {
+ chomp $command;
+ push(@hist, $command)
+ unless @hist && ($command eq $hist[$#hist]); #could elim more redundancy
+
+ $t->insert('insert', "\n");
+
+ $isStartOfCommand = 1;
+
+ $command = PtkshCommand($command);
+
+ exit if ($command eq 'exit');
+
+ package main;
+ no strict;
+ $Tk::ptksh::result = eval "local \$^W=0; $Tk::ptksh::command;";
+ use strict;
+ package Tk::ptksh;
+
+ if ($t->compare('insert', '!=', 'insert linestart')) {
+ $t->insert('insert', "\n");
+ }
+ if ($@) {
+ $t->insert('insert', '## ' . $@, 'error');
+ } else {
+ $result = "" if !defined($result);
+ $t->insert('insert', '# ' . $result, 'result');
+ }
+ }
+
+ Prompt($PROMPT);
+
+ Tk->break;
+}
+
+sub Prompt {
+ my $pr = shift;
+
+ if ($t->compare('insert', '!=', 'insert linestart')) {
+ $t->insert('insert', "\n");
+ }
+
+ $t->insert('insert', $pr, 'prompt');
+ $t->see('insert');
+ $t->markSet('limit', 'insert');
+
+}
+
+sub BackSpace {
+ if ($t->tagNextrange('sel', '1.0', 'end')) {
+ $t->delete('sel.first', 'sel.last');
+ } elsif ($t->compare('insert', '>', 'limit')) {
+ $t->delete('insert-1c');
+ $t->see('insert');
+ }
+ Tk->break;
+}
+
+sub BeginLine {
+ $t->SetCursor('limit');
+ $t->break;
+}
+
+sub Key {
+ my ($self, $k, $a) = @_;
+ #print "key event: ", $k, "\n";
+ if ($t->compare('insert', '<', 'limit')) {
+ $t->markSet('insert', 'end');
+ }
+ #$t->break; #for testing bindtags
+}
+
+sub History {
+ Tk->break if defined($hist);
+
+ $hist = $mw->Toplevel;
+ $hist->title('History');
+ $list = $hist->ScrlListbox(-scrollbars => 'oe',
+ -width => 30, -height => 10, @FONT)->pack(qw(-fill both -expand 1));
+ Center($hist);
+ $list->insert('end', @hist);
+ $list->see('end');
+ $list->activate('end');
+ $hist->bind('<Double-1>', \&HistPick);
+ $hist->bind('<Return>', \&HistPick);
+ $hist->bind('<Escape>', \&HistKill);
+ my $hist_mapped; # see above for $mw_mapped
+ $hist->bind('<Map>', sub {return if $hist_mapped && $hist_mapped>=2; Center($hist); $hist_mapped++;} );
+ $hist->bind('<Destroy>', \&HistDestroy);
+ $hist->focus;
+ $list->focus;
+ $hist->grab;
+ #$mw->afterIdle(sub {Center($hist);});
+ Tk->break;
+}
+
+sub HistPick {
+ my $item = $list->get('active');
+ return if (!$item);
+ $t->markSet('insert', 'end');
+ $t->insert('insert',$item);
+ $t->see('insert');
+ $mw->focus;
+ $t->focus;
+ HistKill();
+}
+
+sub HistKill {
+ if ($hist) {
+ $hist->grabRelease;
+ $hist->destroy;
+ }
+}
+
+# Called from destroy event mapping
+sub HistDestroy {
+ if (defined($hist) && (shift == $hist)) {
+ $hist = undef;
+ $mw->focus;
+ $t->focus;
+ }
+}
+
+sub LastCommand {
+ if ($t->compare('insert', '==', 'limit')) {
+ $t->insert('insert', $hist[$#hist]);
+ $t->break;
+ }
+}
+
+# Center a toplevel on screen or above parent
+sub Center {
+ my $w = shift;
+ my ($x, $y);
+
+ if ($w->parent) {
+ #print STDERR $w->screenwidth, " ", $w->width, "\n";
+ $x = $w->parent->x + ($w->parent->width - $w->width)/2;
+ $y = $w->parent->y + ($w->parent->height - $w->height)/2;
+ } else {
+ #print STDERR $w->screenwidth, " ", $w->width, "\n";
+ $x = ($w->screenwidth - $w->width)/2;
+ $y = ($w->screenheight - $w->height)/2;
+ }
+ $x = int($x);
+ $y = int($y);
+ my $g = "+$x+$y";
+ #print STDERR "Setting geometry to $g\n";
+ $w->geometry($g);
+}
+
+# To deal with "TIE".
+# We have to make sure the prints don't go into the command entry range.
+
+sub TIEHANDLE { # just to capture the tied calls
+ my $self = [];
+ return bless $self;
+
+}
+
+sub PRINT {
+ my ($bogus) = shift;
+
+ $t->markSet('insert', 'end');
+
+ if ($isStartOfCommand) { # Then no prints have happened in this command yet so...
+ if ($t->compare('insert', '!=', 'insert linestart')) {
+ $t->insert('insert', "\n");
+ }
+ # set flag so we know at least one print happened in this eval
+ $isStartOfCommand = 0;
+ }
+
+ while (@_) {
+ $t->insert('end', shift, 'output');
+ }
+
+ $t->see('insert');
+
+ $t->markSet('limit', 'insert'); # don't interpret print as an input command
+}
+
+sub PRINTF
+{
+ my $w = shift;
+ $w->PRINT(sprintf(shift,@_));
+}
+
+###
+### Utility function
+###
+
+sub _o
+ {
+ my $w = shift;
+ my $what = shift;
+
+ $what =~ s/^\s+//;
+ $what =~ s/\s+$//;
+ my (@opt) = split " ", $what;
+
+ print 'o(', join('|', @opt), ")\n";
+ require Tk::Pretty;
+
+ # check for regexp
+ if ($opt[0] =~ s|^/(.*)/$|$1|)
+ {
+ print "options matching /$opt[0]/:\n";
+ foreach ($w->configure())
+ {
+ print Tk::Pretty::Pretty($_),"\n" if $_->[0] =~ /\Q$opt[0]\E/;
+ }
+ return;
+ }
+
+ # list of options (allow as bar words)
+ foreach (@opt)
+ {
+ s/^['"]//;
+ s/,$//;
+ s/['"]$//;
+ s/^([^-])/-$1/;
+ }
+ if (length $what)
+ {
+ foreach (@opt)
+ {
+ print Tk::Pretty::Pretty($w->configure($_)),"\n";
+ }
+ }
+ else
+ {
+ foreach ($w->configure()) { print Tk::Pretty::Pretty($_),"\n" }
+ }
+ }
+
+sub _p {
+ foreach (@_) { print $_, "|\n"; }
+}
+
+use vars qw($u_init %u_last $u_cnt);
+$u_init = 0;
+%u_last = ();
+sub _u {
+ my $module = shift;
+ if (defined($module) and $module ne '') {
+ $module = "Tk/".ucfirst($module).".pm" unless $module =~ /^Tk/;
+ print " --- Loading $module ---\n";
+ require "$module";
+ print $@ if $@;
+ } else {
+ %u_last = () if defined $module;
+ $u_cnt = 0;
+ foreach (sort keys %INC) {
+ next if exists $u_last{$_};
+ $u_cnt++;
+ $u_last{$_} = 1;
+ #next if m,^/, and m,\.ix$,; # Ignore autoloader files
+ #next if m,\.ix$,; # Ignore autoloader files
+
+ if (length($_) < 20 ) {
+ printf "%-20s -> %s\n", $_, $INC{$_};
+ } else {
+ print "$_ -> $INC{$_}\n";
+ }
+ }
+ print STDERR "No modules loaded since last 'u' command (or startup)\n"
+ unless $u_cnt;
+ }
+}
+
+sub _d
+ {
+ require Data::Dumper;
+ local $Data::Dumper::Deparse;
+ $Data::Dumper::Deparse = 1;
+ print Data::Dumper::Dumper(@_);
+ }
+
+sub _h
+ {
+ print <<'EOT';
+
+ ? or h print this message
+ d or x arg,... calls Data::Dumper::Dumper
+ p arg,... print args, each on a line and "|\n"
+ o $w /regexp/ print options of widget matching regexp
+ o $w [opt ...] print (all) options of widget
+ u xxx xxx = string : load Tk::Xxx
+ = '' : list all modules loaded
+ = undef : list modules loaded since last u call
+ (or after ptksh startup)
+
+ Press <Up> (the "up arrow" key) for command history
+ Press <Escape> to leave command history window
+ Type "exit" to quit (saves history)
+ Type \<Return> for continuation of command to following line
+
+EOT
+}
+
+
+# Substitute our special commands into the command line
+sub PtkshCommand {
+ $_ = shift;
+
+ foreach ($_) {
+ last if s/^\?\s*$/Tk::ptksh::_h /;
+ last if s/^h\s*$/Tk::ptksh::_h /;
+ last if s/^u(\s+|$)/Tk::ptksh::_u /;
+ last if s/^[dx]\s+/Tk::ptksh::_d /;
+ last if s/^u\s+(\S+)/Tk::ptksh::_u('$1')/;
+ last if s/^p\s+(.*)$/Tk::ptksh::_p $1;/;
+ last if s/^o\s+(\S+)\s*?$/Tk::ptksh::_o $1;/;
+ last if s/^o\s+(\S+)\s*,?\s+(.*)?$/Tk::ptksh::_o $1, '$2';/;
+ }
+ %u_last = %INC unless $u_init++;
+
+ # print STDERR "Command is: $_\n";
+
+ $_;
+}
+
+###
+### Save History -- use Data::Dumper to preserve multiline commands
+###
+
+END {
+ if ($HISTFILE) { # because this is probably perl -c if $HISTFILE is not set
+ $#hist-- if $hist[-1] =~ /^(q$|x$|\s*exit\b)/; # chop off the exit command
+
+ @hist = @hist[($#hist-$HISTSAVE)..($#hist)] if $#hist > $HISTSAVE;
+
+ if( open HIST, ">$HISTFILE" ) {
+ while ($_ = shift(@hist)) {
+ s/\n/\\\n/mg;
+ print HIST "$_\n";
+ }
+ close HIST;
+ } else {
+ print STDERR "Error: Unable to open history file '$HISTFILE'\n";
+ }
+ }
+}
+
+1; # just in case we decide to be "use"'able in the future.
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/pwhich b/Master/tlpkg/tlperl/bin/pwhich new file mode 100755 index 00000000000..a20dc07fff0 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pwhich @@ -0,0 +1,141 @@ +#!/usr/bin/perl + +use 5.004; +use strict; +use File::Which (); +use Getopt::Std (); + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '1.09'; +} + +# Handle options +my %opts = (); +Getopt::Std::getopts('av', \%opts); + +if ( $opts{v} ) { + print <<"END_TEXT"; +This is pwhich running File::Which version $File::Which::VERSION + +Copyright 2002 Per Einar Ellefsen. + +Some parts copyright 2009 Adam Kennedy. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. +END_TEXT + + exit(0); +} + +unless ( @ARGV ) { + print <<"END_TEXT"; +Usage: $0 [-a] [-v] programname [programname ...] + -a Print all matches in PATH, not just the first. + -v Prints version and exits + +END_TEXT + + exit(0); +} + +foreach my $file ( @ARGV ) { + my @result = $opts{a} + ? File::Which::which($file) + # Need to force scalar + : scalar File::Which::which($file); + + # We might end up with @result = (undef) -> 1 elem + @result = () unless defined $result[0]; + foreach my $result ( @result ) { + print "$result\n" if $result; + } + unless ( @result ) { + print STDERR "pwhich: no $file in PATH\n"; + exit(255); + } +} + +exit(0); + +__END__ + +=pod + +=head1 NAME + +pwhich - Perl-only `which' + +=head1 SYNOPSIS + + $ pwhich perl + $ pwhich -a perl # print all matches + $ pwhich perl perldoc ... # look for multiple programs + $ pwhich -a perl perldoc ... + +=head1 DESCRIPTION + +`pwhich' is a command-line utility program for finding paths to other +programs based on the user's C<PATH>. It is similar to the usualy Unix +tool `which', and tries to emulate its functionality, but is written +purely in Perl (uses the module C<File::Which>), so is portable. + +=head2 Calling syntax + + $ pwhich [-a] [-v] programname [programname ...] + +=head2 Options + +=over + +=item -a + +The option I<-a> will make C<pwhich> print all matches found in the +C<PATH> variable instead of just the first one. Each match is printed +on a separate line. + +=item -v + +Prints version (of C<File::Which>) and copyright notice and exits. + +=back + +=head1 SUPPORT + +Bugs should be reported via the CPAN bug tracker at + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Which> + +For other issues, contact the maintainer. + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt> + +Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet +(for the mod_perl site) and Win32-awareness by me, with slight modifications +by Stas Bekman, then extracted to create C<File::Which>. + +Version 0.04 had some significant platform-related changes, taken from +the Perl Power Tools C<`which'> implementation by Abigail with +enhancements from Peter Prymmer. See +L<http://www.perl.com/language/ppt/src/which/index.html> for more +information. + +=head1 COPYRIGHT + +Copyright 2002 Per Einar Ellefsen. + +Some parts copyright 2009 Adam Kennedy. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<perl>, L<File::Which>, L<which(1)> + +=cut diff --git a/Master/tlpkg/tlperl/bin/pwhich.bat b/Master/tlpkg/tlperl/bin/pwhich.bat new file mode 100755 index 00000000000..191949207d3 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/pwhich.bat @@ -0,0 +1,157 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/bin/perl
+#line 15
+
+use 5.004;
+use strict;
+use File::Which ();
+use Getopt::Std ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.09';
+}
+
+# Handle options
+my %opts = ();
+Getopt::Std::getopts('av', \%opts);
+
+if ( $opts{v} ) {
+ print <<"END_TEXT";
+This is pwhich running File::Which version $File::Which::VERSION
+
+Copyright 2002 Per Einar Ellefsen.
+
+Some parts copyright 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+END_TEXT
+
+ exit(0);
+}
+
+unless ( @ARGV ) {
+ print <<"END_TEXT";
+Usage: $0 [-a] [-v] programname [programname ...]
+ -a Print all matches in PATH, not just the first.
+ -v Prints version and exits
+
+END_TEXT
+
+ exit(0);
+}
+
+foreach my $file ( @ARGV ) {
+ my @result = $opts{a}
+ ? File::Which::which($file)
+ # Need to force scalar
+ : scalar File::Which::which($file);
+
+ # We might end up with @result = (undef) -> 1 elem
+ @result = () unless defined $result[0];
+ foreach my $result ( @result ) {
+ print "$result\n" if $result;
+ }
+ unless ( @result ) {
+ print STDERR "pwhich: no $file in PATH\n";
+ exit(255);
+ }
+}
+
+exit(0);
+
+__END__
+
+=pod
+
+=head1 NAME
+
+pwhich - Perl-only `which'
+
+=head1 SYNOPSIS
+
+ $ pwhich perl
+ $ pwhich -a perl # print all matches
+ $ pwhich perl perldoc ... # look for multiple programs
+ $ pwhich -a perl perldoc ...
+
+=head1 DESCRIPTION
+
+`pwhich' is a command-line utility program for finding paths to other
+programs based on the user's C<PATH>. It is similar to the usualy Unix
+tool `which', and tries to emulate its functionality, but is written
+purely in Perl (uses the module C<File::Which>), so is portable.
+
+=head2 Calling syntax
+
+ $ pwhich [-a] [-v] programname [programname ...]
+
+=head2 Options
+
+=over
+
+=item -a
+
+The option I<-a> will make C<pwhich> print all matches found in the
+C<PATH> variable instead of just the first one. Each match is printed
+on a separate line.
+
+=item -v
+
+Prints version (of C<File::Which>) and copyright notice and exits.
+
+=back
+
+=head1 SUPPORT
+
+Bugs should be reported via the CPAN bug tracker at
+
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Which>
+
+For other issues, contact the maintainer.
+
+=head1 AUTHOR
+
+Adam Kennedy E<lt>adamk@cpan.orgE<gt>
+
+Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt>
+
+Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet
+(for the mod_perl site) and Win32-awareness by me, with slight modifications
+by Stas Bekman, then extracted to create C<File::Which>.
+
+Version 0.04 had some significant platform-related changes, taken from
+the Perl Power Tools C<`which'> implementation by Abigail with
+enhancements from Peter Prymmer. See
+L<http://www.perl.com/language/ppt/src/which/index.html> for more
+information.
+
+=head1 COPYRIGHT
+
+Copyright 2002 Per Einar Ellefsen.
+
+Some parts copyright 2009 Adam Kennedy.
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<perl>, L<File::Which>, L<which(1)>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/runperl.bat b/Master/tlpkg/tlperl/bin/runperl.bat new file mode 100755 index 00000000000..8e8eb1ea948 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/runperl.bat @@ -0,0 +1,83 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+$0 =~ s|\.bat||i;
+unless (-f $0) {
+ $0 =~ s|.*[/\\]||;
+ for (".", split ';', $ENV{PATH}) {
+ $_ = "." if $_ eq "";
+ $0 = "$_/$0" , goto doit if -f "$_/$0";
+ }
+ die "`$0' not found.\n";
+}
+doit: exec "perl", "-x", $0, @ARGV;
+die "Failed to exec `$0': $!";
+__END__
+
+=head1 NAME
+
+runperl.bat - "universal" batch file to run perl scripts
+
+=head1 SYNOPSIS
+
+ C:\> copy runperl.bat foo.bat
+ C:\> foo
+ [..runs the perl script `foo'..]
+
+ C:\> foo.bat
+ [..runs the perl script `foo'..]
+
+
+=head1 DESCRIPTION
+
+This file can be copied to any file name ending in the ".bat" suffix.
+When executed on a DOS-like operating system, it will invoke the perl
+script of the same name, but without the ".bat" suffix. It will
+look for the script in the same directory as itself, and then in
+the current directory, and then search the directories in your PATH.
+
+It relies on the C<exec()> operator, so you will need to make sure
+that works in your perl.
+
+This method of invoking perl scripts has some advantages over
+batch-file wrappers like C<pl2bat.bat>: it avoids duplication
+of all the code; it ensures C<$0> contains the same name as the
+executing file, without any egregious ".bat" suffix; it allows
+you to separate your perl scripts from the wrapper used to
+run them; since the wrapper is generic, you can use symbolic
+links to simply link to C<runperl.bat>, if you are serving your
+files on a filesystem that supports that.
+
+On the other hand, if the batch file is invoked with the ".bat"
+suffix, it does an extra C<exec()>. This may be a performance
+issue. You can avoid this by running it without specifying
+the ".bat" suffix.
+
+Perl is invoked with the -x flag, so the script must contain
+a C<#!perl> line. Any flags found on that line will be honored.
+
+=head1 BUGS
+
+Perl is invoked with the -S flag, so it will search the PATH to find
+the script. This may have undesirable effects.
+
+=head1 SEE ALSO
+
+perl, perlwin32, pl2bat.bat
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/s2p.bat b/Master/tlpkg/tlperl/bin/s2p.bat new file mode 100755 index 00000000000..aaf9845505b --- /dev/null +++ b/Master/tlpkg/tlperl/bin/s2p.bat @@ -0,0 +1,2018 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+my $startperl;
+my $perlpath;
+($startperl = <<'/../') =~ s/\s*\z//;
+#!perl
+/../
+($perlpath = <<'/../') =~ s/\s*\z//;
+C:\strawberry\perl\bin\perl.exe
+/../
+
+$0 =~ s/^.*?(\w+)[\.\w]*$/$1/;
+
+# (p)sed - a stream editor
+# History: Aug 12 2000: Original version.
+# Mar 25 2002: Rearrange generated Perl program.
+# Jul 23 2007: Fix bug in regex stripping (M.Thorland)
+
+use strict;
+use integer;
+use Symbol;
+
+=head1 NAME
+
+psed - a stream editor
+
+=head1 SYNOPSIS
+
+ psed [-an] script [file ...]
+ psed [-an] [-e script] [-f script-file] [file ...]
+
+ s2p [-an] [-e script] [-f script-file]
+
+=head1 DESCRIPTION
+
+A stream editor reads the input stream consisting of the specified files
+(or standard input, if none are given), processes is line by line by
+applying a script consisting of edit commands, and writes resulting lines
+to standard output. The filename `C<->' may be used to read standard input.
+
+The edit script is composed from arguments of B<-e> options and
+script-files, in the given order. A single script argument may be specified
+as the first parameter.
+
+If this program is invoked with the name F<s2p>, it will act as a
+sed-to-Perl translator. See L<"sed Script Translation">.
+
+B<sed> returns an exit code of 0 on success or >0 if an error occurred.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>
+
+A file specified as argument to the B<w> edit command is by default
+opened before input processing starts. Using B<-a>, opening of such
+files is delayed until the first line is actually written to the file.
+
+=item B<-e> I<script>
+
+The editing commands defined by I<script> are appended to the script.
+Multiple commands must be separated by newlines.
+
+=item B<-f> I<script-file>
+
+Editing commands from the specified I<script-file> are read and appended
+to the script.
+
+=item B<-n>
+
+By default, a line is written to standard output after the editing script
+has been applied to it. The B<-n> option suppresses automatic printing.
+
+=back
+
+=head1 COMMANDS
+
+B<sed> command syntax is defined as
+
+Z<> Z<> Z<> Z<>[I<address>[B<,>I<address>]][B<!>]I<function>[I<argument>]
+
+with whitespace being permitted before or after addresses, and between
+the function character and the argument. The I<address>es and the
+address inverter (C<!>) are used to restrict the application of a
+command to the selected line(s) of input.
+
+Each command must be on a line of its own, except where noted in
+the synopses below.
+
+The edit cycle performed on each input line consist of reading the line
+(without its trailing newline character) into the I<pattern space>,
+applying the applicable commands of the edit script, writing the final
+contents of the pattern space and a newline to the standard output.
+A I<hold space> is provided for saving the contents of the
+pattern space for later use.
+
+=head2 Addresses
+
+A sed address is either a line number or a pattern, which may be combined
+arbitrarily to construct ranges. Lines are numbered across all input files.
+
+Any address may be followed by an exclamation mark (`C<!>'), selecting
+all lines not matching that address.
+
+=over 4
+
+=item I<number>
+
+The line with the given number is selected.
+
+=item B<$>
+
+A dollar sign (C<$>) is the line number of the last line of the input stream.
+
+=item B</>I<regular expression>B</>
+
+A pattern address is a basic regular expression (see
+L<"Basic Regular Expressions">), between the delimiting character C</>.
+Any other character except C<\> or newline may be used to delimit a
+pattern address when the initial delimiter is prefixed with a
+backslash (`C<\>').
+
+=back
+
+If no address is given, the command selects every line.
+
+If one address is given, it selects the line (or lines) matching the
+address.
+
+Two addresses select a range that begins whenever the first address
+matches, and ends (including that line) when the second address matches.
+If the first (second) address is a matching pattern, the second
+address is not applied to the very same line to determine the end of
+the range. Likewise, if the second address is a matching pattern, the
+first address is not applied to the very same line to determine the
+begin of another range. If both addresses are line numbers,
+and the second line number is less than the first line number, then
+only the first line is selected.
+
+
+=head2 Functions
+
+The maximum permitted number of addresses is indicated with each
+function synopsis below.
+
+The argument I<text> consists of one or more lines following the command.
+Embedded newlines in I<text> must be preceded with a backslash. Other
+backslashes in I<text> are deleted and the following character is taken
+literally.
+
+=over 4
+
+=cut
+
+my %ComTab;
+my %GenKey;
+#--------------------------------------------------------------------------
+$ComTab{'a'}=[ 1, 'txt', \&Emit, '{ push( @Q, <<'."'TheEnd' ) }\n" ]; #ok
+
+=item [1addr]B<a\> I<text>
+
+Write I<text> (which must start on the line following the command)
+to standard output immediately before reading the next line
+of input, either by executing the B<N> function or by beginning a new cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'b'}=[ 2, 'str', \&Branch, '{ goto XXX; }' ]; #ok
+
+=item [2addr]B<b> [I<label>]
+
+Branch to the B<:> function with the specified I<label>. If no label
+is given, branch to the end of the script.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'c'}=[ 2, 'txt', \&Change, <<'-X-' ]; #ok
+{ print <<'TheEnd'; } $doPrint = 0; goto EOS;
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<c\> I<text>
+
+The line, or range of lines, selected by the address is deleted.
+The I<text> (which must start on the line following the command)
+is written to standard output. With an address range, this occurs at
+the end of the range.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'d'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ $doPrint = 0;
+ goto EOS;
+}
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<d>
+
+Deletes the pattern space and starts the next cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'D'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ s/^.*\n?//;
+ if(length($_)){ goto BOS } else { goto EOS }
+}
+-X-
+### continue OK => next CYCLE;
+
+=item [2addr]B<D>
+
+Deletes the pattern space through the first embedded newline or to the end.
+If the pattern space becomes empty, a new cycle is started, otherwise
+execution of the script is restarted.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'g'}=[ 2, '', \&Emit, '{ $_ = $Hold };' ]; #ok
+
+=item [2addr]B<g>
+
+Replace the contents of the pattern space with the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'G'}=[ 2, '', \&Emit, '{ $_ .= "\n"; $_ .= $Hold };' ]; #ok
+
+=item [2addr]B<G>
+
+Append a newline and the contents of the hold space to the pattern space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'h'}=[ 2, '', \&Emit, '{ $Hold = $_ }' ]; #ok
+
+=item [2addr]B<h>
+
+Replace the contents of the hold space with the pattern space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'H'}=[ 2, '', \&Emit, '{ $Hold .= "\n"; $Hold .= $_; }' ]; #ok
+
+=item [2addr]B<H>
+
+Append a newline and the contents of the pattern space to the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'i'}=[ 1, 'txt', \&Emit, '{ print <<'."'TheEnd' }\n" ]; #ok
+
+=item [1addr]B<i\> I<text>
+
+Write the I<text> (which must start on the line following the command)
+to standard output.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'l'}=[ 2, '', \&Emit, '{ _l() }' ]; #okUTF8
+
+=item [2addr]B<l>
+
+Print the contents of the pattern space: non-printable characters are
+shown in C-style escaped form; long lines are split and have a trailing
+`C<\>' at the point of the split; the true end of a line is marked with
+a `C<$>'. Escapes are: `\a', `\t', `\n', `\f', `\r', `\e' for
+BEL, HT, LF, FF, CR, ESC, respectively, and `\' followed by a three-digit
+octal number for all other non-printable characters.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'n'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ print $_, "\n" if $doPrint;
+ printQ() if @Q;
+ $CondReg = 0;
+ last CYCLE unless getsARGV();
+ chomp();
+}
+-X-
+
+=item [2addr]B<n>
+
+If automatic printing is enabled, write the pattern space to the standard
+output. Replace the pattern space with the next line of input. If
+there is no more input, processing is terminated.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'N'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ printQ() if @Q;
+ $CondReg = 0;
+ last CYCLE unless getsARGV( $h );
+ chomp( $h );
+ $_ .= "\n$h";
+}
+-X-
+
+=item [2addr]B<N>
+
+Append a newline and the next line of input to the pattern space. If
+there is no more input, processing is terminated.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'p'}=[ 2, '', \&Emit, '{ print $_, "\n"; }' ]; #ok
+
+=item [2addr]B<p>
+
+Print the pattern space to the standard output. (Use the B<-n> option
+to suppress automatic printing at the end of a cycle if you want to
+avoid double printing of lines.)
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'P'}=[ 2, '', \&Emit, <<'-X-' ]; #ok
+{ if( /^(.*)/ ){ print $1, "\n"; } }
+-X-
+
+=item [2addr]B<P>
+
+Prints the pattern space through the first embedded newline or to the end.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'q'}=[ 1, '', \&Emit, <<'-X-' ]; #ok
+{ print $_, "\n" if $doPrint;
+ last CYCLE;
+}
+-X-
+
+=item [1addr]B<q>
+
+Branch to the end of the script and quit without starting a new cycle.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'r'}=[ 1, 'str', \&Emit, "{ _r( '-X-' ) }" ]; #ok
+
+=item [1addr]B<r> I<file>
+
+Copy the contents of the I<file> to standard output immediately before
+the next attempt to read a line of input. Any error encountered while
+reading I<file> is silently ignored.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'s'}=[ 2, 'sub', \&Emit, '' ]; #ok
+
+=item [2addr]B<s/>I<regular expression>B</>I<replacement>B</>I<flags>
+
+Substitute the I<replacement> string for the first substring in
+the pattern space that matches the I<regular expression>.
+Any character other than backslash or newline can be used instead of a
+slash to delimit the regular expression and the replacement.
+To use the delimiter as a literal character within the regular expression
+and the replacement, precede the character by a backslash (`C<\>').
+
+Literal newlines may be embedded in the replacement string by
+preceding a newline with a backslash.
+
+Within the replacement, an ampersand (`C<&>') is replaced by the string
+matching the regular expression. The strings `C<\1>' through `C<\9>' are
+replaced by the corresponding subpattern (see L<"Basic Regular Expressions">).
+To get a literal `C<&>' or `C<\>' in the replacement text, precede it
+by a backslash.
+
+The following I<flags> modify the behaviour of the B<s> command:
+
+=over 8
+
+=item B<g>
+
+The replacement is performed for all matching, non-overlapping substrings
+of the pattern space.
+
+=item B<1>..B<9>
+
+Replace only the n-th matching substring of the pattern space.
+
+=item B<p>
+
+If the substitution was made, print the new value of the pattern space.
+
+=item B<w> I<file>
+
+If the substitution was made, write the new value of the pattern space
+to the specified file.
+
+=back
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'t'}=[ 2, 'str', \&Branch, '{ goto XXX if _t() }' ]; #ok
+
+=item [2addr]B<t> [I<label>]
+
+Branch to the B<:> function with the specified I<label> if any B<s>
+substitutions have been made since the most recent reading of an input line
+or execution of a B<t> function. If no label is given, branch to the end of
+the script.
+
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'w'}=[ 2, 'str', \&Write, "{ _w( '-X-' ) }" ]; #ok
+
+=item [2addr]B<w> I<file>
+
+The contents of the pattern space are written to the I<file>.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'x'}=[ 2, '', \&Emit, '{ ($Hold, $_) = ($_, $Hold) }' ]; #ok
+
+=item [2addr]B<x>
+
+Swap the contents of the pattern space and the hold space.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'y'}=[ 2, 'tra', \&Emit, '' ]; #ok
+=item [2addr]B<y>B</>I<string1>B</>I<string2>B</>
+
+In the pattern space, replace all characters occuring in I<string1> by the
+character at the corresponding position in I<string2>. It is possible
+to use any character (other than a backslash or newline) instead of a
+slash to delimit the strings. Within I<string1> and I<string2>, a
+backslash followed by any character other than a newline is that literal
+character, and a backslash followed by an `n' is replaced by a newline
+character.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'='}=[ 1, '', \&Emit, '{ print "$.\n" }' ]; #ok
+
+=item [1addr]B<=>
+
+Prints the current line number on the standard output.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{':'}=[ 0, 'str', \&Label, '' ]; #ok
+
+=item [0addr]B<:> [I<label>]
+
+The command specifies the position of the I<label>. It has no other effect.
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'{'}=[ 2, '', \&BeginBlock, '{' ]; #ok
+$ComTab{'}'}=[ 0, '', \&EndBlock, ';}' ]; #ok
+# ';' to avoid warning on empty {}-block
+
+=item [2addr]B<{> [I<command>]
+
+=item [0addr]B<}>
+
+These two commands begin and end a command list. The first command may
+be given on the same line as the opening B<{> command. The commands
+within the list are jointly selected by the address(es) given on the
+B<{> command (but may still have individual addresses).
+
+=cut
+
+#--------------------------------------------------------------------------
+$ComTab{'#'}=[ 0, 'str', \&Comment, '' ]; #ok
+
+=item [0addr]B<#> [I<comment>]
+
+The entire line is ignored (treated as a comment). If, however, the first
+two characters in the script are `C<#n>', automatic printing of output is
+suppressed, as if the B<-n> option were given on the command line.
+
+=back
+
+=cut
+
+use vars qw{ $isEOF $Hold %wFiles @Q $CondReg $doPrint };
+
+my $useDEBUG = exists( $ENV{PSEDDEBUG} );
+my $useEXTBRE = $ENV{PSEDEXTBRE} || '';
+$useEXTBRE =~ s/[^<>wWyB]//g; # gawk RE's handle these
+
+my $doAutoPrint = 1; # automatic printing of pattern space (-n => 0)
+my $doOpenWrite = 1; # open w command output files at start (-a => 0)
+my $svOpenWrite = 0; # save $doOpenWrite
+
+# lower case $0 below as a VMSism. The VMS build procedure creates the
+# s2p file traditionally in upper case on the disk. When VMS is in a
+# case preserved or case sensitive mode, $0 will be returned in the exact
+# case which will be on the disk, and that is not predictable at this time.
+
+my $doGenerate = lc($0) eq 's2p';
+
+# Collected and compiled script
+#
+my( @Commands, %Defined, @BlockStack, %Label, $labNum, $Code, $Func );
+$Code = '';
+
+##################
+# Compile Time
+#
+# Labels
+#
+# Error handling
+#
+sub Warn($;$){
+ my( $msg, $loc ) = @_;
+ $loc ||= '';
+ $loc .= ': ' if length( $loc );
+ warn( "$0: $loc$msg\n" );
+}
+
+$labNum = 0;
+sub newLabel(){
+ return 'L_'.++$labNum;
+}
+
+# safeHere: create safe here delimiter and modify opcode and argument
+#
+sub safeHere($$){
+ my( $codref, $argref ) = @_;
+ my $eod = 'EOD000';
+ while( $$argref =~ /^$eod$/m ){
+ $eod++;
+ }
+ $$codref =~ s/TheEnd/$eod/e;
+ $$argref .= "$eod\n";
+}
+
+# Emit: create address logic and emit command
+#
+sub Emit($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $cond = '';
+ if( defined( $addr1 ) ){
+ if( defined( $addr2 ) ){
+ $addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
+ } else {
+ $addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
+ }
+ $cond = $negated ? "unless( $addr1 )\n" : "if( $addr1 )\n";
+ }
+
+ if( $opcode eq '' ){
+ $Code .= "$cond$arg\n";
+
+ } elsif( $opcode =~ s/-X-/$arg/e ){
+ $Code .= "$cond$opcode\n";
+
+ } elsif( $opcode =~ /TheEnd/ ){
+ safeHere( \$opcode, \$arg );
+ $Code .= "$cond$opcode$arg";
+
+ } else {
+ $Code .= "$cond$opcode\n";
+ }
+ 0;
+}
+
+# Write (w command, w flag): store pathname
+#
+sub Write($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $path, $fl ) = @_;
+ $wFiles{$path} = '';
+ Emit( $addr1, $addr2, $negated, $opcode, $path, $fl );
+}
+
+
+# Label (: command): label definition
+#
+sub Label($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
+ my $rc = 0;
+ $lab =~ s/\s+//;
+ if( length( $lab ) ){
+ my $h;
+ if( ! exists( $Label{$lab} ) ){
+ $h = $Label{$lab}{name} = newLabel();
+ } else {
+ $h = $Label{$lab}{name};
+ if( exists( $Label{$lab}{defined} ) ){
+ my $dl = $Label{$lab}{defined};
+ Warn( "duplicate label $lab (first defined at $dl)", $fl );
+ $rc = 1;
+ }
+ }
+ $Label{$lab}{defined} = $fl;
+ $Code .= "$h:;\n";
+ }
+ $rc;
+}
+
+# BeginBlock ({ command): push block start
+#
+sub BeginBlock($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ push( @BlockStack, [ $fl, $addr1, $addr2, $negated ] );
+ Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
+}
+
+# EndBlock (} command): check proper nesting
+#
+sub EndBlock($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $rc;
+ my $jcom = pop( @BlockStack );
+ if( defined( $jcom ) ){
+ $rc = Emit( $addr1, $addr2, $negated, $opcode, $arg, $fl );
+ } else {
+ Warn( "unexpected `}'", $fl );
+ $rc = 1;
+ }
+ $rc;
+}
+
+# Branch (t, b commands): check or create label, substitute default
+#
+sub Branch($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $lab, $fl ) = @_;
+ $lab =~ s/\s+//; # no spaces at end
+ my $h;
+ if( length( $lab ) ){
+ if( ! exists( $Label{$lab} ) ){
+ $h = $Label{$lab}{name} = newLabel();
+ } else {
+ $h = $Label{$lab}{name};
+ }
+ push( @{$Label{$lab}{used}}, $fl );
+ } else {
+ $h = 'EOS';
+ }
+ $opcode =~ s/XXX/$h/e;
+ Emit( $addr1, $addr2, $negated, $opcode, '', $fl );
+}
+
+# Change (c command): is special due to range end watching
+#
+sub Change($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+ my $kwd = $negated ? 'unless' : 'if';
+ if( defined( $addr2 ) ){
+ $addr1 .= $addr2 =~ /^\d+$/ ? "..$addr2" : "...$addr2";
+ if( ! $negated ){
+ $addr1 = '$icnt = ('.$addr1.')';
+ $opcode = 'if( $icnt =~ /E0$/ )' . $opcode;
+ }
+ } else {
+ $addr1 .= ' == $.' if $addr1 =~ /^\d+$/;
+ }
+ safeHere( \$opcode, \$arg );
+ $Code .= "$kwd( $addr1 ){\n $opcode$arg}\n";
+ 0;
+}
+
+
+# Comment (# command): A no-op. Who would've thought that!
+#
+sub Comment($$$$$$){
+ my( $addr1, $addr2, $negated, $opcode, $arg, $fl ) = @_;
+### $Code .= "# $arg\n";
+ 0;
+}
+
+# stripRegex from the current command. If we're in the first
+# part of s///, trailing spaces have to be kept as the initial
+# part of the replacement string.
+#
+sub stripRegex($$;$){
+ my( $del, $sref, $sub ) = @_;
+ my $regex = $del;
+ print "stripRegex:$del:$$sref:\n" if $useDEBUG;
+ while( $$sref =~ s{^(.*?)(\\*)\Q$del\E(\s*)}{}s ){
+ my $sl = $2;
+ $regex .= $1.$sl.$del;
+ if( length( $sl ) % 2 == 0 ){
+ if( $sub && (length( $3 ) > 0) ){
+ $$sref = $3 . $$sref;
+ }
+ return $regex;
+ }
+ $regex .= $3;
+ }
+ undef();
+}
+
+# stripTrans: take a <del> terminated string from y command
+# honoring and cleaning up of \-escaped <del>'s
+#
+sub stripTrans($$){
+ my( $del, $sref ) = @_;
+ my $t = '';
+ print "stripTrans:$del:$$sref:\n" if $useDEBUG;
+ while( $$sref =~ s{^(.*?)(\\*)\Q$del\E}{}s ){
+ my $sl = $2;
+ $t .= $1;
+ if( length( $sl ) % 2 == 0 ){
+ $t .= $sl;
+ $t =~ s/\\\\/\\/g;
+ return $t;
+ }
+ chop( $sl );
+ $t .= $sl.$del.$3;
+ }
+ undef();
+}
+
+# makey - construct Perl y/// from sed y///
+#
+sub makey($$$){
+ my( $fr, $to, $fl ) = @_;
+ my $error = 0;
+
+ # Ensure that any '-' is up front.
+ # Diagnose duplicate contradicting mappings
+ my %tr;
+ for( my $i = 0; $i < length($fr); $i++ ){
+ my $fc = substr($fr,$i,1);
+ my $tc = substr($to,$i,1);
+ if( exists( $tr{$fc} ) && $tr{$fc} ne $tc ){
+ Warn( "ambiguous translation for character `$fc' in `y' command",
+ $fl );
+ $error++;
+ }
+ $tr{$fc} = $tc;
+ }
+ $fr = $to = '';
+ if( exists( $tr{'-'} ) ){
+ ( $fr, $to ) = ( '-', $tr{'-'} );
+ delete( $tr{'-'} );
+ } else {
+ $fr = $to = '';
+ }
+ # might just as well sort it...
+ for my $fc ( sort keys( %tr ) ){
+ $fr .= $fc;
+ $to .= $tr{$fc};
+ }
+ # make embedded delimiters and newlines safe
+ $fr =~ s/([{}])/\$1/g;
+ $to =~ s/([{}])/\$1/g;
+ $fr =~ s/\n/\\n/g;
+ $to =~ s/\n/\\n/g;
+ return $error ? undef() : "{ y{$fr}{$to}; }";
+}
+
+######
+# makes - construct Perl s/// from sed s///
+#
+sub makes($$$$$$$){
+ my( $regex, $subst, $path, $global, $print, $nmatch, $fl ) = @_;
+
+ # make embedded newlines safe
+ $regex =~ s/\n/\\n/g;
+ $subst =~ s/\n/\\n/g;
+
+ my $code;
+ # n-th occurrence
+ #
+ if( length( $nmatch ) ){
+ $code = <<TheEnd;
+{ \$n = $nmatch;
+ while( --\$n && ( \$s = m ${regex}g ) ){}
+ \$s = ( substr( \$_, pos() ) =~ s ${regex}${subst}s ) if \$s;
+ \$CondReg ||= \$s;
+TheEnd
+ } else {
+ $code = <<TheEnd;
+{ \$s = s ${regex}${subst}s${global};
+ \$CondReg ||= \$s;
+TheEnd
+ }
+ if( $print ){
+ $code .= ' print $_, "\n" if $s;'."\n";
+ }
+ if( defined( $path ) ){
+ $wFiles{$path} = '';
+ $code .= " _w( '$path' ) if \$s;\n";
+ $GenKey{'w'} = 1;
+ }
+ $code .= "}";
+}
+
+=head1 BASIC REGULAR EXPRESSIONS
+
+A I<Basic Regular Expression> (BRE), as defined in POSIX 1003.2, consists
+of I<atoms>, for matching parts of a string, and I<bounds>, specifying
+repetitions of a preceding atom.
+
+=head2 Atoms
+
+The possible atoms of a BRE are: B<.>, matching any single character;
+B<^> and B<$>, matching the null string at the beginning or end
+of a string, respectively; a I<bracket expressions>, enclosed
+in B<[> and B<]> (see below); and any single character with no
+other significance (matching that character). A B<\> before one
+of: B<.>, B<^>, B<$>, B<[>, B<*>, B<\>, matching the character
+after the backslash. A sequence of atoms enclosed in B<\(> and B<\)>
+becomes an atom and establishes the target for a I<backreference>,
+consisting of the substring that actually matches the enclosed atoms.
+Finally, B<\> followed by one of the digits B<0> through B<9> is a
+backreference.
+
+A B<^> that is not first, or a B<$> that is not last does not have
+a special significance and need not be preceded by a backslash to
+become literal. The same is true for a B<]>, that does not terminate
+a bracket expression.
+
+An unescaped backslash cannot be last in a BRE.
+
+=head2 Bounds
+
+The BRE bounds are: B<*>, specifying 0 or more matches of the preceding
+atom; B<\{>I<count>B<\}>, specifying that many repetitions;
+B<\{>I<minimum>B<,\}>, giving a lower limit; and
+B<\{>I<minimum>B<,>I<maximum>B<\}> finally defines a lower and upper
+bound.
+
+A bound appearing as the first item in a BRE is taken literally.
+
+=head2 Bracket Expressions
+
+A I<bracket expression> is a list of characters, character ranges
+and character classes enclosed in B<[> and B<]> and matches any
+single character from the represented set of characters.
+
+A character range is written as two characters separated by B<-> and
+represents all characters (according to the character collating sequence)
+that are not less than the first and not greater than the second.
+(Ranges are very collating-sequence-dependent, and portable programs
+should avoid relying on them.)
+
+A character class is one of the class names
+
+ alnum digit punct
+ alpha graph space
+ blank lower upper
+ cntrl print xdigit
+
+enclosed in B<[:> and B<:]> and represents the set of characters
+as defined in ctype(3).
+
+If the first character after B<[> is B<^>, the sense of matching is
+inverted.
+
+To include a literal `C<^>', place it anywhere else but first. To
+include a literal 'C<]>' place it first or immediately after an
+initial B<^>. To include a literal `C<->' make it the first (or
+second after B<^>) or last character, or the second endpoint of
+a range.
+
+The special bracket expression constructs C<[[:E<lt>:]]> and C<[[:E<gt>:]]>
+match the null string at the beginning and end of a word respectively.
+(Note that neither is identical to Perl's `\b' atom.)
+
+=head2 Additional Atoms
+
+Since some sed implementations provide additional regular expression
+atoms (not defined in POSIX 1003.2), B<psed> is capable of translating
+the following backslash escapes:
+
+=over 4
+
+=item B<\E<lt>> This is the same as C<[[:E<gt>:]]>.
+
+=item B<\E<gt>> This is the same as C<[[:E<lt>:]]>.
+
+=item B<\w> This is an abbreviation for C<[[:alnum:]_]>.
+
+=item B<\W> This is an abbreviation for C<[^[:alnum:]_]>.
+
+=item B<\y> Match the empty string at a word boundary.
+
+=item B<\B> Match the empty string between any two either word or non-word characters.
+
+=back
+
+To enable this feature, the environment variable PSEDEXTBRE must be set
+to a string containing the requested characters, e.g.:
+C<PSEDEXTBRE='E<lt>E<gt>wW'>.
+
+=cut
+
+#####
+# bre2p - convert BRE to Perl RE
+#
+sub peek(\$$){
+ my( $pref, $ic ) = @_;
+ $ic < length($$pref)-1 ? substr( $$pref, $ic+1, 1 ) : '';
+}
+
+sub bre2p($$$){
+ my( $del, $pat, $fl ) = @_;
+ my $led = $del;
+ $led =~ tr/{([</})]>/;
+ $led = '' if $led eq $del;
+
+ $pat = substr( $pat, 1, length($pat) - 2 );
+ my $res = '';
+ my $bracklev = 0;
+ my $backref = 0;
+ my $parlev = 0;
+ for( my $ic = 0; $ic < length( $pat ); $ic++ ){
+ my $c = substr( $pat, $ic, 1 );
+ if( $c eq '\\' ){
+ ### backslash escapes
+ my $nc = peek($pat,$ic);
+ if( $nc eq '' ){
+ Warn( "`\\' cannot be last in pattern", $fl );
+ return undef();
+ }
+ $ic++;
+ if( $nc eq $del ){ ## \<pattern del> => \<pattern del>
+ $res .= "\\$del";
+
+ } elsif( $nc =~ /([[.*\\n])/ ){
+ ## check for \-escaped magics and \n:
+ ## \[ \. \* \\ \n stay as they are
+ $res .= '\\'.$nc;
+
+ } elsif( $nc eq '(' ){ ## \( => (
+ $parlev++;
+ $res .= '(';
+
+ } elsif( $nc eq ')' ){ ## \) => )
+ $parlev--;
+ $backref++;
+ if( $parlev < 0 ){
+ Warn( "unmatched `\\)'", $fl );
+ return undef();
+ }
+ $res .= ')';
+
+ } elsif( $nc eq '{' ){ ## repetition factor \{<i>[,[<j>]]\}
+ my $endpos = index( $pat, '\\}', $ic );
+ if( $endpos < 0 ){
+ Warn( "unmatched `\\{'", $fl );
+ return undef();
+ }
+ my $rep = substr( $pat, $ic+1, $endpos-($ic+1) );
+ $ic = $endpos + 1;
+
+ if( $res =~ /^\^?$/ ){
+ $res .= "\\{$rep\}";
+ } elsif( $rep =~ /^(\d+)(,?)(\d*)?$/ ){
+ my $min = $1;
+ my $com = $2 || '';
+ my $max = $3;
+ if( length( $max ) ){
+ if( $max < $min ){
+ Warn( "maximum less than minimum in `\\{$rep\\}'",
+ $fl );
+ return undef();
+ }
+ } else {
+ $max = '';
+ }
+ # simplify some
+ if( $min == 0 && $max eq '1' ){
+ $res .= '?';
+ } elsif( $min == 1 && "$com$max" eq ',' ){
+ $res .= '+';
+ } elsif( $min == 0 && "$com$max" eq ',' ){
+ $res .= '*';
+ } else {
+ $res .= "{$min$com$max}";
+ }
+ } else {
+ Warn( "invalid repeat clause `\\{$rep\\}'", $fl );
+ return undef();
+ }
+
+ } elsif( $nc =~ /^[1-9]$/ ){
+ ## \1 .. \9 => \1 .. \9, but check for a following digit
+ if( $nc > $backref ){
+ Warn( "invalid backreference ($nc)", $fl );
+ return undef();
+ }
+ $res .= "\\$nc";
+ if( peek($pat,$ic) =~ /[0-9]/ ){
+ $res .= '(?:)';
+ }
+
+ } elsif( $useEXTBRE && ( $nc =~ /[$useEXTBRE]/ ) ){
+ ## extensions - at most <>wWyB - not in POSIX
+ if( $nc eq '<' ){ ## \< => \b(?=\w), be precise
+ $res .= '\\b(?<=\\W)';
+ } elsif( $nc eq '>' ){ ## \> => \b(?=\W), be precise
+ $res .= '\\b(?=\\W)';
+ } elsif( $nc eq 'y' ){ ## \y => \b
+ $res .= '\\b';
+ } else { ## \B, \w, \W remain the same
+ $res .= "\\$nc";
+ }
+ } elsif( $nc eq $led ){
+ ## \<closing bracketing-delimiter> - keep '\'
+ $res .= "\\$nc";
+
+ } else { ## \ <char> => <char> ("as if `\' were not present")
+ $res .= $nc;
+ }
+
+ } elsif( $c eq '.' ){ ## . => .
+ $res .= $c;
+
+ } elsif( $c eq '*' ){ ## * => * but \* if there's nothing preceding it
+ if( $res =~ /^\^?$/ ){
+ $res .= '\\*';
+ } elsif( substr( $res, -1, 1 ) ne '*' ){
+ $res .= $c;
+ }
+
+ } elsif( $c eq '[' ){
+ ## parse []: [^...] [^]...] [-...]
+ my $add = '[';
+ if( peek($pat,$ic) eq '^' ){
+ $ic++;
+ $add .= '^';
+ }
+ my $nc = peek($pat,$ic);
+ if( $nc eq ']' || $nc eq '-' ){
+ $add .= $nc;
+ $ic++;
+ }
+ # check that [ is not trailing
+ if( $ic >= length( $pat ) - 1 ){
+ Warn( "unmatched `['", $fl );
+ return undef();
+ }
+ # look for [:...:] and x-y
+ my $rstr = substr( $pat, $ic+1 );
+ if( $rstr =~ /^((?:\[:\(\w+|[><]\):\]|[^]-](?:-[^]])?)*)/ ){
+ my $cnt = $1;
+ $ic += length( $cnt );
+ $cnt =~ s/([\\\$])/\\$1/g; # `\', `$' are magic in Perl []
+ # try some simplifications
+ my $red = $cnt;
+ if( $red =~ s/0-9// ){
+ $cnt = $red.'\d';
+ if( $red =~ s/A-Z// && $red =~ s/a-z// && $red =~ s/_// ){
+ $cnt = $red.'\w';
+ }
+ }
+ $add .= $cnt;
+
+ # POSIX 1003.2 has this (optional) for begin/end word
+ $add = '\\b(?=\\W)' if $add eq '[[:<:]]';
+ $add = '\\b(?<=\\W)' if $add eq '[[:>:]]';
+
+ }
+
+ ## may have a trailing `-' before `]'
+ if( $ic < length($pat) - 1 &&
+ substr( $pat, $ic+1 ) =~ /^(-?])/ ){
+ $ic += length( $1 );
+ $add .= $1;
+ # another simplification
+ $add =~ s/^\[(\^?)(\\[dw])]$/ $1 eq '^' ? uc($2) : $2 /e;
+ $res .= $add;
+ } else {
+ Warn( "unmatched `['", $fl );
+ return undef();
+ }
+
+ } elsif( $c eq $led ){ ## unescaped <closing bracketing-delimiter>
+ $res .= "\\$c";
+
+ } elsif( $c eq ']' ){ ## unmatched ] is not magic
+ $res .= ']';
+
+ } elsif( $c =~ /[|+?{}()]/ ){ ## not magic in BRE, but in Perl: \-quote
+ $res .= "\\$c";
+
+ } elsif( $c eq '^' ){ ## not magic unless 1st, but in Perl: \-quote
+ $res .= length( $res ) ? '\\^' : '^';
+
+ } elsif( $c eq '$' ){ ## not magic unless last, but in Perl: \-quote
+ $res .= $ic == length( $pat ) - 1 ? '$' : '\\$';
+
+ } else {
+ $res .= $c;
+ }
+ }
+
+ if( $parlev ){
+ Warn( "unmatched `\\('", $fl );
+ return undef();
+ }
+
+ # final cleanup: eliminate raw HTs
+ $res =~ s/\t/\\t/g;
+ return $del . $res . ( $led ? $led : $del );
+}
+
+
+#####
+# sub2p - convert sed substitution to Perl substitution
+#
+sub sub2p($$$){
+ my( $del, $subst, $fl ) = @_;
+ my $led = $del;
+ $led =~ tr/{([</})]>/;
+ $led = '' if $led eq $del;
+
+ $subst = substr( $subst, 1, length($subst) - 2 );
+ my $res = '';
+
+ for( my $ic = 0; $ic < length( $subst ); $ic++ ){
+ my $c = substr( $subst, $ic, 1 );
+ if( $c eq '\\' ){
+ ### backslash escapes
+ my $nc = peek($subst,$ic);
+ if( $nc eq '' ){
+ Warn( "`\\' cannot be last in substitution", $fl );
+ return undef();
+ }
+ $ic++;
+ if( $nc =~ /[\\$del$led]/ ){ ## \ and delimiter
+ $res .= '\\' . $nc;
+ } elsif( $nc =~ /[1-9]/ ){ ## \1 - \9 => ${1} - ${9}
+ $res .= '${' . $nc . '}';
+ } else { ## everything else (includes &): omit \
+ $res .= $nc;
+ }
+ } elsif( $c eq '&' ){ ## & => $&
+ $res .= '$&';
+ } elsif( $c =~ /[\$\@$led]/ ){ ## magic in Perl's substitution string
+ $res .= '\\' . $c;
+ } else {
+ $res .= $c;
+ }
+ }
+
+ # final cleanup: eliminate raw HTs
+ $res =~ s/\t/\\t/g;
+ return ( $led ? $del : $led ) . $res . ( $led ? $led : $del );
+}
+
+
+sub Parse(){
+ my $error = 0;
+ my( $pdef, $pfil, $plin );
+ for( my $icom = 0; $icom < @Commands; $icom++ ){
+ my $cmd = $Commands[$icom];
+ print "Parse:$cmd:\n" if $useDEBUG;
+ $cmd =~ s/^\s+//;
+ next unless length( $cmd );
+ my $scom = $icom;
+ if( exists( $Defined{$icom} ) ){
+ $pdef = $Defined{$icom};
+ if( $pdef =~ /^ #(\d+)/ ){
+ $pfil = 'expression #';
+ $plin = $1;
+ } else {
+ $pfil = "$pdef l.";
+ $plin = 1;
+ }
+ } else {
+ $plin++;
+ }
+ my $fl = "$pfil$plin";
+
+ # insert command as comment in gnerated code
+ #
+ $Code .= "# $cmd\n" if $doGenerate;
+
+ # The Address(es)
+ #
+ my( $negated, $naddr, $addr1, $addr2 );
+ $naddr = 0;
+ if( $cmd =~ s/^(\d+)\s*// ){
+ $addr1 = "$1"; $naddr++;
+ } elsif( $cmd =~ s/^\$\s*// ){
+ $addr1 = 'eofARGV()'; $naddr++;
+ } elsif( $cmd =~ s{^(/)}{} || $cmd =~ s{^\\(.)}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd );
+ if( defined( $regex ) ){
+ $addr1 = 'm '.bre2p( $del, $regex, $fl ).'s';
+ $naddr++;
+ } else {
+ Warn( "malformed regex, 1st address", $fl );
+ $error++;
+ next;
+ }
+ }
+ if( defined( $addr1 ) && $cmd =~ s/,\s*// ){
+ if( $cmd =~ s/^(\d+)\s*// ){
+ $addr2 = "$1"; $naddr++;
+ } elsif( $cmd =~ s/^\$\s*// ){
+ $addr2 = 'eofARGV()'; $naddr++;
+ } elsif( $cmd =~ s{^(/)}{} || $cmd =~ s{^\\(.)}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd );
+ if( defined( $regex ) ){
+ $addr2 = 'm '. bre2p( $del, $regex, $fl ).'s';
+ $naddr++;
+ } else {
+ Warn( "malformed regex, 2nd address", $fl );
+ $error++;
+ next;
+ }
+ } else {
+ Warn( "invalid address after `,'", $fl );
+ $error++;
+ next;
+ }
+ }
+
+ # address modifier `!'
+ #
+ $negated = $cmd =~ s/^!\s*//;
+ if( defined( $addr1 ) ){
+ print "Parse: addr1=$addr1" if $useDEBUG;
+ if( defined( $addr2 ) ){
+ print ", addr2=$addr2 " if $useDEBUG;
+ # both numeric and addr1 > addr2 => eliminate addr2
+ undef( $addr2 ) if $addr1 =~ /^\d+$/ &&
+ $addr2 =~ /^\d+$/ && $addr1 > $addr2;
+ }
+ }
+ print 'negated' if $useDEBUG && $negated;
+ print " command:$cmd\n" if $useDEBUG;
+
+ # The Command
+ #
+ if( $cmd !~ s/^([:#={}abcdDgGhHilnNpPqrstwxy])\s*// ){
+ my $h = substr( $cmd, 0, 1 );
+ Warn( "unknown command `$h'", $fl );
+ $error++;
+ next;
+ }
+ my $key = $1;
+
+ my $tabref = $ComTab{$key};
+ $GenKey{$key} = 1;
+ if( $naddr > $tabref->[0] ){
+ Warn( "excess address(es)", $fl );
+ $error++;
+ next;
+ }
+
+ my $arg = '';
+ if( $tabref->[1] eq 'str' ){
+ # take remainder - don't care if it is empty
+ $arg = $cmd;
+ $cmd = '';
+
+ } elsif( $tabref->[1] eq 'txt' ){
+ # multi-line text
+ my $goon = $cmd =~ /(.*)\\$/;
+ if( length( $1 ) ){
+ Warn( "extra characters after command ($cmd)", $fl );
+ $error++;
+ }
+ while( $goon ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd = $Commands[$icom];
+ $Code .= "# $cmd\n" if $doGenerate;
+ $goon = $cmd =~ s/\\$//;
+ $cmd =~ s/\\(.)/$1/g;
+ $arg .= "\n" if length( $arg );
+ $arg .= $cmd;
+ }
+ $arg .= "\n" if length( $arg );
+ $cmd = '';
+
+ } elsif( $tabref->[1] eq 'sub' ){
+ # s///
+ if( ! length( $cmd ) ){
+ Warn( "`s' command requires argument", $fl );
+ $error++;
+ next;
+ }
+ if( $cmd =~ s{^([^\\\n])}{} ){
+ my $del = $1;
+ my $regex = stripRegex( $del, \$cmd, "s" );
+ if( ! defined( $regex ) ){
+ Warn( "malformed regular expression", $fl );
+ $error++;
+ next;
+ }
+ $regex = bre2p( $del, $regex, $fl );
+
+ # a trailing \ indicates embedded NL (in replacement string)
+ while( $cmd =~ s/(?<!\\)\\$/\n/ ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd .= $Commands[$icom];
+ $Code .= "# $Commands[$icom]\n" if $doGenerate;
+ }
+
+ my $subst = stripRegex( $del, \$cmd );
+ if( ! defined( $regex ) ){
+ Warn( "malformed substitution expression", $fl );
+ $error++;
+ next;
+ }
+ $subst = sub2p( $del, $subst, $fl );
+
+ # parse s/// modifier: g|p|0-9|w <file>
+ my( $global, $nmatch, $print, $write ) =
+ ( '', '', 0, undef );
+ while( $cmd =~ s/^([gp0-9])// ){
+ $1 eq 'g' ? ( $global = 'g' ) :
+ $1 eq 'p' ? ( $print = $1 ) : ( $nmatch .= $1 );
+ }
+ $write = $1 if $cmd =~ s/w\s*(.*)$//;
+ ### $nmatch =~ s/^(\d)\1*$/$1/; ### may be dangerous?
+ if( $global && length( $nmatch ) || length( $nmatch ) > 1 ){
+ Warn( "conflicting flags `$global$nmatch'", $fl );
+ $error++;
+ next;
+ }
+
+ $arg = makes( $regex, $subst,
+ $write, $global, $print, $nmatch, $fl );
+ if( ! defined( $arg ) ){
+ $error++;
+ next;
+ }
+
+ } else {
+ Warn( "improper delimiter in s command", $fl );
+ $error++;
+ next;
+ }
+
+ } elsif( $tabref->[1] eq 'tra' ){
+ # y///
+ # a trailing \ indicates embedded newline
+ while( $cmd =~ s/(?<!\\)\\$/\n/ ){
+ $icom++;
+ if( $icom > $#Commands ){
+ Warn( "unexpected end of script", $fl );
+ $error++;
+ last;
+ }
+ $cmd .= $Commands[$icom];
+ $Code .= "# $Commands[$icom]\n" if $doGenerate;
+ }
+ if( ! length( $cmd ) ){
+ Warn( "`y' command requires argument", $fl );
+ $error++;
+ next;
+ }
+ my $d = substr( $cmd, 0, 1 ); $cmd = substr( $cmd, 1 );
+ if( $d eq '\\' ){
+ Warn( "`\\' not valid as delimiter in `y' command", $fl );
+ $error++;
+ next;
+ }
+ my $fr = stripTrans( $d, \$cmd );
+ if( ! defined( $fr ) || ! length( $cmd ) ){
+ Warn( "malformed `y' command argument", $fl );
+ $error++;
+ next;
+ }
+ my $to = stripTrans( $d, \$cmd );
+ if( ! defined( $to ) ){
+ Warn( "malformed `y' command argument", $fl );
+ $error++;
+ next;
+ }
+ if( length($fr) != length($to) ){
+ Warn( "string lengths in `y' command differ", $fl );
+ $error++;
+ next;
+ }
+ if( ! defined( $arg = makey( $fr, $to, $fl ) ) ){
+ $error++;
+ next;
+ }
+
+ }
+
+ # $cmd must be now empty - exception is {
+ if( $cmd !~ /^\s*$/ ){
+ if( $key eq '{' ){
+ # dirty hack to process command on '{' line
+ $Commands[$icom--] = $cmd;
+ } else {
+ Warn( "extra characters after command ($cmd)", $fl );
+ $error++;
+ next;
+ }
+ }
+
+ # Make Code
+ #
+ if( &{$tabref->[2]}( $addr1, $addr2, $negated,
+ $tabref->[3], $arg, $fl ) ){
+ $error++;
+ }
+ }
+
+ while( @BlockStack ){
+ my $bl = pop( @BlockStack );
+ Warn( "start of unterminated `{'", $bl );
+ $error++;
+ }
+
+ for my $lab ( keys( %Label ) ){
+ if( ! exists( $Label{$lab}{defined} ) ){
+ for my $used ( @{$Label{$lab}{used}} ){
+ Warn( "undefined label `$lab'", $used );
+ $error++;
+ }
+ }
+ }
+
+ exit( 1 ) if $error;
+}
+
+
+##############
+#### MAIN ####
+##############
+
+sub usage(){
+ print STDERR "Usage: sed [-an] command [file...]\n";
+ print STDERR " [-an] [-e command] [-f script-file] [file...]\n";
+}
+
+###################
+# Here we go again...
+#
+my $expr = 0;
+while( @ARGV && $ARGV[0] =~ /^-(.)(.*)$/ ){
+ my $opt = $1;
+ my $arg = $2;
+ shift( @ARGV );
+ if( $opt eq 'e' ){
+ if( length( $arg ) ){
+ push( @Commands, split( "\n", $arg ) );
+ } elsif( @ARGV ){
+ push( @Commands, shift( @ARGV ) );
+ } else {
+ Warn( "option -e requires an argument" );
+ usage();
+ exit( 1 );
+ }
+ $expr++;
+ $Defined{$#Commands} = " #$expr";
+ next;
+ }
+ if( $opt eq 'f' ){
+ my $path;
+ if( length( $arg ) ){
+ $path = $arg;
+ } elsif( @ARGV ){
+ $path = shift( @ARGV );
+ } else {
+ Warn( "option -f requires an argument" );
+ usage();
+ exit( 1 );
+ }
+ my $fst = $#Commands + 1;
+ open( SCRIPT, "<$path" ) || die( "$0: $path: could not open ($!)\n" );
+ my $cmd;
+ while( defined( $cmd = <SCRIPT> ) ){
+ chomp( $cmd );
+ push( @Commands, $cmd );
+ }
+ close( SCRIPT );
+ if( $#Commands >= $fst ){
+ $Defined{$fst} = "$path";
+ }
+ next;
+ }
+ if( $opt eq '-' && $arg eq '' ){
+ last;
+ }
+ if( $opt eq 'h' || $opt eq '?' ){
+ usage();
+ exit( 0 );
+ }
+ if( $opt eq 'n' ){
+ $doAutoPrint = 0;
+ } elsif( $opt eq 'a' ){
+ $doOpenWrite = 0;
+ } else {
+ Warn( "illegal option `$opt'" );
+ usage();
+ exit( 1 );
+ }
+ if( length( $arg ) ){
+ unshift( @ARGV, "-$arg" );
+ }
+}
+
+# A singleton command may be the 1st argument when there are no options.
+#
+if( @Commands == 0 ){
+ if( @ARGV == 0 ){
+ Warn( "no script command given" );
+ usage();
+ exit( 1 );
+ }
+ push( @Commands, split( "\n", shift( @ARGV ) ) );
+ $Defined{0} = ' #1';
+}
+
+print STDERR "Files: @ARGV\n" if $useDEBUG;
+
+# generate leading code
+#
+$Func = <<'[TheEnd]';
+
+# openARGV: open 1st input file
+#
+sub openARGV(){
+ unshift( @ARGV, '-' ) unless @ARGV;
+ my $file = shift( @ARGV );
+ open( ARG, "<$file" )
+ || die( "$0: can't open $file for reading ($!)\n" );
+ $isEOF = 0;
+}
+
+# getsARGV: Read another input line into argument (default: $_).
+# Move on to next input file, and reset EOF flag $isEOF.
+sub getsARGV(;\$){
+ my $argref = @_ ? shift() : \$_;
+ while( $isEOF || ! defined( $$argref = <ARG> ) ){
+ close( ARG );
+ return 0 unless @ARGV;
+ my $file = shift( @ARGV );
+ open( ARG, "<$file" )
+ || die( "$0: can't open $file for reading ($!)\n" );
+ $isEOF = 0;
+ }
+ 1;
+}
+
+# eofARGV: end-of-file test
+#
+sub eofARGV(){
+ return @ARGV == 0 && ( $isEOF = eof( ARG ) );
+}
+
+# makeHandle: Generates another file handle for some file (given by its path)
+# to be written due to a w command or an s command's w flag.
+sub makeHandle($){
+ my( $path ) = @_;
+ my $handle;
+ if( ! exists( $wFiles{$path} ) || $wFiles{$path} eq '' ){
+ $handle = $wFiles{$path} = gensym();
+ if( $doOpenWrite ){
+ if( ! open( $handle, ">$path" ) ){
+ die( "$0: can't open $path for writing: ($!)\n" );
+ }
+ }
+ } else {
+ $handle = $wFiles{$path};
+ }
+ return $handle;
+}
+
+# printQ: Print queued output which is either a string or a reference
+# to a pathname.
+sub printQ(){
+ for my $q ( @Q ){
+ if( ref( $q ) ){
+ # flush open w files so that reading this file gets it all
+ if( exists( $wFiles{$$q} ) && $wFiles{$$q} ne '' ){
+ open( $wFiles{$$q}, ">>$$q" );
+ }
+ # copy file to stdout: slow, but safe
+ if( open( RF, "<$$q" ) ){
+ while( defined( my $line = <RF> ) ){
+ print $line;
+ }
+ close( RF );
+ }
+ } else {
+ print $q;
+ }
+ }
+ undef( @Q );
+}
+
+[TheEnd]
+
+# generate the sed loop
+#
+$Code .= <<'[TheEnd]';
+sub openARGV();
+sub getsARGV(;\$);
+sub eofARGV();
+sub printQ();
+
+# Run: the sed loop reading input and applying the script
+#
+sub Run(){
+ my( $h, $icnt, $s, $n );
+ # hack (not unbreakable :-/) to avoid // matching an empty string
+ my $z = "\000"; $z =~ /$z/;
+ # Initialize.
+ openARGV();
+ $Hold = '';
+ $CondReg = 0;
+ $doPrint = $doAutoPrint;
+CYCLE:
+ while( getsARGV() ){
+ chomp();
+ $CondReg = 0; # cleared on t
+BOS:;
+[TheEnd]
+
+ # parse - avoid opening files when doing s2p
+ #
+ ( $svOpenWrite, $doOpenWrite ) = ( $doOpenWrite, $svOpenWrite )
+ if $doGenerate;
+ Parse();
+ ( $svOpenWrite, $doOpenWrite ) = ( $doOpenWrite, $svOpenWrite )
+ if $doGenerate;
+
+ # append trailing code
+ #
+ $Code .= <<'[TheEnd]';
+EOS: if( $doPrint ){
+ print $_, "\n";
+ } else {
+ $doPrint = $doAutoPrint;
+ }
+ printQ() if @Q;
+ }
+
+ exit( 0 );
+}
+[TheEnd]
+
+
+# append optional functions, prepend prototypes
+#
+my $Proto = "# prototypes\n";
+if( $GenKey{'l'} ){
+ $Proto .= "sub _l();\n";
+ $Func .= <<'[TheEnd]';
+# _l: l command processing
+#
+sub _l(){
+ my $h = $_;
+ my $mcpl = 70;
+ # transform non printing chars into escape notation
+ $h =~ s/\\/\\\\/g;
+ if( $h =~ /[^[:print:]]/ ){
+ $h =~ s/\a/\\a/g;
+ $h =~ s/\f/\\f/g;
+ $h =~ s/\n/\\n/g;
+ $h =~ s/\t/\\t/g;
+ $h =~ s/\r/\\r/g;
+ $h =~ s/\e/\\e/g;
+ $h =~ s/([^[:print:]])/sprintf("\\%03o", ord($1))/ge;
+ }
+ # split into lines of length $mcpl
+ while( length( $h ) > $mcpl ){
+ my $l = substr( $h, 0, $mcpl-1 );
+ $h = substr( $h, $mcpl );
+ # remove incomplete \-escape from end of line
+ if( $l =~ s/(?<!\\)(\\[0-7]{0,2})$// ){
+ $h = $1 . $h;
+ }
+ print $l, "\\\n";
+ }
+ print "$h\$\n";
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'r'} ){
+ $Proto .= "sub _r(\$);\n";
+ $Func .= <<'[TheEnd]';
+# _r: r command processing: Save a reference to the pathname.
+#
+sub _r($){
+ my $path = shift();
+ push( @Q, \$path );
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'t'} ){
+ $Proto .= "sub _t();\n";
+ $Func .= <<'[TheEnd]';
+# _t: t command - condition register test/reset
+#
+sub _t(){
+ my $res = $CondReg;
+ $CondReg = 0;
+ $res;
+}
+
+[TheEnd]
+}
+
+if( $GenKey{'w'} ){
+ $Proto .= "sub _w(\$);\n";
+ $Func .= <<'[TheEnd]';
+# _w: w command and s command's w flag - write to file
+#
+sub _w($){
+ my $path = shift();
+ my $handle = $wFiles{$path};
+ if( ! $doOpenWrite && ! defined( fileno( $handle ) ) ){
+ open( $handle, ">$path" )
+ || die( "$0: $path: cannot open ($!)\n" );
+ }
+ print $handle $_, "\n";
+}
+
+[TheEnd]
+}
+
+$Code = $Proto . $Code;
+
+# magic "#n" - same as -n option
+#
+$doAutoPrint = 0 if substr( $Commands[0], 0, 2 ) eq '#n';
+
+# eval code - check for errors
+#
+print "Code:\n$Code$Func" if $useDEBUG;
+eval $Code . $Func;
+if( $@ ){
+ print "Code:\n$Code$Func";
+ die( "$0: internal error - generated incorrect Perl code: $@\n" );
+}
+
+if( $doGenerate ){
+
+ # write full Perl program
+ #
+
+ # bang line, declarations, prototypes
+ print <<TheEnd;
+#!$perlpath -w
+eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+ if 0;
+\$0 =~ s/^.*?(\\w+)\[\\.\\w+\]*\$/\$1/;
+
+use strict;
+use Symbol;
+use vars qw{ \$isEOF \$Hold \%wFiles \@Q \$CondReg
+ \$doAutoPrint \$doOpenWrite \$doPrint };
+\$doAutoPrint = $doAutoPrint;
+\$doOpenWrite = $doOpenWrite;
+TheEnd
+
+ my $wf = "'" . join( "', '", keys( %wFiles ) ) . "'";
+ if( $wf ne "''" ){
+ print <<TheEnd;
+sub makeHandle(\$);
+for my \$p ( $wf ){
+ exit( 1 ) unless makeHandle( \$p );
+}
+TheEnd
+ }
+
+ print $Code;
+ print "Run();\n";
+ print $Func;
+ exit( 0 );
+
+} else {
+
+ # execute: make handles (and optionally open) all w files; run!
+ for my $p ( keys( %wFiles ) ){
+ exit( 1 ) unless makeHandle( $p );
+ }
+ Run();
+}
+
+
+=head1 ENVIRONMENT
+
+The environment variable C<PSEDEXTBRE> may be set to extend BREs.
+See L<"Additional Atoms">.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item ambiguous translation for character `%s' in `y' command
+
+The indicated character appears twice, with different translations.
+
+=item `[' cannot be last in pattern
+
+A `[' in a BRE indicates the beginning of a I<bracket expression>.
+
+=item `\' cannot be last in pattern
+
+A `\' in a BRE is used to make the subsequent character literal.
+
+=item `\' cannot be last in substitution
+
+A `\' in a subsitution string is used to make the subsequent character literal.
+
+=item conflicting flags `%s'
+
+In an B<s> command, either the `g' flag and an n-th occurrence flag, or
+multiple n-th occurrence flags are specified. Note that only the digits
+`1' through `9' are permitted.
+
+=item duplicate label %s (first defined at %s)
+
+=item excess address(es)
+
+The command has more than the permitted number of addresses.
+
+=item extra characters after command (%s)
+
+=item illegal option `%s'
+
+=item improper delimiter in s command
+
+The BRE and substitution may not be delimited with `\' or newline.
+
+=item invalid address after `,'
+
+=item invalid backreference (%s)
+
+The specified backreference number exceeds the number of backreferences
+in the BRE.
+
+=item invalid repeat clause `\{%s\}'
+
+The repeat clause does not contain a valid integer value, or pair of
+values.
+
+=item malformed regex, 1st address
+
+=item malformed regex, 2nd address
+
+=item malformed regular expression
+
+=item malformed substitution expression
+
+=item malformed `y' command argument
+
+The first or second string of a B<y> command is syntactically incorrect.
+
+=item maximum less than minimum in `\{%s\}'
+
+=item no script command given
+
+There must be at least one B<-e> or one B<-f> option specifying a
+script or script file.
+
+=item `\' not valid as delimiter in `y' command
+
+=item option -e requires an argument
+
+=item option -f requires an argument
+
+=item `s' command requires argument
+
+=item start of unterminated `{'
+
+=item string lengths in `y' command differ
+
+The translation table strings in a B<y> command must have equal lengths.
+
+=item undefined label `%s'
+
+=item unexpected `}'
+
+A B<}> command without a preceding B<{> command was encountered.
+
+=item unexpected end of script
+
+The end of the script was reached although a text line after a
+B<a>, B<c> or B<i> command indicated another line.
+
+=item unknown command `%s'
+
+=item unterminated `['
+
+A BRE contains an unterminated bracket expression.
+
+=item unterminated `\('
+
+A BRE contains an unterminated backreference.
+
+=item `\{' without closing `\}'
+
+A BRE contains an unterminated bounds specification.
+
+=item `\)' without preceding `\('
+
+=item `y' command requires argument
+
+=back
+
+=head1 EXAMPLE
+
+The basic material for the preceding section was generated by running
+the sed script
+
+ #no autoprint
+ s/^.*Warn( *"\([^"]*\)".*$/\1/
+ t process
+ b
+ :process
+ s/$!/%s/g
+ s/$[_[:alnum:]]\{1,\}/%s/g
+ s/\\\\/\\/g
+ s/^/=item /
+ p
+
+on the program's own text, and piping the output into C<sort -u>.
+
+
+=head1 SED SCRIPT TRANSLATION
+
+If this program is invoked with the name F<s2p> it will act as a
+sed-to-Perl translator. After option processing (all other
+arguments are ignored), a Perl program is printed on standard
+output, which will process the input stream (as read from all
+arguments) in the way defined by the sed script and the option setting
+used for the translation.
+
+=head1 SEE ALSO
+
+perl(1), re_format(7)
+
+=head1 BUGS
+
+The B<l> command will show escape characters (ESC) as `C<\e>', but
+a vertical tab (VT) in octal.
+
+Trailing spaces are truncated from labels in B<:>, B<t> and B<b> commands.
+
+The meaning of an empty regular expression (`C<//>'), as defined by B<sed>,
+is "the last pattern used, at run time". This deviates from the Perl
+interpretation, which will re-use the "last last successfully executed
+regular expression". Since keeping track of pattern usage would create
+terribly cluttered code, and differences would only appear in obscure
+context (where other B<sed> implementations appear to deviate, too),
+the Perl semantics was adopted. Note that common usage of this feature,
+such as in C</abc/s//xyz/>, will work as expected.
+
+Collating elements (of bracket expressions in BREs) are not implemented.
+
+=head1 STANDARDS
+
+This B<sed> implementation conforms to the IEEE Std1003.2-1992 ("POSIX.2")
+definition of B<sed>, and is compatible with the I<OpenBSD>
+implementation, except where otherwise noted (see L<"BUGS">).
+
+=head1 AUTHOR
+
+This Perl implementation of I<sed> was written by Wolfgang Laun,
+I<Wolfgang.Laun@alcatel.at>.
+
+=head1 COPYRIGHT and LICENSE
+
+This program is free and open software. You may use, modify,
+distribute, and sell this program (and any modified variants) in any
+way you wish, provided you do not restrict others from doing the same.
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/search.bat b/Master/tlpkg/tlperl/bin/search.bat new file mode 100755 index 00000000000..963cb269213 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/search.bat @@ -0,0 +1,1887 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+'di';
+'ig00';
+##############################################################################
+##
+## search
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp), Dec 1994.
+## Copyright 19.... ah hell, just take it.
+##
+## BLURB:
+## A combo of find and grep -- more or less do a 'grep' on a whole
+## directory tree. Fast, with lots of options. Much more powerful than
+## the simple "find ... | xargs grep ....". Has a full man page.
+## Powerfully customizable.
+##
+## This file is big, but mostly comments and man page.
+##
+## See man page for usage info.
+## Return value: 2=error, 1=nothing found, 0=something found.
+##
+
+$version = "950918.5";
+##
+## "950918.5";
+## Changed all 'sysread' to 'read' because Linux perl's don't seem
+## to like sysread()
+##
+## "941227.4";
+## Added -n, -u
+##
+## "941222.3"
+## Added -nice (due to Lionel Cons <Lionel.Cons@cern.ch>)
+## Removed any leading "./" from name.
+## Added default flags for ~/.search, including TTY, -nice, -list, etc.
+## Program name now has path removed when printed in diagnostics.
+## Added simple tilde-expansion to -dir arg.
+## Added -dskip, etc. Fixed -iregex bug.
+## Changed -dir to be additive, adding -ddir.
+## Now screen out devices, pipes, and sockets.
+## More tidying and lots of expanding of the man page
+##
+##
+## "941217.2";
+## initial release.
+
+$stripped=0;
+
+&init;
+if (exists $ENV{'HOME'}) {
+ $rc_file = join('/', $ENV{'HOME'}, ".search");
+}
+else {
+ $rc_file = "";
+}
+
+&check_args;
+
+## Make sure we've got a regex.
+## Don't need one if -find or -showrc was specified.
+$!=2, die "expecting regex arguments.\n"
+ if $FIND_ONLY == 0 && $showrc == 0 && @ARGV == 0;
+
+&prepare_to_search($rc_file);
+
+&import_program if !defined &dodir; ## BIG key to speed.
+
+## do search while there are directories to be done.
+&dodir(shift(@todo)) while @todo;
+
+&clear_message if $VERBOSE && $STDERR_IS_TTY;
+exit($retval);
+###############################################################################
+
+sub init
+{
+ ## initialize variables that might be reset by command-line args
+ $DOREP=0; ## set true by -dorep (redo multi-hardlink files)
+ $DOREP=1 if $^O eq 'MSWin32';
+ $DO_SORT=0; ## set by -sort (sort files in a dir before checking)
+ $FIND_ONLY=0; ## set by -find (don't search files)
+ $LIST_ONLY=0; ## set true by -l (list filenames only)
+ $NEWER=0; ## set by -newer, "-mtime -###"
+ $NICE=0; ## set by -nice (print human-readable output)
+ $NOLINKS=0; ## set true by -nolinks (don't follow symlinks)
+ $OLDER=0; ## set by -older, "-mtime ###"
+ $PREPEND_FILENAME=1; ## set false by -h (don't prefix lines with filename)
+ $REPORT_LINENUM=0; ## set true by -n (show line numbers)
+ $VERBOSE=0; ## set to a value by -v, -vv, etc. (verbose messages)
+ $WHY=0; ## set true by -why, -vvv+ (report why skipped)
+ $XDEV=0; ## set true by -xdev (stay on one filesystem)
+ $all=0; ## set true by -all (don't skip many kinds of files)
+ $iflag = ''; ## set to 'i' by -i (ignore case);
+ $norc=0; ## set by -norc (don't load rc file)
+ $showrc=0; ## set by -showrc (show what happens with rc file)
+ $underlineOK=0; ## set true by -u (watch for underline stuff)
+ $words=0; ## set true by -w (match whole-words only)
+ $DELAY=0; ## inter-file delay (seconds)
+ $retval=1; ## will set to 0 if we find anything.
+
+ ## various elements of stat() that we might access
+ $STAT_DEV = 1;
+ $STAT_INODE = 2;
+ $STAT_MTIME = 9;
+
+ $VV_PRINT_COUNT = 50; ## with -vv, print every VV_PRINT_COUNT files, or...
+ $VV_SIZE = 1024*1024; ## ...every VV_SIZE bytes searched
+ $vv_print = $vv_size = 0; ## running totals.
+
+ ## set default options, in case the rc file wants them
+ $opt{'TTY'}= 1 if -t STDOUT;
+
+ ## want to know this for debugging message stuff
+ $STDERR_IS_TTY = -t STDERR ? 1 : 0;
+ $STDERR_SCREWS_STDOUT = ($STDERR_IS_TTY && -t STDOUT) ? 1 : 0;
+
+ $0 =~ s,.*/,,; ## clean up $0 for any diagnostics we'll be printing.
+}
+
+##
+## Check arguments.
+##
+sub check_args
+{
+ while (@ARGV && $ARGV[0] =~ m/^-/)
+ {
+ $arg = shift(@ARGV);
+
+ if ($arg eq '-version' || ($VERBOSE && $arg eq '-help')) {
+ print qq/Jeffrey's file search, version "$version".\n/;
+ exit(0) unless $arg eq '-help';
+ }
+ if ($arg eq '-help') {
+ print <<INLINE_LITERAL_TEXT;
+usage: $0 [options] [-e] [PerlRegex ....]
+OPTIONS TELLING *WHERE* TO SEARCH:
+ -dir DIR start search at the named directory (default is current dir).
+ -xdev stay on starting file system.
+ -sort sort the files in each directory before processing.
+ -nolinks don't follow symbolic links.
+OPTIONS TELLING WHICH FILES TO EVEN CONSIDER:
+ -mtime # consider files modified > # days ago (-# for < # days old)
+ -newer FILE consider files modified more recently than FILE (also -older)
+ -name GLOB consider files whose name matches pattern (also -regex).
+ -skip GLOB opposite of -name: identifies files to not consider.
+ -path GLOB like -name, but for files whose whole path is described.
+ -dpath/-dregex/-dskip versions for selecting or pruning directories.
+ -all don't skip any files marked to be skipped by the startup file.
+ -x<SPECIAL> (see manual, and/or try -showrc).
+ -why report why a file isn't checked (also implied by -vvvv).
+OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED:
+ -f | -find just list files (PerlRegex ignored). Default is to grep them.
+ -ff | -ffind Does a faster -find (implies -find -all -dorep)
+OPTIONS CONTROLLING HOW THE SEARCH IS DONE (AND WHAT IS PRINTED):
+ -l | -list only list files with matches, not the lines themselves.
+ -nice | -nnice print more "human readable" output.
+ -n prefix each output line with its line number in the file.
+ -h don't prefix output lines with file name.
+ -u also look "inside" manpage-style underlined text
+ -i do case-insensitive searching.
+ -w match words only (as defined by perl's \\b).
+OTHER OPTIONS:
+ -v, -vv, -vvv various levels of message verbosity.
+ -e end of options (in case a regex looks like an option).
+ -showrc show what the rc file sets, then exit.
+ -norc don't load the rc file.
+ -dorep check files with multiple hard links multiple times.
+INLINE_LITERAL_TEXT
+ print "Use -v -help for more verbose help.\n" unless $VERBOSE;
+ print "This script file is also a man page.\n" unless $stripped;
+ print <<INLINE_LITERAL_TEXT if $VERBOSE;
+
+If -f (or -find) given, PerlRegex is optional and ignored.
+Otherwise, will search for files with lines matching any of the given regexes.
+
+Combining things like -name and -mtime implies boolean AND.
+However, duplicating things (such as -name '*.c' -name '*.txt') implies OR.
+
+-mtime may be given floating point (i.e. 1.5 is a day and a half).
+-iskip/-idskip/-ipath/... etc are case-insensitive versions.
+
+If any letter in -newer/-older is upper case, "or equal" is
+inserted into the test.
+
+You can always find the latest version on the World Wide Web in
+ http://www.wg.omron.co.jp/~jfriedl/perl/
+INLINE_LITERAL_TEXT
+ exit(0);
+ }
+ $DOREP=1, next if $arg eq '-dorep'; ## do repeats
+ $DO_SORT=1, next if $arg eq '-sort'; ## sort files
+ $NOLINKS=1, next if $arg eq '-nolinks'; ## no sym. links
+ $PREPEND_FILENAME=0, next if $arg eq '-h'; ## no filename prefix
+ $REPORT_LINENUM=1, next if $arg eq '-n'; ## show line numbers
+ $WHY=1, next if $arg eq '-why'; ## tell why skipped
+ $XDEV=1, next if $arg eq '-xdev'; ## don't leave F.S.
+ $all=1,$opt{'-all'}=1,next if $arg eq '-all'; ## don't skip *.Z, etc
+ $iflag='i', next if $arg eq '-i'; ## ignore case
+ $norc=1, next if $arg eq '-norc'; ## don't load rc file
+ $showrc=1, next if $arg eq '-showrc'; ## show rc file
+ $underlineOK=1, next if $arg eq '-u'; ## look throuh underln.
+ $words=1, next if $arg eq '-w'; ## match "words" only
+ &strip if $arg eq '-strip'; ## dump this program
+ last if $arg eq '-e';
+ $DELAY=$1, next if $arg =~ m/-delay(\d+)/;
+
+ $FIND_ONLY=1, next if $arg =~/^-f(ind)?$/;## do "find" only
+
+ $FIND_ONLY=1, $DOREP=1, $all=1,
+ next if $arg =~/^-ff(ind)?$/;## fast -find
+ $LIST_ONLY=1,$opt{'-list'}=1,
+ next if $arg =~/^-l(ist)?$/;## only list files
+
+ if ($arg =~ m/^-(v+)$/) { ## verbosity
+ $VERBOSE =length($1);
+ foreach $len (1..$VERBOSE) { $opt{'-'.('v' x $len)}=1 }
+ next;
+ }
+ if ($arg =~ m/^-(n+)ice$/) { ## "nice" output
+ $NICE =length($1);
+ foreach $len (1..$NICE) { $opt{'-'.('n' x $len).'ice'}=1 }
+ next;
+ }
+
+ if ($arg =~ m/^-(i?)(d?)skip$/) {
+ local($i) = $1 eq 'i';
+ local($d) = $2 eq 'd';
+ $! = 2, die qq/$0: expecting glob arg to -$arg\n/ unless @ARGV;
+ foreach (split(/\s+/, shift @ARGV)) {
+ if ($d) {
+ $idskip{$_}=1 if $i;
+ $dskip{$_}=1;
+ } else {
+ $iskip{$_}=1 if $i;
+ $skip{$_}=1;
+ }
+ }
+ next;
+ }
+
+
+ if ($arg =~ m/^-(i?)(d?)(regex|path|name)$/) {
+ local($i) = $1 eq 'i';
+ $! = 2, die qq/$0: expecting arg to -$arg\n/ unless @ARGV;
+ foreach (split(/\s+/, shift @ARGV)) {
+ $iname{join(',', $arg, $_)}=1 if $i;
+ $name{join(',', $arg, $_)}=1;
+ }
+ next;
+ }
+
+ if ($arg =~ m/^-d?dir$/) {
+ $opt{'-dir'}=1;
+ $! = 2, die qq/$0: expecting filename arg to -$arg\n/ unless @ARGV;
+ $start = shift(@ARGV);
+ $start =~ s#^~(/+|$)#$ENV{'HOME'}$1# if defined $ENV{'HOME'};
+ $! = 2, die qq/$0: can't find ${arg}'s "$start"\n/ unless -e $start;
+ $! = 2, die qq/$0: ${arg}'s "$start" not a directory.\n/ unless -d _;
+ undef(@todo), $opt{'-ddir'}=1 if $arg eq '-ddir';
+ push(@todo, $start);
+ next;
+ }
+
+ if ($arg =~ m/^-(new|old)er$/i) {
+ $! = 2, die "$0: expecting filename arg to -$arg\n" unless @ARGV;
+ local($file, $time) = shift(@ARGV);
+ $! = 2, die qq/$0: can't stat -${arg}'s "$file"./
+ unless $time = (stat($file))[$STAT_MTIME];
+ local($upper) = $arg =~ tr/A-Z//;
+ if ($arg =~ m/new/i) {
+ $time++ unless $upper;
+ $NEWER = $time if $NEWER < $time;
+ } else {
+ $time-- unless $upper;
+ $OLDER = $time if $OLDER == 0 || $OLDER > $time;
+ }
+ next;
+ }
+
+ if ($arg =~ m/-mtime/) {
+ $! = 2, die "$0: expecting numerical arg to -$arg\n" unless @ARGV;
+ local($days) = shift(@ARGV);
+ $! = 2, die qq/$0: inappropriate arg ($days) to $arg\n/ if $days==0;
+ $days *= 3600 * 24;
+ if ($days < 0) {
+ local($time) = $^T + $days;
+ $NEWER = $time if $NEWER < $time;
+ } else {
+ local($time) = $^T - $days;
+ $OLDER = $time if $OLDER == 0 || $OLDER > $time;
+ }
+ next;
+ }
+
+ ## special user options
+ if ($arg =~ m/^-x(.+)/) {
+ foreach (split(/[\s,]+/, $1)) { $user_opt{$_} = $opt{$_}= 1; }
+ next;
+ }
+
+ $! = 2, die "$0: unknown arg [$arg]\n";
+ }
+}
+
+##
+## Given a filename glob, return a regex.
+## If the glob has no globbing chars (no * ? or [..]), then
+## prepend an effective '*' to it.
+##
+sub glob_to_regex
+{
+ local($glob) = @_;
+ local(@parts) = $glob =~ m/\\.|[*?]|\[]?[^]]*]|[^[\\*?]+/g;
+ local($trueglob)=0;
+ foreach (@parts) {
+ if ($_ eq '*' || $_ eq '?') {
+ $_ = ".$_";
+ $trueglob=1; ## * and ? are a real glob
+ } elsif (substr($_, 0, 1) eq '[') {
+ $trueglob=1; ## [..] is a real glob
+ } else {
+ s/^\\//; ## remove any leading backslash;
+ s/\W/\\$&/g; ## now quote anything dangerous;
+ }
+ }
+ unshift(@parts, '.*') unless $trueglob;
+ join('', '^', @parts, '$');
+}
+
+sub prepare_to_search
+{
+ local($rc_file) = @_;
+
+ $HEADER_BYTES=0; ## Might be set nonzero in &read_rc;
+ $last_message_length = 0; ## For &message and &clear_message.
+
+ &read_rc($rc_file, $showrc) unless $norc;
+ exit(0) if $showrc;
+
+ $NEXT_DIR_ENTRY = $DO_SORT ? 'shift @files' : 'readdir(DIR)';
+ $WHY = 1 if $VERBOSE > 3; ## Arg -vvvv or above implies -why.
+ @todo = ('.') if @todo == 0; ## Where we'll start looking
+
+ ## see if any user options were specified that weren't accounted for
+ foreach $opt (keys %user_opt) {
+ next if defined $seen_opt{$opt};
+ warn "warning: -x$opt never considered.\n";
+ }
+
+ die "$0: multiple time constraints exclude all possible files.\n"
+ if ($NEWER && $OLDER) && ($NEWER > $OLDER);
+
+ ##
+ ## Process any -skip/-iskip args that had been given
+ ##
+ local(@skip_test);
+ foreach $glob (keys %skip) {
+ $i = defined($iskip{$glob}) ? 'i': '';
+ push(@skip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i");
+ }
+ if (@skip_test) {
+ $SKIP_TEST = join('||',@skip_test);
+ $DO_SKIP_TEST = 1;
+ } else {
+ $DO_SKIP_TEST = $SKIP_TEST = 0;
+ }
+
+ ##
+ ## Process any -dskip/-idskip args that had been given
+ ##
+ local(@dskip_test);
+ foreach $glob (keys %dskip) {
+ $i = defined($idskip{$glob}) ? 'i': '';
+ push(@dskip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i");
+ }
+ if (@dskip_test) {
+ $DSKIP_TEST = join('||',@dskip_test);
+ $DO_DSKIP_TEST = 1;
+ } else {
+ $DO_DSKIP_TEST = $DSKIP_TEST = 0;
+ }
+
+
+ ##
+ ## Process any -name, -path, -regex, etc. args that had been given.
+ ##
+ undef @name_test;
+ undef @dname_test;
+ foreach $key (keys %name) {
+ local($type, $pat) = split(/,/, $key, 2);
+ local($i) = defined($iname{$key}) ? 'i' : '';
+ if ($type =~ /regex/) {
+ $pat =~ s/!/\\!/g;
+ $test = "\$name =~ m!^$pat\$!$i";
+ } else {
+ local($var) = $type eq 'name' ? '$name' : '$file';
+ $test = "$var =~ m/". &glob_to_regex($pat). "/$i";
+ }
+ if ($type =~ m/^-i?d/) {
+ push(@dname_test, $test);
+ } else {
+ push(@name_test, $test);
+ }
+ }
+ if (@name_test) {
+ $GLOB_TESTS = join('||', @name_test);
+
+ $DO_GLOB_TESTS = 1;
+ } else {
+ $GLOB_TESTS = $DO_GLOB_TESTS = 0;
+ }
+ if (@dname_test) {
+ $DGLOB_TESTS = join('||', @dname_test);
+ $DO_DGLOB_TESTS = 1;
+ } else {
+ $DGLOB_TESTS = $DO_DGLOB_TESTS = 0;
+ }
+
+
+ ##
+ ## Process any 'magic' things from the startup file.
+ ##
+ if (@magic_tests && $HEADER_BYTES) {
+ ## the $magic' one is for when &dodir is not inlined
+ $tests = join('||',@magic_tests);
+ $MAGIC_TESTS = " { package magic; \$val = ($tests) }";
+ $DO_MAGIC_TESTS = 1;
+ } else {
+ $MAGIC_TESTS = 1;
+ $DO_MAGIC_TESTS = 0;
+ }
+
+ ##
+ ## Prepare regular expressions.
+ ##
+ {
+ local(@regex_tests);
+
+ if ($LIST_ONLY) {
+ $mflag = '';
+ ## need to have $* set, but perl5 just won''t shut up about it.
+ if ($] >= 5) {
+ $mflag = 'm';
+ } else {
+ eval ' $* = 1 ';
+ }
+ }
+
+ ##
+ ## Until I figure out a better way to deal with it,
+ ## We have to worry about a regex like [^xyz] when doing $LIST_ONLY.
+ ## Such a regex *will* match \n, and if I'm pulling in multiple
+ ## lines, it can allow lines to match that would otherwise not match.
+ ##
+ ## Therefore, if there is a '[^' in a regex, we can NOT take a chance
+ ## an use the fast listonly.
+ ##
+ $CAN_USE_FAST_LISTONLY = $LIST_ONLY;
+
+ local(@extra);
+ local($underline_glue) = ($] >= 5) ? '(:?_\cH)?' : '(_\cH)?';
+ while (@ARGV) {
+ $regex = shift(@ARGV);
+ ##
+ ## If watching for underlined things too, add another regex.
+ ##
+ if ($underlineOK) {
+ if ($regex =~ m/[?*+{}()\\.|^\$[]/) {
+ warn "$0: warning, can't underline-safe ``$regex''.\n";
+ } else {
+ $regex = join($underline_glue, split(//, $regex));
+ }
+ }
+
+ ## If nothing special in the regex, just use index...
+ ## is quite a bit faster.
+ if (($iflag eq '') && ($words == 0) &&
+ $regex !~ m/[?*+{}()\\.|^\$[]/)
+ {
+ push(@regex_tests, "(index(\$_, q+$regex+)>=0)");
+
+ } else {
+ $regex =~ s#[\$\@\/]\w#\\$&#;
+ if ($words) {
+ if ($regex =~ m/\|/) {
+ ## could be dangerous -- see if we can wrap in parens.
+ if ($regex =~ m/\\\d/) {
+ warn "warning: -w and a | in a regex is dangerous.\n"
+ } else {
+ $regex = join($regex, '(', ')');
+ }
+ }
+ $regex = join($regex, '\b', '\b');
+ }
+ $CAN_USE_FAST_LISTONLY = 0 if substr($regex, "[^") >= 0;
+ push(@regex_tests, "m/$regex/$iflag$mflag");
+ }
+
+ ## If we're done, but still have @extra to do, get set for that.
+ if (@ARGV == 0 && @extra) {
+ @ARGV = @extra; ## now deal with the extra stuff.
+ $underlineOK = 0; ## but no more of this.
+ undef @extra; ## or this.
+ }
+ }
+ if (@regex_tests) {
+ $REGEX_TEST = join('||', @regex_tests);
+ ## print STDERR $REGEX_TEST, "\n"; exit;
+ } else {
+ ## must be doing -find -- just give something syntactically correct.
+ $REGEX_TEST = 1;
+ }
+ }
+
+ ##
+ ## Make sure we can read the first item(s).
+ ##
+ foreach $start (@todo) {
+ $! = 2, die qq/$0: can't stat "$start"\n/
+ unless ($dev,$inode) = (stat($start))[$STAT_DEV,$STAT_INODE];
+
+ if (defined $dir_done{"$dev,$inode"}) {
+ ## ignore the repeat.
+ warn(qq/ignoring "$start" (same as "$dir_done{"$dev,$inode"}").\n/)
+ if $VERBOSE;
+ next;
+ }
+
+ ## if -xdev was given, remember the device.
+ $xdev{$dev} = 1 if $XDEV;
+
+ ## Note that we won't want to do it again
+ $dir_done{"$dev,$inode"} = $start;
+ }
+}
+
+
+##
+## See the comment above the __END__ above the 'sub dodir' below.
+##
+sub import_program
+{
+ sub bad {
+ print STDERR "$0: internal error (@_)\n";
+ exit 2;
+ }
+
+ ## Read from data, up to next __END__. This will be &dodir.
+ local($/) = "\n__END__";
+ $prog = <DATA>;
+ close(DATA);
+
+ $prog =~ s/\beval\b//g; ## remove any 'eval'
+
+ ## Inline uppercase $-variables by their current values.
+ if ($] >= 5) {
+ $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/
+ &bad($1) if !defined ${$main::{$1}}; ${$main::{$1}};/eg;
+ } else {
+ $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/local(*VAR) = $_main{$1};
+ &bad($1) if !defined $VAR; $VAR;/eg;
+ }
+
+ eval $prog; ## now do it. This will define &dodir;
+ $!=2, die "$0 internal error: $@\n" if $@;
+}
+
+###########################################################################
+
+##
+## Read the .search file:
+## Blank lines and lines that are only #-comments ignored.
+## Newlines may be escaped to create long lines
+## Other lines are directives.
+##
+## A directive may begin with an optional tag in the form <...>
+## Things inside the <...> are evaluated as with:
+## <(this || that) && must>
+## will be true if
+## -xmust -xthis or -xmust -xthat
+## were specified on the command line (order doesn't matter, though)
+## A directive is not done if there is a tag and it's false.
+## Any characters but whitespace and &|()>,! may appear after an -x
+## (although "-xdev" is special). -xmust,this is the same as -xmust -xthis.
+## Something like -x~ would make <~> true, and <!~> false.
+##
+## Directives are in the form:
+## option: STRING
+## magic : NUMBYTES : EXPR
+##
+## With option:
+## The STRING is parsed like a Bourne shell command line, and the
+## options are used as if given on the command line.
+## No comments are allowed on 'option' lines.
+## Examples:
+## # skip objects and libraries
+## option: -skip '.o .a'
+## # skip emacs *~ and *# files, unless -x~ given:
+## <!~> option: -skip '~ #'
+##
+## With magic:
+## EXPR can be pretty much any perl (comments allowed!).
+## If it evaluates to true for any particular file, it is skipped.
+## The only info you'll have about a file is the variable $H, which
+## will have at least the first NUMBYTES of the file (less if the file
+## is shorter than that, of course, and maybe more). You'll also have
+## any variables you set in previous 'magic' lines.
+## Examples:
+## magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a'
+## magic: 6 : $x6 eq 'GIF89a'
+##
+## magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a' ## old gif \
+## || $x6 eq 'GIF89a' ## new gif
+## (the above two sets are the same)
+## ## Check the first 32 bytes for "binarish" looking bytes.
+## ## Don't blindly dump on any high-bit set, as non-ASCII text
+## ## often has them set. \x80 and \xff seem to be special, though.
+## ## Require two in a row to not get things like perl's $^T.
+## ## This is known to get *.Z, *.gz, pkzip, *.elc and about any
+## ## executable you'll find.
+## magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
+##
+sub read_rc
+{
+ local($file, $show) = @_;
+ local($line_num, $ln, $tag) = 0;
+ local($use_default, @default) = 0;
+
+ { package magic; $^W= 0; } ## turn off warnings for when we run EXPR's
+
+ unless (open(RC, "$file")) {
+ $use_default=1;
+ $file = "<internal default startup file>";
+ ## no RC file -- use this default.
+ @default = split(/\n/,<<'--------INLINE_LITERAL_TEXT');
+ magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
+ option: -skip '.a .elc .gz .o .pbm .xbm .dvi'
+ option: -iskip '.com .exe .lib .pdb .tarz .zip .z .lzh .jpg .jpeg .gif .uu'
+ <!~> option: -skip '~ #'
+--------INLINE_LITERAL_TEXT
+ }
+
+ ##
+ ## Make an eval error pretty.
+ ##
+ sub clean_eval_error {
+ local($_) = @_;
+ s/ in file \(eval\) at line \d+,//g; ## perl4-style error
+ s/ at \(eval \d+\) line \d+,//g; ## perl5-style error
+ $_ = $` if m/\n/; ## remove all but first line
+ "$_\n";
+ }
+
+ print "reading RC file: $file\n" if $show;
+
+ while (defined($_ = ($use_default ? shift(@default) : <RC>))) {
+ $ln = ++$line_num; ## note starting line num.
+ $_ .= <RC>, $line_num++ while s/\\\n?$/\n/; ## allow continuations
+ next if /^\s*(#.*)?$/; ## skip blank or comment-only lines.
+ $do = '';
+
+ ## look for an initial <...> tag.
+ if (s/^\s*<([^>]*)>//) {
+ ## This simple s// will make the tag ready to eval.
+ ($tag = $msg = $1) =~
+ s/[^\s&|(!)]+/
+ $seen_opt{$&}=1; ## note seen option
+ "defined(\$opt{q>$&>})" ## (q>> is safe quoting here)
+ /eg;
+
+ ## see if the tag is true or not, abort this line if not.
+ $dothis = (eval $tag);
+ $!=2, die "$file $ln <$msg>: $_".&clean_eval_error($@) if $@;
+
+ if ($show) {
+ $msg =~ s/[^\s&|(!)]+/-x$&/;
+ $msg =~ s/\s*!\s*/ no /g;
+ $msg =~ s/\s*&&\s*/ and /g;
+ $msg =~ s/\s*\|\|\s*/ or /g;
+ $msg =~ s/^\s+//; $msg =~ s/\s+$//;
+ $do = $dothis ? "(doing because $msg)" :
+ "(do if $msg)";
+ } elsif (!$dothis) {
+ next;
+ }
+ }
+
+ if (m/^\s*option\s*:\s*/) {
+ next if $all && !$show; ## -all turns off these checks;
+ local($_) = $';
+ s/\n$//;
+ local($orig) = $_;
+ print " $do option: $_\n" if $show;
+ local($0) = "$0 ($file)"; ## for any error message.
+ local(@ARGV);
+ local($this);
+ ##
+ ## Parse $_ as a Bourne shell line -- fill @ARGV
+ ##
+ while (length) {
+ if (s/^\s+//) {
+ push(@ARGV, $this) if defined $this;
+ undef $this;
+ next;
+ }
+ $this = '' if !defined $this;
+ $this .= $1 while s/^'([^']*)'// ||
+ s/^"([^"]*)"// ||
+ s/^([^'"\s\\]+)//||
+ s/^(\\[\D\d])//;
+ die "$file $ln: error parsing $orig at $_\n" if m/^\S/;
+ }
+ push(@ARGV, $this) if defined $this;
+ &check_args;
+ die qq/$file $ln: unused arg "@ARGV".\n/ if @ARGV;
+ next;
+ }
+
+ if (m/^\s*magic\s*:\s*(\d+)\s*:\s*/) {
+ next if $all && !$show; ## -all turns off these checks;
+ local($bytes, $check) = ($1, $');
+
+ if ($show) {
+ $check =~ s/\n?$/\n/;
+ print " $do contents: $check";
+ }
+ ## Check to make sure the thing at least compiles.
+ eval "package magic; (\$H = '1'x \$main'bytes) && (\n$check\n)\n";
+ $! = 2, die "$file $ln: ".&clean_eval_error($@) if $@;
+
+ $HEADER_BYTES = $bytes if $bytes > $HEADER_BYTES;
+ push(@magic_tests, "(\n$check\n)");
+ next;
+ }
+ $! = 2, die "$file $ln: unknown command\n";
+ }
+ close(RC);
+}
+
+sub message
+{
+ if (!$STDERR_IS_TTY) {
+ print STDERR $_[0], "\n";
+ } else {
+ local($text) = @_;
+ $thislength = length($text);
+ if ($thislength >= $last_message_length) {
+ print STDERR $text, "\r";
+ } else {
+ print STDERR $text, ' 'x ($last_message_length-$thislength),"\r";
+ }
+ $last_message_length = $thislength;
+ }
+}
+
+sub clear_message
+{
+ print STDERR ' ' x $last_message_length, "\r" if $last_message_length;
+ $vv_print = $vv_size = $last_message_length = 0;
+}
+
+##
+## Output a copy of this program with comments, extra whitespace, and
+## the trailing man page removed. On an ultra slow machine, such a copy
+## might load faster (but I can't tell any difference on my machine).
+##
+sub strip {
+ seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n";
+ while(<DATA>) {
+ print, next if /INLINE_LITERAL_TEXT/.../INLINE_LITERAL_TEXT/;
+ ## must mention INLINE_LITERAL_TEXT on this line!
+ s/\#\#.*|^\s+|\s+$//; ## remove cruft
+ last if $_ eq '.00;';
+ next if ($_ eq '') || ($_ eq "'di'") || ($_ eq "'ig00'");
+ s/\$stripped=0;/\$stripped=1;/;
+ s/\s\s+/ /; ## squish multiple whitespaces down to one.
+ print $_, "\n";
+ }
+ exit(0);
+}
+
+##
+## Just to shut up -w. Never executed.
+##
+sub dummy {
+
+ 1 || &dummy || &dir_done || &bad || &message || $NEXT_DIR_ENTRY ||
+ $DELAY || $VV_SIZE || $VV_PRINT_COUNT || $STDERR_SCREWS_STDOUT ||
+ @files || @files || $magic'H || $magic'H || $xdev{''} || &clear_message;
+
+}
+
+##
+## If the following __END__ is in place, what follows will be
+## inlined when the program first starts up. Any $ variable name
+## all in upper case, specifically, any string matching
+## \$([A-Z][A-Z0-9_]{2,}\b
+## will have the true value for that variable inlined. Also, any 'eval' is
+## removed
+##
+## The idea is that when the whole thing is then eval'ed to define &dodir,
+## the perl optimizer will make all the decisions that are based upon
+## command-line options (such as $VERBOSE), since they'll be inlined as
+## constants
+##
+## Also, and here's the big win, the tests for matching the regex, and a
+## few others, are all inlined. Should be blinding speed here.
+##
+## See the read from <DATA> above for where all this takes place.
+## But all-in-all, you *want* the __END__ here. Comment it out only for
+## debugging....
+##
+
+__END__
+
+##
+## Given a directory, check all "appropriate" files in it.
+## Shove any subdirectories into the global @todo, so they'll be done
+## later.
+##
+## Be careful about adding any upper-case variables, as they are subject
+## to being inlined. See comments above the __END__ above.
+##
+sub dodir
+{
+ local($dir) = @_;
+ $dir =~ s,/+$,,; ## remove any trailing slash.
+ unless (opendir(DIR, "$dir/.")) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq($0: can't opendir "$dir/".\n);
+ return;
+ }
+
+ if ($VERBOSE) {
+ &message($dir);
+ $vv_print = $vv_size = 0;
+ }
+
+ @files = sort readdir(DIR) if $DO_SORT;
+
+ while (defined($name = eval $NEXT_DIR_ENTRY))
+ {
+ next if $name eq '.' || $name eq '..'; ## never follow these.
+
+ ## create full relative pathname.
+ $file = $dir eq '.' ? $name : "$dir/$name";
+
+ ## if link and skipping them, do so.
+ if ($NOLINKS && -l $file) {
+ warn qq/skip (symlink): $file\n/ if $WHY;
+ next;
+ }
+
+ ## skip things unless files or directories
+ unless (-f $file || -d _) {
+ if ($WHY) {
+ $why = (-S _ && "socket") ||
+ (-p _ && "pipe") ||
+ (-b _ && "block special")||
+ (-c _ && "char special") || "somekinda special";
+ warn qq/skip ($why): $file\n/;
+ }
+ next;
+ }
+
+ ## skip things we can't read
+ unless (-r _) {
+ if ($WHY) {
+ $why = (-l $file) ? "follow" : "read";
+ warn qq/skip (can't $why): $file\n/;
+ }
+ next;
+ }
+
+ ## skip things that are empty
+ unless (-s _ || -d _) {
+ warn qq/skip (empty): $file\n/ if $WHY;
+ next;
+ }
+
+ ## Note file device & inode. If -xdev, skip if appropriate.
+ ($dev, $inode) = (stat(_))[$STAT_DEV, $STAT_INODE];
+ if ($XDEV && defined $xdev{$dev}) {
+ warn qq/skip (other device): $file\n/ if $WHY;
+ next;
+ }
+ $id = "$dev,$inode";
+
+ ## special work for a directory
+ if (-d _) {
+ ## Do checks for directory file endings.
+ if ($DO_DSKIP_TEST && (eval $DSKIP_TEST)) {
+ warn qq/skip (-dskip): $file\n/ if $WHY;
+ next;
+ }
+ ## do checks for -name/-regex/-path tests
+ if ($DO_DGLOB_TESTS && !(eval $DGLOB_TESTS)) {
+ warn qq/skip (dirname): $file\n/ if $WHY;
+ next;
+ }
+
+ ## _never_ redo a directory
+ if (defined $dir_done{$id} and $^O ne 'MSWin32') {
+ warn qq/skip (did as "$dir_done{$id}"): $file\n/ if $WHY;
+ next;
+ }
+ $dir_done{$id} = $file; ## mark it done.
+ unshift(@todo, $file); ## add to the list to do.
+ next;
+ }
+ if ($WHY == 0 && $VERBOSE > 1) {
+ if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){
+ &message($file);
+ $vv_print = $vv_size = 0;
+ }
+ }
+
+ ## do time-related tests
+ if ($NEWER || $OLDER) {
+ $_ = (stat(_))[$STAT_MTIME];
+ if ($NEWER && $_ < $NEWER) {
+ warn qq/skip (too old): $file\n/ if $WHY;
+ next;
+ }
+ if ($OLDER && $_ > $OLDER) {
+ warn qq/skip (too new): $file\n/ if $WHY;
+ next;
+ }
+ }
+
+ ## do checks for file endings
+ if ($DO_SKIP_TEST && (eval $SKIP_TEST)) {
+ warn qq/skip (-skip): $file\n/ if $WHY;
+ next;
+ }
+
+ ## do checks for -name/-regex/-path tests
+ if ($DO_GLOB_TESTS && !(eval $GLOB_TESTS)) {
+ warn qq/skip (filename): $file\n/ if $WHY;
+ next;
+ }
+
+
+ ## If we're not repeating files,
+ ## skip this one if we've done it, or note we're doing it.
+ unless ($DOREP) {
+ if (defined $file_done{$id}) {
+ warn qq/skip (did as "$file_done{$id}"): $file\n/ if $WHY;
+ next;
+ }
+ $file_done{$id} = $file;
+ }
+
+ if ($DO_MAGIC_TESTS) {
+ if (!open(FILE_IN, $file)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't open: $file\n/;
+ next;
+ }
+ unless (read(FILE_IN, $magic'H, $HEADER_BYTES)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't read from "$file"\n"/;
+ close(FILE_IN);
+ next;
+ }
+
+ eval $MAGIC_TESTS;
+ if ($magic'val) {
+ close(FILE_IN);
+ warn qq/skip (magic): $file\n/ if $WHY;
+ next;
+ }
+ seek(FILE_IN, 0, 0); ## reset for later <FILE_IN>
+ }
+
+ if ($WHY != 0 && $VERBOSE > 1) {
+ if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){
+ &message($file);
+ $vv_print = $vv_size = 0;
+ }
+ }
+
+ if ($DELAY) {
+ sleep($DELAY);
+ }
+
+ if ($FIND_ONLY) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ print $file, "\n";
+ $retval=0; ## we've found something
+ close(FILE_IN) if $DO_MAGIC_TESTS;
+ next;
+ } else {
+ ## if we weren't doing magic tests, file won't be open yet...
+ if (!$DO_MAGIC_TESTS && !open(FILE_IN, $file)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't open: $file\n/;
+ next;
+ }
+ if ($LIST_ONLY && $CAN_USE_FAST_LISTONLY) {
+ ##
+ ## This is rather complex, but buys us a LOT when we're just
+ ## listing files and not the individual internal lines.
+ ##
+ local($size) = 4096; ## block-size in which to do reads
+ local($nl); ## will point to $_'s ending newline.
+ local($read); ## will be how many bytes read.
+ local($_) = ''; ## Starts out empty
+ local($hold); ## (see below)
+
+ while (($read = read(FILE_IN,$_,$size,length($_)))||length($_))
+ {
+ undef @parts;
+ ## if read a full block, but no newline, need to read more.
+ while ($read == $size && ($nl = rindex($_, "\n")) < 0) {
+ push(@parts, $_); ## save that part
+ $read = read(FILE_IN, $_, $size); ## keep trying
+ }
+
+ ##
+ ## If we had to save parts, must now combine them together.
+ ## adjusting $nl to reflect the now-larger $_. This should
+ ## be a lot more efficient than using any kind of .= in the
+ ## loop above.
+ ##
+ if (@parts) {
+ local($lastlen) = length($_); #only need if $nl >= 0
+ $_ = join('', @parts, $_);
+ $nl = length($_) - ($lastlen - $nl) if $nl >= 0;
+ }
+
+ ##
+ ## If we're at the end of the file, then we can use $_ as
+ ## is. Otherwise, we need to remove the final partial-line
+ ## and save it so that it'll be at the beginning of the
+ ## next read (where the rest of the line will be layed in
+ ## right after it). $hold will be what we should save
+ ## until next time.
+ ##
+ if ($read != $size || $nl < 0) {
+ $hold = '';
+ } else {
+ $hold = substr($_, $nl + 1);
+ substr($_, $nl + 1) = '';
+ }
+
+ ##
+ ## Now have a bunch of full lines in $_. Use it.
+ ##
+ if (eval $REGEX_TEST) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ print $file, "\n";
+ $retval=0; ## we've found something
+
+ last;
+ }
+
+ ## Prepare for next read....
+ $_ = $hold;
+ }
+
+ } else { ## else not using faster block scanning.....
+
+ $lines_printed = 0 if $NICE;
+ while (<FILE_IN>) {
+ study;
+ next unless (eval $REGEX_TEST);
+
+ ##
+ ## We found a matching line.
+ ##
+ $retval=0;
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ if ($LIST_ONLY) {
+ print $file, "\n";
+ last;
+ } else {
+ ## prepare to print line.
+ if ($NICE && $lines_printed++ == 0) {
+ print '-' x 70, "\n" if $NICE > 1;
+ print $file, ":\n";
+ }
+
+ ##
+ ## Print all the prelim stuff. This looks less efficient
+ ## than it needs to be, but that's so that when the eval
+ ## is compiled (and the tests are optimized away), the
+ ## result will be less actual PRINTs than the more natural
+ ## way of doing these tests....
+ ##
+ if ($NICE) {
+ if ($REPORT_LINENUM) {
+ print " line $.: ";
+ } else {
+ print " ";
+ }
+ } elsif ($REPORT_LINENUM && $PREPEND_FILENAME) {
+ print "$file,:$.: ";
+ } elsif ($PREPEND_FILENAME) {
+ print "$file: ";
+ } elsif ($REPORT_LINENUM) {
+ print "$.: ";
+ }
+ print $_;
+ print "\n" unless m/\n$/;
+ }
+ }
+ print "\n" if ($NICE > 1) && $lines_printed;
+ }
+ close(FILE_IN);
+ }
+ }
+ closedir(DIR);
+}
+
+__END__
+.00; ## finish .ig
+
+'di \" finish diversion--previous line must be blank
+.nr nl 0-1 \" fake up transition to first page again
+.nr % 0 \" start at page 1
+.\"__________________NORMAL_MAN_PAGE_BELOW_________________
+.ll+10n
+.TH search 1 "Dec 17, 1994"
+.SH SEARCH
+search \- search files (a'la grep) in a whole directory tree.
+.SH SYNOPSIS
+search [ grep-like and find-like options] [regex ....]
+.SH DESCRIPTION
+.I Search
+is more or less a combo of 'find' and 'grep' (although the regular
+expression flavor is that of the perl being used, which is closer to
+egrep's than grep's).
+
+.I Search
+does generally the same kind of thing that
+.nf
+ find <blah blah> | xargs egrep <blah blah>
+.fi
+does, but is
+.I much
+more powerful and efficient (and intuitive, I think).
+
+This manual describes
+.I search
+as of version "941227.4". You can always find the latest version at
+.nf
+ http://www.wg.omron.co.jp/~jfriedl/perl/index.html
+.fi
+
+.SH "QUICK EXAMPLE"
+Basic use is simple:
+.nf
+ % search jeff
+.fi
+will search files in the current directory, and all sub directories, for
+files that have "jeff" in them. The lines will be listed with the
+containing file's name prepended.
+.PP
+If you list more than one regex, such as with
+.nf
+ % search jeff Larry Randal+ 'Stoc?k' 'C.*son'
+.fi
+then a line containing any of the regexes will be listed.
+This makes it effectively the same as
+.nf
+ % search 'jeff|Larry|Randal+|Stoc?k|C.*son'
+.fi
+However, listing them separately is much more efficient (and is easier
+to type).
+.PP
+Note that in the case of these examples, the
+.B \-w
+(list whole-words only) option would be useful.
+.PP
+Normally, various kinds of files are automatically removed from consideration.
+If it has has a certain ending (such as ".tar", ".Z", ".o", .etc), or if
+the beginning of the file looks like a binary, it'll be excluded.
+You can control exactly how this works -- see below. One quick way to
+override this is to use the
+.B \-all
+option, which means to consider all the files that would normally be
+automatically excluded.
+Or, if you're curious, you can use
+.B \-why
+to have notes about what files are skipped (and why) printed to stderr.
+
+.SH "BASIC OVERVIEW"
+Normally, the search starts in the current directory, considering files in
+all subdirectories.
+
+You can use the
+.I ~/.search
+file to control ways to automatically exclude files.
+If you don't have this file, a default one will kick in, which automatically
+add
+.nf
+ -skip .o .Z .gif
+.fi
+(among others) to exclude those kinds of files (which you probably want to
+skip when searching for text, as is normal).
+Files that look to be be binary will also be excluded.
+
+Files ending with "#" and "~" will also be excluded unless the
+.B -x~
+option is given.
+
+You can use
+.B -showrc
+to show what kinds of files will normally be skipped.
+See the section on the startup file
+for more info.
+
+You can use the
+.B -all
+option to indicate you want to consider all files that would otherwise be
+skipped by the startup file.
+
+Based upon various other flags (see "WHICH FILES TO CONSIDER" below),
+more files might be removed from consideration. For example
+.nf
+ -mtime 3
+.fi
+will exclude files that aren't at least three days old (change the 3 to -3
+to exclude files that are more than three days old), while
+.nf
+ -skip .*
+.fi
+would exclude any file beginning with a dot (of course, '.' and '..' are
+special and always excluded).
+
+If you'd like to see what files are being excluded, and why, you can get the
+list via the
+.B \-why
+option.
+
+If a file makes it past all the checks, it is then "considered".
+This usually means it is greped for the regular expressions you gave
+on the command line.
+
+If any of the regexes match a line, the line is printed.
+However, if
+.B -list
+is given, just the filename is printed. Or, if
+.B -nice
+is given, a somewhat more (human-)readable output is generated.
+
+If you're searching a huge tree and want to keep informed about how
+the search is progressing,
+.B -v
+will print (to stderr) the current directory being searched.
+Using
+.B -vv
+will also print the current file "every so often", which could be useful
+if a directory is huge. Using
+.B -vvv
+will print the update with every file.
+
+Below is the full listing of options.
+
+.SH "OPTIONS TELLING *WHERE* TO SEARCH"
+.TP
+.BI -dir " DIR"
+Start searching at the named directory instead of the current directory.
+If multiple
+.B -dir
+arguments are given, multiple trees will be searched.
+.TP
+.BI -ddir " DIR"
+Like
+.B -dir
+except it flushes any previous
+.B -dir
+directories (i.e. "-dir A -dir B -dir C" will search A, B, and C, while
+"-dir A -ddir B -dir C" will search only B and C. This might be of use
+in the startup file (see that section below).
+.TP
+.B -xdev
+Stay on the same filesystem as the starting directory/directories.
+.TP
+.B -sort
+Sort the items in a directory before processing them.
+Normally they are processed in whatever order they happen to be read from
+the directory.
+.TP
+.B -nolinks
+Don't follow symbolic links. Normally they're followed.
+
+.SH "OPTIONS CONTROLLING WHICH FILES TO CONSIDER AND EXCLUDE"
+.TP
+.BI -mtime " NUM"
+Only consider files that were last changed more than
+.I NUM
+days ago
+(less than
+.I NUM
+days if
+.I NUM
+has '-' prepended, i.e. "-mtime -2.5" means to consider files that
+have been changed in the last two and a half days).
+.TP
+.B -older FILE
+Only consider files that have not changed since
+.I FILE
+was last changed.
+If there is any upper case in the "-older", "or equal" is added to the sense
+of the test. Therefore, "search -older ./file regex" will never consider
+"./file", while "search -Older ./file regex" will.
+
+If a file is a symbolic link, the time used is that of the file and not the
+link.
+.TP
+.BI -newer " FILE"
+Opposite of
+.BR -older .
+.TP
+.BI -name " GLOB"
+Only consider files that match the shell filename pattern
+.IR GLOB .
+The check is only done on a file's name (use
+.B -path
+to check the whole path, and use
+.B -dname
+to check directory names).
+
+Multiple specifications can be given by separating them with spaces, a'la
+.nf
+ -name '*.c *.h'
+.fi
+to consider C source and header files.
+If
+.I GLOB
+doesn't contain any special pattern characters, a '*' is prepended.
+This last example could have been given as
+.nf
+ -name '.c .h'
+.fi
+It could also be given as
+.nf
+ -name .c -name .h
+.fi
+or
+.nf
+ -name '*.c' -name '*.h'
+.fi
+or
+.nf
+ -name '*.[ch]'
+.fi
+(among others)
+but in this last case, you have to be sure to supply the leading '*'.
+.TP
+.BI -path " GLOB"
+Like
+.B -name
+except the entire path is checked against the pattern.
+.TP
+.B -regex " REGEX"
+Considers files whose names (not paths) match the given perl regex
+exactly.
+.TP
+.BI -iname " GLOB"
+Case-insensitive version of
+.BR -name .
+.TP
+.BI -ipath " GLOB"
+Case-insensitive version of
+.BR -path .
+.TP
+.BI -iregex " REGEX"
+Case-insensitive version of
+.BR -regex .
+
+.TP
+.BI -dpath " GLOB"
+Only search down directories whose path matches the given pattern (this
+doesn't apply to the initial directory given by
+.BI -dir ,
+of course).
+Something like
+.nf
+ -dir /usr/man -dpath /usr/man/man*
+.fi
+would completely skip
+"/usr/man/cat1", "/usr/man/cat2", etc.
+.TP
+.BI -dskip " GLOB"
+Skips directories whose name (not path) matches the given pattern.
+Something like
+.nf
+ -dir /usr/man -dskip cat*
+.fi
+would completely skip any directory in the tree whose name begins with "cat"
+(including "/usr/man/cat1", "/usr/man/cat2", etc.).
+.TP
+.BI -dregex " REGEX"
+Like
+.BI -dpath ,
+but the pattern is a full perl regex. Note that this quite different
+from
+.B -regex
+which considers only file names (not paths). This option considers
+full directory paths (not just names). It's much more useful this way.
+Sorry if it's confusing.
+.TP
+.BI -dpath " GLOB"
+This option exists, but is probably not very useful. It probably wants to
+be like the '-below' or something I mention in the "TODO" section.
+.TP
+.BI -idpath " GLOB"
+Case-insensitive version of
+.BR -dpath .
+.TP
+.BI -idskip " GLOB"
+Case-insensitive version of
+.BR -dskip .
+.TP
+.BI -idregex " REGEX"
+Case-insensitive version of
+.BR -dregex .
+.TP
+.B -all
+Ignore any 'magic' or 'option' lines in the startup file.
+The effect is that all files that would otherwise be automatically
+excluded are considered.
+.TP
+.BI -x SPECIAL
+Arguments starting with
+.B -x
+(except
+.BR -xdev ,
+explained elsewhere) do special interaction with the
+.I ~/.search
+startup file. Something like
+.nf
+ -xflag1 -xflag2
+.fi
+will turn on "flag1" and "flag2" in the startup file (and is
+the same as "-xflag1,flag2"). You can use this to write your own
+rules for what kinds of files are to be considered.
+
+For example, the internal-default startup file contains the line
+.nf
+ <!~> option: -skip '~ #'
+.fi
+This means that if the
+.B -x~
+flag is
+.I not
+seen, the option
+.nf
+ -skip '~ #'
+.fi
+should be done.
+The effect is that emacs temp and backup files are not normally
+considered, but you can included them with the -x~ flag.
+
+You can write your own rules to customize
+.I search
+in powerful ways. See the STARTUP FILE section below.
+.TP
+.B -why
+Print a message (to stderr) when and why a file is not considered.
+
+.SH "OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED"
+.TP
+.B -find
+(you can use
+.B -f
+as well).
+This option changes the basic action of
+.IR search .
+
+Normally, if a file is considered, it is searched
+for the regular expressions as described earlier. However, if this option
+is given, the filename is printed and no searching takes place. This turns
+.I search
+into a 'find' of some sorts.
+
+In this case, no regular expressions are needed on the command line
+(any that are there are silently ignored).
+
+This is not intended to be a replacement for the 'find' program,
+but to aid
+you in understanding just what files are getting past the exclusion checks.
+If you really want to use it as a sort of replacement for the 'find' program,
+you might want to use
+.B -all
+so that it doesn't waste time checking to see if the file is binary, etc
+(unless you really want that, of course).
+
+If you use
+.BR -find ,
+none of the "GREP-LIKE OPTIONS" (below) matter.
+
+As a replacement for 'find',
+.I search
+is probably a bit slower (or in the case of GNU find, a lot slower --
+GNU find is
+.I unbelievably
+fast).
+However, "search -ffind"
+might be more useful than 'find' when options such as
+.B -skip
+are used (at least until 'find' gets such functionality).
+.TP
+.B -ffind
+(or
+.BR -ff )
+A faster more 'find'-like find. Does
+.nf
+ -find -all -dorep
+.fi
+.SH "GREP-LIKE OPTIONS"
+These options control how a searched file is accessed,
+and how things are printed.
+.TP
+.B -i
+Ignore letter case when matching.
+.TP
+.B -w
+Consider only whole-word matches ("whole word" as defined by perl's "\\b"
+regex).
+.TP
+.B -u
+If the regex(es) is/are simple, try to modify them so that they'll work
+in manpage-like underlined text (i.e. like _^Ht_^Hh_^Hi_^Hs).
+This is very rudimentary at the moment.
+.TP
+.B -list
+(you can use
+.B -l
+too).
+Don't print matching lines, but the names of files that contain matching
+lines. This will likely be *much* faster, as special optimizations are
+made -- particularly with large files.
+.TP
+.B -n
+Pepfix each line by its line number.
+.TP
+.B -nice
+Not a grep-like option, but similar to
+.BR -list ,
+so included here.
+.B -nice
+will have the output be a bit more human-readable, with matching lines printed
+slightly indented after the filename, a'la
+.nf
+
+ % search foo
+ somedir/somefile: line with foo in it
+ somedir/somefile: some food for thought
+ anotherdir/x: don't be a buffoon!
+ %
+
+.fi
+will become
+.nf
+
+ % search -nice foo
+ somedir/somefile:
+ line with foo in it
+ some food for thought
+ anotherdir/x:
+ don't be a buffoon!
+ %
+
+.fi
+This option due to Lionel Cons.
+.TP
+.B -nnice
+Be a bit nicer than
+.BR -nice .
+Prefix each file's output by a rule line, and follow with an extra blank line.
+.TP
+.B -h
+Don't prepend each output line with the name of the file
+(meaningless when
+.B -find
+or
+.B -l
+are given).
+
+.SH "OTHER OPTIONS"
+.TP
+.B -help
+Print the usage information.
+.TP
+.B -version
+Print the version information and quit.
+.TP
+.B -v
+Set the level of message verbosity.
+.B -v
+will print a note whenever a new directory is entered.
+.B -vv
+will also print a note "every so often". This can be useful to see
+what's happening when searching huge directories.
+.B -vvv
+will print a new with every file.
+.B -vvvv
+is
+-vvv
+plus
+.BR -why .
+.TP
+.B -e
+This ends the options, and can be useful if the regex begins with '-'.
+.TP
+.B -showrc
+Shows what is being considered in the startup file, then exits.
+.TP
+.B -dorep
+Normally, an identical file won't be checked twice (even with multiple
+hard or symbolic links). If you're just trying to do a fast
+.BR -find ,
+the bookkeeping to remember which files have been seen is not desirable,
+so you can eliminate the bookkeeping with this flag.
+
+.SH "STARTUP FILE"
+When
+.I search
+starts up, it processes the directives in
+.IR ~/.search .
+If no such file exists, a default
+internal version is used.
+
+The internal version looks like:
+.nf
+
+ magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/
+ option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi'
+ option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu'
+ <!~> option: -skip '~ #'
+
+.fi
+If you wish to create your own "~/.search",
+you might consider copying the above, and then working from there.
+
+There are two kinds of directives in a startup file: "magic" and "option".
+.RS 0n
+.TP
+OPTION
+Option lines will automatically do the command-line options given.
+For example, the line
+.nf
+ option: -v
+.fi
+in you startup file will turn on -v every time, without needing to type it
+on the command line.
+
+The text on the line after the "option:" directive is processed
+like the Bourne shell, so make sure to pay attention to quoting.
+.nf
+ option: -skip .exe .com
+.fi
+will give an error (".com" by itself isn't a valid option), while
+.nf
+ option: -skip ".exe .com"
+.fi
+will properly include it as part of -skip's argument.
+
+.TP
+MAGIC
+Magic lines are used to determine if a file should be considered a binary
+or not (the term "magic" refers to checking a file's magic number). These
+are described in more detail below.
+.RE
+
+Blank lines and comments (lines beginning with '#') are allowed.
+
+If a line begins with <...>, then it's a check to see if the
+directive on the line should be done or not. The stuff inside the <...>
+can contain perl's && (and), || (or), ! (not), and parens for grouping,
+along with "flags" that might be indicated by the user with
+.BI -x flag
+options.
+
+For example, using "-xfoo" will cause "foo" to be true inside the <...>
+blocks. Therefore, a line beginning with "<foo>" would be done only when
+"-xfoo" had been specified, while a line beginning with "<!foo>" would be
+done only when "-xfoo" is not specified (of course, a line without any <...>
+is done in either case).
+
+A realistic example might be
+.nf
+ <!v> -vv
+.fi
+This will cause -vv messages to be the default, but allow "-xv" to override.
+
+There are a few flags that are set automatically:
+.RS
+.TP
+.B TTY
+true if the output is to the screen (as opposed to being redirected to a file).
+You can force this (as with all the other automatic flags) with -xTTY.
+.TP
+.B -v
+True if -v was specified. If -vv was specified, both
+.B -v
+and
+.B -vv
+flags are true (and so on).
+.TP
+.B -nice
+True if -nice was specified. Same thing about -nnice as for -vv.
+.PP
+.TP
+.B -list
+true if -list (or -l) was given.
+.TP
+.B -dir
+true if -dir was given.
+.RE
+
+Using this info, you might change the last example to
+.nf
+
+ <!v && !-v> option: -vv
+
+.fi
+The added "&& !-v" means "and if the '-v' option not given".
+This will allow you to use "-v" alone on the command line, and not
+have this directive add the more verbose "-vv" automatically.
+
+.RS 0
+Some other examples:
+.TP
+<!-dir && !here> option: -dir ~/
+Effectively make the default directory your home directory (instead of the
+current directory). Using -dir or -xhere will undo this.
+.TP
+<tex> option: -name .tex -dir ~/pub
+Create '-xtex' to search only "*.tex" files in your ~/pub directory tree.
+Actually, this could be made a bit better. If you combine '-xtex' and '-dir'
+on the command line, this directive will add ~/pub to the list, when you
+probably want to use the -dir directory only. You could do
+.nf
+
+ <tex> option: -name .tex
+ <tex && !-dir> option: -dir ~/pub
+.fi
+
+to will allow '-xtex' to work as before, but allow a command-line "-dir"
+to take precedence with respect to ~/pub.
+.TP
+<fluff> option: -nnice -sort -i -vvv
+Combine a few user-friendly options into one '-xfluff' option.
+.TP
+<man> option: -ddir /usr/man -v -w
+When the '-xman' option is given, search "/usr/man" for whole-words
+(of whatever regex or regexes are given on the command line), with -v.
+.RE
+
+The lines in the startup file are executed from top to bottom, so something
+like
+.nf
+
+ <both> option: -xflag1 -xflag2
+ <flag1> option: ...whatever...
+ <flag2> option: ...whatever...
+
+.fi
+will allow '-xboth' to be the same as '-xflag1 -xflag2' (or '-xflag1,flag2'
+for that matter). However, if you put the "<both>" line below the others,
+they will not be true when encountered, so the result would be different
+(and probably undesired).
+
+The "magic" directives are used to determine if a file looks to be binary
+or not. The form of a magic line is
+.nf
+ magic: \fISIZE\fP : \fIPERLCODE\fP
+.fi
+where
+.I SIZE
+is the number of bytes of the file you need to check, and
+.I PERLCODE
+is the code to do the check. Within
+.IR PERLCODE ,
+the variable $H will hold at least the first
+.I SIZE
+bytes of the file (unless the file is shorter than that, of course).
+It might hold more bytes. The perl should evaluate to true if the file
+should be considered a binary.
+
+An example might be
+.nf
+ magic: 6 : substr($H, 0, 6) eq 'GIF87a'
+.fi
+to test for a GIF ("-iskip .gif" is better, but this might be useful
+if you have images in files without the ".gif" extension).
+
+Since the startup file is checked from top to bottom, you can be a bit
+efficient:
+.nf
+ magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a'
+ magic: 6 : $x6 eq 'GIF89a'
+.fi
+You could also write the same thing as
+.nf
+ magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a') || ## an old gif, or.. \e
+ $x6 eq 'GIF89a' ## .. a new one.
+.fi
+since newlines may be escaped.
+
+The default internal startup file includes
+.nf
+ magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/
+.fi
+which checks for certain non-printable characters, and catches a large
+number of binary files, including most system's executables, linkable
+objects, compressed, tarred, and otherwise folded, spindled, and mutilated
+files.
+
+Another example might be
+.nf
+ ## an archive library
+ magic: 17 : substr($H, 0, 17) eq "!<arch>\en__.SYMDEF"
+.fi
+
+.SH "RETURN VALUE"
+.I Search
+returns zero if lines (or files, if appropriate) were found,
+or if no work was requested (such as with
+.BR -help ).
+Returns 1 if no lines (or files) were found.
+Returns 2 on error.
+
+.SH TODO
+Things I'd like to add some day:
+.nf
+ + show surrounding lines (context).
+ + highlight matched portions of lines.
+ + add '-and', which can go between regexes to override
+ the default logical or of the regexes.
+ + add something like
+ -below GLOB
+ which will examine a tree and only consider files that
+ lie in a directory deeper than one named by the pattern.
+ + add 'warning' and 'error' directives.
+ + add 'help' directive.
+.fi
+.SH BUGS
+If -xdev and multiple -dir arguments are given, any file in any of the
+target filesystems are allowed. It would be better to allow each filesystem
+for each separate tree.
+
+Multiple -dir args might also cause some confusing effects. Doing
+.nf
+ -dir some/dir -dir other
+.fi
+will search "some/dir" completely, then search "other" completely. This
+is good. However, something like
+.nf
+ -dir some/dir -dir some/dir/more/specific
+.fi
+will search "some/dir" completely *except for* "some/dir/more/specific",
+after which it will return and be searched. Not really a bug, but just sort
+of odd.
+
+File times (for -newer, etc.) of symbolic links are for the file, not the
+link. This could cause some misunderstandings.
+
+Probably more. Please let me know.
+.SH AUTHOR
+Jeffrey Friedl, Omron Corp (jfriedl@omron.co.jp)
+.br
+http://www.wg.omron.co.jp/cgi-bin/j-e/jfriedl.html
+
+.SH "LATEST SOURCE"
+See http://www.wg.omron.co.jp/~jfriedl/perl/index.html
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/shasum b/Master/tlpkg/tlperl/bin/shasum new file mode 100755 index 00000000000..3c0185892fa --- /dev/null +++ b/Master/tlpkg/tlperl/bin/shasum @@ -0,0 +1,268 @@ +#!perl -w + + # shasum: filter for computing SHA digests (analogous to sha1sum) + # + # Copyright (C) 2003-2010 Mark Shelor, All Rights Reserved + # + # Version: 5.48 + # Mon Jan 4 16:32:52 MST 2010 + +=head1 NAME + +shasum - Print or Check SHA Checksums + +=head1 SYNOPSIS + + Usage: shasum [OPTION] [FILE]... + or: shasum [OPTION] --check [FILE] + Print or check SHA checksums. + With no FILE, or when FILE is -, read standard input. + + -a, --algorithm 1 (default), 224, 256, 384, 512 + -b, --binary read files in binary mode (default on DOS/Windows) + -c, --check check SHA sums against given list + -p, --portable read files in portable mode + produces same digest on Windows/Unix/Mac + -t, --text read files in text mode (default) + + The following two options are useful only when verifying checksums: + + -s, --status don't output anything, status code shows success + -w, --warn warn about improperly formatted SHA checksum lines + + -h, --help display this help and exit + -v, --version output version information and exit + + The sums are computed as described in FIPS PUB 180-2. When checking, + the input should be a former output of this program. The default mode + is to print a line with checksum, a character indicating type (`*' + for binary, `?' for portable, ` ' for text), and name for each FILE. + +=head1 DESCRIPTION + +The I<shasum> script provides the easiest and most convenient way to +compute SHA message digests. Rather than writing a program, the user +simply feeds data to the script via the command line, and waits for +the results to be printed on standard output. Data can be fed to +I<shasum> through files, standard input, or both. + +The following command shows how easy it is to compute digests for typical +inputs such as the NIST test vector "abc": + + perl -e "print qq(abc)" | shasum + +Or, if you want to use SHA-256 instead of the default SHA-1, simply say: + + perl -e "print qq(abc)" | shasum -a 256 + +Since I<shasum> uses the same interface employed by the familiar +I<sha1sum> program (and its somewhat outmoded anscestor I<md5sum>), +you can install this script as a convenient drop-in replacement. + +=head1 AUTHOR + +Copyright (c) 2003-2010 Mark Shelor <mshelor@cpan.org>. + +=head1 SEE ALSO + +shasum is implemented using the Perl module L<Digest::SHA> or +L<Digest::SHA::PurePerl>. + +=cut + +use strict; +use FileHandle; +use Getopt::Long; + +my $VERSION = "5.48"; + + + # Try to use Digest::SHA, since it's faster. If not installed, + # use Digest::SHA::PurePerl instead. + +my $MOD_PREFER = "Digest::SHA"; +my $MOD_SECOND = "Digest::SHA::PurePerl"; + +my $module = $MOD_PREFER; +eval "require $module"; +if ($@) { + $module = $MOD_SECOND; + eval "require $module"; + die "Unable to find $MOD_PREFER or $MOD_SECOND\n" if $@; +} + + + # Usage statement adapted from Ulrich Drepper's md5sum. + # Include an "-a" option for algorithm selection, + # and a "-p" option for portable digest computation. + +sub usage { + my($err, $msg) = @_; + + $msg = "" unless defined $msg; + if ($err) { + warn($msg . "Type shasum -h for help\n"); + exit($err); + } + print <<'END_OF_USAGE'; +Usage: shasum [OPTION] [FILE]... + or: shasum [OPTION] --check [FILE] +Print or check SHA checksums. +With no FILE, or when FILE is -, read standard input. + + -a, --algorithm 1 (default), 224, 256, 384, 512 + -b, --binary read files in binary mode (default on DOS/Windows) + -c, --check check SHA sums against given list + -p, --portable read files in portable mode + produces same digest on Windows/Unix/Mac + -t, --text read files in text mode (default) + +The following two options are useful only when verifying checksums: + -s, --status don't output anything, status code shows success + -w, --warn warn about improperly formatted SHA checksum lines + + -h, --help display this help and exit + -v, --version output version information and exit + +The sums are computed as described in FIPS PUB 180-2. When checking, the +input should be a former output of this program. The default mode is to +print a line with checksum, a character indicating type (`*' for binary, +`?' for portable, ` ' for text), and name for each FILE. + +Report bugs to <mshelor@cpan.org>. +END_OF_USAGE + exit($err); +} + + + # Collect options from command line + +my ($alg, $binary, $check, $text, $status, $warn, $help, $version); +my ($portable); + +eval { Getopt::Long::Configure ("bundling") }; +GetOptions( + 'b|binary' => \$binary, 'c|check' => \$check, + 't|text' => \$text, 'a|algorithm=i' => \$alg, + 's|status' => \$status, 'w|warn' => \$warn, + 'h|help' => \$help, 'v|version' => \$version, + 'p|portable' => \$portable +) or usage(1, ""); + + + # Deal with help requests and incorrect uses + +usage(0) + if $help; +usage(1, "shasum: Ambiguous file mode\n") + if scalar(grep { defined $_ } ($binary, $portable, $text)) > 1; +usage(1, "shasum: --warn option used only when verifying checksums\n") + if $warn && !$check; +usage(1, "shasum: --status option used only when verifying checksums\n") + if $status && !$check; + + + # Default to SHA-1 unless overriden by command line option + +$alg = 1 unless defined $alg; +grep { $_ == $alg } (1, 224, 256, 384, 512) + or usage(1, "shasum: Unrecognized algorithm\n"); + + + # Display version information if requested + +if ($version) { + print "$VERSION\n"; + exit(0); +} + + + # Try to figure out if the OS is DOS-like. If it is, + # default to binary mode when reading files, unless + # explicitly overriden by command line "--text" or + # "--portable" options. + +my $isDOSish = ($^O =~ /^(MSWin\d\d|os2|dos|mint|cygwin)$/); +if ($isDOSish) { $binary = 1 unless $text || $portable } + +my $modesym = $binary ? '*' : ($portable ? '?' : ' '); + + + # Read from STDIN (-) if no files listed on command line + +@ARGV = ("-") unless @ARGV; + + + # sumfile($file): computes SHA digest of $file + +sub sumfile { + my $file = shift; + + my $mode = $portable ? 'p' : ($binary ? 'b' : ''); + my $digest = eval { $module->new($alg)->addfile($file, $mode) }; + if ($@) { + warn "shasum: $file: $!\n"; + return; + } + + $digest->hexdigest; +} + + + # %len2alg: maps hex digest length to SHA algorithm + +my %len2alg = (40 => 1, 56 => 224, 64 => 256, 96 => 384, 128 => 512); + + + # Verify checksums if requested + +if ($check) { + my $checkfile = shift(@ARGV); + my ($err, $read_errs, $match_errs) = (0, 0, 0); + my ($num_files, $num_checksums) = (0, 0); + my ($fh, $sum, $fname, $rsp, $digest); + + die "shasum: $checkfile: $!\n" + unless $fh = FileHandle->new($checkfile, "r"); + while (<$fh>) { + s/\s+$//; + ($sum, $modesym, $fname) = /^(\S+) (.)(.*)$/; + ($binary, $portable, $text) = + map { $_ eq $modesym } ('*', '?', ' '); + unless ($alg = $len2alg{length($sum)}) { + warn("shasum: $checkfile: $.: improperly " . + "formatted SHA checksum line\n") if $warn; + next; + } + $rsp = "$fname: "; $num_files++; + unless ($digest = sumfile($fname)) { + $rsp .= "FAILED open or read\n"; + $err = 1; $read_errs++; + } + else { + $num_checksums++; + if (lc($sum) eq $digest) { $rsp .= "OK\n" } + else { $rsp .= "FAILED\n"; $err = 1; $match_errs++ } + } + print $rsp unless $status; + } + $fh->close; + unless ($status) { + warn("shasum: WARNING: $read_errs of $num_files listed " . + "files could not be read\n") if $read_errs; + warn("shasum: WARNING: $match_errs of $num_checksums " . + "computed checksums did NOT match\n") if $match_errs; + } + exit($err); +} + + + # Compute and display SHA checksums of requested files + +my($file, $digest); + +for $file (@ARGV) { + if ($digest = sumfile($file)) { + print "$digest $modesym", "$file\n"; + } +} diff --git a/Master/tlpkg/tlperl/bin/shasum.bat b/Master/tlpkg/tlperl/bin/shasum.bat new file mode 100755 index 00000000000..79baeebc5b9 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/shasum.bat @@ -0,0 +1,284 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl -w
+#line 15
+
+ # shasum: filter for computing SHA digests (analogous to sha1sum)
+ #
+ # Copyright (C) 2003-2010 Mark Shelor, All Rights Reserved
+ #
+ # Version: 5.48
+ # Mon Jan 4 16:32:52 MST 2010
+
+=head1 NAME
+
+shasum - Print or Check SHA Checksums
+
+=head1 SYNOPSIS
+
+ Usage: shasum [OPTION] [FILE]...
+ or: shasum [OPTION] --check [FILE]
+ Print or check SHA checksums.
+ With no FILE, or when FILE is -, read standard input.
+
+ -a, --algorithm 1 (default), 224, 256, 384, 512
+ -b, --binary read files in binary mode (default on DOS/Windows)
+ -c, --check check SHA sums against given list
+ -p, --portable read files in portable mode
+ produces same digest on Windows/Unix/Mac
+ -t, --text read files in text mode (default)
+
+ The following two options are useful only when verifying checksums:
+
+ -s, --status don't output anything, status code shows success
+ -w, --warn warn about improperly formatted SHA checksum lines
+
+ -h, --help display this help and exit
+ -v, --version output version information and exit
+
+ The sums are computed as described in FIPS PUB 180-2. When checking,
+ the input should be a former output of this program. The default mode
+ is to print a line with checksum, a character indicating type (`*'
+ for binary, `?' for portable, ` ' for text), and name for each FILE.
+
+=head1 DESCRIPTION
+
+The I<shasum> script provides the easiest and most convenient way to
+compute SHA message digests. Rather than writing a program, the user
+simply feeds data to the script via the command line, and waits for
+the results to be printed on standard output. Data can be fed to
+I<shasum> through files, standard input, or both.
+
+The following command shows how easy it is to compute digests for typical
+inputs such as the NIST test vector "abc":
+
+ perl -e "print qq(abc)" | shasum
+
+Or, if you want to use SHA-256 instead of the default SHA-1, simply say:
+
+ perl -e "print qq(abc)" | shasum -a 256
+
+Since I<shasum> uses the same interface employed by the familiar
+I<sha1sum> program (and its somewhat outmoded anscestor I<md5sum>),
+you can install this script as a convenient drop-in replacement.
+
+=head1 AUTHOR
+
+Copyright (c) 2003-2010 Mark Shelor <mshelor@cpan.org>.
+
+=head1 SEE ALSO
+
+shasum is implemented using the Perl module L<Digest::SHA> or
+L<Digest::SHA::PurePerl>.
+
+=cut
+
+use strict;
+use FileHandle;
+use Getopt::Long;
+
+my $VERSION = "5.48";
+
+
+ # Try to use Digest::SHA, since it's faster. If not installed,
+ # use Digest::SHA::PurePerl instead.
+
+my $MOD_PREFER = "Digest::SHA";
+my $MOD_SECOND = "Digest::SHA::PurePerl";
+
+my $module = $MOD_PREFER;
+eval "require $module";
+if ($@) {
+ $module = $MOD_SECOND;
+ eval "require $module";
+ die "Unable to find $MOD_PREFER or $MOD_SECOND\n" if $@;
+}
+
+
+ # Usage statement adapted from Ulrich Drepper's md5sum.
+ # Include an "-a" option for algorithm selection,
+ # and a "-p" option for portable digest computation.
+
+sub usage {
+ my($err, $msg) = @_;
+
+ $msg = "" unless defined $msg;
+ if ($err) {
+ warn($msg . "Type shasum -h for help\n");
+ exit($err);
+ }
+ print <<'END_OF_USAGE';
+Usage: shasum [OPTION] [FILE]...
+ or: shasum [OPTION] --check [FILE]
+Print or check SHA checksums.
+With no FILE, or when FILE is -, read standard input.
+
+ -a, --algorithm 1 (default), 224, 256, 384, 512
+ -b, --binary read files in binary mode (default on DOS/Windows)
+ -c, --check check SHA sums against given list
+ -p, --portable read files in portable mode
+ produces same digest on Windows/Unix/Mac
+ -t, --text read files in text mode (default)
+
+The following two options are useful only when verifying checksums:
+ -s, --status don't output anything, status code shows success
+ -w, --warn warn about improperly formatted SHA checksum lines
+
+ -h, --help display this help and exit
+ -v, --version output version information and exit
+
+The sums are computed as described in FIPS PUB 180-2. When checking, the
+input should be a former output of this program. The default mode is to
+print a line with checksum, a character indicating type (`*' for binary,
+`?' for portable, ` ' for text), and name for each FILE.
+
+Report bugs to <mshelor@cpan.org>.
+END_OF_USAGE
+ exit($err);
+}
+
+
+ # Collect options from command line
+
+my ($alg, $binary, $check, $text, $status, $warn, $help, $version);
+my ($portable);
+
+eval { Getopt::Long::Configure ("bundling") };
+GetOptions(
+ 'b|binary' => \$binary, 'c|check' => \$check,
+ 't|text' => \$text, 'a|algorithm=i' => \$alg,
+ 's|status' => \$status, 'w|warn' => \$warn,
+ 'h|help' => \$help, 'v|version' => \$version,
+ 'p|portable' => \$portable
+) or usage(1, "");
+
+
+ # Deal with help requests and incorrect uses
+
+usage(0)
+ if $help;
+usage(1, "shasum: Ambiguous file mode\n")
+ if scalar(grep { defined $_ } ($binary, $portable, $text)) > 1;
+usage(1, "shasum: --warn option used only when verifying checksums\n")
+ if $warn && !$check;
+usage(1, "shasum: --status option used only when verifying checksums\n")
+ if $status && !$check;
+
+
+ # Default to SHA-1 unless overriden by command line option
+
+$alg = 1 unless defined $alg;
+grep { $_ == $alg } (1, 224, 256, 384, 512)
+ or usage(1, "shasum: Unrecognized algorithm\n");
+
+
+ # Display version information if requested
+
+if ($version) {
+ print "$VERSION\n";
+ exit(0);
+}
+
+
+ # Try to figure out if the OS is DOS-like. If it is,
+ # default to binary mode when reading files, unless
+ # explicitly overriden by command line "--text" or
+ # "--portable" options.
+
+my $isDOSish = ($^O =~ /^(MSWin\d\d|os2|dos|mint|cygwin)$/);
+if ($isDOSish) { $binary = 1 unless $text || $portable }
+
+my $modesym = $binary ? '*' : ($portable ? '?' : ' ');
+
+
+ # Read from STDIN (-) if no files listed on command line
+
+@ARGV = ("-") unless @ARGV;
+
+
+ # sumfile($file): computes SHA digest of $file
+
+sub sumfile {
+ my $file = shift;
+
+ my $mode = $portable ? 'p' : ($binary ? 'b' : '');
+ my $digest = eval { $module->new($alg)->addfile($file, $mode) };
+ if ($@) {
+ warn "shasum: $file: $!\n";
+ return;
+ }
+
+ $digest->hexdigest;
+}
+
+
+ # %len2alg: maps hex digest length to SHA algorithm
+
+my %len2alg = (40 => 1, 56 => 224, 64 => 256, 96 => 384, 128 => 512);
+
+
+ # Verify checksums if requested
+
+if ($check) {
+ my $checkfile = shift(@ARGV);
+ my ($err, $read_errs, $match_errs) = (0, 0, 0);
+ my ($num_files, $num_checksums) = (0, 0);
+ my ($fh, $sum, $fname, $rsp, $digest);
+
+ die "shasum: $checkfile: $!\n"
+ unless $fh = FileHandle->new($checkfile, "r");
+ while (<$fh>) {
+ s/\s+$//;
+ ($sum, $modesym, $fname) = /^(\S+) (.)(.*)$/;
+ ($binary, $portable, $text) =
+ map { $_ eq $modesym } ('*', '?', ' ');
+ unless ($alg = $len2alg{length($sum)}) {
+ warn("shasum: $checkfile: $.: improperly " .
+ "formatted SHA checksum line\n") if $warn;
+ next;
+ }
+ $rsp = "$fname: "; $num_files++;
+ unless ($digest = sumfile($fname)) {
+ $rsp .= "FAILED open or read\n";
+ $err = 1; $read_errs++;
+ }
+ else {
+ $num_checksums++;
+ if (lc($sum) eq $digest) { $rsp .= "OK\n" }
+ else { $rsp .= "FAILED\n"; $err = 1; $match_errs++ }
+ }
+ print $rsp unless $status;
+ }
+ $fh->close;
+ unless ($status) {
+ warn("shasum: WARNING: $read_errs of $num_files listed " .
+ "files could not be read\n") if $read_errs;
+ warn("shasum: WARNING: $match_errs of $num_checksums " .
+ "computed checksums did NOT match\n") if $match_errs;
+ }
+ exit($err);
+}
+
+
+ # Compute and display SHA checksums of requested files
+
+my($file, $digest);
+
+for $file (@ARGV) {
+ if ($digest = sumfile($file)) {
+ print "$digest $modesym", "$file\n";
+ }
+}
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/splain.bat b/Master/tlpkg/tlperl/bin/splain.bat new file mode 100755 index 00000000000..389ef1879a8 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/splain.bat @@ -0,0 +1,665 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+
+=head1 NAME
+
+diagnostics, splain - produce verbose warning diagnostics
+
+=head1 SYNOPSIS
+
+Using the C<diagnostics> pragma:
+
+ use diagnostics;
+ use diagnostics -verbose;
+
+ enable diagnostics;
+ disable diagnostics;
+
+Using the C<splain> standalone filter program:
+
+ perl program 2>diag.out
+ splain [-v] [-p] diag.out
+
+Using diagnostics to get stack traces from a misbehaving script:
+
+ perl -Mdiagnostics=-traceonly my_script.pl
+
+=head1 DESCRIPTION
+
+=head2 The C<diagnostics> Pragma
+
+This module extends the terse diagnostics normally emitted by both the
+perl compiler and the perl interpreter (from running perl with a -w
+switch or C<use warnings>), augmenting them with the more
+explicative and endearing descriptions found in L<perldiag>. Like the
+other pragmata, it affects the compilation phase of your program rather
+than merely the execution phase.
+
+To use in your program as a pragma, merely invoke
+
+ use diagnostics;
+
+at the start (or near the start) of your program. (Note
+that this I<does> enable perl's B<-w> flag.) Your whole
+compilation will then be subject(ed :-) to the enhanced diagnostics.
+These still go out B<STDERR>.
+
+Due to the interaction between runtime and compiletime issues,
+and because it's probably not a very good idea anyway,
+you may not use C<no diagnostics> to turn them off at compiletime.
+However, you may control their behaviour at runtime using the
+disable() and enable() methods to turn them off and on respectively.
+
+The B<-verbose> flag first prints out the L<perldiag> introduction before
+any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
+escape sequences for pagers.
+
+Warnings dispatched from perl itself (or more accurately, those that match
+descriptions found in L<perldiag>) are only displayed once (no duplicate
+descriptions). User code generated warnings a la warn() are unaffected,
+allowing duplicate user messages to be displayed.
+
+This module also adds a stack trace to the error message when perl dies.
+This is useful for pinpointing what caused the death. The B<-traceonly> (or
+just B<-t>) flag turns off the explanations of warning messages leaving just
+the stack traces. So if your script is dieing, run it again with
+
+ perl -Mdiagnostics=-traceonly my_bad_script
+
+to see the call stack at the time of death. By supplying the B<-warntrace>
+(or just B<-w>) flag, any warnings emitted will also come with a stack
+trace.
+
+=head2 The I<splain> Program
+
+While apparently a whole nuther program, I<splain> is actually nothing
+more than a link to the (executable) F<diagnostics.pm> module, as well as
+a link to the F<diagnostics.pod> documentation. The B<-v> flag is like
+the C<use diagnostics -verbose> directive.
+The B<-p> flag is like the
+$diagnostics::PRETTY variable. Since you're post-processing with
+I<splain>, there's no sense in being able to enable() or disable() processing.
+
+Output from I<splain> is directed to B<STDOUT>, unlike the pragma.
+
+=head1 EXAMPLES
+
+The following file is certain to trigger a few errors at both
+runtime and compiletime:
+
+ use diagnostics;
+ print NOWHERE "nothing\n";
+ print STDERR "\n\tThis message should be unadorned.\n";
+ warn "\tThis is a user warning";
+ print "\nDIAGNOSTIC TESTER: Please enter a <CR> here: ";
+ my $a, $b = scalar <STDIN>;
+ print "\n";
+ print $x/$y;
+
+If you prefer to run your program first and look at its problem
+afterwards, do this:
+
+ perl -w test.pl 2>test.out
+ ./splain < test.out
+
+Note that this is not in general possible in shells of more dubious heritage,
+as the theoretical
+
+ (perl -w test.pl >/dev/tty) >& test.out
+ ./splain < test.out
+
+Because you just moved the existing B<stdout> to somewhere else.
+
+If you don't want to modify your source code, but still have on-the-fly
+warnings, do this:
+
+ exec 3>&1; perl -w test.pl 2>&1 1>&3 3>&- | splain 1>&2 3>&-
+
+Nifty, eh?
+
+If you want to control warnings on the fly, do something like this.
+Make sure you do the C<use> first, or you won't be able to get
+at the enable() or disable() methods.
+
+ use diagnostics; # checks entire compilation phase
+ print "\ntime for 1st bogus diags: SQUAWKINGS\n";
+ print BOGUS1 'nada';
+ print "done with 1st bogus\n";
+
+ disable diagnostics; # only turns off runtime warnings
+ print "\ntime for 2nd bogus: (squelched)\n";
+ print BOGUS2 'nada';
+ print "done with 2nd bogus\n";
+
+ enable diagnostics; # turns back on runtime warnings
+ print "\ntime for 3rd bogus: SQUAWKINGS\n";
+ print BOGUS3 'nada';
+ print "done with 3rd bogus\n";
+
+ disable diagnostics;
+ print "\ntime for 4th bogus: (squelched)\n";
+ print BOGUS4 'nada';
+ print "done with 4th bogus\n";
+
+=head1 INTERNALS
+
+Diagnostic messages derive from the F<perldiag.pod> file when available at
+runtime. Otherwise, they may be embedded in the file itself when the
+splain package is built. See the F<Makefile> for details.
+
+If an extant $SIG{__WARN__} handler is discovered, it will continue
+to be honored, but only after the diagnostics::splainthis() function
+(the module's $SIG{__WARN__} interceptor) has had its way with your
+warnings.
+
+There is a $diagnostics::DEBUG variable you may set if you're desperately
+curious what sorts of things are being intercepted.
+
+ BEGIN { $diagnostics::DEBUG = 1 }
+
+
+=head1 BUGS
+
+Not being able to say "no diagnostics" is annoying, but may not be
+insurmountable.
+
+The C<-pretty> directive is called too late to affect matters.
+You have to do this instead, and I<before> you load the module.
+
+ BEGIN { $diagnostics::PRETTY = 1 }
+
+I could start up faster by delaying compilation until it should be
+needed, but this gets a "panic: top_level" when using the pragma form
+in Perl 5.001e.
+
+While it's true that this documentation is somewhat subserious, if you use
+a program named I<splain>, you should expect a bit of whimsy.
+
+=head1 AUTHOR
+
+Tom Christiansen <F<tchrist@mox.perl.com>>, 25 June 1995.
+
+=cut
+
+use strict;
+use 5.009001;
+use Carp;
+$Carp::Internal{__PACKAGE__.""}++;
+
+our $VERSION = 1.17;
+our $DEBUG;
+our $VERBOSE;
+our $PRETTY;
+our $TRACEONLY = 0;
+our $WARNTRACE = 0;
+
+use Config;
+my($privlib, $archlib) = @Config{qw(privlibexp archlibexp)};
+if ($^O eq 'VMS') {
+ require VMS::Filespec;
+ $privlib = VMS::Filespec::unixify($privlib);
+ $archlib = VMS::Filespec::unixify($archlib);
+}
+my @trypod = (
+ "$archlib/pod/perldiag.pod",
+ "$privlib/pod/perldiag-$Config{version}.pod",
+ "$privlib/pod/perldiag.pod",
+ "$archlib/pods/perldiag.pod",
+ "$privlib/pods/perldiag-$Config{version}.pod",
+ "$privlib/pods/perldiag.pod",
+ );
+# handy for development testing of new warnings etc
+unshift @trypod, "./pod/perldiag.pod" if -e "pod/perldiag.pod";
+(my $PODFILE) = ((grep { -e } @trypod), $trypod[$#trypod])[0];
+
+if ($^O eq 'MacOS') {
+ # just updir one from each lib dir, we'll find it ...
+ ($PODFILE) = grep { -e } map { "$_:pod:perldiag.pod" } @INC;
+}
+
+
+$DEBUG ||= 0;
+my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
+
+local $| = 1;
+my $_;
+
+my $standalone;
+my(%HTML_2_Troff, %HTML_2_Latin_1, %HTML_2_ASCII_7);
+
+CONFIG: {
+ our $opt_p = our $opt_d = our $opt_v = our $opt_f = '';
+
+ unless (caller) {
+ $standalone++;
+ require Getopt::Std;
+ Getopt::Std::getopts('pdvf:')
+ or die "Usage: $0 [-v] [-p] [-f splainpod]";
+ $PODFILE = $opt_f if $opt_f;
+ $DEBUG = 2 if $opt_d;
+ $VERBOSE = $opt_v;
+ $PRETTY = $opt_p;
+ }
+
+ if (open(POD_DIAG, $PODFILE)) {
+ warn "Happy happy podfile from real $PODFILE\n" if $DEBUG;
+ last CONFIG;
+ }
+
+ if (caller) {
+ INCPATH: {
+ for my $file ( (map { "$_/$WHOAMI.pm" } @INC), $0) {
+ warn "Checking $file\n" if $DEBUG;
+ if (open(POD_DIAG, $file)) {
+ while (<POD_DIAG>) {
+ next unless
+ /^__END__\s*# wish diag dbase were more accessible/;
+ print STDERR "podfile is $file\n" if $DEBUG;
+ last INCPATH;
+ }
+ }
+ }
+ }
+ } else {
+ print STDERR "podfile is <DATA>\n" if $DEBUG;
+ *POD_DIAG = *main::DATA;
+ }
+}
+if (eof(POD_DIAG)) {
+ die "couldn't find diagnostic data in $PODFILE @INC $0";
+}
+
+
+%HTML_2_Troff = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "A\\*'", # capital A, acute accent
+ # etc
+
+);
+
+%HTML_2_Latin_1 = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "\xC1" # capital A, acute accent
+
+ # etc
+);
+
+%HTML_2_ASCII_7 = (
+ 'amp' => '&', # ampersand
+ 'lt' => '<', # left chevron, less-than
+ 'gt' => '>', # right chevron, greater-than
+ 'quot' => '"', # double quote
+
+ "Aacute" => "A" # capital A, acute accent
+ # etc
+);
+
+our %HTML_Escapes;
+*HTML_Escapes = do {
+ if ($standalone) {
+ $PRETTY ? \%HTML_2_Latin_1 : \%HTML_2_ASCII_7;
+ } else {
+ \%HTML_2_Latin_1;
+ }
+};
+
+*THITHER = $standalone ? *STDOUT : *STDERR;
+
+my %transfmt = ();
+my $transmo = <<EOFUNC;
+sub transmo {
+ #local \$^W = 0; # recursive warnings we do NOT need!
+ study;
+EOFUNC
+
+my %msg;
+{
+ print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
+ local $/ = '';
+ my $header;
+ my $for_item;
+ while (<POD_DIAG>) {
+
+ unescape();
+ if ($PRETTY) {
+ sub noop { return $_[0] } # spensive for a noop
+ sub bold { my $str =$_[0]; $str =~ s/(.)/$1\b$1/g; return $str; }
+ sub italic { my $str = $_[0]; $str =~ s/(.)/_\b$1/g; return $str; }
+ s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/bold($+)/ges;
+ s/[LIF]<(.*?)>/italic($1)/ges;
+ } else {
+ s/C<<< (.*?) >>>|C<< (.*?) >>|[BC]<(.*?)>/$+/gs;
+ s/[LIF]<(.*?)>/$1/gs;
+ }
+ unless (/^=/) {
+ if (defined $header) {
+ if ( $header eq 'DESCRIPTION' &&
+ ( /Optional warnings are enabled/
+ || /Some of these messages are generic./
+ ) )
+ {
+ next;
+ }
+ s/^/ /gm;
+ $msg{$header} .= $_;
+ undef $for_item;
+ }
+ next;
+ }
+ unless ( s/=item (.*?)\s*\z//) {
+
+ if ( s/=head1\sDESCRIPTION//) {
+ $msg{$header = 'DESCRIPTION'} = '';
+ undef $for_item;
+ }
+ elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
+ $for_item = $1;
+ }
+ next;
+ }
+
+ if( $for_item ) { $header = $for_item; undef $for_item }
+ else {
+ $header = $1;
+ while( $header =~ /[;,]\z/ ) {
+ <POD_DIAG> =~ /^\s*(.*?)\s*\z/;
+ $header .= ' '.$1;
+ }
+ }
+
+ # strip formatting directives from =item line
+ $header =~ s/[A-Z]<(.*?)>/$1/g;
+
+ my @toks = split( /(%l?[dx]|%c|%(?:\.\d+)?s)/, $header );
+ if (@toks > 1) {
+ my $conlen = 0;
+ for my $i (0..$#toks){
+ if( $i % 2 ){
+ if( $toks[$i] eq '%c' ){
+ $toks[$i] = '.';
+ } elsif( $toks[$i] eq '%d' ){
+ $toks[$i] = '\d+';
+ } elsif( $toks[$i] eq '%s' ){
+ $toks[$i] = $i == $#toks ? '.*' : '.*?';
+ } elsif( $toks[$i] =~ '%.(\d+)s' ){
+ $toks[$i] = ".{$1}";
+ } elsif( $toks[$i] =~ '^%l*x$' ){
+ $toks[$i] = '[\da-f]+';
+ }
+ } elsif( length( $toks[$i] ) ){
+ $toks[$i] = quotemeta $toks[$i];
+ $conlen += length( $toks[$i] );
+ }
+ }
+ my $lhs = join( '', @toks );
+ $transfmt{$header}{pat} =
+ " s{^$lhs}\n {\Q$header\E}s\n\t&& return 1;\n";
+ $transfmt{$header}{len} = $conlen;
+ } else {
+ $transfmt{$header}{pat} =
+ " m{^\Q$header\E} && return 1;\n";
+ $transfmt{$header}{len} = length( $header );
+ }
+
+ print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
+ if $msg{$header};
+
+ $msg{$header} = '';
+ }
+
+
+ close POD_DIAG unless *main::DATA eq *POD_DIAG;
+
+ die "No diagnostics?" unless %msg;
+
+ # Apply patterns in order of decreasing sum of lengths of fixed parts
+ # Seems the best way of hitting the right one.
+ for my $hdr ( sort { $transfmt{$b}{len} <=> $transfmt{$a}{len} }
+ keys %transfmt ){
+ $transmo .= $transfmt{$hdr}{pat};
+ }
+ $transmo .= " return 0;\n}\n";
+ print STDERR $transmo if $DEBUG;
+ eval $transmo;
+ die $@ if $@;
+}
+
+if ($standalone) {
+ if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
+ while (defined (my $error = <>)) {
+ splainthis($error) || print THITHER $error;
+ }
+ exit;
+}
+
+my $olddie;
+my $oldwarn;
+
+sub import {
+ shift;
+ $^W = 1; # yup, clobbered the global variable;
+ # tough, if you want diags, you want diags.
+ return if defined $SIG{__WARN__} && ($SIG{__WARN__} eq \&warn_trap);
+
+ for (@_) {
+
+ /^-d(ebug)?$/ && do {
+ $DEBUG++;
+ next;
+ };
+
+ /^-v(erbose)?$/ && do {
+ $VERBOSE++;
+ next;
+ };
+
+ /^-p(retty)?$/ && do {
+ print STDERR "$0: I'm afraid it's too late for prettiness.\n";
+ $PRETTY++;
+ next;
+ };
+ # matches trace and traceonly for legacy doc mixup reasons
+ /^-t(race(only)?)?$/ && do {
+ $TRACEONLY++;
+ next;
+ };
+ /^-w(arntrace)?$/ && do {
+ $WARNTRACE++;
+ next;
+ };
+
+ warn "Unknown flag: $_";
+ }
+
+ $oldwarn = $SIG{__WARN__};
+ $olddie = $SIG{__DIE__};
+ $SIG{__WARN__} = \&warn_trap;
+ $SIG{__DIE__} = \&death_trap;
+}
+
+sub enable { &import }
+
+sub disable {
+ shift;
+ return unless $SIG{__WARN__} eq \&warn_trap;
+ $SIG{__WARN__} = $oldwarn || '';
+ $SIG{__DIE__} = $olddie || '';
+}
+
+sub warn_trap {
+ my $warning = $_[0];
+ if (caller eq $WHOAMI or !splainthis($warning)) {
+ if ($WARNTRACE) {
+ print STDERR Carp::longmess($warning);
+ } else {
+ print STDERR $warning;
+ }
+ }
+ goto &$oldwarn if defined $oldwarn and $oldwarn and $oldwarn ne \&warn_trap;
+};
+
+sub death_trap {
+ my $exception = $_[0];
+
+ # See if we are coming from anywhere within an eval. If so we don't
+ # want to explain the exception because it's going to get caught.
+ my $in_eval = 0;
+ my $i = 0;
+ while (my $caller = (caller($i++))[3]) {
+ if ($caller eq '(eval)') {
+ $in_eval = 1;
+ last;
+ }
+ }
+
+ splainthis($exception) unless $in_eval;
+ if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
+ &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
+
+ return if $in_eval;
+
+ # We don't want to unset these if we're coming from an eval because
+ # then we've turned off diagnostics.
+
+ # Switch off our die/warn handlers so we don't wind up in our own
+ # traps.
+ $SIG{__DIE__} = $SIG{__WARN__} = '';
+
+ # Have carp skip over death_trap() when showing the stack trace.
+ local($Carp::CarpLevel) = 1;
+
+ confess "Uncaught exception from user code:\n\t$exception";
+ # up we go; where we stop, nobody knows, but i think we die now
+ # but i'm deeply afraid of the &$olddie guy reraising and us getting
+ # into an indirect recursion loop
+};
+
+my %exact_duplicate;
+my %old_diag;
+my $count;
+my $wantspace;
+sub splainthis {
+ return 0 if $TRACEONLY;
+ $_ = shift;
+ local $\;
+ local $!;
+ ### &finish_compilation unless %msg;
+ s/\.?\n+$//;
+ my $orig = $_;
+ # return unless defined;
+
+ # get rid of the where-are-we-in-input part
+ s/, <.*?> (?:line|chunk).*$//;
+
+ # Discard 1st " at <file> line <no>" and all text beyond
+ # but be aware of messsages containing " at this-or-that"
+ my $real = 0;
+ my @secs = split( / at / );
+ return unless @secs;
+ $_ = $secs[0];
+ for my $i ( 1..$#secs ){
+ if( $secs[$i] =~ /.+? (?:line|chunk) \d+/ ){
+ $real = 1;
+ last;
+ } else {
+ $_ .= ' at ' . $secs[$i];
+ }
+ }
+
+ # remove parenthesis occurring at the end of some messages
+ s/^\((.*)\)$/$1/;
+
+ if ($exact_duplicate{$orig}++) {
+ return &transmo;
+ } else {
+ return 0 unless &transmo;
+ }
+
+ $orig = shorten($orig);
+ if ($old_diag{$_}) {
+ autodescribe();
+ print THITHER "$orig (#$old_diag{$_})\n";
+ $wantspace = 1;
+ } else {
+ autodescribe();
+ $old_diag{$_} = ++$count;
+ print THITHER "\n" if $wantspace;
+ $wantspace = 0;
+ print THITHER "$orig (#$old_diag{$_})\n";
+ if ($msg{$_}) {
+ print THITHER $msg{$_};
+ } else {
+ if (0 and $standalone) {
+ print THITHER " **** Error #$old_diag{$_} ",
+ ($real ? "is" : "appears to be"),
+ " an unknown diagnostic message.\n\n";
+ }
+ return 0;
+ }
+ }
+ return 1;
+}
+
+sub autodescribe {
+ if ($VERBOSE and not $count) {
+ print THITHER &{$PRETTY ? \&bold : \&noop}("DESCRIPTION OF DIAGNOSTICS"),
+ "\n$msg{DESCRIPTION}\n";
+ }
+}
+
+sub unescape {
+ s {
+ E<
+ ( [A-Za-z]+ )
+ >
+ } {
+ do {
+ exists $HTML_Escapes{$1}
+ ? do { $HTML_Escapes{$1} }
+ : do {
+ warn "Unknown escape: E<$1> in $_";
+ "E<$1>";
+ }
+ }
+ }egx;
+}
+
+sub shorten {
+ my $line = $_[0];
+ if (length($line) > 79 and index($line, "\n") == -1) {
+ my $space_place = rindex($line, ' ', 79);
+ if ($space_place != -1) {
+ substr($line, $space_place, 1) = "\n\t";
+ }
+ }
+ return $line;
+}
+
+
+1 unless $standalone; # or it'll complain about itself
+__END__ # wish diag dbase were more accessible
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/tkjpeg b/Master/tlpkg/tlperl/bin/tkjpeg new file mode 100755 index 00000000000..b2b5619726c --- /dev/null +++ b/Master/tlpkg/tlperl/bin/tkjpeg @@ -0,0 +1,67 @@ +#!/usr/local/bin/perl -w +use strict; +use Tk; +use Tk::JPEG; +use Getopt::Std; +eval { require Tk::PNG; }; + +my $mw = MainWindow->new(); +print "vis=",$mw->visual," d=",$mw->depth,"\n"; +my ($vis) = grep(!/\b8\b/,grep(/truecolor/,$mw->visualsavailable)); +my @args = (); +if ($vis) + { + # print $vis,"\n"; + $mw->destroy; + $mw = MainWindow->new(-visual => $vis); + } +else + { + @args = (-palette => '4/4/4'); + } +# print "vis=",$mw->visual," d=",$mw->depth,' "',join('" "',$mw->visualsavailable),"\"\n"; +my %opt; +getopts('f:',\%opt); +if ($opt{'f'}) + { + push(@args,'-format' => $opt{'f'}); + } +unless (@ARGV) + { + warn "usage $0 [-f format] <imagefile>\n"; + exit 1; + } +my $file = shift; +my $image = $mw->Photo(-file => $file, @args); +#print join(' ',$image->formats),"\n"; +print "w=",$image->width," h=",$image->height,"\n"; +$mw->Label(-image => $image)->pack(-expand => 1, -fill => 'both'); +$mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; +MainLoop; + +__END__ + +=head1 NAME + +tkjpeg - simple JPEG viewer using perl/Tk + +=head1 SYNOPSIS + + tkjpeg imagefile.jpg + +=head1 DESCRIPTION + +Very simplistic image viewer that loads JPEG image, (well actually +anything for which Photo has a handler) and puts it into a +Label for display. + +It tries to find a fullcolour visual to use if display is deeper than +8-bit. (On 8-bit it uses a 4/4/4 palette.) + +=head1 AUTHOR + +Nick Ing-Simmons <nick@ing-simmons.net> + +=cut + + diff --git a/Master/tlpkg/tlperl/bin/tkjpeg.bat b/Master/tlpkg/tlperl/bin/tkjpeg.bat new file mode 100755 index 00000000000..a09abd6075a --- /dev/null +++ b/Master/tlpkg/tlperl/bin/tkjpeg.bat @@ -0,0 +1,83 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+use strict;
+use Tk;
+use Tk::JPEG;
+use Getopt::Std;
+eval { require Tk::PNG; };
+
+my $mw = MainWindow->new();
+print "vis=",$mw->visual," d=",$mw->depth,"\n";
+my ($vis) = grep(!/\b8\b/,grep(/truecolor/,$mw->visualsavailable));
+my @args = ();
+if ($vis)
+ {
+ # print $vis,"\n";
+ $mw->destroy;
+ $mw = MainWindow->new(-visual => $vis);
+ }
+else
+ {
+ @args = (-palette => '4/4/4');
+ }
+# print "vis=",$mw->visual," d=",$mw->depth,' "',join('" "',$mw->visualsavailable),"\"\n";
+my %opt;
+getopts('f:',\%opt);
+if ($opt{'f'})
+ {
+ push(@args,'-format' => $opt{'f'});
+ }
+unless (@ARGV)
+ {
+ warn "usage $0 [-f format] <imagefile>\n";
+ exit 1;
+ }
+my $file = shift;
+my $image = $mw->Photo(-file => $file, @args);
+#print join(' ',$image->formats),"\n";
+print "w=",$image->width," h=",$image->height,"\n";
+$mw->Label(-image => $image)->pack(-expand => 1, -fill => 'both');
+$mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack;
+MainLoop;
+
+__END__
+
+=head1 NAME
+
+tkjpeg - simple JPEG viewer using perl/Tk
+
+=head1 SYNOPSIS
+
+ tkjpeg imagefile.jpg
+
+=head1 DESCRIPTION
+
+Very simplistic image viewer that loads JPEG image, (well actually
+anything for which Photo has a handler) and puts it into a
+Label for display.
+
+It tries to find a fullcolour visual to use if display is deeper than
+8-bit. (On 8-bit it uses a 4/4/4 palette.)
+
+=head1 AUTHOR
+
+Nick Ing-Simmons <nick@ing-simmons.net>
+
+=cut
+
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/widget b/Master/tlpkg/tlperl/bin/widget new file mode 100755 index 00000000000..05af2dcd320 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/widget @@ -0,0 +1,608 @@ +#!/usr/local/bin/perl -w + +use 5.008; +use Config; +use Tk 804.000; +use lib Tk->findINC( 'demos/widget_lib' ); +use Tk::widgets qw/ DialogBox ErrorDialog LabEntry ROText /; +use Tk::Config (); +use WidgetDemo; +use subs qw/ + build_about_dialog demos invoke lsearch + see_code see_vars show_stat view_widget +/; +use vars qw/ $MW $FONT $BOLD_FONT $LARGE_FONT $MONOSPACE_FONT $WIDTRIB /; +use vars qw/ $CODE $CODE_RERUN $CODE_TEXT $VARS $VIEW $VIEW_TEXT /; +use vars qw/ $ALIGN $BRAKES $LIGHTS $OIL $SOBER $TRANS $WIPERS /; +use vars qw/ $COLOR $FONT_STYLE $POINT_SIZE $DEMO_FILE %DEMO_DESCRIPTION $XFT /; +use strict; + +$XFT = $Tk::Config::xlib =~ /-lXft\b/; + +$MW = Tk::MainWindow->new; +$MW->configure(-menu => my $menubar = $MW->Menu); + +{ + package WidgetWrap; + @WidgetWrap::ISA = qw/Tk::MainWindow/; + + # This magic conspires with widget's AUTOLOAD subroutine to make user + # contributed demonstrations that don't use WidgetDemo embed properly. + # The trick works because widget creates a superclass of Tk::MainWindow + # which invokes WidgetDemo() implicitly. You loose if you bypass the + # inheritance mechanism and call Tk::MainWindow directly. + + sub new { + my ($name) = $::DEMO_FILE =~ m#([^/]+).pl$#; + $::MW->WidgetDemo(-name => $name, -text => $::DEMO_DESCRIPTION{$name}); + } +} + +@MainWindow::ISA = 'WidgetWrap'; + +$MW->title('Perl/Tk Widget Demonstration'); +$MW->iconname('widget'); + +my $DEFAULT_FONT_FAMILY = $XFT ? "sans-serif" : "Helvetica"; +{ + $FONT = "$DEFAULT_FONT_FAMILY 12"; + $BOLD_FONT = "$DEFAULT_FONT_FAMILY 12 bold"; + $LARGE_FONT = "$DEFAULT_FONT_FAMILY 18"; + $MONOSPACE_FONT = "Courier 12"; + my $l = $MW->Label; + my $default_font = $l->cget(-font); + if ($default_font) { + my %default_font = $MW->fontActual($default_font); + $FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY); + $BOLD_FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY, -weight => "bold"); + $LARGE_FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY, -weight => "bold", -size => -18); + $MONOSPACE_FONT = $MW->fontCreate(%default_font, -family => $XFT ? "monospace" : "Courier"); + $MW->optionAdd("*font", $FONT); + } + $l->destroy; +} + +my $widget_lib = Tk->findINC('demos/widget_lib'); +my $wd = "$widget_lib/WidgetDemo.pm"; +$WIDTRIB = Tk->findINC('demos/widtrib'); +unless (Tk::tainting) { + $WIDTRIB = $ENV{WIDTRIB} if defined $ENV{WIDTRIB}; + $WIDTRIB = $ARGV[0] if defined $ARGV[0]; +} + +# The code below creates the main window, consisting of a menu bar +# and a text widget that explains how to use the program, plus lists +# all of the demos as hypertext items. + +my $file = $menubar->cascade(qw/-label File -underline 0 -menuitems/ => + [ + [cascade => '~View', -menuitems => + [ + [command => '~widget', -command => [\&view_widget, __FILE__]], + [command => '~WidgetDemo', -command => [\&view_widget, $wd]], + ], # end cascade menuitems + ], # end view cascade + '', + [command => '~Quit', -command => [\&exit], -accelerator => 'Ctrl-Q'], + ]); + +my $help = $menubar->cascade(qw/-label Help -underline 0 -menuitems/ => + [ + [command => '~About'], + ]); + +my $T = $MW->Scrolled('ROText', + -scrollbars => 'e', + -wrap => 'word', + -width => 70, + -height => 30, + -font => $FONT, + -setgrid => 1, + -highlightthickness => 0, + -padx => 4, + -pady => 2, + -takefocus => 0, +)->grid(qw/-sticky nsew/); +$MW->gridRowconfigure( 0, -weight => 1); # allow expansion in both ... +$MW->gridColumnconfigure(0, -weight => 1); # ... X and Y dimensions + +$MW->bind('<Control-q>' => \&exit); + +my $STATUS_VAR; +my $status = $MW->Label(-textvariable => \$STATUS_VAR, qw/-anchor w/); +$status->grid(qw/-sticky ew/); + +# Create a bunch of tags to use in the text widget, such as those for +# section titles and demo descriptions. Also define the bindings for +# tags. + +$T->tagConfigure(qw/title -font/, $LARGE_FONT); +$T->tagConfigure(qw/demo -lmargin1 1c -lmargin2 1c -foreground blue/); + +if ($MW->depth == 1) { + $T->tagConfigure(qw/hot -background black -foreground white/); + $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -underline 1/); +} else { + $T->tagConfigure(qw/hot -relief raised -borderwidth 1 -foreground red/); + $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -foreground/ => + '#303080'); +} +$T->tagConfigure('bold', -font => $BOLD_FONT); + +$T->tagBind(qw/demo <ButtonRelease-1>/ => \&invoke); +my $last_line = ''; +$T->tagBind(qw/demo <Enter>/ => [sub { + my($text, $sv) = @_; + my $e = $text->XEvent; + my($x, $y) = ($e->x, $e->y); + $last_line = $text->index("\@$x,$y linestart"); + $text->tagAdd('hot', $last_line, "$last_line lineend"); + $text->configure(qw/-cursor hand2/); + show_stat $sv, $text, $text->index('current'); + }, \$STATUS_VAR] +); +$T->tagBind(qw/demo <Leave>/ => [sub { + my($text, $sv) = @_; + $text->tagRemove(qw/hot 1.0 end/); + $text->configure(qw/-cursor xterm/); + $$sv = ''; + }, \$STATUS_VAR] +); +$T->tagBind(qw/demo <Motion>/ => [sub { + my($text, $sv) = @_; + my $e = $text->XEvent; + my($x, $y) = ($e->x, $e->y); + my $new_line = $text->index("\@$x,$y linestart"); + if ($new_line ne $last_line) { + $text->tagRemove(qw/hot 1.0 end/); + $last_line = $new_line; + $text->tagAdd('hot', $last_line, "$last_line lineend"); + } + show_stat $sv, $text, $text->index('current'); + }, \$STATUS_VAR] +); + +# Create the text for the text widget. + +$T->insert('end', "Perl/Tk Widget Demonstrations\n", 'title'); +$T->insert('end', +"\nThis application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the ", '', 'See Code', 'bold', " button to see the Perl/Tk code that created the demonstration. If you wish, you can edit the code and click the ", '', "Rerun Demo", 'bold', " button in the code window to reinvoke the demonstration with the modified code.\n" +); + +demos 'Getting Started', ( + 'hello' => 'An introduction to Perl/Tk', +); + +demos 'Labels, buttons, checkbuttons, and radiobuttons', ( + 'labels' => 'Labels (text and images)', + 'unicodeout' => 'Labels and Unicode text', + 'button' => 'Buttons', + 'check' => 'Checkbuttons (select any of a group)', + 'radio' => 'Radiobuttons (select one of a group)', + 'puzzle' => 'A 15-puzzle game made out of buttons', + 'icon' => 'Iconic buttons that use bitmaps', + 'image1' => 'Two labels displaying images', + 'image2' => 'A simple user interface for viewing images', + 'labelframe' => 'Labelled frames', +); + +demos 'Listboxes', ( + 'states' => 'The 50 states', + 'colors' => 'Change widget\'s color scheme', + 'sayings' => 'A collection of famous and infamous sayings', +); + +demos 'Entries and Spin-boxes', ( + 'entry1' => 'Entries without scrollbars', + 'entry2' => 'Entries with scrollbars', + 'entry3' => 'Validated entries and password fields', + 'spin' => 'Spin-boxes', + 'form' => 'Simple Rolodex-like form', +); + +demos 'Text', ( + 'texts' => 'Basic editable text', + 'style' => 'Text display styles', + 'bind' => 'Hypertext (tag bindings)', + 'twind' => 'A text widget with embedded windows', + 'search' => 'A search tool built with a text widget', +); + +demos 'Canvases', ( + 'items' => 'The canvas item types', + 'plot' => 'A simple 2-D plot', + 'ctext' => 'Text items in canvases', + 'arrows' => 'An editor for arrowheads on canvas lines', + 'ruler' => 'A ruler with adjustable tab stops', + 'floor' => 'A building floor plan', + 'cscroll' => 'A simple scrollable canvas', + 'transtile' => 'Tiles and transparent images', +); + +demos 'Scales', ( + 'hscale' => 'Horizontal scale', + 'vscale' => 'Vertical scale', +); + +demos 'Paned Windows', ( + 'paned1' => 'Horizontal paned window', + 'paned2' => 'Vertical paned window', +); + +demos 'Photos and Images', ( + 'photo1' => 'Transparent pixels', + 'photo2' => 'Alpha channel compositing', +); + +demos 'Menus', ( + 'menus' => 'Menus and cascades (sub-menus)', + 'menus2' => 'As above, but using Perl/Tk -menuitems', + 'menbut' => 'Menubuttons', +); + +demos 'Common Dialogs', ( + 'msgBox' => 'Message boxes', + 'filebox' => 'File selection dialog', + 'choosedir' => 'Directory selection dialog', + 'clrpick' => 'Color picker', +); + +demos 'Tix Widgets', ( + 'balloon' => 'Popup help window when mouse lingers over widget', + 'browseentry' => 'Entry with Listbox to select list values', + 'browseentry2' => 'Another BrowseEntry example', + 'dirtree' => 'Display a directory tree', + 'form_mgr' => 'The form geometry manager', + 'HList' => 'A hierarchical listbox widget', + 'HList2' => 'Multicolumn listbox with individual cell styles', + 'labframe' => 'A Frame with embedded label', +); + +demos 'Simulations', ( + 'bounce' => 'Balls bouncing in a cavity', +); + +demos 'Sample Perl Mega-Widgets', ( + 'mega' => 'Introduction to writing pure Perl mega-widgets', + 'slide' => 'Composite Tk::SlideSwitch - binary on/off switch', + 'trace2' => 'Derived Tk::TraceText - Text contents defined by a traced variable', +); + +demos 'Miscellaneous', ( + 'bitmaps' => 'The built-in bitmaps', + 'dialog1' => 'A dialog box with a local grab', + 'dialog2' => 'A dialog box with a global grab', + 'trace1' => 'Trace a variable\'s value', + 'progress' => 'Various ProgressBar widgets', + 'keysyms' => 'Show keyboard symbols', + 'virtevents1' => 'Synthesizing events', +); + +$T->insert('end', "\n", '', "User Contributed Demonstrations\n", 'title'); +opendir(C, $WIDTRIB) or warn "Cannot open $WIDTRIB: $!"; +my(@dirent) = grep /^.+\.pl$/, sort(readdir C); +closedir C; +unshift @dirent, 'TEMPLATE.pl'; # I want it first +my $i = 0; +while ($_ = shift @dirent) { + next if /TEMPLATE\.pl/ and $i != 0; + unless (open(C, "$WIDTRIB/$_")) { + warn "Cannot open $_: $!" unless /TEMPLATE\.pl/; + next; + } + my($name) = /^(.*)\.pl$/; + $_ = <C>; + my($title) = /^#\s*(.*)$/; + $title =~ s{\r}{}g; # strip DOS newlines + $DEMO_DESCRIPTION{$name} = $title; + close C; + $T->insert('end', ++$i . ". $title\n", ['demo', "demo-$name"]); +} + +build_about_dialog $help; +$T->focus; + +MainLoop; + +sub AUTOLOAD { + + # This routine handles the loading of most demo methods. + + my($demo) = @_; + + $T->Busy; + { + $DEMO_FILE = "$WIDTRIB/${demo}.pl" if -f "$WIDTRIB/${demo}.pl"; + $DEMO_FILE = "$widget_lib/${demo}.pl" if -f "$widget_lib/${demo}.pl"; + do $DEMO_FILE; + warn $@ if $@; + } + $T->Unbusy; + goto &$::AUTOLOAD if defined &$::AUTOLOAD; + +} # end AUTOLOAD + +sub build_about_dialog { + + my $help = shift; + + my $dialog = $MW->DialogBox( + -title => "Perl/Tk, based on Tcl/Tk ${Tk::version}.x", + -default_button => 'OK', + -buttons => ['OK'], + ); + my $df = $dialog->add( 'Labelframe', -text => ' 2006 - Oct - 31 ' ); + $df->pack( qw/ -fill both -expand 1 / ); + my( $change ) = $Tk::CHANGE =~ /Change:\s+(.*)/; + my( $tk_date ) = scalar localtime( ( stat $Tk::library )[9] ); + my( $tk ) = "$Tk::VERSION ($change), $tk_date"; + + foreach my $item ( + [ 'Perl', "$], $Config{cf_time}" ], + [ 'Tk', $tk ], + [ 'Platform', $Tk::platform ], + [ 'Library', $Tk::library ], + ) { + my $l = $item->[0] . ':'; + my $le = $df->LabEntry( + -font => $FONT, + -label => ' ' x (13 - length $l) . $l, + -labelPack => [qw/-side left -anchor w/], + -labelFont => 'Courier 12 bold', + -relief => 'flat', + -takefocus => 0, + -textvariable => $item->[1], + -width => 45, + ); + $le->pack(qw/ -fill x -expand 1/); + $le->Subwidget( 'entry' )->bindtags( [ ] ); + } + + $help->cget(-menu)->entryconfigure('About', + -command => [$dialog => 'Show'], + ); + +} # end build_about_dialog + +sub demos { + + # Generate one demo section. + + my ($title, @demos) = @_; + + $T->insert('end', "\n", '', "$title\n", 'title'); + + for (my $n = 0; $n <= $#demos; $n += 2) { + $T->insert('end', $n / 2 + 1 . '. ' . $demos[$n + 1] . ".\n", + ['demo', 'demo-' . $demos[$n]]); + } + +} # end demos + +sub invoke { + + # This procedure is called when the user clicks on a demo description. + + my($text) = @_; + + my $index = $text->index('current'); + my @tags = $T->tagNames($index); + my $i = lsearch('demo\-.*', @tags); + return if $i < 0; + my($demo) = $tags[$i] =~ /demo-(.*)/; + $T->tagAdd('visited', "$index linestart", "$index lineend"); + { + no strict 'refs'; + $SIG{__WARN__} = sub { + print @_ unless $_[0] =~ /Subroutine \S+ redefined at/; + }; + &$demo($demo); + } + +} # end invoke + +sub lsearch { + + # Search the list using the supplied regular expression and return it's + # ordinal, or -1 if not found. + + my($regexp, @list) = @_; + my($i); + + for ($i=0; $i<=$#list; $i++) { + return $i if $list[$i] =~ /$regexp/; + } + return -1; + +} # end lsearch + +sub see_code { + + # This procedure creates a toplevel window that displays the code for + # a demonstration and allows it to be edited and reinvoked. + + my($demo) = @_; + + my $file; + $file = ( $demo =~ /\.pl$/ ) ? $demo : "${demo}.pl"; + if (not Exists $CODE) { + $CODE = $MW->Toplevel; + my $code_buttons = $CODE->Frame; + $code_buttons->pack(qw/-side bottom -fill x/); + my $code_buttons_dismiss = $code_buttons->Button( + -text => 'Dismiss', + -command => [$CODE => 'withdraw'], + ); + $CODE_RERUN = $code_buttons->Button(-text => 'Rerun Demo'); + $CODE_TEXT = $CODE->Scrolled('Text', qw/ -height 40 -scrollbars oe -font /, $MONOSPACE_FONT); + $code_buttons_dismiss->pack(qw/-side left -expand 1/); + $CODE_RERUN->pack(qw/-side left -expand 1/); + $CODE_TEXT->pack(qw/-side left -expand 1 -fill both/); + } else { + $CODE->deiconify; + $CODE->raise; + } + $CODE_RERUN->configure(-command => sub { + eval $CODE_TEXT->get(qw/1.0 end/); + { + no strict 'refs'; + &$demo($demo); + } + }); + $CODE->iconname($file); + $file = "$WIDTRIB/$file" if -f "$WIDTRIB/$file"; + $file = "$widget_lib/$file" if -f "$widget_lib/$file"; + $CODE->title("Demo code: $file"); + $CODE_TEXT->delete(qw/1.0 end/); + open(CODE, "<$file") or warn "Cannot open demo file $file: $!"; + { + local $/ = undef; + $CODE_TEXT->insert('1.0', <CODE>); + } + close CODE; + $CODE_TEXT->markSet(qw/insert 1.0/); + $CODE_TEXT->focus; + +} # end see_code + +sub see_vars { + + # Create a top-level window that displays a bunch of global variable values + # and keeps the display up-to-date even when the variables change value. + # $args is a pointer to a list of list of 2: + # + # ["variable description", \$VAR] + # + # The old trick of passing a string to serve as the description and a soft + # reference to the variable no longer works with lexicals and use strict. + + my($parent, $args) = @_; + + $VARS->destroy if Exists($VARS); + $VARS = $parent->Toplevel; + $VARS->geometry('+300+300'); + $VARS->title('Variable Values'); + $VARS->iconname('Variables'); + + my $title = $VARS->Label( + -text => 'Variable Values:', + -width => 20, + -anchor => 'center', + -font => $LARGE_FONT, + ); + $title->pack(qw/-side top -fill x/); + my($label, $var); + foreach my $i (@$args) { + ($label, $var) = @$i; + my $wf = $VARS->Frame->pack(qw/-anchor w/); + $wf->Label(-text => "$label: ")->pack(qw/-side left/); + $wf->Label(-textvariable => $var)->pack(qw/-side left/); + } + $VARS->Button(-text => 'OK', -command => [$VARS => 'destroy'])-> + pack(qw/-side bottom -pady 2/); + +} # end see_vars + +sub show_stat { + + # Display name of current demonstration. $sv is a reference to the + # status Label -textvariable, $text is the Text widget reference and + # $index is the demonstration index in the Text widget. + + my($sv, $text, $index) = @_; + + my @tags = $text->tagNames($index); + my $i = lsearch('demo\-.*', @tags); + return if $i < 0; + my($demo) = $tags[$i] =~ /demo-(.*)/; + $$sv = "Click Button-1 to run the \"$demo\" demonstration."; + +} # end show_stat + +sub view_widget { + + # Expose a file's innards to the world too, but only for viewing. + + my($widget) = @_; + + if (not Exists $VIEW) { + $VIEW = $MW->Toplevel; + $VIEW->iconname('widget'); + my $view_buttons = $VIEW->Frame; + $view_buttons->pack(qw/-side bottom -fill x/); + my $view_buttons_dismiss = $view_buttons->Button( + -text => 'Dismiss', + -command => [$VIEW => 'withdraw'], + ); + $view_buttons_dismiss->pack(qw/-side left -expand 1/); + $VIEW_TEXT = $VIEW->Scrolled('Text', qw/ -height 40 -scrollbars oe /); + $VIEW_TEXT->pack(qw/-side left -expand 1 -fill both/); + } else { + $VIEW->deiconify; + $VIEW->raise; + } + $VIEW->title("Demo code: $widget"); + $VIEW_TEXT->configure(qw/-state normal/); + $VIEW_TEXT->delete(qw/1.0 end/); + open(VIEW, "<$widget") or warn "Cannot open demo file $widget: $!"; + { + local $/ = undef; + $VIEW_TEXT->insert('1.0', <VIEW>); + } + close VIEW; + $VIEW_TEXT->markSet(qw/insert 1.0/); + $VIEW_TEXT->configure(qw/-state disabled/); + +} # end view_widget + +=head1 NAME + +widget - Demonstration of Perl/Tk widgets + +=head1 SYNOPSYS + + widget [ directory ] + +=head1 DESCRIPTION + +This script demonstrates the various widgets provided by Tk, along with +many of the features of the Tk toolkit. This file only contains code to +generate the main window for the application, which invokes individual +demonstrations. The code for the actual demonstrations is contained in +separate ".pl" files in the "widget_lib" directory, which are autoloaded +by this script as needed. + +widget looks in the directory specified on the command line to load user +contributed demonstrations. If no directory name is specified when widget is +invoked and the environment variable WIDTRIB is defined then demonstrations +are loaded from the WIDTRIB directory. If WIDTRIB is undefined then widget +defaults to the released user contributed directory, "widtrib". + +=head2 History + + # + # Stephen O. Lidie, LUCC, 96/03/11. lusol@Lehigh.EDU + # Stephen O. Lidie, LUCC, 97/01/01. lusol@Lehigh.EDU + # Stephen O. Lidie, LUCC, 97/02/11. lusol@Lehigh.EDU + # Stephen O. Lidie, LUCC, 97/06/07. lusol@Lehigh.EDU + # Update for Tk402.00x. Total revamp: WidgetDemo, Scrolled, released + # composites, -menuitems, qw//, etcetera. Perl 5.004 required. + # Stephen O. Lidie, LUCC, 98/03/10. lusol@Lehigh.EDU + # Update for Tk8. + # Stephen O. Lidie, LUCC, 98/06/26. Stephen.O.Lidie@Lehigh.EDU + # Add Common Dialogs for Tk800.007. + # Stephen.O.Lidie@Lehigh.EDU, 1999/11/29, Lehigh University. + # Demo some "dash patch" changes. + # Stephen.O.Lidie@Lehigh.EDU, 2000/01/11, Lehigh University. + # Update menubar to Tk 8, fix color palette Menubutton demo. + # Stephen.O.Lidie@Lehigh.EDU, 2000/07/06, Lehigh University. + # Remove inswt() from widget and styles.pl to show the proper Perl/Tk + # idiom for inserting Text tags. Various and sundry cleanups. + # sol0@lehigh.edu, 2003/07/29, Lehigh University Computing Center. + # Update for Tk 8.4.4. + +=head1 AUTHOR + +Steve Lidie <sol0@Lehigh.EDU> + +=cut diff --git a/Master/tlpkg/tlperl/bin/widget.bat b/Master/tlpkg/tlperl/bin/widget.bat new file mode 100755 index 00000000000..ab5b6283bbc --- /dev/null +++ b/Master/tlpkg/tlperl/bin/widget.bat @@ -0,0 +1,624 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+#line 15
+
+use 5.008;
+use Config;
+use Tk 804.000;
+use lib Tk->findINC( 'demos/widget_lib' );
+use Tk::widgets qw/ DialogBox ErrorDialog LabEntry ROText /;
+use Tk::Config ();
+use WidgetDemo;
+use subs qw/
+ build_about_dialog demos invoke lsearch
+ see_code see_vars show_stat view_widget
+/;
+use vars qw/ $MW $FONT $BOLD_FONT $LARGE_FONT $MONOSPACE_FONT $WIDTRIB /;
+use vars qw/ $CODE $CODE_RERUN $CODE_TEXT $VARS $VIEW $VIEW_TEXT /;
+use vars qw/ $ALIGN $BRAKES $LIGHTS $OIL $SOBER $TRANS $WIPERS /;
+use vars qw/ $COLOR $FONT_STYLE $POINT_SIZE $DEMO_FILE %DEMO_DESCRIPTION $XFT /;
+use strict;
+
+$XFT = $Tk::Config::xlib =~ /-lXft\b/;
+
+$MW = Tk::MainWindow->new;
+$MW->configure(-menu => my $menubar = $MW->Menu);
+
+{
+ package WidgetWrap;
+ @WidgetWrap::ISA = qw/Tk::MainWindow/;
+
+ # This magic conspires with widget's AUTOLOAD subroutine to make user
+ # contributed demonstrations that don't use WidgetDemo embed properly.
+ # The trick works because widget creates a superclass of Tk::MainWindow
+ # which invokes WidgetDemo() implicitly. You loose if you bypass the
+ # inheritance mechanism and call Tk::MainWindow directly.
+
+ sub new {
+ my ($name) = $::DEMO_FILE =~ m#([^/]+).pl$#;
+ $::MW->WidgetDemo(-name => $name, -text => $::DEMO_DESCRIPTION{$name});
+ }
+}
+
+@MainWindow::ISA = 'WidgetWrap';
+
+$MW->title('Perl/Tk Widget Demonstration');
+$MW->iconname('widget');
+
+my $DEFAULT_FONT_FAMILY = $XFT ? "sans-serif" : "Helvetica";
+{
+ $FONT = "$DEFAULT_FONT_FAMILY 12";
+ $BOLD_FONT = "$DEFAULT_FONT_FAMILY 12 bold";
+ $LARGE_FONT = "$DEFAULT_FONT_FAMILY 18";
+ $MONOSPACE_FONT = "Courier 12";
+ my $l = $MW->Label;
+ my $default_font = $l->cget(-font);
+ if ($default_font) {
+ my %default_font = $MW->fontActual($default_font);
+ $FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY);
+ $BOLD_FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY, -weight => "bold");
+ $LARGE_FONT = $MW->fontCreate(%default_font, -family => $DEFAULT_FONT_FAMILY, -weight => "bold", -size => -18);
+ $MONOSPACE_FONT = $MW->fontCreate(%default_font, -family => $XFT ? "monospace" : "Courier");
+ $MW->optionAdd("*font", $FONT);
+ }
+ $l->destroy;
+}
+
+my $widget_lib = Tk->findINC('demos/widget_lib');
+my $wd = "$widget_lib/WidgetDemo.pm";
+$WIDTRIB = Tk->findINC('demos/widtrib');
+unless (Tk::tainting) {
+ $WIDTRIB = $ENV{WIDTRIB} if defined $ENV{WIDTRIB};
+ $WIDTRIB = $ARGV[0] if defined $ARGV[0];
+}
+
+# The code below creates the main window, consisting of a menu bar
+# and a text widget that explains how to use the program, plus lists
+# all of the demos as hypertext items.
+
+my $file = $menubar->cascade(qw/-label File -underline 0 -menuitems/ =>
+ [
+ [cascade => '~View', -menuitems =>
+ [
+ [command => '~widget', -command => [\&view_widget, __FILE__]],
+ [command => '~WidgetDemo', -command => [\&view_widget, $wd]],
+ ], # end cascade menuitems
+ ], # end view cascade
+ '',
+ [command => '~Quit', -command => [\&exit], -accelerator => 'Ctrl-Q'],
+ ]);
+
+my $help = $menubar->cascade(qw/-label Help -underline 0 -menuitems/ =>
+ [
+ [command => '~About'],
+ ]);
+
+my $T = $MW->Scrolled('ROText',
+ -scrollbars => 'e',
+ -wrap => 'word',
+ -width => 70,
+ -height => 30,
+ -font => $FONT,
+ -setgrid => 1,
+ -highlightthickness => 0,
+ -padx => 4,
+ -pady => 2,
+ -takefocus => 0,
+)->grid(qw/-sticky nsew/);
+$MW->gridRowconfigure( 0, -weight => 1); # allow expansion in both ...
+$MW->gridColumnconfigure(0, -weight => 1); # ... X and Y dimensions
+
+$MW->bind('<Control-q>' => \&exit);
+
+my $STATUS_VAR;
+my $status = $MW->Label(-textvariable => \$STATUS_VAR, qw/-anchor w/);
+$status->grid(qw/-sticky ew/);
+
+# Create a bunch of tags to use in the text widget, such as those for
+# section titles and demo descriptions. Also define the bindings for
+# tags.
+
+$T->tagConfigure(qw/title -font/, $LARGE_FONT);
+$T->tagConfigure(qw/demo -lmargin1 1c -lmargin2 1c -foreground blue/);
+
+if ($MW->depth == 1) {
+ $T->tagConfigure(qw/hot -background black -foreground white/);
+ $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -underline 1/);
+} else {
+ $T->tagConfigure(qw/hot -relief raised -borderwidth 1 -foreground red/);
+ $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -foreground/ =>
+ '#303080');
+}
+$T->tagConfigure('bold', -font => $BOLD_FONT);
+
+$T->tagBind(qw/demo <ButtonRelease-1>/ => \&invoke);
+my $last_line = '';
+$T->tagBind(qw/demo <Enter>/ => [sub {
+ my($text, $sv) = @_;
+ my $e = $text->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ $last_line = $text->index("\@$x,$y linestart");
+ $text->tagAdd('hot', $last_line, "$last_line lineend");
+ $text->configure(qw/-cursor hand2/);
+ show_stat $sv, $text, $text->index('current');
+ }, \$STATUS_VAR]
+);
+$T->tagBind(qw/demo <Leave>/ => [sub {
+ my($text, $sv) = @_;
+ $text->tagRemove(qw/hot 1.0 end/);
+ $text->configure(qw/-cursor xterm/);
+ $$sv = '';
+ }, \$STATUS_VAR]
+);
+$T->tagBind(qw/demo <Motion>/ => [sub {
+ my($text, $sv) = @_;
+ my $e = $text->XEvent;
+ my($x, $y) = ($e->x, $e->y);
+ my $new_line = $text->index("\@$x,$y linestart");
+ if ($new_line ne $last_line) {
+ $text->tagRemove(qw/hot 1.0 end/);
+ $last_line = $new_line;
+ $text->tagAdd('hot', $last_line, "$last_line lineend");
+ }
+ show_stat $sv, $text, $text->index('current');
+ }, \$STATUS_VAR]
+);
+
+# Create the text for the text widget.
+
+$T->insert('end', "Perl/Tk Widget Demonstrations\n", 'title');
+$T->insert('end',
+"\nThis application provides a front end for several short scripts that demonstrate what you can do with Tk widgets. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the ", '', 'See Code', 'bold', " button to see the Perl/Tk code that created the demonstration. If you wish, you can edit the code and click the ", '', "Rerun Demo", 'bold', " button in the code window to reinvoke the demonstration with the modified code.\n"
+);
+
+demos 'Getting Started', (
+ 'hello' => 'An introduction to Perl/Tk',
+);
+
+demos 'Labels, buttons, checkbuttons, and radiobuttons', (
+ 'labels' => 'Labels (text and images)',
+ 'unicodeout' => 'Labels and Unicode text',
+ 'button' => 'Buttons',
+ 'check' => 'Checkbuttons (select any of a group)',
+ 'radio' => 'Radiobuttons (select one of a group)',
+ 'puzzle' => 'A 15-puzzle game made out of buttons',
+ 'icon' => 'Iconic buttons that use bitmaps',
+ 'image1' => 'Two labels displaying images',
+ 'image2' => 'A simple user interface for viewing images',
+ 'labelframe' => 'Labelled frames',
+);
+
+demos 'Listboxes', (
+ 'states' => 'The 50 states',
+ 'colors' => 'Change widget\'s color scheme',
+ 'sayings' => 'A collection of famous and infamous sayings',
+);
+
+demos 'Entries and Spin-boxes', (
+ 'entry1' => 'Entries without scrollbars',
+ 'entry2' => 'Entries with scrollbars',
+ 'entry3' => 'Validated entries and password fields',
+ 'spin' => 'Spin-boxes',
+ 'form' => 'Simple Rolodex-like form',
+);
+
+demos 'Text', (
+ 'texts' => 'Basic editable text',
+ 'style' => 'Text display styles',
+ 'bind' => 'Hypertext (tag bindings)',
+ 'twind' => 'A text widget with embedded windows',
+ 'search' => 'A search tool built with a text widget',
+);
+
+demos 'Canvases', (
+ 'items' => 'The canvas item types',
+ 'plot' => 'A simple 2-D plot',
+ 'ctext' => 'Text items in canvases',
+ 'arrows' => 'An editor for arrowheads on canvas lines',
+ 'ruler' => 'A ruler with adjustable tab stops',
+ 'floor' => 'A building floor plan',
+ 'cscroll' => 'A simple scrollable canvas',
+ 'transtile' => 'Tiles and transparent images',
+);
+
+demos 'Scales', (
+ 'hscale' => 'Horizontal scale',
+ 'vscale' => 'Vertical scale',
+);
+
+demos 'Paned Windows', (
+ 'paned1' => 'Horizontal paned window',
+ 'paned2' => 'Vertical paned window',
+);
+
+demos 'Photos and Images', (
+ 'photo1' => 'Transparent pixels',
+ 'photo2' => 'Alpha channel compositing',
+);
+
+demos 'Menus', (
+ 'menus' => 'Menus and cascades (sub-menus)',
+ 'menus2' => 'As above, but using Perl/Tk -menuitems',
+ 'menbut' => 'Menubuttons',
+);
+
+demos 'Common Dialogs', (
+ 'msgBox' => 'Message boxes',
+ 'filebox' => 'File selection dialog',
+ 'choosedir' => 'Directory selection dialog',
+ 'clrpick' => 'Color picker',
+);
+
+demos 'Tix Widgets', (
+ 'balloon' => 'Popup help window when mouse lingers over widget',
+ 'browseentry' => 'Entry with Listbox to select list values',
+ 'browseentry2' => 'Another BrowseEntry example',
+ 'dirtree' => 'Display a directory tree',
+ 'form_mgr' => 'The form geometry manager',
+ 'HList' => 'A hierarchical listbox widget',
+ 'HList2' => 'Multicolumn listbox with individual cell styles',
+ 'labframe' => 'A Frame with embedded label',
+);
+
+demos 'Simulations', (
+ 'bounce' => 'Balls bouncing in a cavity',
+);
+
+demos 'Sample Perl Mega-Widgets', (
+ 'mega' => 'Introduction to writing pure Perl mega-widgets',
+ 'slide' => 'Composite Tk::SlideSwitch - binary on/off switch',
+ 'trace2' => 'Derived Tk::TraceText - Text contents defined by a traced variable',
+);
+
+demos 'Miscellaneous', (
+ 'bitmaps' => 'The built-in bitmaps',
+ 'dialog1' => 'A dialog box with a local grab',
+ 'dialog2' => 'A dialog box with a global grab',
+ 'trace1' => 'Trace a variable\'s value',
+ 'progress' => 'Various ProgressBar widgets',
+ 'keysyms' => 'Show keyboard symbols',
+ 'virtevents1' => 'Synthesizing events',
+);
+
+$T->insert('end', "\n", '', "User Contributed Demonstrations\n", 'title');
+opendir(C, $WIDTRIB) or warn "Cannot open $WIDTRIB: $!";
+my(@dirent) = grep /^.+\.pl$/, sort(readdir C);
+closedir C;
+unshift @dirent, 'TEMPLATE.pl'; # I want it first
+my $i = 0;
+while ($_ = shift @dirent) {
+ next if /TEMPLATE\.pl/ and $i != 0;
+ unless (open(C, "$WIDTRIB/$_")) {
+ warn "Cannot open $_: $!" unless /TEMPLATE\.pl/;
+ next;
+ }
+ my($name) = /^(.*)\.pl$/;
+ $_ = <C>;
+ my($title) = /^#\s*(.*)$/;
+ $title =~ s{\r}{}g; # strip DOS newlines
+ $DEMO_DESCRIPTION{$name} = $title;
+ close C;
+ $T->insert('end', ++$i . ". $title\n", ['demo', "demo-$name"]);
+}
+
+build_about_dialog $help;
+$T->focus;
+
+MainLoop;
+
+sub AUTOLOAD {
+
+ # This routine handles the loading of most demo methods.
+
+ my($demo) = @_;
+
+ $T->Busy;
+ {
+ $DEMO_FILE = "$WIDTRIB/${demo}.pl" if -f "$WIDTRIB/${demo}.pl";
+ $DEMO_FILE = "$widget_lib/${demo}.pl" if -f "$widget_lib/${demo}.pl";
+ do $DEMO_FILE;
+ warn $@ if $@;
+ }
+ $T->Unbusy;
+ goto &$::AUTOLOAD if defined &$::AUTOLOAD;
+
+} # end AUTOLOAD
+
+sub build_about_dialog {
+
+ my $help = shift;
+
+ my $dialog = $MW->DialogBox(
+ -title => "Perl/Tk, based on Tcl/Tk ${Tk::version}.x",
+ -default_button => 'OK',
+ -buttons => ['OK'],
+ );
+ my $df = $dialog->add( 'Labelframe', -text => ' 2006 - Oct - 31 ' );
+ $df->pack( qw/ -fill both -expand 1 / );
+ my( $change ) = $Tk::CHANGE =~ /Change:\s+(.*)/;
+ my( $tk_date ) = scalar localtime( ( stat $Tk::library )[9] );
+ my( $tk ) = "$Tk::VERSION ($change), $tk_date";
+
+ foreach my $item (
+ [ 'Perl', "$], $Config{cf_time}" ],
+ [ 'Tk', $tk ],
+ [ 'Platform', $Tk::platform ],
+ [ 'Library', $Tk::library ],
+ ) {
+ my $l = $item->[0] . ':';
+ my $le = $df->LabEntry(
+ -font => $FONT,
+ -label => ' ' x (13 - length $l) . $l,
+ -labelPack => [qw/-side left -anchor w/],
+ -labelFont => 'Courier 12 bold',
+ -relief => 'flat',
+ -takefocus => 0,
+ -textvariable => $item->[1],
+ -width => 45,
+ );
+ $le->pack(qw/ -fill x -expand 1/);
+ $le->Subwidget( 'entry' )->bindtags( [ ] );
+ }
+
+ $help->cget(-menu)->entryconfigure('About',
+ -command => [$dialog => 'Show'],
+ );
+
+} # end build_about_dialog
+
+sub demos {
+
+ # Generate one demo section.
+
+ my ($title, @demos) = @_;
+
+ $T->insert('end', "\n", '', "$title\n", 'title');
+
+ for (my $n = 0; $n <= $#demos; $n += 2) {
+ $T->insert('end', $n / 2 + 1 . '. ' . $demos[$n + 1] . ".\n",
+ ['demo', 'demo-' . $demos[$n]]);
+ }
+
+} # end demos
+
+sub invoke {
+
+ # This procedure is called when the user clicks on a demo description.
+
+ my($text) = @_;
+
+ my $index = $text->index('current');
+ my @tags = $T->tagNames($index);
+ my $i = lsearch('demo\-.*', @tags);
+ return if $i < 0;
+ my($demo) = $tags[$i] =~ /demo-(.*)/;
+ $T->tagAdd('visited', "$index linestart", "$index lineend");
+ {
+ no strict 'refs';
+ $SIG{__WARN__} = sub {
+ print @_ unless $_[0] =~ /Subroutine \S+ redefined at/;
+ };
+ &$demo($demo);
+ }
+
+} # end invoke
+
+sub lsearch {
+
+ # Search the list using the supplied regular expression and return it's
+ # ordinal, or -1 if not found.
+
+ my($regexp, @list) = @_;
+ my($i);
+
+ for ($i=0; $i<=$#list; $i++) {
+ return $i if $list[$i] =~ /$regexp/;
+ }
+ return -1;
+
+} # end lsearch
+
+sub see_code {
+
+ # This procedure creates a toplevel window that displays the code for
+ # a demonstration and allows it to be edited and reinvoked.
+
+ my($demo) = @_;
+
+ my $file;
+ $file = ( $demo =~ /\.pl$/ ) ? $demo : "${demo}.pl";
+ if (not Exists $CODE) {
+ $CODE = $MW->Toplevel;
+ my $code_buttons = $CODE->Frame;
+ $code_buttons->pack(qw/-side bottom -fill x/);
+ my $code_buttons_dismiss = $code_buttons->Button(
+ -text => 'Dismiss',
+ -command => [$CODE => 'withdraw'],
+ );
+ $CODE_RERUN = $code_buttons->Button(-text => 'Rerun Demo');
+ $CODE_TEXT = $CODE->Scrolled('Text', qw/ -height 40 -scrollbars oe -font /, $MONOSPACE_FONT);
+ $code_buttons_dismiss->pack(qw/-side left -expand 1/);
+ $CODE_RERUN->pack(qw/-side left -expand 1/);
+ $CODE_TEXT->pack(qw/-side left -expand 1 -fill both/);
+ } else {
+ $CODE->deiconify;
+ $CODE->raise;
+ }
+ $CODE_RERUN->configure(-command => sub {
+ eval $CODE_TEXT->get(qw/1.0 end/);
+ {
+ no strict 'refs';
+ &$demo($demo);
+ }
+ });
+ $CODE->iconname($file);
+ $file = "$WIDTRIB/$file" if -f "$WIDTRIB/$file";
+ $file = "$widget_lib/$file" if -f "$widget_lib/$file";
+ $CODE->title("Demo code: $file");
+ $CODE_TEXT->delete(qw/1.0 end/);
+ open(CODE, "<$file") or warn "Cannot open demo file $file: $!";
+ {
+ local $/ = undef;
+ $CODE_TEXT->insert('1.0', <CODE>);
+ }
+ close CODE;
+ $CODE_TEXT->markSet(qw/insert 1.0/);
+ $CODE_TEXT->focus;
+
+} # end see_code
+
+sub see_vars {
+
+ # Create a top-level window that displays a bunch of global variable values
+ # and keeps the display up-to-date even when the variables change value.
+ # $args is a pointer to a list of list of 2:
+ #
+ # ["variable description", \$VAR]
+ #
+ # The old trick of passing a string to serve as the description and a soft
+ # reference to the variable no longer works with lexicals and use strict.
+
+ my($parent, $args) = @_;
+
+ $VARS->destroy if Exists($VARS);
+ $VARS = $parent->Toplevel;
+ $VARS->geometry('+300+300');
+ $VARS->title('Variable Values');
+ $VARS->iconname('Variables');
+
+ my $title = $VARS->Label(
+ -text => 'Variable Values:',
+ -width => 20,
+ -anchor => 'center',
+ -font => $LARGE_FONT,
+ );
+ $title->pack(qw/-side top -fill x/);
+ my($label, $var);
+ foreach my $i (@$args) {
+ ($label, $var) = @$i;
+ my $wf = $VARS->Frame->pack(qw/-anchor w/);
+ $wf->Label(-text => "$label: ")->pack(qw/-side left/);
+ $wf->Label(-textvariable => $var)->pack(qw/-side left/);
+ }
+ $VARS->Button(-text => 'OK', -command => [$VARS => 'destroy'])->
+ pack(qw/-side bottom -pady 2/);
+
+} # end see_vars
+
+sub show_stat {
+
+ # Display name of current demonstration. $sv is a reference to the
+ # status Label -textvariable, $text is the Text widget reference and
+ # $index is the demonstration index in the Text widget.
+
+ my($sv, $text, $index) = @_;
+
+ my @tags = $text->tagNames($index);
+ my $i = lsearch('demo\-.*', @tags);
+ return if $i < 0;
+ my($demo) = $tags[$i] =~ /demo-(.*)/;
+ $$sv = "Click Button-1 to run the \"$demo\" demonstration.";
+
+} # end show_stat
+
+sub view_widget {
+
+ # Expose a file's innards to the world too, but only for viewing.
+
+ my($widget) = @_;
+
+ if (not Exists $VIEW) {
+ $VIEW = $MW->Toplevel;
+ $VIEW->iconname('widget');
+ my $view_buttons = $VIEW->Frame;
+ $view_buttons->pack(qw/-side bottom -fill x/);
+ my $view_buttons_dismiss = $view_buttons->Button(
+ -text => 'Dismiss',
+ -command => [$VIEW => 'withdraw'],
+ );
+ $view_buttons_dismiss->pack(qw/-side left -expand 1/);
+ $VIEW_TEXT = $VIEW->Scrolled('Text', qw/ -height 40 -scrollbars oe /);
+ $VIEW_TEXT->pack(qw/-side left -expand 1 -fill both/);
+ } else {
+ $VIEW->deiconify;
+ $VIEW->raise;
+ }
+ $VIEW->title("Demo code: $widget");
+ $VIEW_TEXT->configure(qw/-state normal/);
+ $VIEW_TEXT->delete(qw/1.0 end/);
+ open(VIEW, "<$widget") or warn "Cannot open demo file $widget: $!";
+ {
+ local $/ = undef;
+ $VIEW_TEXT->insert('1.0', <VIEW>);
+ }
+ close VIEW;
+ $VIEW_TEXT->markSet(qw/insert 1.0/);
+ $VIEW_TEXT->configure(qw/-state disabled/);
+
+} # end view_widget
+
+=head1 NAME
+
+widget - Demonstration of Perl/Tk widgets
+
+=head1 SYNOPSYS
+
+ widget [ directory ]
+
+=head1 DESCRIPTION
+
+This script demonstrates the various widgets provided by Tk, along with
+many of the features of the Tk toolkit. This file only contains code to
+generate the main window for the application, which invokes individual
+demonstrations. The code for the actual demonstrations is contained in
+separate ".pl" files in the "widget_lib" directory, which are autoloaded
+by this script as needed.
+
+widget looks in the directory specified on the command line to load user
+contributed demonstrations. If no directory name is specified when widget is
+invoked and the environment variable WIDTRIB is defined then demonstrations
+are loaded from the WIDTRIB directory. If WIDTRIB is undefined then widget
+defaults to the released user contributed directory, "widtrib".
+
+=head2 History
+
+ #
+ # Stephen O. Lidie, LUCC, 96/03/11. lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/01/01. lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/02/11. lusol@Lehigh.EDU
+ # Stephen O. Lidie, LUCC, 97/06/07. lusol@Lehigh.EDU
+ # Update for Tk402.00x. Total revamp: WidgetDemo, Scrolled, released
+ # composites, -menuitems, qw//, etcetera. Perl 5.004 required.
+ # Stephen O. Lidie, LUCC, 98/03/10. lusol@Lehigh.EDU
+ # Update for Tk8.
+ # Stephen O. Lidie, LUCC, 98/06/26. Stephen.O.Lidie@Lehigh.EDU
+ # Add Common Dialogs for Tk800.007.
+ # Stephen.O.Lidie@Lehigh.EDU, 1999/11/29, Lehigh University.
+ # Demo some "dash patch" changes.
+ # Stephen.O.Lidie@Lehigh.EDU, 2000/01/11, Lehigh University.
+ # Update menubar to Tk 8, fix color palette Menubutton demo.
+ # Stephen.O.Lidie@Lehigh.EDU, 2000/07/06, Lehigh University.
+ # Remove inswt() from widget and styles.pl to show the proper Perl/Tk
+ # idiom for inserting Text tags. Various and sundry cleanups.
+ # sol0@lehigh.edu, 2003/07/29, Lehigh University Computing Center.
+ # Update for Tk 8.4.4.
+
+=head1 AUTHOR
+
+Steve Lidie <sol0@Lehigh.EDU>
+
+=cut
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/wperl.exe b/Master/tlpkg/tlperl/bin/wperl.exe Binary files differnew file mode 100755 index 00000000000..bd2c649bdc2 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/wperl.exe diff --git a/Master/tlpkg/tlperl/bin/xsubpp.bat b/Master/tlpkg/tlperl/bin/xsubpp.bat new file mode 100755 index 00000000000..672a905c9e8 --- /dev/null +++ b/Master/tlpkg/tlperl/bin/xsubpp.bat @@ -0,0 +1,175 @@ +@rem = '--*-Perl-*--
+@echo off
+if "%OS%" == "Windows_NT" goto WinNT
+perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+:WinNT
+perl -x -S %0 %*
+if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
+if %errorlevel% == 9009 echo You do not have Perl in your PATH.
+if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
+goto endofperl
+@rem ';
+#!perl
+#line 15
+ eval 'exec C:\strawberry\perl\bin\perl.exe -S $0 ${1+"$@"}'
+ if $running_under_some_shell;
+#!./miniperl
+
+require 5.002;
+use ExtUtils::ParseXS qw(process_file);
+use Getopt::Long;
+
+my %args = ();
+
+my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n";
+
+Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case);
+
+@ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility
+GetOptions(\%args, qw(hiertype!
+ prototypes!
+ versioncheck!
+ linenumbers!
+ optimize!
+ inout!
+ argtypes!
+ object_capi!
+ except!
+ v
+ typemap=s@
+ output=s
+ s=s
+ csuffix=s
+ ))
+ or die $usage;
+
+if ($args{v}) {
+ print "xsubpp version $ExtUtils::ParseXS::VERSION\n";
+ exit;
+}
+
+@ARGV == 1 or die $usage;
+
+$args{filename} = shift @ARGV;
+
+process_file(%args);
+exit( ExtUtils::ParseXS::errors() ? 1 : 0 );
+
+__END__
+
+=head1 NAME
+
+xsubpp - compiler to convert Perl XS code into C code
+
+=head1 SYNOPSIS
+
+B<xsubpp> [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs
+
+=head1 DESCRIPTION
+
+This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>.
+
+I<xsubpp> will compile XS code into C code by embedding the constructs
+necessary to let C functions manipulate Perl values and creates the glue
+necessary to let Perl access those functions. The compiler uses typemaps to
+determine how to map C function parameters and variables to Perl values.
+
+The compiler will search for typemap files called I<typemap>. It will use
+the following search path to find default typemaps, with the rightmost
+typemap taking precedence.
+
+ ../../../typemap:../../typemap:../typemap:typemap
+
+It will also use a default typemap installed as C<ExtUtils::typemap>.
+
+=head1 OPTIONS
+
+Note that the C<XSOPT> MakeMaker option may be used to add these options to
+any makefiles generated by MakeMaker.
+
+=over 5
+
+=item B<-hiertype>
+
+Retains '::' in type names so that C++ hierarchical types can be mapped.
+
+=item B<-except>
+
+Adds exception handling stubs to the C code.
+
+=item B<-typemap typemap>
+
+Indicates that a user-supplied typemap should take precedence over the
+default typemaps. This option may be used multiple times, with the last
+typemap having the highest precedence.
+
+=item B<-output filename>
+
+Specifies the name of the output file to generate. If no file is
+specified, output will be written to standard output.
+
+=item B<-v>
+
+Prints the I<xsubpp> version number to standard output, then exits.
+
+=item B<-prototypes>
+
+By default I<xsubpp> will not automatically generate prototype code for
+all xsubs. This flag will enable prototypes.
+
+=item B<-noversioncheck>
+
+Disables the run time test that determines if the object file (derived
+from the C<.xs> file) and the C<.pm> files have the same version
+number.
+
+=item B<-nolinenumbers>
+
+Prevents the inclusion of `#line' directives in the output.
+
+=item B<-nooptimize>
+
+Disables certain optimizations. The only optimization that is currently
+affected is the use of I<target>s by the output C code (see L<perlguts>).
+This may significantly slow down the generated code, but this is the way
+B<xsubpp> of 5.005 and earlier operated.
+
+=item B<-noinout>
+
+Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations.
+
+=item B<-noargtypes>
+
+Disable recognition of ANSI-like descriptions of function signature.
+
+=item B<-C++>
+
+Currently doesn't do anything at all. This flag has been a no-op for
+many versions of perl, at least as far back as perl5.003_07. It's
+allowed here for backwards compatibility.
+
+=back
+
+=head1 ENVIRONMENT
+
+No environment variables are used.
+
+=head1 AUTHOR
+
+Originally by Larry Wall. Turned into the C<ExtUtils::ParseXS> module
+by Ken Williams.
+
+=head1 MODIFICATION HISTORY
+
+See the file F<Changes>.
+
+=head1 SEE ALSO
+
+perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS
+
+=cut
+
+
+__END__
+:endofperl
diff --git a/Master/tlpkg/tlperl/bin/zlib1.dll b/Master/tlpkg/tlperl/bin/zlib1.dll Binary files differnew file mode 100755 index 00000000000..1cf8a476e5a --- /dev/null +++ b/Master/tlpkg/tlperl/bin/zlib1.dll |