summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/bin
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/bin
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff)
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/bin')
-rwxr-xr-xMaster/tlpkg/tlperl/bin/a2p.exebin104448 -> 0 bytes
-rwxr-xr-xMaster/tlpkg/tlperl/bin/bdf2gdfont.bat205
-rwxr-xr-xMaster/tlpkg/tlperl/bin/bdf2gdfont.pl189
-rwxr-xr-xMaster/tlpkg/tlperl/bin/c2ph.bat1383
-rwxr-xr-xMaster/tlpkg/tlperl/bin/config_data249
-rwxr-xr-xMaster/tlpkg/tlperl/bin/config_data.bat265
-rwxr-xr-xMaster/tlpkg/tlperl/bin/corelist272
-rwxr-xr-xMaster/tlpkg/tlperl/bin/corelist.bat288
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpan229
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpan.bat245
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpan2dist671
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpan2dist.bat687
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpandb272
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpandb.bat288
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpaninject137
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpaninject.bat153
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpanp104
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpanp-run-perl10
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpanp-run-perl.bat27
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpanp.bat120
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpansign95
-rwxr-xr-xMaster/tlpkg/tlperl/bin/cpansign.bat111
-rwxr-xr-xMaster/tlpkg/tlperl/bin/crc3231
-rwxr-xr-xMaster/tlpkg/tlperl/bin/crc32.bat47
-rwxr-xr-xMaster/tlpkg/tlperl/bin/dbilogstrip50
-rwxr-xr-xMaster/tlpkg/tlperl/bin/dbilogstrip.bat66
-rwxr-xr-xMaster/tlpkg/tlperl/bin/dbiprof263
-rwxr-xr-xMaster/tlpkg/tlperl/bin/dbiprof.bat279
-rwxr-xr-xMaster/tlpkg/tlperl/bin/dbiproxy184
-rwxr-xr-xMaster/tlpkg/tlperl/bin/dbiproxy.bat200
-rwxr-xr-xMaster/tlpkg/tlperl/bin/dprofpp.bat945
-rwxr-xr-xMaster/tlpkg/tlperl/bin/enc2xs1407
-rwxr-xr-xMaster/tlpkg/tlperl/bin/enc2xs.bat1423
-rwxr-xr-xMaster/tlpkg/tlperl/bin/exe_update.bat114
-rwxr-xr-xMaster/tlpkg/tlperl/bin/exe_update.pl98
-rwxr-xr-xMaster/tlpkg/tlperl/bin/exetype.bat124
-rwxr-xr-xMaster/tlpkg/tlperl/bin/find2perl.bat895
-rwxr-xr-xMaster/tlpkg/tlperl/bin/findrule138
-rwxr-xr-xMaster/tlpkg/tlperl/bin/findrule.bat154
-rwxr-xr-xMaster/tlpkg/tlperl/bin/gedi315
-rwxr-xr-xMaster/tlpkg/tlperl/bin/gedi.bat331
-rwxr-xr-xMaster/tlpkg/tlperl/bin/h2ph.bat959
-rwxr-xr-xMaster/tlpkg/tlperl/bin/h2xs.bat2203
-rwxr-xr-xMaster/tlpkg/tlperl/bin/instmodsh192
-rwxr-xr-xMaster/tlpkg/tlperl/bin/instmodsh.bat208
-rwxr-xr-xMaster/tlpkg/tlperl/bin/json_xs179
-rwxr-xr-xMaster/tlpkg/tlperl/bin/json_xs.bat195
-rwxr-xr-xMaster/tlpkg/tlperl/bin/largeprimes68
-rwxr-xr-xMaster/tlpkg/tlperl/bin/largeprimes.bat84
-rwxr-xr-xMaster/tlpkg/tlperl/bin/libnetcfg.bat737
-rwxr-xr-xMaster/tlpkg/tlperl/bin/libpng3.dllbin260096 -> 0 bytes
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-download320
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-download.bat336
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-dump107
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-dump.bat123
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-mirror103
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-mirror.bat119
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-request531
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-request.bat547
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-rget607
-rwxr-xr-xMaster/tlpkg/tlperl/bin/lwp-rget.bat623
-rwxr-xr-xMaster/tlpkg/tlperl/bin/makerandom50
-rwxr-xr-xMaster/tlpkg/tlperl/bin/makerandom.bat66
-rwxr-xr-xMaster/tlpkg/tlperl/bin/parinstallppd124
-rwxr-xr-xMaster/tlpkg/tlperl/bin/parinstallppd.bat140
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perl.exebin9216 -> 0 bytes
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perl5.10.1.exebin9216 -> 0 bytes
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perl510.dllbin1324032 -> 0 bytes
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perlbug.bat1478
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perldoc7
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perldoc.bat23
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perlglob.bat69
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perlglob.exebin6144 -> 0 bytes
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perlivp.bat456
-rwxr-xr-xMaster/tlpkg/tlperl/bin/perlthanks.bat1478
-rwxr-xr-xMaster/tlpkg/tlperl/bin/piconv299
-rwxr-xr-xMaster/tlpkg/tlperl/bin/piconv.bat315
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pip23
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pip.bat39
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pl2bat.bat430
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pl2pm.bat394
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pler27
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pler.bat43
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pod2html.bat160
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pod2latex.bat398
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pod2man549
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pod2man.bat565
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pod2text273
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pod2text.bat289
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pod2usage.bat157
-rwxr-xr-xMaster/tlpkg/tlperl/bin/podchecker.bat161
-rwxr-xr-xMaster/tlpkg/tlperl/bin/podselect.bat120
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ppd2par167
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ppd2par.bat183
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ppm.bat1066
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ppm.pl1050
-rwxr-xr-xMaster/tlpkg/tlperl/bin/prove338
-rwxr-xr-xMaster/tlpkg/tlperl/bin/prove.bat354
-rwxr-xr-xMaster/tlpkg/tlperl/bin/psed.bat2018
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pstruct.bat1383
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ptar114
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ptar.bat130
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ptardiff112
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ptardiff.bat128
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ptked368
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ptked.bat384
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ptksh730
-rwxr-xr-xMaster/tlpkg/tlperl/bin/ptksh.bat746
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pwhich141
-rwxr-xr-xMaster/tlpkg/tlperl/bin/pwhich.bat157
-rwxr-xr-xMaster/tlpkg/tlperl/bin/runperl.bat83
-rwxr-xr-xMaster/tlpkg/tlperl/bin/s2p.bat2018
-rwxr-xr-xMaster/tlpkg/tlperl/bin/search.bat1887
-rwxr-xr-xMaster/tlpkg/tlperl/bin/shasum268
-rwxr-xr-xMaster/tlpkg/tlperl/bin/shasum.bat284
-rwxr-xr-xMaster/tlpkg/tlperl/bin/splain.bat665
-rwxr-xr-xMaster/tlpkg/tlperl/bin/tkjpeg67
-rwxr-xr-xMaster/tlpkg/tlperl/bin/tkjpeg.bat83
-rwxr-xr-xMaster/tlpkg/tlperl/bin/widget608
-rwxr-xr-xMaster/tlpkg/tlperl/bin/widget.bat624
-rwxr-xr-xMaster/tlpkg/tlperl/bin/wperl.exebin9216 -> 0 bytes
-rwxr-xr-xMaster/tlpkg/tlperl/bin/xsubpp.bat175
-rwxr-xr-xMaster/tlpkg/tlperl/bin/zlib1.dllbin59904 -> 0 bytes
123 files changed, 0 insertions, 45769 deletions
diff --git a/Master/tlpkg/tlperl/bin/a2p.exe b/Master/tlpkg/tlperl/bin/a2p.exe
deleted file mode 100755
index b18a77b4a08..00000000000
--- a/Master/tlpkg/tlperl/bin/a2p.exe
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/tlperl/bin/bdf2gdfont.bat b/Master/tlpkg/tlperl/bin/bdf2gdfont.bat
deleted file mode 100755
index c87b4618745..00000000000
--- a/Master/tlpkg/tlperl/bin/bdf2gdfont.bat
+++ /dev/null
@@ -1,205 +0,0 @@
-@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
deleted file mode 100755
index e807b81137b..00000000000
--- a/Master/tlpkg/tlperl/bin/bdf2gdfont.pl
+++ /dev/null
@@ -1,189 +0,0 @@
-#!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
deleted file mode 100755
index 84937d17f3c..00000000000
--- a/Master/tlpkg/tlperl/bin/c2ph.bat
+++ /dev/null
@@ -1,1383 +0,0 @@
-@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
deleted file mode 100755
index 532fe2406b0..00000000000
--- a/Master/tlpkg/tlperl/bin/config_data
+++ /dev/null
@@ -1,249 +0,0 @@
-#!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
deleted file mode 100755
index 19604694e39..00000000000
--- a/Master/tlpkg/tlperl/bin/config_data.bat
+++ /dev/null
@@ -1,265 +0,0 @@
-@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
deleted file mode 100755
index b59aef34776..00000000000
--- a/Master/tlpkg/tlperl/bin/corelist
+++ /dev/null
@@ -1,272 +0,0 @@
-#!/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
deleted file mode 100755
index f0cc991ff10..00000000000
--- a/Master/tlpkg/tlperl/bin/corelist.bat
+++ /dev/null
@@ -1,288 +0,0 @@
-@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
deleted file mode 100755
index 5e5609555f6..00000000000
--- a/Master/tlpkg/tlperl/bin/cpan
+++ /dev/null
@@ -1,229 +0,0 @@
-#!/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
deleted file mode 100755
index b96d7678fd2..00000000000
--- a/Master/tlpkg/tlperl/bin/cpan.bat
+++ /dev/null
@@ -1,245 +0,0 @@
-@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
deleted file mode 100755
index 5ba4556c529..00000000000
--- a/Master/tlpkg/tlperl/bin/cpan2dist
+++ /dev/null
@@ -1,671 +0,0 @@
-#!/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
deleted file mode 100755
index aa670d75d28..00000000000
--- a/Master/tlpkg/tlperl/bin/cpan2dist.bat
+++ /dev/null
@@ -1,687 +0,0 @@
-@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
deleted file mode 100755
index 46c07b939a1..00000000000
--- a/Master/tlpkg/tlperl/bin/cpandb
+++ /dev/null
@@ -1,272 +0,0 @@
-#!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
deleted file mode 100755
index 0eeeb422909..00000000000
--- a/Master/tlpkg/tlperl/bin/cpandb.bat
+++ /dev/null
@@ -1,288 +0,0 @@
-@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
deleted file mode 100755
index 12679fb1737..00000000000
--- a/Master/tlpkg/tlperl/bin/cpaninject
+++ /dev/null
@@ -1,137 +0,0 @@
-#!/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
deleted file mode 100755
index ddbeeff5dd2..00000000000
--- a/Master/tlpkg/tlperl/bin/cpaninject.bat
+++ /dev/null
@@ -1,153 +0,0 @@
-@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
deleted file mode 100755
index a493322cc29..00000000000
--- a/Master/tlpkg/tlperl/bin/cpanp
+++ /dev/null
@@ -1,104 +0,0 @@
-#!/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
deleted file mode 100755
index 34e62bddd04..00000000000
--- a/Master/tlpkg/tlperl/bin/cpanp-run-perl
+++ /dev/null
@@ -1,10 +0,0 @@
-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
deleted file mode 100755
index b00cb8b2282..00000000000
--- a/Master/tlpkg/tlperl/bin/cpanp-run-perl.bat
+++ /dev/null
@@ -1,27 +0,0 @@
-@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
deleted file mode 100755
index af12a334b3e..00000000000
--- a/Master/tlpkg/tlperl/bin/cpanp.bat
+++ /dev/null
@@ -1,120 +0,0 @@
-@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
deleted file mode 100755
index 64fb87ed8f2..00000000000
--- a/Master/tlpkg/tlperl/bin/cpansign
+++ /dev/null
@@ -1,95 +0,0 @@
-#!/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
deleted file mode 100755
index 512befb81d8..00000000000
--- a/Master/tlpkg/tlperl/bin/cpansign.bat
+++ /dev/null
@@ -1,111 +0,0 @@
-@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
deleted file mode 100755
index aa7da02a8ad..00000000000
--- a/Master/tlpkg/tlperl/bin/crc32
+++ /dev/null
@@ -1,31 +0,0 @@
-#!/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
deleted file mode 100755
index 623a893a786..00000000000
--- a/Master/tlpkg/tlperl/bin/crc32.bat
+++ /dev/null
@@ -1,47 +0,0 @@
-@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
deleted file mode 100755
index 36623718308..00000000000
--- a/Master/tlpkg/tlperl/bin/dbilogstrip
+++ /dev/null
@@ -1,50 +0,0 @@
-#!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
deleted file mode 100755
index f5f852aaee6..00000000000
--- a/Master/tlpkg/tlperl/bin/dbilogstrip.bat
+++ /dev/null
@@ -1,66 +0,0 @@
-@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
deleted file mode 100755
index af238db7e7a..00000000000
--- a/Master/tlpkg/tlperl/bin/dbiprof
+++ /dev/null
@@ -1,263 +0,0 @@
-#!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
deleted file mode 100755
index 7dc86ee2ab0..00000000000
--- a/Master/tlpkg/tlperl/bin/dbiprof.bat
+++ /dev/null
@@ -1,279 +0,0 @@
-@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
deleted file mode 100755
index 0ce06af6065..00000000000
--- a/Master/tlpkg/tlperl/bin/dbiproxy
+++ /dev/null
@@ -1,184 +0,0 @@
-#!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
deleted file mode 100755
index 1199ebbfa92..00000000000
--- a/Master/tlpkg/tlperl/bin/dbiproxy.bat
+++ /dev/null
@@ -1,200 +0,0 @@
-@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
deleted file mode 100755
index ee8f9e3be95..00000000000
--- a/Master/tlpkg/tlperl/bin/dprofpp.bat
+++ /dev/null
@@ -1,945 +0,0 @@
-@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
deleted file mode 100755
index 773c0a09fba..00000000000
--- a/Master/tlpkg/tlperl/bin/enc2xs
+++ /dev/null
@@ -1,1407 +0,0 @@
-#!./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
deleted file mode 100755
index dfed5e1ec34..00000000000
--- a/Master/tlpkg/tlperl/bin/enc2xs.bat
+++ /dev/null
@@ -1,1423 +0,0 @@
-@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
deleted file mode 100755
index 5c3ab156379..00000000000
--- a/Master/tlpkg/tlperl/bin/exe_update.bat
+++ /dev/null
@@ -1,114 +0,0 @@
-@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
deleted file mode 100755
index dc43251ebff..00000000000
--- a/Master/tlpkg/tlperl/bin/exe_update.pl
+++ /dev/null
@@ -1,98 +0,0 @@
-#!/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
deleted file mode 100755
index 90e84330756..00000000000
--- a/Master/tlpkg/tlperl/bin/exetype.bat
+++ /dev/null
@@ -1,124 +0,0 @@
-@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
deleted file mode 100755
index 208ed40e9e7..00000000000
--- a/Master/tlpkg/tlperl/bin/find2perl.bat
+++ /dev/null
@@ -1,895 +0,0 @@
-@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
deleted file mode 100755
index 6aa37d64f1c..00000000000
--- a/Master/tlpkg/tlperl/bin/findrule
+++ /dev/null
@@ -1,138 +0,0 @@
-#!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
deleted file mode 100755
index 82bfb986fba..00000000000
--- a/Master/tlpkg/tlperl/bin/findrule.bat
+++ /dev/null
@@ -1,154 +0,0 @@
-@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
deleted file mode 100755
index c42bbb6fdd6..00000000000
--- a/Master/tlpkg/tlperl/bin/gedi
+++ /dev/null
@@ -1,315 +0,0 @@
-#!/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
deleted file mode 100755
index bf0a7d28ebf..00000000000
--- a/Master/tlpkg/tlperl/bin/gedi.bat
+++ /dev/null
@@ -1,331 +0,0 @@
-@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
deleted file mode 100755
index eb1f7862961..00000000000
--- a/Master/tlpkg/tlperl/bin/h2ph.bat
+++ /dev/null
@@ -1,959 +0,0 @@
-@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
deleted file mode 100755
index 136eeea2fad..00000000000
--- a/Master/tlpkg/tlperl/bin/h2xs.bat
+++ /dev/null
@@ -1,2203 +0,0 @@
-@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
deleted file mode 100755
index 5874aa61c7a..00000000000
--- a/Master/tlpkg/tlperl/bin/instmodsh
+++ /dev/null
@@ -1,192 +0,0 @@
-#!/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
deleted file mode 100755
index c72c0f22199..00000000000
--- a/Master/tlpkg/tlperl/bin/instmodsh.bat
+++ /dev/null
@@ -1,208 +0,0 @@
-@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
deleted file mode 100755
index 8509f64cf9e..00000000000
--- a/Master/tlpkg/tlperl/bin/json_xs
+++ /dev/null
@@ -1,179 +0,0 @@
-#!/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
deleted file mode 100755
index 306e47e0650..00000000000
--- a/Master/tlpkg/tlperl/bin/json_xs.bat
+++ /dev/null
@@ -1,195 +0,0 @@
-@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
deleted file mode 100755
index 498bfbe9462..00000000000
--- a/Master/tlpkg/tlperl/bin/largeprimes
+++ /dev/null
@@ -1,68 +0,0 @@
-#!/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
deleted file mode 100755
index 81b48044af1..00000000000
--- a/Master/tlpkg/tlperl/bin/largeprimes.bat
+++ /dev/null
@@ -1,84 +0,0 @@
-@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
deleted file mode 100755
index aacd5fe7490..00000000000
--- a/Master/tlpkg/tlperl/bin/libnetcfg.bat
+++ /dev/null
@@ -1,737 +0,0 @@
-@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
deleted file mode 100755
index 649ec648979..00000000000
--- a/Master/tlpkg/tlperl/bin/libpng3.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/tlperl/bin/lwp-download b/Master/tlpkg/tlperl/bin/lwp-download
deleted file mode 100755
index a85ac551d9f..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-download
+++ /dev/null
@@ -1,320 +0,0 @@
-#!/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
deleted file mode 100755
index ec045baf4e9..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-download.bat
+++ /dev/null
@@ -1,336 +0,0 @@
-@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
deleted file mode 100755
index 1805eb56138..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-dump
+++ /dev/null
@@ -1,107 +0,0 @@
-#!/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
deleted file mode 100755
index fcd6ac64baf..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-dump.bat
+++ /dev/null
@@ -1,123 +0,0 @@
-@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
deleted file mode 100755
index 13da7971242..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-mirror
+++ /dev/null
@@ -1,103 +0,0 @@
-#!/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
deleted file mode 100755
index 87beb3aa103..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-mirror.bat
+++ /dev/null
@@ -1,119 +0,0 @@
-@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
deleted file mode 100755
index ee9dbf88ea7..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-request
+++ /dev/null
@@ -1,531 +0,0 @@
-#!/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
deleted file mode 100755
index 0b447c29fd0..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-request.bat
+++ /dev/null
@@ -1,547 +0,0 @@
-@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
deleted file mode 100755
index 2ac798f4bb0..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-rget
+++ /dev/null
@@ -1,607 +0,0 @@
-#!/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
deleted file mode 100755
index 34b097d1f2c..00000000000
--- a/Master/tlpkg/tlperl/bin/lwp-rget.bat
+++ /dev/null
@@ -1,623 +0,0 @@
-@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
deleted file mode 100755
index 29b21c6608c..00000000000
--- a/Master/tlpkg/tlperl/bin/makerandom
+++ /dev/null
@@ -1,50 +0,0 @@
-#!/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
deleted file mode 100755
index 672a5dd6812..00000000000
--- a/Master/tlpkg/tlperl/bin/makerandom.bat
+++ /dev/null
@@ -1,66 +0,0 @@
-@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
deleted file mode 100755
index ea4c6385a66..00000000000
--- a/Master/tlpkg/tlperl/bin/parinstallppd
+++ /dev/null
@@ -1,124 +0,0 @@
-#!/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
deleted file mode 100755
index 1a7478353b7..00000000000
--- a/Master/tlpkg/tlperl/bin/parinstallppd.bat
+++ /dev/null
@@ -1,140 +0,0 @@
-@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
deleted file mode 100755
index e66a18bb962..00000000000
--- a/Master/tlpkg/tlperl/bin/perl.exe
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/tlperl/bin/perl5.10.1.exe b/Master/tlpkg/tlperl/bin/perl5.10.1.exe
deleted file mode 100755
index e66a18bb962..00000000000
--- a/Master/tlpkg/tlperl/bin/perl5.10.1.exe
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/tlperl/bin/perl510.dll b/Master/tlpkg/tlperl/bin/perl510.dll
deleted file mode 100755
index 4a533b76803..00000000000
--- a/Master/tlpkg/tlperl/bin/perl510.dll
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/tlperl/bin/perlbug.bat b/Master/tlpkg/tlperl/bin/perlbug.bat
deleted file mode 100755
index 2d37b78d2ba..00000000000
--- a/Master/tlpkg/tlperl/bin/perlbug.bat
+++ /dev/null
@@ -1,1478 +0,0 @@
-@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
deleted file mode 100755
index 48f9b79ba42..00000000000
--- a/Master/tlpkg/tlperl/bin/perldoc
+++ /dev/null
@@ -1,7 +0,0 @@
-#!/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
deleted file mode 100755
index a6fc80ed1da..00000000000
--- a/Master/tlpkg/tlperl/bin/perldoc.bat
+++ /dev/null
@@ -1,23 +0,0 @@
-@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
deleted file mode 100755
index f4a81850873..00000000000
--- a/Master/tlpkg/tlperl/bin/perlglob.bat
+++ /dev/null
@@ -1,69 +0,0 @@
-@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
deleted file mode 100755
index ba5b1d47623..00000000000
--- a/Master/tlpkg/tlperl/bin/perlglob.exe
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/tlperl/bin/perlivp.bat b/Master/tlpkg/tlperl/bin/perlivp.bat
deleted file mode 100755
index c44e6a85615..00000000000
--- a/Master/tlpkg/tlperl/bin/perlivp.bat
+++ /dev/null
@@ -1,456 +0,0 @@
-@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
deleted file mode 100755
index 2d37b78d2ba..00000000000
--- a/Master/tlpkg/tlperl/bin/perlthanks.bat
+++ /dev/null
@@ -1,1478 +0,0 @@
-@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
deleted file mode 100755
index 9fdebd193cf..00000000000
--- a/Master/tlpkg/tlperl/bin/piconv
+++ /dev/null
@@ -1,299 +0,0 @@
-#!./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
deleted file mode 100755
index a255687f2af..00000000000
--- a/Master/tlpkg/tlperl/bin/piconv.bat
+++ /dev/null
@@ -1,315 +0,0 @@
-@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
deleted file mode 100755
index f7f5a41df7d..00000000000
--- a/Master/tlpkg/tlperl/bin/pip
+++ /dev/null
@@ -1,23 +0,0 @@
-#!/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
deleted file mode 100755
index eea5b74873c..00000000000
--- a/Master/tlpkg/tlperl/bin/pip.bat
+++ /dev/null
@@ -1,39 +0,0 @@
-@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
deleted file mode 100755
index 64887875c96..00000000000
--- a/Master/tlpkg/tlperl/bin/pl2bat.bat
+++ /dev/null
@@ -1,430 +0,0 @@
-@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
deleted file mode 100755
index ec126bdf156..00000000000
--- a/Master/tlpkg/tlperl/bin/pl2pm.bat
+++ /dev/null
@@ -1,394 +0,0 @@
-@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
deleted file mode 100755
index 01002aa034b..00000000000
--- a/Master/tlpkg/tlperl/bin/pler
+++ /dev/null
@@ -1,27 +0,0 @@
-#!/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
deleted file mode 100755
index 924a81f64fd..00000000000
--- a/Master/tlpkg/tlperl/bin/pler.bat
+++ /dev/null
@@ -1,43 +0,0 @@
-@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
deleted file mode 100755
index 75cf111f655..00000000000
--- a/Master/tlpkg/tlperl/bin/pod2html.bat
+++ /dev/null
@@ -1,160 +0,0 @@
-@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
deleted file mode 100755
index 3cc895461a4..00000000000
--- a/Master/tlpkg/tlperl/bin/pod2latex.bat
+++ /dev/null
@@ -1,398 +0,0 @@
-@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
deleted file mode 100755
index 1eff3ca275f..00000000000
--- a/Master/tlpkg/tlperl/bin/pod2man
+++ /dev/null
@@ -1,549 +0,0 @@
-#!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
deleted file mode 100755
index f2555659bc3..00000000000
--- a/Master/tlpkg/tlperl/bin/pod2man.bat
+++ /dev/null
@@ -1,565 +0,0 @@
-@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
deleted file mode 100755
index d1f230fd90d..00000000000
--- a/Master/tlpkg/tlperl/bin/pod2text
+++ /dev/null
@@ -1,273 +0,0 @@
-#!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
deleted file mode 100755
index 2ef787155af..00000000000
--- a/Master/tlpkg/tlperl/bin/pod2text.bat
+++ /dev/null
@@ -1,289 +0,0 @@
-@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
deleted file mode 100755
index 94d50856f08..00000000000
--- a/Master/tlpkg/tlperl/bin/pod2usage.bat
+++ /dev/null
@@ -1,157 +0,0 @@
-@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
deleted file mode 100755
index 4763503eca9..00000000000
--- a/Master/tlpkg/tlperl/bin/podchecker.bat
+++ /dev/null
@@ -1,161 +0,0 @@
-@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
deleted file mode 100755
index d9d05ec85c8..00000000000
--- a/Master/tlpkg/tlperl/bin/podselect.bat
+++ /dev/null
@@ -1,120 +0,0 @@
-@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
deleted file mode 100755
index 64bcb5dc3c7..00000000000
--- a/Master/tlpkg/tlperl/bin/ppd2par
+++ /dev/null
@@ -1,167 +0,0 @@
-#!/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
deleted file mode 100755
index eecd3c79243..00000000000
--- a/Master/tlpkg/tlperl/bin/ppd2par.bat
+++ /dev/null
@@ -1,183 +0,0 @@
-@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
deleted file mode 100755
index a02cf726d6c..00000000000
--- a/Master/tlpkg/tlperl/bin/ppm.bat
+++ /dev/null
@@ -1,1066 +0,0 @@
-@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
deleted file mode 100755
index 9773e9470c1..00000000000
--- a/Master/tlpkg/tlperl/bin/ppm.pl
+++ /dev/null
@@ -1,1050 +0,0 @@
-#!/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
deleted file mode 100755
index bb419ed2db7..00000000000
--- a/Master/tlpkg/tlperl/bin/prove
+++ /dev/null
@@ -1,338 +0,0 @@
-#!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
deleted file mode 100755
index ef4ca66182b..00000000000
--- a/Master/tlpkg/tlperl/bin/prove.bat
+++ /dev/null
@@ -1,354 +0,0 @@
-@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
deleted file mode 100755
index aaf9845505b..00000000000
--- a/Master/tlpkg/tlperl/bin/psed.bat
+++ /dev/null
@@ -1,2018 +0,0 @@
-@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
deleted file mode 100755
index 84937d17f3c..00000000000
--- a/Master/tlpkg/tlperl/bin/pstruct.bat
+++ /dev/null
@@ -1,1383 +0,0 @@
-@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
deleted file mode 100755
index 6a3c1bcd2ec..00000000000
--- a/Master/tlpkg/tlperl/bin/ptar
+++ /dev/null
@@ -1,114 +0,0 @@
-#!/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
deleted file mode 100755
index 6c439e086dc..00000000000
--- a/Master/tlpkg/tlperl/bin/ptar.bat
+++ /dev/null
@@ -1,130 +0,0 @@
-@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
deleted file mode 100755
index 21e7d6cce59..00000000000
--- a/Master/tlpkg/tlperl/bin/ptardiff
+++ /dev/null
@@ -1,112 +0,0 @@
-#!/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
deleted file mode 100755
index 85ac7896610..00000000000
--- a/Master/tlpkg/tlperl/bin/ptardiff.bat
+++ /dev/null
@@ -1,128 +0,0 @@
-@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
deleted file mode 100755
index e0c537d96f4..00000000000
--- a/Master/tlpkg/tlperl/bin/ptked
+++ /dev/null
@@ -1,368 +0,0 @@
-#!/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
deleted file mode 100755
index 390178b1916..00000000000
--- a/Master/tlpkg/tlperl/bin/ptked.bat
+++ /dev/null
@@ -1,384 +0,0 @@
-@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
deleted file mode 100755
index a606f0b6a8f..00000000000
--- a/Master/tlpkg/tlperl/bin/ptksh
+++ /dev/null
@@ -1,730 +0,0 @@
-#!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
deleted file mode 100755
index ff42a69076f..00000000000
--- a/Master/tlpkg/tlperl/bin/ptksh.bat
+++ /dev/null
@@ -1,746 +0,0 @@
-@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
deleted file mode 100755
index a20dc07fff0..00000000000
--- a/Master/tlpkg/tlperl/bin/pwhich
+++ /dev/null
@@ -1,141 +0,0 @@
-#!/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
deleted file mode 100755
index 191949207d3..00000000000
--- a/Master/tlpkg/tlperl/bin/pwhich.bat
+++ /dev/null
@@ -1,157 +0,0 @@
-@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
deleted file mode 100755
index 8e8eb1ea948..00000000000
--- a/Master/tlpkg/tlperl/bin/runperl.bat
+++ /dev/null
@@ -1,83 +0,0 @@
-@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
deleted file mode 100755
index aaf9845505b..00000000000
--- a/Master/tlpkg/tlperl/bin/s2p.bat
+++ /dev/null
@@ -1,2018 +0,0 @@
-@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
deleted file mode 100755
index 963cb269213..00000000000
--- a/Master/tlpkg/tlperl/bin/search.bat
+++ /dev/null
@@ -1,1887 +0,0 @@
-@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
deleted file mode 100755
index 3c0185892fa..00000000000
--- a/Master/tlpkg/tlperl/bin/shasum
+++ /dev/null
@@ -1,268 +0,0 @@
-#!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
deleted file mode 100755
index 79baeebc5b9..00000000000
--- a/Master/tlpkg/tlperl/bin/shasum.bat
+++ /dev/null
@@ -1,284 +0,0 @@
-@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
deleted file mode 100755
index 389ef1879a8..00000000000
--- a/Master/tlpkg/tlperl/bin/splain.bat
+++ /dev/null
@@ -1,665 +0,0 @@
-@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
deleted file mode 100755
index b2b5619726c..00000000000
--- a/Master/tlpkg/tlperl/bin/tkjpeg
+++ /dev/null
@@ -1,67 +0,0 @@
-#!/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
deleted file mode 100755
index a09abd6075a..00000000000
--- a/Master/tlpkg/tlperl/bin/tkjpeg.bat
+++ /dev/null
@@ -1,83 +0,0 @@
-@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
deleted file mode 100755
index 05af2dcd320..00000000000
--- a/Master/tlpkg/tlperl/bin/widget
+++ /dev/null
@@ -1,608 +0,0 @@
-#!/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
deleted file mode 100755
index ab5b6283bbc..00000000000
--- a/Master/tlpkg/tlperl/bin/widget.bat
+++ /dev/null
@@ -1,624 +0,0 @@
-@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
deleted file mode 100755
index bd2c649bdc2..00000000000
--- a/Master/tlpkg/tlperl/bin/wperl.exe
+++ /dev/null
Binary files differ
diff --git a/Master/tlpkg/tlperl/bin/xsubpp.bat b/Master/tlpkg/tlperl/bin/xsubpp.bat
deleted file mode 100755
index 672a905c9e8..00000000000
--- a/Master/tlpkg/tlperl/bin/xsubpp.bat
+++ /dev/null
@@ -1,175 +0,0 @@
-@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
deleted file mode 100755
index 1cf8a476e5a..00000000000
--- a/Master/tlpkg/tlperl/bin/zlib1.dll
+++ /dev/null
Binary files differ