From 316ee97c621496b0fe3267f57cce81bee44ca1e6 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Thu, 17 Feb 2011 12:20:49 +0000 Subject: Moving old tlperl prior to committing new one git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/bin/a2p.exe | Bin 104448 -> 0 bytes Master/tlpkg/tlperl/bin/bdf2gdfont.bat | 205 --- Master/tlpkg/tlperl/bin/bdf2gdfont.pl | 189 --- Master/tlpkg/tlperl/bin/c2ph.bat | 1383 ----------------- Master/tlpkg/tlperl/bin/config_data | 249 ---- Master/tlpkg/tlperl/bin/config_data.bat | 265 ---- Master/tlpkg/tlperl/bin/corelist | 272 ---- Master/tlpkg/tlperl/bin/corelist.bat | 288 ---- Master/tlpkg/tlperl/bin/cpan | 229 --- Master/tlpkg/tlperl/bin/cpan.bat | 245 ---- Master/tlpkg/tlperl/bin/cpan2dist | 671 --------- Master/tlpkg/tlperl/bin/cpan2dist.bat | 687 --------- Master/tlpkg/tlperl/bin/cpandb | 272 ---- Master/tlpkg/tlperl/bin/cpandb.bat | 288 ---- Master/tlpkg/tlperl/bin/cpaninject | 137 -- Master/tlpkg/tlperl/bin/cpaninject.bat | 153 -- Master/tlpkg/tlperl/bin/cpanp | 104 -- Master/tlpkg/tlperl/bin/cpanp-run-perl | 10 - Master/tlpkg/tlperl/bin/cpanp-run-perl.bat | 27 - Master/tlpkg/tlperl/bin/cpanp.bat | 120 -- Master/tlpkg/tlperl/bin/cpansign | 95 -- Master/tlpkg/tlperl/bin/cpansign.bat | 111 -- Master/tlpkg/tlperl/bin/crc32 | 31 - Master/tlpkg/tlperl/bin/crc32.bat | 47 - Master/tlpkg/tlperl/bin/dbilogstrip | 50 - Master/tlpkg/tlperl/bin/dbilogstrip.bat | 66 - Master/tlpkg/tlperl/bin/dbiprof | 263 ---- Master/tlpkg/tlperl/bin/dbiprof.bat | 279 ---- Master/tlpkg/tlperl/bin/dbiproxy | 184 --- Master/tlpkg/tlperl/bin/dbiproxy.bat | 200 --- Master/tlpkg/tlperl/bin/dprofpp.bat | 945 ------------ Master/tlpkg/tlperl/bin/enc2xs | 1407 ------------------ Master/tlpkg/tlperl/bin/enc2xs.bat | 1423 ------------------ Master/tlpkg/tlperl/bin/exe_update.bat | 114 -- Master/tlpkg/tlperl/bin/exe_update.pl | 98 -- Master/tlpkg/tlperl/bin/exetype.bat | 124 -- Master/tlpkg/tlperl/bin/find2perl.bat | 895 ----------- Master/tlpkg/tlperl/bin/findrule | 138 -- Master/tlpkg/tlperl/bin/findrule.bat | 154 -- Master/tlpkg/tlperl/bin/gedi | 315 ---- Master/tlpkg/tlperl/bin/gedi.bat | 331 ----- Master/tlpkg/tlperl/bin/h2ph.bat | 959 ------------ Master/tlpkg/tlperl/bin/h2xs.bat | 2203 ---------------------------- Master/tlpkg/tlperl/bin/instmodsh | 192 --- Master/tlpkg/tlperl/bin/instmodsh.bat | 208 --- Master/tlpkg/tlperl/bin/json_xs | 179 --- Master/tlpkg/tlperl/bin/json_xs.bat | 195 --- Master/tlpkg/tlperl/bin/largeprimes | 68 - Master/tlpkg/tlperl/bin/largeprimes.bat | 84 -- Master/tlpkg/tlperl/bin/libnetcfg.bat | 737 ---------- Master/tlpkg/tlperl/bin/libpng3.dll | Bin 260096 -> 0 bytes Master/tlpkg/tlperl/bin/lwp-download | 320 ---- Master/tlpkg/tlperl/bin/lwp-download.bat | 336 ----- Master/tlpkg/tlperl/bin/lwp-dump | 107 -- Master/tlpkg/tlperl/bin/lwp-dump.bat | 123 -- Master/tlpkg/tlperl/bin/lwp-mirror | 103 -- Master/tlpkg/tlperl/bin/lwp-mirror.bat | 119 -- Master/tlpkg/tlperl/bin/lwp-request | 531 ------- Master/tlpkg/tlperl/bin/lwp-request.bat | 547 ------- Master/tlpkg/tlperl/bin/lwp-rget | 607 -------- Master/tlpkg/tlperl/bin/lwp-rget.bat | 623 -------- Master/tlpkg/tlperl/bin/makerandom | 50 - Master/tlpkg/tlperl/bin/makerandom.bat | 66 - Master/tlpkg/tlperl/bin/parinstallppd | 124 -- Master/tlpkg/tlperl/bin/parinstallppd.bat | 140 -- Master/tlpkg/tlperl/bin/perl.exe | Bin 9216 -> 0 bytes Master/tlpkg/tlperl/bin/perl5.10.1.exe | Bin 9216 -> 0 bytes Master/tlpkg/tlperl/bin/perl510.dll | Bin 1324032 -> 0 bytes Master/tlpkg/tlperl/bin/perlbug.bat | 1478 ------------------- Master/tlpkg/tlperl/bin/perldoc | 7 - Master/tlpkg/tlperl/bin/perldoc.bat | 23 - Master/tlpkg/tlperl/bin/perlglob.bat | 69 - Master/tlpkg/tlperl/bin/perlglob.exe | Bin 6144 -> 0 bytes Master/tlpkg/tlperl/bin/perlivp.bat | 456 ------ Master/tlpkg/tlperl/bin/perlthanks.bat | 1478 ------------------- Master/tlpkg/tlperl/bin/piconv | 299 ---- Master/tlpkg/tlperl/bin/piconv.bat | 315 ---- Master/tlpkg/tlperl/bin/pip | 23 - Master/tlpkg/tlperl/bin/pip.bat | 39 - Master/tlpkg/tlperl/bin/pl2bat.bat | 430 ------ Master/tlpkg/tlperl/bin/pl2pm.bat | 394 ----- Master/tlpkg/tlperl/bin/pler | 27 - Master/tlpkg/tlperl/bin/pler.bat | 43 - Master/tlpkg/tlperl/bin/pod2html.bat | 160 -- Master/tlpkg/tlperl/bin/pod2latex.bat | 398 ----- Master/tlpkg/tlperl/bin/pod2man | 549 ------- Master/tlpkg/tlperl/bin/pod2man.bat | 565 ------- Master/tlpkg/tlperl/bin/pod2text | 273 ---- Master/tlpkg/tlperl/bin/pod2text.bat | 289 ---- Master/tlpkg/tlperl/bin/pod2usage.bat | 157 -- Master/tlpkg/tlperl/bin/podchecker.bat | 161 -- Master/tlpkg/tlperl/bin/podselect.bat | 120 -- Master/tlpkg/tlperl/bin/ppd2par | 167 --- Master/tlpkg/tlperl/bin/ppd2par.bat | 183 --- Master/tlpkg/tlperl/bin/ppm.bat | 1066 -------------- Master/tlpkg/tlperl/bin/ppm.pl | 1050 ------------- Master/tlpkg/tlperl/bin/prove | 338 ----- Master/tlpkg/tlperl/bin/prove.bat | 354 ----- Master/tlpkg/tlperl/bin/psed.bat | 2018 ------------------------- Master/tlpkg/tlperl/bin/pstruct.bat | 1383 ----------------- Master/tlpkg/tlperl/bin/ptar | 114 -- Master/tlpkg/tlperl/bin/ptar.bat | 130 -- Master/tlpkg/tlperl/bin/ptardiff | 112 -- Master/tlpkg/tlperl/bin/ptardiff.bat | 128 -- Master/tlpkg/tlperl/bin/ptked | 368 ----- Master/tlpkg/tlperl/bin/ptked.bat | 384 ----- Master/tlpkg/tlperl/bin/ptksh | 730 --------- Master/tlpkg/tlperl/bin/ptksh.bat | 746 ---------- Master/tlpkg/tlperl/bin/pwhich | 141 -- Master/tlpkg/tlperl/bin/pwhich.bat | 157 -- Master/tlpkg/tlperl/bin/runperl.bat | 83 -- Master/tlpkg/tlperl/bin/s2p.bat | 2018 ------------------------- Master/tlpkg/tlperl/bin/search.bat | 1887 ------------------------ Master/tlpkg/tlperl/bin/shasum | 268 ---- Master/tlpkg/tlperl/bin/shasum.bat | 284 ---- Master/tlpkg/tlperl/bin/splain.bat | 665 --------- Master/tlpkg/tlperl/bin/tkjpeg | 67 - Master/tlpkg/tlperl/bin/tkjpeg.bat | 83 -- Master/tlpkg/tlperl/bin/widget | 608 -------- Master/tlpkg/tlperl/bin/widget.bat | 624 -------- Master/tlpkg/tlperl/bin/wperl.exe | Bin 9216 -> 0 bytes Master/tlpkg/tlperl/bin/xsubpp.bat | 175 --- Master/tlpkg/tlperl/bin/zlib1.dll | Bin 59904 -> 0 bytes 123 files changed, 45769 deletions(-) delete mode 100755 Master/tlpkg/tlperl/bin/a2p.exe delete mode 100755 Master/tlpkg/tlperl/bin/bdf2gdfont.bat delete mode 100755 Master/tlpkg/tlperl/bin/bdf2gdfont.pl delete mode 100755 Master/tlpkg/tlperl/bin/c2ph.bat delete mode 100755 Master/tlpkg/tlperl/bin/config_data delete mode 100755 Master/tlpkg/tlperl/bin/config_data.bat delete mode 100755 Master/tlpkg/tlperl/bin/corelist delete mode 100755 Master/tlpkg/tlperl/bin/corelist.bat delete mode 100755 Master/tlpkg/tlperl/bin/cpan delete mode 100755 Master/tlpkg/tlperl/bin/cpan.bat delete mode 100755 Master/tlpkg/tlperl/bin/cpan2dist delete mode 100755 Master/tlpkg/tlperl/bin/cpan2dist.bat delete mode 100755 Master/tlpkg/tlperl/bin/cpandb delete mode 100755 Master/tlpkg/tlperl/bin/cpandb.bat delete mode 100755 Master/tlpkg/tlperl/bin/cpaninject delete mode 100755 Master/tlpkg/tlperl/bin/cpaninject.bat delete mode 100755 Master/tlpkg/tlperl/bin/cpanp delete mode 100755 Master/tlpkg/tlperl/bin/cpanp-run-perl delete mode 100755 Master/tlpkg/tlperl/bin/cpanp-run-perl.bat delete mode 100755 Master/tlpkg/tlperl/bin/cpanp.bat delete mode 100755 Master/tlpkg/tlperl/bin/cpansign delete mode 100755 Master/tlpkg/tlperl/bin/cpansign.bat delete mode 100755 Master/tlpkg/tlperl/bin/crc32 delete mode 100755 Master/tlpkg/tlperl/bin/crc32.bat delete mode 100755 Master/tlpkg/tlperl/bin/dbilogstrip delete mode 100755 Master/tlpkg/tlperl/bin/dbilogstrip.bat delete mode 100755 Master/tlpkg/tlperl/bin/dbiprof delete mode 100755 Master/tlpkg/tlperl/bin/dbiprof.bat delete mode 100755 Master/tlpkg/tlperl/bin/dbiproxy delete mode 100755 Master/tlpkg/tlperl/bin/dbiproxy.bat delete mode 100755 Master/tlpkg/tlperl/bin/dprofpp.bat delete mode 100755 Master/tlpkg/tlperl/bin/enc2xs delete mode 100755 Master/tlpkg/tlperl/bin/enc2xs.bat delete mode 100755 Master/tlpkg/tlperl/bin/exe_update.bat delete mode 100755 Master/tlpkg/tlperl/bin/exe_update.pl delete mode 100755 Master/tlpkg/tlperl/bin/exetype.bat delete mode 100755 Master/tlpkg/tlperl/bin/find2perl.bat delete mode 100755 Master/tlpkg/tlperl/bin/findrule delete mode 100755 Master/tlpkg/tlperl/bin/findrule.bat delete mode 100755 Master/tlpkg/tlperl/bin/gedi delete mode 100755 Master/tlpkg/tlperl/bin/gedi.bat delete mode 100755 Master/tlpkg/tlperl/bin/h2ph.bat delete mode 100755 Master/tlpkg/tlperl/bin/h2xs.bat delete mode 100755 Master/tlpkg/tlperl/bin/instmodsh delete mode 100755 Master/tlpkg/tlperl/bin/instmodsh.bat delete mode 100755 Master/tlpkg/tlperl/bin/json_xs delete mode 100755 Master/tlpkg/tlperl/bin/json_xs.bat delete mode 100755 Master/tlpkg/tlperl/bin/largeprimes delete mode 100755 Master/tlpkg/tlperl/bin/largeprimes.bat delete mode 100755 Master/tlpkg/tlperl/bin/libnetcfg.bat delete mode 100755 Master/tlpkg/tlperl/bin/libpng3.dll delete mode 100755 Master/tlpkg/tlperl/bin/lwp-download delete mode 100755 Master/tlpkg/tlperl/bin/lwp-download.bat delete mode 100755 Master/tlpkg/tlperl/bin/lwp-dump delete mode 100755 Master/tlpkg/tlperl/bin/lwp-dump.bat delete mode 100755 Master/tlpkg/tlperl/bin/lwp-mirror delete mode 100755 Master/tlpkg/tlperl/bin/lwp-mirror.bat delete mode 100755 Master/tlpkg/tlperl/bin/lwp-request delete mode 100755 Master/tlpkg/tlperl/bin/lwp-request.bat delete mode 100755 Master/tlpkg/tlperl/bin/lwp-rget delete mode 100755 Master/tlpkg/tlperl/bin/lwp-rget.bat delete mode 100755 Master/tlpkg/tlperl/bin/makerandom delete mode 100755 Master/tlpkg/tlperl/bin/makerandom.bat delete mode 100755 Master/tlpkg/tlperl/bin/parinstallppd delete mode 100755 Master/tlpkg/tlperl/bin/parinstallppd.bat delete mode 100755 Master/tlpkg/tlperl/bin/perl.exe delete mode 100755 Master/tlpkg/tlperl/bin/perl5.10.1.exe delete mode 100755 Master/tlpkg/tlperl/bin/perl510.dll delete mode 100755 Master/tlpkg/tlperl/bin/perlbug.bat delete mode 100755 Master/tlpkg/tlperl/bin/perldoc delete mode 100755 Master/tlpkg/tlperl/bin/perldoc.bat delete mode 100755 Master/tlpkg/tlperl/bin/perlglob.bat delete mode 100755 Master/tlpkg/tlperl/bin/perlglob.exe delete mode 100755 Master/tlpkg/tlperl/bin/perlivp.bat delete mode 100755 Master/tlpkg/tlperl/bin/perlthanks.bat delete mode 100755 Master/tlpkg/tlperl/bin/piconv delete mode 100755 Master/tlpkg/tlperl/bin/piconv.bat delete mode 100755 Master/tlpkg/tlperl/bin/pip delete mode 100755 Master/tlpkg/tlperl/bin/pip.bat delete mode 100755 Master/tlpkg/tlperl/bin/pl2bat.bat delete mode 100755 Master/tlpkg/tlperl/bin/pl2pm.bat delete mode 100755 Master/tlpkg/tlperl/bin/pler delete mode 100755 Master/tlpkg/tlperl/bin/pler.bat delete mode 100755 Master/tlpkg/tlperl/bin/pod2html.bat delete mode 100755 Master/tlpkg/tlperl/bin/pod2latex.bat delete mode 100755 Master/tlpkg/tlperl/bin/pod2man delete mode 100755 Master/tlpkg/tlperl/bin/pod2man.bat delete mode 100755 Master/tlpkg/tlperl/bin/pod2text delete mode 100755 Master/tlpkg/tlperl/bin/pod2text.bat delete mode 100755 Master/tlpkg/tlperl/bin/pod2usage.bat delete mode 100755 Master/tlpkg/tlperl/bin/podchecker.bat delete mode 100755 Master/tlpkg/tlperl/bin/podselect.bat delete mode 100755 Master/tlpkg/tlperl/bin/ppd2par delete mode 100755 Master/tlpkg/tlperl/bin/ppd2par.bat delete mode 100755 Master/tlpkg/tlperl/bin/ppm.bat delete mode 100755 Master/tlpkg/tlperl/bin/ppm.pl delete mode 100755 Master/tlpkg/tlperl/bin/prove delete mode 100755 Master/tlpkg/tlperl/bin/prove.bat delete mode 100755 Master/tlpkg/tlperl/bin/psed.bat delete mode 100755 Master/tlpkg/tlperl/bin/pstruct.bat delete mode 100755 Master/tlpkg/tlperl/bin/ptar delete mode 100755 Master/tlpkg/tlperl/bin/ptar.bat delete mode 100755 Master/tlpkg/tlperl/bin/ptardiff delete mode 100755 Master/tlpkg/tlperl/bin/ptardiff.bat delete mode 100755 Master/tlpkg/tlperl/bin/ptked delete mode 100755 Master/tlpkg/tlperl/bin/ptked.bat delete mode 100755 Master/tlpkg/tlperl/bin/ptksh delete mode 100755 Master/tlpkg/tlperl/bin/ptksh.bat delete mode 100755 Master/tlpkg/tlperl/bin/pwhich delete mode 100755 Master/tlpkg/tlperl/bin/pwhich.bat delete mode 100755 Master/tlpkg/tlperl/bin/runperl.bat delete mode 100755 Master/tlpkg/tlperl/bin/s2p.bat delete mode 100755 Master/tlpkg/tlperl/bin/search.bat delete mode 100755 Master/tlpkg/tlperl/bin/shasum delete mode 100755 Master/tlpkg/tlperl/bin/shasum.bat delete mode 100755 Master/tlpkg/tlperl/bin/splain.bat delete mode 100755 Master/tlpkg/tlperl/bin/tkjpeg delete mode 100755 Master/tlpkg/tlperl/bin/tkjpeg.bat delete mode 100755 Master/tlpkg/tlperl/bin/widget delete mode 100755 Master/tlpkg/tlperl/bin/widget.bat delete mode 100755 Master/tlpkg/tlperl/bin/wperl.exe delete mode 100755 Master/tlpkg/tlperl/bin/xsubpp.bat delete mode 100755 Master/tlpkg/tlperl/bin/zlib1.dll (limited to 'Master/tlpkg/tlperl/bin') diff --git a/Master/tlpkg/tlperl/bin/a2p.exe b/Master/tlpkg/tlperl/bin/a2p.exe deleted file mode 100755 index b18a77b4a08..00000000000 Binary files a/Master/tlpkg/tlperl/bin/a2p.exe and /dev/null 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 , heavily adopted from bdftogd from -# Jan Pazdziora -# -# 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 - -=head1 AUTHOR - -Lincoln Stein , heavily adapted from bdftogd from -Jan Pazdziora . - -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 , heavily adopted from bdftogd from -# Jan Pazdziora -# -# 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 - -=head1 AUTHOR - -Lincoln Stein , heavily adapted from bdftogd from -Jan Pazdziora . - -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, -# -# 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 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 - -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 /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 for further explanation: "; - ; - open (PIPE, "|". ($ENV{PAGER} || 'more')); - $SIG{PIPE} = PLUMBER; - select(PIPE); - } - - print "usage: $0 [-dpnP] [var=val] [files ...]\n"; - - exit unless $isatty; - - print < 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" : "").": "; - } - } - -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 < $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]] || ""); } - -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 () { - 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 .= " "; - /^=s%$/ and $out .= " ="; - } - - pad_line($out, 35); - $out .= "$defs{$name}{desc}\n"; - } - - $out .= < 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), Jon Swartz (C), Andy -Wardley (C), and Larry Wall (perl's own Config.pm) -have developed independently. - -The configuration system emplyed here was developed in the context of -C. Under this system, configuration information for a -module C, for example, is stored in a module called -C) (I would have called it C, 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 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 values -and C values. A C value may be any perl scalar, -including references to complex data structures. It must, however, be -serializable using C. A C 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 or C 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, 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 entry, shows its value. The value -will be displayed using C (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 to the given boolean value. Specify the value -as either 1 or 0. - -=item set_config - -Sets the given C entry to the given value. - -=item eval - -If the C<--eval> option is used, the values in C 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 .= " "; - /^=s%$/ and $out .= " ="; - } - - pad_line($out, 35); - $out .= "$defs{$name}{desc}\n"; - } - - $out .= < 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), Jon Swartz (C), Andy -Wardley (C), and Larry Wall (perl's own Config.pm) -have developed independently. - -The configuration system emplyed here was developed in the context of -C. Under this system, configuration information for a -module C, for example, is stored in a module called -C) (I would have called it C, 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 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 values -and C values. A C value may be any perl scalar, -including references to complex data structures. It must, however, be -serializable using C. A C 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 or C 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, 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 entry, shows its value. The value -will be displayed using C (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 to the given boolean value. Specify the value -as either 1 or 0. - -=item set_config - -Sets the given C entry to the given value. - -=item eval - -If the C<--eval> option is used, the values in C 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 for one. - -=head1 SYNOPSIS - - corelist -v - corelist [-a|-d] | // [] ... - corelist [-v ] [ | // ] ... - -=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 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, 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 Eperl5-porters@perl.orgE. - -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 for one. - -=head1 SYNOPSIS - - corelist -v - corelist [-a|-d] | // [] ... - corelist [-v ] [ | // ] ... - -=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 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, 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 Eperl5-porters@perl.orgE. - -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 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 -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 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<< >> - -=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 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 -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 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<< >> - -=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 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. See the C 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, L, L, -C - -=head1 BUG REPORTS - -Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. - -=head1 AUTHOR - -This module by Jos Boumans Ekane@cpan.orgE. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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 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. See the C 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, L, L, -C - -=head1 BUG REPORTS - -Please report bugs or other issues to Ebug-cpanplus@rt.cpan.org. - -=head1 AUTHOR - -This module by Jos Boumans Ekane@cpan.orgE. - -=head1 COPYRIGHT - -The CPAN++ interface (of which this module is a part of) is copyright (c) -2001 - 2007, Jos Boumans Ekane@cpan.orgE. 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 - -=head1 DESCRIPTION - -This script is an interface to the routines of -L for setting up, maintaining and -searching a C 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 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 uses, if this is -configured, and are updated if they are more than one -day old. - -If the C option is not given, it will default -to C of L, if this is configured, -with the sources being found under C. -A fatal error results if such a directory isn't found. -Updates to these index files are assumed here to be -handled by C. - -=item * C<--db_name 'cpan-sqlite'> - -This is the name of the database that C -will use. If not given, this defaults to C. - -=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 directory of C, 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 -option. - -=item * C<--reindex 'dist_name'> - -This specifies that the CPAN distribution C -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. - -=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 - -=head1 DESCRIPTION - -This script is an interface to the routines of -L for setting up, maintaining and -searching a C 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 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 uses, if this is -configured, and are updated if they are more than one -day old. - -If the C option is not given, it will default -to C of L, if this is configured, -with the sources being found under C. -A fatal error results if such a directory isn't found. -Updates to these index files are assumed here to be -handled by C. - -=item * C<--db_name 'cpan-sqlite'> - -This is the name of the database that C -will use. If not given, this defaults to C. - -=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 directory of C, 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 -option. - -=item * C<--reindex 'dist_name'> - -This specifies that the CPAN distribution C -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. - -=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 is a small front-end application for the L -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 F 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 - -For other issues, or commercial enhancement and support, contact the author - -=head1 AUTHOR - -Adam Kennedy Eadamk@cpan.orgE - -=head1 SEE ALSO - -L - -=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 is a small front-end application for the L -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 F 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 - -For other issues, or commercial enhancement and support, contact the author - -=head1 AUTHOR - -Adam Kennedy Eadamk@cpan.orgE - -=head1 SEE ALSO - -L - -=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 - -B S<[-]B> S<[ --[B-]I> S<[ --[B-]I
)) { - while (/\\$/) { # Handle continuation lines - chop $line; - $line .=
; - } - - 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 = ; - $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 - -=head1 DESCRIPTION - -I -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, instead of -beneath the default Perl library location (C<$Config{'installsitearch'}>). - -=item -r - -Run recursively; if any of B are directories, then run I -on all files in those directories (and their subdirectories, etc.). B<-r> -and B<-a> are mutually exclusive. - -=item -a - -Run automagically; convert B, 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. In those cases when you B 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. - -=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 [B ...] [headerfile ... [extra_libraries]] - -B B<-h>|B<-?>|B<--help> - -=head1 DESCRIPTION - -I 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 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 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> 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 file, and adds a HISTORY section to -the POD template. - -=item B<-F>, B<--cpp-flags>=I - -Additional flags to specify to C preprocessor when scanning header for -function declarations. Writes these options in the generated F -too. - -=item B<-M>, B<--func-mask>=I - -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 -method to construct and return a new structure, initialised to zeroes. - -=item B<-b>, B<--compat-version>=I - -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 from the .xs file and corresponding specialised -C from the .pm file. - -=item B<-d>, B<--debugging> - -Turn on debugging messages. - -=item B<-e>, B<--omit-enums>=[I] - -If I 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. - -Since I is optional, make sure that this switch is followed -by at least one other switch if you omit I 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. - -=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, omit the const attribute in the -generated XS code. - -=item B<-m>, B<--gen-tied-var> - -B: 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 - -Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> - -=item B<-o>, B<--opaque-re>=I - -Use "opaque" data type for the C types matched by the regular -expression, even if these types are C-equivalent to types -from typemaps. Should not be used without B<-x>. - -This may be useful since, say, types which are C-equivalent -to integers may represent OS-related handles, and one may want to work -with these handles in OO-way, as in C<$handle-Edo_something()>. -Use C<-o .> if you want to handle all the Ced 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 - -Specify a prefix which should be removed from the Perl function names, -e.g., S<-p sec_rgy_> This sets up the XS B keyword and removes -the prefix from functions that are autoloaded via the C -mechanism. - -=item B<-s>, B<--const-subs>=I - -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, e.g., -S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>. - -=item B<-t>, B<--default-type>=I - -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 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 rather than C which is the default for versions before -5.7.2 . C will be added to PREREQ_PM in the generated -C. - -=item B<--use-old-tests> - -Will force the generation of test code that uses the older C module. - -=item B<--skip-exporter> - -Do not use C and/or export any symbol. - -=item B<--skip-ppport> - -Do not use C: no portability to older version. - -=item B<--skip-autoloader> - -Do not use the module C; but keep the constant() function -and C for constants. - -=item B<--skip-strict> - -Do not use the pragma C. - -=item B<--skip-warnings> - -Do not use the pragma C. - -=item B<-v>, B<--version>=I - -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 should be installed. If this -option is specified, the name of the header file may look like -C. 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), pointers to functions, or arrays. See -also the section on L>. - -=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 - h2xs rpcsvc::rusers - - # Extension is ONC::RPC. Still finds - 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 and -I, and you want the perl module be named as -C. 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. - -=item Copy C files - -Copy your header files and C files to this directory F. - -=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 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 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, L, L, and L. - -=head1 DIAGNOSTICS - -The usual warnings if it cannot read or write the files involved. - -=head1 LIMITATIONS of B<-x> - -F would not distinguish whether an argument to a C function -which is of the form, say, C, 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 is an input parameter. - -Additionally, F 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 and L 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 <. - --skip-strict Do not use the pragma C. - --skip-warnings Do not use the pragma C. - -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. - -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 <= 0.70 - or die <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 () { - 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; # | ??>| }| - } - 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 $/; }; - 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(?[$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\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 <))[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 = < should be removed. -# -#EOD - $exp_doc .= <${email}E -# -#=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 <[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_to_ptr()> -# -#Converts an object of type C<$name> to an object of type C<$ptrname>. -# -#=item C<$name-Enew()> -# -#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 () { - 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 ? '' : < ['$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 ? '' : < '\$(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 <MANIFEST') or die "Can't create MANIFEST: $!"; -my @files = grep { -f } (<*>, , <$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 = < - 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 = ; 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 = < - Select a module - q - Quit the program -EOF -print($help); -while (1) - { - print("cmd? "); - my $reply = ; 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 = < - 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 = ; 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 = < - Select a module - q - Quit the program -EOF -print($help); -while (1) - { - print("cmd? "); - my $reply = ; 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 converts between some input and output formats (one of them is -JSON). - -The default input format is C and the default output format is -C. - -=head1 OPTIONS - -=over 4 - -=item -v - -Be slightly more verbose. - -=item -f fromformat - -Read a file in the given format from STDIN. - -C 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 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 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. - - pretty.json - -Prettify the JSON file F to F. - - json_xs -f storable-file and print a human-readable JSON -version of it to STDOUT. - - json_xs -f storable-file -t yaml and pretty-print it. - -=head1 AUTHOR - -Copyright (C) 2008 Marc Lehmann - -=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 - $_ = ; -} - -$_ = $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 converts between some input and output formats (one of them is -JSON). - -The default input format is C and the default output format is -C. - -=head1 OPTIONS - -=over 4 - -=item -v - -Be slightly more verbose. - -=item -f fromformat - -Read a file in the given format from STDIN. - -C 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 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 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. - - pretty.json - -Prettify the JSON file F to F. - - json_xs -f storable-file and print a human-readable JSON -version of it to STDOUT. - - json_xs -f storable-file -t yaml and pretty-print it. - -=head1 AUTHOR - -Copyright (C) 2008 Marc Lehmann - -=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 - $_ = ; -} - -$_ = $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, L - -=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 <, 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 = <. To accept the -default, hit - -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 = < 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 <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 Binary files a/Master/tlpkg/tlperl/bin/libpng3.dll and /dev/null 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 [B<-a>] > [>] - -=head1 DESCRIPTION - -The B program will save the file at I to a local -file. - -If I is not specified, then the current directory is -assumed. - -If I 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 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 is not a directory, then it is simply used as the -path to save into. - -The I program is implemented using the I -library. It is better suited to down load big files than the -I 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 - -=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 = ; - 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 = ; - 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] []\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 [B<-a>] > [>] - -=head1 DESCRIPTION - -The B program will save the file at I to a local -file. - -If I is not specified, then the current directory is -assumed. - -If I 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 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 is not a directory, then it is simply used as the -path to save into. - -The I program is implemented using the I -library. It is better suited to down load big files than the -I 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 - -=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 = ; - 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 = ; - 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] []\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] - -Recognized options are: - --agent - --keep-client-headers - --max-length - --method - --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 [ I ] I - -=head1 DESCRIPTION - -The B 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 - -Override the user agent string passed to the server. - -=item B<--keep-client-headers> - -LWP internally generate various C headers that are stripped by -B in order to show the headers exactly as the server provided them. -This option will suppress this. - -=item B<--max-length> I - -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 - -Use the given method for the request instead of the default "GET". - -=item B<--parse-head> - -By default B will not try to initialize headers by looking at the -head section of HTML documents. This option enables this. This corresponds to -L. - -=back - -=head1 SEE ALSO - -L, L, L - 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] - -Recognized options are: - --agent - --keep-client-headers - --max-length - --method - --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 [ I ] I - -=head1 DESCRIPTION - -The B 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 - -Override the user agent string passed to the server. - -=item B<--keep-client-headers> - -LWP internally generate various C headers that are stripped by -B in order to show the headers exactly as the server provided them. -This option will suppress this. - -=item B<--max-length> I - -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 - -Use the given method for the request instead of the default "GET". - -=item B<--parse-head> - -By default B will not try to initialize headers by looking at the -head section of HTML documents. This option enables this. This corresponds to -L. - -=back - -=head1 SEE ALSO - -L, L, L - - -__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] - -=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, L - -=head1 AUTHOR - -Gisle Aas - -=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] - -v print version number of program - -t 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] - -=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, L - -=head1 AUTHOR - -Gisle Aas - -=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] - -v print version number of program - -t 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 [B<-afPuUsSedvhx>] [B<-m> I] [B<-b> I] [B<-t> I] - [B<-i> I] [B<-c> I] - [B<-C> I] [B<-p> I] [B<-o> I] I... - -=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 - -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 - -This URI will be used as the base URI for resolving all relative URIs -given as argument. - -=item -t - -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
- -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 : - -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 print the content of the response. - -=item -o - -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, I, I, -I and I. - -If you specify the I format then the HTML will be formatted as -plain latin1 text. If you specify the I format then it will be -formatted as Postscript. - -The I format will output all links found in the HTML document. -Relative links will be expanded to absolute ones. - -The I format will reformat the HTML code and the I format -will just dump the HTML syntax tree. - -Note that the C distribution needs to be installed for this -option to work. In addition the C 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, L - -=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 - -=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 = ; - chomp($user); - return (undef, undef) unless length $user; - print STDERR "Password: "; - system("stty -echo"); - my $password = ; - 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("", ); -} -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] ... - -m use method for the request (default is '$method') - -f make request even if $progname believes method is illegal - -b Use the specified URL as base - -t Set timeout value - -i
send this HTTP header (you can specify several) - -C : - 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 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 [B<-afPuUsSedvhx>] [B<-m> I] [B<-b> I] [B<-t> I] - [B<-i> I] [B<-c> I] - [B<-C> I] [B<-p> I] [B<-o> I] I... - -=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 - -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 - -This URI will be used as the base URI for resolving all relative URIs -given as argument. - -=item -t - -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
- -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 : - -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 print the content of the response. - -=item -o - -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, I, I, -I and I. - -If you specify the I format then the HTML will be formatted as -plain latin1 text. If you specify the I format then it will be -formatted as Postscript. - -The I format will output all links found in the HTML document. -Relative links will be expanded to absolute ones. - -The I format will reformat the HTML code and the I format -will just dump the HTML syntax tree. - -Note that the C distribution needs to be installed for this -option to work. In addition the C 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, L - -=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 - -=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 = ; - chomp($user); - return (undef, undef) unless length $user; - print STDERR "Password: "; - system("stty -echo"); - my $password = ; - 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("", ); -} -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] ... - -m use method for the request (default is '$method') - -f make request even if $progname believes method is illegal - -b Use the specified URL as base - -t Set timeout value - -i
send this HTTP header (you can specify several) - -C : - 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 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] - 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 - -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 - -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 - -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 requests if the referring page was transmitted over -C 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 - -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 - -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 - -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, then prefix will be set to -C. - -Use C<--prefix=''> if you don't want the fetching to be limited by any -prefix. - -=item --sleep=I - -Sleep I 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, L - -=head1 AUTHOR - -Gisle Aas - -=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 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: - # - # - # - } - 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] -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] - 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 - -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 - -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 - -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 requests if the referring page was transmitted over -C 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 - -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 - -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 - -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, then prefix will be set to -C. - -Use C<--prefix=''> if you don't want the fetching to be limited by any -prefix. - -=item --sleep=I - -Sleep I 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, L - -=head1 AUTHOR - -Gisle Aas - -=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 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: - # - # - # - } - 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] -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 -which is specific to ActiveState's perl distributions to F<.par> -files and installs those using L. - -It works much the same way as the L 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 module. Please -refer to that module's documentation for details on how this all works. - -PAR has a mailing list, , that you can write to; send -an empty mail to to join the list and -participate in the discussion. - -Please send bug reports to . - -The official PAR website may be of help, too: http://par.perl.org - -For details on the I, please refer to ActiveState's -website at L. - -=head1 AUTHOR - -Steffen Mueller, Esmueller at cpan dot orgE - -=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 -which is specific to ActiveState's perl distributions to F<.par> -files and installs those using L. - -It works much the same way as the L 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 -which is specific to ActiveState's perl distributions to F<.par> -files and installs those using L. - -It works much the same way as the L 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 module. Please -refer to that module's documentation for details on how this all works. - -PAR has a mailing list, , that you can write to; send -an empty mail to to join the list and -participate in the discussion. - -Please send bug reports to . - -The official PAR website may be of help, too: http://par.perl.org - -For details on the I, please refer to ActiveState's -website at L. - -=head1 AUTHOR - -Steffen Mueller, Esmueller at cpan dot orgE - -=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 -which is specific to ActiveState's perl distributions to F<.par> -files and installs those using L. - -It works much the same way as the L 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 Binary files a/Master/tlpkg/tlperl/bin/perl.exe and /dev/null 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 Binary files a/Master/tlpkg/tlperl/bin/perl5.10.1.exe and /dev/null differ diff --git a/Master/tlpkg/tlperl/bin/perl510.dll b/Master/tlpkg/tlperl/bin/perl510.dll deleted file mode 100755 index 4a533b76803..00000000000 Binary files a/Master/tlpkg/tlperl/bin/perl510.dll and /dev/null 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' 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 < 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 <first_release($entry); - if ($entry and not $first_release) { - paraprint <$filename") or die "Unable to create report file '$filename': $!\n"; - my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug') - : $::opt_n ? "build failure" : "success"; - - print REP <) { - 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 <etry dit - next; - } elsif ( $action =~ /^[cq]/i ) { # ancel, 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 = <ile/ve - if ( SaveMessage() ) { exit } - } elsif ($action =~ /^(d|l|sh)/i ) { # isplay, ist, ow - # Display the message - open(REP, "<$filename") or die "Couldn't open file '$filename': $!\n"; - while () { print $_ } - close(REP) or die "Error closing report file '$filename': $!"; - } elsif ($action =~ /^su/i) { # 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) { # 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 <dit, e-edit - # edit the message - Edit(); - } elsif ($action =~ /^[qc]/i) { # ancel, uit - Cancel(); - } elsif ($action =~ /^s/i) { - paraprint < 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 () { $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 () { 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 = ) { - $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 - -B S<[ B<-v> ]> S<[ B<-a> I
]> S<[ B<-s> I ]> -S<[ B<-b> I | B<-f> I ]> S<[ B<-F> I ]> -S<[ B<-r> I ]> -S<[ B<-e> I ]> S<[ B<-c> I | B<-C> ]> -S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]> - -B S<[ B<-v> ]> S<[ B<-r> I ]> - S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> - -B - -=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), 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 (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 -using your regular mail client. - -In extreme cases, B 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 to get system configuration -information to include in a manually composed bug report to -B. - - -When reporting a bug, please run through this checklist: - -=over 4 - -=item What version of Perl you are running? - -Type C 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, your issue is likely to -receive more attention. You may want to start with B -L 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 L 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 L, 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 -L. - -=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 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, B, 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 will almost -definitely be fixed. When sending a patch, please use the C -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 -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, if the thing you're patching is covered -by Perl's test suite). - -=item Can you use C to submit the report? - -B will, amongst other things, ensure your report includes -crucial information about your version of perl. If C 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 and email it to B. If, for some reason, you -cannot run C at all on your system, be sure to include the -entire output produced by running C (note the uppercase V). - -Whether you use C 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 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. 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. - -=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). 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). 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. - -=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 (Ekjahds@kjahds.comE), subsequently -Itored by Gurusamy Sarathy (Egsar@activestate.comE), -Tom Christiansen (Etchrist@perl.comE), Nathan Torkington -(Egnat@frii.comE), Charles F. Randall (Ecfr@pobox.comE), -Mike Guy (Emjtg@cam.a.ukE), Dominic Dunlop -(Edomo@computer.orgE), Hugo van der Sanden (Ehv@crypt.org), -Jarkko Hietaniemi (Ejhi@iki.fiE), Chris Nandor -(Epudge@pobox.comE), Jon Orwant (Eorwant@media.mit.eduE, -Richard Foley (Erichard.foley@rfi.netE), and Jesse Vincent -(Ejesse@bestpractical.com). - -=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. - -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 for details of overriding -builtins. - -=head1 AUTHOR - -Gurusamy Sarathy - -=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 Binary files a/Master/tlpkg/tlperl/bin/perlglob.exe and /dev/null 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 [B<-a>] [B<-p>] [B<-v>] [B<-h>] - -=head1 DESCRIPTION - -The B 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 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 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 -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 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 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' 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 < 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 <first_release($entry); - if ($entry and not $first_release) { - paraprint <$filename") or die "Unable to create report file '$filename': $!\n"; - my $reptype = !$ok ? ($thanks ? 'thank-you' : 'bug') - : $::opt_n ? "build failure" : "success"; - - print REP <) { - 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 <etry dit - next; - } elsif ( $action =~ /^[cq]/i ) { # ancel, 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 = <ile/ve - if ( SaveMessage() ) { exit } - } elsif ($action =~ /^(d|l|sh)/i ) { # isplay, ist, ow - # Display the message - open(REP, "<$filename") or die "Couldn't open file '$filename': $!\n"; - while () { print $_ } - close(REP) or die "Error closing report file '$filename': $!"; - } elsif ($action =~ /^su/i) { # 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) { # 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 <dit, e-edit - # edit the message - Edit(); - } elsif ($action =~ /^[qc]/i) { # ancel, uit - Cancel(); - } elsif ($action =~ /^s/i) { - paraprint < 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 () { $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 () { 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 = ) { - $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 - -B S<[ B<-v> ]> S<[ B<-a> I
]> S<[ B<-s> I ]> -S<[ B<-b> I | B<-f> I ]> S<[ B<-F> I ]> -S<[ B<-r> I ]> -S<[ B<-e> I ]> S<[ B<-c> I | B<-C> ]> -S<[ B<-S> ]> S<[ B<-t> ]> S<[ B<-d> ]> S<[ B<-A> ]> S<[ B<-h> ]> S<[ B<-T> ]> - -B S<[ B<-v> ]> S<[ B<-r> I ]> - S<[ B<-A> ]> S<[ B<-ok> | B<-okay> | B<-nok> | B<-nokay> ]> - -B - -=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), 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 (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 -using your regular mail client. - -In extreme cases, B 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 to get system configuration -information to include in a manually composed bug report to -B. - - -When reporting a bug, please run through this checklist: - -=over 4 - -=item What version of Perl you are running? - -Type C 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, your issue is likely to -receive more attention. You may want to start with B -L 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 L 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 L, 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 -L. - -=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 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, B, 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 will almost -definitely be fixed. When sending a patch, please use the C -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 -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, if the thing you're patching is covered -by Perl's test suite). - -=item Can you use C to submit the report? - -B will, amongst other things, ensure your report includes -crucial information about your version of perl. If C 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 and email it to B. If, for some reason, you -cannot run C at all on your system, be sure to include the -entire output produced by running C (note the uppercase V). - -Whether you use C 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 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. 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. - -=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). 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). 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. - -=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 (Ekjahds@kjahds.comE), subsequently -Itored by Gurusamy Sarathy (Egsar@activestate.comE), -Tom Christiansen (Etchrist@perl.comE), Nathan Torkington -(Egnat@frii.comE), Charles F. Randall (Ecfr@pobox.comE), -Mike Guy (Emjtg@cam.a.ukE), Dominic Dunlop -(Edomo@computer.orgE), Hugo van der Sanden (Ehv@crypt.org), -Jarkko Hietaniemi (Ejhi@iki.fiE), Chris Nandor -(Epudge@pobox.comE), Jon Orwant (Eorwant@media.mit.eduE, -Richard Foley (Erichard.foley@rfi.netE), and Jesse Vincent -(Ejesse@bestpractical.com). - -=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 is perl version of B, 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, -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, -this option can be omitted. In such cases, the current locale is used. - -Therefore, when both -f and -t are omitted, B just acts -like B. - -=item -s,--string I - -uses I 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 -for a full discussion. - -=item -C,--check I - -Check the validity of the stream if I = 1. When I = -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 -L -L -L -L -L - -=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 is perl version of B, 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, -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, -this option can be omitted. In such cases, the current locale is used. - -Therefore, when both -f and -t are omitted, B just acts -like B. - -=item -s,--string I - -uses I 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 -for a full discussion. - -=item -C,--check I - -Check the validity of the stream if I = 1. When I = -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 -L -L -L -L -L - -=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 = <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 = ; - 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 B<-h> - -B [B<-w>] S<[B<-a> I]> S<[B<-s> I]> [files] - -B [B<-w>] S<[B<-n> I]> S<[B<-o> I]> S<[B<-s> I]> [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 -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. - -=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 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 [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. - -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 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 under Windows NT, if F is not -in your B, 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. When using -F 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 implements this by -doing C 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, 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 file handle. - -One approach is: - - . #!perl - . while( ) { - . last if /^__END__$/; - . [...] - . } - . __END__ - . lines of data - . to be processed - . __END__ - . :endofperl - -The dots in the first column are only there to prevent F to interpret -the C<:endofperl> line in this documentation. Otherwise F 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 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 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 -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 shell -under Windows NT. 4DOS/NT users will want to put a C -line in their initialization file, or execute C 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 - -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 - -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 - -Arguments to invoke perl with in generated batch file. Specifying -B<-a> prevents the batch file from checking the C environment -variable to determine which operating system it is being run from. - -=item B<-s> I - -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. - -=item B<-w> - -If no line matching C 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]. With the B<-w> -option, C<" -w"> is added after the value of C<$Config{startperl}>. -If a line matching C 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, -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 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. - -=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 F - -=head1 DESCRIPTION - -B 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 - -=cut - -use strict; -use warnings; - -my %keyword = (); - -while () { - 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= --infile= --outfile= - --podpath=:...: --podroot= - --libpods=:...: --recurse --norecurse --verbose - --index --noindex --title= - -=head1 DESCRIPTION - -Converts files from pod format (see L) 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, Etchrist@perl.comE. - -=head1 BUGS - -See L for a list of known bugs in the translator. - -=head1 SEE ALSO - -L, L - -=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 is a program to convert POD format documentation -(L) 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 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 code. - -=item B<-sections> - -Specify pod sections to include (or remove if negated) in the -translation. See L for the -format to use for I. This option may be given multiple -times on the command line.This is identical to the similar option in -the C command. - -=item B<-modify> - -This option causes the output C 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) 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 label and index entries to be prefixed by the -name of the module. - -=item B<-h1level> - -Specifies the C section that is equivalent to a C

pod -directive. This is an integer between 0 and 5 with 0 equivalent to a -C chapter, 1 equivalent to a C section etc. The default -is 1 (C

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 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 - -=head1 AUTHOR - -Tim Jenness Etjenness@cpan.orgE - -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 -# -# 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] [B<--date>=I] - [B<--fixed>=I] [B<--fixedbold>=I] [B<--fixeditalic>=I] - [B<--fixedbolditalic>=I] [B<--name>=I] [B<--official>] - [B<--quotes>=I] [B<--release>[=I]] - [B<--section>=I] [B<--stderr>] [B<--utf8>] [B<--verbose>] - [I [I] ...] - -pod2man B<--help> - -=head1 DESCRIPTION - -B 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 is the file to read for POD source (the POD can be embedded in -code). If I isn't given, it defaults to C. I, if -given, is the file to which to write the formatted output. If I -isn't given, the formatted output is written to C. Several POD -files can be processed in the same B invocation (saving module -load and compile times) by providing multiple pairs of I and -I 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 for details. - -B assumes that your *roff formatters have a fixed-width font -named C. If yours is called something else (like C), 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 for -complete information. - -=head1 OPTIONS - -=over 4 - -=item B<-c> I, B<--center>=I - -Sets the centered page header to I. The default is "User -Contributed Perl Documentation", but also see B<--official> below. - -=item B<-d> I, B<--date>=I - -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. - -=item B<--fixed>=I - -The fixed-width font to use for verbatim text and code. Defaults to -C. Some systems may want C instead. Only matters for troff(1) -output. - -=item B<--fixedbold>=I - -Bold version of the fixed-width font. Defaults to C. Only matters -for troff(1) output. - -=item B<--fixeditalic>=I - -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. Only matters for troff(1) output. - -=item B<--fixedbolditalic>=I - -Bold italic (probably actually oblique) version of the fixed-width font. -Pod::Man doesn't assume you have this, and defaults to C. Some -systems (such as Solaris) have this font available as C. Only matters -for troff(1) output. - -=item B<-h>, B<--help> - -Print out usage information. - -=item B<-l>, B<--lax> - -No longer used. B used to check its input for validity as a -manual page, but this should now be done by L instead. -Accepted for backward compatibility; this option no longer does anything. - -=item B<-n> I, B<--name>=I - -Set the name of the manual page to I. 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. 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, B<--quotes>=I - -Sets the quote marks used to surround CE> text to I. If -I is a single character, it is used as both the left and right -quote; if I is two characters, the first character is used as the -left quote and the second as the right quoted; and if I is four -characters, the first two are used as the left quote and the second two as -the right quote. - -I may also be set to the special value C, in which case no -quote marks are added around CE> 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 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 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 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. - -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 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 fails with errors, see L and L 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, 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 CE> directives. See -L for more details. - -=head1 BUGS - -Lots of this documentation is duplicated from L. - -=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 BEE) wherever it occurs, as are all program options. -Arguments should be written in italics (IEE). 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 CEE. References to other man pages should be in the form -C, 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 CModule::NameE> 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 CEE or -BEE. 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. This is normally presented as a list, with -each option as a separate C<=item>. The specific option string should be -enclosed in BEE. Any values that the option takes should be -enclosed in IEE. For example, the section for the option -B<--section>=I would be introduced with: - - =item B<--section>=I - -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, B<--section>=I - -(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 or C 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 FEE. 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 form, don't have to be enclosed in -LEE (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 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, 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 LEE, so don't do that. - -For additional information that may be more accurate for your specific -system, see either L or L depending on your system manual -section numbering conventions. - -=head1 SEE ALSO - -L, L, L, L, L, -L, L, L - -The man page documenting the an macro set may be L instead of -L on your system. - -The current version of this script is always available from its web site at -L. It is also part of the -Perl core distribution as of 5.6.0. - -=head1 AUTHOR - -Russ Allbery , based I heavily on the original -B 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 documentation by Tom. - -=head1 COPYRIGHT AND LICENSE - -Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery -. - -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 -# -# 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] [B<--date>=I] - [B<--fixed>=I] [B<--fixedbold>=I] [B<--fixeditalic>=I] - [B<--fixedbolditalic>=I] [B<--name>=I] [B<--official>] - [B<--quotes>=I] [B<--release>[=I]] - [B<--section>=I] [B<--stderr>] [B<--utf8>] [B<--verbose>] - [I [I] ...] - -pod2man B<--help> - -=head1 DESCRIPTION - -B 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 is the file to read for POD source (the POD can be embedded in -code). If I isn't given, it defaults to C. I, if -given, is the file to which to write the formatted output. If I -isn't given, the formatted output is written to C. Several POD -files can be processed in the same B invocation (saving module -load and compile times) by providing multiple pairs of I and -I 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 for details. - -B assumes that your *roff formatters have a fixed-width font -named C. If yours is called something else (like C), 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 for -complete information. - -=head1 OPTIONS - -=over 4 - -=item B<-c> I, B<--center>=I - -Sets the centered page header to I. The default is "User -Contributed Perl Documentation", but also see B<--official> below. - -=item B<-d> I, B<--date>=I - -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. - -=item B<--fixed>=I - -The fixed-width font to use for verbatim text and code. Defaults to -C. Some systems may want C instead. Only matters for troff(1) -output. - -=item B<--fixedbold>=I - -Bold version of the fixed-width font. Defaults to C. Only matters -for troff(1) output. - -=item B<--fixeditalic>=I - -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. Only matters for troff(1) output. - -=item B<--fixedbolditalic>=I - -Bold italic (probably actually oblique) version of the fixed-width font. -Pod::Man doesn't assume you have this, and defaults to C. Some -systems (such as Solaris) have this font available as C. Only matters -for troff(1) output. - -=item B<-h>, B<--help> - -Print out usage information. - -=item B<-l>, B<--lax> - -No longer used. B used to check its input for validity as a -manual page, but this should now be done by L instead. -Accepted for backward compatibility; this option no longer does anything. - -=item B<-n> I, B<--name>=I - -Set the name of the manual page to I. 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. 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, B<--quotes>=I - -Sets the quote marks used to surround CE> text to I. If -I is a single character, it is used as both the left and right -quote; if I is two characters, the first character is used as the -left quote and the second as the right quoted; and if I is four -characters, the first two are used as the left quote and the second two as -the right quote. - -I may also be set to the special value C, in which case no -quote marks are added around CE> 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 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 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 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. - -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 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 fails with errors, see L and L 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, 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 CE> directives. See -L for more details. - -=head1 BUGS - -Lots of this documentation is duplicated from L. - -=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 BEE) wherever it occurs, as are all program options. -Arguments should be written in italics (IEE). 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 CEE. References to other man pages should be in the form -C, 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 CModule::NameE> 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 CEE or -BEE. 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. This is normally presented as a list, with -each option as a separate C<=item>. The specific option string should be -enclosed in BEE. Any values that the option takes should be -enclosed in IEE. For example, the section for the option -B<--section>=I would be introduced with: - - =item B<--section>=I - -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, B<--section>=I - -(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 or C 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 FEE. 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 form, don't have to be enclosed in -LEE (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 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, 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 LEE, so don't do that. - -For additional information that may be more accurate for your specific -system, see either L or L depending on your system manual -section numbering conventions. - -=head1 SEE ALSO - -L, L, L, L, L, -L, L, L - -The man page documenting the an macro set may be L instead of -L on your system. - -The current version of this script is always available from its web site at -L. It is also part of the -Perl core distribution as of 5.6.0. - -=head1 AUTHOR - -Russ Allbery , based I heavily on the original -B 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 documentation by Tom. - -=head1 COPYRIGHT AND LICENSE - -Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery -. - -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 -# -# 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 -# -. We turn that into -w 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] S<[B<-q> I]> - [B<--stderr>] S<[B<-w> I]> [I [I ...]] - -pod2text B<-h> - -=head1 DESCRIPTION - -B 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 is the file to read for POD source (the POD can be embedded in -code). If I isn't given, it defaults to C. I, if -given, is the file to which to write the formatted output. If I -isn't given, the formatted output is written to C. Several POD -files can be processed in the same B invocation (saving module -load and compile times) by providing multiple pairs of I and -I 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, B<--indent=>I - -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, B<--left-margin>=I, B<--margin>=I - -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, know how -to convert this to bold or underlined text. - -=item B<-q> I, B<--quotes>=I - -Sets the quote marks used to surround CE> text to I. If -I is a single character, it is used as both the left and right -quote; if I is two characters, the first character is used as the -left quote and the second as the right quoted; and if I is four -characters, the first two are used as the left quote and the second two as -the right quote. - -I may also be set to the special value C, in which case no -quote marks are added around CE> 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 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 -will contain terminal control sequences for your current terminal type. - -=item B<-u>, B<--utf8> - -By default, B 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 for more information on the C<=encoding> command. - -=item B<-w>, B<--width=>I, B<->I - -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 fails with errors, see L and L 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 error messages may result from invalid -command-line options. - -=head1 ENVIRONMENT - -=over 4 - -=item COLUMNS - -If B<-t> is given, B 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 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, L, L, -L, L, L - -The current version of this script is always available from its web site at -L. It is also part of the -Perl core distribution as of 5.6.0. - -=head1 AUTHOR - -Russ Allbery . - -=head1 COPYRIGHT AND LICENSE - -Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery -. - -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 -# -# 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 -# -. We turn that into -w 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] S<[B<-q> I]> - [B<--stderr>] S<[B<-w> I]> [I [I ...]] - -pod2text B<-h> - -=head1 DESCRIPTION - -B 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 is the file to read for POD source (the POD can be embedded in -code). If I isn't given, it defaults to C. I, if -given, is the file to which to write the formatted output. If I -isn't given, the formatted output is written to C. Several POD -files can be processed in the same B invocation (saving module -load and compile times) by providing multiple pairs of I and -I 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, B<--indent=>I - -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, B<--left-margin>=I, B<--margin>=I - -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, know how -to convert this to bold or underlined text. - -=item B<-q> I, B<--quotes>=I - -Sets the quote marks used to surround CE> text to I. If -I is a single character, it is used as both the left and right -quote; if I is two characters, the first character is used as the -left quote and the second as the right quoted; and if I is four -characters, the first two are used as the left quote and the second two as -the right quote. - -I may also be set to the special value C, in which case no -quote marks are added around CE> 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 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 -will contain terminal control sequences for your current terminal type. - -=item B<-u>, B<--utf8> - -By default, B 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 for more information on the C<=encoding> command. - -=item B<-w>, B<--width=>I, B<->I - -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 fails with errors, see L and L 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 error messages may result from invalid -command-line options. - -=head1 ENVIRONMENT - -=over 4 - -=item COLUMNS - -If B<-t> is given, B 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 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, L, L, -L, L, L - -The current version of this script is always available from its web site at -L. It is also part of the -Perl core distribution as of 5.6.0. - -=head1 AUTHOR - -Russ Allbery . - -=head1 COPYRIGHT AND LICENSE - -Copyright 1999, 2000, 2001, 2004, 2006, 2008 Russ Allbery -. - -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 - -[B<-help>] -[B<-man>] -[B<-exit>S< >I] -[B<-output>S< >I] -[B<-verbose> I] -[B<-pathlist> I] -I - -=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 - -The exit status value to return. - -=item B<-output> I - -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 - -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 - -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 - -The pathname of a file containing pod documentation to be output in -usage message format (defaults to standard input). - -=back - -=head1 DESCRIPTION - -B 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 invokes the B function in the B -module. Please see L. - -=head1 SEE ALSO - -L, L - -=head1 AUTHOR - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -=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 [B<-help>] [B<-man>] [B<-(no)warnings>] [IS< >...] - -=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,E" characters. - -=item I - -The pathname of a POD file to syntax-check (defaults to standard input). - -=back - -=head1 DESCRIPTION - -B 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 invokes the B function exported by B -Please see L for more details. - -=head1 RETURN VALUE - -B returns a 0 (zero) exit status if all specified -POD files are ok. - -=head1 ERRORS - -B 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 POD commands. - -Status 1 overrides status 2. If you want unambiguous -results, call B with one single argument only. - -=head1 SEE ALSO - -L and L - -=head1 AUTHORS - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE, -Marek Rouchal Emarekr@cpan.orgE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -=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 [B<-help>] [B<-man>] [B<-section>S< >I] -[IS< >...] - -=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 - -Specify a section to include in the output. -See L -for the format to use for I. -This option may be given multiple times on the command line. - -=item I - -The pathname of a file from which to select sections of pod -documentation (defaults to standard input). - -=back - -=head1 DESCRIPTION - -B 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 invokes the B function exported by B -Please see L for more details. - -=head1 SEE ALSO - -L and L - -=head1 AUTHOR - -Please report bugs using L. - -Brad Appleton Ebradapp@enteract.comE - -Based on code for B written by -Tom Christiansen Etchrist@mox.perl.comE - -=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 which is specific to ActiveState's -perl distributions. In order to do this, F 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 module. Please -refer to that module's documentation for details on how this all works. - -PAR has a mailing list, , that you can write to; send -an empty mail to to join the list and -participate in the discussion. - -Please send bug reports to . - -The official PAR website may be of help, too: http://par.perl.org - -For details on the I, please refer to ActiveState's -website at L. - -=head1 AUTHOR - -Steffen Mueller, Esmueller at cpan dot orgE - -=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 which is specific to ActiveState's -perl distributions. In order to do this, F 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 module. Please -refer to that module's documentation for details on how this all works. - -PAR has a mailing list, , that you can write to; send -an empty mail to to join the list and -participate in the discussion. - -Please send bug reports to . - -The official PAR website may be of help, too: http://par.perl.org - -For details on the I, please refer to ActiveState's -website at L. - -=head1 AUTHOR - -Steffen Mueller, Esmueller at cpan dot orgE - -=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 () { - 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"; - - 2,1,8,0 - - -EOF - foreach my $name(sort keys %$reps) { - my $loc = $reps->{$name}->{location}; - my $sf = $reps->{$name}->{summaryfile}; - print << "EOF"; - -EOF - } - print <<"EOF"; - 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 - -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 or 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 or 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 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, EFE - -=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 () { - 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"; - - 2,1,8,0 - - -EOF - foreach my $name(sort keys %$reps) { - my $loc = $reps->{$name}->{location}; - my $sf = $reps->{$name}->{summaryfile}; - print << "EOF"; - -EOF - } - print <<"EOF"; - 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 - -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 or 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 or 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 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, EFE - -=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 - -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 in the C directory of this distribution. - -=head2 Default Test Directory - -If no files or directories are supplied, C looks for all files -matching the pattern C. - -=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 on Unix-like platforms and -L windows. If the necessary module is not installed -colored output will not be available. - -=head2 Exit Code - -If the tests fail C 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 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 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 - -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 - -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 option newly passing tests will be -excluded from subsequent runs. - - # Repeat until no more failures - $ prove -b --state=failed,save - -=item C - -Run only the passed tests from last time. Useful to make sure that no -new problems have been introduced. - -=item C - -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 - -Run the tests that most recently failed first. The last failure time of -each test is stored. The C 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 - -Run any tests with todos. - -=item C - -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 - -Run test tests in fastest to slowest order. - -=item C - -Run the tests in newest to oldest order based on the modification times -of the test scripts. - -=item C - -Run the tests in oldest to newest order. - -=item C - -Run those test scripts that have been modified since the last test run. - -=item C - -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 environment variable, via -Ifoo in C or -via the C<-Ilib> option to F. - -=head2 Taint Mode - -Normally when a Perl program is run in taint mode the contents of the -C environment variable do not appear in C<@INC>. - -Because C is often used during testing to add build -directories to C<@INC> prove passes the names of any directories found -in C as -I switches. The net effect of this is that -C is honoured even when prove is run in taint mode. - - -=head1 FORMATTERS - -You can load a custom L: - - prove --formatter MyFormatter - -=head1 SOURCE HANDLERS - -You can load custom Ls, to change the way the -parser interprets particular I 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 examples above. - -All C<--sources> are combined into a hash, and passed to L's -C parameter. - -See L for more details on how configuration is -passed to I. - -=head1 PLUGINS - -Plugins can be loaded using the C<< -PI >> syntax, eg: - - prove -PMyPlugin - -This will search for a module named C, or failing -that, C. If the plugin can't be found, C 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 - -=head2 Writing Plugins - -Please see L. - -=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 - -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 in the C directory of this distribution. - -=head2 Default Test Directory - -If no files or directories are supplied, C looks for all files -matching the pattern C. - -=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 on Unix-like platforms and -L windows. If the necessary module is not installed -colored output will not be available. - -=head2 Exit Code - -If the tests fail C 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 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 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 - -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 - -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 option newly passing tests will be -excluded from subsequent runs. - - # Repeat until no more failures - $ prove -b --state=failed,save - -=item C - -Run only the passed tests from last time. Useful to make sure that no -new problems have been introduced. - -=item C - -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 - -Run the tests that most recently failed first. The last failure time of -each test is stored. The C 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 - -Run any tests with todos. - -=item C - -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 - -Run test tests in fastest to slowest order. - -=item C - -Run the tests in newest to oldest order based on the modification times -of the test scripts. - -=item C - -Run the tests in oldest to newest order. - -=item C - -Run those test scripts that have been modified since the last test run. - -=item C - -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 environment variable, via -Ifoo in C or -via the C<-Ilib> option to F. - -=head2 Taint Mode - -Normally when a Perl program is run in taint mode the contents of the -C environment variable do not appear in C<@INC>. - -Because C is often used during testing to add build -directories to C<@INC> prove passes the names of any directories found -in C as -I switches. The net effect of this is that -C is honoured even when prove is run in taint mode. - - -=head1 FORMATTERS - -You can load a custom L: - - prove --formatter MyFormatter - -=head1 SOURCE HANDLERS - -You can load custom Ls, to change the way the -parser interprets particular I 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 examples above. - -All C<--sources> are combined into a hash, and passed to L's -C parameter. - -See L for more details on how configuration is -passed to I. - -=head1 PLUGINS - -Plugins can be loaded using the C<< -PI >> syntax, eg: - - prove -PMyPlugin - -This will search for a module named C, or failing -that, C. If the plugin can't be found, C 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 - -=head2 Writing Plugins - -Please see L. - -=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, it will act as a -sed-to-Perl translator. See L<"sed Script Translation">. - -B 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 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