[Midnightbsd-cvs] src [6454] trunk/contrib/perl: remove old files
laffer1 at midnightbsd.org
laffer1 at midnightbsd.org
Tue Dec 3 21:10:21 EST 2013
Revision: 6454
http://svnweb.midnightbsd.org/src/?rev=6454
Author: laffer1
Date: 2013-12-03 21:10:19 -0500 (Tue, 03 Dec 2013)
Log Message:
-----------
remove old files
Removed Paths:
-------------
trunk/contrib/perl/cpan/Compress-Raw-Bzip2/pod/
trunk/contrib/perl/cpan/Compress-Raw-Zlib/pod/
trunk/contrib/perl/cpan/IO-Compress/pod/
trunk/contrib/perl/cpan/List-Util/lib/Scalar/Util/
trunk/contrib/perl/cpan/List-Util/t/p_openhan.t
trunk/contrib/perl/cpan/List-Util/t/p_reduce.t
trunk/contrib/perl/cpan/List-Util/t/p_reftype.t
trunk/contrib/perl/cpan/List-Util/t/p_sum.t
trunk/contrib/perl/cpan/Pod-Parser/t/pod/p2u_data.pl
trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage.t
trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage.xr
trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage2.t
trunk/contrib/perl/cpan/Pod-Parser/t/pod/podchkenc.t
trunk/contrib/perl/cpan/Pod-Parser/t/pod/podchkenc.xr
trunk/contrib/perl/cpan/Pod-Parser/t/pod/poderrs.t
trunk/contrib/perl/cpan/Pod-Parser/t/pod/poderrs.xr
trunk/contrib/perl/cpan/Pod-Parser/t/pod/usage.pod
trunk/contrib/perl/cpan/Pod-Parser/t/pod/usage2.pod
trunk/contrib/perl/cpan/Shell/
trunk/contrib/perl/cpan/Tie-File/
trunk/contrib/perl/cpan/Time-HiRes/t/HiRes.t
trunk/contrib/perl/cpan/Unicode-Collate/Collate/Locale/sw.pl
trunk/contrib/perl/cpan/Version-Requirements/
trunk/contrib/perl/dist/Attribute-Handlers/README
trunk/contrib/perl/dist/B-Lint/
trunk/contrib/perl/dist/ExtUtils-ParseXS/t/basic.t
trunk/contrib/perl/dist/ExtUtils-ParseXS/t/more.t
trunk/contrib/perl/dist/ExtUtils-ParseXS/t/usage.t
trunk/contrib/perl/dist/File-CheckTree/
trunk/contrib/perl/dist/Pod-Perldoc/
trunk/contrib/perl/epoc/
trunk/contrib/perl/ext/Attribute-Handlers/
trunk/contrib/perl/ext/B/B/Debug.pm
trunk/contrib/perl/ext/B/B/Deparse.pm
trunk/contrib/perl/ext/B/B/Lint/
trunk/contrib/perl/ext/B/B/Lint.pm
trunk/contrib/perl/ext/B/defsubs_h.PL
trunk/contrib/perl/ext/B/t/debug.t
trunk/contrib/perl/ext/B/t/deparse.t
trunk/contrib/perl/ext/B/t/lint.t
trunk/contrib/perl/ext/B/t/pluglib/
trunk/contrib/perl/ext/Compress/
trunk/contrib/perl/ext/Compress-Raw-Bzip2/
trunk/contrib/perl/ext/Compress-Raw-Zlib/
trunk/contrib/perl/ext/Cwd/
trunk/contrib/perl/ext/DB_File/
trunk/contrib/perl/ext/Data/
trunk/contrib/perl/ext/Data-Dumper/
trunk/contrib/perl/ext/Devel/
trunk/contrib/perl/ext/Devel-DProf/
trunk/contrib/perl/ext/Devel-PPPort/
trunk/contrib/perl/ext/Digest/
trunk/contrib/perl/ext/Digest-MD5/
trunk/contrib/perl/ext/Digest-SHA/
trunk/contrib/perl/ext/DynaLoader/XSLoader_pm.PL
trunk/contrib/perl/ext/DynaLoader/dl_beos.xs
trunk/contrib/perl/ext/DynaLoader/dl_mac.xs
trunk/contrib/perl/ext/DynaLoader/dl_mpeix.xs
trunk/contrib/perl/ext/DynaLoader/dl_vmesa.xs
trunk/contrib/perl/ext/DynaLoader/t/XSLoader.t
trunk/contrib/perl/ext/Encode/
trunk/contrib/perl/ext/File/
trunk/contrib/perl/ext/Filter/
trunk/contrib/perl/ext/Filter-Util-Call/
trunk/contrib/perl/ext/Hash/
trunk/contrib/perl/ext/Hash-Util-FieldHash/t/10_hash.t
trunk/contrib/perl/ext/I18N/
trunk/contrib/perl/ext/I18N-Langinfo/fallback/
trunk/contrib/perl/ext/IO/
trunk/contrib/perl/ext/IO-Compress/
trunk/contrib/perl/ext/IO_Compress_Base/
trunk/contrib/perl/ext/IO_Compress_Zlib/
trunk/contrib/perl/ext/IPC/
trunk/contrib/perl/ext/IPC-Open2/
trunk/contrib/perl/ext/IPC-SysV/
trunk/contrib/perl/ext/List/
trunk/contrib/perl/ext/List-Util/
trunk/contrib/perl/ext/MIME/
trunk/contrib/perl/ext/MIME-Base64/
trunk/contrib/perl/ext/Math/
trunk/contrib/perl/ext/Math-BigInt-FastCalc/
trunk/contrib/perl/ext/Module-Pluggable/
trunk/contrib/perl/ext/Opcode/Makefile.PL
trunk/contrib/perl/ext/Opcode/Safe.pm
trunk/contrib/perl/ext/POSIX/POSIX.pm
trunk/contrib/perl/ext/POSIX/POSIX.pod
trunk/contrib/perl/ext/POSIX/hints/uts.pl
trunk/contrib/perl/ext/PerlIO/
trunk/contrib/perl/ext/Pod-Html/Html.pm
trunk/contrib/perl/ext/Pod-Html/pod2html.PL
trunk/contrib/perl/ext/Safe/
trunk/contrib/perl/ext/Socket/
trunk/contrib/perl/ext/Storable/
trunk/contrib/perl/ext/Sys/
trunk/contrib/perl/ext/Sys-Syslog/
trunk/contrib/perl/ext/Test-Harness/
trunk/contrib/perl/ext/Text/
trunk/contrib/perl/ext/Text-Soundex/
trunk/contrib/perl/ext/Time/
trunk/contrib/perl/ext/Time-HiRes/
trunk/contrib/perl/ext/Time-Piece/
trunk/contrib/perl/ext/Unicode/
trunk/contrib/perl/ext/Unicode-Normalize/
trunk/contrib/perl/ext/Win32/
trunk/contrib/perl/ext/Win32API/
trunk/contrib/perl/ext/Win32API-File/
trunk/contrib/perl/ext/XS/
trunk/contrib/perl/ext/XS-Typemap/typemap
trunk/contrib/perl/ext/attrs/
trunk/contrib/perl/ext/mro/t/
trunk/contrib/perl/ext/re/hints/
trunk/contrib/perl/ext/threads/
trunk/contrib/perl/ext/threads-shared/
trunk/contrib/perl/ext/util/
trunk/contrib/perl/global.sym
trunk/contrib/perl/hints/beos.sh
trunk/contrib/perl/hints/machten.sh
trunk/contrib/perl/hints/machten_2.sh
trunk/contrib/perl/hints/mpeix.sh
trunk/contrib/perl/hints/rhapsody.sh
trunk/contrib/perl/hints/uts.sh
trunk/contrib/perl/hints/vmesa.sh
trunk/contrib/perl/lib/Archive/
trunk/contrib/perl/lib/Attribute/
trunk/contrib/perl/lib/AutoLoader/
trunk/contrib/perl/lib/AutoLoader.pm
trunk/contrib/perl/lib/AutoLoader.t
trunk/contrib/perl/lib/AutoSplit.pm
trunk/contrib/perl/lib/AutoSplit.t
trunk/contrib/perl/lib/CGI/
trunk/contrib/perl/lib/CGI.pm
trunk/contrib/perl/lib/CPAN/
trunk/contrib/perl/lib/CPAN.pm
trunk/contrib/perl/lib/CPANPLUS/
trunk/contrib/perl/lib/CPANPLUS.pm
trunk/contrib/perl/lib/Carp/
trunk/contrib/perl/lib/Carp.pm
trunk/contrib/perl/lib/Carp.t
trunk/contrib/perl/lib/Class/ISA/
trunk/contrib/perl/lib/Class/ISA.pm
trunk/contrib/perl/lib/Cwd.pm
trunk/contrib/perl/lib/Devel/
trunk/contrib/perl/lib/Digest/
trunk/contrib/perl/lib/Digest.pm
trunk/contrib/perl/lib/Dumpvalue.pm
trunk/contrib/perl/lib/Dumpvalue.t
trunk/contrib/perl/lib/Env/
trunk/contrib/perl/lib/Env.pm
trunk/contrib/perl/lib/ExtUtils/CBuilder/
trunk/contrib/perl/lib/ExtUtils/CBuilder.pm
trunk/contrib/perl/lib/ExtUtils/Command/
trunk/contrib/perl/lib/ExtUtils/Command.pm
trunk/contrib/perl/lib/ExtUtils/Constant/
trunk/contrib/perl/lib/ExtUtils/Constant.pm
trunk/contrib/perl/lib/ExtUtils/Install.pm
trunk/contrib/perl/lib/ExtUtils/Installed.pm
trunk/contrib/perl/lib/ExtUtils/Liblist/
trunk/contrib/perl/lib/ExtUtils/Liblist.pm
trunk/contrib/perl/lib/ExtUtils/MANIFEST.SKIP
trunk/contrib/perl/lib/ExtUtils/MM.pm
trunk/contrib/perl/lib/ExtUtils/MM_AIX.pm
trunk/contrib/perl/lib/ExtUtils/MM_Any.pm
trunk/contrib/perl/lib/ExtUtils/MM_BeOS.pm
trunk/contrib/perl/lib/ExtUtils/MM_Cygwin.pm
trunk/contrib/perl/lib/ExtUtils/MM_DOS.pm
trunk/contrib/perl/lib/ExtUtils/MM_Darwin.pm
trunk/contrib/perl/lib/ExtUtils/MM_MacOS.pm
trunk/contrib/perl/lib/ExtUtils/MM_NW5.pm
trunk/contrib/perl/lib/ExtUtils/MM_OS2.pm
trunk/contrib/perl/lib/ExtUtils/MM_QNX.pm
trunk/contrib/perl/lib/ExtUtils/MM_UWIN.pm
trunk/contrib/perl/lib/ExtUtils/MM_Unix.pm
trunk/contrib/perl/lib/ExtUtils/MM_VMS.pm
trunk/contrib/perl/lib/ExtUtils/MM_VOS.pm
trunk/contrib/perl/lib/ExtUtils/MM_Win32.pm
trunk/contrib/perl/lib/ExtUtils/MM_Win95.pm
trunk/contrib/perl/lib/ExtUtils/MY.pm
trunk/contrib/perl/lib/ExtUtils/Mkbootstrap.pm
trunk/contrib/perl/lib/ExtUtils/Mksymlists.pm
trunk/contrib/perl/lib/Fatal.pm
trunk/contrib/perl/lib/Fatal.t
trunk/contrib/perl/lib/File/CheckTree.pm
trunk/contrib/perl/lib/File/CheckTree.t
trunk/contrib/perl/lib/File/DosGlob.pm
trunk/contrib/perl/lib/File/DosGlob.t
trunk/contrib/perl/lib/File/Fetch/
trunk/contrib/perl/lib/File/Fetch.pm
trunk/contrib/perl/lib/File/Path.pm
trunk/contrib/perl/lib/File/Path.t
trunk/contrib/perl/lib/File/Spec/
trunk/contrib/perl/lib/File/Spec.pm
trunk/contrib/perl/lib/File/Temp/
trunk/contrib/perl/lib/File/Temp.pm
trunk/contrib/perl/lib/FileCache/
trunk/contrib/perl/lib/FileCache.pm
trunk/contrib/perl/lib/Filter/
trunk/contrib/perl/lib/Getopt/Long/
trunk/contrib/perl/lib/Getopt/Long.pm
trunk/contrib/perl/lib/I18N/
trunk/contrib/perl/lib/IO/
trunk/contrib/perl/lib/IPC/
trunk/contrib/perl/lib/Locale/
trunk/contrib/perl/lib/Log/
trunk/contrib/perl/lib/Math/
trunk/contrib/perl/lib/Memoize/
trunk/contrib/perl/lib/Memoize.pm
trunk/contrib/perl/lib/Module/
trunk/contrib/perl/lib/NEXT/
trunk/contrib/perl/lib/NEXT.pm
trunk/contrib/perl/lib/Net/Cmd.pm
trunk/contrib/perl/lib/Net/Config.eg
trunk/contrib/perl/lib/Net/Config.pm
trunk/contrib/perl/lib/Net/Domain.pm
trunk/contrib/perl/lib/Net/FTP/
trunk/contrib/perl/lib/Net/FTP.pm
trunk/contrib/perl/lib/Net/Hostname.pm.eg
trunk/contrib/perl/lib/Net/NNTP.pm
trunk/contrib/perl/lib/Net/Netrc.pm
trunk/contrib/perl/lib/Net/POP3.pm
trunk/contrib/perl/lib/Net/Ping/
trunk/contrib/perl/lib/Net/Ping.pm
trunk/contrib/perl/lib/Net/README
trunk/contrib/perl/lib/Net/SMTP.pm
trunk/contrib/perl/lib/Net/Time.pm
trunk/contrib/perl/lib/Net/demos/
trunk/contrib/perl/lib/Net/libnetFAQ.pod
trunk/contrib/perl/lib/Net/t/
trunk/contrib/perl/lib/Object/
trunk/contrib/perl/lib/Package/
trunk/contrib/perl/lib/Params/
trunk/contrib/perl/lib/Parse/
trunk/contrib/perl/lib/PerlIO/
trunk/contrib/perl/lib/Pod/Checker.pm
trunk/contrib/perl/lib/Pod/Escapes/
trunk/contrib/perl/lib/Pod/Escapes.pm
trunk/contrib/perl/lib/Pod/Find.pm
trunk/contrib/perl/lib/Pod/Functions.pm
trunk/contrib/perl/lib/Pod/Html.pm
trunk/contrib/perl/lib/Pod/InputObjects.pm
trunk/contrib/perl/lib/Pod/LaTeX.pm
trunk/contrib/perl/lib/Pod/Man.pm
trunk/contrib/perl/lib/Pod/ParseLink.pm
trunk/contrib/perl/lib/Pod/ParseUtils.pm
trunk/contrib/perl/lib/Pod/Parser.pm
trunk/contrib/perl/lib/Pod/Perldoc/
trunk/contrib/perl/lib/Pod/Perldoc.pm
trunk/contrib/perl/lib/Pod/PlainText.pm
trunk/contrib/perl/lib/Pod/Plainer.pm
trunk/contrib/perl/lib/Pod/Select.pm
trunk/contrib/perl/lib/Pod/Simple/
trunk/contrib/perl/lib/Pod/Simple.pm
trunk/contrib/perl/lib/Pod/Simple.pod
trunk/contrib/perl/lib/Pod/Text/
trunk/contrib/perl/lib/Pod/Text.pm
trunk/contrib/perl/lib/Pod/Usage.pm
trunk/contrib/perl/lib/Pod/t/Functions.t
trunk/contrib/perl/lib/Pod/t/basic.cap
trunk/contrib/perl/lib/Pod/t/basic.clr
trunk/contrib/perl/lib/Pod/t/basic.man
trunk/contrib/perl/lib/Pod/t/basic.ovr
trunk/contrib/perl/lib/Pod/t/basic.pod
trunk/contrib/perl/lib/Pod/t/basic.t
trunk/contrib/perl/lib/Pod/t/basic.txt
trunk/contrib/perl/lib/Pod/t/color.t
trunk/contrib/perl/lib/Pod/t/contains_pod.t
trunk/contrib/perl/lib/Pod/t/eol.t
trunk/contrib/perl/lib/Pod/t/filehandle.t
trunk/contrib/perl/lib/Pod/t/htmlescp.pod
trunk/contrib/perl/lib/Pod/t/htmlescp.t
trunk/contrib/perl/lib/Pod/t/htmllink.pod
trunk/contrib/perl/lib/Pod/t/htmllink.t
trunk/contrib/perl/lib/Pod/t/htmlview.pod
trunk/contrib/perl/lib/Pod/t/htmlview.t
trunk/contrib/perl/lib/Pod/t/man-options.t
trunk/contrib/perl/lib/Pod/t/man-utf8.t
trunk/contrib/perl/lib/Pod/t/man.t
trunk/contrib/perl/lib/Pod/t/parselink.t
trunk/contrib/perl/lib/Pod/t/pod-parser.t
trunk/contrib/perl/lib/Pod/t/pod-spelling.t
trunk/contrib/perl/lib/Pod/t/pod.t
trunk/contrib/perl/lib/Pod/t/pod2html-lib.pl
trunk/contrib/perl/lib/Pod/t/pod2latex.t
trunk/contrib/perl/lib/Pod/t/termcap.t
trunk/contrib/perl/lib/Pod/t/text-encoding.t
trunk/contrib/perl/lib/Pod/t/text-options.t
trunk/contrib/perl/lib/Pod/t/text-utf8.t
trunk/contrib/perl/lib/Pod/t/text.t
trunk/contrib/perl/lib/Pod/t/user.t
trunk/contrib/perl/lib/Search/
trunk/contrib/perl/lib/SelfLoader/
trunk/contrib/perl/lib/SelfLoader-buggy.t
trunk/contrib/perl/lib/SelfLoader.pm
trunk/contrib/perl/lib/SelfLoader.t
trunk/contrib/perl/lib/Shell.pm
trunk/contrib/perl/lib/Shell.t
trunk/contrib/perl/lib/Switch/
trunk/contrib/perl/lib/Switch.pm
trunk/contrib/perl/lib/Term/
Deleted: trunk/contrib/perl/cpan/List-Util/t/p_openhan.t
===================================================================
--- trunk/contrib/perl/cpan/List-Util/t/p_openhan.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/List-Util/t/p_openhan.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,7 +0,0 @@
-#!./perl
-
-# force perl-only version to be tested
-$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
-
-(my $f = __FILE__) =~ s/p_//;
-do $f; die $@ if $@;
Deleted: trunk/contrib/perl/cpan/List-Util/t/p_reduce.t
===================================================================
--- trunk/contrib/perl/cpan/List-Util/t/p_reduce.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/List-Util/t/p_reduce.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,8 +0,0 @@
-#!./perl
-
-# force perl-only version to be tested
-$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
-
-(my $f = __FILE__) =~ s/p_//;
-$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once!
-do $f; die $@ if $@;
Deleted: trunk/contrib/perl/cpan/List-Util/t/p_reftype.t
===================================================================
--- trunk/contrib/perl/cpan/List-Util/t/p_reftype.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/List-Util/t/p_reftype.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,7 +0,0 @@
-#!./perl
-
-# force perl-only version to be tested
-$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
-
-(my $f = __FILE__) =~ s/p_//;
-do $f; die $@ if $@;
Deleted: trunk/contrib/perl/cpan/List-Util/t/p_sum.t
===================================================================
--- trunk/contrib/perl/cpan/List-Util/t/p_sum.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/List-Util/t/p_sum.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,7 +0,0 @@
-#!./perl
-
-# force perl-only version to be tested
-$List::Util::TESTING_PERL_ONLY = $List::Util::TESTING_PERL_ONLY = 1;
-
-(my $f = __FILE__) =~ s/p_//;
-do $f; die $@ if $@;
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/p2u_data.pl
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/p2u_data.pl 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/p2u_data.pl 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,18 +0,0 @@
-use Pod::Usage;
-pod2usage(-verbose => 2, -exit => 17, -input => \*DATA);
-
-__DATA__
-=head1 NAME
-
-Test
-
-=head1 SYNOPSIS
-
-perl podusagetest.pl
-
-=head1 DESCRIPTION
-
-This is a test.
-
-=cut
-
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage.t
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,18 +0,0 @@
-BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-=include pod2usage.PL
-
-
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage.xr
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage.xr 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage.xr 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,57 +0,0 @@
-###### begin =include pod2usage.PL #####
-NAME
- pod2usage - print usage messages from embedded pod docs in files
-
-SYNOPSIS
- pod2usage [-help] [-man] [-exit *exitval*] [-output *outfile*]
- [-verbose *level*] [-pathlist *dirlist*] *file*
-
-OPTIONS AND ARGUMENTS
- -help Print a brief help message and exit.
-
- -man Print this command's manual page and exit.
-
- -exit *exitval*
- The exit status value to return.
-
- -output *outfile*
- The output file to print to. If the special names "-" or ">&1"
- or ">&STDOUT" are used then standard output is used. If ">&2" or
- ">&STDERR" is used then standard error is used.
-
- -verbose *level*
- The desired level of verbosity to use:
-
- 1 : print SYNOPSIS only
- 2 : print SYNOPSIS sections and any OPTIONS/ARGUMENTS sections
- 3 : print the entire manpage (similar to running pod2text)
-
- -pathlist *dirlist*
- Specifies one or more directories to search for the input file
- if it was not supplied with an absolute path. Each directory
- path in the given list should be separated by a ':' on Unix (';'
- on MSWin32 and DOS).
-
- *file* The pathname of a file containing pod documentation to be output
- in usage message format (defaults to standard input).
-
-DESCRIPTION
- pod2usage will read the given input file looking for pod documentation
- and will print the corresponding usage message. If no input file is
- specified then standard input is read.
-
- pod2usage invokes the pod2usage() function in the Pod::Usage module.
- Please see the pod2usage() entry in the Pod::Usage manpage.
-
-SEE ALSO
- the Pod::Usage manpage, the pod2text(1) manpage
-
-AUTHOR
- Please report bugs using http://rt.cpan.org.
-
- Brad Appleton <bradapp at enteract.com>
-
- Based on code for pod2text(1) written by Tom Christiansen
- <tchrist at mox.perl.com>
-
-###### end =include pod2usage.PL #####
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage2.t
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage2.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/pod2usage2.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,357 +0,0 @@
-#!/usr/bin/perl -w
-
-use Test::More;
-use strict;
-
-BEGIN {
- if ($^O eq 'MSWin32' || $^O eq 'VMS') {
- plan skip_all => "Not portable on Win32 or VMS\n";
- }
- else {
- plan tests => 34;
- }
- use_ok ("Pod::Usage");
-}
-
-sub getoutput
-{
- my ($code) = @_;
- my $pid = open(TEST_IN, "-|");
- unless(defined $pid) {
- die "Cannot fork: $!";
- }
- if($pid) {
- # parent
- my @out = <TEST_IN>;
- close(TEST_IN);
- my $exit = $?>>8;
- s/^/#/ for @out;
- local $" = "";
- print "#EXIT=$exit OUTPUT=+++#@out#+++\n";
- return($exit, join("", at out));
- }
- # child
- open(STDERR, ">&STDOUT");
- Test::More->builder->no_ending(1);
- &$code;
- print "--NORMAL-RETURN--\n";
- exit 0;
-}
-
-sub compare
-{
- my ($left,$right) = @_;
- $left =~ s/^#\s+/#/gm;
- $right =~ s/^#\s+/#/gm;
- $left =~ s/\s+/ /gm;
- $right =~ s/\s+/ /gm;
- $left eq $right;
-}
-
-SKIP: {
-if('Pod::Usage'->isa('Pod::Text') && $Pod::Text::VERSION < 2.18) {
- skip("Formatting with Pod::Text $Pod::Text::VERSION not reliable", 33);
-}
-
-my ($exit, $text) = getoutput( sub { pod2usage() } );
-is ($exit, 2, "Exit status pod2usage ()");
-ok (compare ($text, <<'EOT'), "Output test pod2usage ()");
-#Usage:
-# frobnicate [ -r | --recursive ] [ -f | --force ] file ...
-#
-EOT
-
-($exit, $text) = getoutput( sub { pod2usage(
- -message => 'You naughty person, what did you say?',
- -verbose => 1 ) });
-is ($exit, 1, "Exit status pod2usage (-message => '...', -verbose => 1)");
-ok (compare ($text, <<'EOT'), "Output test pod2usage (-message => '...', -verbose => 1)") or diag("Got:\n$text\n");
-#You naughty person, what did you say?
-# Usage:
-# frobnicate [ -r | --recursive ] [ -f | --force ] file ...
-#
-# Options:
-# -r | --recursive
-# Run recursively.
-#
-# -f | --force
-# Just do it!
-#
-# -n number
-# Specify number of frobs, default is 42.
-#
-EOT
-
-($exit, $text) = getoutput( sub { pod2usage(
- -verbose => 2, -exit => 42 ) } );
-is ($exit, 42, "Exit status pod2usage (-verbose => 2, -exit => 42)");
-ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -exit => 42)");
-#NAME
-# frobnicate - do what I mean
-#
-# SYNOPSIS
-# frobnicate [ -r | --recursive ] [ -f | --force ] file ...
-#
-# DESCRIPTION
-# frobnicate does foo and bar and what not.
-#
-# OPTIONS
-# -r | --recursive
-# Run recursively.
-#
-# -f | --force
-# Just do it!
-#
-# -n number
-# Specify number of frobs, default is 42.
-#
-EOT
-
-($exit, $text) = getoutput( sub { pod2usage(0) } );
-is ($exit, 0, "Exit status pod2usage (0)");
-ok (compare ($text, <<'EOT'), "Output test pod2usage (0)");
-#Usage:
-# frobnicate [ -r | --recursive ] [ -f | --force ] file ...
-#
-# Options:
-# -r | --recursive
-# Run recursively.
-#
-# -f | --force
-# Just do it!
-#
-# -n number
-# Specify number of frobs, default is 42.
-#
-EOT
-
-($exit, $text) = getoutput( sub { pod2usage(42) } );
-is ($exit, 42, "Exit status pod2usage (42)");
-ok (compare ($text, <<'EOT'), "Output test pod2usage (42)");
-#Usage:
-# frobnicate [ -r | --recursive ] [ -f | --force ] file ...
-#
-EOT
-
-($exit, $text) = getoutput( sub { pod2usage(-verbose => 0, -exit => 'NOEXIT') } );
-is ($exit, 0, "Exit status pod2usage (-verbose => 0, -exit => 'NOEXIT')");
-ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 0, -exit => 'NOEXIT')");
-#Usage:
-# frobnicate [ -r | --recursive ] [ -f | --force ] file ...
-#
-# --NORMAL-RETURN--
-EOT
-
-($exit, $text) = getoutput( sub { pod2usage(-verbose => 99, -sections => 'DESCRIPTION') } );
-is ($exit, 1, "Exit status pod2usage (-verbose => 99, -sections => 'DESCRIPTION')");
-ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 99, -sections => 'DESCRIPTION')");
-#Description:
-# frobnicate does foo and bar and what not.
-#
-EOT
-
-# does the __DATA__ work ok as input
-my (@blib, $test_script, $pod_file1, , $pod_file2);
-if (!$ENV{PERL_CORE}) {
- @blib = '-Mblib';
-}
-$test_script = File::Spec->catfile(qw(t pod p2u_data.pl));
-$pod_file1 = File::Spec->catfile(qw(t pod usage.pod));
-$pod_file2 = File::Spec->catfile(qw(t pod usage2.pod));
-
-
-($exit, $text) = getoutput( sub { system($^X, @blib, $test_script); exit($? >> 8); } );
-$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-is ($exit, 17, "Exit status pod2usage (-verbose => 2, -input => \*DATA)");
-ok (compare ($text, <<'EOT'), "Output test pod2usage (-verbose => 2, -input => \*DATA)") or diag "Got:\n$text\n";
-#NAME
-# Test
-#
-#SYNOPSIS
-# perl podusagetest.pl
-#
-#DESCRIPTION
-# This is a test.
-#
-EOT
-
-# test that SYNOPSIS and USAGE are printed
-($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1,
- -exitval => 0, -verbose => 0); });
-$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-is ($exit, 0, "Exit status pod2usage with USAGE");
-ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE") or diag "Got:\n$text\n";
-#Usage:
-# This is a test for CPAN#33020
-#
-#Usage:
-# And this will be also printed.
-#
-EOT
-
-# test that SYNOPSIS and USAGE are printed with options
-($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1,
- -exitval => 0, -verbose => 1); });
-$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-is ($exit, 0, "Exit status pod2usage with USAGE and verbose=1");
-ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=1") or diag "Got:\n$text\n";
-#Usage:
-# This is a test for CPAN#33020
-#
-#Usage:
-# And this will be also printed.
-#
-#Options:
-# And this with verbose == 1
-#
-EOT
-
-# test that only USAGE is printed when requested
-($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file1,
- -exitval => 0, -verbose => 99, -sections => 'USAGE'); });
-$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-is ($exit, 0, "Exit status pod2usage with USAGE and verbose=99");
-ok (compare ($text, <<'EOT'), "Output test pod2usage with USAGE and verbose=99") or diag "Got:\n$text\n";
-#Usage:
-# This is a test for CPAN#33020
-#
-EOT
-
-# test with pod_where
-use_ok('Pod::Find', qw(pod_where));
-
-($exit, $text) = getoutput( sub { pod2usage( -input => pod_where({-inc => 1}, 'Pod::Usage'),
- -exitval => 0, -verbose => 0) } );
-$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-is ($exit, 0, "Exit status pod2usage with Pod::Find");
-ok (compare ($text, <<'EOT'), "Output test pod2usage with Pod::Find") or diag "Got:\n$text\n";
-#Usage:
-# use Pod::Usage
-#
-# my $message_text = "This text precedes the usage message.";
-# my $exit_status = 2; ## The exit status to use
-# my $verbose_level = 0; ## The verbose level to use
-# my $filehandle = \*STDERR; ## The filehandle to write to
-#
-# pod2usage($message_text);
-#
-# pod2usage($exit_status);
-#
-# pod2usage( { -message => $message_text ,
-# -exitval => $exit_status ,
-# -verbose => $verbose_level,
-# -output => $filehandle } );
-#
-# pod2usage( -msg => $message_text ,
-# -exitval => $exit_status ,
-# -verbose => $verbose_level,
-# -output => $filehandle );
-#
-# pod2usage( -verbose => 2,
-# -noperldoc => 1 )
-#
-EOT
-
-# verify that sections are correctly found after nested headings
-($exit, $text) = getoutput( sub { pod2usage(-input => $pod_file2,
- -exitval => 0, -verbose => 99,
- -sections => [qw(BugHeader BugHeader/.*')]) });
-$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-is ($exit, 0, "Exit status pod2usage with nested headings");
-ok (compare ($text, <<'EOT'), "Output test pod2usage with nested headings") or diag "Got:\n$text\n";
-#BugHeader:
-# Some text
-#
-# BugHeader2:
-# More
-# Still More
-#
-EOT
-
-# Verify that =over =back work OK
-($exit, $text) = getoutput( sub {
- pod2usage(-input => $pod_file2,
- -exitval => 0, -verbose => 99, -sections => 'BugHeader/BugHeader2') } );
-$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-is ($exit, 0, "Exit status pod2usage with over/back");
-ok (compare ($text, <<'EOT'), "Output test pod2usage with over/back") or diag "Got:\n$text\n";
-# BugHeader2:
-# More
-# Still More
-#
-EOT
-
-# new array API for -sections
-($exit, $text) = getoutput( sub {
- pod2usage(-input => $pod_file2,
- -exitval => 0, -verbose => 99, -sections => [qw(Heading-1/!.+ Heading-2/.+)]) } );
-$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-is ($exit, 0, "Exit status pod2usage with -sections => []");
-ok (compare ($text, <<'EOT'), "Output test pod2usage with -sections => []") or diag "Got:\n$text\n";
-#Heading-1:
-# One
-# Two
-#
-# Heading-2.2:
-# More text.
-#
-EOT
-
-# allow subheadings in OPTIONS and ARGUMENTS
-($exit, $text) = getoutput( sub {
- pod2usage(-input => $pod_file2,
- -exitval => 0, -verbose => 1) } );
-$text =~ s{#Using.*/blib.*\n}{}; # older blib's emit something to STDERR
-$text =~ s{[*](destination|files)[*]}{$1}g; # strip * chars
-is ($exit, 0, "Exit status pod2usage with subheadings in OPTIONS");
-ok (compare ($text, <<'EOT'), "Output test pod2usage with subheadings in OPTIONS") or diag "Got:\n$text\n";
-#Options and Arguments:
-# Arguments:
-# The required arguments (which typically follow any options on the
-# command line) are:
-#
-# destination
-# files
-#
-# Options:
-# Options may be abbreviated. Options which take values may be separated
-# from the values by whitespace or the "=" character.
-#
-EOT
-} # end SKIP
-
-__END__
-
-=head1 NAME
-
-frobnicate - do what I mean
-
-=head1 SYNOPSIS
-
-B<frobnicate> S<[ B<-r> | B<--recursive> ]> S<[ B<-f> | B<--force> ]>
- file ...
-
-=head1 DESCRIPTION
-
-B<frobnicate> does foo and bar and what not.
-
-=head1 OPTIONS
-
-=over 4
-
-=item B<-r> | B<--recursive>
-
-Run recursively.
-
-=item B<-f> | B<--force>
-
-Just do it!
-
-=item B<-n> number
-
-Specify number of frobs, default is 42.
-
-=back
-
-=cut
-
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/podchkenc.t
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/podchkenc.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/podchkenc.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,29 +0,0 @@
-#!/usr/bin/perl
-BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testpchk.pl";
- import TestPodChecker;
-}
-
-# this tests Pod::Checker accepts =encoding directive
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodchecker \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-__END__
-
-=encoding utf8
-
-=encode utf8
-
-dummy error
-
-=head1 An example.
-
-'Twas brillig, and the slithy toves did gyre and gimble in the wabe.
-
-=cut
-
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/podchkenc.xr
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/podchkenc.xr 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/podchkenc.xr 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1 +0,0 @@
-*** ERROR: Unknown command 'encode' at line 20 in file t/pod/podchkenc.t
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/poderrs.t
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/poderrs.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/poderrs.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,209 +0,0 @@
-BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testpchk.pl";
- import TestPodChecker;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodchecker \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-### Deliberately throw in some blank but non-empty lines
-
-### The above line should contain spaces
-
-
-__END__
-
-=head2 This should cause a warning
-
-=head1 NAME
-
-poderrors.t - test Pod::Checker on some pod syntax errors
-
-=unknown1 this is an unknown command with two N<unknownA>
-and D<unknownB> interior sequences.
-
-This is some paragraph text with some unknown interior sequences,
-such as Q<unknown2>,
-A<unknown3>,
-and Y<unknown4 V<unknown5>>.
-
-Now try some unterminated sequences like
-I<hello mudda!
-B<hello fadda!
-
-Here I am at C<camp granada!
-
-Camps is very,
-entertaining.
-And they say we'll have some fun if it stops raining!
-
-Okay, now use a non-empty blank line to terminate a paragraph and make
-sure we get a warning.
-
-The above blank line contains tabs and spaces only
-
-=head1 Additional tests
-
-=head2 item without over
-
-=item oops
-
-=head2 back without over
-
-=back
-
-=head2 over without back
-
-=over 4
-
-=item aaps
-
-=head2 end without begin
-
-=end
-
-=head2 begin and begin
-
-=begin html
-
-=begin text
-
-=end
-
-=end
-
-second one results in end w/o begin
-
-=head2 begin w/o formatter
-
-=begin
-
-=end
-
-=head2 for w/o formatter
-
-=for
-
-something...
-
-=head2 Nested sequences of the same type
-
-C<code I<italic C<code again!>>>
-
-=head2 Garbled entities
-
-E<alea iacta est>
-E<C<auml>>
-E<abcI<bla>>
-E<0x100>
-E<07777>
-E<300>
-
-=head2 Unresolved internal links
-
-L</"begin or begin">
-L<"end with begin">
-L</OoPs>
-
-=head2 Some links with problems
-
-L<abc
-def>
-L<>
-L< aha>
-L<oho >
-L<"Warnings"> this one is ok
-L</unescaped> ok too, this POD has an X of the same name
-
-=head2 Warnings
-
-L<passwd(5)>
-L<some text with / in it|perlvar/$|> should give warnings as hell
-
-=over 4
-
-=item bla
-
-=back 200
-
-the 200 is evil
-
-=begin html
-
-What?
-
-=end xml
-
-X<unescaped>see these unescaped < and > in the text?
-
-=head2 Misc
-
-Z<ddd> should be empty
-
-X<> should not be empty
-
-=over four
-
-This paragrapgh is misplaced - it ought to be an item.
-
-=item four should be numeric!
-
-=item
-
-=item blah
-
-=item previous is all empty!!!
-
-=back
-
-All empty over/back:
-
-=over 4
-
-=back
-
-item w/o name
-
-=cut
-
-=pod bla
-
-bla is evil
-
-=cut blub
-
-blub is evil
-
-=head2 reoccurence
-
-=over 4
-
-=item Misc
-
-we already have a head Misc
-
-=back
-
-=head2 some heading
-
-=head2 another one
-
-previous section is empty!
-
-=head1 LINK TESTS
-
-Due to bug reported by Rafael Garcia-Suarez "rgarciasuarez at free.fr":
-
-The following hyperlinks :
-L<"I/O Operators">
-L<perlop/"I/O Operators">
-trigger a podchecker warning (using bleadperl) :
- node 'I/O Operators' contains non-escaped | or /
-
-=cut
-
-
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/poderrs.xr
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/poderrs.xr 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/poderrs.xr 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,47 +0,0 @@
-*** WARNING: =head2 without preceding higher level at line 20 in file t/pod/poderrs.t
-*** WARNING: empty section in previous paragraph at line 22 in file t/pod/poderrs.t
-*** ERROR: Unknown command 'unknown1' at line 26 in file t/pod/poderrs.t
-*** ERROR: Unknown interior-sequence 'Q' at line 30 in file t/pod/poderrs.t
-*** ERROR: Unknown interior-sequence 'A' at line 31 in file t/pod/poderrs.t
-*** ERROR: Unknown interior-sequence 'Y' at line 32 in file t/pod/poderrs.t
-*** ERROR: Unknown interior-sequence 'V' at line 32 in file t/pod/poderrs.t
-*** ERROR: unterminated B<...> at line 36 in file t/pod/poderrs.t
-*** ERROR: unterminated I<...> at line 35 in file t/pod/poderrs.t
-*** ERROR: unterminated C<...> at line 38 in file t/pod/poderrs.t
-*** WARNING: line containing nothing but whitespace in paragraph at line 46 in file t/pod/poderrs.t
-*** ERROR: =item without previous =over at line 53 in file t/pod/poderrs.t
-*** ERROR: =back without previous =over at line 57 in file t/pod/poderrs.t
-*** ERROR: =over on line 61 without closing =back (at head2) at line 65 in file t/pod/poderrs.t
-*** ERROR: =end without =begin at line 67 in file t/pod/poderrs.t
-*** ERROR: Nested =begin's (first at line 71:html) at line 73 in file t/pod/poderrs.t
-*** ERROR: =end without =begin at line 77 in file t/pod/poderrs.t
-*** ERROR: No argument for =begin at line 83 in file t/pod/poderrs.t
-*** ERROR: =for without formatter specification at line 89 in file t/pod/poderrs.t
-*** WARNING: nested commands C<...C<...>...> at line 95 in file t/pod/poderrs.t
-*** ERROR: garbled entity E<alea iacta est> at line 99 in file t/pod/poderrs.t
-*** ERROR: garbled entity E<C<auml>> at line 100 in file t/pod/poderrs.t
-*** ERROR: garbled entity E<abcI<bla>> at line 101 in file t/pod/poderrs.t
-*** ERROR: Entity number out of range E<0x100> at line 102 in file t/pod/poderrs.t
-*** ERROR: Entity number out of range E<07777> at line 103 in file t/pod/poderrs.t
-*** ERROR: Entity number out of range E<300> at line 104 in file t/pod/poderrs.t
-*** ERROR: malformed link L<> : empty link at line 116 in file t/pod/poderrs.t
-*** WARNING: ignoring leading whitespace in link at line 117 in file t/pod/poderrs.t
-*** WARNING: ignoring trailing whitespace in link at line 118 in file t/pod/poderrs.t
-*** WARNING: (section) in 'passwd(5)' deprecated at line 124 in file t/pod/poderrs.t
-*** WARNING: node '$|' contains non-escaped | or / at line 125 in file t/pod/poderrs.t
-*** WARNING: alternative text '$|' contains non-escaped | or / at line 125 in file t/pod/poderrs.t
-*** ERROR: Spurious character(s) after =back at line 131 in file t/pod/poderrs.t
-*** ERROR: Nonempty Z<> at line 145 in file t/pod/poderrs.t
-*** ERROR: Empty X<> at line 147 in file t/pod/poderrs.t
-*** WARNING: preceding non-item paragraph(s) at line 153 in file t/pod/poderrs.t
-*** WARNING: No argument for =item at line 155 in file t/pod/poderrs.t
-*** WARNING: previous =item has no contents at line 157 in file t/pod/poderrs.t
-*** WARNING: No items in =over (at line 165) / =back list at line 167 in file t/pod/poderrs.t
-*** ERROR: Spurious text after =pod at line 173 in file t/pod/poderrs.t
-*** ERROR: Spurious text after =cut at line 177 in file t/pod/poderrs.t
-*** WARNING: empty section in previous paragraph at line 193 in file t/pod/poderrs.t
-*** ERROR: unresolved internal link 'begin or begin' at line 108 in file t/pod/poderrs.t
-*** ERROR: unresolved internal link 'end with begin' at line 109 in file t/pod/poderrs.t
-*** ERROR: unresolved internal link 'OoPs' at line 110 in file t/pod/poderrs.t
-*** ERROR: unresolved internal link 'abc def' at line 114 in file t/pod/poderrs.t
-*** ERROR: unresolved internal link 'I/O Operators' at line 202 in file t/pod/poderrs.t
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/usage.pod
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/usage.pod 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/usage.pod 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,18 +0,0 @@
-=head1 NAME
-
-usage.pod - example for testing USAGE and SYNOPSIS
-
-=head1 USAGE
-
-This is a test for CPAN#33020
-
-=head1 SYNOPSIS
-
-And this will be also printed.
-
-=head1 OPTIONS
-
-And this with verbose == 1
-
-=cut
-
Deleted: trunk/contrib/perl/cpan/Pod-Parser/t/pod/usage2.pod
===================================================================
--- trunk/contrib/perl/cpan/Pod-Parser/t/pod/usage2.pod 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Pod-Parser/t/pod/usage2.pod 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,56 +0,0 @@
-=head1 Heading-1
-
-=over 100
-
-=item One
-
-=item Two
-
-=back
-
-=head2 Heading 2
-
-Some text
-
-=head1 BugHeader
-
-Some text
-
-=head2 BugHeader2
-
-=over 4
-
-=item More
-
-=item Still More
-
-=back
-
-=head1 Heading-2
-
-=head2 Heading-2.2
-
-More text.
-
-=head1 OPTIONS AND ARGUMENTS
-
-=head2 Arguments
-
-The required arguments (which typically follow any options on the
-command line) are:
-
-=over
-
-=item I<destination>
-
-=item I<files>
-
-=back
-
-=head2 Options
-
-Options may be abbreviated. Options which take values may be separated
-from the values by whitespace or the "=" character.
-
-=cut
-
Deleted: trunk/contrib/perl/cpan/Time-HiRes/t/HiRes.t
===================================================================
--- trunk/contrib/perl/cpan/Time-HiRes/t/HiRes.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Time-HiRes/t/HiRes.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,828 +0,0 @@
-#!./perl -w
-
-BEGIN {
- if ($ENV{PERL_CORE}) {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- if (" $Config{'extensions'} " !~ m[ Time/HiRes ]) {
- print "1..0 # Skip -- Perl configured without Time::HiRes module\n";
- exit 0;
- }
- }
-}
-
-BEGIN { $| = 1; print "1..48\n"; }
-
-END { print "not ok 1\n" unless $loaded }
-
-use Time::HiRes 1.9704; # Remember to bump this once in a while.
-use Time::HiRes qw(tv_interval);
-
-$loaded = 1;
-
-print "ok 1\n";
-
-use strict;
-
-my $have_gettimeofday = &Time::HiRes::d_gettimeofday;
-my $have_usleep = &Time::HiRes::d_usleep;
-my $have_nanosleep = &Time::HiRes::d_nanosleep;
-my $have_ualarm = &Time::HiRes::d_ualarm;
-my $have_clock_gettime = &Time::HiRes::d_clock_gettime;
-my $have_clock_getres = &Time::HiRes::d_clock_getres;
-my $have_clock_nanosleep = &Time::HiRes::d_clock_nanosleep;
-my $have_clock = &Time::HiRes::d_clock;
-my $have_hires_stat = &Time::HiRes::d_hires_stat;
-
-sub has_symbol {
- my $symbol = shift;
- eval "use Time::HiRes qw($symbol)";
- return 0 unless $@ eq '';
- eval "my \$a = $symbol";
- return $@ eq '';
-}
-
-printf "# have_gettimeofday = %d\n", $have_gettimeofday;
-printf "# have_usleep = %d\n", $have_usleep;
-printf "# have_nanosleep = %d\n", $have_nanosleep;
-printf "# have_ualarm = %d\n", $have_ualarm;
-printf "# have_clock_gettime = %d\n", $have_clock_gettime;
-printf "# have_clock_getres = %d\n", $have_clock_getres;
-printf "# have_clock_nanosleep = %d\n", $have_clock_nanosleep;
-printf "# have_clock = %d\n", $have_clock;
-printf "# have_hires_stat = %d\n", $have_hires_stat;
-
-import Time::HiRes 'gettimeofday' if $have_gettimeofday;
-import Time::HiRes 'usleep' if $have_usleep;
-import Time::HiRes 'nanosleep' if $have_nanosleep;
-import Time::HiRes 'ualarm' if $have_ualarm;
-import Time::HiRes 'clock_gettime' if $have_clock_gettime;
-import Time::HiRes 'clock_getres' if $have_clock_getres;
-import Time::HiRes 'clock_nanosleep' if $have_clock_nanosleep;
-import Time::HiRes 'clock' if $have_clock;
-
-use Config;
-
-use Time::HiRes qw(gettimeofday);
-
-my $have_alarm = $Config{d_alarm};
-my $have_fork = $Config{d_fork};
-my $waitfor = 360; # 30-45 seconds is normal (load affects this).
-my $timer_pid;
-my $TheEnd;
-
-if ($have_fork) {
- print "# I am the main process $$, starting the timer process...\n";
- $timer_pid = fork();
- if (defined $timer_pid) {
- if ($timer_pid == 0) { # We are the kid, set up the timer.
- my $ppid = getppid();
- print "# I am the timer process $$, sleeping for $waitfor seconds...\n";
- sleep($waitfor - 2); # Workaround for perlbug #49073
- sleep(2); # Wait for parent to exit
- if (kill(0, $ppid)) { # Check if parent still exists
- warn "\n$0: overall time allowed for tests (${waitfor}s) exceeded!\n";
- print "# Terminating main process $ppid...\n";
- kill('KILL', $ppid);
- print "# This is the timer process $$, over and out.\n";
- }
- exit(0);
- } else {
- print "# The timer process $timer_pid launched, continuing testing...\n";
- $TheEnd = time() + $waitfor;
- }
- } else {
- warn "$0: fork failed: $!\n";
- }
-} else {
- print "# No timer process (need fork)\n";
-}
-
-my $xdefine = '';
-
-if (open(XDEFINE, "xdefine")) {
- chomp($xdefine = <XDEFINE> || "");
- close(XDEFINE);
-}
-
-# Ideally, we'd like to test that the timers are rather precise.
-# However, if the system is busy, there are no guarantees on how
-# quickly we will return. This limit used to be 10%, but that
-# was occasionally triggered falsely.
-# So let's try 25%.
-# Another possibility might be to print "ok" if the test completes fine
-# with (say) 10% slosh, "skip - system may have been busy?" if the test
-# completes fine with (say) 30% slosh, and fail otherwise. If you do that,
-# consider changing over to test.pl at the same time.
-# --A.D., Nov 27, 2001
-my $limit = 0.25; # 25% is acceptable slosh for testing timers
-
-sub skip {
- map { print "ok $_ # skipped\n" } @_;
-}
-
-sub ok {
- my ($n, $result, @info) = @_;
- if ($result) {
- print "ok $n\n";
- }
- else {
- print "not ok $n\n";
- print "# @info\n" if @info;
- }
-}
-
-unless ($have_gettimeofday) {
- skip 2..6;
-}
-else {
- my @one = gettimeofday();
- ok 2, @one == 2, 'gettimeofday returned ', 0+ at one, ' args';
- ok 3, $one[0] > 850_000_000, "@one too small";
-
- sleep 1;
-
- my @two = gettimeofday();
- ok 4, ($two[0] > $one[0] || ($two[0] == $one[0] && $two[1] > $one[1])),
- "@two is not greater than @one";
-
- my $f = Time::HiRes::time();
- ok 5, $f > 850_000_000, "$f too small";
- ok 6, $f - $two[0] < 2, "$f - $two[0] >= 2";
-}
-
-unless ($have_usleep) {
- skip 7..8;
-}
-else {
- use Time::HiRes qw(usleep);
- my $one = time;
- usleep(10_000);
- my $two = time;
- usleep(10_000);
- my $three = time;
- ok 7, $one == $two || $two == $three, "slept too long, $one $two $three";
-
- unless ($have_gettimeofday) {
- skip 8;
- }
- else {
- my $f = Time::HiRes::time();
- usleep(500_000);
- my $f2 = Time::HiRes::time();
- my $d = $f2 - $f;
- ok 8, $d > 0.4 && $d < 0.9, "slept $d secs $f to $f2";
- }
-}
-
-# Two-arg tv_interval() is always available.
-{
- my $f = tv_interval [5, 100_000], [10, 500_000];
- ok 9, abs($f - 5.4) < 0.001, $f;
-}
-
-unless ($have_gettimeofday) {
- skip 10;
-}
-else {
- my $r = [gettimeofday()];
- my $f = tv_interval $r;
- ok 10, $f < 2, $f;
-}
-
-unless ($have_usleep && $have_gettimeofday) {
- skip 11;
-}
-else {
- my $r = [ gettimeofday() ];
- Time::HiRes::sleep( 0.5 );
- my $f = tv_interval $r;
- ok 11, $f > 0.4 && $f < 0.9, "slept $f instead of 0.5 secs.";
-}
-
-unless ($have_ualarm && $have_alarm) {
- skip 12..13;
-}
-else {
- my $tick = 0;
- local $SIG{ ALRM } = sub { $tick++ };
-
- my $one = time; $tick = 0; ualarm(10_000); while ($tick == 0) { }
- my $two = time; $tick = 0; ualarm(10_000); while ($tick == 0) { }
- my $three = time;
- ok 12, $one == $two || $two == $three, "slept too long, $one $two $three";
- print "# tick = $tick, one = $one, two = $two, three = $three\n";
-
- $tick = 0; ualarm(10_000, 10_000); while ($tick < 3) { }
- ok 13, 1;
- ualarm(0);
- print "# tick = $tick, one = $one, two = $two, three = $three\n";
-}
-
-# Did we even get close?
-
-unless ($have_gettimeofday) {
- skip 14;
-} else {
- my ($s, $n, $i) = (0);
- for $i (1 .. 100) {
- $s += Time::HiRes::time() - time();
- $n++;
- }
- # $s should be, at worst, equal to $n
- # (time() may be rounding down, up, or closest),
- # but allow 10% of slop.
- ok 14, abs($s) / $n <= 1.10, "Time::HiRes::time() not close to time()";
- print "# s = $s, n = $n, s/n = ", abs($s)/$n, "\n";
-}
-
-my $has_ualarm = $Config{d_ualarm};
-
-$has_ualarm ||= $xdefine =~ /-DHAS_UALARM/;
-
-my $can_subsecond_alarm =
- defined &Time::HiRes::gettimeofday &&
- defined &Time::HiRes::ualarm &&
- defined &Time::HiRes::usleep &&
- $has_ualarm;
-
-unless ($can_subsecond_alarm) {
- for (15..17) {
- print "ok $_ # Skip: no gettimeofday or no ualarm or no usleep\n";
- }
-} else {
- use Time::HiRes qw(time alarm sleep);
- eval { require POSIX };
- my $use_sigaction =
- !$@ && defined &POSIX::sigaction && &POSIX::SIGALRM > 0;
-
- my ($f, $r, $i, $not, $ok);
-
- $f = time;
- print "# time...$f\n";
- print "ok 15\n";
-
- $r = [Time::HiRes::gettimeofday()];
- sleep (0.5);
- print "# sleep...", Time::HiRes::tv_interval($r), "\nok 16\n";
-
- $r = [Time::HiRes::gettimeofday()];
- $i = 5;
- my $oldaction;
- if ($use_sigaction) {
- $oldaction = new POSIX::SigAction;
- printf "# sigaction tick, ALRM = %d\n", &POSIX::SIGALRM;
-
- # Perl's deferred signals may be too wimpy to break through
- # a restartable select(), so use POSIX::sigaction if available.
-
- POSIX::sigaction(&POSIX::SIGALRM,
- POSIX::SigAction->new("tick"),
- $oldaction)
- or die "Error setting SIGALRM handler with sigaction: $!\n";
- } else {
- print "# SIG tick\n";
- $SIG{ALRM} = "tick";
- }
-
- # On VMS timers can not interrupt select.
- if ($^O eq 'VMS') {
- $ok = "Skip: VMS select() does not get interrupted.";
- } else {
- while ($i > 0) {
- alarm(0.3);
- select (undef, undef, undef, 3);
- my $ival = Time::HiRes::tv_interval ($r);
- print "# Select returned! $i $ival\n";
- print "# ", abs($ival/3 - 1), "\n";
- # Whether select() gets restarted after signals is
- # implementation dependent. If it is restarted, we
- # will get about 3.3 seconds: 3 from the select, 0.3
- # from the alarm. If this happens, let's just skip
- # this particular test. --jhi
- if (abs($ival/3.3 - 1) < $limit) {
- $ok = "Skip: your select() may get restarted by your SIGALRM (or just retry test)";
- undef $not;
- last;
- }
- my $exp = 0.3 * (5 - $i);
- if ($exp == 0) {
- $not = "while: divisor became zero";
- last;
- }
- # This test is more sensitive, so impose a softer limit.
- if (abs($ival/$exp - 1) > 4*$limit) {
- my $ratio = abs($ival/$exp);
- $not = "while: $exp sleep took $ival ratio $ratio";
- last;
- }
- $ok = $i;
- }
- }
-
- sub tick {
- $i--;
- my $ival = Time::HiRes::tv_interval ($r);
- print "# Tick! $i $ival\n";
- my $exp = 0.3 * (5 - $i);
- if ($exp == 0) {
- $not = "tick: divisor became zero";
- last;
- }
- # This test is more sensitive, so impose a softer limit.
- if (abs($ival/$exp - 1) > 4*$limit) {
- my $ratio = abs($ival/$exp);
- $not = "tick: $exp sleep took $ival ratio $ratio";
- $i = 0;
- }
- }
-
- if ($use_sigaction) {
- POSIX::sigaction(&POSIX::SIGALRM, $oldaction);
- } else {
- alarm(0); # can't cancel usig %SIG
- }
-
- print $not ? "not ok 17 # $not\n" : "ok 17 # $ok\n";
-}
-
-unless (defined &Time::HiRes::setitimer
- && defined &Time::HiRes::getitimer
- && has_symbol('ITIMER_VIRTUAL')
- && $Config{sig_name} =~ m/\bVTALRM\b/
- && $^O ne 'nto' # nto: QNX 6 has the API but no implementation
- && $^O ne 'haiku' # haiku: has the API but no implementation
- ) {
- for (18..19) {
- print "ok $_ # Skip: no virtual interval timers\n";
- }
-} else {
- use Time::HiRes qw(setitimer getitimer ITIMER_VIRTUAL);
-
- my $i = 3;
- my $r = [Time::HiRes::gettimeofday()];
-
- $SIG{VTALRM} = sub {
- $i ? $i-- : setitimer(&ITIMER_VIRTUAL, 0);
- print "# Tick! $i ", Time::HiRes::tv_interval($r), "\n";
- };
-
- print "# setitimer: ", join(" ", setitimer(ITIMER_VIRTUAL, 0.5, 0.4)), "\n";
-
- # Assume interval timer granularity of $limit * 0.5 seconds. Too bold?
- my $virt = getitimer(&ITIMER_VIRTUAL);
- print "not " unless defined $virt && abs($virt / 0.5) - 1 < $limit;
- print "ok 18\n";
-
- print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
-
- while (getitimer(&ITIMER_VIRTUAL)) {
- my $j;
- for (1..1000) { $j++ } # Can't be unbreakable, must test getitimer().
- }
-
- print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
-
- $virt = getitimer(&ITIMER_VIRTUAL);
- print "not " unless defined $virt && $virt == 0;
- print "ok 19\n";
-
- $SIG{VTALRM} = 'DEFAULT';
-}
-
-if ($have_gettimeofday &&
- $have_usleep) {
- use Time::HiRes qw(usleep);
-
- my ($t0, $td);
-
- my $sleep = 1.5; # seconds
- my $msg;
-
- $t0 = gettimeofday();
- $a = abs(sleep($sleep) / $sleep - 1.0);
- $td = gettimeofday() - $t0;
- my $ratio = 1.0 + $a;
-
- $msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
-
- if ($td < $sleep * (1 + $limit)) {
- print $a < $limit ? "ok 20 # $msg" : "not ok 20 # $msg";
- } else {
- print "ok 20 # Skip: $msg";
- }
-
- $t0 = gettimeofday();
- $a = abs(usleep($sleep * 1E6) / ($sleep * 1E6) - 1.0);
- $td = gettimeofday() - $t0;
- $ratio = 1.0 + $a;
-
- $msg = "$td went by while sleeping $sleep, ratio $ratio.\n";
-
- if ($td < $sleep * (1 + $limit)) {
- print $a < $limit ? "ok 21 # $msg" : "not ok 21 # $msg";
- } else {
- print "ok 21 # Skip: $msg";
- }
-
-} else {
- for (20..21) {
- print "ok $_ # Skip: no gettimeofday\n";
- }
-}
-
-unless ($have_nanosleep) {
- skip 22..23;
-}
-else {
- my $one = CORE::time;
- nanosleep(10_000_000);
- my $two = CORE::time;
- nanosleep(10_000_000);
- my $three = CORE::time;
- ok 22, $one == $two || $two == $three, "slept too long, $one $two $three";
-
- unless ($have_gettimeofday) {
- skip 23;
- }
- else {
- my $f = Time::HiRes::time();
- nanosleep(500_000_000);
- my $f2 = Time::HiRes::time();
- my $d = $f2 - $f;
- ok 23, $d > 0.4 && $d < 0.9, "slept $d secs $f to $f2";
- }
-}
-
-eval { sleep(-1) };
-print $@ =~ /::sleep\(-1\): negative time not invented yet/ ?
- "ok 24\n" : "not ok 24\n";
-
-eval { usleep(-2) };
-print $@ =~ /::usleep\(-2\): negative time not invented yet/ ?
- "ok 25\n" : "not ok 25\n";
-
-if ($have_ualarm) {
- eval { alarm(-3) };
- print $@ =~ /::alarm\(-3, 0\): negative time not invented yet/ ?
- "ok 26\n" : "not ok 26\n";
-
- eval { ualarm(-4) };
- print $@ =~ /::ualarm\(-4, 0\): negative time not invented yet/ ?
- "ok 27\n" : "not ok 27\n";
-} else {
- skip 26;
- skip 27;
-}
-
-if ($have_nanosleep) {
- eval { nanosleep(-5) };
- print $@ =~ /::nanosleep\(-5\): negative time not invented yet/ ?
- "ok 28\n" : "not ok 28\n";
-} else {
- skip 28;
-}
-
-# Find the loop size N (a for() loop 0..N-1)
-# that will take more than T seconds.
-
-if ($have_ualarm && $] >= 5.008001) {
- # http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3
- # Perl changes [18765] and [18770], perl bug [perl #20920]
-
- print "# Finding delay loop...\n";
-
- my $T = 0.01;
- use Time::HiRes qw(time);
- my $DelayN = 1024;
- my $i;
- N: {
- do {
- my $t0 = time();
- for ($i = 0; $i < $DelayN; $i++) { }
- my $t1 = time();
- my $dt = $t1 - $t0;
- print "# N = $DelayN, t1 = $t1, t0 = $t0, dt = $dt\n";
- last N if $dt > $T;
- $DelayN *= 2;
- } while (1);
- }
-
- # The time-burner which takes at least T (default 1) seconds.
- my $Delay = sub {
- my $c = @_ ? shift : 1;
- my $n = $c * $DelayN;
- my $i;
- for ($i = 0; $i < $n; $i++) { }
- };
-
- # Next setup a periodic timer (the two-argument alarm() of
- # Time::HiRes, behind the curtains the libc getitimer() or
- # ualarm()) which has a signal handler that takes so much time (on
- # the first initial invocation) that the first periodic invocation
- # (second invocation) will happen before the first invocation has
- # finished. In Perl 5.8.0 the "safe signals" concept was
- # implemented, with unfortunately at least one bug that caused a
- # core dump on reentering the handler. This bug was fixed by the
- # time of Perl 5.8.1.
-
- # Do not try mixing sleep() and alarm() for testing this.
-
- my $a = 0; # Number of alarms we receive.
- my $A = 2; # Number of alarms we will handle before disarming.
- # (We may well get $A + 1 alarms.)
-
- $SIG{ALRM} = sub {
- $a++;
- print "# Alarm $a - ", time(), "\n";
- alarm(0) if $a >= $A; # Disarm the alarm.
- $Delay->(2); # Try burning CPU at least for 2T seconds.
- };
-
- use Time::HiRes qw(alarm);
- alarm($T, $T); # Arm the alarm.
-
- $Delay->(10); # Try burning CPU at least for 10T seconds.
-
- print "ok 29\n"; # Not core dumping by now is considered to be the success.
-} else {
- skip 29;
-}
-
-if ($have_clock_gettime &&
- # All implementations of clock_gettime()
- # are SUPPOSED TO support CLOCK_REALTIME.
- has_symbol('CLOCK_REALTIME')) {
- my $ok = 0;
- TRY: {
- for my $try (1..3) {
- print "# CLOCK_REALTIME: try = $try\n";
- my $t0 = clock_gettime(&CLOCK_REALTIME);
- use Time::HiRes qw(sleep);
- my $T = 1.5;
- sleep($T);
- my $t1 = clock_gettime(&CLOCK_REALTIME);
- if ($t0 > 0 && $t1 > $t0) {
- print "# t1 = $t1, t0 = $t0\n";
- my $dt = $t1 - $t0;
- my $rt = abs(1 - $dt / $T);
- print "# dt = $dt, rt = $rt\n";
- if ($rt <= 2 * $limit) {
- $ok = 1;
- last TRY;
- }
- } else {
- print "# Error: t0 = $t0, t1 = $t1\n";
- }
- my $r = rand() + rand();
- printf "# Sleeping for %.6f seconds...\n", $r;
- sleep($r);
- }
- }
- if ($ok) {
- print "ok 30\n";
- } else {
- print "not ok 30\n";
- }
-} else {
- print "# No clock_gettime\n";
- skip 30;
-}
-
-if ($have_clock_getres) {
- my $tr = clock_getres();
- if ($tr > 0) {
- print "ok 31 # tr = $tr\n";
- } else {
- print "not ok 31 # tr = $tr\n";
- }
-} else {
- print "# No clock_getres\n";
- skip 31;
-}
-
-if ($have_clock_nanosleep &&
- has_symbol('CLOCK_REALTIME')) {
- my $s = 1.5e9;
- my $t = clock_nanosleep(&CLOCK_REALTIME, $s);
- my $r = abs(1 - $t / $s);
- if ($r < 2 * $limit) {
- print "ok 32\n";
- } else {
- print "not ok 32 # $t = $t, r = $r\n";
- }
-} else {
- print "# No clock_nanosleep\n";
- skip 32;
-}
-
-if ($have_clock) {
- my @clock = clock();
- print "# clock = @clock\n";
- for my $i (1..3) {
- for (my $j = 0; $j < 1e6; $j++) { }
- push @clock, clock();
- print "# clock = @clock\n";
- }
- if ($clock[0] >= 0 &&
- $clock[1] > $clock[0] &&
- $clock[2] > $clock[1] &&
- $clock[3] > $clock[2]) {
- print "ok 33\n";
- } else {
- print "not ok 33\n";
- }
-} else {
- skip 33;
-}
-
-sub bellish { # Cheap emulation of a bell curve.
- my ($min, $max) = @_;
- my $rand = ($max - $min) / 5;
- my $sum = 0;
- for my $i (0..4) {
- $sum += rand($rand);
- }
- return $min + $sum;
-}
-
-if ($have_ualarm) {
- # 1_100_000 sligthly over 1_000_000,
- # 2_200_000 slightly over 2**31/1000,
- # 4_300_000 slightly over 2**32/1000.
- for my $t ([34, 100_000],
- [35, 1_100_000],
- [36, 2_200_000],
- [37, 4_300_000]) {
- my ($i, $n) = @$t;
- my $ok;
- for my $retry (1..10) {
- my $alarmed = 0;
- local $SIG{ ALRM } = sub { $alarmed++ };
- my $t0 = Time::HiRes::time();
- print "# t0 = $t0\n";
- print "# ualarm($n)\n";
- ualarm($n); 1 while $alarmed == 0;
- my $t1 = Time::HiRes::time();
- print "# t1 = $t1\n";
- my $dt = $t1 - $t0;
- print "# dt = $dt\n";
- my $r = $dt / ($n/1e6);
- print "# r = $r\n";
- $ok =
- ($n < 1_000_000 || # Too much noise.
- ($r >= 0.8 && $r <= 1.6));
- last if $ok;
- my $nap = bellish(3, 15);
- printf "# Retrying in %.1f seconds...\n", $nap;
- Time::HiRes::sleep($nap);
- }
- ok $i, $ok, "ualarm($n) close enough";
- }
-} else {
- print "# No ualarm\n";
- skip 34..37;
-}
-
-if ($^O =~ /^(cygwin|MSWin)/) {
- print "# $^O: timestamps may not be good enough\n";
- skip 38;
-} elsif (&Time::HiRes::d_hires_stat) {
- my @stat;
- my @atime;
- my @mtime;
- for (1..5) {
- Time::HiRes::sleep(rand(0.1) + 0.1);
- open(X, ">$$");
- print X $$;
- close(X);
- @stat = Time::HiRes::stat($$);
- push @mtime, $stat[9];
- Time::HiRes::sleep(rand(0.1) + 0.1);
- open(X, "<$$");
- <X>;
- close(X);
- @stat = Time::HiRes::stat($$);
- push @atime, $stat[8];
- }
- 1 while unlink $$;
- print "# mtime = @mtime\n";
- print "# atime = @atime\n";
- my $ai = 0;
- my $mi = 0;
- my $ss = 0;
- for (my $i = 1; $i < @atime; $i++) {
- if ($atime[$i] >= $atime[$i-1]) {
- $ai++;
- }
- if ($atime[$i] > int($atime[$i])) {
- $ss++;
- }
- }
- for (my $i = 1; $i < @mtime; $i++) {
- if ($mtime[$i] >= $mtime[$i-1]) {
- $mi++;
- }
- if ($mtime[$i] > int($mtime[$i])) {
- $ss++;
- }
- }
- print "# ai = $ai, mi = $mi, ss = $ss\n";
- # Need at least 75% of monotonical increase and
- # 20% of subsecond results. Yes, this is guessing.
- if ($ss == 0) {
- print "# No subsecond timestamps detected\n";
- skip 38;
- } elsif ($mi/(@mtime-1) >= 0.75 && $ai/(@atime-1) >= 0.75 &&
- $ss/(@mtime+ at atime) >= 0.2) {
- print "ok 38\n";
- } else {
- print "not ok 38\n";
- }
-} else {
- print "# No effectual d_hires_stat\n";
- skip 38;
-}
-
-unless ($can_subsecond_alarm) {
- skip 39..44;
-} else {
- {
- my $alrm;
- $SIG{ALRM} = sub { $alrm++ };
- Time::HiRes::alarm(0.1);
- my $t0 = time();
- 1 while time() - $t0 <= 1;
- print $alrm ? "ok 39\n" : "not ok 39\n";
- }
- {
- my $alrm;
- $SIG{ALRM} = sub { $alrm++ };
- Time::HiRes::alarm(1.1);
- my $t0 = time();
- 1 while time() - $t0 <= 2;
- print $alrm ? "ok 40\n" : "not ok 40\n";
- }
-
- {
- my $alrm = 0;
- $SIG{ALRM} = sub { $alrm++ };
- my $got = Time::HiRes::alarm(2.7);
- ok(41, $got == 0, $got);
-
- my $t0 = time();
- 1 while time() - $t0 <= 1;
-
- $got = Time::HiRes::alarm(0);
- ok(42, $got > 0 && $got < 1.8, $got);
-
- ok(43, $alrm == 0, $alrm);
-
- $got = Time::HiRes::alarm(0);
- ok(44, $got == 0, $got);
- }
-}
-
-unless ($have_ualarm) {
- skip 45..48;
-}
-else {
- {
- my $alrm = 0;
- $SIG{ALRM} = sub { $alrm++ };
- my $got = Time::HiRes::ualarm(500_000);
- ok(45, $got == 0, $got);
-
- my $t0 = Time::HiRes::time();
- my $t1;
- do {
- $t1 = Time::HiRes::time();
- } while $t1 - $t0 <= 0.3;
- print "# t0 = $t0\n# t1 = $t1\n# t1 - t0 = ", ($t1 - $t0), "\n";
-
- $got = Time::HiRes::ualarm(0);
- ok(46, $got > 0 && $got < 300_000, $got);
-
- ok(47, $alrm == 0, $alrm);
-
- $got = Time::HiRes::ualarm(0);
- ok(48, $got == 0, $got);
- }
-}
-
-END {
- if ($timer_pid) { # Only in the main process.
- my $left = $TheEnd - time();
- printf "# I am the main process $$, terminating the timer process $timer_pid\n# before it terminates me in %d seconds (testing took %d seconds).\n", $left, $waitfor - $left;
- if (kill(0, $timer_pid)) {
- local $? = 0;
- my $kill = kill('KILL', $timer_pid); # We are done, the timer can go.
- wait();
- printf "# kill KILL $timer_pid = %d\n", $kill;
- }
- unlink("ktrace.out"); # Used in BSD system call tracing.
- print "# All done.\n";
- }
-}
-
Deleted: trunk/contrib/perl/cpan/Unicode-Collate/Collate/Locale/sw.pl
===================================================================
--- trunk/contrib/perl/cpan/Unicode-Collate/Collate/Locale/sw.pl 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/cpan/Unicode-Collate/Collate/Locale/sw.pl 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,28 +0,0 @@
-+{
- entry => <<'ENTRY', # for DUCET v6.0.0
-0063 0068 ; [.15BA.0020.0002.0063] # <LATIN SMALL LETTER C, LATIN SMALL LETTER H>
-0043 0068 ; [.15BA.0020.0007.0043] # <LATIN CAPITAL LETTER C, LATIN SMALL LETTER H>
-0043 0048 ; [.15BA.0020.0008.0043] # <LATIN CAPITAL LETTER C, LATIN CAPITAL LETTER H>
-0064 0068 ; [.15E5.0020.0002.0064] # <LATIN SMALL LETTER D, LATIN SMALL LETTER H>
-0044 0068 ; [.15E5.0020.0007.0044] # <LATIN CAPITAL LETTER D, LATIN SMALL LETTER H>
-0044 0048 ; [.15E5.0020.0008.0044] # <LATIN CAPITAL LETTER D, LATIN CAPITAL LETTER H>
-0067 0068 ; [.1645.0020.0002.0067] # <LATIN SMALL LETTER G, LATIN SMALL LETTER H>
-0047 0068 ; [.1645.0020.0007.0047] # <LATIN CAPITAL LETTER G, LATIN SMALL LETTER H>
-0047 0048 ; [.1645.0020.0008.0047] # <LATIN CAPITAL LETTER G, LATIN CAPITAL LETTER H>
-006B 0068 ; [.16B3.0020.0002.006B] # <LATIN SMALL LETTER K, LATIN SMALL LETTER H>
-004B 0068 ; [.16B3.0020.0007.004B] # <LATIN CAPITAL LETTER K, LATIN SMALL LETTER H>
-004B 0048 ; [.16B3.0020.0008.004B] # <LATIN CAPITAL LETTER K, LATIN CAPITAL LETTER H>
-006E 0067 0027 ; [.1703.0020.0002.006E] # <LATIN SMALL LETTER N, LATIN SMALL LETTER G, APOSTROPHE>
-004E 0067 0027 ; [.1703.0020.0007.004E] # <LATIN CAPITAL LETTER N, LATIN SMALL LETTER G, APOSTROPHE>
-004E 0047 0027 ; [.1703.0020.0008.004E] # <LATIN CAPITAL LETTER N, LATIN CAPITAL LETTER G, APOSTROPHE>
-006E 0079 ; [.1704.0020.0002.006E] # <LATIN SMALL LETTER N, LATIN SMALL LETTER Y>
-004E 0079 ; [.1704.0020.0007.004E] # <LATIN CAPITAL LETTER N, LATIN SMALL LETTER Y>
-004E 0059 ; [.1704.0020.0008.004E] # <LATIN CAPITAL LETTER N, LATIN CAPITAL LETTER Y>
-0073 0068 ; [.17A7.0020.0002.0073] # <LATIN SMALL LETTER S, LATIN SMALL LETTER H>
-0053 0068 ; [.17A7.0020.0007.0053] # <LATIN CAPITAL LETTER S, LATIN SMALL LETTER H>
-0053 0048 ; [.17A7.0020.0008.0053] # <LATIN CAPITAL LETTER S, LATIN CAPITAL LETTER H>
-0074 0068 ; [.17CA.0020.0002.0074] # <LATIN SMALL LETTER T, LATIN SMALL LETTER H>
-0054 0068 ; [.17CA.0020.0007.0054] # <LATIN CAPITAL LETTER T, LATIN SMALL LETTER H>
-0054 0048 ; [.17CA.0020.0008.0054] # <LATIN CAPITAL LETTER T, LATIN CAPITAL LETTER H>
-ENTRY
-};
Deleted: trunk/contrib/perl/dist/Attribute-Handlers/README
===================================================================
--- trunk/contrib/perl/dist/Attribute-Handlers/README 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/dist/Attribute-Handlers/README 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,605 +0,0 @@
-==============================================================================
- Attribute::Handlers
-==============================================================================
-
-
-NAME
- Attribute::Handlers - Simpler definition of attribute handlers
-
-VERSION
- This document describes version 0.79 of Attribute::Handlers, released
- November 25, 2007.
-
-SYNOPSIS
- package MyClass;
- require 5.006;
- use Attribute::Handlers;
- no warnings 'redefine';
-
-
- sub Good : ATTR(SCALAR) {
- my ($package, $symbol, $referent, $attr, $data) = @_;
-
- # Invoked for any scalar variable with a :Good attribute,
- # provided the variable was declared in MyClass (or
- # a derived class) or typed to MyClass.
-
- # Do whatever to $referent here (executed in CHECK phase).
- ...
- }
-
- sub Bad : ATTR(SCALAR) {
- # Invoked for any scalar variable with a :Bad attribute,
- # provided the variable was declared in MyClass (or
- # a derived class) or typed to MyClass.
- ...
- }
-
- sub Good : ATTR(ARRAY) {
- # Invoked for any array variable with a :Good attribute,
- # provided the variable was declared in MyClass (or
- # a derived class) or typed to MyClass.
- ...
- }
-
- sub Good : ATTR(HASH) {
- # Invoked for any hash variable with a :Good attribute,
- # provided the variable was declared in MyClass (or
- # a derived class) or typed to MyClass.
- ...
- }
-
- sub Ugly : ATTR(CODE) {
- # Invoked for any subroutine declared in MyClass (or a
- # derived class) with an :Ugly attribute.
- ...
- }
-
- sub Omni : ATTR {
- # Invoked for any scalar, array, hash, or subroutine
- # with an :Omni attribute, provided the variable or
- # subroutine was declared in MyClass (or a derived class)
- # or the variable was typed to MyClass.
- # Use ref($_[2]) to determine what kind of referent it was.
- ...
- }
-
-
- use Attribute::Handlers autotie => { Cycle => Tie::Cycle };
-
- my $next : Cycle(['A'..'Z']);
-
-DESCRIPTION
- This module, when inherited by a package, allows that package's class to
- define attribute handler subroutines for specific attributes. Variables
- and subroutines subsequently defined in that package, or in packages
- derived from that package may be given attributes with the same names as
- the attribute handler subroutines, which will then be called in one of
- the compilation phases (i.e. in a "BEGIN", "CHECK", "INIT", or "END"
- block). ("UNITCHECK" blocks don't correspond to a global compilation
- phase, so they can't be specified here.)
-
- To create a handler, define it as a subroutine with the same name as the
- desired attribute, and declare the subroutine itself with the attribute
- ":ATTR". For example:
-
- package LoudDecl;
- use Attribute::Handlers;
-
- sub Loud :ATTR {
- my ($package, $symbol, $referent, $attr, $data, $phase, $filename, $linenum) = @_;
- print STDERR
- ref($referent), " ",
- *{$symbol}{NAME}, " ",
- "($referent) ", "was just declared ",
- "and ascribed the ${attr} attribute ",
- "with data ($data)\n",
- "in phase $phase\n",
- "in file $filename at line $linenum\n";
- }
-
- This creates a handler for the attribute ":Loud" in the class LoudDecl.
- Thereafter, any subroutine declared with a ":Loud" attribute in the
- class LoudDecl:
-
- package LoudDecl;
-
- sub foo: Loud {...}
-
- causes the above handler to be invoked, and passed:
-
- [0] the name of the package into which it was declared;
-
- [1] a reference to the symbol table entry (typeglob) containing the
- subroutine;
-
- [2] a reference to the subroutine;
-
- [3] the name of the attribute;
-
- [4] any data associated with that attribute;
-
- [5] the name of the phase in which the handler is being invoked;
-
- [6] the filename in which the handler is being invoked;
-
- [7] the line number in this file.
-
- Likewise, declaring any variables with the ":Loud" attribute within the
- package:
-
- package LoudDecl;
-
- my $foo :Loud;
- my @foo :Loud;
- my %foo :Loud;
-
- will cause the handler to be called with a similar argument list
- (except, of course, that $_[2] will be a reference to the variable).
-
- The package name argument will typically be the name of the class into
- which the subroutine was declared, but it may also be the name of a
- derived class (since handlers are inherited).
-
- If a lexical variable is given an attribute, there is no symbol table to
- which it belongs, so the symbol table argument ($_[1]) is set to the
- string 'LEXICAL' in that case. Likewise, ascribing an attribute to an
- anonymous subroutine results in a symbol table argument of 'ANON'.
-
- The data argument passes in the value (if any) associated with the
- attribute. For example, if &foo had been declared:
-
- sub foo :Loud("turn it up to 11, man!") {...}
-
- then a reference to an array containing the string "turn it up to 11,
- man!" would be passed as the last argument.
-
- Attribute::Handlers makes strenuous efforts to convert the data argument
- ($_[4]) to a useable form before passing it to the handler (but see
- "Non-interpretive attribute handlers"). If those efforts succeed, the
- interpreted data is passed in an array reference; if they fail, the raw
- data is passed as a string. For example, all of these:
-
- sub foo :Loud(till=>ears=>are=>bleeding) {...}
- sub foo :Loud(qw/till ears are bleeding/) {...}
- sub foo :Loud(qw/my, ears, are, bleeding/) {...}
- sub foo :Loud(till,ears,are,bleeding) {...}
-
- causes it to pass "['till','ears','are','bleeding']" as the handler's
- data argument. While:
-
- sub foo :Loud(['till','ears','are','bleeding']) {...}
-
- causes it to pass "[ ['till','ears','are','bleeding'] ]"; the array
- reference specified in the data being passed inside the standard array
- reference indicating successful interpretation.
-
- However, if the data can't be parsed as valid Perl, then it is passed as
- an uninterpreted string. For example:
-
- sub foo :Loud(my,ears,are,bleeding) {...}
- sub foo :Loud(qw/my ears are bleeding) {...}
-
- cause the strings 'my,ears,are,bleeding' and 'qw/my ears are bleeding'
- respectively to be passed as the data argument.
-
- If no value is associated with the attribute, "undef" is passed.
-
- Typed lexicals
- Regardless of the package in which it is declared, if a lexical variable
- is ascribed an attribute, the handler that is invoked is the one
- belonging to the package to which it is typed. For example, the
- following declarations:
-
- package OtherClass;
-
- my LoudDecl $loudobj : Loud;
- my LoudDecl @loudobjs : Loud;
- my LoudDecl %loudobjex : Loud;
-
- causes the LoudDecl::Loud handler to be invoked (even if OtherClass also
- defines a handler for ":Loud" attributes).
-
- Type-specific attribute handlers
- If an attribute handler is declared and the ":ATTR" specifier is given
- the name of a built-in type ("SCALAR", "ARRAY", "HASH", or "CODE"), the
- handler is only applied to declarations of that type. For example, the
- following definition:
-
- package LoudDecl;
-
- sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
-
- creates an attribute handler that applies only to scalars:
-
- package Painful;
- use base LoudDecl;
-
- my $metal : RealLoud; # invokes &LoudDecl::RealLoud
- my @metal : RealLoud; # error: unknown attribute
- my %metal : RealLoud; # error: unknown attribute
- sub metal : RealLoud {...} # error: unknown attribute
-
- You can, of course, declare separate handlers for these types as well
- (but you'll need to specify "no warnings 'redefine'" to do it quietly):
-
- package LoudDecl;
- use Attribute::Handlers;
- no warnings 'redefine';
-
- sub RealLoud :ATTR(SCALAR) { print "Yeeeeow!" }
- sub RealLoud :ATTR(ARRAY) { print "Urrrrrrrrrr!" }
- sub RealLoud :ATTR(HASH) { print "Arrrrrgggghhhhhh!" }
- sub RealLoud :ATTR(CODE) { croak "Real loud sub torpedoed" }
-
- You can also explicitly indicate that a single handler is meant to be
- used for all types of referents like so:
-
- package LoudDecl;
- use Attribute::Handlers;
-
- sub SeriousLoud :ATTR(ANY) { warn "Hearing loss imminent" }
-
- (I.e. "ATTR(ANY)" is a synonym for ":ATTR").
-
- Non-interpretive attribute handlers
- Occasionally the strenuous efforts Attribute::Handlers makes to convert
- the data argument ($_[4]) to a useable form before passing it to the
- handler get in the way.
-
- You can turn off that eagerness-to-help by declaring an attribute
- handler with the keyword "RAWDATA". For example:
-
- sub Raw : ATTR(RAWDATA) {...}
- sub Nekkid : ATTR(SCALAR,RAWDATA) {...}
- sub Au::Naturale : ATTR(RAWDATA,ANY) {...}
-
- Then the handler makes absolutely no attempt to interpret the data it
- receives and simply passes it as a string:
-
- my $power : Raw(1..100); # handlers receives "1..100"
-
- Phase-specific attribute handlers
- By default, attribute handlers are called at the end of the compilation
- phase (in a "CHECK" block). This seems to be optimal in most cases
- because most things that can be defined are defined by that point but
- nothing has been executed.
-
- However, it is possible to set up attribute handlers that are called at
- other points in the program's compilation or execution, by explicitly
- stating the phase (or phases) in which you wish the attribute handler to
- be called. For example:
-
- sub Early :ATTR(SCALAR,BEGIN) {...}
- sub Normal :ATTR(SCALAR,CHECK) {...}
- sub Late :ATTR(SCALAR,INIT) {...}
- sub Final :ATTR(SCALAR,END) {...}
- sub Bookends :ATTR(SCALAR,BEGIN,END) {...}
-
- As the last example indicates, a handler may be set up to be (re)called
- in two or more phases. The phase name is passed as the handler's final
- argument.
-
- Note that attribute handlers that are scheduled for the "BEGIN" phase
- are handled as soon as the attribute is detected (i.e. before any
- subsequently defined "BEGIN" blocks are executed).
-
- Attributes as "tie" interfaces
- Attributes make an excellent and intuitive interface through which to
- tie variables. For example:
-
- use Attribute::Handlers;
- use Tie::Cycle;
-
- sub UNIVERSAL::Cycle : ATTR(SCALAR) {
- my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
- $data = [ $data ] unless ref $data eq 'ARRAY';
- tie $$referent, 'Tie::Cycle', $data;
- }
-
- # and thereafter...
-
- package main;
-
- my $next : Cycle('A'..'Z'); # $next is now a tied variable
-
- while (<>) {
- print $next;
- }
-
- Note that, because the "Cycle" attribute receives its arguments in the
- $data variable, if the attribute is given a list of arguments, $data
- will consist of a single array reference; otherwise, it will consist of
- the single argument directly. Since Tie::Cycle requires its cycling
- values to be passed as an array reference, this means that we need to
- wrap non-array-reference arguments in an array constructor:
-
- $data = [ $data ] unless ref $data eq 'ARRAY';
-
- Typically, however, things are the other way around: the tieable class
- expects its arguments as a flattened list, so the attribute looks like:
-
- sub UNIVERSAL::Cycle : ATTR(SCALAR) {
- my ($package, $symbol, $referent, $attr, $data, $phase) = @_;
- my @data = ref $data eq 'ARRAY' ? @$data : $data;
- tie $$referent, 'Tie::Whatever', @data;
- }
-
- This software pattern is so widely applicable that Attribute::Handlers
- provides a way to automate it: specifying 'autotie' in the "use
- Attribute::Handlers" statement. So, the cycling example, could also be
- written:
-
- use Attribute::Handlers autotie => { Cycle => 'Tie::Cycle' };
-
- # and thereafter...
-
- package main;
-
- my $next : Cycle(['A'..'Z']); # $next is now a tied variable
-
- while (<>) {
- print $next;
-
- Note that we now have to pass the cycling values as an array reference,
- since the "autotie" mechanism passes "tie" a list of arguments as a list
- (as in the Tie::Whatever example), *not* as an array reference (as in
- the original Tie::Cycle example at the start of this section).
-
- The argument after 'autotie' is a reference to a hash in which each key
- is the name of an attribute to be created, and each value is the class
- to which variables ascribed that attribute should be tied.
-
- Note that there is no longer any need to import the Tie::Cycle module --
- Attribute::Handlers takes care of that automagically. You can even pass
- arguments to the module's "import" subroutine, by appending them to the
- class name. For example:
-
- use Attribute::Handlers
- autotie => { Dir => 'Tie::Dir qw(DIR_UNLINK)' };
-
- If the attribute name is unqualified, the attribute is installed in the
- current package. Otherwise it is installed in the qualifier's package:
-
- package Here;
-
- use Attribute::Handlers autotie => {
- Other::Good => Tie::SecureHash, # tie attr installed in Other::
- Bad => Tie::Taxes, # tie attr installed in Here::
- UNIVERSAL::Ugly => Software::Patent # tie attr installed everywhere
- };
-
- Autoties are most commonly used in the module to which they actually
- tie, and need to export their attributes to any module that calls them.
- To facilitate this, Attribute::Handlers recognizes a special
- "pseudo-class" -- "__CALLER__", which may be specified as the qualifier
- of an attribute:
-
- package Tie::Me::Kangaroo:Down::Sport;
-
- use Attribute::Handlers autotie => { '__CALLER__::Roo' => __PACKAGE__ };
-
- This causes Attribute::Handlers to define the "Roo" attribute in the
- package that imports the Tie::Me::Kangaroo:Down::Sport module.
-
- Note that it is important to quote the __CALLER__::Roo identifier
- because a bug in perl 5.8 will refuse to parse it and cause an unknown
- error.
-
- Passing the tied object to "tie"
- Occasionally it is important to pass a reference to the object being
- tied to the TIESCALAR, TIEHASH, etc. that ties it.
-
- The "autotie" mechanism supports this too. The following code:
-
- use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
- my $var : Selfish(@args);
-
- has the same effect as:
-
- tie my $var, 'Tie::Selfish', @args;
-
- But when "autotieref" is used instead of "autotie":
-
- use Attribute::Handlers autotieref => { Selfish => Tie::Selfish };
- my $var : Selfish(@args);
-
- the effect is to pass the "tie" call an extra reference to the variable
- being tied:
-
- tie my $var, 'Tie::Selfish', \$var, @args;
-
-EXAMPLES
- If the class shown in SYNOPSIS were placed in the MyClass.pm module,
- then the following code:
-
- package main;
- use MyClass;
-
- my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
-
- package SomeOtherClass;
- use base MyClass;
-
- sub tent { 'acle' }
-
- sub fn :Ugly(sister) :Omni('po',tent()) {...}
- my @arr :Good :Omni(s/cie/nt/);
- my %hsh :Good(q/bye/) :Omni(q/bus/);
-
- would cause the following handlers to be invoked:
-
- # my MyClass $slr :Good :Bad(1**1-1) :Omni(-vorous);
-
- MyClass::Good:ATTR(SCALAR)( 'MyClass', # class
- 'LEXICAL', # no typeglob
- \$slr, # referent
- 'Good', # attr name
- undef # no attr data
- 'CHECK', # compiler phase
- );
-
- MyClass::Bad:ATTR(SCALAR)( 'MyClass', # class
- 'LEXICAL', # no typeglob
- \$slr, # referent
- 'Bad', # attr name
- 0 # eval'd attr data
- 'CHECK', # compiler phase
- );
-
- MyClass::Omni:ATTR(SCALAR)( 'MyClass', # class
- 'LEXICAL', # no typeglob
- \$slr, # referent
- 'Omni', # attr name
- '-vorous' # eval'd attr data
- 'CHECK', # compiler phase
- );
-
-
- # sub fn :Ugly(sister) :Omni('po',tent()) {...}
-
- MyClass::UGLY:ATTR(CODE)( 'SomeOtherClass', # class
- \*SomeOtherClass::fn, # typeglob
- \&SomeOtherClass::fn, # referent
- 'Ugly', # attr name
- 'sister' # eval'd attr data
- 'CHECK', # compiler phase
- );
-
- MyClass::Omni:ATTR(CODE)( 'SomeOtherClass', # class
- \*SomeOtherClass::fn, # typeglob
- \&SomeOtherClass::fn, # referent
- 'Omni', # attr name
- ['po','acle'] # eval'd attr data
- 'CHECK', # compiler phase
- );
-
-
- # my @arr :Good :Omni(s/cie/nt/);
-
- MyClass::Good:ATTR(ARRAY)( 'SomeOtherClass', # class
- 'LEXICAL', # no typeglob
- \@arr, # referent
- 'Good', # attr name
- undef # no attr data
- 'CHECK', # compiler phase
- );
-
- MyClass::Omni:ATTR(ARRAY)( 'SomeOtherClass', # class
- 'LEXICAL', # no typeglob
- \@arr, # referent
- 'Omni', # attr name
- "" # eval'd attr data
- 'CHECK', # compiler phase
- );
-
-
- # my %hsh :Good(q/bye) :Omni(q/bus/);
-
- MyClass::Good:ATTR(HASH)( 'SomeOtherClass', # class
- 'LEXICAL', # no typeglob
- \%hsh, # referent
- 'Good', # attr name
- 'q/bye' # raw attr data
- 'CHECK', # compiler phase
- );
-
- MyClass::Omni:ATTR(HASH)( 'SomeOtherClass', # class
- 'LEXICAL', # no typeglob
- \%hsh, # referent
- 'Omni', # attr name
- 'bus' # eval'd attr data
- 'CHECK', # compiler phase
- );
-
- Installing handlers into UNIVERSAL, makes them...err..universal. For
- example:
-
- package Descriptions;
- use Attribute::Handlers;
-
- my %name;
- sub name { return $name{$_[2]}||*{$_[1]}{NAME} }
-
- sub UNIVERSAL::Name :ATTR {
- $name{$_[2]} = $_[4];
- }
-
- sub UNIVERSAL::Purpose :ATTR {
- print STDERR "Purpose of ", &name, " is $_[4]\n";
- }
-
- sub UNIVERSAL::Unit :ATTR {
- print STDERR &name, " measured in $_[4]\n";
- }
-
- Let's you write:
-
- use Descriptions;
-
- my $capacity : Name(capacity)
- : Purpose(to store max storage capacity for files)
- : Unit(Gb);
-
-
- package Other;
-
- sub foo : Purpose(to foo all data before barring it) { }
-
- # etc.
-
-DIAGNOSTICS
- "Bad attribute type: ATTR(%s)"
- An attribute handler was specified with an ":ATTR(*ref_type*)", but
- the type of referent it was defined to handle wasn't one of the five
- permitted: "SCALAR", "ARRAY", "HASH", "CODE", or "ANY".
-
- "Attribute handler %s doesn't handle %s attributes"
- A handler for attributes of the specified name *was* defined, but
- not for the specified type of declaration. Typically encountered whe
- trying to apply a "VAR" attribute handler to a subroutine, or a
- "SCALAR" attribute handler to some other type of variable.
-
- "Declaration of %s attribute in package %s may clash with future
- reserved word"
- A handler for an attributes with an all-lowercase name was declared.
- An attribute with an all-lowercase name might have a meaning to Perl
- itself some day, even though most don't yet. Use a mixed-case
- attribute name, instead.
-
- "Can't have two ATTR specifiers on one subroutine"
- You just can't, okay? Instead, put all the specifications together
- with commas between them in a single "ATTR(*specification*)".
-
- "Can't autotie a %s"
- You can only declare autoties for types "SCALAR", "ARRAY", and
- "HASH". They're the only things (apart from typeglobs -- which are
- not declarable) that Perl can tie.
-
- "Internal error: %s symbol went missing"
- Something is rotten in the state of the program. An attributed
- subroutine ceased to exist between the point it was declared and the
- point at which its attribute handler(s) would have been called.
-
- "Won't be able to apply END handler"
- You have defined an END handler for an attribute that is being
- applied to a lexical variable. Since the variable may not be
- available during END this won't happen.
-
-AUTHOR
- Damian Conway (damian at conway.org). The maintainer of this module is now
- Rafael Garcia-Suarez (rgarciasuarez at gmail.com).
-
- Maintainer of the CPAN release is Steffen Mueller (smueller at cpan.org).
- Contact him with technical difficulties with respect to the packaging of
- the CPAN module.
-
-BUGS
- There are undoubtedly serious bugs lurking somewhere in code this funky
- :-) Bug reports and other feedback are most welcome.
-
-COPYRIGHT AND LICENSE
- Copyright (c) 2001-2009, Damian Conway. All Rights Reserved.
- This module is free software. It may be used, redistributed
- and/or modified under the same terms as Perl itself.
-
Deleted: trunk/contrib/perl/dist/ExtUtils-ParseXS/t/basic.t
===================================================================
--- trunk/contrib/perl/dist/ExtUtils-ParseXS/t/basic.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/dist/ExtUtils-ParseXS/t/basic.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,80 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use Test::More;
-use Config;
-use DynaLoader;
-use ExtUtils::CBuilder;
-
-plan tests => 10;
-
-my ($source_file, $obj_file, $lib_file);
-
-require_ok( 'ExtUtils::ParseXS' );
-ExtUtils::ParseXS->import('process_file');
-
-chdir 't' or die "Can't chdir to t/, $!";
-
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
-
-#########################
-
-# Try sending to filehandle
-tie *FH, 'Foo';
-process_file( filename => 'XSTest.xs', output => \*FH, prototypes => 1 );
-like tied(*FH)->content, '/is_even/', "Test that output contains some text";
-
-$source_file = 'XSTest.c';
-
-# Try sending to file
-process_file(filename => 'XSTest.xs', output => $source_file, prototypes => 0);
-ok -e $source_file, "Create an output file";
-
-my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
-my $b = ExtUtils::CBuilder->new(quiet => $quiet);
-
-SKIP: {
- skip "no compiler available", 2
- if ! $b->have_compiler;
- $obj_file = $b->compile( source => $source_file );
- ok $obj_file;
- ok -e $obj_file, "Make sure $obj_file exists";
-}
-
-SKIP: {
- skip "no dynamic loading", 5
- if !$b->have_compiler || !$Config{usedl};
- my $module = 'XSTest';
- $lib_file = $b->link( objects => $obj_file, module_name => $module );
- ok $lib_file;
- ok -e $lib_file, "Make sure $lib_file exists";
-
- eval {require XSTest};
- is $@, '';
- ok XSTest::is_even(8);
- ok !XSTest::is_even(9);
-
- # Win32 needs to close the DLL before it can unlink it, but unfortunately
- # dl_unload_file was missing on Win32 prior to perl change #24679!
- if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
- for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
- if ($DynaLoader::dl_modules[$i] eq $module) {
- DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
- last;
- }
- }
- }
-}
-
-unless ($ENV{PERL_NO_CLEANUP}) {
- for ( $obj_file, $lib_file, $source_file) {
- next unless defined $_;
- 1 while unlink $_;
- }
-}
-
-#####################################################################
-
-sub Foo::TIEHANDLE { bless {}, 'Foo' }
-sub Foo::PRINT { shift->{buf} .= join '', @_ }
-sub Foo::content { shift->{buf} }
Deleted: trunk/contrib/perl/dist/ExtUtils-ParseXS/t/more.t
===================================================================
--- trunk/contrib/perl/dist/ExtUtils-ParseXS/t/more.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/dist/ExtUtils-ParseXS/t/more.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,110 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use Test::More;
-use Config;
-use DynaLoader;
-use ExtUtils::CBuilder;
-use attributes;
-use overload;
-
-plan tests => 25;
-
-my ($source_file, $obj_file, $lib_file);
-
-require_ok( 'ExtUtils::ParseXS' );
-ExtUtils::ParseXS->import('process_file');
-
-chdir 't' or die "Can't chdir to t/, $!";
-
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
-
-#########################
-
-$source_file = 'XSMore.c';
-
-# Try sending to file
-ExtUtils::ParseXS->process_file(
- filename => 'XSMore.xs',
- output => $source_file,
-);
-ok -e $source_file, "Create an output file";
-
-my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
-my $b = ExtUtils::CBuilder->new(quiet => $quiet);
-
-SKIP: {
- skip "no compiler available", 2
- if ! $b->have_compiler;
- $obj_file = $b->compile( source => $source_file );
- ok $obj_file;
- ok -e $obj_file, "Make sure $obj_file exists";
-}
-
-SKIP: {
- skip "no dynamic loading", 21
- if !$b->have_compiler || !$Config{usedl};
- my $module = 'XSMore';
- $lib_file = $b->link( objects => $obj_file, module_name => $module );
- ok $lib_file;
- ok -e $lib_file, "Make sure $lib_file exists";
-
- eval{
- package XSMore;
- our $VERSION = 42;
- our $boot_ok;
- DynaLoader::bootstrap_inherit(__PACKAGE__, $VERSION); # VERSIONCHECK disabled
-
- sub new{ bless {}, shift }
- };
- is $@, '';
- is ExtUtils::ParseXS::errors(), 0, 'ExtUtils::ParseXS::errors()';
-
- is $XSMore::boot_ok, 100, 'the BOOT keyword';
-
- ok XSMore::include_ok(), 'the INCLUDE keyword';
- is prototype(\&XSMore::include_ok), "", 'the PROTOTYPES keyword';
-
- is prototype(\&XSMore::prototype_ssa), '$$@', 'the PROTOTYPE keyword';
-
- is_deeply [attributes::get(\&XSMore::attr_method)], [qw(method)], 'the ATTRS keyword';
- is prototype(\&XSMore::attr_method), '$;@', 'ATTRS with prototype';
-
- is XSMore::return_1(), 1, 'the CASE keyword (1)';
- is XSMore::return_2(), 2, 'the CASE keyword (2)';
- is prototype(\&XSMore::return_1), "", 'ALIAS with prototype (1)';
- is prototype(\&XSMore::return_2), "", 'ALIAS with prototype (2)';
-
- is XSMore::arg_init(200), 200, 'argument init';
-
- ok overload::Overloaded(XSMore->new), 'the FALLBACK keyword';
- is abs(XSMore->new), 42, 'the OVERLOAD keyword';
-
- my @a;
- XSMore::hook(\@a);
- is_deeply \@a, [qw(INIT CODE POSTCALL CLEANUP)], 'the INIT & POSTCALL & CLEANUP keywords';
-
- is_deeply [XSMore::outlist()], [ord('a'), ord('b')], 'the OUTLIST keyword';
-
- is XSMore::len("foo"), 3, 'the length keyword';
-
- is XSMore::sum(5, 9), 14, 'the INCLUDE_COMMAND directive';
-
- # Win32 needs to close the DLL before it can unlink it, but unfortunately
- # dl_unload_file was missing on Win32 prior to perl change #24679!
- if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
- for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
- if ($DynaLoader::dl_modules[$i] eq $module) {
- DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
- last;
- }
- }
- }
-}
-
-unless ($ENV{PERL_NO_CLEANUP}) {
- for ( $obj_file, $lib_file, $source_file) {
- next unless defined $_;
- 1 while unlink $_;
- }
-}
Deleted: trunk/contrib/perl/dist/ExtUtils-ParseXS/t/usage.t
===================================================================
--- trunk/contrib/perl/dist/ExtUtils-ParseXS/t/usage.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/dist/ExtUtils-ParseXS/t/usage.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,117 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use Test::More;
-use Config;
-use DynaLoader;
-use ExtUtils::CBuilder;
-
-if ( $] < 5.008 ) {
- plan skip_all => "INTERFACE keyword support broken before 5.8";
-}
-else {
- plan tests => 24;
-}
-
-my ($source_file, $obj_file, $lib_file, $module);
-
-require_ok( 'ExtUtils::ParseXS' );
-ExtUtils::ParseXS->import('process_file');
-
-chdir 't' or die "Can't chdir to t/, $!";
-
-use Carp; $SIG{__WARN__} = \&Carp::cluck;
-
-#########################
-
-$source_file = 'XSUsage.c';
-
-# Try sending to file
-process_file(filename => 'XSUsage.xs', output => $source_file);
-ok -e $source_file, "Create an output file";
-
-# TEST doesn't like extraneous output
-my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE};
-
-# Try to compile the file! Don't get too fancy, though.
-my $b = ExtUtils::CBuilder->new(quiet => $quiet);
-
-SKIP: {
- skip "no compiler available", 2
- if ! $b->have_compiler;
- $module = 'XSUsage';
-
- $obj_file = $b->compile( source => $source_file );
- ok $obj_file;
- ok -e $obj_file, "Make sure $obj_file exists";
-}
-SKIP: {
- skip "no dynamic loading", 20
- if !$b->have_compiler || !$Config{usedl};
-
- $lib_file = $b->link( objects => $obj_file, module_name => $module );
- ok $lib_file;
- ok -e $lib_file, "Make sure $lib_file exists";
-
- eval {require XSUsage};
- is $@, '';
-
- # The real tests here - for each way of calling the functions, call with the
- # wrong number of arguments and check the Usage line is what we expect
-
- eval { XSUsage::one(1) };
- ok $@;
- ok $@ =~ /^Usage: XSUsage::one/;
-
- eval { XSUsage::two(1) };
- ok $@;
- ok $@ =~ /^Usage: XSUsage::two/;
-
- eval { XSUsage::two_x(1) };
- ok $@;
- ok $@ =~ /^Usage: XSUsage::two_x/;
-
- eval { FOO::two(1) };
- ok $@;
- ok $@ =~ /^Usage: FOO::two/;
-
- eval { XSUsage::three(1) };
- ok $@;
- ok $@ =~ /^Usage: XSUsage::three/;
-
- eval { XSUsage::four(1) };
- ok !$@;
-
- eval { XSUsage::five() };
- ok $@;
- ok $@ =~ /^Usage: XSUsage::five/;
-
- eval { XSUsage::six() };
- ok !$@;
-
- eval { XSUsage::six(1) };
- ok !$@;
-
- eval { XSUsage::six(1,2) };
- ok $@;
- ok $@ =~ /^Usage: XSUsage::six/;
-
- # Win32 needs to close the DLL before it can unlink it, but unfortunately
- # dl_unload_file was missing on Win32 prior to perl change #24679!
- if ($^O eq 'MSWin32' and defined &DynaLoader::dl_unload_file) {
- for (my $i = 0; $i < @DynaLoader::dl_modules; $i++) {
- if ($DynaLoader::dl_modules[$i] eq $module) {
- DynaLoader::dl_unload_file($DynaLoader::dl_librefs[$i]);
- last;
- }
- }
- }
-}
-
-unless ($ENV{PERL_NO_CLEANUP}) {
- for ( $obj_file, $lib_file, $source_file) {
- next unless defined $_;
- 1 while unlink $_;
- }
-}
-
Deleted: trunk/contrib/perl/ext/B/B/Debug.pm
===================================================================
--- trunk/contrib/perl/ext/B/B/Debug.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/B/B/Debug.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,420 +0,0 @@
-package B::Debug;
-
-our $VERSION = '1.11';
-
-use strict;
-require 5.006;
-use B qw(peekop class walkoptree walkoptree_exec
- main_start main_root cstring sv_undef);
-use Config;
-my (@optype, @specialsv_name);
-require B;
-if ($] < 5.009) {
- require B::Asmdata;
- B::Asmdata->import qw(@optype @specialsv_name);
-} else {
- B->import qw(@optype @specialsv_name);
-}
-my $have_B_Flags;
-if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
- eval { require B::Flags and $have_B_Flags++ };
-}
-my %done_gv;
-
-sub _printop {
- my $op = shift;
- my $addr = ${$op} ? $op->ppaddr : '';
- $addr =~ s/^PL_ppaddr// if $addr;
- return sprintf "0x%x %s %s", ${$op}, ${$op} ? class($op) : '', $addr;
-}
-
-sub B::OP::debug {
- my ($op) = @_;
- printf <<'EOT', class($op), $$op, $op->ppaddr, _printop($op->next), _printop($op->sibling), $op->targ, $op->type;
-%s (0x%lx)
- op_ppaddr %s
- op_next %s
- op_sibling %s
- op_targ %d
- op_type %d
-EOT
- if ($] > 5.009) {
- printf <<'EOT', $op->opt;
- op_opt %d
-EOT
- } else {
- printf <<'EOT', $op->seq;
- op_seq %d
-EOT
- }
- if ($have_B_Flags) {
- printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
- op_flags %d %s
- op_private %d %s
-EOT
- } else {
- printf <<'EOT', $op->flags, $op->private;
- op_flags %d
- op_private %d
-EOT
- }
-}
-
-sub B::UNOP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- printf "\top_first\t%s\n", _printop($op->first);
-}
-
-sub B::BINOP::debug {
- my ($op) = @_;
- $op->B::UNOP::debug();
- printf "\top_last \t%s\n", _printop($op->last);
-}
-
-sub B::LOOP::debug {
- my ($op) = @_;
- $op->B::BINOP::debug();
- printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
- op_redoop %s
- op_nextop %s
- op_lastop %s
-EOT
-}
-
-sub B::LOGOP::debug {
- my ($op) = @_;
- $op->B::UNOP::debug();
- printf "\top_other\t%s\n", _printop($op->other);
-}
-
-sub B::LISTOP::debug {
- my ($op) = @_;
- $op->B::BINOP::debug();
- printf "\top_children\t%d\n", $op->children;
-}
-
-sub B::PMOP::debug {
- my ($op) = @_;
- $op->B::LISTOP::debug();
- printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
- printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
- printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
- if ($Config{'useithreads'}) {
- printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
- printf "\top_pmoffset\t%d\n", $op->pmoffset;
- } else {
- printf "\top_pmstash\t%s\n", cstring($op->pmstash);
- }
- printf "\top_precomp\t%s\n", cstring($op->precomp);
- printf "\top_pmflags\t0x%x\n", $op->pmflags;
- printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
- printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
- printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
- $op->pmreplroot->debug if $] < 5.008;
-}
-
-sub B::COP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
- printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
- cop_label "%s"
- cop_stashpv "%s"
- cop_file "%s"
- cop_seq %d
- cop_arybase %d
- cop_line %d
- cop_warnings 0x%x
- cop_io %s
-EOT
-}
-
-sub B::SVOP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- printf "\top_sv\t\t0x%x\n", ${$op->sv};
- $op->sv->debug;
-}
-
-sub B::PVOP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- printf "\top_pv\t\t%s\n", cstring($op->pv);
-}
-
-sub B::PADOP::debug {
- my ($op) = @_;
- $op->B::OP::debug();
- printf "\top_padix\t%ld\n", $op->padix;
-}
-
-sub B::NULL::debug {
- my ($sv) = @_;
- if ($$sv == ${sv_undef()}) {
- print "&sv_undef\n";
- } else {
- printf "NULL (0x%x)\n", $$sv;
- }
-}
-
-sub B::SV::debug {
- my ($sv) = @_;
- if (!$$sv) {
- print class($sv), " = NULL\n";
- return;
- }
- printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
-%s (0x%x)
- REFCNT %d
- FLAGS 0x%x
-EOT
-}
-
-sub B::RV::debug {
- my ($rv) = @_;
- B::SV::debug($rv);
- printf <<'EOT', ${$rv->RV};
- RV 0x%x
-EOT
- $rv->RV->debug;
-}
-
-sub B::PV::debug {
- my ($sv) = @_;
- $sv->B::SV::debug();
- my $pv = $sv->PV();
- printf <<'EOT', cstring($pv), length($pv);
- xpv_pv %s
- xpv_cur %d
-EOT
-}
-
-sub B::IV::debug {
- my ($sv) = @_;
- $sv->B::SV::debug();
- printf "\txiv_iv\t\t%d\n", $sv->IV;
-}
-
-sub B::NV::debug {
- my ($sv) = @_;
- $sv->B::IV::debug();
- printf "\txnv_nv\t\t%s\n", $sv->NV;
-}
-
-sub B::PVIV::debug {
- my ($sv) = @_;
- $sv->B::PV::debug();
- printf "\txiv_iv\t\t%d\n", $sv->IV;
-}
-
-sub B::PVNV::debug {
- my ($sv) = @_;
- $sv->B::PVIV::debug();
- printf "\txnv_nv\t\t%s\n", $sv->NV;
-}
-
-sub B::PVLV::debug {
- my ($sv) = @_;
- $sv->B::PVNV::debug();
- printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
- printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
- printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
-}
-
-sub B::BM::debug {
- my ($sv) = @_;
- $sv->B::PVNV::debug();
- printf "\txbm_useful\t%d\n", $sv->USEFUL;
- printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
- printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
-}
-
-sub B::CV::debug {
- my ($sv) = @_;
- $sv->B::PVNV::debug();
- my ($stash) = $sv->STASH;
- my ($start) = $sv->START;
- my ($root) = $sv->ROOT;
- my ($padlist) = $sv->PADLIST;
- my ($file) = $sv->FILE;
- my ($gv) = $sv->GV;
- printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
- STASH 0x%x
- START 0x%x
- ROOT 0x%x
- GV 0x%x
- FILE %s
- DEPTH %d
- PADLIST 0x%x
- OUTSIDE 0x%x
- OUTSIDE_SEQ %d
-EOT
- $start->debug if $start;
- $root->debug if $root;
- $gv->debug if $gv;
- $padlist->debug if $padlist;
-}
-
-sub B::AV::debug {
- my ($av) = @_;
- $av->B::SV::debug;
- # tied arrays may leave out FETCHSIZE
- my (@array) = eval { $av->ARRAY; };
- print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
- my $fill = eval { scalar(@array) };
- if ($Config{'useithreads'}) {
- printf <<'EOT', $fill, $av->MAX, $av->OFF;
- FILL %d
- MAX %d
- OFF %d
-EOT
- } else {
- printf <<'EOT', $fill, $av->MAX;
- FILL %d
- MAX %d
-EOT
- }
- printf <<'EOT', $av->AvFLAGS if $] < 5.009;
- AvFLAGS %d
-EOT
-}
-
-sub B::GV::debug {
- my ($gv) = @_;
- if ($done_gv{$$gv}++) {
- printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
- return;
- }
- my ($sv) = $gv->SV;
- my ($av) = $gv->AV;
- my ($cv) = $gv->CV;
- $gv->B::SV::debug;
- printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
- NAME %s
- STASH %s (0x%x)
- SV 0x%x
- GvREFCNT %d
- FORM 0x%x
- AV 0x%x
- HV 0x%x
- EGV 0x%x
- CV 0x%x
- CVGEN %d
- LINE %d
- FILE %s
- GvFLAGS 0x%x
-EOT
- $sv->debug if $sv;
- $av->debug if $av;
- $cv->debug if $cv;
-}
-
-sub B::SPECIAL::debug {
- my $sv = shift;
- print $specialsv_name[$$sv], "\n";
-}
-
-sub compile {
- my $order = shift;
- B::clearsym();
- if ($order && $order eq "exec") {
- return sub { walkoptree_exec(main_start, "debug") }
- } else {
- return sub { walkoptree(main_root, "debug") }
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-B::Debug - Walk Perl syntax tree, printing debug info about ops
-
-=head1 SYNOPSIS
-
- perl -MO=Debug[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-See F<ext/B/README> and the newer L<B::Concise>, L<B::Terse>.
-
-=head1 OPTIONS
-
-With option -exec, walks tree in execute order,
-otherwise in basic order.
-
-=head1 Changes
-
- 1.11 2008-07-14 rurban
- avoid B::Flags in CORE tests not to crash on old XS in @INC
-
- 1.10 2008-06-28 rurban
- require 5.006; Test::More not possible in 5.00505
- our => my
-
- 1.09 2008-06-18 rurban
- minor META.yml syntax fix
- 5.8.0 ending nextstate test failure: be more tolerant
- PREREQ_PM Test::More
-
- 1.08 2008-06-17 rurban
- support 5.00558 - 5.6.2
-
- 1.07 2008-06-16 rurban
- debug.t: fix strawberry perl quoting issue
-
- 1.06 2008-06-11 rurban
- added B::Flags output
- dual-life CPAN as B-Debug-1.06 and CORE
- protect scalar(@array) if tied arrays leave out FETCHSIZE
-
- 1.05_03 2008-04-16 rurban
- ithread fixes in B::AV
- B-C-1.04_??
-
- B-C-1.04_09 2008-02-24 rurban
- support 5.8 (import Asmdata)
-
- 1.05_02 2008-02-21 rurban
- added _printop
- B-C-1.04_08 and CORE
-
- 1.05_01 2008-02-05 rurban
- 5.10 fix for op->seq
- B-C-1.04_04
-
-=head1 AUTHOR
-
-Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
-Reini Urban C<rurban at cpan.org>
-
-=head1 LICENSE
-
-Copyright (c) 1996, 1997 Malcolm Beattie
-Copyright (c) 2008 Reini Urban
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of either:
-
- a) the GNU General Public License as published by the Free
- Software Foundation; either version 1, or (at your option) any
- later version, or
-
- b) the "Artistic License" which comes with this kit.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
- the GNU General Public License or the Artistic License for more details.
-
- You should have received a copy of the Artistic License with this kit,
- in the file named "Artistic". If not, you can get one from the Perl
- distribution. You should also have received a copy of the GNU General
- Public License, in the file named "Copying". If not, you can get one
- from the Perl distribution or else write to the Free Software Foundation,
- Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
-
-=cut
Deleted: trunk/contrib/perl/ext/B/B/Deparse.pm
===================================================================
--- trunk/contrib/perl/ext/B/B/Deparse.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/B/B/Deparse.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,4858 +0,0 @@
-# B::Deparse.pm
-# Copyright (c) 1998-2000, 2002, 2003, 2004, 2005, 2006 Stephen McCamant.
-# All rights reserved.
-# This module is free software; you can redistribute and/or modify
-# it under the same terms as Perl itself.
-
-# This is based on the module of the same name by Malcolm Beattie,
-# but essentially none of his code remains.
-
-package B::Deparse;
-use Carp;
-use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
- OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
- OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD OPpPAD_STATE
- OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
- OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
- OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
- OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
- SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
- CVf_METHOD CVf_LVALUE
- PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
- PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
- ($] < 5.009 ? 'PMf_SKIPWHITE' : 'RXf_SKIPWHITE'),
- ($] < 5.011 ? 'CVf_LOCKED' : ());
-$VERSION = 0.89;
-use strict;
-use vars qw/$AUTOLOAD/;
-use warnings ();
-
-BEGIN {
- # Easiest way to keep this code portable between 5.12.x and 5.10.x looks to
- # be to fake up a dummy CVf_LOCKED that will never actually be true.
- *CVf_LOCKED = sub () {0} unless defined &CVf_LOCKED;
-}
-
-# Changes between 0.50 and 0.51:
-# - fixed nulled leave with live enter in sort { }
-# - fixed reference constants (\"str")
-# - handle empty programs gracefully
-# - handle infinte loops (for (;;) {}, while (1) {})
-# - differentiate between `for my $x ...' and `my $x; for $x ...'
-# - various minor cleanups
-# - moved globals into an object
-# - added `-u', like B::C
-# - package declarations using cop_stash
-# - subs, formats and code sorted by cop_seq
-# Changes between 0.51 and 0.52:
-# - added pp_threadsv (special variables under USE_5005THREADS)
-# - added documentation
-# Changes between 0.52 and 0.53:
-# - many changes adding precedence contexts and associativity
-# - added `-p' and `-s' output style options
-# - various other minor fixes
-# Changes between 0.53 and 0.54:
-# - added support for new `for (1..100)' optimization,
-# thanks to Gisle Aas
-# Changes between 0.54 and 0.55:
-# - added support for new qr// construct
-# - added support for new pp_regcreset OP
-# Changes between 0.55 and 0.56:
-# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
-# - fixed $# on non-lexicals broken in last big rewrite
-# - added temporary fix for change in opcode of OP_STRINGIFY
-# - fixed problem in 0.54's for() patch in `for (@ary)'
-# - fixed precedence in conditional of ?:
-# - tweaked list paren elimination in `my($x) = @_'
-# - made continue-block detection trickier wrt. null ops
-# - fixed various prototype problems in pp_entersub
-# - added support for sub prototypes that never get GVs
-# - added unquoting for special filehandle first arg in truncate
-# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
-# - added semicolons at the ends of blocks
-# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
-# Changes between 0.56 and 0.561:
-# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
-# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
-# Changes between 0.561 and 0.57:
-# - stylistic changes to symbolic constant stuff
-# - handled scope in s///e replacement code
-# - added unquote option for expanding "" into concats, etc.
-# - split method and proto parts of pp_entersub into separate functions
-# - various minor cleanups
-# Changes after 0.57:
-# - added parens in \&foo (patch by Albert Dvornik)
-# Changes between 0.57 and 0.58:
-# - fixed `0' statements that weren't being printed
-# - added methods for use from other programs
-# (based on patches from James Duncan and Hugo van der Sanden)
-# - added -si and -sT to control indenting (also based on a patch from Hugo)
-# - added -sv to print something else instead of '???'
-# - preliminary version of utf8 tr/// handling
-# Changes after 0.58:
-# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
-# - added support for Hugo's new OP_SETSTATE (like nextstate)
-# Changes between 0.58 and 0.59
-# - added support for Chip's OP_METHOD_NAMED
-# - added support for Ilya's OPpTARGET_MY optimization
-# - elided arrows before `()' subscripts when possible
-# Changes between 0.59 and 0.60
-# - support for method attribues was added
-# - some warnings fixed
-# - separate recognition of constant subs
-# - rewrote continue block handling, now recoginizing for loops
-# - added more control of expanding control structures
-# Changes between 0.60 and 0.61 (mostly by Robin Houston)
-# - many bug-fixes
-# - support for pragmas and 'use'
-# - support for the little-used $[ variable
-# - support for __DATA__ sections
-# - UTF8 support
-# - BEGIN, CHECK, INIT and END blocks
-# - scoping of subroutine declarations fixed
-# - compile-time output from the input program can be suppressed, so that the
-# output is just the deparsed code. (a change to O.pm in fact)
-# - our() declarations
-# - *all* the known bugs are now listed in the BUGS section
-# - comprehensive test mechanism (TEST -deparse)
-# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
-# - bug-fixes
-# - new switch -P
-# - support for command-line switches (-l, -0, etc.)
-# Changes between 0.63 and 0.64
-# - support for //, CHECK blocks, and assertions
-# - improved handling of foreach loops and lexicals
-# - option to use Data::Dumper for constants
-# - more bug fixes
-# - discovered lots more bugs not yet fixed
-#
-# ...
-#
-# Changes between 0.72 and 0.73
-# - support new switch constructs
-
-# Todo:
-# (See also BUGS section at the end of this file)
-#
-# - finish tr/// changes
-# - add option for even more parens (generalize \&foo change)
-# - left/right context
-# - copy comments (look at real text with $^P?)
-# - avoid semis in one-statement blocks
-# - associativity of &&=, ||=, ?:
-# - ',' => '=>' (auto-unquote?)
-# - break long lines ("\r" as discretionary break?)
-# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
-# - more style options: brace style, hex vs. octal, quotes, ...
-# - print big ints as hex/octal instead of decimal (heuristic?)
-# - handle `my $x if 0'?
-# - version using op_next instead of op_first/sibling?
-# - avoid string copies (pass arrays, one big join?)
-# - here-docs?
-
-# Current test.deparse failures
-# comp/hints 6 - location of BEGIN blocks wrt. block openings
-# run/switchI 1 - missing -I switches entirely
-# perl -Ifoo -e 'print @INC'
-# op/caller 2 - warning mask propagates backwards before warnings::register
-# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
-# op/getpid 2 - can't assign to shared my() declaration (threads only)
-# 'my $x : shared = 5'
-# op/override 7 - parens on overriden require change v-string interpretation
-# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
-# c.f. 'BEGIN { *f = sub {0} }; f 2'
-# op/pat 774 - losing Unicode-ness of Latin1-only strings
-# 'use charnames ":short"; $x="\N{latin:a with acute}"'
-# op/recurse 12 - missing parens on recursive call makes it look like method
-# 'sub f { f($x) }'
-# op/subst 90 - inconsistent handling of utf8 under "use utf8"
-# op/taint 29 - "use re 'taint'" deparsed in the wrong place wrt. block open
-# op/tiehandle compile - "use strict" deparsed in the wrong place
-# uni/tr_ several
-# ext/B/t/xref 11 - line numbers when we add newlines to one-line subs
-# ext/Data/Dumper/t/dumper compile
-# ext/DB_file/several
-# ext/Encode/several
-# ext/Ernno/Errno warnings
-# ext/IO/lib/IO/t/io_sel 23
-# ext/PerlIO/t/encoding compile
-# ext/POSIX/t/posix 6
-# ext/Socket/Socket 8
-# ext/Storable/t/croak compile
-# lib/Attribute/Handlers/t/multi compile
-# lib/bignum/ several
-# lib/charnames 35
-# lib/constant 32
-# lib/English 40
-# lib/ExtUtils/t/bytes 4
-# lib/File/DosGlob compile
-# lib/Filter/Simple/t/data 1
-# lib/Math/BigInt/t/constant 1
-# lib/Net/t/config Deparse-warning
-# lib/overload compile
-# lib/Switch/ several
-# lib/Symbol 4
-# lib/Test/Simple several
-# lib/Term/Complete
-# lib/Tie/File/t/29_downcopy 5
-# lib/vars 22
-
-# Object fields (were globals):
-#
-# avoid_local:
-# (local($a), local($b)) and local($a, $b) have the same internal
-# representation but the short form looks better. We notice we can
-# use a large-scale local when checking the list, but need to prevent
-# individual locals too. This hash holds the addresses of OPs that
-# have already had their local-ness accounted for. The same thing
-# is done with my().
-#
-# curcv:
-# CV for current sub (or main program) being deparsed
-#
-# curcvlex:
-# Cached hash of lexical variables for curcv: keys are names,
-# each value is an array of pairs, indicating the cop_seq of scopes
-# in which a var of that name is valid.
-#
-# curcop:
-# COP for statement being deparsed
-#
-# curstash:
-# name of the current package for deparsed code
-#
-# subs_todo:
-# array of [cop_seq, CV, is_format?] for subs and formats we still
-# want to deparse
-#
-# protos_todo:
-# as above, but [name, prototype] for subs that never got a GV
-#
-# subs_done, forms_done:
-# keys are addresses of GVs for subs and formats we've already
-# deparsed (or at least put into subs_todo)
-#
-# subs_declared
-# keys are names of subs for which we've printed declarations.
-# That means we can omit parentheses from the arguments.
-#
-# subs_deparsed
-# Keeps track of fully qualified names of all deparsed subs.
-#
-# parens: -p
-# linenums: -l
-# unquote: -q
-# cuddle: ` ' or `\n', depending on -sC
-# indent_size: -si
-# use_tabs: -sT
-# ex_const: -sv
-
-# A little explanation of how precedence contexts and associativity
-# work:
-#
-# deparse() calls each per-op subroutine with an argument $cx (short
-# for context, but not the same as the cx* in the perl core), which is
-# a number describing the op's parents in terms of precedence, whether
-# they're inside an expression or at statement level, etc. (see
-# chart below). When ops with children call deparse on them, they pass
-# along their precedence. Fractional values are used to implement
-# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
-# parentheses hacks. The major disadvantage of this scheme is that
-# it doesn't know about right sides and left sides, so say if you
-# assign a listop to a variable, it can't tell it's allowed to leave
-# the parens off the listop.
-
-# Precedences:
-# 26 [TODO] inside interpolation context ("")
-# 25 left terms and list operators (leftward)
-# 24 left ->
-# 23 nonassoc ++ --
-# 22 right **
-# 21 right ! ~ \ and unary + and -
-# 20 left =~ !~
-# 19 left * / % x
-# 18 left + - .
-# 17 left << >>
-# 16 nonassoc named unary operators
-# 15 nonassoc < > <= >= lt gt le ge
-# 14 nonassoc == != <=> eq ne cmp
-# 13 left &
-# 12 left | ^
-# 11 left &&
-# 10 left ||
-# 9 nonassoc .. ...
-# 8 right ?:
-# 7 right = += -= *= etc.
-# 6 left , =>
-# 5 nonassoc list operators (rightward)
-# 4 right not
-# 3 left and
-# 2 left or xor
-# 1 statement modifiers
-# 0.5 statements, but still print scopes as do { ... }
-# 0 statement level
-
-# Nonprinting characters with special meaning:
-# \cS - steal parens (see maybe_parens_unop)
-# \n - newline and indent
-# \t - increase indent
-# \b - decrease indent (`outdent')
-# \f - flush left (no indent)
-# \cK - kill following semicolon, if any
-
-sub null {
- my $op = shift;
- return class($op) eq "NULL";
-}
-
-sub todo {
- my $self = shift;
- my($cv, $is_form) = @_;
- return unless ($cv->FILE eq $0 || exists $self->{files}{$cv->FILE});
- my $seq;
- if ($cv->OUTSIDE_SEQ) {
- $seq = $cv->OUTSIDE_SEQ;
- } elsif (!null($cv->START) and is_state($cv->START)) {
- $seq = $cv->START->cop_seq;
- } else {
- $seq = 0;
- }
- push @{$self->{'subs_todo'}}, [$seq, $cv, $is_form];
- unless ($is_form || class($cv->STASH) eq 'SPECIAL') {
- $self->{'subs_deparsed'}{$cv->STASH->NAME."::".$cv->GV->NAME} = 1;
- }
-}
-
-sub next_todo {
- my $self = shift;
- my $ent = shift @{$self->{'subs_todo'}};
- my $cv = $ent->[1];
- my $gv = $cv->GV;
- my $name = $self->gv_name($gv);
- if ($ent->[2]) {
- return "format $name =\n"
- . $self->deparse_format($ent->[1]). "\n";
- } else {
- $self->{'subs_declared'}{$name} = 1;
- if ($name eq "BEGIN") {
- my $use_dec = $self->begin_is_use($cv);
- if (defined ($use_dec) and $self->{'expand'} < 5) {
- return () if 0 == length($use_dec);
- return $use_dec;
- }
- }
- my $l = '';
- if ($self->{'linenums'}) {
- my $line = $gv->LINE;
- my $file = $gv->FILE;
- $l = "\n\f#line $line \"$file\"\n";
- }
- my $p = '';
- if (class($cv->STASH) ne "SPECIAL") {
- my $stash = $cv->STASH->NAME;
- if ($stash ne $self->{'curstash'}) {
- $p = "package $stash;\n";
- $name = "$self->{'curstash'}::$name" unless $name =~ /::/;
- $self->{'curstash'} = $stash;
- }
- $name =~ s/^\Q$stash\E::(?!\z|.*::)//;
- }
- return "${p}${l}sub $name " . $self->deparse_sub($cv);
- }
-}
-
-# Return a "use" declaration for this BEGIN block, if appropriate
-sub begin_is_use {
- my ($self, $cv) = @_;
- my $root = $cv->ROOT;
- local @$self{qw'curcv curcvlex'} = ($cv);
-#require B::Debug;
-#B::walkoptree($cv->ROOT, "debug");
- my $lineseq = $root->first;
- return if $lineseq->name ne "lineseq";
-
- my $req_op = $lineseq->first->sibling;
- return if $req_op->name ne "require";
-
- my $module;
- if ($req_op->first->private & OPpCONST_BARE) {
- # Actually it should always be a bareword
- $module = $self->const_sv($req_op->first)->PV;
- $module =~ s[/][::]g;
- $module =~ s/.pm$//;
- }
- else {
- $module = $self->const($self->const_sv($req_op->first), 6);
- }
-
- my $version;
- my $version_op = $req_op->sibling;
- return if class($version_op) eq "NULL";
- if ($version_op->name eq "lineseq") {
- # We have a version parameter; skip nextstate & pushmark
- my $constop = $version_op->first->next->next;
-
- return unless $self->const_sv($constop)->PV eq $module;
- $constop = $constop->sibling;
- $version = $self->const_sv($constop);
- if (class($version) eq "IV") {
- $version = $version->int_value;
- } elsif (class($version) eq "NV") {
- $version = $version->NV;
- } elsif (class($version) ne "PVMG") {
- # Includes PVIV and PVNV
- $version = $version->PV;
- } else {
- # version specified as a v-string
- $version = 'v'.join '.', map ord, split //, $version->PV;
- }
- $constop = $constop->sibling;
- return if $constop->name ne "method_named";
- return if $self->const_sv($constop)->PV ne "VERSION";
- }
-
- $lineseq = $version_op->sibling;
- return if $lineseq->name ne "lineseq";
- my $entersub = $lineseq->first->sibling;
- if ($entersub->name eq "stub") {
- return "use $module $version ();\n" if defined $version;
- return "use $module ();\n";
- }
- return if $entersub->name ne "entersub";
-
- # See if there are import arguments
- my $args = '';
-
- my $svop = $entersub->first->sibling; # Skip over pushmark
- return unless $self->const_sv($svop)->PV eq $module;
-
- # Pull out the arguments
- for ($svop=$svop->sibling; $svop->name ne "method_named";
- $svop = $svop->sibling) {
- $args .= ", " if length($args);
- $args .= $self->deparse($svop, 6);
- }
-
- my $use = 'use';
- my $method_named = $svop;
- return if $method_named->name ne "method_named";
- my $method_name = $self->const_sv($method_named)->PV;
-
- if ($method_name eq "unimport") {
- $use = 'no';
- }
-
- # Certain pragmas are dealt with using hint bits,
- # so we ignore them here
- if ($module eq 'strict' || $module eq 'integer'
- || $module eq 'bytes' || $module eq 'warnings'
- || $module eq 'feature') {
- return "";
- }
-
- if (defined $version && length $args) {
- return "$use $module $version ($args);\n";
- } elsif (defined $version) {
- return "$use $module $version;\n";
- } elsif (length $args) {
- return "$use $module ($args);\n";
- } else {
- return "$use $module;\n";
- }
-}
-
-sub stash_subs {
- my ($self, $pack) = @_;
- my (@ret, $stash);
- if (!defined $pack) {
- $pack = '';
- $stash = \%::;
- }
- else {
- $pack =~ s/(::)?$/::/;
- no strict 'refs';
- $stash = \%$pack;
- }
- my %stash = svref_2object($stash)->ARRAY;
- while (my ($key, $val) = each %stash) {
- my $class = class($val);
- if ($class eq "PV") {
- # Just a prototype. As an ugly but fairly effective way
- # to find out if it belongs here is to see if the AUTOLOAD
- # (if any) for the stash was defined in one of our files.
- my $A = $stash{"AUTOLOAD"};
- if (defined ($A) && class($A) eq "GV" && defined($A->CV)
- && class($A->CV) eq "CV") {
- my $AF = $A->FILE;
- next unless $AF eq $0 || exists $self->{'files'}{$AF};
- }
- push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
- } elsif ($class eq "IV") {
- # Just a name. As above.
- my $A = $stash{"AUTOLOAD"};
- if (defined ($A) && class($A) eq "GV" && defined($A->CV)
- && class($A->CV) eq "CV") {
- my $AF = $A->FILE;
- next unless $AF eq $0 || exists $self->{'files'}{$AF};
- }
- push @{$self->{'protos_todo'}}, [$pack . $key, undef];
- } elsif ($class eq "GV") {
- if (class(my $cv = $val->CV) ne "SPECIAL") {
- next if $self->{'subs_done'}{$$val}++;
- next if $$val != ${$cv->GV}; # Ignore imposters
- $self->todo($cv, 0);
- }
- if (class(my $cv = $val->FORM) ne "SPECIAL") {
- next if $self->{'forms_done'}{$$val}++;
- next if $$val != ${$cv->GV}; # Ignore imposters
- $self->todo($cv, 1);
- }
- if (class($val->HV) ne "SPECIAL" && $key =~ /::$/) {
- $self->stash_subs($pack . $key)
- unless $pack eq '' && $key eq 'main::';
- # avoid infinite recursion
- }
- }
- }
-}
-
-sub print_protos {
- my $self = shift;
- my $ar;
- my @ret;
- foreach $ar (@{$self->{'protos_todo'}}) {
- my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
- push @ret, "sub " . $ar->[0] . "$proto;\n";
- }
- delete $self->{'protos_todo'};
- return @ret;
-}
-
-sub style_opts {
- my $self = shift;
- my $opts = shift;
- my $opt;
- while (length($opt = substr($opts, 0, 1))) {
- if ($opt eq "C") {
- $self->{'cuddle'} = " ";
- $opts = substr($opts, 1);
- } elsif ($opt eq "i") {
- $opts =~ s/^i(\d+)//;
- $self->{'indent_size'} = $1;
- } elsif ($opt eq "T") {
- $self->{'use_tabs'} = 1;
- $opts = substr($opts, 1);
- } elsif ($opt eq "v") {
- $opts =~ s/^v([^.]*)(.|$)//;
- $self->{'ex_const'} = $1;
- }
- }
-}
-
-sub new {
- my $class = shift;
- my $self = bless {}, $class;
- $self->{'cuddle'} = "\n";
- $self->{'curcop'} = undef;
- $self->{'curstash'} = "main";
- $self->{'ex_const'} = "'???'";
- $self->{'expand'} = 0;
- $self->{'files'} = {};
- $self->{'indent_size'} = 4;
- $self->{'linenums'} = 0;
- $self->{'parens'} = 0;
- $self->{'subs_todo'} = [];
- $self->{'unquote'} = 0;
- $self->{'use_dumper'} = 0;
- $self->{'use_tabs'} = 0;
-
- $self->{'ambient_arybase'} = 0;
- $self->{'ambient_warnings'} = undef; # Assume no lexical warnings
- $self->{'ambient_hints'} = 0;
- $self->{'ambient_hinthash'} = undef;
- $self->init();
-
- while (my $arg = shift @_) {
- if ($arg eq "-d") {
- $self->{'use_dumper'} = 1;
- require Data::Dumper;
- } elsif ($arg =~ /^-f(.*)/) {
- $self->{'files'}{$1} = 1;
- } elsif ($arg eq "-l") {
- $self->{'linenums'} = 1;
- } elsif ($arg eq "-p") {
- $self->{'parens'} = 1;
- } elsif ($arg eq "-P") {
- $self->{'noproto'} = 1;
- } elsif ($arg eq "-q") {
- $self->{'unquote'} = 1;
- } elsif (substr($arg, 0, 2) eq "-s") {
- $self->style_opts(substr $arg, 2);
- } elsif ($arg =~ /^-x(\d)$/) {
- $self->{'expand'} = $1;
- }
- }
- return $self;
-}
-
-{
- # Mask out the bits that L<warnings::register> uses
- my $WARN_MASK;
- BEGIN {
- $WARN_MASK = $warnings::Bits{all} | $warnings::DeadBits{all};
- }
- sub WARN_MASK () {
- return $WARN_MASK;
- }
-}
-
-# Initialise the contextual information, either from
-# defaults provided with the ambient_pragmas method,
-# or from perl's own defaults otherwise.
-sub init {
- my $self = shift;
-
- $self->{'arybase'} = $self->{'ambient_arybase'};
- $self->{'warnings'} = defined ($self->{'ambient_warnings'})
- ? $self->{'ambient_warnings'} & WARN_MASK
- : undef;
- $self->{'hints'} = $self->{'ambient_hints'};
- $self->{'hints'} &= 0xFF if $] < 5.009;
- $self->{'hinthash'} = $self->{'ambient_hinthash'};
-
- # also a convenient place to clear out subs_declared
- delete $self->{'subs_declared'};
-}
-
-sub compile {
- my(@args) = @_;
- return sub {
- my $self = B::Deparse->new(@args);
- # First deparse command-line args
- if (defined $^I) { # deparse -i
- print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
- }
- if ($^W) { # deparse -w
- print qq(BEGIN { \$^W = $^W; }\n);
- }
- if ($/ ne "\n" or defined $O::savebackslash) { # deparse -l and -0
- my $fs = perlstring($/) || 'undef';
- my $bs = perlstring($O::savebackslash) || 'undef';
- print qq(BEGIN { \$/ = $fs; \$\\ = $bs; }\n);
- }
- my @BEGINs = B::begin_av->isa("B::AV") ? B::begin_av->ARRAY : ();
- my @UNITCHECKs = B::unitcheck_av->isa("B::AV")
- ? B::unitcheck_av->ARRAY
- : ();
- my @CHECKs = B::check_av->isa("B::AV") ? B::check_av->ARRAY : ();
- my @INITs = B::init_av->isa("B::AV") ? B::init_av->ARRAY : ();
- my @ENDs = B::end_av->isa("B::AV") ? B::end_av->ARRAY : ();
- for my $block (@BEGINs, @UNITCHECKs, @CHECKs, @INITs, @ENDs) {
- $self->todo($block, 0);
- }
- $self->stash_subs();
- local($SIG{"__DIE__"}) =
- sub {
- if ($self->{'curcop'}) {
- my $cop = $self->{'curcop'};
- my($line, $file) = ($cop->line, $cop->file);
- print STDERR "While deparsing $file near line $line,\n";
- }
- };
- $self->{'curcv'} = main_cv;
- $self->{'curcvlex'} = undef;
- print $self->print_protos;
- @{$self->{'subs_todo'}} =
- sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
- print $self->indent($self->deparse_root(main_root)), "\n"
- unless null main_root;
- my @text;
- while (scalar(@{$self->{'subs_todo'}})) {
- push @text, $self->next_todo;
- }
- print $self->indent(join("", @text)), "\n" if @text;
-
- # Print __DATA__ section, if necessary
- no strict 'refs';
- my $laststash = defined $self->{'curcop'}
- ? $self->{'curcop'}->stash->NAME : $self->{'curstash'};
- if (defined *{$laststash."::DATA"}{IO}) {
- print "package $laststash;\n"
- unless $laststash eq $self->{'curstash'};
- print "__DATA__\n";
- print readline(*{$laststash."::DATA"});
- }
- }
-}
-
-sub coderef2text {
- my $self = shift;
- my $sub = shift;
- croak "Usage: ->coderef2text(CODEREF)" unless UNIVERSAL::isa($sub, "CODE");
-
- $self->init();
- return $self->indent($self->deparse_sub(svref_2object($sub)));
-}
-
-sub ambient_pragmas {
- my $self = shift;
- my ($arybase, $hint_bits, $warning_bits, $hinthash) = (0, 0);
-
- while (@_ > 1) {
- my $name = shift();
- my $val = shift();
-
- if ($name eq 'strict') {
- require strict;
-
- if ($val eq 'none') {
- $hint_bits &= ~strict::bits(qw/refs subs vars/);
- next();
- }
-
- my @names;
- if ($val eq "all") {
- @names = qw/refs subs vars/;
- }
- elsif (ref $val) {
- @names = @$val;
- }
- else {
- @names = split' ', $val;
- }
- $hint_bits |= strict::bits(@names);
- }
-
- elsif ($name eq '$[') {
- $arybase = $val;
- }
-
- elsif ($name eq 'integer'
- || $name eq 'bytes'
- || $name eq 'utf8') {
- require "$name.pm";
- if ($val) {
- $hint_bits |= ${$::{"${name}::"}{"hint_bits"}};
- }
- else {
- $hint_bits &= ~${$::{"${name}::"}{"hint_bits"}};
- }
- }
-
- elsif ($name eq 're') {
- require re;
- if ($val eq 'none') {
- $hint_bits &= ~re::bits(qw/taint eval/);
- next();
- }
-
- my @names;
- if ($val eq 'all') {
- @names = qw/taint eval/;
- }
- elsif (ref $val) {
- @names = @$val;
- }
- else {
- @names = split' ',$val;
- }
- $hint_bits |= re::bits(@names);
- }
-
- elsif ($name eq 'warnings') {
- if ($val eq 'none') {
- $warning_bits = $warnings::NONE;
- next();
- }
-
- my @names;
- if (ref $val) {
- @names = @$val;
- }
- else {
- @names = split/\s+/, $val;
- }
-
- $warning_bits = $warnings::NONE if !defined ($warning_bits);
- $warning_bits |= warnings::bits(@names);
- }
-
- elsif ($name eq 'warning_bits') {
- $warning_bits = $val;
- }
-
- elsif ($name eq 'hint_bits') {
- $hint_bits = $val;
- }
-
- elsif ($name eq '%^H') {
- $hinthash = $val;
- }
-
- else {
- croak "Unknown pragma type: $name";
- }
- }
- if (@_) {
- croak "The ambient_pragmas method expects an even number of args";
- }
-
- $self->{'ambient_arybase'} = $arybase;
- $self->{'ambient_warnings'} = $warning_bits;
- $self->{'ambient_hints'} = $hint_bits;
- $self->{'ambient_hinthash'} = $hinthash;
-}
-
-# This method is the inner loop, so try to keep it simple
-sub deparse {
- my $self = shift;
- my($op, $cx) = @_;
-
- Carp::confess("Null op in deparse") if !defined($op)
- || class($op) eq "NULL";
- my $meth = "pp_" . $op->name;
- return $self->$meth($op, $cx);
-}
-
-sub indent {
- my $self = shift;
- my $txt = shift;
- my @lines = split(/\n/, $txt);
- my $leader = "";
- my $level = 0;
- my $line;
- for $line (@lines) {
- my $cmd = substr($line, 0, 1);
- if ($cmd eq "\t" or $cmd eq "\b") {
- $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
- if ($self->{'use_tabs'}) {
- $leader = "\t" x ($level / 8) . " " x ($level % 8);
- } else {
- $leader = " " x $level;
- }
- $line = substr($line, 1);
- }
- if (substr($line, 0, 1) eq "\f") {
- $line = substr($line, 1); # no indent
- } else {
- $line = $leader . $line;
- }
- $line =~ s/\cK;?//g;
- }
- return join("\n", @lines);
-}
-
-sub deparse_sub {
- my $self = shift;
- my $cv = shift;
- my $proto = "";
-Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
-Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
- local $self->{'curcop'} = $self->{'curcop'};
- if ($cv->FLAGS & SVf_POK) {
- $proto = "(". $cv->PV . ") ";
- }
- if ($cv->CvFLAGS & (CVf_METHOD|CVf_LOCKED|CVf_LVALUE)) {
- $proto .= ": ";
- $proto .= "lvalue " if $cv->CvFLAGS & CVf_LVALUE;
- $proto .= "locked " if $cv->CvFLAGS & CVf_LOCKED;
- $proto .= "method " if $cv->CvFLAGS & CVf_METHOD;
- }
-
- local($self->{'curcv'}) = $cv;
- local($self->{'curcvlex'});
- local(@$self{qw'curstash warnings hints hinthash'})
- = @$self{qw'curstash warnings hints hinthash'};
- my $body;
- if (not null $cv->ROOT) {
- my $lineseq = $cv->ROOT->first;
- if ($lineseq->name eq "lineseq") {
- my @ops;
- for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
- push @ops, $o;
- }
- $body = $self->lineseq(undef, @ops).";";
- my $scope_en = $self->find_scope_en($lineseq);
- if (defined $scope_en) {
- my $subs = join"", $self->seq_subs($scope_en);
- $body .= ";\n$subs" if length($subs);
- }
- }
- else {
- $body = $self->deparse($cv->ROOT->first, 0);
- }
- }
- else {
- my $sv = $cv->const_sv;
- if ($$sv) {
- # uh-oh. inlinable sub... format it differently
- return $proto . "{ " . $self->const($sv, 0) . " }\n";
- } else { # XSUB? (or just a declaration)
- return "$proto;\n";
- }
- }
- return $proto ."{\n\t$body\n\b}" ."\n";
-}
-
-sub deparse_format {
- my $self = shift;
- my $form = shift;
- my @text;
- local($self->{'curcv'}) = $form;
- local($self->{'curcvlex'});
- local($self->{'in_format'}) = 1;
- local(@$self{qw'curstash warnings hints hinthash'})
- = @$self{qw'curstash warnings hints hinthash'};
- my $op = $form->ROOT;
- my $kid;
- return "\f." if $op->first->name eq 'stub'
- || $op->first->name eq 'nextstate';
- $op = $op->first->first; # skip leavewrite, lineseq
- while (not null $op) {
- $op = $op->sibling; # skip nextstate
- my @exprs;
- $kid = $op->first->sibling; # skip pushmark
- push @text, "\f".$self->const_sv($kid)->PV;
- $kid = $kid->sibling;
- for (; not null $kid; $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 0);
- }
- push @text, "\f".join(", ", @exprs)."\n" if @exprs;
- $op = $op->sibling;
- }
- return join("", @text) . "\f.";
-}
-
-sub is_scope {
- my $op = shift;
- return $op->name eq "leave" || $op->name eq "scope"
- || $op->name eq "lineseq"
- || ($op->name eq "null" && class($op) eq "UNOP"
- && (is_scope($op->first) || $op->first->name eq "enter"));
-}
-
-sub is_state {
- my $name = $_[0]->name;
- return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
-}
-
-sub is_miniwhile { # check for one-line loop (`foo() while $y--')
- my $op = shift;
- return (!null($op) and null($op->sibling)
- and $op->name eq "null" and class($op) eq "UNOP"
- and (($op->first->name =~ /^(and|or)$/
- and $op->first->first->sibling->name eq "lineseq")
- or ($op->first->name eq "lineseq"
- and not null $op->first->first->sibling
- and $op->first->first->sibling->name eq "unstack")
- ));
-}
-
-# Check if the op and its sibling are the initialization and the rest of a
-# for (..;..;..) { ... } loop
-sub is_for_loop {
- my $op = shift;
- # This OP might be almost anything, though it won't be a
- # nextstate. (It's the initialization, so in the canonical case it
- # will be an sassign.) The sibling is a lineseq whose first child
- # is a nextstate and whose second is a leaveloop.
- my $lseq = $op->sibling;
- if (!is_state $op and !null($lseq) and $lseq->name eq "lineseq") {
- if ($lseq->first && !null($lseq->first) && is_state($lseq->first)
- && (my $sib = $lseq->first->sibling)) {
- return (!null($sib) && $sib->name eq "leaveloop");
- }
- }
- return 0;
-}
-
-sub is_scalar {
- my $op = shift;
- return ($op->name eq "rv2sv" or
- $op->name eq "padsv" or
- $op->name eq "gv" or # only in array/hash constructs
- $op->flags & OPf_KIDS && !null($op->first)
- && $op->first->name eq "gvsv");
-}
-
-sub maybe_parens {
- my $self = shift;
- my($text, $cx, $prec) = @_;
- if ($prec < $cx # unary ops nest just fine
- or $prec == $cx and $cx != 4 and $cx != 16 and $cx != 21
- or $self->{'parens'})
- {
- $text = "($text)";
- # In a unop, let parent reuse our parens; see maybe_parens_unop
- $text = "\cS" . $text if $cx == 16;
- return $text;
- } else {
- return $text;
- }
-}
-
-# same as above, but get around the `if it looks like a function' rule
-sub maybe_parens_unop {
- my $self = shift;
- my($name, $kid, $cx) = @_;
- if ($cx > 16 or $self->{'parens'}) {
- $kid = $self->deparse($kid, 1);
- if ($name eq "umask" && $kid =~ /^\d+$/) {
- $kid = sprintf("%#o", $kid);
- }
- return "$name($kid)";
- } else {
- $kid = $self->deparse($kid, 16);
- if ($name eq "umask" && $kid =~ /^\d+$/) {
- $kid = sprintf("%#o", $kid);
- }
- if (substr($kid, 0, 1) eq "\cS") {
- # use kid's parens
- return $name . substr($kid, 1);
- } elsif (substr($kid, 0, 1) eq "(") {
- # avoid looks-like-a-function trap with extra parens
- # (`+' can lead to ambiguities)
- return "$name(" . $kid . ")";
- } else {
- return "$name $kid";
- }
- }
-}
-
-sub maybe_parens_func {
- my $self = shift;
- my($func, $text, $cx, $prec) = @_;
- if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
- return "$func($text)";
- } else {
- return "$func $text";
- }
-}
-
-sub maybe_local {
- my $self = shift;
- my($op, $cx, $text) = @_;
- my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0;
- if ($op->private & (OPpLVAL_INTRO|$our_intro)
- and not $self->{'avoid_local'}{$$op}) {
- my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our";
- if( $our_local eq 'our' ) {
- # XXX This assertion fails code with non-ASCII identifiers,
- # like ./ext/Encode/t/jperl.t
- die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
- $text =~ s/(\w+::)+//;
- }
- if (want_scalar($op)) {
- return "$our_local $text";
- } else {
- return $self->maybe_parens_func("$our_local", $text, $cx, 16);
- }
- } else {
- return $text;
- }
-}
-
-sub maybe_targmy {
- my $self = shift;
- my($op, $cx, $func, @args) = @_;
- if ($op->private & OPpTARGET_MY) {
- my $var = $self->padname($op->targ);
- my $val = $func->($self, $op, 7, @args);
- return $self->maybe_parens("$var = $val", $cx, 7);
- } else {
- return $func->($self, $op, $cx, @args);
- }
-}
-
-sub padname_sv {
- my $self = shift;
- my $targ = shift;
- return $self->{'curcv'}->PADLIST->ARRAYelt(0)->ARRAYelt($targ);
-}
-
-sub maybe_my {
- my $self = shift;
- my($op, $cx, $text) = @_;
- if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
- my $my = $op->private & OPpPAD_STATE ? "state" : "my";
- if (want_scalar($op)) {
- return "$my $text";
- } else {
- return $self->maybe_parens_func($my, $text, $cx, 16);
- }
- } else {
- return $text;
- }
-}
-
-# The following OPs don't have functions:
-
-# pp_padany -- does not exist after parsing
-
-sub AUTOLOAD {
- if ($AUTOLOAD =~ s/^.*::pp_//) {
- warn "unexpected OP_".uc $AUTOLOAD;
- return "XXX";
- } else {
- die "Undefined subroutine $AUTOLOAD called";
- }
-}
-
-sub DESTROY {} # Do not AUTOLOAD
-
-# $root should be the op which represents the root of whatever
-# we're sequencing here. If it's undefined, then we don't append
-# any subroutine declarations to the deparsed ops, otherwise we
-# append appropriate declarations.
-sub lineseq {
- my($self, $root, @ops) = @_;
- my($expr, @exprs);
-
- my $out_cop = $self->{'curcop'};
- my $out_seq = defined($out_cop) ? $out_cop->cop_seq : undef;
- my $limit_seq;
- if (defined $root) {
- $limit_seq = $out_seq;
- my $nseq;
- $nseq = $self->find_scope_st($root->sibling) if ${$root->sibling};
- $limit_seq = $nseq if !defined($limit_seq)
- or defined($nseq) && $nseq < $limit_seq;
- }
- $limit_seq = $self->{'limit_seq'}
- if defined($self->{'limit_seq'})
- && (!defined($limit_seq) || $self->{'limit_seq'} < $limit_seq);
- local $self->{'limit_seq'} = $limit_seq;
-
- $self->walk_lineseq($root, \@ops,
- sub { push @exprs, $_[0]} );
-
- my $body = join(";\n", grep {length} @exprs);
- my $subs = "";
- if (defined $root && defined $limit_seq && !$self->{'in_format'}) {
- $subs = join "\n", $self->seq_subs($limit_seq);
- }
- return join(";\n", grep {length} $body, $subs);
-}
-
-sub scopeop {
- my($real_block, $self, $op, $cx) = @_;
- my $kid;
- my @kids;
-
- local(@$self{qw'curstash warnings hints hinthash'})
- = @$self{qw'curstash warnings hints hinthash'} if $real_block;
- if ($real_block) {
- $kid = $op->first->sibling; # skip enter
- if (is_miniwhile($kid)) {
- my $top = $kid->first;
- my $name = $top->name;
- if ($name eq "and") {
- $name = "while";
- } elsif ($name eq "or") {
- $name = "until";
- } else { # no conditional -> while 1 or until 0
- return $self->deparse($top->first, 1) . " while 1";
- }
- my $cond = $top->first;
- my $body = $cond->sibling->first; # skip lineseq
- $cond = $self->deparse($cond, 1);
- $body = $self->deparse($body, 1);
- return "$body $name $cond";
- }
- } else {
- $kid = $op->first;
- }
- for (; !null($kid); $kid = $kid->sibling) {
- push @kids, $kid;
- }
- if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
- return "do {\n\t" . $self->lineseq($op, @kids) . "\n\b}";
- } else {
- my $lineseq = $self->lineseq($op, @kids);
- return (length ($lineseq) ? "$lineseq;" : "");
- }
-}
-
-sub pp_scope { scopeop(0, @_); }
-sub pp_lineseq { scopeop(0, @_); }
-sub pp_leave { scopeop(1, @_); }
-
-# This is a special case of scopeop and lineseq, for the case of the
-# main_root. The difference is that we print the output statements as
-# soon as we get them, for the sake of impatient users.
-sub deparse_root {
- my $self = shift;
- my($op) = @_;
- local(@$self{qw'curstash warnings hints hinthash'})
- = @$self{qw'curstash warnings hints hinthash'};
- my @kids;
- return if null $op->first; # Can happen, e.g., for Bytecode without -k
- for (my $kid = $op->first->sibling; !null($kid); $kid = $kid->sibling) {
- push @kids, $kid;
- }
- $self->walk_lineseq($op, \@kids,
- sub { print $self->indent($_[0].';');
- print "\n" unless $_[1] == $#kids;
- });
-}
-
-sub walk_lineseq {
- my ($self, $op, $kids, $callback) = @_;
- my @kids = @$kids;
- for (my $i = 0; $i < @kids; $i++) {
- my $expr = "";
- if (is_state $kids[$i]) {
- $expr = $self->deparse($kids[$i++], 0);
- if ($i > $#kids) {
- $callback->($expr, $i);
- last;
- }
- }
- if (is_for_loop($kids[$i])) {
- $callback->($expr . $self->for_loop($kids[$i], 0), $i++);
- next;
- }
- $expr .= $self->deparse($kids[$i], (@kids != 1)/2);
- $expr =~ s/;\n?\z//;
- $callback->($expr, $i);
- }
-}
-
-# The BEGIN {} is used here because otherwise this code isn't executed
-# when you run B::Deparse on itself.
-my %globalnames;
-BEGIN { map($globalnames{$_}++, "SIG", "STDIN", "STDOUT", "STDERR", "INC",
- "ENV", "ARGV", "ARGVOUT", "_"); }
-
-sub gv_name {
- my $self = shift;
- my $gv = shift;
-Carp::confess() unless ref($gv) eq "B::GV";
- my $stash = $gv->STASH->NAME;
- my $name = $gv->SAFENAME;
- if ($stash eq 'main' && $name =~ /^::/) {
- $stash = '::';
- }
- elsif (($stash eq 'main' && $globalnames{$name})
- or ($stash eq $self->{'curstash'} && !$globalnames{$name}
- && ($stash eq 'main' || $name !~ /::/))
- or $name =~ /^[^A-Za-z_:]/)
- {
- $stash = "";
- } else {
- $stash = $stash . "::";
- }
- if ($name =~ /^(\^..|{)/) {
- $name = "{$name}"; # ${^WARNING_BITS}, etc and ${
- }
- return $stash . $name;
-}
-
-# Return the name to use for a stash variable.
-# If a lexical with the same name is in scope, it may need to be
-# fully-qualified.
-sub stash_variable {
- my ($self, $prefix, $name) = @_;
-
- return "$prefix$name" if $name =~ /::/;
-
- unless ($prefix eq '$' || $prefix eq '@' || #'
- $prefix eq '%' || $prefix eq '$#') {
- return "$prefix$name";
- }
-
- my $v = ($prefix eq '$#' ? '@' : $prefix) . $name;
- return $prefix .$self->{'curstash'}.'::'. $name if $self->lex_in_scope($v);
- return "$prefix$name";
-}
-
-sub lex_in_scope {
- my ($self, $name) = @_;
- $self->populate_curcvlex() if !defined $self->{'curcvlex'};
-
- return 0 if !defined($self->{'curcop'});
- my $seq = $self->{'curcop'}->cop_seq;
- return 0 if !exists $self->{'curcvlex'}{$name};
- for my $a (@{$self->{'curcvlex'}{$name}}) {
- my ($st, $en) = @$a;
- return 1 if $seq > $st && $seq <= $en;
- }
- return 0;
-}
-
-sub populate_curcvlex {
- my $self = shift;
- for (my $cv = $self->{'curcv'}; class($cv) eq "CV"; $cv = $cv->OUTSIDE) {
- my $padlist = $cv->PADLIST;
- # an undef CV still in lexical chain
- next if class($padlist) eq "SPECIAL";
- my @padlist = $padlist->ARRAY;
- my @ns = $padlist[0]->ARRAY;
-
- for (my $i=0; $i<@ns; ++$i) {
- next if class($ns[$i]) eq "SPECIAL";
- next if $ns[$i]->FLAGS & SVpad_OUR; # Skip "our" vars
- if (class($ns[$i]) eq "PV") {
- # Probably that pesky lexical @_
- next;
- }
- my $name = $ns[$i]->PVX;
- my ($seq_st, $seq_en) =
- ($ns[$i]->FLAGS & SVf_FAKE)
- ? (0, 999999)
- : ($ns[$i]->COP_SEQ_RANGE_LOW, $ns[$i]->COP_SEQ_RANGE_HIGH);
-
- push @{$self->{'curcvlex'}{$name}}, [$seq_st, $seq_en];
- }
- }
-}
-
-sub find_scope_st { ((find_scope(@_))[0]); }
-sub find_scope_en { ((find_scope(@_))[1]); }
-
-# Recurses down the tree, looking for pad variable introductions and COPs
-sub find_scope {
- my ($self, $op, $scope_st, $scope_en) = @_;
- carp("Undefined op in find_scope") if !defined $op;
- return ($scope_st, $scope_en) unless $op->flags & OPf_KIDS;
-
- my @queue = ($op);
- while(my $op = shift @queue ) {
- for (my $o=$op->first; $$o; $o=$o->sibling) {
- if ($o->name =~ /^pad.v$/ && $o->private & OPpLVAL_INTRO) {
- my $s = int($self->padname_sv($o->targ)->COP_SEQ_RANGE_LOW);
- my $e = $self->padname_sv($o->targ)->COP_SEQ_RANGE_HIGH;
- $scope_st = $s if !defined($scope_st) || $s < $scope_st;
- $scope_en = $e if !defined($scope_en) || $e > $scope_en;
- return ($scope_st, $scope_en);
- }
- elsif (is_state($o)) {
- my $c = $o->cop_seq;
- $scope_st = $c if !defined($scope_st) || $c < $scope_st;
- $scope_en = $c if !defined($scope_en) || $c > $scope_en;
- return ($scope_st, $scope_en);
- }
- elsif ($o->flags & OPf_KIDS) {
- unshift (@queue, $o);
- }
- }
- }
-
- return ($scope_st, $scope_en);
-}
-
-# Returns a list of subs which should be inserted before the COP
-sub cop_subs {
- my ($self, $op, $out_seq) = @_;
- my $seq = $op->cop_seq;
- # If we have nephews, then our sequence number indicates
- # the cop_seq of the end of some sort of scope.
- if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
- and my $nseq = $self->find_scope_st($op->sibling) ) {
- $seq = $nseq;
- }
- $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
- return $self->seq_subs($seq);
-}
-
-sub seq_subs {
- my ($self, $seq) = @_;
- my @text;
-#push @text, "# ($seq)\n";
-
- return "" if !defined $seq;
- while (scalar(@{$self->{'subs_todo'}})
- and $seq > $self->{'subs_todo'}[0][0]) {
- push @text, $self->next_todo;
- }
- return @text;
-}
-
-# Notice how subs and formats are inserted between statements here;
-# also $[ assignments and pragmas.
-sub pp_nextstate {
- my $self = shift;
- my($op, $cx) = @_;
- $self->{'curcop'} = $op;
- my @text;
- push @text, $self->cop_subs($op);
- push @text, $op->label . ": " if $op->label;
- my $stash = $op->stashpv;
- if ($stash ne $self->{'curstash'}) {
- push @text, "package $stash;\n";
- $self->{'curstash'} = $stash;
- }
-
- if ($self->{'arybase'} != $op->arybase) {
- push @text, '$[ = '. $op->arybase .";\n";
- $self->{'arybase'} = $op->arybase;
- }
-
- my $warnings = $op->warnings;
- my $warning_bits;
- if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
- $warning_bits = $warnings::Bits{"all"} & WARN_MASK;
- }
- elsif ($warnings->isa("B::SPECIAL") && $$warnings == 5) {
- $warning_bits = $warnings::NONE;
- }
- elsif ($warnings->isa("B::SPECIAL")) {
- $warning_bits = undef;
- }
- else {
- $warning_bits = $warnings->PV & WARN_MASK;
- }
-
- if (defined ($warning_bits) and
- !defined($self->{warnings}) || $self->{'warnings'} ne $warning_bits) {
- push @text, declare_warnings($self->{'warnings'}, $warning_bits);
- $self->{'warnings'} = $warning_bits;
- }
-
- if ($self->{'hints'} != $op->hints) {
- push @text, declare_hints($self->{'hints'}, $op->hints);
- $self->{'hints'} = $op->hints;
- }
-
- # hack to check that the hint hash hasn't changed
- if ($] > 5.009 &&
- "@{[sort %{$self->{'hinthash'} || {}}]}"
- ne "@{[sort %{$op->hints_hash->HASH || {}}]}") {
- push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size});
- $self->{'hinthash'} = $op->hints_hash->HASH;
- }
-
- # This should go after of any branches that add statements, to
- # increase the chances that it refers to the same line it did in
- # the original program.
- if ($self->{'linenums'}) {
- push @text, "\f#line " . $op->line .
- ' "' . $op->file, qq'"\n';
- }
-
- return join("", @text);
-}
-
-sub declare_warnings {
- my ($from, $to) = @_;
- if (($to & WARN_MASK) eq (warnings::bits("all") & WARN_MASK)) {
- return "use warnings;\n";
- }
- elsif (($to & WARN_MASK) eq ("\0"x length($to) & WARN_MASK)) {
- return "no warnings;\n";
- }
- return "BEGIN {\${^WARNING_BITS} = ".perlstring($to)."}\n";
-}
-
-sub declare_hints {
- my ($from, $to) = @_;
- my $use = $to & ~$from;
- my $no = $from & ~$to;
- my $decls = "";
- for my $pragma (hint_pragmas($use)) {
- $decls .= "use $pragma;\n";
- }
- for my $pragma (hint_pragmas($no)) {
- $decls .= "no $pragma;\n";
- }
- return $decls;
-}
-
-# Internal implementation hints that the core sets automatically, so don't need
-# (or want) to be passed back to the user
-my %ignored_hints = (
- 'open<' => 1,
- 'open>' => 1,
- ':' => 1,
-);
-
-sub declare_hinthash {
- my ($from, $to, $indent) = @_;
- my @decls;
- for my $key (keys %$to) {
- next if $ignored_hints{$key};
- if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) {
- push @decls, qq(\$^H{'$key'} = q($to->{$key}););
- }
- }
- for my $key (keys %$from) {
- next if $ignored_hints{$key};
- if (!exists $to->{$key}) {
- push @decls, qq(delete \$^H{'$key'};);
- }
- }
- @decls or return '';
- return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
-}
-
-sub hint_pragmas {
- my ($bits) = @_;
- my @pragmas;
- push @pragmas, "integer" if $bits & 0x1;
- push @pragmas, "strict 'refs'" if $bits & 0x2;
- push @pragmas, "bytes" if $bits & 0x8;
- return @pragmas;
-}
-
-sub pp_dbstate { pp_nextstate(@_) }
-sub pp_setstate { pp_nextstate(@_) }
-
-sub pp_unstack { return "" } # see also leaveloop
-
-sub baseop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- return $name;
-}
-
-sub pp_stub {
- my $self = shift;
- my($op, $cx, $name) = @_;
- if ($cx >= 1) {
- return "()";
- }
- else {
- return "();";
- }
-}
-sub pp_wantarray { baseop(@_, "wantarray") }
-sub pp_fork { baseop(@_, "fork") }
-sub pp_wait { maybe_targmy(@_, \&baseop, "wait") }
-sub pp_getppid { maybe_targmy(@_, \&baseop, "getppid") }
-sub pp_time { maybe_targmy(@_, \&baseop, "time") }
-sub pp_tms { baseop(@_, "times") }
-sub pp_ghostent { baseop(@_, "gethostent") }
-sub pp_gnetent { baseop(@_, "getnetent") }
-sub pp_gprotoent { baseop(@_, "getprotoent") }
-sub pp_gservent { baseop(@_, "getservent") }
-sub pp_ehostent { baseop(@_, "endhostent") }
-sub pp_enetent { baseop(@_, "endnetent") }
-sub pp_eprotoent { baseop(@_, "endprotoent") }
-sub pp_eservent { baseop(@_, "endservent") }
-sub pp_gpwent { baseop(@_, "getpwent") }
-sub pp_spwent { baseop(@_, "setpwent") }
-sub pp_epwent { baseop(@_, "endpwent") }
-sub pp_ggrent { baseop(@_, "getgrent") }
-sub pp_sgrent { baseop(@_, "setgrent") }
-sub pp_egrent { baseop(@_, "endgrent") }
-sub pp_getlogin { baseop(@_, "getlogin") }
-
-sub POSTFIX () { 1 }
-
-# I couldn't think of a good short name, but this is the category of
-# symbolic unary operators with interesting precedence
-
-sub pfixop {
- my $self = shift;
- my($op, $cx, $name, $prec, $flags) = (@_, 0);
- my $kid = $op->first;
- $kid = $self->deparse($kid, $prec);
- return $self->maybe_parens(($flags & POSTFIX) ? "$kid$name" : "$name$kid",
- $cx, $prec);
-}
-
-sub pp_preinc { pfixop(@_, "++", 23) }
-sub pp_predec { pfixop(@_, "--", 23) }
-sub pp_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
-sub pp_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
-sub pp_i_preinc { pfixop(@_, "++", 23) }
-sub pp_i_predec { pfixop(@_, "--", 23) }
-sub pp_i_postinc { maybe_targmy(@_, \&pfixop, "++", 23, POSTFIX) }
-sub pp_i_postdec { maybe_targmy(@_, \&pfixop, "--", 23, POSTFIX) }
-sub pp_complement { maybe_targmy(@_, \&pfixop, "~", 21) }
-
-sub pp_negate { maybe_targmy(@_, \&real_negate) }
-sub real_negate {
- my $self = shift;
- my($op, $cx) = @_;
- if ($op->first->name =~ /^(i_)?negate$/) {
- # avoid --$x
- $self->pfixop($op, $cx, "-", 21.5);
- } else {
- $self->pfixop($op, $cx, "-", 21);
- }
-}
-sub pp_i_negate { pp_negate(@_) }
-
-sub pp_not {
- my $self = shift;
- my($op, $cx) = @_;
- if ($cx <= 4) {
- $self->pfixop($op, $cx, "not ", 4);
- } else {
- $self->pfixop($op, $cx, "!", 21);
- }
-}
-
-sub unop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- my $kid;
- if ($op->flags & OPf_KIDS) {
- $kid = $op->first;
- my $builtinname = $name;
- $builtinname =~ /^CORE::/ or $builtinname = "CORE::$name";
- if (defined prototype($builtinname)
- && prototype($builtinname) =~ /^;?\*/
- && $kid->name eq "rv2gv") {
- $kid = $kid->first;
- }
-
- return $self->maybe_parens_unop($name, $kid, $cx);
- } else {
- return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
- }
-}
-
-sub pp_chop { maybe_targmy(@_, \&unop, "chop") }
-sub pp_chomp { maybe_targmy(@_, \&unop, "chomp") }
-sub pp_schop { maybe_targmy(@_, \&unop, "chop") }
-sub pp_schomp { maybe_targmy(@_, \&unop, "chomp") }
-sub pp_defined { unop(@_, "defined") }
-sub pp_undef { unop(@_, "undef") }
-sub pp_study { unop(@_, "study") }
-sub pp_ref { unop(@_, "ref") }
-sub pp_pos { maybe_local(@_, unop(@_, "pos")) }
-
-sub pp_sin { maybe_targmy(@_, \&unop, "sin") }
-sub pp_cos { maybe_targmy(@_, \&unop, "cos") }
-sub pp_rand { maybe_targmy(@_, \&unop, "rand") }
-sub pp_srand { unop(@_, "srand") }
-sub pp_exp { maybe_targmy(@_, \&unop, "exp") }
-sub pp_log { maybe_targmy(@_, \&unop, "log") }
-sub pp_sqrt { maybe_targmy(@_, \&unop, "sqrt") }
-sub pp_int { maybe_targmy(@_, \&unop, "int") }
-sub pp_hex { maybe_targmy(@_, \&unop, "hex") }
-sub pp_oct { maybe_targmy(@_, \&unop, "oct") }
-sub pp_abs { maybe_targmy(@_, \&unop, "abs") }
-
-sub pp_length { maybe_targmy(@_, \&unop, "length") }
-sub pp_ord { maybe_targmy(@_, \&unop, "ord") }
-sub pp_chr { maybe_targmy(@_, \&unop, "chr") }
-
-sub pp_each { unop(@_, "each") }
-sub pp_values { unop(@_, "values") }
-sub pp_keys { unop(@_, "keys") }
-sub pp_aeach { unop(@_, "each") }
-sub pp_avalues { unop(@_, "values") }
-sub pp_akeys { unop(@_, "keys") }
-sub pp_pop { unop(@_, "pop") }
-sub pp_shift { unop(@_, "shift") }
-
-sub pp_caller { unop(@_, "caller") }
-sub pp_reset { unop(@_, "reset") }
-sub pp_exit { unop(@_, "exit") }
-sub pp_prototype { unop(@_, "prototype") }
-
-sub pp_close { unop(@_, "close") }
-sub pp_fileno { unop(@_, "fileno") }
-sub pp_umask { unop(@_, "umask") }
-sub pp_untie { unop(@_, "untie") }
-sub pp_tied { unop(@_, "tied") }
-sub pp_dbmclose { unop(@_, "dbmclose") }
-sub pp_getc { unop(@_, "getc") }
-sub pp_eof { unop(@_, "eof") }
-sub pp_tell { unop(@_, "tell") }
-sub pp_getsockname { unop(@_, "getsockname") }
-sub pp_getpeername { unop(@_, "getpeername") }
-
-sub pp_chdir { maybe_targmy(@_, \&unop, "chdir") }
-sub pp_chroot { maybe_targmy(@_, \&unop, "chroot") }
-sub pp_readlink { unop(@_, "readlink") }
-sub pp_rmdir { maybe_targmy(@_, \&unop, "rmdir") }
-sub pp_readdir { unop(@_, "readdir") }
-sub pp_telldir { unop(@_, "telldir") }
-sub pp_rewinddir { unop(@_, "rewinddir") }
-sub pp_closedir { unop(@_, "closedir") }
-sub pp_getpgrp { maybe_targmy(@_, \&unop, "getpgrp") }
-sub pp_localtime { unop(@_, "localtime") }
-sub pp_gmtime { unop(@_, "gmtime") }
-sub pp_alarm { unop(@_, "alarm") }
-sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
-
-sub pp_dofile { unop(@_, "do") }
-sub pp_entereval { unop(@_, "eval") }
-
-sub pp_ghbyname { unop(@_, "gethostbyname") }
-sub pp_gnbyname { unop(@_, "getnetbyname") }
-sub pp_gpbyname { unop(@_, "getprotobyname") }
-sub pp_shostent { unop(@_, "sethostent") }
-sub pp_snetent { unop(@_, "setnetent") }
-sub pp_sprotoent { unop(@_, "setprotoent") }
-sub pp_sservent { unop(@_, "setservent") }
-sub pp_gpwnam { unop(@_, "getpwnam") }
-sub pp_gpwuid { unop(@_, "getpwuid") }
-sub pp_ggrnam { unop(@_, "getgrnam") }
-sub pp_ggrgid { unop(@_, "getgrgid") }
-
-sub pp_lock { unop(@_, "lock") }
-
-sub pp_continue { unop(@_, "continue"); }
-sub pp_break {
- my ($self, $op) = @_;
- return "" if $op->flags & OPf_SPECIAL;
- unop(@_, "break");
-}
-
-sub givwhen {
- my $self = shift;
- my($op, $cx, $givwhen) = @_;
-
- my $enterop = $op->first;
- my ($head, $block);
- if ($enterop->flags & OPf_SPECIAL) {
- $head = "default";
- $block = $self->deparse($enterop->first, 0);
- }
- else {
- my $cond = $enterop->first;
- my $cond_str = $self->deparse($cond, 1);
- $head = "$givwhen ($cond_str)";
- $block = $self->deparse($cond->sibling, 0);
- }
-
- return "$head {\n".
- "\t$block\n".
- "\b}\cK";
-}
-
-sub pp_leavegiven { givwhen(@_, "given"); }
-sub pp_leavewhen { givwhen(@_, "when"); }
-
-sub pp_exists {
- my $self = shift;
- my($op, $cx) = @_;
- my $arg;
- if ($op->private & OPpEXISTS_SUB) {
- # Checking for the existence of a subroutine
- return $self->maybe_parens_func("exists",
- $self->pp_rv2cv($op->first, 16), $cx, 16);
- }
- if ($op->flags & OPf_SPECIAL) {
- # Array element, not hash element
- return $self->maybe_parens_func("exists",
- $self->pp_aelem($op->first, 16), $cx, 16);
- }
- return $self->maybe_parens_func("exists", $self->pp_helem($op->first, 16),
- $cx, 16);
-}
-
-sub pp_delete {
- my $self = shift;
- my($op, $cx) = @_;
- my $arg;
- if ($op->private & OPpSLICE) {
- if ($op->flags & OPf_SPECIAL) {
- # Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
- $self->pp_aslice($op->first, 16),
- $cx, 16);
- }
- return $self->maybe_parens_func("delete",
- $self->pp_hslice($op->first, 16),
- $cx, 16);
- } else {
- if ($op->flags & OPf_SPECIAL) {
- # Deleting from an array, not a hash
- return $self->maybe_parens_func("delete",
- $self->pp_aelem($op->first, 16),
- $cx, 16);
- }
- return $self->maybe_parens_func("delete",
- $self->pp_helem($op->first, 16),
- $cx, 16);
- }
-}
-
-sub pp_require {
- my $self = shift;
- my($op, $cx) = @_;
- my $opname = $op->flags & OPf_SPECIAL ? 'CORE::require' : 'require';
- if (class($op) eq "UNOP" and $op->first->name eq "const"
- and $op->first->private & OPpCONST_BARE)
- {
- my $name = $self->const_sv($op->first)->PV;
- $name =~ s[/][::]g;
- $name =~ s/\.pm//g;
- return "$opname $name";
- } else {
- $self->unop($op, $cx, $opname);
- }
-}
-
-sub pp_scalar {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first;
- if (not null $kid->sibling) {
- # XXX Was a here-doc
- return $self->dquote($op);
- }
- $self->unop(@_, "scalar");
-}
-
-
-sub padval {
- my $self = shift;
- my $targ = shift;
- return $self->{'curcv'}->PADLIST->ARRAYelt(1)->ARRAYelt($targ);
-}
-
-sub anon_hash_or_list {
- my $self = shift;
- my($op, $cx) = @_;
-
- my($pre, $post) = @{{"anonlist" => ["[","]"],
- "anonhash" => ["{","}"]}->{$op->name}};
- my($expr, @exprs);
- $op = $op->first->sibling; # skip pushmark
- for (; !null($op); $op = $op->sibling) {
- $expr = $self->deparse($op, 6);
- push @exprs, $expr;
- }
- if ($pre eq "{" and $cx < 1) {
- # Disambiguate that it's not a block
- $pre = "+{";
- }
- return $pre . join(", ", @exprs) . $post;
-}
-
-sub pp_anonlist {
- my $self = shift;
- my ($op, $cx) = @_;
- if ($op->flags & OPf_SPECIAL) {
- return $self->anon_hash_or_list($op, $cx);
- }
- warn "Unexpected op pp_" . $op->name() . " without OPf_SPECIAL";
- return 'XXX';
-}
-
-*pp_anonhash = \&pp_anonlist;
-
-sub pp_refgen {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first;
- if ($kid->name eq "null") {
- $kid = $kid->first;
- if (!null($kid->sibling) and
- $kid->sibling->name eq "anoncode") {
- return $self->e_anoncode({ code => $self->padval($kid->sibling->targ) });
- } elsif ($kid->name eq "pushmark") {
- my $sib_name = $kid->sibling->name;
- if ($sib_name =~ /^(pad|rv2)[ah]v$/
- and not $kid->sibling->flags & OPf_REF)
- {
- # The @a in \(@a) isn't in ref context, but only when the
- # parens are there.
- return "\\(" . $self->pp_list($op->first) . ")";
- } elsif ($sib_name eq 'entersub') {
- my $text = $self->deparse($kid->sibling, 1);
- # Always show parens for \(&func()), but only with -p otherwise
- $text = "($text)" if $self->{'parens'}
- or $kid->sibling->private & OPpENTERSUB_AMPER;
- return "\\$text";
- }
- }
- }
- $self->pfixop($op, $cx, "\\", 20);
-}
-
-sub e_anoncode {
- my ($self, $info) = @_;
- my $text = $self->deparse_sub($info->{code});
- return "sub " . $text;
-}
-
-sub pp_srefgen { pp_refgen(@_) }
-
-sub pp_readline {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first;
- $kid = $kid->first if $kid->name eq "rv2gv"; # <$fh>
- return "<" . $self->deparse($kid, 1) . ">" if is_scalar($kid);
- return $self->unop($op, $cx, "readline");
-}
-
-sub pp_rcatline {
- my $self = shift;
- my($op) = @_;
- return "<" . $self->gv_name($self->gv_or_padgv($op)) . ">";
-}
-
-# Unary operators that can occur as pseudo-listops inside double quotes
-sub dq_unop {
- my $self = shift;
- my($op, $cx, $name, $prec, $flags) = (@_, 0, 0);
- my $kid;
- if ($op->flags & OPf_KIDS) {
- $kid = $op->first;
- # If there's more than one kid, the first is an ex-pushmark.
- $kid = $kid->sibling if not null $kid->sibling;
- return $self->maybe_parens_unop($name, $kid, $cx);
- } else {
- return $name . ($op->flags & OPf_SPECIAL ? "()" : "");
- }
-}
-
-sub pp_ucfirst { dq_unop(@_, "ucfirst") }
-sub pp_lcfirst { dq_unop(@_, "lcfirst") }
-sub pp_uc { dq_unop(@_, "uc") }
-sub pp_lc { dq_unop(@_, "lc") }
-sub pp_quotemeta { maybe_targmy(@_, \&dq_unop, "quotemeta") }
-
-sub loopex {
- my $self = shift;
- my ($op, $cx, $name) = @_;
- if (class($op) eq "PVOP") {
- return "$name " . $op->pv;
- } elsif (class($op) eq "OP") {
- return $name;
- } elsif (class($op) eq "UNOP") {
- # Note -- loop exits are actually exempt from the
- # looks-like-a-func rule, but a few extra parens won't hurt
- return $self->maybe_parens_unop($name, $op->first, $cx);
- }
-}
-
-sub pp_last { loopex(@_, "last") }
-sub pp_next { loopex(@_, "next") }
-sub pp_redo { loopex(@_, "redo") }
-sub pp_goto { loopex(@_, "goto") }
-sub pp_dump { loopex(@_, "dump") }
-
-sub ftst {
- my $self = shift;
- my($op, $cx, $name) = @_;
- if (class($op) eq "UNOP") {
- # Genuine `-X' filetests are exempt from the LLAFR, but not
- # l?stat(); for the sake of clarity, give'em all parens
- return $self->maybe_parens_unop($name, $op->first, $cx);
- } elsif (class($op) =~ /^(SV|PAD)OP$/) {
- return $self->maybe_parens_func($name, $self->pp_gv($op, 1), $cx, 16);
- } else { # I don't think baseop filetests ever survive ck_ftst, but...
- return $name;
- }
-}
-
-sub pp_lstat { ftst(@_, "lstat") }
-sub pp_stat { ftst(@_, "stat") }
-sub pp_ftrread { ftst(@_, "-R") }
-sub pp_ftrwrite { ftst(@_, "-W") }
-sub pp_ftrexec { ftst(@_, "-X") }
-sub pp_fteread { ftst(@_, "-r") }
-sub pp_ftewrite { ftst(@_, "-w") }
-sub pp_fteexec { ftst(@_, "-x") }
-sub pp_ftis { ftst(@_, "-e") }
-sub pp_fteowned { ftst(@_, "-O") }
-sub pp_ftrowned { ftst(@_, "-o") }
-sub pp_ftzero { ftst(@_, "-z") }
-sub pp_ftsize { ftst(@_, "-s") }
-sub pp_ftmtime { ftst(@_, "-M") }
-sub pp_ftatime { ftst(@_, "-A") }
-sub pp_ftctime { ftst(@_, "-C") }
-sub pp_ftsock { ftst(@_, "-S") }
-sub pp_ftchr { ftst(@_, "-c") }
-sub pp_ftblk { ftst(@_, "-b") }
-sub pp_ftfile { ftst(@_, "-f") }
-sub pp_ftdir { ftst(@_, "-d") }
-sub pp_ftpipe { ftst(@_, "-p") }
-sub pp_ftlink { ftst(@_, "-l") }
-sub pp_ftsuid { ftst(@_, "-u") }
-sub pp_ftsgid { ftst(@_, "-g") }
-sub pp_ftsvtx { ftst(@_, "-k") }
-sub pp_fttty { ftst(@_, "-t") }
-sub pp_fttext { ftst(@_, "-T") }
-sub pp_ftbinary { ftst(@_, "-B") }
-
-sub SWAP_CHILDREN () { 1 }
-sub ASSIGN () { 2 } # has OP= variant
-sub LIST_CONTEXT () { 4 } # Assignment is in list context
-
-my(%left, %right);
-
-sub assoc_class {
- my $op = shift;
- my $name = $op->name;
- if ($name eq "concat" and $op->first->name eq "concat") {
- # avoid spurious `=' -- see comment in pp_concat
- return "concat";
- }
- if ($name eq "null" and class($op) eq "UNOP"
- and $op->first->name =~ /^(and|x?or)$/
- and null $op->first->sibling)
- {
- # Like all conditional constructs, OP_ANDs and OP_ORs are topped
- # with a null that's used as the common end point of the two
- # flows of control. For precedence purposes, ignore it.
- # (COND_EXPRs have these too, but we don't bother with
- # their associativity).
- return assoc_class($op->first);
- }
- return $name . ($op->flags & OPf_STACKED ? "=" : "");
-}
-
-# Left associative operators, like `+', for which
-# $a + $b + $c is equivalent to ($a + $b) + $c
-
-BEGIN {
- %left = ('multiply' => 19, 'i_multiply' => 19,
- 'divide' => 19, 'i_divide' => 19,
- 'modulo' => 19, 'i_modulo' => 19,
- 'repeat' => 19,
- 'add' => 18, 'i_add' => 18,
- 'subtract' => 18, 'i_subtract' => 18,
- 'concat' => 18,
- 'left_shift' => 17, 'right_shift' => 17,
- 'bit_and' => 13,
- 'bit_or' => 12, 'bit_xor' => 12,
- 'and' => 3,
- 'or' => 2, 'xor' => 2,
- );
-}
-
-sub deparse_binop_left {
- my $self = shift;
- my($op, $left, $prec) = @_;
- if ($left{assoc_class($op)} && $left{assoc_class($left)}
- and $left{assoc_class($op)} == $left{assoc_class($left)})
- {
- return $self->deparse($left, $prec - .00001);
- } else {
- return $self->deparse($left, $prec);
- }
-}
-
-# Right associative operators, like `=', for which
-# $a = $b = $c is equivalent to $a = ($b = $c)
-
-BEGIN {
- %right = ('pow' => 22,
- 'sassign=' => 7, 'aassign=' => 7,
- 'multiply=' => 7, 'i_multiply=' => 7,
- 'divide=' => 7, 'i_divide=' => 7,
- 'modulo=' => 7, 'i_modulo=' => 7,
- 'repeat=' => 7,
- 'add=' => 7, 'i_add=' => 7,
- 'subtract=' => 7, 'i_subtract=' => 7,
- 'concat=' => 7,
- 'left_shift=' => 7, 'right_shift=' => 7,
- 'bit_and=' => 7,
- 'bit_or=' => 7, 'bit_xor=' => 7,
- 'andassign' => 7,
- 'orassign' => 7,
- );
-}
-
-sub deparse_binop_right {
- my $self = shift;
- my($op, $right, $prec) = @_;
- if ($right{assoc_class($op)} && $right{assoc_class($right)}
- and $right{assoc_class($op)} == $right{assoc_class($right)})
- {
- return $self->deparse($right, $prec - .00001);
- } else {
- return $self->deparse($right, $prec);
- }
-}
-
-sub binop {
- my $self = shift;
- my ($op, $cx, $opname, $prec, $flags) = (@_, 0);
- my $left = $op->first;
- my $right = $op->last;
- my $eq = "";
- if ($op->flags & OPf_STACKED && $flags & ASSIGN) {
- $eq = "=";
- $prec = 7;
- }
- if ($flags & SWAP_CHILDREN) {
- ($left, $right) = ($right, $left);
- }
- $left = $self->deparse_binop_left($op, $left, $prec);
- $left = "($left)" if $flags & LIST_CONTEXT
- && $left !~ /^(my|our|local|)[\@\(]/;
- $right = $self->deparse_binop_right($op, $right, $prec);
- return $self->maybe_parens("$left $opname$eq $right", $cx, $prec);
-}
-
-sub pp_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
-sub pp_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
-sub pp_subtract { maybe_targmy(@_, \&binop, "-",18, ASSIGN) }
-sub pp_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
-sub pp_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
-sub pp_i_add { maybe_targmy(@_, \&binop, "+", 18, ASSIGN) }
-sub pp_i_multiply { maybe_targmy(@_, \&binop, "*", 19, ASSIGN) }
-sub pp_i_subtract { maybe_targmy(@_, \&binop, "-", 18, ASSIGN) }
-sub pp_i_divide { maybe_targmy(@_, \&binop, "/", 19, ASSIGN) }
-sub pp_i_modulo { maybe_targmy(@_, \&binop, "%", 19, ASSIGN) }
-sub pp_pow { maybe_targmy(@_, \&binop, "**", 22, ASSIGN) }
-
-sub pp_left_shift { maybe_targmy(@_, \&binop, "<<", 17, ASSIGN) }
-sub pp_right_shift { maybe_targmy(@_, \&binop, ">>", 17, ASSIGN) }
-sub pp_bit_and { maybe_targmy(@_, \&binop, "&", 13, ASSIGN) }
-sub pp_bit_or { maybe_targmy(@_, \&binop, "|", 12, ASSIGN) }
-sub pp_bit_xor { maybe_targmy(@_, \&binop, "^", 12, ASSIGN) }
-
-sub pp_eq { binop(@_, "==", 14) }
-sub pp_ne { binop(@_, "!=", 14) }
-sub pp_lt { binop(@_, "<", 15) }
-sub pp_gt { binop(@_, ">", 15) }
-sub pp_ge { binop(@_, ">=", 15) }
-sub pp_le { binop(@_, "<=", 15) }
-sub pp_ncmp { binop(@_, "<=>", 14) }
-sub pp_i_eq { binop(@_, "==", 14) }
-sub pp_i_ne { binop(@_, "!=", 14) }
-sub pp_i_lt { binop(@_, "<", 15) }
-sub pp_i_gt { binop(@_, ">", 15) }
-sub pp_i_ge { binop(@_, ">=", 15) }
-sub pp_i_le { binop(@_, "<=", 15) }
-sub pp_i_ncmp { binop(@_, "<=>", 14) }
-
-sub pp_seq { binop(@_, "eq", 14) }
-sub pp_sne { binop(@_, "ne", 14) }
-sub pp_slt { binop(@_, "lt", 15) }
-sub pp_sgt { binop(@_, "gt", 15) }
-sub pp_sge { binop(@_, "ge", 15) }
-sub pp_sle { binop(@_, "le", 15) }
-sub pp_scmp { binop(@_, "cmp", 14) }
-
-sub pp_sassign { binop(@_, "=", 7, SWAP_CHILDREN) }
-sub pp_aassign { binop(@_, "=", 7, SWAP_CHILDREN | LIST_CONTEXT) }
-
-sub pp_smartmatch {
- my ($self, $op, $cx) = @_;
- if ($op->flags & OPf_SPECIAL) {
- return $self->deparse($op->last, $cx);
- }
- else {
- binop(@_, "~~", 14);
- }
-}
-
-# `.' is special because concats-of-concats are optimized to save copying
-# by making all but the first concat stacked. The effect is as if the
-# programmer had written `($a . $b) .= $c', except legal.
-sub pp_concat { maybe_targmy(@_, \&real_concat) }
-sub real_concat {
- my $self = shift;
- my($op, $cx) = @_;
- my $left = $op->first;
- my $right = $op->last;
- my $eq = "";
- my $prec = 18;
- if ($op->flags & OPf_STACKED and $op->first->name ne "concat") {
- $eq = "=";
- $prec = 7;
- }
- $left = $self->deparse_binop_left($op, $left, $prec);
- $right = $self->deparse_binop_right($op, $right, $prec);
- return $self->maybe_parens("$left .$eq $right", $cx, $prec);
-}
-
-# `x' is weird when the left arg is a list
-sub pp_repeat {
- my $self = shift;
- my($op, $cx) = @_;
- my $left = $op->first;
- my $right = $op->last;
- my $eq = "";
- my $prec = 19;
- if ($op->flags & OPf_STACKED) {
- $eq = "=";
- $prec = 7;
- }
- if (null($right)) { # list repeat; count is inside left-side ex-list
- my $kid = $left->first->sibling; # skip pushmark
- my @exprs;
- for (; !null($kid->sibling); $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
- }
- $right = $kid;
- $left = "(" . join(", ", @exprs). ")";
- } else {
- $left = $self->deparse_binop_left($op, $left, $prec);
- }
- $right = $self->deparse_binop_right($op, $right, $prec);
- return $self->maybe_parens("$left x$eq $right", $cx, $prec);
-}
-
-sub range {
- my $self = shift;
- my ($op, $cx, $type) = @_;
- my $left = $op->first;
- my $right = $left->sibling;
- $left = $self->deparse($left, 9);
- $right = $self->deparse($right, 9);
- return $self->maybe_parens("$left $type $right", $cx, 9);
-}
-
-sub pp_flop {
- my $self = shift;
- my($op, $cx) = @_;
- my $flip = $op->first;
- my $type = ($flip->flags & OPf_SPECIAL) ? "..." : "..";
- return $self->range($flip->first, $cx, $type);
-}
-
-# one-line while/until is handled in pp_leave
-
-sub logop {
- my $self = shift;
- my ($op, $cx, $lowop, $lowprec, $highop, $highprec, $blockname) = @_;
- my $left = $op->first;
- my $right = $op->first->sibling;
- if ($cx < 1 and is_scope($right) and $blockname
- and $self->{'expand'} < 7)
- { # if ($a) {$b}
- $left = $self->deparse($left, 1);
- $right = $self->deparse($right, 0);
- return "$blockname ($left) {\n\t$right\n\b}\cK";
- } elsif ($cx < 1 and $blockname and not $self->{'parens'}
- and $self->{'expand'} < 7) { # $b if $a
- $right = $self->deparse($right, 1);
- $left = $self->deparse($left, 1);
- return "$right $blockname $left";
- } elsif ($cx > $lowprec and $highop) { # $a && $b
- $left = $self->deparse_binop_left($op, $left, $highprec);
- $right = $self->deparse_binop_right($op, $right, $highprec);
- return $self->maybe_parens("$left $highop $right", $cx, $highprec);
- } else { # $a and $b
- $left = $self->deparse_binop_left($op, $left, $lowprec);
- $right = $self->deparse_binop_right($op, $right, $lowprec);
- return $self->maybe_parens("$left $lowop $right", $cx, $lowprec);
- }
-}
-
-sub pp_and { logop(@_, "and", 3, "&&", 11, "if") }
-sub pp_or { logop(@_, "or", 2, "||", 10, "unless") }
-sub pp_dor { logop(@_, "err", 2, "//", 10, "") }
-
-# xor is syntactically a logop, but it's really a binop (contrary to
-# old versions of opcode.pl). Syntax is what matters here.
-sub pp_xor { logop(@_, "xor", 2, "", 0, "") }
-
-sub logassignop {
- my $self = shift;
- my ($op, $cx, $opname) = @_;
- my $left = $op->first;
- my $right = $op->first->sibling->first; # skip sassign
- $left = $self->deparse($left, 7);
- $right = $self->deparse($right, 7);
- return $self->maybe_parens("$left $opname $right", $cx, 7);
-}
-
-sub pp_andassign { logassignop(@_, "&&=") }
-sub pp_orassign { logassignop(@_, "||=") }
-sub pp_dorassign { logassignop(@_, "//=") }
-
-sub listop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- my(@exprs);
- my $parens = ($cx >= 5) || $self->{'parens'};
- my $kid = $op->first->sibling;
- return $name if null $kid;
- my $first;
- $name = "socketpair" if $name eq "sockpair";
- my $proto = prototype("CORE::$name");
- if (defined $proto
- && $proto =~ /^;?\*/
- && $kid->name eq "rv2gv") {
- $first = $self->deparse($kid->first, 6);
- }
- else {
- $first = $self->deparse($kid, 6);
- }
- if ($name eq "chmod" && $first =~ /^\d+$/) {
- $first = sprintf("%#o", $first);
- }
- $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
- push @exprs, $first;
- $kid = $kid->sibling;
- if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
- push @exprs, $self->deparse($kid->first, 6);
- $kid = $kid->sibling;
- }
- for (; !null($kid); $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
- }
- if ($parens) {
- return "$name(" . join(", ", @exprs) . ")";
- } else {
- return "$name " . join(", ", @exprs);
- }
-}
-
-sub pp_bless { listop(@_, "bless") }
-sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
-sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
-sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
-sub pp_index { maybe_targmy(@_, \&listop, "index") }
-sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
-sub pp_sprintf { maybe_targmy(@_, \&listop, "sprintf") }
-sub pp_formline { listop(@_, "formline") } # see also deparse_format
-sub pp_crypt { maybe_targmy(@_, \&listop, "crypt") }
-sub pp_unpack { listop(@_, "unpack") }
-sub pp_pack { listop(@_, "pack") }
-sub pp_join { maybe_targmy(@_, \&listop, "join") }
-sub pp_splice { listop(@_, "splice") }
-sub pp_push { maybe_targmy(@_, \&listop, "push") }
-sub pp_unshift { maybe_targmy(@_, \&listop, "unshift") }
-sub pp_reverse { listop(@_, "reverse") }
-sub pp_warn { listop(@_, "warn") }
-sub pp_die { listop(@_, "die") }
-# Actually, return is exempt from the LLAFR (see examples in this very
-# module!), but for consistency's sake, ignore that fact
-sub pp_return { listop(@_, "return") }
-sub pp_open { listop(@_, "open") }
-sub pp_pipe_op { listop(@_, "pipe") }
-sub pp_tie { listop(@_, "tie") }
-sub pp_binmode { listop(@_, "binmode") }
-sub pp_dbmopen { listop(@_, "dbmopen") }
-sub pp_sselect { listop(@_, "select") }
-sub pp_select { listop(@_, "select") }
-sub pp_read { listop(@_, "read") }
-sub pp_sysopen { listop(@_, "sysopen") }
-sub pp_sysseek { listop(@_, "sysseek") }
-sub pp_sysread { listop(@_, "sysread") }
-sub pp_syswrite { listop(@_, "syswrite") }
-sub pp_send { listop(@_, "send") }
-sub pp_recv { listop(@_, "recv") }
-sub pp_seek { listop(@_, "seek") }
-sub pp_fcntl { listop(@_, "fcntl") }
-sub pp_ioctl { listop(@_, "ioctl") }
-sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
-sub pp_socket { listop(@_, "socket") }
-sub pp_sockpair { listop(@_, "sockpair") }
-sub pp_bind { listop(@_, "bind") }
-sub pp_connect { listop(@_, "connect") }
-sub pp_listen { listop(@_, "listen") }
-sub pp_accept { listop(@_, "accept") }
-sub pp_shutdown { listop(@_, "shutdown") }
-sub pp_gsockopt { listop(@_, "getsockopt") }
-sub pp_ssockopt { listop(@_, "setsockopt") }
-sub pp_chown { maybe_targmy(@_, \&listop, "chown") }
-sub pp_unlink { maybe_targmy(@_, \&listop, "unlink") }
-sub pp_chmod { maybe_targmy(@_, \&listop, "chmod") }
-sub pp_utime { maybe_targmy(@_, \&listop, "utime") }
-sub pp_rename { maybe_targmy(@_, \&listop, "rename") }
-sub pp_link { maybe_targmy(@_, \&listop, "link") }
-sub pp_symlink { maybe_targmy(@_, \&listop, "symlink") }
-sub pp_mkdir { maybe_targmy(@_, \&listop, "mkdir") }
-sub pp_open_dir { listop(@_, "opendir") }
-sub pp_seekdir { listop(@_, "seekdir") }
-sub pp_waitpid { maybe_targmy(@_, \&listop, "waitpid") }
-sub pp_system { maybe_targmy(@_, \&listop, "system") }
-sub pp_exec { maybe_targmy(@_, \&listop, "exec") }
-sub pp_kill { maybe_targmy(@_, \&listop, "kill") }
-sub pp_setpgrp { maybe_targmy(@_, \&listop, "setpgrp") }
-sub pp_getpriority { maybe_targmy(@_, \&listop, "getpriority") }
-sub pp_setpriority { maybe_targmy(@_, \&listop, "setpriority") }
-sub pp_shmget { listop(@_, "shmget") }
-sub pp_shmctl { listop(@_, "shmctl") }
-sub pp_shmread { listop(@_, "shmread") }
-sub pp_shmwrite { listop(@_, "shmwrite") }
-sub pp_msgget { listop(@_, "msgget") }
-sub pp_msgctl { listop(@_, "msgctl") }
-sub pp_msgsnd { listop(@_, "msgsnd") }
-sub pp_msgrcv { listop(@_, "msgrcv") }
-sub pp_semget { listop(@_, "semget") }
-sub pp_semctl { listop(@_, "semctl") }
-sub pp_semop { listop(@_, "semop") }
-sub pp_ghbyaddr { listop(@_, "gethostbyaddr") }
-sub pp_gnbyaddr { listop(@_, "getnetbyaddr") }
-sub pp_gpbynumber { listop(@_, "getprotobynumber") }
-sub pp_gsbyname { listop(@_, "getservbyname") }
-sub pp_gsbyport { listop(@_, "getservbyport") }
-sub pp_syscall { listop(@_, "syscall") }
-
-sub pp_glob {
- my $self = shift;
- my($op, $cx) = @_;
- my $text = $self->dq($op->first->sibling); # skip pushmark
- if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
- or $text =~ /[<>]/) {
- return 'glob(' . single_delim('qq', '"', $text) . ')';
- } else {
- return '<' . $text . '>';
- }
-}
-
-# Truncate is special because OPf_SPECIAL makes a bareword first arg
-# be a filehandle. This could probably be better fixed in the core
-# by moving the GV lookup into ck_truc.
-
-sub pp_truncate {
- my $self = shift;
- my($op, $cx) = @_;
- my(@exprs);
- my $parens = ($cx >= 5) || $self->{'parens'};
- my $kid = $op->first->sibling;
- my $fh;
- if ($op->flags & OPf_SPECIAL) {
- # $kid is an OP_CONST
- $fh = $self->const_sv($kid)->PV;
- } else {
- $fh = $self->deparse($kid, 6);
- $fh = "+$fh" if not $parens and substr($fh, 0, 1) eq "(";
- }
- my $len = $self->deparse($kid->sibling, 6);
- if ($parens) {
- return "truncate($fh, $len)";
- } else {
- return "truncate $fh, $len";
- }
-}
-
-sub indirop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- my($expr, @exprs);
- my $kid = $op->first->sibling;
- my $indir = "";
- if ($op->flags & OPf_STACKED) {
- $indir = $kid;
- $indir = $indir->first; # skip rv2gv
- if (is_scope($indir)) {
- $indir = "{" . $self->deparse($indir, 0) . "}";
- $indir = "{;}" if $indir eq "{}";
- } elsif ($indir->name eq "const" && $indir->private & OPpCONST_BARE) {
- $indir = $self->const_sv($indir)->PV;
- } else {
- $indir = $self->deparse($indir, 24);
- }
- $indir = $indir . " ";
- $kid = $kid->sibling;
- }
- if ($name eq "sort" && $op->private & (OPpSORT_NUMERIC | OPpSORT_INTEGER)) {
- $indir = ($op->private & OPpSORT_DESCEND) ? '{$b <=> $a} '
- : '{$a <=> $b} ';
- }
- elsif ($name eq "sort" && $op->private & OPpSORT_DESCEND) {
- $indir = '{$b cmp $a} ';
- }
- for (; !null($kid); $kid = $kid->sibling) {
- $expr = $self->deparse($kid, 6);
- push @exprs, $expr;
- }
- my $name2 = $name;
- if ($name eq "sort" && $op->private & OPpSORT_REVERSE) {
- $name2 = 'reverse sort';
- }
- if ($name eq "sort" && ($op->private & OPpSORT_INPLACE)) {
- return "$exprs[0] = $name2 $indir $exprs[0]";
- }
-
- my $args = $indir . join(", ", @exprs);
- if ($indir ne "" and $name eq "sort") {
- # We don't want to say "sort(f 1, 2, 3)", since perl -w will
- # give bareword warnings in that case. Therefore if context
- # requires, we'll put parens around the outside "(sort f 1, 2,
- # 3)". Unfortunately, we'll currently think the parens are
- # necessary more often that they really are, because we don't
- # distinguish which side of an assignment we're on.
- if ($cx >= 5) {
- return "($name2 $args)";
- } else {
- return "$name2 $args";
- }
- } else {
- return $self->maybe_parens_func($name2, $args, $cx, 5);
- }
-
-}
-
-sub pp_prtf { indirop(@_, "printf") }
-sub pp_print { indirop(@_, "print") }
-sub pp_say { indirop(@_, "say") }
-sub pp_sort { indirop(@_, "sort") }
-
-sub mapop {
- my $self = shift;
- my($op, $cx, $name) = @_;
- my($expr, @exprs);
- my $kid = $op->first; # this is the (map|grep)start
- $kid = $kid->first->sibling; # skip a pushmark
- my $code = $kid->first; # skip a null
- if (is_scope $code) {
- $code = "{" . $self->deparse($code, 0) . "} ";
- } else {
- $code = $self->deparse($code, 24) . ", ";
- }
- $kid = $kid->sibling;
- for (; !null($kid); $kid = $kid->sibling) {
- $expr = $self->deparse($kid, 6);
- push @exprs, $expr if defined $expr;
- }
- return $self->maybe_parens_func($name, $code . join(", ", @exprs), $cx, 5);
-}
-
-sub pp_mapwhile { mapop(@_, "map") }
-sub pp_grepwhile { mapop(@_, "grep") }
-sub pp_mapstart { baseop(@_, "map") }
-sub pp_grepstart { baseop(@_, "grep") }
-
-sub pp_list {
- my $self = shift;
- my($op, $cx) = @_;
- my($expr, @exprs);
- my $kid = $op->first->sibling; # skip pushmark
- my $lop;
- my $local = "either"; # could be local(...), my(...), state(...) or our(...)
- for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
- # This assumes that no other private flags equal 128, and that
- # OPs that store things other than flags in their op_private,
- # like OP_AELEMFAST, won't be immediate children of a list.
- #
- # OP_ENTERSUB can break this logic, so check for it.
- # I suspect that open and exit can too.
-
- if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
- or $lop->name eq "undef")
- or $lop->name eq "entersub"
- or $lop->name eq "exit"
- or $lop->name eq "open")
- {
- $local = ""; # or not
- last;
- }
- if ($lop->name =~ /^pad[ash]v$/) {
- if ($lop->private & OPpPAD_STATE) { # state()
- ($local = "", last) if $local =~ /^(?:local|our|my)$/;
- $local = "state";
- } else { # my()
- ($local = "", last) if $local =~ /^(?:local|our|state)$/;
- $local = "my";
- }
- } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/
- && $lop->private & OPpOUR_INTRO
- or $lop->name eq "null" && $lop->first->name eq "gvsv"
- && $lop->first->private & OPpOUR_INTRO) { # our()
- ($local = "", last) if $local =~ /^(?:my|local|state)$/;
- $local = "our";
- } elsif ($lop->name ne "undef"
- # specifically avoid the "reverse sort" optimisation,
- # where "reverse" is nullified
- && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE)))
- {
- # local()
- ($local = "", last) if $local =~ /^(?:my|our|state)$/;
- $local = "local";
- }
- }
- $local = "" if $local eq "either"; # no point if it's all undefs
- return $self->deparse($kid, $cx) if null $kid->sibling and not $local;
- for (; !null($kid); $kid = $kid->sibling) {
- if ($local) {
- if (class($kid) eq "UNOP" and $kid->first->name eq "gvsv") {
- $lop = $kid->first;
- } else {
- $lop = $kid;
- }
- $self->{'avoid_local'}{$$lop}++;
- $expr = $self->deparse($kid, 6);
- delete $self->{'avoid_local'}{$$lop};
- } else {
- $expr = $self->deparse($kid, 6);
- }
- push @exprs, $expr;
- }
- if ($local) {
- return "$local(" . join(", ", @exprs) . ")";
- } else {
- return $self->maybe_parens( join(", ", @exprs), $cx, 6);
- }
-}
-
-sub is_ifelse_cont {
- my $op = shift;
- return ($op->name eq "null" and class($op) eq "UNOP"
- and $op->first->name =~ /^(and|cond_expr)$/
- and is_scope($op->first->first->sibling));
-}
-
-sub pp_cond_expr {
- my $self = shift;
- my($op, $cx) = @_;
- my $cond = $op->first;
- my $true = $cond->sibling;
- my $false = $true->sibling;
- my $cuddle = $self->{'cuddle'};
- unless ($cx < 1 and (is_scope($true) and $true->name ne "null") and
- (is_scope($false) || is_ifelse_cont($false))
- and $self->{'expand'} < 7) {
- $cond = $self->deparse($cond, 8);
- $true = $self->deparse($true, 6);
- $false = $self->deparse($false, 8);
- return $self->maybe_parens("$cond ? $true : $false", $cx, 8);
- }
-
- $cond = $self->deparse($cond, 1);
- $true = $self->deparse($true, 0);
- my $head = "if ($cond) {\n\t$true\n\b}";
- my @elsifs;
- while (!null($false) and is_ifelse_cont($false)) {
- my $newop = $false->first;
- my $newcond = $newop->first;
- my $newtrue = $newcond->sibling;
- $false = $newtrue->sibling; # last in chain is OP_AND => no else
- if ($newcond->name eq "lineseq")
- {
- # lineseq to ensure correct line numbers in elsif()
- # Bug #37302 fixed by change #33710.
- $newcond = $newcond->first->sibling;
- }
- $newcond = $self->deparse($newcond, 1);
- $newtrue = $self->deparse($newtrue, 0);
- push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
- }
- if (!null($false)) {
- $false = $cuddle . "else {\n\t" .
- $self->deparse($false, 0) . "\n\b}\cK";
- } else {
- $false = "\cK";
- }
- return $head . join($cuddle, "", @elsifs) . $false;
-}
-
-sub pp_once {
- my ($self, $op, $cx) = @_;
- my $cond = $op->first;
- my $true = $cond->sibling;
-
- return $self->deparse($true, $cx);
-}
-
-sub loop_common {
- my $self = shift;
- my($op, $cx, $init) = @_;
- my $enter = $op->first;
- my $kid = $enter->sibling;
- local(@$self{qw'curstash warnings hints hinthash'})
- = @$self{qw'curstash warnings hints hinthash'};
- my $head = "";
- my $bare = 0;
- my $body;
- my $cond = undef;
- if ($kid->name eq "lineseq") { # bare or infinite loop
- if ($kid->last->name eq "unstack") { # infinite
- $head = "while (1) "; # Can't use for(;;) if there's a continue
- $cond = "";
- } else {
- $bare = 1;
- }
- $body = $kid;
- } elsif ($enter->name eq "enteriter") { # foreach
- my $ary = $enter->first->sibling; # first was pushmark
- my $var = $ary->sibling;
- if ($ary->name eq 'null' and $enter->private & OPpITER_REVERSED) {
- # "reverse" was optimised away
- $ary = listop($self, $ary->first->sibling, 1, 'reverse');
- } elsif ($enter->flags & OPf_STACKED
- and not null $ary->first->sibling->sibling)
- {
- $ary = $self->deparse($ary->first->sibling, 9) . " .. " .
- $self->deparse($ary->first->sibling->sibling, 9);
- } else {
- $ary = $self->deparse($ary, 1);
- }
- if (null $var) {
- if ($enter->flags & OPf_SPECIAL) { # thread special var
- $var = $self->pp_threadsv($enter, 1);
- } else { # regular my() variable
- $var = $self->pp_padsv($enter, 1);
- }
- } elsif ($var->name eq "rv2gv") {
- $var = $self->pp_rv2sv($var, 1);
- if ($enter->private & OPpOUR_INTRO) {
- # our declarations don't have package names
- $var =~ s/^(.).*::/$1/;
- $var = "our $var";
- }
- } elsif ($var->name eq "gv") {
- $var = "\$" . $self->deparse($var, 1);
- }
- $body = $kid->first->first->sibling; # skip OP_AND and OP_ITER
- if (!is_state $body->first and $body->first->name ne "stub") {
- confess unless $var eq '$_';
- $body = $body->first;
- return $self->deparse($body, 2) . " foreach ($ary)";
- }
- $head = "foreach $var ($ary) ";
- } elsif ($kid->name eq "null") { # while/until
- $kid = $kid->first;
- my $name = {"and" => "while", "or" => "until"}->{$kid->name};
- $cond = $self->deparse($kid->first, 1);
- $head = "$name ($cond) ";
- $body = $kid->first->sibling;
- } elsif ($kid->name eq "stub") { # bare and empty
- return "{;}"; # {} could be a hashref
- }
- # If there isn't a continue block, then the next pointer for the loop
- # will point to the unstack, which is kid's last child, except
- # in a bare loop, when it will point to the leaveloop. When neither of
- # these conditions hold, then the second-to-last child is the continue
- # block (or the last in a bare loop).
- my $cont_start = $enter->nextop;
- my $cont;
- if ($$cont_start != $$op && ${$cont_start} != ${$body->last}) {
- if ($bare) {
- $cont = $body->last;
- } else {
- $cont = $body->first;
- while (!null($cont->sibling->sibling)) {
- $cont = $cont->sibling;
- }
- }
- my $state = $body->first;
- my $cuddle = $self->{'cuddle'};
- my @states;
- for (; $$state != $$cont; $state = $state->sibling) {
- push @states, $state;
- }
- $body = $self->lineseq(undef, @states);
- if (defined $cond and not is_scope $cont and $self->{'expand'} < 3) {
- $head = "for ($init; $cond; " . $self->deparse($cont, 1) .") ";
- $cont = "\cK";
- } else {
- $cont = $cuddle . "continue {\n\t" .
- $self->deparse($cont, 0) . "\n\b}\cK";
- }
- } else {
- return "" if !defined $body;
- if (length $init) {
- $head = "for ($init; $cond;) ";
- }
- $cont = "\cK";
- $body = $self->deparse($body, 0);
- }
- $body =~ s/;?$/;\n/;
-
- return $head . "{\n\t" . $body . "\b}" . $cont;
-}
-
-sub pp_leaveloop { shift->loop_common(@_, "") }
-
-sub for_loop {
- my $self = shift;
- my($op, $cx) = @_;
- my $init = $self->deparse($op, 1);
- return $self->loop_common($op->sibling->first->sibling, $cx, $init);
-}
-
-sub pp_leavetry {
- my $self = shift;
- return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
-}
-
-BEGIN { eval "sub OP_CONST () {" . opnumber("const") . "}" }
-BEGIN { eval "sub OP_STRINGIFY () {" . opnumber("stringify") . "}" }
-BEGIN { eval "sub OP_RV2SV () {" . opnumber("rv2sv") . "}" }
-BEGIN { eval "sub OP_LIST () {" . opnumber("list") . "}" }
-
-sub pp_null {
- my $self = shift;
- my($op, $cx) = @_;
- if (class($op) eq "OP") {
- # old value is lost
- return $self->{'ex_const'} if $op->targ == OP_CONST;
- } elsif ($op->first->name eq "pushmark") {
- return $self->pp_list($op, $cx);
- } elsif ($op->first->name eq "enter") {
- return $self->pp_leave($op, $cx);
- } elsif ($op->first->name eq "leave") {
- return $self->pp_leave($op->first, $cx);
- } elsif ($op->first->name eq "scope") {
- return $self->pp_scope($op->first, $cx);
- } elsif ($op->targ == OP_STRINGIFY) {
- return $self->dquote($op, $cx);
- } elsif (!null($op->first->sibling) and
- $op->first->sibling->name eq "readline" and
- $op->first->sibling->flags & OPf_STACKED) {
- return $self->maybe_parens($self->deparse($op->first, 7) . " = "
- . $self->deparse($op->first->sibling, 7),
- $cx, 7);
- } elsif (!null($op->first->sibling) and
- $op->first->sibling->name eq "trans" and
- $op->first->sibling->flags & OPf_STACKED) {
- return $self->maybe_parens($self->deparse($op->first, 20) . " =~ "
- . $self->deparse($op->first->sibling, 20),
- $cx, 20);
- } elsif ($op->flags & OPf_SPECIAL && $cx < 1 && !$op->targ) {
- return "do {\n\t". $self->deparse($op->first, $cx) ."\n\b};";
- } elsif (!null($op->first->sibling) and
- $op->first->sibling->name eq "null" and
- class($op->first->sibling) eq "UNOP" and
- $op->first->sibling->first->flags & OPf_STACKED and
- $op->first->sibling->first->name eq "rcatline") {
- return $self->maybe_parens($self->deparse($op->first, 18) . " .= "
- . $self->deparse($op->first->sibling, 18),
- $cx, 18);
- } else {
- return $self->deparse($op->first, $cx);
- }
-}
-
-sub padname {
- my $self = shift;
- my $targ = shift;
- return $self->padname_sv($targ)->PVX;
-}
-
-sub padany {
- my $self = shift;
- my $op = shift;
- return substr($self->padname($op->targ), 1); # skip $/@/%
-}
-
-sub pp_padsv {
- my $self = shift;
- my($op, $cx) = @_;
- return $self->maybe_my($op, $cx, $self->padname($op->targ));
-}
-
-sub pp_padav { pp_padsv(@_) }
-sub pp_padhv { pp_padsv(@_) }
-
-my @threadsv_names;
-
-BEGIN {
- @threadsv_names = ("_", "1", "2", "3", "4", "5", "6", "7", "8", "9",
- "&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
- "^", "-", "%", "=", "|", "~", ":", "^A", "^E",
- "!", "@");
-}
-
-sub pp_threadsv {
- my $self = shift;
- my($op, $cx) = @_;
- return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]);
-}
-
-sub gv_or_padgv {
- my $self = shift;
- my $op = shift;
- if (class($op) eq "PADOP") {
- return $self->padval($op->padix);
- } else { # class($op) eq "SVOP"
- return $op->gv;
- }
-}
-
-sub pp_gvsv {
- my $self = shift;
- my($op, $cx) = @_;
- my $gv = $self->gv_or_padgv($op);
- return $self->maybe_local($op, $cx, $self->stash_variable("\$",
- $self->gv_name($gv)));
-}
-
-sub pp_gv {
- my $self = shift;
- my($op, $cx) = @_;
- my $gv = $self->gv_or_padgv($op);
- return $self->gv_name($gv);
-}
-
-sub pp_aelemfast {
- my $self = shift;
- my($op, $cx) = @_;
- my $name;
- if ($op->flags & OPf_SPECIAL) { # optimised PADAV
- $name = $self->padname($op->targ);
- $name =~ s/^@/\$/;
- }
- else {
- my $gv = $self->gv_or_padgv($op);
- $name = $self->gv_name($gv);
- $name = $self->{'curstash'}."::$name"
- if $name !~ /::/ && $self->lex_in_scope('@'.$name);
- $name = '$' . $name;
- }
-
- return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
-}
-
-sub rv2x {
- my $self = shift;
- my($op, $cx, $type) = @_;
-
- if (class($op) eq 'NULL' || !$op->can("first")) {
- carp("Unexpected op in pp_rv2x");
- return 'XXX';
- }
- my $kid = $op->first;
- if ($kid->name eq "gv") {
- return $self->stash_variable($type, $self->deparse($kid, 0));
- } elsif (is_scalar $kid) {
- my $str = $self->deparse($kid, 0);
- if ($str =~ /^\$([^\w\d])\z/) {
- # "$$+" isn't a legal way to write the scalar dereference
- # of $+, since the lexer can't tell you aren't trying to
- # do something like "$$ + 1" to get one more than your
- # PID. Either "${$+}" or "$${+}" are workable
- # disambiguations, but if the programmer did the former,
- # they'd be in the "else" clause below rather than here.
- # It's not clear if this should somehow be unified with
- # the code in dq and re_dq that also adds lexer
- # disambiguation braces.
- $str = '$' . "{$1}"; #'
- }
- return $type . $str;
- } else {
- return $type . "{" . $self->deparse($kid, 0) . "}";
- }
-}
-
-sub pp_rv2sv { maybe_local(@_, rv2x(@_, "\$")) }
-sub pp_rv2hv { maybe_local(@_, rv2x(@_, "%")) }
-sub pp_rv2gv { maybe_local(@_, rv2x(@_, "*")) }
-
-# skip rv2av
-sub pp_av2arylen {
- my $self = shift;
- my($op, $cx) = @_;
- if ($op->first->name eq "padav") {
- return $self->maybe_local($op, $cx, '$#' . $self->padany($op->first));
- } else {
- return $self->maybe_local($op, $cx,
- $self->rv2x($op->first, $cx, '$#'));
- }
-}
-
-# skip down to the old, ex-rv2cv
-sub pp_rv2cv {
- my ($self, $op, $cx) = @_;
- if (!null($op->first) && $op->first->name eq 'null' &&
- $op->first->targ eq OP_LIST)
- {
- return $self->rv2x($op->first->first->sibling, $cx, "&")
- }
- else {
- return $self->rv2x($op, $cx, "")
- }
-}
-
-sub list_const {
- my $self = shift;
- my($cx, @list) = @_;
- my @a = map $self->const($_, 6), @list;
- if (@a == 0) {
- return "()";
- } elsif (@a == 1) {
- return $a[0];
- } elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
- # collapse (-1,0,1,2) into (-1..2)
- my ($s, $e) = @a[0,-1];
- my $i = $s;
- return $self->maybe_parens("$s..$e", $cx, 9)
- unless grep $i++ != $_, @a;
- }
- return $self->maybe_parens(join(", ", @a), $cx, 6);
-}
-
-sub pp_rv2av {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first;
- if ($kid->name eq "const") { # constant list
- my $av = $self->const_sv($kid);
- return $self->list_const($cx, $av->ARRAY);
- } else {
- return $self->maybe_local($op, $cx, $self->rv2x($op, $cx, "\@"));
- }
- }
-
-sub is_subscriptable {
- my $op = shift;
- if ($op->name =~ /^[ahg]elem/) {
- return 1;
- } elsif ($op->name eq "entersub") {
- my $kid = $op->first;
- return 0 unless null $kid->sibling;
- $kid = $kid->first;
- $kid = $kid->sibling until null $kid->sibling;
- return 0 if is_scope($kid);
- $kid = $kid->first;
- return 0 if $kid->name eq "gv";
- return 0 if is_scalar($kid);
- return is_subscriptable($kid);
- } else {
- return 0;
- }
-}
-
-sub elem_or_slice_array_name
-{
- my $self = shift;
- my ($array, $left, $padname, $allow_arrow) = @_;
-
- if ($array->name eq $padname) {
- return $self->padany($array);
- } elsif (is_scope($array)) { # ${expr}[0]
- return "{" . $self->deparse($array, 0) . "}";
- } elsif ($array->name eq "gv") {
- $array = $self->gv_name($self->gv_or_padgv($array));
- if ($array !~ /::/) {
- my $prefix = ($left eq '[' ? '@' : '%');
- $array = $self->{curstash}.'::'.$array
- if $self->lex_in_scope($prefix . $array);
- }
- return $array;
- } elsif (!$allow_arrow || is_scalar $array) { # $x[0], $$x[0], ...
- return $self->deparse($array, 24);
- } else {
- return undef;
- }
-}
-
-sub elem_or_slice_single_index
-{
- my $self = shift;
- my ($idx) = @_;
-
- $idx = $self->deparse($idx, 1);
-
- # Outer parens in an array index will confuse perl
- # if we're interpolating in a regular expression, i.e.
- # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
- #
- # If $self->{parens}, then an initial '(' will
- # definitely be paired with a final ')'. If
- # !$self->{parens}, the misleading parens won't
- # have been added in the first place.
- #
- # [You might think that we could get "(...)...(...)"
- # where the initial and final parens do not match
- # each other. But we can't, because the above would
- # only happen if there's an infix binop between the
- # two pairs of parens, and *that* means that the whole
- # expression would be parenthesized as well.]
- #
- $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
-
- # Hash-element braces will autoquote a bareword inside themselves.
- # We need to make sure that C<$hash{warn()}> doesn't come out as
- # C<$hash{warn}>, which has a quite different meaning. Currently
- # B::Deparse will always quote strings, even if the string was a
- # bareword in the original (i.e. the OPpCONST_BARE flag is ignored
- # for constant strings.) So we can cheat slightly here - if we see
- # a bareword, we know that it is supposed to be a function call.
- #
- $idx =~ s/^([A-Za-z_]\w*)$/$1()/;
-
- return $idx;
-}
-
-sub elem {
- my $self = shift;
- my ($op, $cx, $left, $right, $padname) = @_;
- my($array, $idx) = ($op->first, $op->first->sibling);
-
- $idx = $self->elem_or_slice_single_index($idx);
-
- unless ($array->name eq $padname) { # Maybe this has been fixed
- $array = $array->first; # skip rv2av (or ex-rv2av in _53+)
- }
- if (my $array_name=$self->elem_or_slice_array_name
- ($array, $left, $padname, 1)) {
- return "\$" . $array_name . $left . $idx . $right;
- } else {
- # $x[20][3]{hi} or expr->[20]
- my $arrow = is_subscriptable($array) ? "" : "->";
- return $self->deparse($array, 24) . $arrow . $left . $idx . $right;
- }
-
-}
-
-sub pp_aelem { maybe_local(@_, elem(@_, "[", "]", "padav")) }
-sub pp_helem { maybe_local(@_, elem(@_, "{", "}", "padhv")) }
-
-sub pp_gelem {
- my $self = shift;
- my($op, $cx) = @_;
- my($glob, $part) = ($op->first, $op->last);
- $glob = $glob->first; # skip rv2gv
- $glob = $glob->first if $glob->name eq "rv2gv"; # this one's a bug
- my $scope = is_scope($glob);
- $glob = $self->deparse($glob, 0);
- $part = $self->deparse($part, 1);
- return "*" . ($scope ? "{$glob}" : $glob) . "{$part}";
-}
-
-sub slice {
- my $self = shift;
- my ($op, $cx, $left, $right, $regname, $padname) = @_;
- my $last;
- my(@elems, $kid, $array, $list);
- if (class($op) eq "LISTOP") {
- $last = $op->last;
- } else { # ex-hslice inside delete()
- for ($kid = $op->first; !null $kid->sibling; $kid = $kid->sibling) {}
- $last = $kid;
- }
- $array = $last;
- $array = $array->first
- if $array->name eq $regname or $array->name eq "null";
- $array = $self->elem_or_slice_array_name($array,$left,$padname,0);
- $kid = $op->first->sibling; # skip pushmark
- if ($kid->name eq "list") {
- $kid = $kid->first->sibling; # skip list, pushmark
- for (; !null $kid; $kid = $kid->sibling) {
- push @elems, $self->deparse($kid, 6);
- }
- $list = join(", ", @elems);
- } else {
- $list = $self->elem_or_slice_single_index($kid);
- }
- return "\@" . $array . $left . $list . $right;
-}
-
-sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
-sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
-
-sub pp_lslice {
- my $self = shift;
- my($op, $cx) = @_;
- my $idx = $op->first;
- my $list = $op->last;
- my(@elems, $kid);
- $list = $self->deparse($list, 1);
- $idx = $self->deparse($idx, 1);
- return "($list)" . "[$idx]";
-}
-
-sub want_scalar {
- my $op = shift;
- return ($op->flags & OPf_WANT) == OPf_WANT_SCALAR;
-}
-
-sub want_list {
- my $op = shift;
- return ($op->flags & OPf_WANT) == OPf_WANT_LIST;
-}
-
-sub _method {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first->sibling; # skip pushmark
- my($meth, $obj, @exprs);
- if ($kid->name eq "list" and want_list $kid) {
- # When an indirect object isn't a bareword but the args are in
- # parens, the parens aren't part of the method syntax (the LLAFR
- # doesn't apply), but they make a list with OPf_PARENS set that
- # doesn't get flattened by the append_elem that adds the method,
- # making a (object, arg1, arg2, ...) list where the object
- # usually is. This can be distinguished from
- # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
- # object) because in the later the list is in scalar context
- # as the left side of -> always is, while in the former
- # the list is in list context as method arguments always are.
- # (Good thing there aren't method prototypes!)
- $meth = $kid->sibling;
- $kid = $kid->first->sibling; # skip pushmark
- $obj = $kid;
- $kid = $kid->sibling;
- for (; not null $kid; $kid = $kid->sibling) {
- push @exprs, $kid;
- }
- } else {
- $obj = $kid;
- $kid = $kid->sibling;
- for (; !null ($kid->sibling) && $kid->name ne "method_named";
- $kid = $kid->sibling) {
- push @exprs, $kid
- }
- $meth = $kid;
- }
-
- if ($meth->name eq "method_named") {
- $meth = $self->const_sv($meth)->PV;
- } else {
- $meth = $meth->first;
- if ($meth->name eq "const") {
- # As of 5.005_58, this case is probably obsoleted by the
- # method_named case above
- $meth = $self->const_sv($meth)->PV; # needs to be bare
- }
- }
-
- return { method => $meth, variable_method => ref($meth),
- object => $obj, args => \@exprs };
-}
-
-# compat function only
-sub method {
- my $self = shift;
- my $info = $self->_method(@_);
- return $self->e_method( $self->_method(@_) );
-}
-
-sub e_method {
- my ($self, $info) = @_;
- my $obj = $self->deparse($info->{object}, 24);
-
- my $meth = $info->{method};
- $meth = $self->deparse($meth, 1) if $info->{variable_method};
- my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
- my $kid = $obj . "->" . $meth;
- if (length $args) {
- return $kid . "(" . $args . ")"; # parens mandatory
- } else {
- return $kid;
- }
-}
-
-# returns "&" if the prototype doesn't match the args,
-# or ("", $args_after_prototype_demunging) if it does.
-sub check_proto {
- my $self = shift;
- return "&" if $self->{'noproto'};
- my($proto, @args) = @_;
- my($arg, $real);
- my $doneok = 0;
- my @reals;
- # An unbackslashed @ or % gobbles up the rest of the args
- 1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
- while ($proto) {
- $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)//;
- my $chr = $1;
- if ($chr eq "") {
- return "&" if @args;
- } elsif ($chr eq ";") {
- $doneok = 1;
- } elsif ($chr eq "@" or $chr eq "%") {
- push @reals, map($self->deparse($_, 6), @args);
- @args = ();
- } else {
- $arg = shift @args;
- last unless $arg;
- if ($chr eq "\$" || $chr eq "_") {
- if (want_scalar $arg) {
- push @reals, $self->deparse($arg, 6);
- } else {
- return "&";
- }
- } elsif ($chr eq "&") {
- if ($arg->name =~ /^(s?refgen|undef)$/) {
- push @reals, $self->deparse($arg, 6);
- } else {
- return "&";
- }
- } elsif ($chr eq "*") {
- if ($arg->name =~ /^s?refgen$/
- and $arg->first->first->name eq "rv2gv")
- {
- $real = $arg->first->first; # skip refgen, null
- if ($real->first->name eq "gv") {
- push @reals, $self->deparse($real, 6);
- } else {
- push @reals, $self->deparse($real->first, 6);
- }
- } else {
- return "&";
- }
- } elsif (substr($chr, 0, 1) eq "\\") {
- $chr =~ tr/\\[]//d;
- if ($arg->name =~ /^s?refgen$/ and
- !null($real = $arg->first) and
- ($chr =~ /\$/ && is_scalar($real->first)
- or ($chr =~ /@/
- && class($real->first->sibling) ne 'NULL'
- && $real->first->sibling->name
- =~ /^(rv2|pad)av$/)
- or ($chr =~ /%/
- && class($real->first->sibling) ne 'NULL'
- && $real->first->sibling->name
- =~ /^(rv2|pad)hv$/)
- #or ($chr =~ /&/ # This doesn't work
- # && $real->first->name eq "rv2cv")
- or ($chr =~ /\*/
- && $real->first->name eq "rv2gv")))
- {
- push @reals, $self->deparse($real, 6);
- } else {
- return "&";
- }
- }
- }
- }
- return "&" if $proto and !$doneok; # too few args and no `;'
- return "&" if @args; # too many args
- return ("", join ", ", @reals);
-}
-
-sub pp_entersub {
- my $self = shift;
- my($op, $cx) = @_;
- return $self->e_method($self->_method($op, $cx))
- unless null $op->first->sibling;
- my $prefix = "";
- my $amper = "";
- my($kid, @exprs);
- if ($op->flags & OPf_SPECIAL && !($op->flags & OPf_MOD)) {
- $prefix = "do ";
- } elsif ($op->private & OPpENTERSUB_AMPER) {
- $amper = "&";
- }
- $kid = $op->first;
- $kid = $kid->first->sibling; # skip ex-list, pushmark
- for (; not null $kid->sibling; $kid = $kid->sibling) {
- push @exprs, $kid;
- }
- my $simple = 0;
- my $proto = undef;
- if (is_scope($kid)) {
- $amper = "&";
- $kid = "{" . $self->deparse($kid, 0) . "}";
- } elsif ($kid->first->name eq "gv") {
- my $gv = $self->gv_or_padgv($kid->first);
- if (class($gv->CV) ne "SPECIAL") {
- $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK;
- }
- $simple = 1; # only calls of named functions can be prototyped
- $kid = $self->deparse($kid, 24);
- if (!$amper) {
- if ($kid eq 'main::') {
- $kid = '::';
- } elsif ($kid !~ /^(?:\w|::)(?:[\w\d]|::(?!\z))*\z/) {
- $kid = single_delim("q", "'", $kid) . '->';
- }
- }
- } elsif (is_scalar ($kid->first) && $kid->first->name ne 'rv2cv') {
- $amper = "&";
- $kid = $self->deparse($kid, 24);
- } else {
- $prefix = "";
- my $arrow = is_subscriptable($kid->first) ? "" : "->";
- $kid = $self->deparse($kid, 24) . $arrow;
- }
-
- # Doesn't matter how many prototypes there are, if
- # they haven't happened yet!
- my $declared;
- {
- no strict 'refs';
- no warnings 'uninitialized';
- $declared = exists $self->{'subs_declared'}{$kid}
- || (
- defined &{ ${$self->{'curstash'}."::"}{$kid} }
- && !exists
- $self->{'subs_deparsed'}{$self->{'curstash'}."::".$kid}
- && defined prototype $self->{'curstash'}."::".$kid
- );
- if (!$declared && defined($proto)) {
- # Avoid "too early to check prototype" warning
- ($amper, $proto) = ('&');
- }
- }
-
- my $args;
- if ($declared and defined $proto and not $amper) {
- ($amper, $args) = $self->check_proto($proto, @exprs);
- if ($amper eq "&") {
- $args = join(", ", map($self->deparse($_, 6), @exprs));
- }
- } else {
- $args = join(", ", map($self->deparse($_, 6), @exprs));
- }
- if ($prefix or $amper) {
- if ($op->flags & OPf_STACKED) {
- return $prefix . $amper . $kid . "(" . $args . ")";
- } else {
- return $prefix . $amper. $kid;
- }
- } else {
- # glob() invocations can be translated into calls of
- # CORE::GLOBAL::glob with a second parameter, a number.
- # Reverse this.
- if ($kid eq "CORE::GLOBAL::glob") {
- $kid = "glob";
- $args =~ s/\s*,[^,]+$//;
- }
-
- # It's a syntax error to call CORE::GLOBAL::foo without a prefix,
- # so it must have been translated from a keyword call. Translate
- # it back.
- $kid =~ s/^CORE::GLOBAL:://;
-
- my $dproto = defined($proto) ? $proto : "undefined";
- if (!$declared) {
- return "$kid(" . $args . ")";
- } elsif ($dproto eq "") {
- return $kid;
- } elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
- # is_scalar is an excessively conservative test here:
- # really, we should be comparing to the precedence of the
- # top operator of $exprs[0] (ala unop()), but that would
- # take some major code restructuring to do right.
- return $self->maybe_parens_func($kid, $args, $cx, 16);
- } elsif ($dproto ne '$' and defined($proto) || $simple) { #'
- return $self->maybe_parens_func($kid, $args, $cx, 5);
- } else {
- return "$kid(" . $args . ")";
- }
- }
-}
-
-sub pp_enterwrite { unop(@_, "write") }
-
-# escape things that cause interpolation in double quotes,
-# but not character escapes
-sub uninterp {
- my($str) = @_;
- $str =~ s/(^|\G|[^\\])((?:\\\\)*)([\$\@]|\\[uUlLQE])/$1$2\\$3/g;
- return $str;
-}
-
-{
-my $bal;
-BEGIN {
- use re "eval";
- # Matches any string which is balanced with respect to {braces}
- $bal = qr(
- (?:
- [^\\{}]
- | \\\\
- | \\[{}]
- | \{(??{$bal})\}
- )*
- )x;
-}
-
-# the same, but treat $|, $), $( and $ at the end of the string differently
-sub re_uninterp {
- my($str) = @_;
-
- $str =~ s/
- ( ^|\G # $1
- | [^\\]
- )
-
- ( # $2
- (?:\\\\)*
- )
-
- ( # $3
- (\(\?\??\{$bal\}\)) # $4
- | [\$\@]
- (?!\||\)|\(|$)
- | \\[uUlLQE]
- )
-
- /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
-
- return $str;
-}
-
-# This is for regular expressions with the /x modifier
-# We have to leave comments unmangled.
-sub re_uninterp_extended {
- my($str) = @_;
-
- $str =~ s/
- ( ^|\G # $1
- | [^\\]
- )
-
- ( # $2
- (?:\\\\)*
- )
-
- ( # $3
- ( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
- | \#[^\n]* # (skip over comments)
- )
- | [\$\@]
- (?!\||\)|\(|$|\s)
- | \\[uUlLQE]
- )
-
- /defined($4) && length($4) ? "$1$2$4" : "$1$2\\$3"/xeg;
-
- return $str;
-}
-}
-
-my %unctrl = # portable to to EBCDIC
- (
- "\c@" => '\c@', # unused
- "\cA" => '\cA',
- "\cB" => '\cB',
- "\cC" => '\cC',
- "\cD" => '\cD',
- "\cE" => '\cE',
- "\cF" => '\cF',
- "\cG" => '\cG',
- "\cH" => '\cH',
- "\cI" => '\cI',
- "\cJ" => '\cJ',
- "\cK" => '\cK',
- "\cL" => '\cL',
- "\cM" => '\cM',
- "\cN" => '\cN',
- "\cO" => '\cO',
- "\cP" => '\cP',
- "\cQ" => '\cQ',
- "\cR" => '\cR',
- "\cS" => '\cS',
- "\cT" => '\cT',
- "\cU" => '\cU',
- "\cV" => '\cV',
- "\cW" => '\cW',
- "\cX" => '\cX',
- "\cY" => '\cY',
- "\cZ" => '\cZ',
- "\c[" => '\c[', # unused
- "\c\\" => '\c\\', # unused
- "\c]" => '\c]', # unused
- "\c_" => '\c_', # unused
- );
-
-# character escapes, but not delimiters that might need to be escaped
-sub escape_str { # ASCII, UTF8
- my($str) = @_;
- $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
- $str =~ s/\a/\\a/g;
-# $str =~ s/\cH/\\b/g; # \b means something different in a regex
- $str =~ s/\t/\\t/g;
- $str =~ s/\n/\\n/g;
- $str =~ s/\e/\\e/g;
- $str =~ s/\f/\\f/g;
- $str =~ s/\r/\\r/g;
- $str =~ s/([\cA-\cZ])/$unctrl{$1}/ge;
- $str =~ s/([[:^print:]])/sprintf("\\%03o", ord($1))/ge;
- return $str;
-}
-
-# For regexes with the /x modifier.
-# Leave whitespace unmangled.
-sub escape_extended_re {
- my($str) = @_;
- $str =~ s/(.)/ord($1) > 255 ? sprintf("\\x{%x}", ord($1)) : $1/eg;
- $str =~ s/([[:^print:]])/
- ($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
- $str =~ s/\n/\n\f/g;
- return $str;
-}
-
-# Don't do this for regexen
-sub unback {
- my($str) = @_;
- $str =~ s/\\/\\\\/g;
- return $str;
-}
-
-# Remove backslashes which precede literal control characters,
-# to avoid creating ambiguity when we escape the latter.
-sub re_unback {
- my($str) = @_;
-
- # the insane complexity here is due to the behaviour of "\c\"
- $str =~ s/(^|[^\\]|\\c\\)(?<!\\c)\\(\\\\)*(?=[[:^print:]])/$1$2/g;
- return $str;
-}
-
-sub balanced_delim {
- my($str) = @_;
- my @str = split //, $str;
- my($ar, $open, $close, $fail, $c, $cnt, $last_bs);
- for $ar (['[',']'], ['(',')'], ['<','>'], ['{','}']) {
- ($open, $close) = @$ar;
- $fail = 0; $cnt = 0; $last_bs = 0;
- for $c (@str) {
- if ($c eq $open) {
- $fail = 1 if $last_bs;
- $cnt++;
- } elsif ($c eq $close) {
- $fail = 1 if $last_bs;
- $cnt--;
- if ($cnt < 0) {
- # qq()() isn't ")("
- $fail = 1;
- last;
- }
- }
- $last_bs = $c eq '\\';
- }
- $fail = 1 if $cnt != 0;
- return ($open, "$open$str$close") if not $fail;
- }
- return ("", $str);
-}
-
-sub single_delim {
- my($q, $default, $str) = @_;
- return "$default$str$default" if $default and index($str, $default) == -1;
- if ($q ne 'qr') {
- (my $succeed, $str) = balanced_delim($str);
- return "$q$str" if $succeed;
- }
- for my $delim ('/', '"', '#') {
- return "$q$delim" . $str . $delim if index($str, $delim) == -1;
- }
- if ($default) {
- $str =~ s/$default/\\$default/g;
- return "$default$str$default";
- } else {
- $str =~ s[/][\\/]g;
- return "$q/$str/";
- }
-}
-
-my $max_prec;
-BEGIN { $max_prec = int(0.999 + 8*length(pack("F", 42))*log(2)/log(10)); }
-
-# Split a floating point number into an integer mantissa and a binary
-# exponent. Assumes you've already made sure the number isn't zero or
-# some weird infinity or NaN.
-sub split_float {
- my($f) = @_;
- my $exponent = 0;
- if ($f == int($f)) {
- while ($f % 2 == 0) {
- $f /= 2;
- $exponent++;
- }
- } else {
- while ($f != int($f)) {
- $f *= 2;
- $exponent--;
- }
- }
- my $mantissa = sprintf("%.0f", $f);
- return ($mantissa, $exponent);
-}
-
-sub const {
- my $self = shift;
- my($sv, $cx) = @_;
- if ($self->{'use_dumper'}) {
- return $self->const_dumper($sv, $cx);
- }
- if (class($sv) eq "SPECIAL") {
- # sv_undef, sv_yes, sv_no
- return ('undef', '1', $self->maybe_parens("!1", $cx, 21))[$$sv-1];
- }
- if (class($sv) eq "NULL") {
- return 'undef';
- }
- # convert a version object into the "v1.2.3" string in its V magic
- if ($sv->FLAGS & SVs_RMG) {
- for (my $mg = $sv->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
- return $mg->PTR if $mg->TYPE eq 'V';
- }
- }
-
- if ($sv->FLAGS & SVf_IOK) {
- my $str = $sv->int_value;
- $str = $self->maybe_parens($str, $cx, 21) if $str < 0;
- return $str;
- } elsif ($sv->FLAGS & SVf_NOK) {
- my $nv = $sv->NV;
- if ($nv == 0) {
- if (pack("F", $nv) eq pack("F", 0)) {
- # positive zero
- return "0";
- } else {
- # negative zero
- return $self->maybe_parens("-.0", $cx, 21);
- }
- } elsif (1/$nv == 0) {
- if ($nv > 0) {
- # positive infinity
- return $self->maybe_parens("9**9**9", $cx, 22);
- } else {
- # negative infinity
- return $self->maybe_parens("-9**9**9", $cx, 21);
- }
- } elsif ($nv != $nv) {
- # NaN
- if (pack("F", $nv) eq pack("F", sin(9**9**9))) {
- # the normal kind
- return "sin(9**9**9)";
- } elsif (pack("F", $nv) eq pack("F", -sin(9**9**9))) {
- # the inverted kind
- return $self->maybe_parens("-sin(9**9**9)", $cx, 21);
- } else {
- # some other kind
- my $hex = unpack("h*", pack("F", $nv));
- return qq'unpack("F", pack("h*", "$hex"))';
- }
- }
- # first, try the default stringification
- my $str = "$nv";
- if ($str != $nv) {
- # failing that, try using more precision
- $str = sprintf("%.${max_prec}g", $nv);
-# if (pack("F", $str) ne pack("F", $nv)) {
- if ($str != $nv) {
- # not representable in decimal with whatever sprintf()
- # and atof() Perl is using here.
- my($mant, $exp) = split_float($nv);
- return $self->maybe_parens("$mant * 2**$exp", $cx, 19);
- }
- }
- $str = $self->maybe_parens($str, $cx, 21) if $nv < 0;
- return $str;
- } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
- my $ref = $sv->RV;
- if (class($ref) eq "AV") {
- return "[" . $self->list_const(2, $ref->ARRAY) . "]";
- } elsif (class($ref) eq "HV") {
- my %hash = $ref->ARRAY;
- my @elts;
- for my $k (sort keys %hash) {
- push @elts, "$k => " . $self->const($hash{$k}, 6);
- }
- return "{" . join(", ", @elts) . "}";
- } elsif (class($ref) eq "CV") {
- return "sub " . $self->deparse_sub($ref);
- }
- if ($ref->FLAGS & SVs_SMG) {
- for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
- if ($mg->TYPE eq 'r') {
- my $re = re_uninterp(escape_str(re_unback($mg->precomp)));
- return single_delim("qr", "", $re);
- }
- }
- }
-
- return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
- } elsif ($sv->FLAGS & SVf_POK) {
- my $str = $sv->PV;
- if ($str =~ /[[:^print:]]/) {
- return single_delim("qq", '"', uninterp escape_str unback $str);
- } else {
- return single_delim("q", "'", unback $str);
- }
- } else {
- return "undef";
- }
-}
-
-sub const_dumper {
- my $self = shift;
- my($sv, $cx) = @_;
- my $ref = $sv->object_2svref();
- my $dumper = Data::Dumper->new([$$ref], ['$v']);
- $dumper->Purity(1)->Terse(1)->Deparse(1)->Indent(0)->Useqq(1)->Sortkeys(1);
- my $str = $dumper->Dump();
- if ($str =~ /^\$v/) {
- return '${my ' . $str . ' \$v}';
- } else {
- return $str;
- }
-}
-
-sub const_sv {
- my $self = shift;
- my $op = shift;
- my $sv = $op->sv;
- # the constant could be in the pad (under useithreads)
- $sv = $self->padval($op->targ) unless $$sv;
- return $sv;
-}
-
-sub pp_const {
- my $self = shift;
- my($op, $cx) = @_;
- if ($op->private & OPpCONST_ARYBASE) {
- return '$[';
- }
-# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
-# return $self->const_sv($op)->PV;
-# }
- my $sv = $self->const_sv($op);
- return $self->const($sv, $cx);
-}
-
-sub dq {
- my $self = shift;
- my $op = shift;
- my $type = $op->name;
- if ($type eq "const") {
- return '$[' if $op->private & OPpCONST_ARYBASE;
- return uninterp(escape_str(unback($self->const_sv($op)->as_string)));
- } elsif ($type eq "concat") {
- my $first = $self->dq($op->first);
- my $last = $self->dq($op->last);
-
- # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
- ($last =~ /^[A-Z\\\^\[\]_?]/ &&
- $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
- || ($last =~ /^[:'{\[\w_]/ && #'
- $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
-
- return $first . $last;
- } elsif ($type eq "uc") {
- return '\U' . $self->dq($op->first->sibling) . '\E';
- } elsif ($type eq "lc") {
- return '\L' . $self->dq($op->first->sibling) . '\E';
- } elsif ($type eq "ucfirst") {
- return '\u' . $self->dq($op->first->sibling);
- } elsif ($type eq "lcfirst") {
- return '\l' . $self->dq($op->first->sibling);
- } elsif ($type eq "quotemeta") {
- return '\Q' . $self->dq($op->first->sibling) . '\E';
- } elsif ($type eq "join") {
- return $self->deparse($op->last, 26); # was join($", @ary)
- } else {
- return $self->deparse($op, 26);
- }
-}
-
-sub pp_backtick {
- my $self = shift;
- my($op, $cx) = @_;
- # skip pushmark if it exists (readpipe() vs ``)
- my $child = $op->first->sibling->isa('B::NULL')
- ? $op->first : $op->first->sibling;
- return single_delim("qx", '`', $self->dq($child));
-}
-
-sub dquote {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first->sibling; # skip ex-stringify, pushmark
- return $self->deparse($kid, $cx) if $self->{'unquote'};
- $self->maybe_targmy($kid, $cx,
- sub {single_delim("qq", '"', $self->dq($_[1]))});
-}
-
-# OP_STRINGIFY is a listop, but it only ever has one arg
-sub pp_stringify { maybe_targmy(@_, \&dquote) }
-
-# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
-# note that tr(from)/to/ is OK, but not tr/from/(to)
-sub double_delim {
- my($from, $to) = @_;
- my($succeed, $delim);
- if ($from !~ m[/] and $to !~ m[/]) {
- return "/$from/$to/";
- } elsif (($succeed, $from) = balanced_delim($from) and $succeed) {
- if (($succeed, $to) = balanced_delim($to) and $succeed) {
- return "$from$to";
- } else {
- for $delim ('/', '"', '#') { # note no `'' -- s''' is special
- return "$from$delim$to$delim" if index($to, $delim) == -1;
- }
- $to =~ s[/][\\/]g;
- return "$from/$to/";
- }
- } else {
- for $delim ('/', '"', '#') { # note no '
- return "$delim$from$delim$to$delim"
- if index($to . $from, $delim) == -1;
- }
- $from =~ s[/][\\/]g;
- $to =~ s[/][\\/]g;
- return "/$from/$to/";
- }
-}
-
-# Only used by tr///, so backslashes hyphens
-sub pchr { # ASCII
- my($n) = @_;
- if ($n == ord '\\') {
- return '\\\\';
- } elsif ($n == ord "-") {
- return "\\-";
- } elsif ($n >= ord(' ') and $n <= ord('~')) {
- return chr($n);
- } elsif ($n == ord "\a") {
- return '\\a';
- } elsif ($n == ord "\b") {
- return '\\b';
- } elsif ($n == ord "\t") {
- return '\\t';
- } elsif ($n == ord "\n") {
- return '\\n';
- } elsif ($n == ord "\e") {
- return '\\e';
- } elsif ($n == ord "\f") {
- return '\\f';
- } elsif ($n == ord "\r") {
- return '\\r';
- } elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
- return '\\c' . chr(ord("@") + $n);
- } else {
-# return '\x' . sprintf("%02x", $n);
- return '\\' . sprintf("%03o", $n);
- }
-}
-
-sub collapse {
- my(@chars) = @_;
- my($str, $c, $tr) = ("");
- for ($c = 0; $c < @chars; $c++) {
- $tr = $chars[$c];
- $str .= pchr($tr);
- if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
- $chars[$c + 2] == $tr + 2)
- {
- for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
- {}
- $str .= "-";
- $str .= pchr($chars[$c]);
- }
- }
- return $str;
-}
-
-sub tr_decode_byte {
- my($table, $flags) = @_;
- my(@table) = unpack("s*", $table);
- splice @table, 0x100, 1; # Number of subsequent elements
- my($c, $tr, @from, @to, @delfrom, $delhyphen);
- if ($table[ord "-"] != -1 and
- $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
- {
- $tr = $table[ord "-"];
- $table[ord "-"] = -1;
- if ($tr >= 0) {
- @from = ord("-");
- @to = $tr;
- } else { # -2 ==> delete
- $delhyphen = 1;
- }
- }
- for ($c = 0; $c < @table; $c++) {
- $tr = $table[$c];
- if ($tr >= 0) {
- push @from, $c; push @to, $tr;
- } elsif ($tr == -2) {
- push @delfrom, $c;
- }
- }
- @from = (@from, @delfrom);
- if ($flags & OPpTRANS_COMPLEMENT) {
- my @newfrom = ();
- my %from;
- @from{@from} = (1) x @from;
- for ($c = 0; $c < 256; $c++) {
- push @newfrom, $c unless $from{$c};
- }
- @from = @newfrom;
- }
- unless ($flags & OPpTRANS_DELETE || !@to) {
- pop @to while $#to and $to[$#to] == $to[$#to -1];
- }
- my($from, $to);
- $from = collapse(@from);
- $to = collapse(@to);
- $from .= "-" if $delhyphen;
- return ($from, $to);
-}
-
-sub tr_chr {
- my $x = shift;
- if ($x == ord "-") {
- return "\\-";
- } elsif ($x == ord "\\") {
- return "\\\\";
- } else {
- return chr $x;
- }
-}
-
-# XXX This doesn't yet handle all cases correctly either
-
-sub tr_decode_utf8 {
- my($swash_hv, $flags) = @_;
- my %swash = $swash_hv->ARRAY;
- my $final = undef;
- $final = $swash{'FINAL'}->IV if exists $swash{'FINAL'};
- my $none = $swash{"NONE"}->IV;
- my $extra = $none + 1;
- my(@from, @delfrom, @to);
- my $line;
- foreach $line (split /\n/, $swash{'LIST'}->PV) {
- my($min, $max, $result) = split(/\t/, $line);
- $min = hex $min;
- if (length $max) {
- $max = hex $max;
- } else {
- $max = $min;
- }
- $result = hex $result;
- if ($result == $extra) {
- push @delfrom, [$min, $max];
- } else {
- push @from, [$min, $max];
- push @to, [$result, $result + $max - $min];
- }
- }
- for my $i (0 .. $#from) {
- if ($from[$i][0] == ord '-') {
- unshift @from, splice(@from, $i, 1);
- unshift @to, splice(@to, $i, 1);
- last;
- } elsif ($from[$i][1] == ord '-') {
- $from[$i][1]--;
- $to[$i][1]--;
- unshift @from, ord '-';
- unshift @to, ord '-';
- last;
- }
- }
- for my $i (0 .. $#delfrom) {
- if ($delfrom[$i][0] == ord '-') {
- push @delfrom, splice(@delfrom, $i, 1);
- last;
- } elsif ($delfrom[$i][1] == ord '-') {
- $delfrom[$i][1]--;
- push @delfrom, ord '-';
- last;
- }
- }
- if (defined $final and $to[$#to][1] != $final) {
- push @to, [$final, $final];
- }
- push @from, @delfrom;
- if ($flags & OPpTRANS_COMPLEMENT) {
- my @newfrom;
- my $next = 0;
- for my $i (0 .. $#from) {
- push @newfrom, [$next, $from[$i][0] - 1];
- $next = $from[$i][1] + 1;
- }
- @from = ();
- for my $range (@newfrom) {
- if ($range->[0] <= $range->[1]) {
- push @from, $range;
- }
- }
- }
- my($from, $to, $diff);
- for my $chunk (@from) {
- $diff = $chunk->[1] - $chunk->[0];
- if ($diff > 1) {
- $from .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
- } elsif ($diff == 1) {
- $from .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
- } else {
- $from .= tr_chr($chunk->[0]);
- }
- }
- for my $chunk (@to) {
- $diff = $chunk->[1] - $chunk->[0];
- if ($diff > 1) {
- $to .= tr_chr($chunk->[0]) . "-" . tr_chr($chunk->[1]);
- } elsif ($diff == 1) {
- $to .= tr_chr($chunk->[0]) . tr_chr($chunk->[1]);
- } else {
- $to .= tr_chr($chunk->[0]);
- }
- }
- #$final = sprintf("%04x", $final) if defined $final;
- #$none = sprintf("%04x", $none) if defined $none;
- #$extra = sprintf("%04x", $extra) if defined $extra;
- #print STDERR "final: $final\n none: $none\nextra: $extra\n";
- #print STDERR $swash{'LIST'}->PV;
- return (escape_str($from), escape_str($to));
-}
-
-sub pp_trans {
- my $self = shift;
- my($op, $cx) = @_;
- my($from, $to);
- if (class($op) eq "PVOP") {
- ($from, $to) = tr_decode_byte($op->pv, $op->private);
- } else { # class($op) eq "SVOP"
- ($from, $to) = tr_decode_utf8($op->sv->RV, $op->private);
- }
- my $flags = "";
- $flags .= "c" if $op->private & OPpTRANS_COMPLEMENT;
- $flags .= "d" if $op->private & OPpTRANS_DELETE;
- $to = "" if $from eq $to and $flags eq "";
- $flags .= "s" if $op->private & OPpTRANS_SQUASH;
- return "tr" . double_delim($from, $to) . $flags;
-}
-
-sub re_dq_disambiguate {
- my ($first, $last) = @_;
- # Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
- ($last =~ /^[A-Z\\\^\[\]_?]/ &&
- $first =~ s/([\$@])\^$/${1}{^}/) # "${^}W" etc
- || ($last =~ /^[{\[\w_]/ &&
- $first =~ s/([\$@])([A-Za-z_]\w*)$/${1}{$2}/);
- return $first . $last;
-}
-
-# Like dq(), but different
-sub re_dq {
- my $self = shift;
- my ($op, $extended) = @_;
-
- my $type = $op->name;
- if ($type eq "const") {
- return '$[' if $op->private & OPpCONST_ARYBASE;
- my $unbacked = re_unback($self->const_sv($op)->as_string);
- return re_uninterp_extended(escape_extended_re($unbacked))
- if $extended;
- return re_uninterp(escape_str($unbacked));
- } elsif ($type eq "concat") {
- my $first = $self->re_dq($op->first, $extended);
- my $last = $self->re_dq($op->last, $extended);
- return re_dq_disambiguate($first, $last);
- } elsif ($type eq "uc") {
- return '\U' . $self->re_dq($op->first->sibling, $extended) . '\E';
- } elsif ($type eq "lc") {
- return '\L' . $self->re_dq($op->first->sibling, $extended) . '\E';
- } elsif ($type eq "ucfirst") {
- return '\u' . $self->re_dq($op->first->sibling, $extended);
- } elsif ($type eq "lcfirst") {
- return '\l' . $self->re_dq($op->first->sibling, $extended);
- } elsif ($type eq "quotemeta") {
- return '\Q' . $self->re_dq($op->first->sibling, $extended) . '\E';
- } elsif ($type eq "join") {
- return $self->deparse($op->last, 26); # was join($", @ary)
- } else {
- return $self->deparse($op, 26);
- }
-}
-
-sub pure_string {
- my ($self, $op) = @_;
- return 0 if null $op;
- my $type = $op->name;
-
- if ($type eq 'const') {
- return 1;
- }
- elsif ($type =~ /^[ul]c(first)?$/ || $type eq 'quotemeta') {
- return $self->pure_string($op->first->sibling);
- }
- elsif ($type eq 'join') {
- my $join_op = $op->first->sibling; # Skip pushmark
- return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
-
- my $gvop = $join_op->first;
- return 0 unless $gvop->name eq 'gvsv';
- return 0 unless '"' eq $self->gv_name($self->gv_or_padgv($gvop));
-
- return 0 unless ${$join_op->sibling} eq ${$op->last};
- return 0 unless $op->last->name =~ /^(?:[ah]slice|(?:rv2|pad)av)$/;
- }
- elsif ($type eq 'concat') {
- return $self->pure_string($op->first)
- && $self->pure_string($op->last);
- }
- elsif (is_scalar($op) || $type =~ /^[ah]elem$/) {
- return 1;
- }
- elsif ($type eq "null" and $op->can('first') and not null $op->first and
- $op->first->name eq "null" and $op->first->can('first')
- and not null $op->first->first and
- $op->first->first->name eq "aelemfast") {
- return 1;
- }
- else {
- return 0;
- }
-
- return 1;
-}
-
-sub regcomp {
- my $self = shift;
- my($op, $cx, $extended) = @_;
- my $kid = $op->first;
- $kid = $kid->first if $kid->name eq "regcmaybe";
- $kid = $kid->first if $kid->name eq "regcreset";
- if ($kid->name eq "null" and !null($kid->first)
- and $kid->first->name eq 'pushmark')
- {
- my $str = '';
- $kid = $kid->first->sibling;
- while (!null($kid)) {
- my $first = $str;
- my $last = $self->re_dq($kid, $extended);
- $str = re_dq_disambiguate($first, $last);
- $kid = $kid->sibling;
- }
- return $str, 1;
- }
-
- return ($self->re_dq($kid, $extended), 1) if $self->pure_string($kid);
- return ($self->deparse($kid, $cx), 0);
-}
-
-sub pp_regcomp {
- my ($self, $op, $cx) = @_;
- return (($self->regcomp($op, $cx, 0))[0]);
-}
-
-# osmic acid -- see osmium tetroxide
-
-my %matchwords;
-map($matchwords{join "", sort split //, $_} = $_, 'cig', 'cog', 'cos', 'cogs',
- 'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
- 'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
-
-sub matchop {
- my $self = shift;
- my($op, $cx, $name, $delim) = @_;
- my $kid = $op->first;
- my ($binop, $var, $re) = ("", "", "");
- if ($op->flags & OPf_STACKED) {
- $binop = 1;
- $var = $self->deparse($kid, 20);
- $kid = $kid->sibling;
- }
- my $quote = 1;
- my $extended = ($op->pmflags & PMf_EXTENDED);
- if (null $kid) {
- my $unbacked = re_unback($op->precomp);
- if ($extended) {
- $re = re_uninterp_extended(escape_extended_re($unbacked));
- } else {
- $re = re_uninterp(escape_str(re_unback($op->precomp)));
- }
- } elsif ($kid->name ne 'regcomp') {
- carp("found ".$kid->name." where regcomp expected");
- } else {
- ($re, $quote) = $self->regcomp($kid, 21, $extended);
- }
- my $flags = "";
- $flags .= "c" if $op->pmflags & PMf_CONTINUE;
- $flags .= "g" if $op->pmflags & PMf_GLOBAL;
- $flags .= "i" if $op->pmflags & PMf_FOLD;
- $flags .= "m" if $op->pmflags & PMf_MULTILINE;
- $flags .= "o" if $op->pmflags & PMf_KEEP;
- $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
- $flags .= "x" if $op->pmflags & PMf_EXTENDED;
- $flags = $matchwords{$flags} if $matchwords{$flags};
- if ($op->pmflags & PMf_ONCE) { # only one kind of delimiter works here
- $re =~ s/\?/\\?/g;
- $re = "?$re?";
- } elsif ($quote) {
- $re = single_delim($name, $delim, $re);
- }
- $re = $re . $flags if $quote;
- if ($binop) {
- return $self->maybe_parens("$var =~ $re", $cx, 20);
- } else {
- return $re;
- }
-}
-
-sub pp_match { matchop(@_, "m", "/") }
-sub pp_pushre { matchop(@_, "m", "/") }
-sub pp_qr { matchop(@_, "qr", "") }
-
-sub pp_split {
- my $self = shift;
- my($op, $cx) = @_;
- my($kid, @exprs, $ary, $expr);
- $kid = $op->first;
-
- # For our kid (an OP_PUSHRE), pmreplroot is never actually the
- # root of a replacement; it's either empty, or abused to point to
- # the GV for an array we split into (an optimization to save
- # assignment overhead). Depending on whether we're using ithreads,
- # this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
- # figures out for us which it is.
- my $replroot = $kid->pmreplroot;
- my $gv = 0;
- if (ref($replroot) eq "B::GV") {
- $gv = $replroot;
- } elsif (!ref($replroot) and $replroot > 0) {
- $gv = $self->padval($replroot);
- }
- $ary = $self->stash_variable('@', $self->gv_name($gv)) if $gv;
-
- for (; !null($kid); $kid = $kid->sibling) {
- push @exprs, $self->deparse($kid, 6);
- }
-
- # handle special case of split(), and split(' ') that compiles to /\s+/
- $kid = $op->first;
- if ( $kid->flags & OPf_SPECIAL
- and ( $] < 5.009 ? $kid->pmflags & PMf_SKIPWHITE()
- : $kid->reflags & RXf_SKIPWHITE() ) ) {
- $exprs[0] = "' '";
- }
-
- $expr = "split(" . join(", ", @exprs) . ")";
- if ($ary) {
- return $self->maybe_parens("$ary = $expr", $cx, 7);
- } else {
- return $expr;
- }
-}
-
-# oxime -- any of various compounds obtained chiefly by the action of
-# hydroxylamine on aldehydes and ketones and characterized by the
-# bivalent grouping C=NOH [Webster's Tenth]
-
-my %substwords;
-map($substwords{join "", sort split //, $_} = $_, 'ego', 'egoism', 'em',
- 'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
- 'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
- 'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
-
-sub pp_subst {
- my $self = shift;
- my($op, $cx) = @_;
- my $kid = $op->first;
- my($binop, $var, $re, $repl) = ("", "", "", "");
- if ($op->flags & OPf_STACKED) {
- $binop = 1;
- $var = $self->deparse($kid, 20);
- $kid = $kid->sibling;
- }
- my $flags = "";
- if (null($op->pmreplroot)) {
- $repl = $self->dq($kid);
- $kid = $kid->sibling;
- } else {
- $repl = $op->pmreplroot->first; # skip substcont
- while ($repl->name eq "entereval") {
- $repl = $repl->first;
- $flags .= "e";
- }
- if ($op->pmflags & PMf_EVAL) {
- $repl = $self->deparse($repl->first, 0);
- } else {
- $repl = $self->dq($repl);
- }
- }
- my $extended = ($op->pmflags & PMf_EXTENDED);
- if (null $kid) {
- my $unbacked = re_unback($op->precomp);
- if ($extended) {
- $re = re_uninterp_extended(escape_extended_re($unbacked));
- }
- else {
- $re = re_uninterp(escape_str($unbacked));
- }
- } else {
- ($re) = $self->regcomp($kid, 1, $extended);
- }
- $flags .= "e" if $op->pmflags & PMf_EVAL;
- $flags .= "g" if $op->pmflags & PMf_GLOBAL;
- $flags .= "i" if $op->pmflags & PMf_FOLD;
- $flags .= "m" if $op->pmflags & PMf_MULTILINE;
- $flags .= "o" if $op->pmflags & PMf_KEEP;
- $flags .= "s" if $op->pmflags & PMf_SINGLELINE;
- $flags .= "x" if $extended;
- $flags = $substwords{$flags} if $substwords{$flags};
- if ($binop) {
- return $self->maybe_parens("$var =~ s"
- . double_delim($re, $repl) . $flags,
- $cx, 20);
- } else {
- return "s". double_delim($re, $repl) . $flags;
- }
-}
-
-1;
-__END__
-
-=head1 NAME
-
-B::Deparse - Perl compiler backend to produce perl code
-
-=head1 SYNOPSIS
-
-B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
- [B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
-
-=head1 DESCRIPTION
-
-B::Deparse is a backend module for the Perl compiler that generates
-perl source code, based on the internal compiled structure that perl
-itself creates after parsing a program. The output of B::Deparse won't
-be exactly the same as the original source, since perl doesn't keep
-track of comments or whitespace, and there isn't a one-to-one
-correspondence between perl's syntactical constructions and their
-compiled form, but it will often be close. When you use the B<-p>
-option, the output also includes parentheses even when they are not
-required by precedence, which can make it easy to see if perl is
-parsing your expressions the way you intended.
-
-While B::Deparse goes to some lengths to try to figure out what your
-original program was doing, some parts of the language can still trip
-it up; it still fails even on some parts of Perl's own test suite. If
-you encounter a failure other than the most common ones described in
-the BUGS section below, you can help contribute to B::Deparse's
-ongoing development by submitting a bug report with a small
-example.
-
-=head1 OPTIONS
-
-As with all compiler backend options, these must follow directly after
-the '-MO=Deparse', separated by a comma but not any white space.
-
-=over 4
-
-=item B<-d>
-
-Output data values (when they appear as constants) using Data::Dumper.
-Without this option, B::Deparse will use some simple routines of its
-own for the same purpose. Currently, Data::Dumper is better for some
-kinds of data (such as complex structures with sharing and
-self-reference) while the built-in routines are better for others
-(such as odd floating-point values).
-
-=item B<-f>I<FILE>
-
-Normally, B::Deparse deparses the main code of a program, and all the subs
-defined in the same file. To include subs defined in other files, pass the
-B<-f> option with the filename. You can pass the B<-f> option several times, to
-include more than one secondary file. (Most of the time you don't want to
-use it at all.) You can also use this option to include subs which are
-defined in the scope of a B<#line> directive with two parameters.
-
-=item B<-l>
-
-Add '#line' declarations to the output based on the line and file
-locations of the original code.
-
-=item B<-p>
-
-Print extra parentheses. Without this option, B::Deparse includes
-parentheses in its output only when they are needed, based on the
-structure of your program. With B<-p>, it uses parentheses (almost)
-whenever they would be legal. This can be useful if you are used to
-LISP, or if you want to see how perl parses your input. If you say
-
- if ($var & 0x7f == 65) {print "Gimme an A!"}
- print ($which ? $a : $b), "\n";
- $name = $ENV{USER} or "Bob";
-
-C<B::Deparse,-p> will print
-
- if (($var & 0)) {
- print('Gimme an A!')
- };
- (print(($which ? $a : $b)), '???');
- (($name = $ENV{'USER'}) or '???')
-
-which probably isn't what you intended (the C<'???'> is a sign that
-perl optimized away a constant value).
-
-=item B<-P>
-
-Disable prototype checking. With this option, all function calls are
-deparsed as if no prototype was defined for them. In other words,
-
- perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
-
-will print
-
- sub foo (\@) {
- 1;
- }
- &foo(\@x);
-
-making clear how the parameters are actually passed to C<foo>.
-
-=item B<-q>
-
-Expand double-quoted strings into the corresponding combinations of
-concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
-instance, print
-
- print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
-
-as
-
- print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
- . ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
-
-Note that the expanded form represents the way perl handles such
-constructions internally -- this option actually turns off the reverse
-translation that B::Deparse usually does. On the other hand, note that
-C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
-of $y into a string before doing the assignment.
-
-=item B<-s>I<LETTERS>
-
-Tweak the style of B::Deparse's output. The letters should follow
-directly after the 's', with no space or punctuation. The following
-options are available:
-
-=over 4
-
-=item B<C>
-
-Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
-
- if (...) {
- ...
- } else {
- ...
- }
-
-instead of
-
- if (...) {
- ...
- }
- else {
- ...
- }
-
-The default is not to cuddle.
-
-=item B<i>I<NUMBER>
-
-Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
-
-=item B<T>
-
-Use tabs for each 8 columns of indent. The default is to use only spaces.
-For instance, if the style options are B<-si4T>, a line that's indented
-3 times will be preceded by one tab and four spaces; if the options were
-B<-si8T>, the same line would be preceded by three tabs.
-
-=item B<v>I<STRING>B<.>
-
-Print I<STRING> for the value of a constant that can't be determined
-because it was optimized away (mnemonic: this happens when a constant
-is used in B<v>oid context). The end of the string is marked by a period.
-The string should be a valid perl expression, generally a constant.
-Note that unless it's a number, it probably needs to be quoted, and on
-a command line quotes need to be protected from the shell. Some
-conventional values include 0, 1, 42, '', 'foo', and
-'Useless use of constant omitted' (which may need to be
-B<-sv"'Useless use of constant omitted'.">
-or something similar depending on your shell). The default is '???'.
-If you're using B::Deparse on a module or other file that's require'd,
-you shouldn't use a value that evaluates to false, since the customary
-true constant at the end of a module will be in void context when the
-file is compiled as a main program.
-
-=back
-
-=item B<-x>I<LEVEL>
-
-Expand conventional syntax constructions into equivalent ones that expose
-their internal operation. I<LEVEL> should be a digit, with higher values
-meaning more expansion. As with B<-q>, this actually involves turning off
-special cases in B::Deparse's normal operations.
-
-If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
-while loops with continue blocks; for instance
-
- for ($i = 0; $i < 10; ++$i) {
- print $i;
- }
-
-turns into
-
- $i = 0;
- while ($i < 10) {
- print $i;
- } continue {
- ++$i
- }
-
-Note that in a few cases this translation can't be perfectly carried back
-into the source code -- if the loop's initializer declares a my variable,
-for instance, it won't have the correct scope outside of the loop.
-
-If I<LEVEL> is at least 5, C<use> declarations will be translated into
-C<BEGIN> blocks containing calls to C<require> and C<import>; for
-instance,
-
- use strict 'refs';
-
-turns into
-
- sub BEGIN {
- require strict;
- do {
- 'strict'->import('refs')
- };
- }
-
-If I<LEVEL> is at least 7, C<if> statements will be translated into
-equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
-
- print 'hi' if $nice;
- if ($nice) {
- print 'hi';
- }
- if ($nice) {
- print 'hi';
- } else {
- print 'bye';
- }
-
-turns into
-
- $nice and print 'hi';
- $nice and do { print 'hi' };
- $nice ? do { print 'hi' } : do { print 'bye' };
-
-Long sequences of elsifs will turn into nested ternary operators, which
-B::Deparse doesn't know how to indent nicely.
-
-=back
-
-=head1 USING B::Deparse AS A MODULE
-
-=head2 Synopsis
-
- use B::Deparse;
- $deparse = B::Deparse->new("-p", "-sC");
- $body = $deparse->coderef2text(\&func);
- eval "sub func $body"; # the inverse operation
-
-=head2 Description
-
-B::Deparse can also be used on a sub-by-sub basis from other perl
-programs.
-
-=head2 new
-
- $deparse = B::Deparse->new(OPTIONS)
-
-Create an object to store the state of a deparsing operation and any
-options. The options are the same as those that can be given on the
-command line (see L</OPTIONS>); options that are separated by commas
-after B<-MO=Deparse> should be given as separate strings.
-
-=head2 ambient_pragmas
-
- $deparse->ambient_pragmas(strict => 'all', '$[' => $[);
-
-The compilation of a subroutine can be affected by a few compiler
-directives, B<pragmas>. These are:
-
-=over 4
-
-=item *
-
-use strict;
-
-=item *
-
-use warnings;
-
-=item *
-
-Assigning to the special variable $[
-
-=item *
-
-use integer;
-
-=item *
-
-use bytes;
-
-=item *
-
-use utf8;
-
-=item *
-
-use re;
-
-=back
-
-Ordinarily, if you use B::Deparse on a subroutine which has
-been compiled in the presence of one or more of these pragmas,
-the output will include statements to turn on the appropriate
-directives. So if you then compile the code returned by coderef2text,
-it will behave the same way as the subroutine which you deparsed.
-
-However, you may know that you intend to use the results in a
-particular context, where some pragmas are already in scope. In
-this case, you use the B<ambient_pragmas> method to describe the
-assumptions you wish to make.
-
-Not all of the options currently have any useful effect. See
-L</BUGS> for more details.
-
-The parameters it accepts are:
-
-=over 4
-
-=item strict
-
-Takes a string, possibly containing several values separated
-by whitespace. The special values "all" and "none" mean what you'd
-expect.
-
- $deparse->ambient_pragmas(strict => 'subs refs');
-
-=item $[
-
-Takes a number, the value of the array base $[.
-
-=item bytes
-
-=item utf8
-
-=item integer
-
-If the value is true, then the appropriate pragma is assumed to
-be in the ambient scope, otherwise not.
-
-=item re
-
-Takes a string, possibly containing a whitespace-separated list of
-values. The values "all" and "none" are special. It's also permissible
-to pass an array reference here.
-
- $deparser->ambient_pragmas(re => 'eval');
-
-
-=item warnings
-
-Takes a string, possibly containing a whitespace-separated list of
-values. The values "all" and "none" are special, again. It's also
-permissible to pass an array reference here.
-
- $deparser->ambient_pragmas(warnings => [qw[void io]]);
-
-If one of the values is the string "FATAL", then all the warnings
-in that list will be considered fatal, just as with the B<warnings>
-pragma itself. Should you need to specify that some warnings are
-fatal, and others are merely enabled, you can pass the B<warnings>
-parameter twice:
-
- $deparser->ambient_pragmas(
- warnings => 'all',
- warnings => [FATAL => qw/void io/],
- );
-
-See L<perllexwarn> for more information about lexical warnings.
-
-=item hint_bits
-
-=item warning_bits
-
-These two parameters are used to specify the ambient pragmas in
-the format used by the special variables $^H and ${^WARNING_BITS}.
-
-They exist principally so that you can write code like:
-
- { my ($hint_bits, $warning_bits);
- BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
- $deparser->ambient_pragmas (
- hint_bits => $hint_bits,
- warning_bits => $warning_bits,
- '$[' => 0 + $[
- ); }
-
-which specifies that the ambient pragmas are exactly those which
-are in scope at the point of calling.
-
-=item %^H
-
-This parameter is used to specify the ambient pragmas which are
-stored in the special hash %^H.
-
-=back
-
-=head2 coderef2text
-
- $body = $deparse->coderef2text(\&func)
- $body = $deparse->coderef2text(sub ($$) { ... })
-
-Return source code for the body of a subroutine (a block, optionally
-preceded by a prototype in parens), given a reference to the
-sub. Because a subroutine can have no names, or more than one name,
-this method doesn't return a complete subroutine definition -- if you
-want to eval the result, you should prepend "sub subname ", or "sub "
-for an anonymous function constructor. Unless the sub was defined in
-the main:: package, the code will include a package declaration.
-
-=head1 BUGS
-
-=over 4
-
-=item *
-
-The only pragmas to be completely supported are: C<use warnings>,
-C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
-behaves like a pragma, is also supported.)
-
-Excepting those listed above, we're currently unable to guarantee that
-B::Deparse will produce a pragma at the correct point in the program.
-(Specifically, pragmas at the beginning of a block often appear right
-before the start of the block instead.)
-Since the effects of pragmas are often lexically scoped, this can mean
-that the pragma holds sway over a different portion of the program
-than in the input file.
-
-=item *
-
-In fact, the above is a specific instance of a more general problem:
-we can't guarantee to produce BEGIN blocks or C<use> declarations in
-exactly the right place. So if you use a module which affects compilation
-(such as by over-riding keywords, overloading constants or whatever)
-then the output code might not work as intended.
-
-This is the most serious outstanding problem, and will require some help
-from the Perl core to fix.
-
-=item *
-
-If a keyword is over-ridden, and your program explicitly calls
-the built-in version by using CORE::keyword, the output of B::Deparse
-will not reflect this. If you run the resulting code, it will call
-the over-ridden version rather than the built-in one. (Maybe there
-should be an option to B<always> print keyword calls as C<CORE::name>.)
-
-=item *
-
-Some constants don't print correctly either with or without B<-d>.
-For instance, neither B::Deparse nor Data::Dumper know how to print
-dual-valued scalars correctly, as in:
-
- use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
-
- use constant H => { "#" => 1 }; H->{"#"};
-
-=item *
-
-An input file that uses source filtering probably won't be deparsed into
-runnable code, because it will still include the B<use> declaration
-for the source filtering module, even though the code that is
-produced is already ordinary Perl which shouldn't be filtered again.
-
-=item *
-
-Optimised away statements are rendered as '???'. This includes statements that
-have a compile-time side-effect, such as the obscure
-
- my $x if 0;
-
-which is not, consequently, deparsed correctly.
-
- foreach my $i (@_) { 0 }
- =>
- foreach my $i (@_) { '???' }
-
-=item *
-
-Lexical (my) variables declared in scopes external to a subroutine
-appear in code2ref output text as package variables. This is a tricky
-problem, as perl has no native facility for refering to a lexical variable
-defined within a different scope, although L<PadWalker> is a good start.
-
-=item *
-
-There are probably many more bugs on non-ASCII platforms (EBCDIC).
-
-=back
-
-=head1 AUTHOR
-
-Stephen McCamant <smcc at CSUA.Berkeley.EDU>, based on an earlier version
-by Malcolm Beattie <mbeattie at sable.ox.ac.uk>, with contributions from
-Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
-Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
-Garcia-Suarez.
-
-=cut
Deleted: trunk/contrib/perl/ext/B/B/Lint.pm
===================================================================
--- trunk/contrib/perl/ext/B/B/Lint.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/B/B/Lint.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,792 +0,0 @@
-package B::Lint;
-
-our $VERSION = '1.11'; ## no critic
-
-=head1 NAME
-
-B::Lint - Perl lint
-
-=head1 SYNOPSIS
-
-perl -MO=Lint[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-The B::Lint module is equivalent to an extended version of the B<-w>
-option of B<perl>. It is named after the program F<lint> which carries
-out a similar process for C programs.
-
-=head1 OPTIONS AND LINT CHECKS
-
-Option words are separated by commas (not whitespace) and follow the
-usual conventions of compiler backend options. Following any options
-(indicated by a leading B<->) come lint check arguments. Each such
-argument (apart from the special B<all> and B<none> options) is a
-word representing one possible lint check (turning on that check) or
-is B<no-foo> (turning off that check). Before processing the check
-arguments, a standard list of checks is turned on. Later options
-override earlier ones. Available options are:
-
-=over 8
-
-=item B<magic-diamond>
-
-Produces a warning whenever the magic C<E<lt>E<gt>> readline is
-used. Internally it uses perl's two-argument open which itself treats
-filenames with special characters specially. This could allow
-interestingly named files to have unexpected effects when reading.
-
- % touch 'rm *|'
- % perl -pe 1
-
-The above creates a file named C<rm *|>. When perl opens it with
-C<E<lt>E<gt>> it actually executes the shell program C<rm *>. This
-makes C<E<lt>E<gt>> dangerous to use carelessly.
-
-=item B<context>
-
-Produces a warning whenever an array is used in an implicit scalar
-context. For example, both of the lines
-
- $foo = length(@bar);
- $foo = @bar;
-
-will elicit a warning. Using an explicit B<scalar()> silences the
-warning. For example,
-
- $foo = scalar(@bar);
-
-=item B<implicit-read> and B<implicit-write>
-
-These options produce a warning whenever an operation implicitly
-reads or (respectively) writes to one of Perl's special variables.
-For example, B<implicit-read> will warn about these:
-
- /foo/;
-
-and B<implicit-write> will warn about these:
-
- s/foo/bar/;
-
-Both B<implicit-read> and B<implicit-write> warn about this:
-
- for (@a) { ... }
-
-=item B<bare-subs>
-
-This option warns whenever a bareword is implicitly quoted, but is also
-the name of a subroutine in the current package. Typical mistakes that it will
-trap are:
-
- use constant foo => 'bar';
- @a = ( foo => 1 );
- $b{foo} = 2;
-
-Neither of these will do what a naive user would expect.
-
-=item B<dollar-underscore>
-
-This option warns whenever C<$_> is used either explicitly anywhere or
-as the implicit argument of a B<print> statement.
-
-=item B<private-names>
-
-This option warns on each use of any variable, subroutine or
-method name that lives in a non-current package but begins with
-an underscore ("_"). Warnings aren't issued for the special case
-of the single character name "_" by itself (e.g. C<$_> and C<@_>).
-
-=item B<undefined-subs>
-
-This option warns whenever an undefined subroutine is invoked.
-This option will only catch explicitly invoked subroutines such
-as C<foo()> and not indirect invocations such as C<&$subref()>
-or C<$obj-E<gt>meth()>. Note that some programs or modules delay
-definition of subs until runtime by means of the AUTOLOAD
-mechanism.
-
-=item B<regexp-variables>
-
-This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
-is used. Any occurrence of any of these variables in your
-program can slow your whole program down. See L<perlre> for
-details.
-
-=item B<all>
-
-Turn all warnings on.
-
-=item B<none>
-
-Turn all warnings off.
-
-=back
-
-=head1 NON LINT-CHECK OPTIONS
-
-=over 8
-
-=item B<-u Package>
-
-Normally, Lint only checks the main code of the program together
-with all subs defined in package main. The B<-u> option lets you
-include other package names whose subs are then checked by Lint.
-
-=back
-
-=head1 EXTENDING LINT
-
-Lint can be extended by with plugins. Lint uses L<Module::Pluggable>
-to find available plugins. Plugins are expected but not required to
-inform Lint of which checks they are adding.
-
-The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
-adds the list of C<@new_checks> to the list of valid checks. If your
-module wasn't loaded by L<Module::Pluggable> then your class name is
-added to the list of plugins.
-
-You must create a C<match( \%checks )> method in your plugin class or one
-of its parents. It will be called on every op as a regular method call
-with a hash ref of checks as its parameter.
-
-The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
-the current filename and line number.
-
- package Sample;
- use B::Lint;
- B::Lint->register_plugin( Sample => [ 'good_taste' ] );
-
- sub match {
- my ( $op, $checks_href ) = shift @_;
- if ( $checks_href->{good_taste} ) {
- ...
- }
- }
-
-=head1 TODO
-
-=over
-
-=item while(<FH>) stomps $_
-
-=item strict oo
-
-=item unchecked system calls
-
-=item more tests, validate against older perls
-
-=back
-
-=head1 BUGS
-
-This is only a very preliminary version.
-
-=head1 AUTHOR
-
-Malcolm Beattie, mbeattie at sable.ox.ac.uk.
-
-=head1 ACKNOWLEDGEMENTS
-
-Sebastien Aperghis-Tramoni - bug fixes
-
-=cut
-
-use strict;
-use B qw( walkoptree_slow
- main_root main_cv walksymtable parents
- OPpOUR_INTRO
- OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED SVf_POK );
-use Carp 'carp';
-
-# The current M::P doesn't know about .pmc files.
-use Module::Pluggable ( require => 1 );
-
-use List::Util 'first';
-## no critic Prototypes
-sub any (&@) { my $test = shift @_; $test->() and return 1 for @_; return 0 }
-
-BEGIN {
-
- # Import or create some constants from B. B doesn't provide
- # everything I need so some things like OPpCONST_BARE are defined
- # here.
- for my $sym ( qw( begin_av check_av init_av end_av ),
- [ 'OPpCONST_BARE' => 64 ] )
- {
- my $val;
- ( $sym, $val ) = @$sym if ref $sym;
-
- if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) {
- B->import($sym);
- }
- else {
- require constant;
- constant->import( $sym => $val );
- }
- }
-}
-
-my $file = "unknown"; # shadows current filename
-my $line = 0; # shadows current line number
-my $curstash = "main"; # shadows current stash
-my $curcv; # shadows current B::CV for pad lookups
-
-sub file {$file}
-sub line {$line}
-sub curstash {$curstash}
-sub curcv {$curcv}
-
-# Lint checks
-my %check;
-my %implies_ok_context;
-
-map( $implies_ok_context{$_}++,
- qw(scalar av2arylen aelem aslice helem hslice
- keys values hslice defined undef delete) );
-
-# Lint checks turned on by default
-my @default_checks
- = qw(context magic_diamond undefined_subs regexp_variables);
-
-my %valid_check;
-
-# All valid checks
-for my $check (
- qw(context implicit_read implicit_write dollar_underscore
- private_names bare_subs undefined_subs regexp_variables
- magic_diamond )
- )
-{
- $valid_check{$check} = __PACKAGE__;
-}
-
-# Debugging options
-my ($debug_op);
-
-my %done_cv; # used to mark which subs have already been linted
-my @extra_packages; # Lint checks mainline code and all subs which are
- # in main:: or in one of these packages.
-
-sub warning {
- my $format = ( @_ < 2 ) ? "%s" : shift @_;
- warn sprintf( "$format at %s line %d\n", @_, $file, $line );
- return undef; ## no critic undef
-}
-
-# This gimme can't cope with context that's only determined
-# at runtime via dowantarray().
-sub gimme {
- my $op = shift @_;
- my $flags = $op->flags;
- if ( $flags & OPf_WANT ) {
- return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
- }
- return undef; ## no critic undef
-}
-
-my @plugins = __PACKAGE__->plugins;
-
-sub inside_grepmap {
-
- # A boolean function to be used while inside a B::walkoptree_slow
- # call. If we are in the EXPR part of C<grep EXPR, ...> or C<grep
- # { EXPR } ...>, this returns true.
- return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() };
-}
-
-sub inside_foreach_modifier {
-
- # TODO: use any()
-
- # A boolean function to be used while inside a B::walkoptree_slow
- # call. If we are in the EXPR part of C<EXPR foreach ...> this
- # returns true.
- for my $ancestor ( @{ parents() } ) {
- next unless $ancestor->name eq 'leaveloop';
-
- my $first = $ancestor->first;
- next unless $first->name eq 'enteriter';
-
- next if $first->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
-
- return 1;
- }
- return 0;
-}
-
-for (
- [qw[ B::PADOP::gv_harder gv padix]],
- [qw[ B::SVOP::sv_harder sv targ]],
- [qw[ B::SVOP::gv_harder gv padix]]
- )
-{
-
- # I'm generating some functions here because they're mostly
- # similar. It's all for compatibility with threaded
- # perl. Perhaps... this code should inspect $Config{usethreads}
- # and generate a *specific* function. I'm leaving it generic for
- # the moment.
- #
- # In threaded perl SVs and GVs aren't used directly in the optrees
- # like they are in non-threaded perls. The ops that would use a SV
- # or GV keep an index into the subroutine's scratchpad. I'm
- # currently ignoring $cv->DEPTH and that might be at my peril.
-
- my ( $subname, $attr, $pad_attr ) = @$_;
- my $target = do { ## no critic strict
- no strict 'refs';
- \*$subname;
- };
- *$target = sub {
- my ($op) = @_;
-
- my $elt;
- if ( not $op->isa('B::PADOP') ) {
- $elt = $op->$attr;
- }
- return $elt if eval { $elt->isa('B::SV') };
-
- my $ix = $op->$pad_attr;
- my @entire_pad = $curcv->PADLIST->ARRAY;
- my @elts = map +( $_->ARRAY )[$ix], @entire_pad;
- ($elt) = first {
- eval { $_->isa('B::SV') } ? $_ : ();
- }
- @elts[ 0, reverse 1 .. $#elts ];
- return $elt;
- };
-}
-
-sub B::OP::lint {
- my ($op) = @_;
-
- # This is a fallback ->lint for all the ops where I haven't
- # defined something more specific. Nothing happens here.
-
- # Call all registered plugins
- my $m;
- $m = $_->can('match'), $op->$m( \%check ) for @plugins;
- return;
-}
-
-sub B::COP::lint {
- my ($op) = @_;
-
- # nextstate ops sit between statements. Whenever I see one I
- # update the current info on file, line, and stash. This code also
- # updates it when it sees a dbstate or setstate op. I have no idea
- # what those are but having seen them mentioned together in other
- # parts of the perl I think they're kind of equivalent.
- if ( $op->name =~ m/\A(?:next|db|set)state\z/ ) {
- $file = $op->file;
- $line = $op->line;
- $curstash = $op->stash->NAME;
- }
-
- # Call all registered plugins
- my $m;
- $m = $_->can('match'), $op->$m( \%check ) for @plugins;
- return;
-}
-
-sub B::UNOP::lint {
- my ($op) = @_;
-
- my $opname = $op->name;
-
-CONTEXT: {
-
- # Check arrays and hashes in scalar or void context where
- # scalar() hasn't been used.
-
- next
- unless $check{context}
- and $opname =~ m/\Arv2[ah]v\z/xms
- and not gimme($op);
-
- my ( $parent, $gparent ) = @{ parents() }[ 0, 1 ];
- my $pname = $parent->name;
-
- next if $implies_ok_context{$pname};
-
- # Three special cases to deal with: "foreach (@foo)", "delete
- # $a{$b}", and "exists $a{$b}" null out the parent so we have to
- # check for a parent of pp_null and a grandparent of
- # pp_enteriter, pp_delete, pp_exists
-
- next
- if $pname eq "null"
- and $gparent->name =~ m/\A(?:delete|enteriter|exists)\z/xms;
-
- # our( @bar ); would also trigger this error so I exclude
- # that.
- next
- if $op->private & OPpOUR_INTRO
- and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
-
- warning 'Implicit scalar context for %s in %s',
- $opname eq "rv2av" ? "array" : "hash", $parent->desc;
- }
-
-PRIVATE_NAMES: {
-
- # Looks for calls to methods with names that begin with _ and
- # that aren't visible within the current package. Maybe this
- # should look at @ISA.
- next
- unless $check{private_names}
- and $opname =~ m/\Amethod/xms;
-
- my $methop = $op->first;
- next unless $methop->name eq "const";
-
- my $method = $methop->sv_harder->PV;
- next
- unless $method =~ m/\A_/xms
- and not defined &{"$curstash\::$method"};
-
- warning q[Illegal reference to private method name '%s'], $method;
- }
-
- # Call all registered plugins
- my $m;
- $m = $_->can('match'), $op->$m( \%check ) for @plugins;
- return;
-}
-
-sub B::PMOP::lint {
- my ($op) = @_;
-
-IMPLICIT_READ: {
-
- # Look for /.../ that doesn't use =~ to bind to something.
- next
- unless $check{implicit_read}
- and $op->name eq "match"
- and not( $op->flags & OPf_STACKED
- or inside_grepmap() );
- warning 'Implicit match on $_';
- }
-
-IMPLICIT_WRITE: {
-
- # Look for s/.../.../ that doesn't use =~ to bind to
- # something.
- next
- unless $check{implicit_write}
- and $op->name eq "subst"
- and not $op->flags & OPf_STACKED;
- warning 'Implicit substitution on $_';
- }
-
- # Call all registered plugins
- my $m;
- $m = $_->can('match'), $op->$m( \%check ) for @plugins;
- return;
-}
-
-sub B::LOOP::lint {
- my ($op) = @_;
-
-IMPLICIT_FOO: {
-
- # Look for C<for ( ... )>.
- next
- unless ( $check{implicit_read} or $check{implicit_write} )
- and $op->name eq "enteriter";
-
- my $last = $op->last;
- next
- unless $last->name eq "gv"
- and $last->gv_harder->NAME eq "_"
- and $op->redoop->name =~ m/\A(?:next|db|set)state\z/xms;
-
- warning 'Implicit use of $_ in foreach';
- }
-
- # Call all registered plugins
- my $m;
- $m = $_->can('match'), $op->$m( \%check ) for @plugins;
- return;
-}
-
-# In threaded vs non-threaded perls you'll find that threaded perls
-# use PADOP in place of SVOPs so they can do lookups into the
-# scratchpad to find things. I suppose this is so a optree can be
-# shared between threads and all symbol table muckery will just get
-# written to a scratchpad.
-*B::PADOP::lint = *B::PADOP::lint = \&B::SVOP::lint;
-
-sub B::SVOP::lint {
- my ($op) = @_;
-
-MAGIC_DIAMOND: {
- next
- unless $check{magic_diamond}
- and parents()->[0]->name eq 'readline'
- and $op->gv_harder->NAME eq 'ARGV';
-
- warning 'Use of <>';
- }
-
-BARE_SUBS: {
- next
- unless $check{bare_subs}
- and $op->name eq 'const'
- and $op->private & OPpCONST_BARE;
-
- my $sv = $op->sv_harder;
- next unless $sv->FLAGS & SVf_POK;
-
- my $sub = $sv->PV;
- my $subname = "$curstash\::$sub";
-
- # I want to skip over things that were declared with the
- # constant pragma. Well... sometimes. Hmm. I want to ignore
- # C<<use constant FOO => ...>> but warn on C<<FOO => ...>>
- # later. The former is typical declaration syntax and the
- # latter would be an error.
- #
- # Skipping over both could be handled by looking if
- # $constant::declared{$subname} is true.
-
- # Check that it's a function.
- next
- unless exists &{"$curstash\::$sub"};
-
- warning q[Bare sub name '%s' interpreted as string], $sub;
- }
-
-PRIVATE_NAMES: {
- next unless $check{private_names};
-
- my $opname = $op->name;
- if ( $opname =~ m/\Agv(?:sv)?\z/xms ) {
-
- # Looks for uses of variables and stuff that are named
- # private and we're not in the same package.
- my $gv = $op->gv_harder;
- my $name = $gv->NAME;
- next
- unless $name =~ m/\A_./xms
- and $gv->STASH->NAME ne $curstash;
-
- warning q[Illegal reference to private name '%s'], $name;
- }
- elsif ( $opname eq "method_named" ) {
- my $method = $op->sv_harder->PV;
- next unless $method =~ m/\A_./xms;
-
- warning q[Illegal reference to private method name '%s'], $method;
- }
- }
-
-DOLLAR_UNDERSCORE: {
-
- # Warn on uses of $_ with a few exceptions. I'm not warning on
- # $_ inside grep, map, or statement modifer foreach because
- # they localize $_ and it'd be impossible to use these
- # features without getting warnings.
-
- next
- unless $check{dollar_underscore}
- and $op->name eq "gvsv"
- and $op->gv_harder->NAME eq "_"
- and not( inside_grepmap
- or inside_foreach_modifier );
-
- warning 'Use of $_';
- }
-
-REGEXP_VARIABLES: {
-
- # Look for any uses of $`, $&, or $'.
- next
- unless $check{regexp_variables}
- and $op->name eq "gvsv";
-
- my $name = $op->gv_harder->NAME;
- next unless $name =~ m/\A[\&\'\`]\z/xms;
-
- warning 'Use of regexp variable $%s', $name;
- }
-
-UNDEFINED_SUBS: {
-
- # Look for calls to functions that either don't exist or don't
- # have a definition.
- next
- unless $check{undefined_subs}
- and $op->name eq "gv"
- and $op->next->name eq "entersub";
-
- my $gv = $op->gv_harder;
- my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
-
- no strict 'refs'; ## no critic strict
- if ( not exists &$subname ) {
- $subname =~ s/\Amain:://;
- warning q[Nonexistant subroutine '%s' called], $subname;
- }
- elsif ( not defined &$subname ) {
- $subname =~ s/\A\&?main:://;
- warning q[Undefined subroutine '%s' called], $subname;
- }
- }
-
- # Call all registered plugins
- my $m;
- $m = $_->can('match'), $op->$m( \%check ) for @plugins;
- return;
-}
-
-sub B::GV::lintcv {
-
- # Example: B::svref_2object( \ *A::Glob )->lintcv
-
- my $gv = shift @_;
- my $cv = $gv->CV;
- return unless $cv->can('lintcv');
- $cv->lintcv;
- return;
-}
-
-sub B::CV::lintcv {
-
- # Example: B::svref_2object( \ &foo )->lintcv
-
- # Write to the *global* $
- $curcv = shift @_;
-
- #warn sprintf("lintcv: %s::%s (done=%d)\n",
- # $gv->STASH->NAME, $gv->NAME, $done_cv{$$curcv});#debug
- return unless ref($curcv) and $$curcv and not $done_cv{$$curcv}++;
- my $root = $curcv->ROOT;
-
- #warn " root = $root (0x$$root)\n";#debug
- walkoptree_slow( $root, "lint" ) if $$root;
- return;
-}
-
-sub do_lint {
- my %search_pack;
-
- # Copy to the global $curcv for use in pad lookups.
- $curcv = main_cv;
- walkoptree_slow( main_root, "lint" ) if ${ main_root() };
-
- # Do all the miscellaneous non-sub blocks.
- for my $av ( begin_av, init_av, check_av, end_av ) {
- next unless eval { $av->isa('B::AV') };
- for my $cv ( $av->ARRAY ) {
- next unless ref($cv) and $cv->FILE eq $0;
- $cv->lintcv;
- }
- }
-
- walksymtable(
- \%main::,
- sub {
- if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
- },
- sub {1}
- );
- return;
-}
-
-sub compile {
- my @options = @_;
-
- # Turn on default lint checks
- for my $opt (@default_checks) {
- $check{$opt} = 1;
- }
-
-OPTION:
- while ( my $option = shift @options ) {
- my ( $opt, $arg );
- unless ( ( $opt, $arg ) = $option =~ m/\A-(.)(.*)/xms ) {
- unshift @options, $option;
- last OPTION;
- }
-
- if ( $opt eq "-" && $arg eq "-" ) {
- shift @options;
- last OPTION;
- }
- elsif ( $opt eq "D" ) {
- $arg ||= shift @options;
- foreach my $arg ( split //, $arg ) {
- if ( $arg eq "o" ) {
- B->debug(1);
- }
- elsif ( $arg eq "O" ) {
- $debug_op = 1;
- }
- }
- }
- elsif ( $opt eq "u" ) {
- $arg ||= shift @options;
- push @extra_packages, $arg;
- }
- }
-
- foreach my $opt ( @default_checks, @options ) {
- $opt =~ tr/-/_/;
- if ( $opt eq "all" ) {
- %check = %valid_check;
- }
- elsif ( $opt eq "none" ) {
- %check = ();
- }
- else {
- if ( $opt =~ s/\Ano_//xms ) {
- $check{$opt} = 0;
- }
- else {
- $check{$opt} = 1;
- }
- carp "No such check: $opt"
- unless defined $valid_check{$opt};
- }
- }
-
- # Remaining arguments are things to check. So why aren't I
- # capturing them or something? I don't know.
-
- return \&do_lint;
-}
-
-sub register_plugin {
- my ( undef, $plugin, $new_checks ) = @_;
-
- # Allow the user to be lazy and not give us a name.
- $plugin = caller unless defined $plugin;
-
- # Register the plugin's named checks, if any.
- for my $check ( eval {@$new_checks} ) {
- if ( not defined $check ) {
- carp 'Undefined value in checks.';
- next;
- }
- if ( exists $valid_check{$check} ) {
- carp
- "$check is already registered as a $valid_check{$check} feature.";
- next;
- }
-
- $valid_check{$check} = $plugin;
- }
-
- # Register a non-Module::Pluggable loaded module. @plugins already
- # contains whatever M::P found on disk. The user might load a
- # plugin manually from some arbitrary namespace and ask for it to
- # be registered.
- if ( not any { $_ eq $plugin } @plugins ) {
- push @plugins, $plugin;
- }
-
- return;
-}
-
-1;
Deleted: trunk/contrib/perl/ext/B/defsubs_h.PL
===================================================================
--- trunk/contrib/perl/ext/B/defsubs_h.PL 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/B/defsubs_h.PL 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,98 +0,0 @@
-# Do not remove the following line; MakeMaker relies on it to identify
-# this file as a template for defsubs.h
-# Extracting defsubs.h (with variable substitutions)
-#!perl -w
-use File::Spec;
-my (undef, $headerpath) = @ARGV;
-my ($out) = __FILE__ =~ /(^.*)\.PL/i;
-$out =~ s/_h$/.h/;
-unlink $out if -l $out;
-open(OUT,">$out") || die "Cannot open $file:$!";
-print "Extracting $out...\n";
-print OUT <<"END";
-/*
- !!! Don't modify this file - it's autogenerated from $0 !!!
- */
-END
-
-foreach my $const (qw(
- CVf_ANON
- CVf_CLONE
- CVf_CLONED
- CVf_CONST
- CVf_LOCKED
- CVf_LVALUE
- CVf_METHOD
- CVf_NODEBUG
- CVf_UNIQUE
- CVf_WEAKOUTSIDE
- GVf_IMPORTED_AV
- GVf_IMPORTED_CV
- GVf_IMPORTED_HV
- GVf_IMPORTED_SV
- HEf_SVKEY
- SVTYPEMASK
- SVf_FAKE
- SVf_IOK
- SVf_IVisUV
- SVf_NOK
- SVf_POK
- SVf_READONLY
- SVf_ROK
- SVp_IOK
- SVp_NOK
- SVp_POK
- SVpad_OUR
- SVs_RMG
- SVs_SMG
- SVt_PVGV
- SVt_PVHV
- PAD_FAKELEX_ANON
- PAD_FAKELEX_MULTI
- ))
- {
- doconst($const);
- }
-
-if ($] < 5.009) {
- # This is only present in 5.10, but it's useful to B::Deparse to be able
- # to import a dummy value from B
- doconst(OPpPAD_STATE);
-}
-
-if ($] >= 5.009) {
- # Constant not present in 5.8.x
- doconst(CVf_ISXSUB);
-} else {
- # Constant not present after 5.8.x
- doconst(AVf_REAL);
-}
-
-if ($] < 5.011) {
- # Constant not present after 5.10.x
- doconst(CVf_LOCKED);
-}
-
-foreach my $tuple (['op.h'],['cop.h'],['regexp.h','RXf_'])
- {
- my $file = $tuple->[0];
- my $pfx = $tuple->[1] || '';
- my $path = File::Spec->catfile($headerpath, $file);
- open(OPH,"$path") || die "Cannot open $path:$!";
- while (<OPH>)
- {
- doconst($1) if (/#define\s+($pfx\w+)\s+([\(\)\|\dx]+)\s*(?:$|\/\*)/);
- }
- close(OPH);
- }
-close(OUT);
-
-sub doconst
-{
- my $sym = shift;
- my $l = length($sym);
- print OUT <<"END";
- newCONSTSUB(stash,"$sym",newSViv($sym));
- av_push(export_ok,newSVpvn("$sym",$l));
-END
-}
Deleted: trunk/contrib/perl/ext/B/t/debug.t
===================================================================
--- trunk/contrib/perl/ext/B/t/debug.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/B/t/debug.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,90 +0,0 @@
-#!./perl
-
-BEGIN {
- delete $ENV{PERL_DL_NONLAZY} if $] < 5.005_58; #Perl_byterun problem
- if ($ENV{PERL_CORE}){
- chdir('t') if -d 't';
- if ($^O eq 'MacOS') {
- @INC = qw(: ::lib ::macos:lib);
- } else {
- @INC = '.';
- push @INC, '../lib';
- }
- } else {
- unshift @INC, 't';
- }
- require Config;
- if (($Config::Config{'extensions'} !~ /\bB\b/) ){
- print "1..0 # Skip -- Perl configured without B module\n";
- exit 0;
- }
-}
-
-$| = 1;
-use warnings;
-use strict;
-use Config;
-use Test::More tests => 8;
-use B;
-use B::Debug;
-
-my $a;
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-my $path = join " ", map { qq["-I$_"] } @INC;
-my $redir = $Is_MacOS ? "" : "2>&1";
-
-$a = `$^X $path "-MO=Debug" -e 1 $redir`;
-like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s);
-
-
-$a = `$^X $path "-MO=Terse" -e 1 $redir`;
-like($a, qr/\bLISTOP\b.*leave.*\n OP\b.*enter.*\n COP\b.*nextstate.*\n OP\b.*null/s);
-
-$a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
-$a =~ s/\(0x[^)]+\)//g;
-$a =~ s/\[[^\]]+\]//g;
-$a =~ s/-e syntax OK//;
-$a =~ s/[^a-z ]+//g;
-$a =~ s/\s+/ /g;
-$a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
-$a =~ s/^\s+//;
-$a =~ s/\s+$//;
-$a =~ s/\s+nextstate$//; # if $] < 5.008001; # 5.8.0 adds it. 5.8.8 not anymore
-my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
-if ($is_thread) {
- $b=<<EOF;
-leave enter nextstate label leaveloop enterloop null and defined null
-threadsv readline gv lineseq nextstate aassign null pushmark split pushre
-threadsv const null pushmark rvav gv nextstate subst const unstack
-EOF
-} else {
- $b=<<EOF;
-leave enter nextstate label leaveloop enterloop null and defined null null
-gvsv readline gv lineseq nextstate aassign null pushmark split pushre null
-gvsv const null pushmark rvav gv nextstate subst const unstack
-EOF
-}
-#$b .= " nextstate" if $] < 5.008001; # ??
-$b=~s/\n/ /g;$b=~s/\s+/ /g;
-$b =~ s/\s+$//;
-is($a, $b);
-
-like(B::Debug::_printop(B::main_root), qr/LISTOP\s+\[OP_LEAVE\]/);
-like(B::Debug::_printop(B::main_start), qr/OP\s+\[OP_ENTER\]/);
-
-$a = `$^X $path "-MO=Debug" -e "B::main_root->debug" $redir`;
-like($a, qr/op_next\s+0x0/m);
-$a = `$^X $path "-MO=Debug" -e "B::main_start->debug" $redir`;
-like($a, qr/PL_ppaddr\[OP_ENTER\]/m);
-
-# pass missing FETCHSIZE, fixed with 1.06
-my $tmp = "tmp.pl";
-open TMP, "> $tmp";
-print TMP 'BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};
-print $a[1]';
-close TMP;
-$a = `$^X $path "-MO=Debug" $tmp $redir`;
-unlink $tmp;
-unlike($a, qr/locate object method "FETCHSIZE"/m);
Deleted: trunk/contrib/perl/ext/B/t/deparse.t
===================================================================
--- trunk/contrib/perl/ext/B/t/deparse.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/B/t/deparse.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,527 +0,0 @@
-#!./perl
-
-BEGIN {
- if ($ENV{PERL_CORE}){
- chdir('t') if -d 't';
- if ($^O eq 'MacOS') {
- @INC = qw(: ::lib ::macos:lib);
- } else {
- @INC = '.';
- push @INC, '../lib';
- }
- } else {
- unshift @INC, 't';
- }
- require Config;
- if (($Config::Config{'extensions'} !~ /\bB\b/) ){
- print "1..0 # Skip -- Perl configured without B module\n";
- exit 0;
- }
-}
-
-use warnings;
-use strict;
-BEGIN {
- # BEGIN block is acutally a subroutine :-)
- return unless $] > 5.009;
- require feature;
- feature->import(':5.10');
-}
-use Test::More tests => 70;
-use Config ();
-
-use B::Deparse;
-my $deparse = B::Deparse->new();
-ok($deparse);
-
-# Tell B::Deparse about our ambient pragmas
-{ my ($hint_bits, $warning_bits, $hinthash);
- BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); }
- $deparse->ambient_pragmas (
- hint_bits => $hint_bits,
- warning_bits => $warning_bits,
- '$[' => 0 + $[,
- '%^H' => $hinthash,
- );
-}
-
-$/ = "\n####\n";
-while (<DATA>) {
- chomp;
- # This code is pinched from the t/lib/common.pl for TODO.
- # It's not clear how to avoid duplication
- # Now tweaked a bit to do skip or todo
- my %reason;
- foreach my $what (qw(skip todo)) {
- s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1;
- # If the SKIP reason starts ? then it's taken as a code snippet to
- # evaluate. This provides the flexibility to have conditional SKIPs
- if ($reason{$what} && $reason{$what} =~ s/^\?//) {
- my $temp = eval $reason{$what};
- if ($@) {
- die "# In \U$what\E code reason:\n# $reason{$what}\n$@";
- }
- $reason{$what} = $temp;
- }
- }
-
- s/^\s*#\s*(.*)$//mg;
- my ($num, $testname) = $1 =~ m/(\d+)\s*(.*)/;
-
- if ($reason{skip}) {
- # Like this to avoid needing a label SKIP:
- Test::More->builder->skip($reason{skip});
- next;
- }
-
- my ($input, $expected);
- if (/(.*)\n>>>>\n(.*)/s) {
- ($input, $expected) = ($1, $2);
- }
- else {
- ($input, $expected) = ($_, $_);
- }
-
- my $coderef = eval "sub {$input}";
-
- if ($@) {
- diag("$num deparsed: $@");
- ok(0, $testname);
- }
- else {
- my $deparsed = $deparse->coderef2text( $coderef );
- my $regex = $expected;
- $regex =~ s/(\S+)/\Q$1/g;
- $regex =~ s/\s+/\\s+/g;
- $regex = '^\{\s*' . $regex . '\s*\}$';
-
- local $::TODO = $reason{todo};
- like($deparsed, qr/$regex/, $testname);
- }
-}
-
-use constant 'c', 'stuff';
-is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff');
-
-my $a = 0;
-is("{\n (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a }));
-
-use constant cr => ['hello'];
-my $string = "sub " . $deparse->coderef2text(\&cr);
-my $val = (eval $string)->() or diag $string;
-is(ref($val), 'ARRAY');
-is($val->[0], 'hello');
-
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-my $path = join " ", map { qq["-I$_"] } @INC;
-$path .= " -MMac::err=unix" if $Is_MacOS;
-my $redir = $Is_MacOS ? "" : "2>&1";
-
-$a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
-$a =~ s/-e syntax OK\n//g;
-$a =~ s/.*possible typo.*\n//; # Remove warning line
-$a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
-$a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
-$b = <<'EOF';
-BEGIN { $^I = ".bak"; }
-BEGIN { $^W = 1; }
-BEGIN { $/ = "\n"; $\ = "\n"; }
-LINE: while (defined($_ = <ARGV>)) {
- chomp $_;
- our(@F) = split(' ', $_, 0);
- '???';
-}
-EOF
-$b =~ s/(LINE:)/sub BEGIN {
- 'MacPerl'->bootstrap;
- 'OSA'->bootstrap;
- 'XL'->bootstrap;
-}
-$1/ if $Is_MacOS;
-is($a, $b);
-
-#Re: perlbug #35857, patch #24505
-#handle warnings::register-ed packages properly.
-package B::Deparse::Wrapper;
-use strict;
-use warnings;
-use warnings::register;
-sub getcode {
- my $deparser = B::Deparse->new();
- return $deparser->coderef2text(shift);
-}
-
-package Moo;
-use overload '0+' => sub { 42 };
-
-package main;
-use strict;
-use warnings;
-use constant GLIPP => 'glipp';
-use constant PI => 4;
-use constant OVERLOADED_NUMIFICATION => bless({}, 'Moo');
-use Fcntl qw/O_TRUNC O_APPEND O_EXCL/;
-BEGIN { delete $::Fcntl::{O_APPEND}; }
-use POSIX qw/O_CREAT/;
-sub test {
- my $val = shift;
- my $res = B::Deparse::Wrapper::getcode($val);
- like( $res, qr/use warnings/);
-}
-my ($q,$p);
-my $x=sub { ++$q,++$p };
-test($x);
-eval <<EOFCODE and test($x);
- package bar;
- use strict;
- use warnings;
- use warnings::register;
- package main;
- 1
-EOFCODE
-
-__DATA__
-# 2
-1;
-####
-# 3
-{
- no warnings;
- '???';
- 2;
-}
-####
-# 4
-my $test;
-++$test and $test /= 2;
->>>>
-my $test;
-$test /= 2 if ++$test;
-####
-# 5
--((1, 2) x 2);
-####
-# 6
-{
- my $test = sub : lvalue {
- my $x;
- }
- ;
-}
-####
-# 7
-{
- my $test = sub : method {
- my $x;
- }
- ;
-}
-####
-# 8
-{
- my $test = sub : locked method {
- my $x;
- }
- ;
-}
-####
-# 9
-{
- 234;
-}
-continue {
- 123;
-}
-####
-# 10
-my $x;
-print $main::x;
-####
-# 11
-my @x;
-print $main::x[1];
-####
-# 12
-my %x;
-$x{warn()};
-####
-# 13
-my $foo;
-$_ .= <ARGV> . <$foo>;
-####
-# 14
-my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
-####
-# 15
-s/x/'y';/e;
-####
-# 16 - various lypes of loop
-{ my $x; }
-####
-# 17
-while (1) { my $k; }
-####
-# 18
-my ($x, at a);
-$x=1 for @a;
->>>>
-my($x, @a);
-$x = 1 foreach (@a);
-####
-# 19
-for (my $i = 0; $i < 2;) {
- my $z = 1;
-}
-####
-# 20
-for (my $i = 0; $i < 2; ++$i) {
- my $z = 1;
-}
-####
-# 21
-for (my $i = 0; $i < 2; ++$i) {
- my $z = 1;
-}
-####
-# 22
-my $i;
-while ($i) { my $z = 1; } continue { $i = 99; }
-####
-# 23
-foreach my $i (1, 2) {
- my $z = 1;
-}
-####
-# 24
-my $i;
-foreach $i (1, 2) {
- my $z = 1;
-}
-####
-# 25
-my $i;
-foreach my $i (1, 2) {
- my $z = 1;
-}
-####
-# 26
-foreach my $i (1, 2) {
- my $z = 1;
-}
-####
-# 27
-foreach our $i (1, 2) {
- my $z = 1;
-}
-####
-# 28
-my $i;
-foreach our $i (1, 2) {
- my $z = 1;
-}
-####
-# 29
-my @x;
-print reverse sort(@x);
-####
-# 30
-my @x;
-print((sort {$b cmp $a} @x));
-####
-# 31
-my @x;
-print((reverse sort {$b <=> $a} @x));
-####
-# 32
-our @a;
-print $_ foreach (reverse @a);
-####
-# 33
-our @a;
-print $_ foreach (reverse 1, 2..5);
-####
-# 34 (bug #38684)
-our @ary;
- at ary = split(' ', 'foo', 0);
-####
-# 35 (bug #40055)
-do { () };
-####
-# 36 (ibid.)
-do { my $x = 1; $x };
-####
-# 37 <20061012113037.GJ25805 at c4.convolution.nl>
-my $f = sub {
- +{[]};
-} ;
-####
-# 38 (bug #43010)
-'!@$%'->();
-####
-# 39 (ibid.)
-::();
-####
-# 40 (ibid.)
-'::::'->();
-####
-# 41 (ibid.)
-&::::;
-####
-# 42
-my $bar;
-'Foo'->$bar('orz');
-####
-# 43
-'Foo'->bar('orz');
-####
-# 44
-'Foo'->bar;
-####
-# SKIP ?$] < 5.010 && "say not implemented on this Perl version"
-# 45 say
-say 'foo';
-####
-# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
-# 46 state vars
-state $x = 42;
-####
-# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
-# 47 state var assignment
-{
- my $y = (state $x = 42);
-}
-####
-# SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
-# 48 state vars in anoymous subroutines
-$a = sub {
- state $x;
- return $x++;
-}
-;
-####
-# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
-# 49 each @array;
-each @ARGV;
-each @$a;
-####
-# SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
-# 50 keys @array; values @array
-keys @$a if keys @ARGV;
-values @ARGV if values @$a;
-####
-# 51 Anonymous arrays and hashes, and references to them
-my $a = {};
-my $b = \{};
-my $c = [];
-my $d = \[];
-####
-# SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
-# 52 implicit smartmatch in given/when
-given ('foo') {
- when ('bar') { continue; }
- when ($_ ~~ 'quux') { continue; }
- default { 0; }
-}
-####
-# 53 conditions in elsifs (regression in change #33710 which fixed bug #37302)
-if ($a) { x(); }
-elsif ($b) { x(); }
-elsif ($a and $b) { x(); }
-elsif ($a or $b) { x(); }
-else { x(); }
-####
-# 54 interpolation in regexps
-my($y, $t);
-/x${y}z$t/;
-####
-# TODO new undocumented cpan-bug #33708
-# 55 (cpan-bug #33708)
-%{$_ || {}}
-####
-# TODO hash constants not yet fixed
-# 56 (cpan-bug #33708)
-use constant H => { "#" => 1 }; H->{"#"}
-####
-# TODO optimized away 0 not yet fixed
-# 57 (cpan-bug #33708)
-foreach my $i (@_) { 0 }
-####
-# 58 placeholder for skipped edbe35ea95
-1;
-####
-# 59 placeholder for skipped edbe35ea95
-1;
-####
-# 60 tests that should be constant folded
-x() if 1;
-x() if GLIPP;
-x() if !GLIPP;
-x() if GLIPP && GLIPP;
-x() if !GLIPP || GLIPP;
-x() if do { GLIPP };
-x() if do { no warnings 'void'; 5; GLIPP };
-x() if do { !GLIPP };
-if (GLIPP) { x() } else { z() }
-if (!GLIPP) { x() } else { z() }
-if (GLIPP) { x() } elsif (GLIPP) { z() }
-if (!GLIPP) { x() } elsif (GLIPP) { z() }
-if (GLIPP) { x() } elsif (!GLIPP) { z() }
-if (!GLIPP) { x() } elsif (!GLIPP) { z() }
-if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (GLIPP) { t() }
-if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
-if (!GLIPP) { x() } elsif (!GLIPP) { z() } elsif (!GLIPP) { t() }
->>>>
-x();
-x();
-'???';
-x();
-x();
-x();
-x();
-do {
- '???'
-};
-do {
- x()
-};
-do {
- z()
-};
-do {
- x()
-};
-do {
- z()
-};
-do {
- x()
-};
-'???';
-do {
- t()
-};
-'???';
-!1;
-####
-# TODO Only strict 'refs' currently supported
-# 68 strict
-no strict;
-$x;
-####
-# TODO Subsets of warnings could be encoded textually, rather than as bitflips.
-no warnings 'deprecated';
-my $x;
-####
-# TODO Better test for CPAN #33708 - the deparsed code has different behaviour
-use strict;
-no warnings;
-
-foreach (0..3) {
- my $x = 2;
- {
- my $x if 0;
- print ++$x, "\n";
- }
-}
Deleted: trunk/contrib/perl/ext/B/t/lint.t
===================================================================
--- trunk/contrib/perl/ext/B/t/lint.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/B/t/lint.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,151 +0,0 @@
-#!./perl -w
-
-BEGIN {
- if ( $ENV{PERL_CORE} ) {
- chdir('t') if -d 't';
- @INC = ( '.', '../lib' );
- }
- else {
- unshift @INC, 't';
- push @INC, "../../t";
- }
- require Config;
- if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) {
- print "1..0 # Skip -- Perl configured without B module\n";
- exit 0;
- }
- require 'test.pl';
-}
-use strict;
-use warnings;
-
-plan tests => 29;
-
-# Runs a separate perl interpreter with the appropriate lint options
-# turned on
-sub runlint ($$$;$) {
- my ( $opts, $prog, $result, $testname ) = @_;
- my $res = runperl(
- switches => ["-MO=Lint,$opts"],
- prog => $prog,
- stderr => 1,
- );
- $res =~ s/-e syntax OK\n$//;
- local $::Level = $::Level + 1;
- is( $res, $result, $testname || $opts );
-}
-
-runlint 'magic-diamond', 'while(<>){}', <<'RESULT';
-Use of <> at -e line 1
-RESULT
-
-runlint 'magic-diamond', 'while(<ARGV>){}', <<'RESULT';
-Use of <> at -e line 1
-RESULT
-
-runlint 'magic-diamond', 'while(<FOO>){}', <<'RESULT';
-RESULT
-
-runlint 'context', '$foo = @bar', <<'RESULT';
-Implicit scalar context for array in scalar assignment at -e line 1
-RESULT
-
-runlint 'context', '$foo = length @bar', <<'RESULT';
-Implicit scalar context for array in length at -e line 1
-RESULT
-
-runlint 'context', 'our @bar', '';
-
-runlint 'context', 'exists $BAR{BAZ}', '';
-
-runlint 'implicit-read', '/foo/', <<'RESULT';
-Implicit match on $_ at -e line 1
-RESULT
-
-runlint 'implicit-read', 'grep /foo/, ()', '';
-
-runlint 'implicit-read', 'grep { /foo/ } ()', '';
-
-runlint 'implicit-write', 's/foo/bar/', <<'RESULT';
-Implicit substitution on $_ at -e line 1
-RESULT
-
-runlint 'implicit-read', 'for ( @ARGV ) { 1 }',
- <<'RESULT', 'implicit-read in foreach';
-Implicit use of $_ in foreach at -e line 1
-RESULT
-
-runlint 'implicit-read', '1 for @ARGV', '', 'implicit-read in foreach';
-
-runlint 'dollar-underscore', '$_ = 1', <<'RESULT';
-Use of $_ at -e line 1
-RESULT
-
-runlint 'dollar-underscore', 'sub foo {}; foo( $_ ) for @A', '';
-runlint 'dollar-underscore', 'sub foo {}; map { foo( $_ ) } @A', '';
-runlint 'dollar-underscore', 'sub foo {}; grep { foo( $_ ) } @A', '';
-
-runlint 'dollar-underscore', 'print',
- <<'RESULT', 'dollar-underscore in print';
-Use of $_ at -e line 1
-RESULT
-
-runlint 'private-names', 'sub A::_f{};A::_f()', <<'RESULT';
-Illegal reference to private name '_f' at -e line 1
-RESULT
-
-runlint 'private-names', '$A::_x', <<'RESULT';
-Illegal reference to private name '_x' at -e line 1
-RESULT
-
-runlint 'private-names', 'sub A::_f{};A->_f()', <<'RESULT',
-Illegal reference to private method name '_f' at -e line 1
-RESULT
- 'private-names (method)';
-
-runlint 'undefined-subs', 'foo()', <<'RESULT';
-Nonexistant subroutine 'foo' called at -e line 1
-RESULT
-
-runlint 'undefined-subs', 'foo();sub foo;', <<'RESULT';
-Undefined subroutine 'foo' called at -e line 1
-RESULT
-
-runlint 'regexp-variables', 'print $&', <<'RESULT';
-Use of regexp variable $& at -e line 1
-RESULT
-
-runlint 'regexp-variables', 's/./$&/', <<'RESULT';
-Use of regexp variable $& at -e line 1
-RESULT
-
-runlint 'bare-subs', 'sub bare(){1};$x=bare', '';
-
-runlint 'bare-subs', 'sub bare(){1}; $x=[bare=>0]; $x=$y{bare}', <<'RESULT';
-Bare sub name 'bare' interpreted as string at -e line 1
-Bare sub name 'bare' interpreted as string at -e line 1
-RESULT
-
-{
-
- # Check for backwards-compatible plugin support. This was where
- # preloaded mdoules would register themselves with B::Lint.
- my $res = runperl(
- switches => ["-MB::Lint"],
- prog =>
- 'BEGIN{B::Lint->register_plugin(X=>[q[x]])};use O(qw[Lint x]);sub X::match{warn qq[X ok.\n]};dummy()',
- stderr => 1,
- );
- like( $res, qr/X ok\./, 'Lint legacy plugin' );
-}
-
-{
-
- # Check for Module::Plugin support
- my $res = runperl(
- switches => [ '-I../ext/B/t/pluglib', '-MO=Lint,none' ],
- prog => 1,
- stderr => 1,
- );
- like( $res, qr/Module::Pluggable ok\./, 'Lint uses Module::Pluggable' );
-}
Deleted: trunk/contrib/perl/ext/DynaLoader/XSLoader_pm.PL
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/XSLoader_pm.PL 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/DynaLoader/XSLoader_pm.PL 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,407 +0,0 @@
-use strict;
-use Config;
-
-sub to_string {
- my ($value) = @_;
- $value =~ s/\\/\\\\/g;
- $value =~ s/'/\\'/g;
- return "'$value'";
-}
-
-1 while unlink "XSLoader.pm";
-open OUT, ">XSLoader.pm" or die $!;
-print OUT <<'EOT';
-# Generated from XSLoader.pm.PL (resolved %Config::Config value)
-
-package XSLoader;
-
-$VERSION = "0.10";
-
-#use strict;
-
-# enable debug/trace messages from DynaLoader perl code
-# $dl_debug = $ENV{PERL_DL_DEBUG} || 0 unless defined $dl_debug;
-
-EOT
-
-print OUT ' my $dl_dlext = ', to_string($Config::Config{'dlext'}), ";\n" ;
-
-print OUT <<'EOT';
-
-package DynaLoader;
-
-# No prizes for guessing why we don't say 'bootstrap DynaLoader;' here.
-# NOTE: All dl_*.xs (including dl_none.xs) define a dl_error() XSUB
-boot_DynaLoader('DynaLoader') if defined(&boot_DynaLoader) &&
- !defined(&dl_error);
-package XSLoader;
-
-sub load {
- package DynaLoader;
-
- die q{XSLoader::load('Your::Module', $Your::Module::VERSION)} unless @_;
-
- my($module) = $_[0];
-
- # work with static linking too
- my $boots = "$module\::bootstrap";
- goto &$boots if defined &$boots;
-
- goto retry unless $module and defined &dl_load_file;
-
- my @modparts = split(/::/,$module);
- my $modfname = $modparts[-1];
-
-EOT
-
-print OUT <<'EOT' if defined &DynaLoader::mod2fname;
- # Some systems have restrictions on files names for DLL's etc.
- # mod2fname returns appropriate file base name (typically truncated)
- # It may also edit @modparts if required.
- $modfname = &mod2fname(\@modparts) if defined &mod2fname;
-
-EOT
-
-print OUT <<'EOT' if $^O eq 'os2';
-
- # os2 static build can dynaload, but cannot dynaload Perl modules...
- die 'Dynaloaded Perl modules are not available in this build of Perl' if $OS2::is_static;
-
-EOT
-
-print OUT <<'EOT';
- my $modpname = join('/', at modparts);
- my $modlibname = (caller())[1];
- my $c = @modparts;
- $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename
- my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext";
-
-# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug;
-
- my $bs = $file;
- $bs =~ s/(\.\w+)?(;\d*)?$/\.bs/; # look for .bs 'beside' the library
-
- if (-s $bs) { # only read file if it's not empty
-# print STDERR "BS: $bs ($^O, $dlsrc)\n" if $dl_debug;
- eval { do $bs; };
- warn "$bs: $@\n" if $@;
- }
-
- goto retry if not -f $file or -s $bs;
-
- my $bootname = "boot_$module";
- $bootname =~ s/\W/_/g;
- @DynaLoader::dl_require_symbols = ($bootname);
-
- my $boot_symbol_ref;
-
-EOT
-
- if ($^O eq 'darwin') {
-print OUT <<'EOT';
- if ($boot_symbol_ref = dl_find_symbol(0, $bootname)) {
- goto boot; #extension library has already been loaded, e.g. darwin
- }
-EOT
- }
-
-print OUT <<'EOT';
- # Many dynamic extension loading problems will appear to come from
- # this section of code: XYZ failed at line 123 of DynaLoader.pm.
- # Often these errors are actually occurring in the initialisation
- # C code of the extension XS file. Perl reports the error as being
- # in this perl code simply because this was the last perl code
- # it executed.
-
- my $libref = dl_load_file($file, 0) or do {
- require Carp;
- Carp::croak("Can't load '$file' for module $module: " . dl_error());
- };
- push(@DynaLoader::dl_librefs,$libref); # record loaded object
-
- my @unresolved = dl_undef_symbols();
- if (@unresolved) {
- require Carp;
- Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
- }
-
- $boot_symbol_ref = dl_find_symbol($libref, $bootname) or do {
- require Carp;
- Carp::croak("Can't find '$bootname' symbol in $file\n");
- };
-
- push(@DynaLoader::dl_modules, $module); # record loaded module
-
- boot:
- my $xs = dl_install_xsub($boots, $boot_symbol_ref, $file);
-
- # See comment block above
- push(@DynaLoader::dl_shared_objects, $file); # record files loaded
- return &$xs(@_);
-
- retry:
- my $bootstrap_inherit = DynaLoader->can('bootstrap_inherit') ||
- XSLoader->can('bootstrap_inherit');
- goto &$bootstrap_inherit;
-}
-
-# Versions of DynaLoader prior to 5.6.0 don't have this function.
-sub bootstrap_inherit {
- package DynaLoader;
-
- my $module = $_[0];
- local *DynaLoader::isa = *{"$module\::ISA"};
- local @DynaLoader::isa = (@DynaLoader::isa, 'DynaLoader');
- # Cannot goto due to delocalization. Will report errors on a wrong line?
- require DynaLoader;
- DynaLoader::bootstrap(@_);
-}
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-XSLoader - Dynamically load C libraries into Perl code
-
-=head1 VERSION
-
-Version 0.10
-
-=head1 SYNOPSIS
-
- package YourPackage;
- use XSLoader;
-
- XSLoader::load 'YourPackage', $YourPackage::VERSION;
-
-=head1 DESCRIPTION
-
-This module defines a standard I<simplified> interface to the dynamic
-linking mechanisms available on many platforms. Its primary purpose is
-to implement cheap automatic dynamic loading of Perl modules.
-
-For a more complicated interface, see L<DynaLoader>. Many (most)
-features of C<DynaLoader> are not implemented in C<XSLoader>, like for
-example the C<dl_load_flags>, not honored by C<XSLoader>.
-
-=head2 Migration from C<DynaLoader>
-
-A typical module using L<DynaLoader|DynaLoader> starts like this:
-
- package YourPackage;
- require DynaLoader;
-
- our @ISA = qw( OnePackage OtherPackage DynaLoader );
- our $VERSION = '0.01';
- bootstrap YourPackage $VERSION;
-
-Change this to
-
- package YourPackage;
- use XSLoader;
-
- our @ISA = qw( OnePackage OtherPackage );
- our $VERSION = '0.01';
- XSLoader::load 'YourPackage', $VERSION;
-
-In other words: replace C<require DynaLoader> by C<use XSLoader>, remove
-C<DynaLoader> from C<@ISA>, change C<bootstrap> by C<XSLoader::load>. Do not
-forget to quote the name of your package on the C<XSLoader::load> line,
-and add comma (C<,>) before the arguments (C<$VERSION> above).
-
-Of course, if C<@ISA> contained only C<DynaLoader>, there is no need to have
-the C<@ISA> assignment at all; moreover, if instead of C<our> one uses the
-more backward-compatible
-
- use vars qw($VERSION @ISA);
-
-one can remove this reference to C<@ISA> together with the C<@ISA> assignment.
-
-If no C<$VERSION> was specified on the C<bootstrap> line, the last line becomes
-
- XSLoader::load 'YourPackage';
-
-=head2 Backward compatible boilerplate
-
-If you want to have your cake and eat it too, you need a more complicated
-boilerplate.
-
- package YourPackage;
- use vars qw($VERSION @ISA);
-
- @ISA = qw( OnePackage OtherPackage );
- $VERSION = '0.01';
- eval {
- require XSLoader;
- XSLoader::load('YourPackage', $VERSION);
- 1;
- } or do {
- require DynaLoader;
- push @ISA, 'DynaLoader';
- bootstrap YourPackage $VERSION;
- };
-
-The parentheses about C<XSLoader::load()> arguments are needed since we replaced
-C<use XSLoader> by C<require>, so the compiler does not know that a function
-C<XSLoader::load()> is present.
-
-This boilerplate uses the low-overhead C<XSLoader> if present; if used with
-an antic Perl which has no C<XSLoader>, it falls back to using C<DynaLoader>.
-
-=head1 Order of initialization: early load()
-
-I<Skip this section if the XSUB functions are supposed to be called from other
-modules only; read it only if you call your XSUBs from the code in your module,
-or have a C<BOOT:> section in your XS file (see L<perlxs/"The BOOT: Keyword">).
-What is described here is equally applicable to the L<DynaLoader|DynaLoader>
-interface.>
-
-A sufficiently complicated module using XS would have both Perl code (defined
-in F<YourPackage.pm>) and XS code (defined in F<YourPackage.xs>). If this
-Perl code makes calls into this XS code, and/or this XS code makes calls to
-the Perl code, one should be careful with the order of initialization.
-
-The call to C<XSLoader::load()> (or C<bootstrap()>) has three side effects:
-
-=over
-
-=item *
-
-if C<$VERSION> was specified, a sanity check is done to ensure that the
-versions of the F<.pm> and the (compiled) F<.xs> parts are compatible;
-
-=item *
-
-the XSUBs are made accessible from Perl;
-
-=item *
-
-if a C<BOOT:> section was present in the F<.xs> file, the code there is called.
-
-=back
-
-Consequently, if the code in the F<.pm> file makes calls to these XSUBs, it is
-convenient to have XSUBs installed before the Perl code is defined; for
-example, this makes prototypes for XSUBs visible to this Perl code.
-Alternatively, if the C<BOOT:> section makes calls to Perl functions (or
-uses Perl variables) defined in the F<.pm> file, they must be defined prior to
-the call to C<XSLoader::load()> (or C<bootstrap()>).
-
-The first situation being much more frequent, it makes sense to rewrite the
-boilerplate as
-
- package YourPackage;
- use XSLoader;
- use vars qw($VERSION @ISA);
-
- BEGIN {
- @ISA = qw( OnePackage OtherPackage );
- $VERSION = '0.01';
-
- # Put Perl code used in the BOOT: section here
-
- XSLoader::load 'YourPackage', $VERSION;
- }
-
- # Put Perl code making calls into XSUBs here
-
-=head2 The most hairy case
-
-If the interdependence of your C<BOOT:> section and Perl code is
-more complicated than this (e.g., the C<BOOT:> section makes calls to Perl
-functions which make calls to XSUBs with prototypes), get rid of the C<BOOT:>
-section altogether. Replace it with a function C<onBOOT()>, and call it like
-this:
-
- package YourPackage;
- use XSLoader;
- use vars qw($VERSION @ISA);
-
- BEGIN {
- @ISA = qw( OnePackage OtherPackage );
- $VERSION = '0.01';
- XSLoader::load 'YourPackage', $VERSION;
- }
-
- # Put Perl code used in onBOOT() function here; calls to XSUBs are
- # prototype-checked.
-
- onBOOT;
-
- # Put Perl initialization code assuming that XS is initialized here
-
-
-=head1 DIAGNOSTICS
-
-=over
-
-=item C<Can't find '%s' symbol in %s>
-
-B<(F)> The bootstrap symbol could not be found in the extension module.
-
-=item C<Can't load '%s' for module %s: %s>
-
-B<(F)> The loading or initialisation of the extension module failed.
-The detailed error follows.
-
-=item C<Undefined symbols present after loading %s: %s>
-
-B<(W)> As the message says, some symbols stay undefined although the
-extension module was correctly loaded and initialised. The list of undefined
-symbols follows.
-
-=item C<XSLoader::load('Your::Module', $Your::Module::VERSION)>
-
-B<(F)> You tried to invoke C<load()> without any argument. You must supply
-a module name, and optionally its version.
-
-=back
-
-
-=head1 LIMITATIONS
-
-To reduce the overhead as much as possible, only one possible location
-is checked to find the extension DLL (this location is where C<make install>
-would put the DLL). If not found, the search for the DLL is transparently
-delegated to C<DynaLoader>, which looks for the DLL along the C<@INC> list.
-
-In particular, this is applicable to the structure of C<@INC> used for testing
-not-yet-installed extensions. This means that running uninstalled extensions
-may have much more overhead than running the same extensions after
-C<make install>.
-
-
-=head1 BUGS
-
-Please report any bugs or feature requests via the perlbug(1) utility.
-
-
-=head1 SEE ALSO
-
-L<DynaLoader>
-
-
-=head1 AUTHORS
-
-Ilya Zakharevich originally extracted C<XSLoader> from C<DynaLoader>.
-
-CPAN version is currently maintained by SE<eacute>bastien Aperghis-Tramoni
-E<lt>sebastien at aperghis.netE<gt>.
-
-Previous maintainer was Michael G Schwern <schwern at pobox.com>.
-
-
-=head1 COPYRIGHT & LICENSE
-
-Copyright (C) 1990-2007 by Larry Wall and others.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
-EOT
-
-close OUT or die $!;
Deleted: trunk/contrib/perl/ext/DynaLoader/dl_beos.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_beos.xs 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/DynaLoader/dl_beos.xs 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,133 +0,0 @@
-/*
- * dl_beos.xs, by Tom Spindler
- * based on dl_dlopen.xs, by Paul Marquess
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-#include <be/kernel/image.h>
-#include <OS.h>
-#include <stdlib.h>
-#include <limits.h>
-
-#define dlerror() strerror(errno)
-
-#include "dlutils.c" /* SaveError() etc */
-
-static void
-dl_private_init(pTHX)
-{
- (void)dl_generic_private_init(aTHX);
-}
-
-MODULE = DynaLoader PACKAGE = DynaLoader
-
-BOOT:
- (void)dl_private_init(aTHX);
-
-
-void *
-dl_load_file(filename, flags=0)
- char * filename
- int flags
- CODE:
-{ image_id bogo;
- char *path;
- path = malloc(PATH_MAX);
- if (*filename != '/') {
- getcwd(path, PATH_MAX);
- strcat(path, "/");
- strcat(path, filename);
- } else {
- strcpy(path, filename);
- }
-
- DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", path, flags));
- bogo = load_add_on(path);
- DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL));
- ST(0) = sv_newmortal() ;
- if (bogo < 0) {
- SaveError(aTHX_ "%s", strerror(bogo));
- PerlIO_printf(Perl_debug_log, "load_add_on(%s) : %d (%s)\n", path, bogo, strerror(bogo));
- } else {
- RETVAL = (void *) bogo;
- sv_setiv( ST(0), PTR2IV(RETVAL) );
- }
- free(path);
-}
-
-void *
-dl_find_symbol(libhandle, symbolname)
- void * libhandle
- char * symbolname
- CODE:
- status_t retcode;
- void *adr = 0;
-#ifdef DLSYM_NEEDS_UNDERSCORE
- symbolname = Perl_form_nocontext("_%s", symbolname);
-#endif
- RETVAL = NULL;
- DLDEBUG(2, PerlIO_printf(Perl_debug_log,
- "dl_find_symbol(handle=%lx, symbol=%s)\n",
- (unsigned long) libhandle, symbolname));
- retcode = get_image_symbol((image_id) libhandle, symbolname,
- B_SYMBOL_TYPE_TEXT, (void **) &adr);
- RETVAL = adr;
- DLDEBUG(2, PerlIO_printf(Perl_debug_log,
- " symbolref = %lx\n", (unsigned long) RETVAL));
- ST(0) = sv_newmortal() ;
- if (RETVAL == NULL) {
- SaveError(aTHX_ "%s", strerror(retcode)) ;
- PerlIO_printf(Perl_debug_log, "retcode = %p (%s)\n", retcode, strerror(retcode));
- } else
- sv_setiv( ST(0), PTR2IV(RETVAL));
-
-
-void
-dl_undef_symbols()
- PPCODE:
-
-
-
-# These functions should not need changing on any platform:
-
-void
-dl_install_xsub(perl_name, symref, filename="$Package")
- char * perl_name
- void * symref
- const char * filename
- CODE:
- DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n",
- perl_name, (unsigned long) symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename, NULL,
- XS_DYNAMIC_FILENAME)));
-
-
-char *
-dl_error()
- CODE:
- dMY_CXT;
- RETVAL = dl_last_error ;
- OUTPUT:
- RETVAL
-
-#if defined(USE_ITHREADS)
-
-void
-CLONE(...)
- CODE:
- MY_CXT_CLONE;
-
- /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
- * using Perl variables that belong to another thread, we create our
- * own for this thread.
- */
- MY_CXT.x_dl_last_error = newSVpvn("", 0);
-
-#endif
-
-# end.
Deleted: trunk/contrib/perl/ext/DynaLoader/dl_mac.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_mac.xs 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/DynaLoader/dl_mac.xs 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,162 +0,0 @@
-/* dl_mac.xs
- *
- * Platform: Macintosh CFM
- * Author: Matthias Neeracher <neeri at iis.ee.ethz.ch>
- * Adapted from dl_dlopen.xs reference implementation by
- * Paul Marquess (pmarquess at bfsec.bt.co.uk)
- * $Log: not supported by cvs2svn $
- * Revision 1.3 1998/04/07 01:47:24 neeri
- * MacPerl 5.2.0r4b1
- *
- * Revision 1.2 1997/08/08 16:39:18 neeri
- * MacPerl 5.1.4b1 + time() fix
- *
- * Revision 1.1 1997/04/07 20:48:23 neeri
- * Synchronized with MacPerl 5.1.4a1
- *
- */
-
-#define MAC_CONTEXT
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-#include <CodeFragments.h>
-
-typedef CFragConnectionID ConnectionID;
-
-typedef struct {
- ConnectionID ** x_connections;
-} my_cxtx_t; /* this *must* be named my_cxtx_t */
-
-#define DL_CXT_EXTRA /* ask for dl_cxtx to be defined in dlutils.c */
-#include "dlutils.c" /* SaveError() etc */
-
-#define dl_connections (dl_cxtx.x_connections)
-
-static void terminate(pTHX_ void *ptr)
-{
- dMY_CXT;
- int size = GetHandleSize((Handle) dl_connections) / sizeof(ConnectionID);
- HLock((Handle) dl_connections);
- while (size)
- CloseConnection(*dl_connections + --size);
- DisposeHandle((Handle) dl_connections);
- dl_connections = nil;
-}
-
-static void
-dl_private_init(pTHX)
-{
- (void)dl_generic_private_init(aTHX);
-}
-
-MODULE = DynaLoader PACKAGE = DynaLoader
-
-BOOT:
- (void)dl_private_init(aTHX);
-
-
-ConnectionID
-dl_load_file(filename, flags=0)
- char * filename
- int flags
- PREINIT:
- OSErr err;
- FSSpec spec;
- ConnectionID connID;
- Ptr mainAddr;
- Str255 errName;
- CODE:
- DLDEBUG(1,PerlIO_printf(Perl_debug_log,"dl_load_file(%s):\n", filename));
- err = GUSIPath2FSp(filename, &spec);
- if (!err)
- err =
- GetDiskFragment(
- &spec, 0, 0, spec.name, kLoadCFrag, &connID, &mainAddr, errName);
- if (!err) {
- dMY_CXT;
- if (!dl_connections) {
- dl_connections = (ConnectionID **)NewHandle(0);
- call_atexit(terminate, (void*)0);
- }
- PtrAndHand((Ptr) &connID, (Handle) dl_connections, sizeof(ConnectionID));
- RETVAL = connID;
- } else
- RETVAL = (ConnectionID) 0;
- DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%d\n", RETVAL));
- ST(0) = sv_newmortal() ;
- if (err)
- SaveError(aTHX_ "DynaLoader error [%d, %#s]", err, errName) ;
- else
- sv_setiv( ST(0), (IV)RETVAL);
-
-void *
-dl_find_symbol(connID, symbol)
- ConnectionID connID
- Str255 symbol
- CODE:
- {
- OSErr err;
- Ptr symAddr;
- CFragSymbolClass symClass;
- DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%#s)\n",
- connID, symbol));
- err = FindSymbol(connID, symbol, &symAddr, &symClass);
- if (err)
- symAddr = (Ptr) 0;
- RETVAL = (void *) symAddr;
- DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref = %x\n", RETVAL));
- ST(0) = sv_newmortal() ;
- if (err)
- SaveError(aTHX_ "DynaLoader error [%d]!", err) ;
- else
- sv_setiv( ST(0), (IV)RETVAL);
- }
-
-void
-dl_undef_symbols()
- PPCODE:
-
-
-
-# These functions should not need changing on any platform:
-
-void
-dl_install_xsub(perl_name, symref, filename="$Package")
- char * perl_name
- void * symref
- const char * filename
- CODE:
- DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
- perl_name, symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename, NULL,
- XS_DYNAMIC_FILENAME)));
-
-
-char *
-dl_error()
- CODE:
- dMY_CXT;
- RETVAL = dl_last_error ;
- OUTPUT:
- RETVAL
-
-#if defined(USE_ITHREADS)
-
-void
-CLONE(...)
- CODE:
- MY_CXT_CLONE;
-
- /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
- * using Perl variables that belong to another thread, we create our
- * own for this thread.
- */
- MY_CXT.x_dl_last_error = newSVpvn("", 0);
-
-#endif
-
-# end.
Deleted: trunk/contrib/perl/ext/DynaLoader/dl_mpeix.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_mpeix.xs 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/DynaLoader/dl_mpeix.xs 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,146 +0,0 @@
-/*
- * Author: Mark Klein (mklein at dis.com)
- * Version: 2.1, 1996/07/25
- * Version: 2.2, 1997/09/25 Mark Bixby (markb at cccd.edu)
- * Version: 2.3, 1998/11/19 Mark Bixby (markb at cccd.edu)
- * Version: 2.4, 2002/03/24 Mark Bixby (mark at bixby.org)
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-#ifdef __GNUC__
-extern void HPGETPROCPLABEL( int parms,
- char * procname,
- void * plabel,
- int * status,
- char * firstfile,
- int casesensitive,
- int symboltype,
- int * datasize,
- int position,
- int searchpath,
- int binding);
-#else
-#pragma intrinsic HPGETPROCPLABEL
-#endif
-#include "dlutils.c" /* for SaveError() etc */
-
-typedef struct {
- char filename[PATH_MAX + 3];
- } t_mpe_dld, *p_mpe_dld;
-
-static void
-dl_private_init(pTHX)
-{
- (void)dl_generic_private_init(aTHX);
-}
-
-MODULE = DynaLoader PACKAGE = DynaLoader
-
-BOOT:
- (void)dl_private_init(aTHX);
-
-void *
-dl_load_file(filename, flags=0)
- char * filename
- int flags
- PREINIT:
- char buf[PATH_MAX + 3];
- p_mpe_dld obj = NULL;
-
- CODE:
- DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,
-flags));
- if (flags & 0x01)
- Perl_warn(aTHX_
-"Can't make loaded symbols global on this platform while loading %s",filename);
- obj = (p_mpe_dld) safemalloc(sizeof(t_mpe_dld));
- memzero(obj, sizeof(t_mpe_dld));
- if (filename[0] != '/')
- {
- getcwd(buf,sizeof(buf));
- sprintf(obj->filename," %s/%s ",buf,filename);
- }
- else
- sprintf(obj->filename," %s ",filename);
-
- DLDEBUG(2,PerlIO_printf(Perl_debug_log," libref=%x\n", obj));
-
- ST(0) = sv_newmortal() ;
- if (obj == NULL)
- SaveError(aTHX_"%s",Strerror(errno));
- else
- sv_setiv( ST(0), PTR2IV(obj) );
-
-void *
-dl_find_symbol(libhandle, symbolname)
- void * libhandle
- char * symbolname
- CODE:
- int datalen;
- p_mpe_dld obj = (p_mpe_dld) libhandle;
- char symname[PATH_MAX + 3];
- void * symaddr = NULL;
- int status;
- DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_find_symbol(handle=%x, symbol=%s)\n",
- libhandle, symbolname));
- ST(0) = sv_newmortal() ;
- errno = 0;
-
- sprintf(symname, " %s ", symbolname);
- HPGETPROCPLABEL(8, symname, &symaddr, &status, obj->filename, 1,
- 0, &datalen, 1, 0, 0);
-
- DLDEBUG(2,PerlIO_printf(Perl_debug_log," symbolref(PROCEDURE) = %x, status=%x\n", symaddr, status));
-
- if (status != 0) {
- SaveError(aTHX_"%s",(errno) ? Strerror(errno) : "Symbol not found") ;
- } else {
- sv_setiv( ST(0), PTR2IV(symaddr) );
- }
-
-void
-dl_undef_symbols()
- PPCODE:
-
-# These functions should not need changing on any platform:
-
-void
-dl_install_xsub(perl_name, symref, filename="$Package")
- char * perl_name
- void * symref
- const char * filename
- CODE:
- DLDEBUG(2,PerlIO_printf(Perl_debug_log,"dl_install_xsub(name=%s, symref=%x)\n",
- perl_name, symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename, NULL,
- XS_DYNAMIC_FILENAME)));
-
-char *
-dl_error()
- CODE:
- dMY_CXT;
- RETVAL = dl_last_error ;
- OUTPUT:
- RETVAL
-
-#if defined(USE_ITHREADS)
-
-void
-CLONE(...)
- CODE:
- MY_CXT_CLONE;
-
- /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
- * using Perl variables that belong to another thread, we create our
- * own for this thread.
- */
- MY_CXT.x_dl_last_error = newSVpvn("", 0);
-
-#endif
-
-# end.
Deleted: trunk/contrib/perl/ext/DynaLoader/dl_vmesa.xs
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/dl_vmesa.xs 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/DynaLoader/dl_vmesa.xs 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,192 +0,0 @@
-/* dl_vmesa.xs
- *
- * Platform: VM/ESA, possibly others which use dllload etc.
- * Author: Neale Ferguson (neale at mailbox.tabnsw.com.au)
- * Created: 23rd September, 1998
- *
- *
- */
-
-/* Porting notes:
-
-
- Definition of VM/ESA dynamic Linking functions
- ==============================================
- In order to make this implementation easier to understand here is a
- quick definition of the VM/ESA Dynamic Linking functions which are
- used here.
-
- dlopen
- ------
- void *
- dlopen(const char *path)
-
- This function takes the name of a dynamic object file and returns
- a descriptor which can be used by dlsym later. It returns NULL on
- error.
-
-
- dllsym
- ------
- void *
- dlsym(void *handle, char *symbol)
-
- Takes the handle returned from dlopen and the name of a symbol to
- get the address of. If the symbol was found a pointer is
- returned. It returns NULL on error.
-
- dlerror
- -------
- char * dlerror()
-
- Returns a null-terminated string which describes the last error
- that occurred with the other dll functions. After each call to
- dlerror the error message will be reset to a null pointer. The
- SaveError function is used to save the error as soo as it happens.
-
-
- Return Types
- ============
- In this implementation the two functions, dl_load_file &
- dl_find_symbol, return void *. This is because the underlying SunOS
- dynamic linker calls also return void *. This is not necessarily
- the case for all architectures. For example, some implementation
- will want to return a char * for dl_load_file.
-
- If void * is not appropriate for your architecture, you will have to
- change the void * to whatever you require. If you are not certain of
- how Perl handles C data types, I suggest you start by consulting
- Dean Roerich's Perl 5 API document. Also, have a look in the typemap
- file (in the ext directory) for a fairly comprehensive list of types
- that are already supported. If you are completely stuck, I suggest you
- post a message to perl5-porters, comp.lang.perl.misc or if you are really
- desperate to me.
-
- Remember when you are making any changes that the return value from
- dl_load_file is used as a parameter in the dl_find_symbol
- function. Also the return value from find_symbol is used as a parameter
- to install_xsub.
-
-
- Dealing with Error Messages
- ============================
- In order to make the handling of dynamic linking errors as generic as
- possible you should store any error messages associated with your
- implementation with the StoreError function.
-
- In the case of VM/ESA the function dlerror returns the error message
- associated with the last dynamic link error. As the VM/ESA dynamic
- linker functions return NULL on error every call to a VM/ESA dynamic
- dynamic link routine is coded like this
-
- RETVAL = dlopen(filename) ;
- if (RETVAL == NULL)
- SaveError(aTHX_ "%s",dlerror()) ;
-
- Note that SaveError() takes a printf format string. Use a "%s" as
- the first parameter if the error may contain and % characters.
-
-*/
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include <dll.h>
-
-
-#include "dlutils.c" /* SaveError() etc */
-
-
-static void
-dl_private_init(pTHX)
-{
- (void)dl_generic_private_init(aTHX);
-}
-
-MODULE = DynaLoader PACKAGE = DynaLoader
-
-BOOT:
- (void)dl_private_init(aTHX);
-
-
-void *
-dl_load_file(filename, flags=0)
- char * filename
- int flags
- CODE:
- if (flags & 0x01)
- Perl_warn(aTHX_ "Can't make loaded symbols global on this platform while loading %s",filename);
- DLDEBUG(1,PerlIO_printf(Perl_debug_log, "dl_load_file(%s,%x):\n", filename,flags));
- RETVAL = dlopen(filename) ;
- DLDEBUG(2,PerlIO_printf(Perl_debug_log, " libref=%lx\n", (unsigned long) RETVAL));
- ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
- SaveError(aTHX_ "%s",dlerror()) ;
- else
- sv_setiv( ST(0), PTR2IV(RETVAL) );
-
-
-void *
-dl_find_symbol(libhandle, symbolname)
- void * libhandle
- char * symbolname
- CODE:
- DLDEBUG(2, PerlIO_printf(Perl_debug_log,
- "dl_find_symbol(handle=%lx, symbol=%s)\n",
- (unsigned long) libhandle, symbolname));
- RETVAL = dlsym(libhandle, symbolname);
- DLDEBUG(2, PerlIO_printf(Perl_debug_log,
- " symbolref = %lx\n", (unsigned long) RETVAL));
- ST(0) = sv_newmortal() ;
- if (RETVAL == NULL)
- SaveError(aTHX_ "%s",dlerror()) ;
- else
- sv_setiv( ST(0), PTR2IV(RETVAL) );
-
-
-void
-dl_undef_symbols()
- PPCODE:
-
-
-
-# These functions should not need changing on any platform:
-
-void
-dl_install_xsub(perl_name, symref, filename="$Package")
- char * perl_name
- void * symref
- const char * filename
- CODE:
- DLDEBUG(2,PerlIO_printf(Perl_debug_log, "dl_install_xsub(name=%s, symref=%lx)\n",
- perl_name, (unsigned long) symref));
- ST(0) = sv_2mortal(newRV((SV*)newXS_flags(perl_name,
- (void(*)(pTHX_ CV *))symref,
- filename, NULL,
- XS_DYNAMIC_FILENAME)));
-
-
-char *
-dl_error()
- CODE:
- dMY_CXT;
- RETVAL = dl_last_error ;
- OUTPUT:
- RETVAL
-
-#if defined(USE_ITHREADS)
-
-void
-CLONE(...)
- CODE:
- MY_CXT_CLONE;
-
- /* MY_CXT_CLONE just does a memcpy on the whole structure, so to avoid
- * using Perl variables that belong to another thread, we create our
- * own for this thread.
- */
- MY_CXT.x_dl_last_error = newSVpvn("", 0);
-
-#endif
-
-# end.
Deleted: trunk/contrib/perl/ext/DynaLoader/t/XSLoader.t
===================================================================
--- trunk/contrib/perl/ext/DynaLoader/t/XSLoader.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/DynaLoader/t/XSLoader.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,87 +0,0 @@
-#!perl -T
-
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- }
-}
-
-use strict;
-use Config;
-
-my $db_file;
-BEGIN {
- eval "use Test::More";
- if ($@) {
- print "1..0 # Skip: Test::More not available\n";
- die "Test::More not available\n";
- }
-
- use Config;
- foreach (qw/SDBM_File GDBM_File ODBM_File NDBM_File DB_File/) {
- if ($Config{extensions} =~ /\b$_\b/) {
- $db_file = $_;
- last;
- }
- }
-}
-
-
-my %modules = (
- # ModuleName => q|code to check that it was loaded|,
- 'Cwd' => q| ::can_ok( 'Cwd' => 'fastcwd' ) |, # 5.7 ?
- 'File::Glob' => q| ::can_ok( 'File::Glob' => 'doglob' ) |, # 5.6
- $db_file => q| ::can_ok( $db_file => 'TIEHASH' ) |, # 5.0
- 'Socket' => q| ::can_ok( 'Socket' => 'inet_aton' ) |, # 5.0
- 'Time::HiRes'=> q| ::can_ok( 'Time::HiRes' => 'usleep' ) |, # 5.7.3
-);
-
-plan tests => keys(%modules) * 4 + 5;
-
-# Try to load the module
-use_ok( 'XSLoader' );
-
-# Check functions
-can_ok( 'XSLoader' => 'load' );
-can_ok( 'XSLoader' => 'bootstrap_inherit' );
-
-# Check error messages
-eval { XSLoader::load() };
-like( $@, '/^XSLoader::load\(\'Your::Module\', \$Your::Module::VERSION\)/',
- "calling XSLoader::load() with no argument" );
-
-eval q{ package Thwack; XSLoader::load('Thwack'); };
-if ($Config{usedl}) {
- like( $@, q{/^Can't locate loadable object for module Thwack in @INC/},
- "calling XSLoader::load() under a package with no XS part" );
-}
-else {
- like( $@, q{/^Can't load module Thwack, dynamic loading not available in this perl./},
- "calling XSLoader::load() under a package with no XS part" );
-}
-
-# Now try to load well known XS modules
-my $extensions = $Config{'extensions'};
-$extensions =~ s|/|::|g;
-
-for my $module (sort keys %modules) {
- my $warnings = "";
- local $SIG{__WARN__} = sub { $warnings = $_[0] };
-
- SKIP: {
- skip "$module not available", 4 if $extensions !~ /\b$module\b/;
-
- eval qq{ package $module; XSLoader::load('$module', "qunckkk"); };
- like( $@, "/^$module object version \\S+ does not match bootstrap parameter (?:qunckkk|0)/",
- "calling XSLoader::load() with a XS module and an incorrect version" );
- like( $warnings, "/^\$|^Version string 'qunckkk' contains invalid data; ignoring: 'qunckkk'/",
- "in Perl 5.10, DynaLoader warns about the incorrect version string" );
-
- eval qq{ package $module; XSLoader::load('$module'); };
- is( $@, '', "XSLoader::load($module)");
-
- eval qq{ package $module; $modules{$module}; };
- }
-}
-
Deleted: trunk/contrib/perl/ext/Hash-Util-FieldHash/t/10_hash.t
===================================================================
--- trunk/contrib/perl/ext/Hash-Util-FieldHash/t/10_hash.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/Hash-Util-FieldHash/t/10_hash.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,110 +0,0 @@
-#!./perl -w
-use Test::More;
-
-use strict;
-use Hash::Util::FieldHash qw( :all);
-
-no warnings 'misc';
-
-plan tests => 5;
-
-fieldhash my %h;
-
-ok (!Internals::HvREHASH(%h), "hash doesn't start with rehash flag on");
-
-foreach (1..10) {
- $h{"\0"x$_}++;
-}
-
-ok (!Internals::HvREHASH(%h), "10 entries doesn't trigger rehash");
-
-foreach (11..20) {
- $h{"\0"x$_}++;
-}
-
-ok (Internals::HvREHASH(%h), "20 entries triggers rehash");
-
-
-
-
-# second part using an emulation of the PERL_HASH in perl, mounting an
-# attack on a pre-populated hash. This is also useful if you need normal
-# keys which don't contain \0 -- suitable for stashes
-
-use constant MASK_U32 => 2**32;
-use constant HASH_SEED => 0;
-use constant THRESHOLD => 14;
-use constant START => "a";
-
-# some initial hash data
-fieldhash my %h2;
-%h2 = map {$_ => 1} 'a'..'cc';
-
-ok (!Internals::HvREHASH(%h2),
- "starting with pre-populated non-pathological hash (rehash flag if off)");
-
-my @keys = get_keys(\%h2);
-$h2{$_}++ for @keys;
-ok (Internals::HvREHASH(%h2),
- scalar(@keys) . " colliding into the same bucket keys are triggering rehash");
-
-sub get_keys {
- my $hr = shift;
-
- # the minimum of bits required to mount the attack on a hash
- my $min_bits = log(THRESHOLD)/log(2);
-
- # if the hash has already been populated with a significant amount
- # of entries the number of mask bits can be higher
- my $keys = scalar keys %$hr;
- my $bits = $keys ? log($keys)/log(2) : 0;
- $bits = $min_bits if $min_bits > $bits;
-
- $bits = int($bits) < $bits ? int($bits) + 1 : int($bits);
- # need to add 2 bits to cover the internal split cases
- $bits += 2;
- my $mask = 2**$bits-1;
- print "# using mask: $mask ($bits)\n";
-
- my @keys;
- my $s = START;
- my $c = 0;
- # get 2 keys on top of the THRESHOLD
- my $hash;
- while (@keys < THRESHOLD+2) {
- # next if exists $hash->{$s};
- $hash = hash($s);
- next unless ($hash & $mask) == 0;
- $c++;
- printf "# %2d: %5s, %10s\n", $c, $s, $hash;
- push @keys, $s;
- } continue {
- $s++;
- }
-
- return @keys;
-}
-
-
-# trying to provide the fastest equivalent of C macro's PERL_HASH in
-# Perl - the main complication is that it uses U32 integer, which we
-# can't do it perl, without doing some tricks
-sub hash {
- my $s = shift;
- my @c = split //, $s;
- my $u = HASH_SEED;
- for (@c) {
- # (A % M) + (B % M) == (A + B) % M
- # This works because '+' produces a NV, which is big enough to hold
- # the intermediate result. We only need the % before any "^" and "&"
- # to get the result in the range for an I32.
- # and << doesn't work on NV, so using 1 << 10
- $u += ord;
- $u += $u * (1 << 10); $u %= MASK_U32;
- $u ^= $u >> 6;
- }
- $u += $u << 3; $u %= MASK_U32;
- $u ^= $u >> 11; $u %= MASK_U32;
- $u += $u << 15; $u %= MASK_U32;
- $u;
-}
Deleted: trunk/contrib/perl/ext/Opcode/Makefile.PL
===================================================================
--- trunk/contrib/perl/ext/Opcode/Makefile.PL 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/Opcode/Makefile.PL 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,6 +0,0 @@
-use ExtUtils::MakeMaker;
-WriteMakefile(
- NAME => 'Opcode',
- MAN3PODS => {},
- VERSION_FROM => 'Opcode.pm',
-);
Deleted: trunk/contrib/perl/ext/Opcode/Safe.pm
===================================================================
--- trunk/contrib/perl/ext/Opcode/Safe.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/Opcode/Safe.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,621 +0,0 @@
-package Safe;
-
-use 5.003_11;
-use strict;
-
-$Safe::VERSION = "2.12";
-
-# *** Don't declare any lexicals above this point ***
-#
-# This function should return a closure which contains an eval that can't
-# see any lexicals in scope (apart from __ExPr__ which is unavoidable)
-
-sub lexless_anon_sub {
- # $_[0] is package;
- # $_[1] is strict flag;
- my $__ExPr__ = $_[2]; # must be a lexical to create the closure that
- # can be used to pass the value into the safe
- # world
-
- # Create anon sub ref in root of compartment.
- # Uses a closure (on $__ExPr__) to pass in the code to be executed.
- # (eval on one line to keep line numbers as expected by caller)
- eval sprintf
- 'package %s; %s strict; sub { @_=(); eval q[my $__ExPr__;] . $__ExPr__; }',
- $_[0], $_[1] ? 'use' : 'no';
-}
-
-use Carp;
-use Carp::Heavy;
-
-use Opcode 1.01, qw(
- opset opset_to_ops opmask_add
- empty_opset full_opset invert_opset verify_opset
- opdesc opcodes opmask define_optag opset_to_hex
-);
-
-*ops_to_opset = \&opset; # Temporary alias for old Penguins
-
-
-my $default_root = 0;
-# share *_ and functions defined in universal.c
-# Don't share stuff like *UNIVERSAL:: otherwise code from the
-# compartment can 0wn functions in UNIVERSAL
-my $default_share = [qw[
- *_
- &PerlIO::get_layers
- &Regexp::DESTROY
- &re::is_regexp
- &re::regname
- &re::regnames
- &re::regnames_count
- &Tie::Hash::NamedCapture::FETCH
- &Tie::Hash::NamedCapture::STORE
- &Tie::Hash::NamedCapture::DELETE
- &Tie::Hash::NamedCapture::CLEAR
- &Tie::Hash::NamedCapture::EXISTS
- &Tie::Hash::NamedCapture::FIRSTKEY
- &Tie::Hash::NamedCapture::NEXTKEY
- &Tie::Hash::NamedCapture::SCALAR
- &Tie::Hash::NamedCapture::flags
- &UNIVERSAL::isa
- &UNIVERSAL::can
- &UNIVERSAL::DOES
- &UNIVERSAL::VERSION
- &utf8::is_utf8
- &utf8::valid
- &utf8::encode
- &utf8::decode
- &utf8::upgrade
- &utf8::downgrade
- &utf8::native_to_unicode
- &utf8::unicode_to_native
- &version::()
- &version::new
- &version::(""
- &version::stringify
- &version::(0+
- &version::numify
- &version::normal
- &version::(cmp
- &version::(<=>
- &version::vcmp
- &version::(bool
- &version::boolean
- &version::(nomethod
- &version::noop
- &version::is_alpha
- &version::qv
-]];
-
-sub new {
- my($class, $root, $mask) = @_;
- my $obj = {};
- bless $obj, $class;
-
- if (defined($root)) {
- croak "Can't use \"$root\" as root name"
- if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
- $obj->{Root} = $root;
- $obj->{Erase} = 0;
- }
- else {
- $obj->{Root} = "Safe::Root".$default_root++;
- $obj->{Erase} = 1;
- }
-
- # use permit/deny methods instead till interface issues resolved
- # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
- croak "Mask parameter to new no longer supported" if defined $mask;
- $obj->permit_only(':default');
-
- # We must share $_ and @_ with the compartment or else ops such
- # as split, length and so on won't default to $_ properly, nor
- # will passing argument to subroutines work (via @_). In fact,
- # for reasons I don't completely understand, we need to share
- # the whole glob *_ rather than $_ and @_ separately, otherwise
- # @_ in non default packages within the compartment don't work.
- $obj->share_from('main', $default_share);
- Opcode::_safe_pkg_prep($obj->{Root}) if($Opcode::VERSION > 1.04);
- return $obj;
-}
-
-sub DESTROY {
- my $obj = shift;
- $obj->erase('DESTROY') if $obj->{Erase};
-}
-
-sub erase {
- my ($obj, $action) = @_;
- my $pkg = $obj->root();
- my ($stem, $leaf);
-
- no strict 'refs';
- $pkg = "main::$pkg\::"; # expand to full symbol table name
- ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
-
- # The 'my $foo' is needed! Without it you get an
- # 'Attempt to free unreferenced scalar' warning!
- my $stem_symtab = *{$stem}{HASH};
-
- #warn "erase($pkg) stem=$stem, leaf=$leaf";
- #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
- # ", join(', ', %$stem_symtab),"\n";
-
-# delete $stem_symtab->{$leaf};
-
- my $leaf_glob = $stem_symtab->{$leaf};
- my $leaf_symtab = *{$leaf_glob}{HASH};
-# warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
- %$leaf_symtab = ();
- #delete $leaf_symtab->{'__ANON__'};
- #delete $leaf_symtab->{'foo'};
- #delete $leaf_symtab->{'main::'};
-# my $foo = undef ${"$stem\::"}{"$leaf\::"};
-
- if ($action and $action eq 'DESTROY') {
- delete $stem_symtab->{$leaf};
- } else {
- $obj->share_from('main', $default_share);
- }
- 1;
-}
-
-
-sub reinit {
- my $obj= shift;
- $obj->erase;
- $obj->share_redo;
-}
-
-sub root {
- my $obj = shift;
- croak("Safe root method now read-only") if @_;
- return $obj->{Root};
-}
-
-
-sub mask {
- my $obj = shift;
- return $obj->{Mask} unless @_;
- $obj->deny_only(@_);
-}
-
-# v1 compatibility methods
-sub trap { shift->deny(@_) }
-sub untrap { shift->permit(@_) }
-
-sub deny {
- my $obj = shift;
- $obj->{Mask} |= opset(@_);
-}
-sub deny_only {
- my $obj = shift;
- $obj->{Mask} = opset(@_);
-}
-
-sub permit {
- my $obj = shift;
- # XXX needs testing
- $obj->{Mask} &= invert_opset opset(@_);
-}
-sub permit_only {
- my $obj = shift;
- $obj->{Mask} = invert_opset opset(@_);
-}
-
-
-sub dump_mask {
- my $obj = shift;
- print opset_to_hex($obj->{Mask}),"\n";
-}
-
-
-
-sub share {
- my($obj, @vars) = @_;
- $obj->share_from(scalar(caller), \@vars);
-}
-
-sub share_from {
- my $obj = shift;
- my $pkg = shift;
- my $vars = shift;
- my $no_record = shift || 0;
- my $root = $obj->root();
- croak("vars not an array ref") unless ref $vars eq 'ARRAY';
- no strict 'refs';
- # Check that 'from' package actually exists
- croak("Package \"$pkg\" does not exist")
- unless keys %{"$pkg\::"};
- my $arg;
- foreach $arg (@$vars) {
- # catch some $safe->share($var) errors:
- my ($var, $type);
- $type = $1 if ($var = $arg) =~ s/^(\W)//;
- # warn "share_from $pkg $type $var";
- *{$root."::$var"} = (!$type) ? \&{$pkg."::$var"}
- : ($type eq '&') ? \&{$pkg."::$var"}
- : ($type eq '$') ? \${$pkg."::$var"}
- : ($type eq '@') ? \@{$pkg."::$var"}
- : ($type eq '%') ? \%{$pkg."::$var"}
- : ($type eq '*') ? *{$pkg."::$var"}
- : croak(qq(Can't share "$type$var" of unknown type));
- }
- $obj->share_record($pkg, $vars) unless $no_record or !$vars;
-}
-
-sub share_record {
- my $obj = shift;
- my $pkg = shift;
- my $vars = shift;
- my $shares = \%{$obj->{Shares} ||= {}};
- # Record shares using keys of $obj->{Shares}. See reinit.
- @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
-}
-sub share_redo {
- my $obj = shift;
- my $shares = \%{$obj->{Shares} ||= {}};
- my($var, $pkg);
- while(($var, $pkg) = each %$shares) {
- # warn "share_redo $pkg\:: $var";
- $obj->share_from($pkg, [ $var ], 1);
- }
-}
-sub share_forget {
- delete shift->{Shares};
-}
-
-sub varglob {
- my ($obj, $var) = @_;
- no strict 'refs';
- return *{$obj->root()."::$var"};
-}
-
-
-sub reval {
- my ($obj, $expr, $strict) = @_;
- my $root = $obj->{Root};
-
- my $evalsub = lexless_anon_sub($root,$strict, $expr);
- return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
-}
-
-sub rdo {
- my ($obj, $file) = @_;
- my $root = $obj->{Root};
-
- my $evalsub = eval
- sprintf('package %s; sub { @_ = (); do $file }', $root);
- return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-Safe - Compile and execute code in restricted compartments
-
-=head1 SYNOPSIS
-
- use Safe;
-
- $compartment = new Safe;
-
- $compartment->permit(qw(time sort :browse));
-
- $result = $compartment->reval($unsafe_code);
-
-=head1 DESCRIPTION
-
-The Safe extension module allows the creation of compartments
-in which perl code can be evaluated. Each compartment has
-
-=over 8
-
-=item a new namespace
-
-The "root" of the namespace (i.e. "main::") is changed to a
-different package and code evaluated in the compartment cannot
-refer to variables outside this namespace, even with run-time
-glob lookups and other tricks.
-
-Code which is compiled outside the compartment can choose to place
-variables into (or I<share> variables with) the compartment's namespace
-and only that data will be visible to code evaluated in the
-compartment.
-
-By default, the only variables shared with compartments are the
-"underscore" variables $_ and @_ (and, technically, the less frequently
-used %_, the _ filehandle and so on). This is because otherwise perl
-operators which default to $_ will not work and neither will the
-assignment of arguments to @_ on subroutine entry.
-
-=item an operator mask
-
-Each compartment has an associated "operator mask". Recall that
-perl code is compiled into an internal format before execution.
-Evaluating perl code (e.g. via "eval" or "do 'file'") causes
-the code to be compiled into an internal format and then,
-provided there was no error in the compilation, executed.
-Code evaluated in a compartment compiles subject to the
-compartment's operator mask. Attempting to evaluate code in a
-compartment which contains a masked operator will cause the
-compilation to fail with an error. The code will not be executed.
-
-The default operator mask for a newly created compartment is
-the ':default' optag.
-
-It is important that you read the L<Opcode> module documentation
-for more information, especially for detailed definitions of opnames,
-optags and opsets.
-
-Since it is only at the compilation stage that the operator mask
-applies, controlled access to potentially unsafe operations can
-be achieved by having a handle to a wrapper subroutine (written
-outside the compartment) placed into the compartment. For example,
-
- $cpt = new Safe;
- sub wrapper {
- # vet arguments and perform potentially unsafe operations
- }
- $cpt->share('&wrapper');
-
-=back
-
-
-=head1 WARNING
-
-The authors make B<no warranty>, implied or otherwise, about the
-suitability of this software for safety or security purposes.
-
-The authors shall not in any case be liable for special, incidental,
-consequential, indirect or other similar damages arising from the use
-of this software.
-
-Your mileage will vary. If in any doubt B<do not use it>.
-
-
-=head2 RECENT CHANGES
-
-The interface to the Safe module has changed quite dramatically since
-version 1 (as supplied with Perl5.002). Study these pages carefully if
-you have code written to use Safe version 1 because you will need to
-makes changes.
-
-
-=head2 Methods in class Safe
-
-To create a new compartment, use
-
- $cpt = new Safe;
-
-Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
-to use for the compartment (defaults to "Safe::Root0", incremented for
-each new compartment).
-
-Note that version 1.00 of the Safe module supported a second optional
-parameter, MASK. That functionality has been withdrawn pending deeper
-consideration. Use the permit and deny methods described below.
-
-The following methods can then be used on the compartment
-object returned by the above constructor. The object argument
-is implicit in each case.
-
-
-=over 8
-
-=item permit (OP, ...)
-
-Permit the listed operators to be used when compiling code in the
-compartment (in I<addition> to any operators already permitted).
-
-You can list opcodes by names, or use a tag name; see
-L<Opcode/"Predefined Opcode Tags">.
-
-=item permit_only (OP, ...)
-
-Permit I<only> the listed operators to be used when compiling code in
-the compartment (I<no> other operators are permitted).
-
-=item deny (OP, ...)
-
-Deny the listed operators from being used when compiling code in the
-compartment (other operators may still be permitted).
-
-=item deny_only (OP, ...)
-
-Deny I<only> the listed operators from being used when compiling code
-in the compartment (I<all> other operators will be permitted).
-
-=item trap (OP, ...)
-
-=item untrap (OP, ...)
-
-The trap and untrap methods are synonyms for deny and permit
-respectfully.
-
-=item share (NAME, ...)
-
-This shares the variable(s) in the argument list with the compartment.
-This is almost identical to exporting variables using the L<Exporter>
-module.
-
-Each NAME must be the B<name> of a non-lexical variable, typically
-with the leading type identifier included. A bareword is treated as a
-function name.
-
-Examples of legal names are '$foo' for a scalar, '@foo' for an
-array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
-for a glob (i.e. all symbol table entries associated with "foo",
-including scalar, array, hash, sub and filehandle).
-
-Each NAME is assumed to be in the calling package. See share_from
-for an alternative method (which share uses).
-
-=item share_from (PACKAGE, ARRAYREF)
-
-This method is similar to share() but allows you to explicitly name the
-package that symbols should be shared from. The symbol names (including
-type characters) are supplied as an array reference.
-
- $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
-
-
-=item varglob (VARNAME)
-
-This returns a glob reference for the symbol table entry of VARNAME in
-the package of the compartment. VARNAME must be the B<name> of a
-variable without any leading type marker. For example,
-
- $cpt = new Safe 'Root';
- $Root::foo = "Hello world";
- # Equivalent version which doesn't need to know $cpt's package name:
- ${$cpt->varglob('foo')} = "Hello world";
-
-
-=item reval (STRING)
-
-This evaluates STRING as perl code inside the compartment.
-
-The code can only see the compartment's namespace (as returned by the
-B<root> method). The compartment's root package appears to be the
-C<main::> package to the code inside the compartment.
-
-Any attempt by the code in STRING to use an operator which is not permitted
-by the compartment will cause an error (at run-time of the main program
-but at compile-time for the code in STRING). The error is of the form
-"'%s' trapped by operation mask...".
-
-If an operation is trapped in this way, then the code in STRING will
-not be executed. If such a trapped operation occurs or any other
-compile-time or return error, then $@ is set to the error message, just
-as with an eval().
-
-If there is no error, then the method returns the value of the last
-expression evaluated, or a return statement may be used, just as with
-subroutines and B<eval()>. The context (list or scalar) is determined
-by the caller as usual.
-
-This behaviour differs from the beta distribution of the Safe extension
-where earlier versions of perl made it hard to mimic the return
-behaviour of the eval() command and the context was always scalar.
-
-Some points to note:
-
-If the entereval op is permitted then the code can use eval "..." to
-'hide' code which might use denied ops. This is not a major problem
-since when the code tries to execute the eval it will fail because the
-opmask is still in effect. However this technique would allow clever,
-and possibly harmful, code to 'probe' the boundaries of what is
-possible.
-
-Any string eval which is executed by code executing in a compartment,
-or by code called from code executing in a compartment, will be eval'd
-in the namespace of the compartment. This is potentially a serious
-problem.
-
-Consider a function foo() in package pkg compiled outside a compartment
-but shared with it. Assume the compartment has a root package called
-'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
-normally, $pkg::foo will be set to 1. If foo() is called from the
-compartment (by whatever means) then instead of setting $pkg::foo, the
-eval will actually set $Root::pkg::foo.
-
-This can easily be demonstrated by using a module, such as the Socket
-module, which uses eval "..." as part of an AUTOLOAD function. You can
-'use' the module outside the compartment and share an (autoloaded)
-function with the compartment. If an autoload is triggered by code in
-the compartment, or by any code anywhere that is called by any means
-from the compartment, then the eval in the Socket module's AUTOLOAD
-function happens in the namespace of the compartment. Any variables
-created or used by the eval'd code are now under the control of
-the code in the compartment.
-
-A similar effect applies to I<all> runtime symbol lookups in code
-called from a compartment but not compiled within it.
-
-
-
-=item rdo (FILENAME)
-
-This evaluates the contents of file FILENAME inside the compartment.
-See above documentation on the B<reval> method for further details.
-
-=item root (NAMESPACE)
-
-This method returns the name of the package that is the root of the
-compartment's namespace.
-
-Note that this behaviour differs from version 1.00 of the Safe module
-where the root module could be used to change the namespace. That
-functionality has been withdrawn pending deeper consideration.
-
-=item mask (MASK)
-
-This is a get-or-set method for the compartment's operator mask.
-
-With no MASK argument present, it returns the current operator mask of
-the compartment.
-
-With the MASK argument present, it sets the operator mask for the
-compartment (equivalent to calling the deny_only method).
-
-=back
-
-
-=head2 Some Safety Issues
-
-This section is currently just an outline of some of the things code in
-a compartment might do (intentionally or unintentionally) which can
-have an effect outside the compartment.
-
-=over 8
-
-=item Memory
-
-Consuming all (or nearly all) available memory.
-
-=item CPU
-
-Causing infinite loops etc.
-
-=item Snooping
-
-Copying private information out of your system. Even something as
-simple as your user name is of value to others. Much useful information
-could be gleaned from your environment variables for example.
-
-=item Signals
-
-Causing signals (especially SIGFPE and SIGALARM) to affect your process.
-
-Setting up a signal handler will need to be carefully considered
-and controlled. What mask is in effect when a signal handler
-gets called? If a user can get an imported function to get an
-exception and call the user's signal handler, does that user's
-restricted mask get re-instated before the handler is called?
-Does an imported handler get called with its original mask or
-the user's one?
-
-=item State Changes
-
-Ops such as chdir obviously effect the process as a whole and not just
-the code in the compartment. Ops such as rand and srand have a similar
-but more subtle effect.
-
-=back
-
-=head2 AUTHOR
-
-Originally designed and implemented by Malcolm Beattie.
-
-Reworked to use the Opcode module and other changes added by Tim Bunce.
-
-Currently maintained by the Perl 5 Porters, <perl5-porters at perl.org>.
-
-=cut
-
Deleted: trunk/contrib/perl/ext/POSIX/POSIX.pm
===================================================================
--- trunk/contrib/perl/ext/POSIX/POSIX.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/POSIX/POSIX.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1042 +0,0 @@
-package POSIX;
-use strict;
-use warnings;
-
-our(@ISA, %EXPORT_TAGS, @EXPORT_OK, @EXPORT, $AUTOLOAD, %SIGRT) = ();
-
-our $VERSION = "1.17";
-
-use AutoLoader;
-
-use XSLoader ();
-
-use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD
- F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND
- O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC
- O_WRONLY SEEK_CUR SEEK_END SEEK_SET
- S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG
- S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID
- S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR);
-
-# Grandfather old foo_h form to new :foo_h form
-my $loaded;
-
-sub import {
- load_imports() unless $loaded++;
- my $this = shift;
- my @list = map { m/^\w+_h$/ ? ":$_" : $_ } @_;
- local $Exporter::ExportLevel = 1;
- Exporter::import($this, at list);
-}
-
-sub croak { require Carp; goto &Carp::croak }
-# declare usage to assist AutoLoad
-sub usage;
-
-XSLoader::load 'POSIX', $VERSION;
-
-sub AUTOLOAD {
- no strict;
- no warnings 'uninitialized';
- if ($AUTOLOAD =~ /::(_?[a-z])/) {
- # require AutoLoader;
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD
- }
- local $! = 0;
- my $constname = $AUTOLOAD;
- $constname =~ s/.*:://;
- my ($error, $val) = constant($constname);
- croak $error if $error;
- *$AUTOLOAD = sub { $val };
-
- goto &$AUTOLOAD;
-}
-
-package POSIX::SigAction;
-
-use AutoLoader 'AUTOLOAD';
-
-package POSIX::SigRt;
-
-use AutoLoader 'AUTOLOAD';
-
-use Tie::Hash;
-
-use vars qw($SIGACTION_FLAGS $_SIGRTMIN $_SIGRTMAX $_sigrtn @ISA);
- at POSIX::SigRt::ISA = qw(Tie::StdHash);
-
-$SIGACTION_FLAGS = 0;
-
-tie %POSIX::SIGRT, 'POSIX::SigRt';
-
-sub DESTROY {};
-
-package POSIX;
-
-1;
-__END__
-
-sub usage {
- my ($mess) = @_;
- croak "Usage: POSIX::$mess";
-}
-
-sub redef {
- my ($mess) = @_;
- croak "Use method $mess instead";
-}
-
-sub unimpl {
- my ($mess) = @_;
- $mess =~ s/xxx//;
- croak "Unimplemented: POSIX::$mess";
-}
-
-sub assert {
- usage "assert(expr)" if @_ != 1;
- if (!$_[0]) {
- croak "Assertion failed";
- }
-}
-
-sub tolower {
- usage "tolower(string)" if @_ != 1;
- lc($_[0]);
-}
-
-sub toupper {
- usage "toupper(string)" if @_ != 1;
- uc($_[0]);
-}
-
-sub closedir {
- usage "closedir(dirhandle)" if @_ != 1;
- CORE::closedir($_[0]);
-}
-
-sub opendir {
- usage "opendir(directory)" if @_ != 1;
- my $dirhandle;
- CORE::opendir($dirhandle, $_[0])
- ? $dirhandle
- : undef;
-}
-
-sub readdir {
- usage "readdir(dirhandle)" if @_ != 1;
- CORE::readdir($_[0]);
-}
-
-sub rewinddir {
- usage "rewinddir(dirhandle)" if @_ != 1;
- CORE::rewinddir($_[0]);
-}
-
-sub errno {
- usage "errno()" if @_ != 0;
- $! + 0;
-}
-
-sub creat {
- usage "creat(filename, mode)" if @_ != 2;
- &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1]);
-}
-
-sub fcntl {
- usage "fcntl(filehandle, cmd, arg)" if @_ != 3;
- CORE::fcntl($_[0], $_[1], $_[2]);
-}
-
-sub getgrgid {
- usage "getgrgid(gid)" if @_ != 1;
- CORE::getgrgid($_[0]);
-}
-
-sub getgrnam {
- usage "getgrnam(name)" if @_ != 1;
- CORE::getgrnam($_[0]);
-}
-
-sub atan2 {
- usage "atan2(x,y)" if @_ != 2;
- CORE::atan2($_[0], $_[1]);
-}
-
-sub cos {
- usage "cos(x)" if @_ != 1;
- CORE::cos($_[0]);
-}
-
-sub exp {
- usage "exp(x)" if @_ != 1;
- CORE::exp($_[0]);
-}
-
-sub fabs {
- usage "fabs(x)" if @_ != 1;
- CORE::abs($_[0]);
-}
-
-sub log {
- usage "log(x)" if @_ != 1;
- CORE::log($_[0]);
-}
-
-sub pow {
- usage "pow(x,exponent)" if @_ != 2;
- $_[0] ** $_[1];
-}
-
-sub sin {
- usage "sin(x)" if @_ != 1;
- CORE::sin($_[0]);
-}
-
-sub sqrt {
- usage "sqrt(x)" if @_ != 1;
- CORE::sqrt($_[0]);
-}
-
-sub getpwnam {
- usage "getpwnam(name)" if @_ != 1;
- CORE::getpwnam($_[0]);
-}
-
-sub getpwuid {
- usage "getpwuid(uid)" if @_ != 1;
- CORE::getpwuid($_[0]);
-}
-
-sub longjmp {
- unimpl "longjmp() is C-specific: use die instead";
-}
-
-sub setjmp {
- unimpl "setjmp() is C-specific: use eval {} instead";
-}
-
-sub siglongjmp {
- unimpl "siglongjmp() is C-specific: use die instead";
-}
-
-sub sigsetjmp {
- unimpl "sigsetjmp() is C-specific: use eval {} instead";
-}
-
-sub kill {
- usage "kill(pid, sig)" if @_ != 2;
- CORE::kill $_[1], $_[0];
-}
-
-sub raise {
- usage "raise(sig)" if @_ != 1;
- CORE::kill $_[0], $$; # Is this good enough?
-}
-
-sub offsetof {
- unimpl "offsetof() is C-specific, stopped";
-}
-
-sub clearerr {
- redef "IO::Handle::clearerr()";
-}
-
-sub fclose {
- redef "IO::Handle::close()";
-}
-
-sub fdopen {
- redef "IO::Handle::new_from_fd()";
-}
-
-sub feof {
- redef "IO::Handle::eof()";
-}
-
-sub fgetc {
- redef "IO::Handle::getc()";
-}
-
-sub fgets {
- redef "IO::Handle::gets()";
-}
-
-sub fileno {
- redef "IO::Handle::fileno()";
-}
-
-sub fopen {
- redef "IO::File::open()";
-}
-
-sub fprintf {
- unimpl "fprintf() is C-specific--use printf instead";
-}
-
-sub fputc {
- unimpl "fputc() is C-specific--use print instead";
-}
-
-sub fputs {
- unimpl "fputs() is C-specific--use print instead";
-}
-
-sub fread {
- unimpl "fread() is C-specific--use read instead";
-}
-
-sub freopen {
- unimpl "freopen() is C-specific--use open instead";
-}
-
-sub fscanf {
- unimpl "fscanf() is C-specific--use <> and regular expressions instead";
-}
-
-sub fseek {
- redef "IO::Seekable::seek()";
-}
-
-sub fsync {
- redef "IO::Handle::sync()";
-}
-
-sub ferror {
- redef "IO::Handle::error()";
-}
-
-sub fflush {
- redef "IO::Handle::flush()";
-}
-
-sub fgetpos {
- redef "IO::Seekable::getpos()";
-}
-
-sub fsetpos {
- redef "IO::Seekable::setpos()";
-}
-
-sub ftell {
- redef "IO::Seekable::tell()";
-}
-
-sub fwrite {
- unimpl "fwrite() is C-specific--use print instead";
-}
-
-sub getc {
- usage "getc(handle)" if @_ != 1;
- CORE::getc($_[0]);
-}
-
-sub getchar {
- usage "getchar()" if @_ != 0;
- CORE::getc(STDIN);
-}
-
-sub gets {
- usage "gets()" if @_ != 0;
- scalar <STDIN>;
-}
-
-sub perror {
- print STDERR "@_: " if @_;
- print STDERR $!,"\n";
-}
-
-sub printf {
- usage "printf(pattern, args...)" if @_ < 1;
- CORE::printf STDOUT @_;
-}
-
-sub putc {
- unimpl "putc() is C-specific--use print instead";
-}
-
-sub putchar {
- unimpl "putchar() is C-specific--use print instead";
-}
-
-sub puts {
- unimpl "puts() is C-specific--use print instead";
-}
-
-sub remove {
- usage "remove(filename)" if @_ != 1;
- (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0]);
-}
-
-sub rename {
- usage "rename(oldfilename, newfilename)" if @_ != 2;
- CORE::rename($_[0], $_[1]);
-}
-
-sub rewind {
- usage "rewind(filehandle)" if @_ != 1;
- CORE::seek($_[0],0,0);
-}
-
-sub scanf {
- unimpl "scanf() is C-specific--use <> and regular expressions instead";
-}
-
-sub sprintf {
- usage "sprintf(pattern,args)" if @_ == 0;
- CORE::sprintf(shift, at _);
-}
-
-sub sscanf {
- unimpl "sscanf() is C-specific--use regular expressions instead";
-}
-
-sub tmpfile {
- redef "IO::File::new_tmpfile()";
-}
-
-sub ungetc {
- redef "IO::Handle::ungetc()";
-}
-
-sub vfprintf {
- unimpl "vfprintf() is C-specific";
-}
-
-sub vprintf {
- unimpl "vprintf() is C-specific";
-}
-
-sub vsprintf {
- unimpl "vsprintf() is C-specific";
-}
-
-sub abs {
- usage "abs(x)" if @_ != 1;
- CORE::abs($_[0]);
-}
-
-sub atexit {
- unimpl "atexit() is C-specific: use END {} instead";
-}
-
-sub atof {
- unimpl "atof() is C-specific, stopped";
-}
-
-sub atoi {
- unimpl "atoi() is C-specific, stopped";
-}
-
-sub atol {
- unimpl "atol() is C-specific, stopped";
-}
-
-sub bsearch {
- unimpl "bsearch() not supplied";
-}
-
-sub calloc {
- unimpl "calloc() is C-specific, stopped";
-}
-
-sub div {
- unimpl "div() is C-specific, use /, % and int instead";
-}
-
-sub exit {
- usage "exit(status)" if @_ != 1;
- CORE::exit($_[0]);
-}
-
-sub free {
- unimpl "free() is C-specific, stopped";
-}
-
-sub getenv {
- usage "getenv(name)" if @_ != 1;
- $ENV{$_[0]};
-}
-
-sub labs {
- unimpl "labs() is C-specific, use abs instead";
-}
-
-sub ldiv {
- unimpl "ldiv() is C-specific, use /, % and int instead";
-}
-
-sub malloc {
- unimpl "malloc() is C-specific, stopped";
-}
-
-sub qsort {
- unimpl "qsort() is C-specific, use sort instead";
-}
-
-sub rand {
- unimpl "rand() is non-portable, use Perl's rand instead";
-}
-
-sub realloc {
- unimpl "realloc() is C-specific, stopped";
-}
-
-sub srand {
- unimpl "srand()";
-}
-
-sub system {
- usage "system(command)" if @_ != 1;
- CORE::system($_[0]);
-}
-
-sub memchr {
- unimpl "memchr() is C-specific, use index() instead";
-}
-
-sub memcmp {
- unimpl "memcmp() is C-specific, use eq instead";
-}
-
-sub memcpy {
- unimpl "memcpy() is C-specific, use = instead";
-}
-
-sub memmove {
- unimpl "memmove() is C-specific, use = instead";
-}
-
-sub memset {
- unimpl "memset() is C-specific, use x instead";
-}
-
-sub strcat {
- unimpl "strcat() is C-specific, use .= instead";
-}
-
-sub strchr {
- unimpl "strchr() is C-specific, use index() instead";
-}
-
-sub strcmp {
- unimpl "strcmp() is C-specific, use eq instead";
-}
-
-sub strcpy {
- unimpl "strcpy() is C-specific, use = instead";
-}
-
-sub strcspn {
- unimpl "strcspn() is C-specific, use regular expressions instead";
-}
-
-sub strerror {
- usage "strerror(errno)" if @_ != 1;
- local $! = $_[0];
- $! . "";
-}
-
-sub strlen {
- unimpl "strlen() is C-specific, use length instead";
-}
-
-sub strncat {
- unimpl "strncat() is C-specific, use .= instead";
-}
-
-sub strncmp {
- unimpl "strncmp() is C-specific, use eq instead";
-}
-
-sub strncpy {
- unimpl "strncpy() is C-specific, use = instead";
-}
-
-sub strpbrk {
- unimpl "strpbrk() is C-specific, stopped";
-}
-
-sub strrchr {
- unimpl "strrchr() is C-specific, use rindex() instead";
-}
-
-sub strspn {
- unimpl "strspn() is C-specific, stopped";
-}
-
-sub strstr {
- usage "strstr(big, little)" if @_ != 2;
- CORE::index($_[0], $_[1]);
-}
-
-sub strtok {
- unimpl "strtok() is C-specific, stopped";
-}
-
-sub chmod {
- usage "chmod(mode, filename)" if @_ != 2;
- CORE::chmod($_[0], $_[1]);
-}
-
-sub fstat {
- usage "fstat(fd)" if @_ != 1;
- local *TMP;
- CORE::open(TMP, "<&$_[0]"); # Gross.
- my @l = CORE::stat(TMP);
- CORE::close(TMP);
- @l;
-}
-
-sub mkdir {
- usage "mkdir(directoryname, mode)" if @_ != 2;
- CORE::mkdir($_[0], $_[1]);
-}
-
-sub stat {
- usage "stat(filename)" if @_ != 1;
- CORE::stat($_[0]);
-}
-
-sub umask {
- usage "umask(mask)" if @_ != 1;
- CORE::umask($_[0]);
-}
-
-sub wait {
- usage "wait()" if @_ != 0;
- CORE::wait();
-}
-
-sub waitpid {
- usage "waitpid(pid, options)" if @_ != 2;
- CORE::waitpid($_[0], $_[1]);
-}
-
-sub gmtime {
- usage "gmtime(time)" if @_ != 1;
- CORE::gmtime($_[0]);
-}
-
-sub localtime {
- usage "localtime(time)" if @_ != 1;
- CORE::localtime($_[0]);
-}
-
-sub time {
- usage "time()" if @_ != 0;
- CORE::time;
-}
-
-sub alarm {
- usage "alarm(seconds)" if @_ != 1;
- CORE::alarm($_[0]);
-}
-
-sub chdir {
- usage "chdir(directory)" if @_ != 1;
- CORE::chdir($_[0]);
-}
-
-sub chown {
- usage "chown(uid, gid, filename)" if @_ != 3;
- CORE::chown($_[0], $_[1], $_[2]);
-}
-
-sub execl {
- unimpl "execl() is C-specific, stopped";
-}
-
-sub execle {
- unimpl "execle() is C-specific, stopped";
-}
-
-sub execlp {
- unimpl "execlp() is C-specific, stopped";
-}
-
-sub execv {
- unimpl "execv() is C-specific, stopped";
-}
-
-sub execve {
- unimpl "execve() is C-specific, stopped";
-}
-
-sub execvp {
- unimpl "execvp() is C-specific, stopped";
-}
-
-sub fork {
- usage "fork()" if @_ != 0;
- CORE::fork;
-}
-
-sub getegid {
- usage "getegid()" if @_ != 0;
- $) + 0;
-}
-
-sub geteuid {
- usage "geteuid()" if @_ != 0;
- $> + 0;
-}
-
-sub getgid {
- usage "getgid()" if @_ != 0;
- $( + 0;
-}
-
-sub getgroups {
- usage "getgroups()" if @_ != 0;
- my %seen;
- grep(!$seen{$_}++, split(' ', $) ));
-}
-
-sub getlogin {
- usage "getlogin()" if @_ != 0;
- CORE::getlogin();
-}
-
-sub getpgrp {
- usage "getpgrp()" if @_ != 0;
- CORE::getpgrp;
-}
-
-sub getpid {
- usage "getpid()" if @_ != 0;
- $$;
-}
-
-sub getppid {
- usage "getppid()" if @_ != 0;
- CORE::getppid;
-}
-
-sub getuid {
- usage "getuid()" if @_ != 0;
- $<;
-}
-
-sub isatty {
- usage "isatty(filehandle)" if @_ != 1;
- -t $_[0];
-}
-
-sub link {
- usage "link(oldfilename, newfilename)" if @_ != 2;
- CORE::link($_[0], $_[1]);
-}
-
-sub rmdir {
- usage "rmdir(directoryname)" if @_ != 1;
- CORE::rmdir($_[0]);
-}
-
-sub setbuf {
- redef "IO::Handle::setbuf()";
-}
-
-sub setvbuf {
- redef "IO::Handle::setvbuf()";
-}
-
-sub sleep {
- usage "sleep(seconds)" if @_ != 1;
- $_[0] - CORE::sleep($_[0]);
-}
-
-sub unlink {
- usage "unlink(filename)" if @_ != 1;
- CORE::unlink($_[0]);
-}
-
-sub utime {
- usage "utime(filename, atime, mtime)" if @_ != 3;
- CORE::utime($_[1], $_[2], $_[0]);
-}
-
-sub load_imports {
-%EXPORT_TAGS = (
-
- assert_h => [qw(assert NDEBUG)],
-
- ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower
- isprint ispunct isspace isupper isxdigit tolower toupper)],
-
- dirent_h => [],
-
- errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT
- EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED
- ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT
- EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS
- EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK
- EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH
- ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM
- ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
- ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM
- EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE
- ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT
- ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY
- EUSERS EWOULDBLOCK EXDEV errno)],
-
- fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK
- F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK
- O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK
- O_RDONLY O_RDWR O_TRUNC O_WRONLY
- creat
- SEEK_CUR SEEK_END SEEK_SET
- S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
- S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID
- S_IWGRP S_IWOTH S_IWUSR)],
-
- float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG
- DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP
- DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP
- FLT_DIG FLT_EPSILON FLT_MANT_DIG
- FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP
- FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP
- FLT_RADIX FLT_ROUNDS
- LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG
- LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP
- LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)],
-
- grp_h => [],
-
- limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX
- INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON
- MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX
- PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN
- SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX
- ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX
- _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT
- _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX
- _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX
- _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)],
-
- locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES
- LC_MONETARY LC_NUMERIC LC_TIME NULL
- localeconv setlocale)],
-
- math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod
- frexp ldexp log10 modf pow sinh tan tanh)],
-
- pwd_h => [],
-
- setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)],
-
- signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK
- SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM
- SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL
- SIGPIPE %SIGRT SIGRTMIN SIGRTMAX SIGQUIT SIGSEGV SIGSTOP
- SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2
- SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK
- raise sigaction signal sigpending sigprocmask sigsuspend)],
-
- stdarg_h => [],
-
- stddef_h => [qw(NULL offsetof)],
-
- stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
- L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET
- STREAM_MAX TMP_MAX stderr stdin stdout
- clearerr fclose fdopen feof ferror fflush fgetc fgetpos
- fgets fopen fprintf fputc fputs fread freopen
- fscanf fseek fsetpos ftell fwrite getchar gets
- perror putc putchar puts remove rewind
- scanf setbuf setvbuf sscanf tmpfile tmpnam
- ungetc vfprintf vprintf vsprintf)],
-
- stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX
- abort atexit atof atoi atol bsearch calloc div
- free getenv labs ldiv malloc mblen mbstowcs mbtowc
- qsort realloc strtod strtol strtoul wcstombs wctomb)],
-
- string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat
- strchr strcmp strcoll strcpy strcspn strerror strlen
- strncat strncmp strncpy strpbrk strrchr strspn strstr
- strtok strxfrm)],
-
- sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU
- S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG
- S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
- fstat mkfifo)],
-
- sys_times_h => [],
-
- sys_types_h => [],
-
- sys_utsname_h => [qw(uname)],
-
- sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED
- WNOHANG WSTOPSIG WTERMSIG WUNTRACED)],
-
- termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400
- B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL
- CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK
- ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR
- INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST
- PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION
- TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW
- TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART
- VSTOP VSUSP VTIME
- cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain
- tcflow tcflush tcgetattr tcsendbreak tcsetattr )],
-
- time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime
- difftime mktime strftime tzset tzname)],
-
- unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET
- STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK
- _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON
- _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX
- _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED
- _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS
- _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX
- _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL
- _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS
- _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
- _exit access ctermid cuserid
- dup2 dup execl execle execlp execv execve execvp
- fpathconf fsync getcwd getegid geteuid getgid getgroups
- getpid getuid isatty lseek pathconf pause setgid setpgid
- setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)],
-
- utime_h => [],
-
-);
-
-# Exporter::export_tags();
-{
- # De-duplicate the export list:
- my %export;
- @export{map {@$_} values %EXPORT_TAGS} = ();
- # Doing the de-dup with a temporary hash has the advantage that the SVs in
- # @EXPORT are actually shared hash key sacalars, which will save some memory.
- push @EXPORT, keys %export;
-}
-
- at EXPORT_OK = qw(
- abs
- alarm
- atan2
- chdir
- chmod
- chown
- close
- closedir
- cos
- exit
- exp
- fcntl
- fileno
- fork
- getc
- getgrgid
- getgrnam
- getlogin
- getpgrp
- getppid
- getpwnam
- getpwuid
- gmtime
- isatty
- kill
- lchown
- link
- localtime
- log
- mkdir
- nice
- open
- opendir
- pipe
- printf
- rand
- read
- readdir
- rename
- rewinddir
- rmdir
- sin
- sleep
- sprintf
- sqrt
- srand
- stat
- system
- time
- times
- umask
- unlink
- utime
- wait
- waitpid
- write
-);
-
-require Exporter;
-}
-
-package POSIX::SigAction;
-
-sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] }
-sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} };
-sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} };
-sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} };
-sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} };
-
-package POSIX::SigRt;
-
-
-sub _init {
- $_SIGRTMIN = &POSIX::SIGRTMIN;
- $_SIGRTMAX = &POSIX::SIGRTMAX;
- $_sigrtn = $_SIGRTMAX - $_SIGRTMIN;
-}
-
-sub _croak {
- &_init unless defined $_sigrtn;
- die "POSIX::SigRt not available" unless defined $_sigrtn && $_sigrtn > 0;
-}
-
-sub _getsig {
- &_croak;
- my $rtsig = $_[0];
- # Allow (SIGRT)?MIN( + n)?, a common idiom when doing these things in C.
- $rtsig = $_SIGRTMIN + ($1 || 0)
- if $rtsig =~ /^(?:(?:SIG)?RT)?MIN(\s*\+\s*(\d+))?$/;
- return $rtsig;
-}
-
-sub _exist {
- my $rtsig = _getsig($_[1]);
- my $ok = $rtsig >= $_SIGRTMIN && $rtsig <= $_SIGRTMAX;
- ($rtsig, $ok);
-}
-
-sub _check {
- my ($rtsig, $ok) = &_exist;
- die "No POSIX::SigRt signal $_[1] (valid range SIGRTMIN..SIGRTMAX, or $_SIGRTMIN..$_SIGRTMAX)"
- unless $ok;
- return $rtsig;
-}
-
-sub new {
- my ($rtsig, $handler, $flags) = @_;
- my $sigset = POSIX::SigSet->new($rtsig);
- my $sigact = POSIX::SigAction->new($handler,
- $sigset,
- $flags);
- POSIX::sigaction($rtsig, $sigact);
-}
-
-sub EXISTS { &_exist }
-sub FETCH { my $rtsig = &_check;
- my $oa = POSIX::SigAction->new();
- POSIX::sigaction($rtsig, undef, $oa);
- return $oa->{HANDLER} }
-sub STORE { my $rtsig = &_check; new($rtsig, $_[2], $SIGACTION_FLAGS) }
-sub DELETE { delete $SIG{ &_check } }
-sub CLEAR { &_exist; delete @SIG{ &POSIX::SIGRTMIN .. &POSIX::SIGRTMAX } }
-sub SCALAR { &_croak; $_sigrtn + 1 }
Deleted: trunk/contrib/perl/ext/POSIX/POSIX.pod
===================================================================
--- trunk/contrib/perl/ext/POSIX/POSIX.pod 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/POSIX/POSIX.pod 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,2210 +0,0 @@
-=head1 NAME
-
-POSIX - Perl interface to IEEE Std 1003.1
-
-=head1 SYNOPSIS
-
- use POSIX;
- use POSIX qw(setsid);
- use POSIX qw(:errno_h :fcntl_h);
-
- printf "EINTR is %d\n", EINTR;
-
- $sess_id = POSIX::setsid();
-
- $fd = POSIX::open($path, O_CREAT|O_EXCL|O_WRONLY, 0644);
- # note: that's a filedescriptor, *NOT* a filehandle
-
-=head1 DESCRIPTION
-
-The POSIX module permits you to access all (or nearly all) the standard
-POSIX 1003.1 identifiers. Many of these identifiers have been given Perl-ish
-interfaces.
-
-I<Everything is exported by default> with the exception of any POSIX
-functions with the same name as a built-in Perl function, such as
-C<abs>, C<alarm>, C<rmdir>, C<write>, etc.., which will be exported
-only if you ask for them explicitly. This is an unfortunate backwards
-compatibility feature. You can stop the exporting by saying C<use
-POSIX ()> and then use the fully qualified names (ie. C<POSIX::SEEK_END>).
-
-This document gives a condensed list of the features available in the POSIX
-module. Consult your operating system's manpages for general information on
-most features. Consult L<perlfunc> for functions which are noted as being
-identical to Perl's builtin functions.
-
-The first section describes POSIX functions from the 1003.1 specification.
-The second section describes some classes for signal objects, TTY objects,
-and other miscellaneous objects. The remaining sections list various
-constants and macros in an organization which roughly follows IEEE Std
-1003.1b-1993.
-
-=head1 NOTE
-
-The POSIX module is probably the most complex Perl module supplied with
-the standard distribution. It incorporates autoloading, namespace games,
-and dynamic loading of code that's in Perl, C, or both. It's a great
-source of wisdom.
-
-=head1 CAVEATS
-
-A few functions are not implemented because they are C specific. If you
-attempt to call these, they will print a message telling you that they
-aren't implemented, and suggest using the Perl equivalent should one
-exist. For example, trying to access the setjmp() call will elicit the
-message "setjmp() is C-specific: use eval {} instead".
-
-Furthermore, some evil vendors will claim 1003.1 compliance, but in fact
-are not so: they will not pass the PCTS (POSIX Compliance Test Suites).
-For example, one vendor may not define EDEADLK, or the semantics of the
-errno values set by open(2) might not be quite right. Perl does not
-attempt to verify POSIX compliance. That means you can currently
-successfully say "use POSIX", and then later in your program you find
-that your vendor has been lax and there's no usable ICANON macro after
-all. This could be construed to be a bug.
-
-=head1 FUNCTIONS
-
-=over 8
-
-=item _exit
-
-This is identical to the C function C<_exit()>. It exits the program
-immediately which means among other things buffered I/O is B<not> flushed.
-
-Note that when using threads and in Linux this is B<not> a good way to
-exit a thread because in Linux processes and threads are kind of the
-same thing (Note: while this is the situation in early 2003 there are
-projects under way to have threads with more POSIXly semantics in Linux).
-If you want not to return from a thread, detach the thread.
-
-=item abort
-
-This is identical to the C function C<abort()>. It terminates the
-process with a C<SIGABRT> signal unless caught by a signal handler or
-if the handler does not return normally (it e.g. does a C<longjmp>).
-
-=item abs
-
-This is identical to Perl's builtin C<abs()> function, returning
-the absolute value of its numerical argument.
-
-=item access
-
-Determines the accessibility of a file.
-
- if( POSIX::access( "/", &POSIX::R_OK ) ){
- print "have read permission\n";
- }
-
-Returns C<undef> on failure. Note: do not use C<access()> for
-security purposes. Between the C<access()> call and the operation
-you are preparing for the permissions might change: a classic
-I<race condition>.
-
-=item acos
-
-This is identical to the C function C<acos()>, returning
-the arcus cosine of its numerical argument. See also L<Math::Trig>.
-
-=item alarm
-
-This is identical to Perl's builtin C<alarm()> function,
-either for arming or disarming the C<SIGARLM> timer.
-
-=item asctime
-
-This is identical to the C function C<asctime()>. It returns
-a string of the form
-
- "Fri Jun 2 18:22:13 2000\n\0"
-
-and it is called thusly
-
- $asctime = asctime($sec, $min, $hour, $mday, $mon, $year,
- $wday, $yday, $isdst);
-
-The C<$mon> is zero-based: January equals C<0>. The C<$year> is
-1900-based: 2001 equals C<101>. C<$wday> and C<$yday> default to zero
-(and are usually ignored anyway), and C<$isdst> defaults to -1.
-
-=item asin
-
-This is identical to the C function C<asin()>, returning
-the arcus sine of its numerical argument. See also L<Math::Trig>.
-
-=item assert
-
-Unimplemented, but you can use L<perlfunc/die> and the L<Carp> module
-to achieve similar things.
-
-=item atan
-
-This is identical to the C function C<atan()>, returning the
-arcus tangent of its numerical argument. See also L<Math::Trig>.
-
-=item atan2
-
-This is identical to Perl's builtin C<atan2()> function, returning
-the arcus tangent defined by its two numerical arguments, the I<y>
-coordinate and the I<x> coordinate. See also L<Math::Trig>.
-
-=item atexit
-
-atexit() is C-specific: use C<END {}> instead, see L<perlsub>.
-
-=item atof
-
-atof() is C-specific. Perl converts strings to numbers transparently.
-If you need to force a scalar to a number, add a zero to it.
-
-=item atoi
-
-atoi() is C-specific. Perl converts strings to numbers transparently.
-If you need to force a scalar to a number, add a zero to it.
-If you need to have just the integer part, see L<perlfunc/int>.
-
-=item atol
-
-atol() is C-specific. Perl converts strings to numbers transparently.
-If you need to force a scalar to a number, add a zero to it.
-If you need to have just the integer part, see L<perlfunc/int>.
-
-=item bsearch
-
-bsearch() not supplied. For doing binary search on wordlists,
-see L<Search::Dict>.
-
-=item calloc
-
-calloc() is C-specific. Perl does memory management transparently.
-
-=item ceil
-
-This is identical to the C function C<ceil()>, returning the smallest
-integer value greater than or equal to the given numerical argument.
-
-=item chdir
-
-This is identical to Perl's builtin C<chdir()> function, allowing
-one to change the working (default) directory, see L<perlfunc/chdir>.
-
-=item chmod
-
-This is identical to Perl's builtin C<chmod()> function, allowing
-one to change file and directory permissions, see L<perlfunc/chmod>.
-
-=item chown
-
-This is identical to Perl's builtin C<chown()> function, allowing one
-to change file and directory owners and groups, see L<perlfunc/chown>.
-
-=item clearerr
-
-Use the method C<IO::Handle::clearerr()> instead, to reset the error
-state (if any) and EOF state (if any) of the given stream.
-
-=item clock
-
-This is identical to the C function C<clock()>, returning the
-amount of spent processor time in microseconds.
-
-=item close
-
-Close the file. This uses file descriptors such as those obtained by calling
-C<POSIX::open>.
-
- $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
- POSIX::close( $fd );
-
-Returns C<undef> on failure.
-
-See also L<perlfunc/close>.
-
-=item closedir
-
-This is identical to Perl's builtin C<closedir()> function for closing
-a directory handle, see L<perlfunc/closedir>.
-
-=item cos
-
-This is identical to Perl's builtin C<cos()> function, for returning
-the cosine of its numerical argument, see L<perlfunc/cos>.
-See also L<Math::Trig>.
-
-=item cosh
-
-This is identical to the C function C<cosh()>, for returning
-the hyperbolic cosine of its numeric argument. See also L<Math::Trig>.
-
-=item creat
-
-Create a new file. This returns a file descriptor like the ones returned by
-C<POSIX::open>. Use C<POSIX::close> to close the file.
-
- $fd = POSIX::creat( "foo", 0611 );
- POSIX::close( $fd );
-
-See also L<perlfunc/sysopen> and its C<O_CREAT> flag.
-
-=item ctermid
-
-Generates the path name for the controlling terminal.
-
- $path = POSIX::ctermid();
-
-=item ctime
-
-This is identical to the C function C<ctime()> and equivalent
-to C<asctime(localtime(...))>, see L</asctime> and L</localtime>.
-
-=item cuserid
-
-Get the login name of the owner of the current process.
-
- $name = POSIX::cuserid();
-
-=item difftime
-
-This is identical to the C function C<difftime()>, for returning
-the time difference (in seconds) between two times (as returned
-by C<time()>), see L</time>.
-
-=item div
-
-div() is C-specific, use L<perlfunc/int> on the usual C</> division and
-the modulus C<%>.
-
-=item dup
-
-This is similar to the C function C<dup()>, for duplicating a file
-descriptor.
-
-This uses file descriptors such as those obtained by calling
-C<POSIX::open>.
-
-Returns C<undef> on failure.
-
-=item dup2
-
-This is similar to the C function C<dup2()>, for duplicating a file
-descriptor to an another known file descriptor.
-
-This uses file descriptors such as those obtained by calling
-C<POSIX::open>.
-
-Returns C<undef> on failure.
-
-=item errno
-
-Returns the value of errno.
-
- $errno = POSIX::errno();
-
-This identical to the numerical values of the C<$!>, see L<perlvar/$ERRNO>.
-
-=item execl
-
-execl() is C-specific, see L<perlfunc/exec>.
-
-=item execle
-
-execle() is C-specific, see L<perlfunc/exec>.
-
-=item execlp
-
-execlp() is C-specific, see L<perlfunc/exec>.
-
-=item execv
-
-execv() is C-specific, see L<perlfunc/exec>.
-
-=item execve
-
-execve() is C-specific, see L<perlfunc/exec>.
-
-=item execvp
-
-execvp() is C-specific, see L<perlfunc/exec>.
-
-=item exit
-
-This is identical to Perl's builtin C<exit()> function for exiting the
-program, see L<perlfunc/exit>.
-
-=item exp
-
-This is identical to Perl's builtin C<exp()> function for
-returning the exponent (I<e>-based) of the numerical argument,
-see L<perlfunc/exp>.
-
-=item fabs
-
-This is identical to Perl's builtin C<abs()> function for returning
-the absolute value of the numerical argument, see L<perlfunc/abs>.
-
-=item fclose
-
-Use method C<IO::Handle::close()> instead, or see L<perlfunc/close>.
-
-=item fcntl
-
-This is identical to Perl's builtin C<fcntl()> function,
-see L<perlfunc/fcntl>.
-
-=item fdopen
-
-Use method C<IO::Handle::new_from_fd()> instead, or see L<perlfunc/open>.
-
-=item feof
-
-Use method C<IO::Handle::eof()> instead, or see L<perlfunc/eof>.
-
-=item ferror
-
-Use method C<IO::Handle::error()> instead.
-
-=item fflush
-
-Use method C<IO::Handle::flush()> instead.
-See also L<perlvar/$OUTPUT_AUTOFLUSH>.
-
-=item fgetc
-
-Use method C<IO::Handle::getc()> instead, or see L<perlfunc/read>.
-
-=item fgetpos
-
-Use method C<IO::Seekable::getpos()> instead, or see L<L/seek>.
-
-=item fgets
-
-Use method C<IO::Handle::gets()> instead. Similar to E<lt>E<gt>, also known
-as L<perlfunc/readline>.
-
-=item fileno
-
-Use method C<IO::Handle::fileno()> instead, or see L<perlfunc/fileno>.
-
-=item floor
-
-This is identical to the C function C<floor()>, returning the largest
-integer value less than or equal to the numerical argument.
-
-=item fmod
-
-This is identical to the C function C<fmod()>.
-
- $r = fmod($x, $y);
-
-It returns the remainder C<$r = $x - $n*$y>, where C<$n = trunc($x/$y)>.
-The C<$r> has the same sign as C<$x> and magnitude (absolute value)
-less than the magnitude of C<$y>.
-
-=item fopen
-
-Use method C<IO::File::open()> instead, or see L<perlfunc/open>.
-
-=item fork
-
-This is identical to Perl's builtin C<fork()> function
-for duplicating the current process, see L<perlfunc/fork>
-and L<perlfork> if you are in Windows.
-
-=item fpathconf
-
-Retrieves the value of a configurable limit on a file or directory. This
-uses file descriptors such as those obtained by calling C<POSIX::open>.
-
-The following will determine the maximum length of the longest allowable
-pathname on the filesystem which holds C</var/foo>.
-
- $fd = POSIX::open( "/var/foo", &POSIX::O_RDONLY );
- $path_max = POSIX::fpathconf( $fd, &POSIX::_PC_PATH_MAX );
-
-Returns C<undef> on failure.
-
-=item fprintf
-
-fprintf() is C-specific, see L<perlfunc/printf> instead.
-
-=item fputc
-
-fputc() is C-specific, see L<perlfunc/print> instead.
-
-=item fputs
-
-fputs() is C-specific, see L<perlfunc/print> instead.
-
-=item fread
-
-fread() is C-specific, see L<perlfunc/read> instead.
-
-=item free
-
-free() is C-specific. Perl does memory management transparently.
-
-=item freopen
-
-freopen() is C-specific, see L<perlfunc/open> instead.
-
-=item frexp
-
-Return the mantissa and exponent of a floating-point number.
-
- ($mantissa, $exponent) = POSIX::frexp( 1.234e56 );
-
-=item fscanf
-
-fscanf() is C-specific, use E<lt>E<gt> and regular expressions instead.
-
-=item fseek
-
-Use method C<IO::Seekable::seek()> instead, or see L<perlfunc/seek>.
-
-=item fsetpos
-
-Use method C<IO::Seekable::setpos()> instead, or seek L<perlfunc/seek>.
-
-=item fstat
-
-Get file status. This uses file descriptors such as those obtained by
-calling C<POSIX::open>. The data returned is identical to the data from
-Perl's builtin C<stat> function.
-
- $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
- @stats = POSIX::fstat( $fd );
-
-=item fsync
-
-Use method C<IO::Handle::sync()> instead.
-
-=item ftell
-
-Use method C<IO::Seekable::tell()> instead, or see L<perlfunc/tell>.
-
-=item fwrite
-
-fwrite() is C-specific, see L<perlfunc/print> instead.
-
-=item getc
-
-This is identical to Perl's builtin C<getc()> function,
-see L<perlfunc/getc>.
-
-=item getchar
-
-Returns one character from STDIN. Identical to Perl's C<getc()>,
-see L<perlfunc/getc>.
-
-=item getcwd
-
-Returns the name of the current working directory.
-See also L<Cwd>.
-
-=item getegid
-
-Returns the effective group identifier. Similar to Perl' s builtin
-variable C<$(>, see L<perlvar/$EGID>.
-
-=item getenv
-
-Returns the value of the specified environment variable.
-The same information is available through the C<%ENV> array.
-
-=item geteuid
-
-Returns the effective user identifier. Identical to Perl's builtin C<$E<gt>>
-variable, see L<perlvar/$EUID>.
-
-=item getgid
-
-Returns the user's real group identifier. Similar to Perl's builtin
-variable C<$)>, see L<perlvar/$GID>.
-
-=item getgrgid
-
-This is identical to Perl's builtin C<getgrgid()> function for
-returning group entries by group identifiers, see
-L<perlfunc/getgrgid>.
-
-=item getgrnam
-
-This is identical to Perl's builtin C<getgrnam()> function for
-returning group entries by group names, see L<perlfunc/getgrnam>.
-
-=item getgroups
-
-Returns the ids of the user's supplementary groups. Similar to Perl's
-builtin variable C<$)>, see L<perlvar/$GID>.
-
-=item getlogin
-
-This is identical to Perl's builtin C<getlogin()> function for
-returning the user name associated with the current session, see
-L<perlfunc/getlogin>.
-
-=item getpgrp
-
-This is identical to Perl's builtin C<getpgrp()> function for
-returning the process group identifier of the current process, see
-L<perlfunc/getpgrp>.
-
-=item getpid
-
-Returns the process identifier. Identical to Perl's builtin
-variable C<$$>, see L<perlvar/$PID>.
-
-=item getppid
-
-This is identical to Perl's builtin C<getppid()> function for
-returning the process identifier of the parent process of the current
-process , see L<perlfunc/getppid>.
-
-=item getpwnam
-
-This is identical to Perl's builtin C<getpwnam()> function for
-returning user entries by user names, see L<perlfunc/getpwnam>.
-
-=item getpwuid
-
-This is identical to Perl's builtin C<getpwuid()> function for
-returning user entries by user identifiers, see L<perlfunc/getpwuid>.
-
-=item gets
-
-Returns one line from C<STDIN>, similar to E<lt>E<gt>, also known
-as the C<readline()> function, see L<perlfunc/readline>.
-
-B<NOTE>: if you have C programs that still use C<gets()>, be very
-afraid. The C<gets()> function is a source of endless grief because
-it has no buffer overrun checks. It should B<never> be used. The
-C<fgets()> function should be preferred instead.
-
-=item getuid
-
-Returns the user's identifier. Identical to Perl's builtin C<$E<lt>> variable,
-see L<perlvar/$UID>.
-
-=item gmtime
-
-This is identical to Perl's builtin C<gmtime()> function for
-converting seconds since the epoch to a date in Greenwich Mean Time,
-see L<perlfunc/gmtime>.
-
-=item isalnum
-
-This is identical to the C function, except that it can apply to a
-single character or to a whole string. Note that locale settings may
-affect what characters are considered C<isalnum>. Does not work on
-Unicode characters code point 256 or higher. Consider using regular
-expressions and the C</[[:alnum:]]/> construct instead, or possibly
-the C</\w/> construct.
-
-=item isalpha
-
-This is identical to the C function, except that it can apply to
-a single character or to a whole string. Note that locale settings
-may affect what characters are considered C<isalpha>. Does not work
-on Unicode characters code point 256 or higher. Consider using regular
-expressions and the C</[[:alpha:]]/> construct instead.
-
-=item isatty
-
-Returns a boolean indicating whether the specified filehandle is connected
-to a tty. Similar to the C<-t> operator, see L<perlfunc/-X>.
-
-=item iscntrl
-
-This is identical to the C function, except that it can apply to
-a single character or to a whole string. Note that locale settings
-may affect what characters are considered C<iscntrl>. Does not work
-on Unicode characters code point 256 or higher. Consider using regular
-expressions and the C</[[:cntrl:]]/> construct instead.
-
-=item isdigit
-
-This is identical to the C function, except that it can apply to
-a single character or to a whole string. Note that locale settings
-may affect what characters are considered C<isdigit> (unlikely, but
-still possible). Does not work on Unicode characters code point 256
-or higher. Consider using regular expressions and the C</[[:digit:]]/>
-construct instead, or the C</\d/> construct.
-
-=item isgraph
-
-This is identical to the C function, except that it can apply to
-a single character or to a whole string. Note that locale settings
-may affect what characters are considered C<isgraph>. Does not work
-on Unicode characters code point 256 or higher. Consider using regular
-expressions and the C</[[:graph:]]/> construct instead.
-
-=item islower
-
-This is identical to the C function, except that it can apply to
-a single character or to a whole string. Note that locale settings
-may affect what characters are considered C<islower>. Does not work
-on Unicode characters code point 256 or higher. Consider using regular
-expressions and the C</[[:lower:]]/> construct instead. Do B<not> use
-C</[a-z]/>.
-
-=item isprint
-
-This is identical to the C function, except that it can apply to
-a single character or to a whole string. Note that locale settings
-may affect what characters are considered C<isprint>. Does not work
-on Unicode characters code point 256 or higher. Consider using regular
-expressions and the C</[[:print:]]/> construct instead.
-
-=item ispunct
-
-This is identical to the C function, except that it can apply to
-a single character or to a whole string. Note that locale settings
-may affect what characters are considered C<ispunct>. Does not work
-on Unicode characters code point 256 or higher. Consider using regular
-expressions and the C</[[:punct:]]/> construct instead.
-
-=item isspace
-
-This is identical to the C function, except that it can apply to
-a single character or to a whole string. Note that locale settings
-may affect what characters are considered C<isspace>. Does not work
-on Unicode characters code point 256 or higher. Consider using regular
-expressions and the C</[[:space:]]/> construct instead, or the C</\s/>
-construct. (Note that C</\s/> and C</[[:space:]]/> are slightly
-different in that C</[[:space:]]/> can normally match a vertical tab,
-while C</\s/> does not.)
-
-=item isupper
-
-This is identical to the C function, except that it can apply to
-a single character or to a whole string. Note that locale settings
-may affect what characters are considered C<isupper>. Does not work
-on Unicode characters code point 256 or higher. Consider using regular
-expressions and the C</[[:upper:]]/> construct instead. Do B<not> use
-C</[A-Z]/>.
-
-=item isxdigit
-
-This is identical to the C function, except that it can apply to a single
-character or to a whole string. Note that locale settings may affect what
-characters are considered C<isxdigit> (unlikely, but still possible).
-Does not work on Unicode characters code point 256 or higher.
-Consider using regular expressions and the C</[[:xdigit:]]/>
-construct instead, or simply C</[0-9a-f]/i>.
-
-=item kill
-
-This is identical to Perl's builtin C<kill()> function for sending
-signals to processes (often to terminate them), see L<perlfunc/kill>.
-
-=item labs
-
-(For returning absolute values of long integers.)
-labs() is C-specific, see L<perlfunc/abs> instead.
-
-=item ldexp
-
-This is identical to the C function C<ldexp()>
-for multiplying floating point numbers with powers of two.
-
- $x_quadrupled = POSIX::ldexp($x, 2);
-
-=item ldiv
-
-(For computing dividends of long integers.)
-ldiv() is C-specific, use C</> and C<int()> instead.
-
-=item link
-
-This is identical to Perl's builtin C<link()> function
-for creating hard links into files, see L<perlfunc/link>.
-
-=item localeconv
-
-Get numeric formatting information. Returns a reference to a hash
-containing the current locale formatting values.
-
-Here is how to query the database for the B<de> (Deutsch or German) locale.
-
- $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" );
- print "Locale = $loc\n";
- $lconv = POSIX::localeconv();
- print "decimal_point = ", $lconv->{decimal_point}, "\n";
- print "thousands_sep = ", $lconv->{thousands_sep}, "\n";
- print "grouping = ", $lconv->{grouping}, "\n";
- print "int_curr_symbol = ", $lconv->{int_curr_symbol}, "\n";
- print "currency_symbol = ", $lconv->{currency_symbol}, "\n";
- print "mon_decimal_point = ", $lconv->{mon_decimal_point}, "\n";
- print "mon_thousands_sep = ", $lconv->{mon_thousands_sep}, "\n";
- print "mon_grouping = ", $lconv->{mon_grouping}, "\n";
- print "positive_sign = ", $lconv->{positive_sign}, "\n";
- print "negative_sign = ", $lconv->{negative_sign}, "\n";
- print "int_frac_digits = ", $lconv->{int_frac_digits}, "\n";
- print "frac_digits = ", $lconv->{frac_digits}, "\n";
- print "p_cs_precedes = ", $lconv->{p_cs_precedes}, "\n";
- print "p_sep_by_space = ", $lconv->{p_sep_by_space}, "\n";
- print "n_cs_precedes = ", $lconv->{n_cs_precedes}, "\n";
- print "n_sep_by_space = ", $lconv->{n_sep_by_space}, "\n";
- print "p_sign_posn = ", $lconv->{p_sign_posn}, "\n";
- print "n_sign_posn = ", $lconv->{n_sign_posn}, "\n";
-
-=item localtime
-
-This is identical to Perl's builtin C<localtime()> function for
-converting seconds since the epoch to a date see L<perlfunc/localtime>.
-
-=item log
-
-This is identical to Perl's builtin C<log()> function,
-returning the natural (I<e>-based) logarithm of the numerical argument,
-see L<perlfunc/log>.
-
-=item log10
-
-This is identical to the C function C<log10()>,
-returning the 10-base logarithm of the numerical argument.
-You can also use
-
- sub log10 { log($_[0]) / log(10) }
-
-or
-
- sub log10 { log($_[0]) / 2.30258509299405 }
-
-or
-
- sub log10 { log($_[0]) * 0.434294481903252 }
-
-=item longjmp
-
-longjmp() is C-specific: use L<perlfunc/die> instead.
-
-=item lseek
-
-Move the file's read/write position. This uses file descriptors such as
-those obtained by calling C<POSIX::open>.
-
- $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
- $off_t = POSIX::lseek( $fd, 0, &POSIX::SEEK_SET );
-
-Returns C<undef> on failure.
-
-=item malloc
-
-malloc() is C-specific. Perl does memory management transparently.
-
-=item mblen
-
-This is identical to the C function C<mblen()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
-
-=item mbstowcs
-
-This is identical to the C function C<mbstowcs()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
-
-=item mbtowc
-
-This is identical to the C function C<mbtowc()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
-
-=item memchr
-
-memchr() is C-specific, see L<perlfunc/index> instead.
-
-=item memcmp
-
-memcmp() is C-specific, use C<eq> instead, see L<perlop>.
-
-=item memcpy
-
-memcpy() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>.
-
-=item memmove
-
-memmove() is C-specific, use C<=>, see L<perlop>, or see L<perlfunc/substr>.
-
-=item memset
-
-memset() is C-specific, use C<x> instead, see L<perlop>.
-
-=item mkdir
-
-This is identical to Perl's builtin C<mkdir()> function
-for creating directories, see L<perlfunc/mkdir>.
-
-=item mkfifo
-
-This is similar to the C function C<mkfifo()> for creating
-FIFO special files.
-
- if (mkfifo($path, $mode)) { ....
-
-Returns C<undef> on failure. The C<$mode> is similar to the
-mode of C<mkdir()>, see L<perlfunc/mkdir>, though for C<mkfifo>
-you B<must> specify the C<$mode>.
-
-=item mktime
-
-Convert date/time info to a calendar time.
-
-Synopsis:
-
- mktime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
-
-The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero.
-I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The
-year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the
-year 2001 is 101. Consult your system's C<mktime()> manpage for details
-about these and the other arguments.
-
-Calendar time for December 12, 1995, at 10:30 am.
-
- $time_t = POSIX::mktime( 0, 30, 10, 12, 11, 95 );
- print "Date = ", POSIX::ctime($time_t);
-
-Returns C<undef> on failure.
-
-=item modf
-
-Return the integral and fractional parts of a floating-point number.
-
- ($fractional, $integral) = POSIX::modf( 3.14 );
-
-=item nice
-
-This is similar to the C function C<nice()>, for changing
-the scheduling preference of the current process. Positive
-arguments mean more polite process, negative values more
-needy process. Normal user processes can only be more polite.
-
-Returns C<undef> on failure.
-
-=item offsetof
-
-offsetof() is C-specific, you probably want to see L<perlfunc/pack> instead.
-
-=item open
-
-Open a file for reading for writing. This returns file descriptors, not
-Perl filehandles. Use C<POSIX::close> to close the file.
-
-Open a file read-only with mode 0666.
-
- $fd = POSIX::open( "foo" );
-
-Open a file for read and write.
-
- $fd = POSIX::open( "foo", &POSIX::O_RDWR );
-
-Open a file for write, with truncation.
-
- $fd = POSIX::open( "foo", &POSIX::O_WRONLY | &POSIX::O_TRUNC );
-
-Create a new file with mode 0640. Set up the file for writing.
-
- $fd = POSIX::open( "foo", &POSIX::O_CREAT | &POSIX::O_WRONLY, 0640 );
-
-Returns C<undef> on failure.
-
-See also L<perlfunc/sysopen>.
-
-=item opendir
-
-Open a directory for reading.
-
- $dir = POSIX::opendir( "/var" );
- @files = POSIX::readdir( $dir );
- POSIX::closedir( $dir );
-
-Returns C<undef> on failure.
-
-=item pathconf
-
-Retrieves the value of a configurable limit on a file or directory.
-
-The following will determine the maximum length of the longest allowable
-pathname on the filesystem which holds C</var>.
-
- $path_max = POSIX::pathconf( "/var", &POSIX::_PC_PATH_MAX );
-
-Returns C<undef> on failure.
-
-=item pause
-
-This is similar to the C function C<pause()>, which suspends
-the execution of the current process until a signal is received.
-
-Returns C<undef> on failure.
-
-=item perror
-
-This is identical to the C function C<perror()>, which outputs to the
-standard error stream the specified message followed by ": " and the
-current error string. Use the C<warn()> function and the C<$!>
-variable instead, see L<perlfunc/warn> and L<perlvar/$ERRNO>.
-
-=item pipe
-
-Create an interprocess channel. This returns file descriptors like those
-returned by C<POSIX::open>.
-
- my ($read, $write) = POSIX::pipe();
- POSIX::write( $write, "hello", 5 );
- POSIX::read( $read, $buf, 5 );
-
-See also L<perlfunc/pipe>.
-
-=item pow
-
-Computes C<$x> raised to the power C<$exponent>.
-
- $ret = POSIX::pow( $x, $exponent );
-
-You can also use the C<**> operator, see L<perlop>.
-
-=item printf
-
-Formats and prints the specified arguments to STDOUT.
-See also L<perlfunc/printf>.
-
-=item putc
-
-putc() is C-specific, see L<perlfunc/print> instead.
-
-=item putchar
-
-putchar() is C-specific, see L<perlfunc/print> instead.
-
-=item puts
-
-puts() is C-specific, see L<perlfunc/print> instead.
-
-=item qsort
-
-qsort() is C-specific, see L<perlfunc/sort> instead.
-
-=item raise
-
-Sends the specified signal to the current process.
-See also L<perlfunc/kill> and the C<$$> in L<perlvar/$PID>.
-
-=item rand
-
-C<rand()> is non-portable, see L<perlfunc/rand> instead.
-
-=item read
-
-Read from a file. This uses file descriptors such as those obtained by
-calling C<POSIX::open>. If the buffer C<$buf> is not large enough for the
-read then Perl will extend it to make room for the request.
-
- $fd = POSIX::open( "foo", &POSIX::O_RDONLY );
- $bytes = POSIX::read( $fd, $buf, 3 );
-
-Returns C<undef> on failure.
-
-See also L<perlfunc/sysread>.
-
-=item readdir
-
-This is identical to Perl's builtin C<readdir()> function
-for reading directory entries, see L<perlfunc/readdir>.
-
-=item realloc
-
-realloc() is C-specific. Perl does memory management transparently.
-
-=item remove
-
-This is identical to Perl's builtin C<unlink()> function
-for removing files, see L<perlfunc/unlink>.
-
-=item rename
-
-This is identical to Perl's builtin C<rename()> function
-for renaming files, see L<perlfunc/rename>.
-
-=item rewind
-
-Seeks to the beginning of the file.
-
-=item rewinddir
-
-This is identical to Perl's builtin C<rewinddir()> function for
-rewinding directory entry streams, see L<perlfunc/rewinddir>.
-
-=item rmdir
-
-This is identical to Perl's builtin C<rmdir()> function
-for removing (empty) directories, see L<perlfunc/rmdir>.
-
-=item scanf
-
-scanf() is C-specific, use E<lt>E<gt> and regular expressions instead,
-see L<perlre>.
-
-=item setgid
-
-Sets the real group identifier and the effective group identifier for
-this process. Similar to assigning a value to the Perl's builtin
-C<$)> variable, see L<perlvar/$EGID>, except that the latter
-will change only the real user identifier, and that the setgid()
-uses only a single numeric argument, as opposed to a space-separated
-list of numbers.
-
-=item setjmp
-
-C<setjmp()> is C-specific: use C<eval {}> instead,
-see L<perlfunc/eval>.
-
-=item setlocale
-
-Modifies and queries program's locale. The following examples assume
-
- use POSIX qw(setlocale LC_ALL LC_CTYPE);
-
-has been issued.
-
-The following will set the traditional UNIX system locale behavior
-(the second argument C<"C">).
-
- $loc = setlocale( LC_ALL, "C" );
-
-The following will query the current LC_CTYPE category. (No second
-argument means 'query'.)
-
- $loc = setlocale( LC_CTYPE );
-
-The following will set the LC_CTYPE behaviour according to the locale
-environment variables (the second argument C<"">).
-Please see your systems C<setlocale(3)> documentation for the locale
-environment variables' meaning or consult L<perllocale>.
-
- $loc = setlocale( LC_CTYPE, "" );
-
-The following will set the LC_COLLATE behaviour to Argentinian
-Spanish. B<NOTE>: The naming and availability of locales depends on
-your operating system. Please consult L<perllocale> for how to find
-out which locales are available in your system.
-
- $loc = setlocale( LC_ALL, "es_AR.ISO8859-1" );
-
-=item setpgid
-
-This is similar to the C function C<setpgid()> for
-setting the process group identifier of the current process.
-
-Returns C<undef> on failure.
-
-=item setsid
-
-This is identical to the C function C<setsid()> for
-setting the session identifier of the current process.
-
-=item setuid
-
-Sets the real user identifier and the effective user identifier for
-this process. Similar to assigning a value to the Perl's builtin
-C<$E<lt>> variable, see L<perlvar/$UID>, except that the latter
-will change only the real user identifier.
-
-=item sigaction
-
-Detailed signal management. This uses C<POSIX::SigAction> objects for
-the C<action> and C<oldaction> arguments (the oldaction can also be
-just a hash reference). Consult your system's C<sigaction> manpage
-for details, see also C<POSIX::SigRt>.
-
-Synopsis:
-
- sigaction(signal, action, oldaction = 0)
-
-Returns C<undef> on failure. The C<signal> must be a number (like
-SIGHUP), not a string (like "SIGHUP"), though Perl does try hard
-to understand you.
-
-If you use the SA_SIGINFO flag, the signal handler will in addition to
-the first argument, the signal name, also receive a second argument, a
-hash reference, inside which are the following keys with the following
-semantics, as defined by POSIX/SUSv3:
-
- signo the signal number
- errno the error number
- code if this is zero or less, the signal was sent by
- a user process and the uid and pid make sense,
- otherwise the signal was sent by the kernel
-
-The following are also defined by POSIX/SUSv3, but unfortunately
-not very widely implemented:
-
- pid the process id generating the signal
- uid the uid of the process id generating the signal
- status exit value or signal for SIGCHLD
- band band event for SIGPOLL
-
-A third argument is also passed to the handler, which contains a copy
-of the raw binary contents of the siginfo structure: if a system has
-some non-POSIX fields, this third argument is where to unpack() them
-from.
-
-Note that not all siginfo values make sense simultaneously (some are
-valid only for certain signals, for example), and not all values make
-sense from Perl perspective, you should to consult your system's
-C<sigaction> and possibly also C<siginfo> documentation.
-
-=item siglongjmp
-
-siglongjmp() is C-specific: use L<perlfunc/die> instead.
-
-=item sigpending
-
-Examine signals that are blocked and pending. This uses C<POSIX::SigSet>
-objects for the C<sigset> argument. Consult your system's C<sigpending>
-manpage for details.
-
-Synopsis:
-
- sigpending(sigset)
-
-Returns C<undef> on failure.
-
-=item sigprocmask
-
-Change and/or examine calling process's signal mask. This uses
-C<POSIX::SigSet> objects for the C<sigset> and C<oldsigset> arguments.
-Consult your system's C<sigprocmask> manpage for details.
-
-Synopsis:
-
- sigprocmask(how, sigset, oldsigset = 0)
-
-Returns C<undef> on failure.
-
-=item sigsetjmp
-
-C<sigsetjmp()> is C-specific: use C<eval {}> instead,
-see L<perlfunc/eval>.
-
-=item sigsuspend
-
-Install a signal mask and suspend process until signal arrives. This uses
-C<POSIX::SigSet> objects for the C<signal_mask> argument. Consult your
-system's C<sigsuspend> manpage for details.
-
-Synopsis:
-
- sigsuspend(signal_mask)
-
-Returns C<undef> on failure.
-
-=item sin
-
-This is identical to Perl's builtin C<sin()> function
-for returning the sine of the numerical argument,
-see L<perlfunc/sin>. See also L<Math::Trig>.
-
-=item sinh
-
-This is identical to the C function C<sinh()>
-for returning the hyperbolic sine of the numerical argument.
-See also L<Math::Trig>.
-
-=item sleep
-
-This is functionally identical to Perl's builtin C<sleep()> function
-for suspending the execution of the current for process for certain
-number of seconds, see L<perlfunc/sleep>. There is one significant
-difference, however: C<POSIX::sleep()> returns the number of
-B<unslept> seconds, while the C<CORE::sleep()> returns the
-number of slept seconds.
-
-=item sprintf
-
-This is similar to Perl's builtin C<sprintf()> function
-for returning a string that has the arguments formatted as requested,
-see L<perlfunc/sprintf>.
-
-=item sqrt
-
-This is identical to Perl's builtin C<sqrt()> function.
-for returning the square root of the numerical argument,
-see L<perlfunc/sqrt>.
-
-=item srand
-
-Give a seed the pseudorandom number generator, see L<perlfunc/srand>.
-
-=item sscanf
-
-sscanf() is C-specific, use regular expressions instead,
-see L<perlre>.
-
-=item stat
-
-This is identical to Perl's builtin C<stat()> function
-for returning information about files and directories.
-
-=item strcat
-
-strcat() is C-specific, use C<.=> instead, see L<perlop>.
-
-=item strchr
-
-strchr() is C-specific, see L<perlfunc/index> instead.
-
-=item strcmp
-
-strcmp() is C-specific, use C<eq> or C<cmp> instead, see L<perlop>.
-
-=item strcoll
-
-This is identical to the C function C<strcoll()>
-for collating (comparing) strings transformed using
-the C<strxfrm()> function. Not really needed since
-Perl can do this transparently, see L<perllocale>.
-
-=item strcpy
-
-strcpy() is C-specific, use C<=> instead, see L<perlop>.
-
-=item strcspn
-
-strcspn() is C-specific, use regular expressions instead,
-see L<perlre>.
-
-=item strerror
-
-Returns the error string for the specified errno.
-Identical to the string form of the C<$!>, see L<perlvar/$ERRNO>.
-
-=item strftime
-
-Convert date and time information to string. Returns the string.
-
-Synopsis:
-
- strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
-
-The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero.
-I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The
-year (C<year>) is given in years since 1900. I.e., the year 1995 is 95; the
-year 2001 is 101. Consult your system's C<strftime()> manpage for details
-about these and the other arguments.
-
-If you want your code to be portable, your format (C<fmt>) argument
-should use only the conversion specifiers defined by the ANSI C
-standard (C89, to play safe). These are C<aAbBcdHIjmMpSUwWxXyYZ%>.
-But even then, the B<results> of some of the conversion specifiers are
-non-portable. For example, the specifiers C<aAbBcpZ> change according
-to the locale settings of the user, and both how to set locales (the
-locale names) and what output to expect are non-standard.
-The specifier C<c> changes according to the timezone settings of the
-user and the timezone computation rules of the operating system.
-The C<Z> specifier is notoriously unportable since the names of
-timezones are non-standard. Sticking to the numeric specifiers is the
-safest route.
-
-The given arguments are made consistent as though by calling
-C<mktime()> before calling your system's C<strftime()> function,
-except that the C<isdst> value is not affected.
-
-The string for Tuesday, December 12, 1995.
-
- $str = POSIX::strftime( "%A, %B %d, %Y", 0, 0, 0, 12, 11, 95, 2 );
- print "$str\n";
-
-=item strlen
-
-strlen() is C-specific, use C<length()> instead, see L<perlfunc/length>.
-
-=item strncat
-
-strncat() is C-specific, use C<.=> instead, see L<perlop>.
-
-=item strncmp
-
-strncmp() is C-specific, use C<eq> instead, see L<perlop>.
-
-=item strncpy
-
-strncpy() is C-specific, use C<=> instead, see L<perlop>.
-
-=item strpbrk
-
-strpbrk() is C-specific, use regular expressions instead,
-see L<perlre>.
-
-=item strrchr
-
-strrchr() is C-specific, see L<perlfunc/rindex> instead.
-
-=item strspn
-
-strspn() is C-specific, use regular expressions instead,
-see L<perlre>.
-
-=item strstr
-
-This is identical to Perl's builtin C<index()> function,
-see L<perlfunc/index>.
-
-=item strtod
-
-String to double translation. Returns the parsed number and the number
-of characters in the unparsed portion of the string. Truly
-POSIX-compliant systems set $! ($ERRNO) to indicate a translation
-error, so clear $! before calling strtod. However, non-POSIX systems
-may not check for overflow, and therefore will never set $!.
-
-strtod should respect any POSIX I<setlocale()> settings.
-
-To parse a string $str as a floating point number use
-
- $! = 0;
- ($num, $n_unparsed) = POSIX::strtod($str);
-
-The second returned item and $! can be used to check for valid input:
-
- if (($str eq '') || ($n_unparsed != 0) || $!) {
- die "Non-numeric input $str" . ($! ? ": $!\n" : "\n");
- }
-
-When called in a scalar context strtod returns the parsed number.
-
-=item strtok
-
-strtok() is C-specific, use regular expressions instead, see
-L<perlre>, or L<perlfunc/split>.
-
-=item strtol
-
-String to (long) integer translation. Returns the parsed number and
-the number of characters in the unparsed portion of the string. Truly
-POSIX-compliant systems set $! ($ERRNO) to indicate a translation
-error, so clear $! before calling strtol. However, non-POSIX systems
-may not check for overflow, and therefore will never set $!.
-
-strtol should respect any POSIX I<setlocale()> settings.
-
-To parse a string $str as a number in some base $base use
-
- $! = 0;
- ($num, $n_unparsed) = POSIX::strtol($str, $base);
-
-The base should be zero or between 2 and 36, inclusive. When the base
-is zero or omitted strtol will use the string itself to determine the
-base: a leading "0x" or "0X" means hexadecimal; a leading "0" means
-octal; any other leading characters mean decimal. Thus, "1234" is
-parsed as a decimal number, "01234" as an octal number, and "0x1234"
-as a hexadecimal number.
-
-The second returned item and $! can be used to check for valid input:
-
- if (($str eq '') || ($n_unparsed != 0) || !$!) {
- die "Non-numeric input $str" . $! ? ": $!\n" : "\n";
- }
-
-When called in a scalar context strtol returns the parsed number.
-
-=item strtoul
-
-String to unsigned (long) integer translation. strtoul() is identical
-to strtol() except that strtoul() only parses unsigned integers. See
-L</strtol> for details.
-
-Note: Some vendors supply strtod() and strtol() but not strtoul().
-Other vendors that do supply strtoul() parse "-1" as a valid value.
-
-=item strxfrm
-
-String transformation. Returns the transformed string.
-
- $dst = POSIX::strxfrm( $src );
-
-Used in conjunction with the C<strcoll()> function, see L</strcoll>.
-
-Not really needed since Perl can do this transparently, see
-L<perllocale>.
-
-=item sysconf
-
-Retrieves values of system configurable variables.
-
-The following will get the machine's clock speed.
-
- $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK );
-
-Returns C<undef> on failure.
-
-=item system
-
-This is identical to Perl's builtin C<system()> function, see
-L<perlfunc/system>.
-
-=item tan
-
-This is identical to the C function C<tan()>, returning the
-tangent of the numerical argument. See also L<Math::Trig>.
-
-=item tanh
-
-This is identical to the C function C<tanh()>, returning the
-hyperbolic tangent of the numerical argument. See also L<Math::Trig>.
-
-=item tcdrain
-
-This is similar to the C function C<tcdrain()> for draining
-the output queue of its argument stream.
-
-Returns C<undef> on failure.
-
-=item tcflow
-
-This is similar to the C function C<tcflow()> for controlling
-the flow of its argument stream.
-
-Returns C<undef> on failure.
-
-=item tcflush
-
-This is similar to the C function C<tcflush()> for flushing
-the I/O buffers of its argument stream.
-
-Returns C<undef> on failure.
-
-=item tcgetpgrp
-
-This is identical to the C function C<tcgetpgrp()> for returning the
-process group identifier of the foreground process group of the controlling
-terminal.
-
-=item tcsendbreak
-
-This is similar to the C function C<tcsendbreak()> for sending
-a break on its argument stream.
-
-Returns C<undef> on failure.
-
-=item tcsetpgrp
-
-This is similar to the C function C<tcsetpgrp()> for setting the
-process group identifier of the foreground process group of the controlling
-terminal.
-
-Returns C<undef> on failure.
-
-=item time
-
-This is identical to Perl's builtin C<time()> function
-for returning the number of seconds since the epoch
-(whatever it is for the system), see L<perlfunc/time>.
-
-=item times
-
-The times() function returns elapsed realtime since some point in the past
-(such as system startup), user and system times for this process, and user
-and system times used by child processes. All times are returned in clock
-ticks.
-
- ($realtime, $user, $system, $cuser, $csystem) = POSIX::times();
-
-Note: Perl's builtin C<times()> function returns four values, measured in
-seconds.
-
-=item tmpfile
-
-Use method C<IO::File::new_tmpfile()> instead, or see L<File::Temp>.
-
-=item tmpnam
-
-Returns a name for a temporary file.
-
- $tmpfile = POSIX::tmpnam();
-
-For security reasons, which are probably detailed in your system's
-documentation for the C library tmpnam() function, this interface
-should not be used; instead see L<File::Temp>.
-
-=item tolower
-
-This is identical to the C function, except that it can apply to a single
-character or to a whole string. Consider using the C<lc()> function,
-see L<perlfunc/lc>, or the equivalent C<\L> operator inside doublequotish
-strings.
-
-=item toupper
-
-This is identical to the C function, except that it can apply to a single
-character or to a whole string. Consider using the C<uc()> function,
-see L<perlfunc/uc>, or the equivalent C<\U> operator inside doublequotish
-strings.
-
-=item ttyname
-
-This is identical to the C function C<ttyname()> for returning the
-name of the current terminal.
-
-=item tzname
-
-Retrieves the time conversion information from the C<tzname> variable.
-
- POSIX::tzset();
- ($std, $dst) = POSIX::tzname();
-
-=item tzset
-
-This is identical to the C function C<tzset()> for setting
-the current timezone based on the environment variable C<TZ>,
-to be used by C<ctime()>, C<localtime()>, C<mktime()>, and C<strftime()>
-functions.
-
-=item umask
-
-This is identical to Perl's builtin C<umask()> function
-for setting (and querying) the file creation permission mask,
-see L<perlfunc/umask>.
-
-=item uname
-
-Get name of current operating system.
-
- ($sysname, $nodename, $release, $version, $machine) = POSIX::uname();
-
-Note that the actual meanings of the various fields are not
-that well standardized, do not expect any great portability.
-The C<$sysname> might be the name of the operating system,
-the C<$nodename> might be the name of the host, the C<$release>
-might be the (major) release number of the operating system,
-the C<$version> might be the (minor) release number of the
-operating system, and the C<$machine> might be a hardware identifier.
-Maybe.
-
-=item ungetc
-
-Use method C<IO::Handle::ungetc()> instead.
-
-=item unlink
-
-This is identical to Perl's builtin C<unlink()> function
-for removing files, see L<perlfunc/unlink>.
-
-=item utime
-
-This is identical to Perl's builtin C<utime()> function
-for changing the time stamps of files and directories,
-see L<perlfunc/utime>.
-
-=item vfprintf
-
-vfprintf() is C-specific, see L<perlfunc/printf> instead.
-
-=item vprintf
-
-vprintf() is C-specific, see L<perlfunc/printf> instead.
-
-=item vsprintf
-
-vsprintf() is C-specific, see L<perlfunc/sprintf> instead.
-
-=item wait
-
-This is identical to Perl's builtin C<wait()> function,
-see L<perlfunc/wait>.
-
-=item waitpid
-
-Wait for a child process to change state. This is identical to Perl's
-builtin C<waitpid()> function, see L<perlfunc/waitpid>.
-
- $pid = POSIX::waitpid( -1, POSIX::WNOHANG );
- print "status = ", ($? / 256), "\n";
-
-=item wcstombs
-
-This is identical to the C function C<wcstombs()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
-
-=item wctomb
-
-This is identical to the C function C<wctomb()>.
-Perl does not have any support for the wide and multibyte
-characters of the C standards, so this might be a rather
-useless function.
-
-=item write
-
-Write to a file. This uses file descriptors such as those obtained by
-calling C<POSIX::open>.
-
- $fd = POSIX::open( "foo", &POSIX::O_WRONLY );
- $buf = "hello";
- $bytes = POSIX::write( $fd, $buf, 5 );
-
-Returns C<undef> on failure.
-
-See also L<perlfunc/syswrite>.
-
-=back
-
-=head1 CLASSES
-
-=head2 POSIX::SigAction
-
-=over 8
-
-=item new
-
-Creates a new C<POSIX::SigAction> object which corresponds to the C
-C<struct sigaction>. This object will be destroyed automatically when
-it is no longer needed. The first parameter is the handler, a sub
-reference. The second parameter is a C<POSIX::SigSet> object, it
-defaults to the empty set. The third parameter contains the
-C<sa_flags>, it defaults to 0.
-
- $sigset = POSIX::SigSet->new(SIGINT, SIGQUIT);
- $sigaction = POSIX::SigAction->new( \&handler, $sigset, &POSIX::SA_NOCLDSTOP );
-
-This C<POSIX::SigAction> object is intended for use with the C<POSIX::sigaction()>
-function.
-
-=back
-
-=over 8
-
-=item handler
-
-=item mask
-
-=item flags
-
-accessor functions to get/set the values of a SigAction object.
-
- $sigset = $sigaction->mask;
- $sigaction->flags(&POSIX::SA_RESTART);
-
-=item safe
-
-accessor function for the "safe signals" flag of a SigAction object; see
-L<perlipc> for general information on safe (a.k.a. "deferred") signals. If
-you wish to handle a signal safely, use this accessor to set the "safe" flag
-in the C<POSIX::SigAction> object:
-
- $sigaction->safe(1);
-
-You may also examine the "safe" flag on the output action object which is
-filled in when given as the third parameter to C<POSIX::sigaction()>:
-
- sigaction(SIGINT, $new_action, $old_action);
- if ($old_action->safe) {
- # previous SIGINT handler used safe signals
- }
-
-=back
-
-=head2 POSIX::SigRt
-
-=over 8
-
-=item %SIGRT
-
-A hash of the POSIX realtime signal handlers. It is an extension of
-the standard %SIG, the $POSIX::SIGRT{SIGRTMIN} is roughly equivalent
-to $SIG{SIGRTMIN}, but the right POSIX moves (see below) are made with
-the POSIX::SigSet and POSIX::sigaction instead of accessing the %SIG.
-
-You can set the %POSIX::SIGRT elements to set the POSIX realtime
-signal handlers, use C<delete> and C<exists> on the elements, and use
-C<scalar> on the C<%POSIX::SIGRT> to find out how many POSIX realtime
-signals there are available (SIGRTMAX - SIGRTMIN + 1, the SIGRTMAX is
-a valid POSIX realtime signal).
-
-Setting the %SIGRT elements is equivalent to calling this:
-
- sub new {
- my ($rtsig, $handler, $flags) = @_;
- my $sigset = POSIX::SigSet($rtsig);
- my $sigact = POSIX::SigAction->new($handler, $sigset, $flags);
- sigaction($rtsig, $sigact);
- }
-
-The flags default to zero, if you want something different you can
-either use C<local> on $POSIX::SigRt::SIGACTION_FLAGS, or you can
-derive from POSIX::SigRt and define your own C<new()> (the tied hash
-STORE method of the %SIGRT calls C<new($rtsig, $handler, $SIGACTION_FLAGS)>,
-where the $rtsig ranges from zero to SIGRTMAX - SIGRTMIN + 1).
-
-Just as with any signal, you can use sigaction($rtsig, undef, $oa) to
-retrieve the installed signal handler (or, rather, the signal action).
-
-B<NOTE:> whether POSIX realtime signals really work in your system, or
-whether Perl has been compiled so that it works with them, is outside
-of this discussion.
-
-=item SIGRTMIN
-
-Return the minimum POSIX realtime signal number available, or C<undef>
-if no POSIX realtime signals are available.
-
-=item SIGRTMAX
-
-Return the maximum POSIX realtime signal number available, or C<undef>
-if no POSIX realtime signals are available.
-
-=back
-
-=head2 POSIX::SigSet
-
-=over 8
-
-=item new
-
-Create a new SigSet object. This object will be destroyed automatically
-when it is no longer needed. Arguments may be supplied to initialize the
-set.
-
-Create an empty set.
-
- $sigset = POSIX::SigSet->new;
-
-Create a set with SIGUSR1.
-
- $sigset = POSIX::SigSet->new( &POSIX::SIGUSR1 );
-
-=item addset
-
-Add a signal to a SigSet object.
-
- $sigset->addset( &POSIX::SIGUSR2 );
-
-Returns C<undef> on failure.
-
-=item delset
-
-Remove a signal from the SigSet object.
-
- $sigset->delset( &POSIX::SIGUSR2 );
-
-Returns C<undef> on failure.
-
-=item emptyset
-
-Initialize the SigSet object to be empty.
-
- $sigset->emptyset();
-
-Returns C<undef> on failure.
-
-=item fillset
-
-Initialize the SigSet object to include all signals.
-
- $sigset->fillset();
-
-Returns C<undef> on failure.
-
-=item ismember
-
-Tests the SigSet object to see if it contains a specific signal.
-
- if( $sigset->ismember( &POSIX::SIGUSR1 ) ){
- print "contains SIGUSR1\n";
- }
-
-=back
-
-=head2 POSIX::Termios
-
-=over 8
-
-=item new
-
-Create a new Termios object. This object will be destroyed automatically
-when it is no longer needed. A Termios object corresponds to the termios
-C struct. new() mallocs a new one, getattr() fills it from a file descriptor,
-and setattr() sets a file descriptor's parameters to match Termios' contents.
-
- $termios = POSIX::Termios->new;
-
-=item getattr
-
-Get terminal control attributes.
-
-Obtain the attributes for stdin.
-
- $termios->getattr( 0 ) # Recommended for clarity.
- $termios->getattr()
-
-Obtain the attributes for stdout.
-
- $termios->getattr( 1 )
-
-Returns C<undef> on failure.
-
-=item getcc
-
-Retrieve a value from the c_cc field of a termios object. The c_cc field is
-an array so an index must be specified.
-
- $c_cc[1] = $termios->getcc(1);
-
-=item getcflag
-
-Retrieve the c_cflag field of a termios object.
-
- $c_cflag = $termios->getcflag;
-
-=item getiflag
-
-Retrieve the c_iflag field of a termios object.
-
- $c_iflag = $termios->getiflag;
-
-=item getispeed
-
-Retrieve the input baud rate.
-
- $ispeed = $termios->getispeed;
-
-=item getlflag
-
-Retrieve the c_lflag field of a termios object.
-
- $c_lflag = $termios->getlflag;
-
-=item getoflag
-
-Retrieve the c_oflag field of a termios object.
-
- $c_oflag = $termios->getoflag;
-
-=item getospeed
-
-Retrieve the output baud rate.
-
- $ospeed = $termios->getospeed;
-
-=item setattr
-
-Set terminal control attributes.
-
-Set attributes immediately for stdout.
-
- $termios->setattr( 1, &POSIX::TCSANOW );
-
-Returns C<undef> on failure.
-
-=item setcc
-
-Set a value in the c_cc field of a termios object. The c_cc field is an
-array so an index must be specified.
-
- $termios->setcc( &POSIX::VEOF, 1 );
-
-=item setcflag
-
-Set the c_cflag field of a termios object.
-
- $termios->setcflag( $c_cflag | &POSIX::CLOCAL );
-
-=item setiflag
-
-Set the c_iflag field of a termios object.
-
- $termios->setiflag( $c_iflag | &POSIX::BRKINT );
-
-=item setispeed
-
-Set the input baud rate.
-
- $termios->setispeed( &POSIX::B9600 );
-
-Returns C<undef> on failure.
-
-=item setlflag
-
-Set the c_lflag field of a termios object.
-
- $termios->setlflag( $c_lflag | &POSIX::ECHO );
-
-=item setoflag
-
-Set the c_oflag field of a termios object.
-
- $termios->setoflag( $c_oflag | &POSIX::OPOST );
-
-=item setospeed
-
-Set the output baud rate.
-
- $termios->setospeed( &POSIX::B9600 );
-
-Returns C<undef> on failure.
-
-=item Baud rate values
-
-B38400 B75 B200 B134 B300 B1800 B150 B0 B19200 B1200 B9600 B600 B4800 B50 B2400 B110
-
-=item Terminal interface values
-
-TCSADRAIN TCSANOW TCOON TCIOFLUSH TCOFLUSH TCION TCIFLUSH TCSAFLUSH TCIOFF TCOOFF
-
-=item c_cc field values
-
-VEOF VEOL VERASE VINTR VKILL VQUIT VSUSP VSTART VSTOP VMIN VTIME NCCS
-
-=item c_cflag field values
-
-CLOCAL CREAD CSIZE CS5 CS6 CS7 CS8 CSTOPB HUPCL PARENB PARODD
-
-=item c_iflag field values
-
-BRKINT ICRNL IGNBRK IGNCR IGNPAR INLCR INPCK ISTRIP IXOFF IXON PARMRK
-
-=item c_lflag field values
-
-ECHO ECHOE ECHOK ECHONL ICANON IEXTEN ISIG NOFLSH TOSTOP
-
-=item c_oflag field values
-
-OPOST
-
-=back
-
-=head1 PATHNAME CONSTANTS
-
-=over 8
-
-=item Constants
-
-_PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE
-
-=back
-
-=head1 POSIX CONSTANTS
-
-=over 8
-
-=item Constants
-
-_POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE _POSIX_VERSION
-
-=back
-
-=head1 SYSTEM CONFIGURATION
-
-=over 8
-
-=item Constants
-
-_SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION
-
-=back
-
-=head1 ERRNO
-
-=over 8
-
-=item Constants
-
-E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF
-EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ
-EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS EINTR
-EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE ENAMETOOLONG
-ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODEV ENOENT ENOEXEC
-ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR
-ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE
-EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART EROFS
-ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS
-ETXTBSY EUSERS EWOULDBLOCK EXDEV
-
-=back
-
-=head1 FCNTL
-
-=over 8
-
-=item Constants
-
-FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC O_WRONLY
-
-=back
-
-=head1 FLOAT
-
-=over 8
-
-=item Constants
-
-DBL_DIG DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX FLT_ROUNDS LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP
-
-=back
-
-=head1 LIMITS
-
-=over 8
-
-=item Constants
-
-ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX
-
-=back
-
-=head1 LOCALE
-
-=over 8
-
-=item Constants
-
-LC_ALL LC_COLLATE LC_CTYPE LC_MONETARY LC_NUMERIC LC_TIME
-
-=back
-
-=head1 MATH
-
-=over 8
-
-=item Constants
-
-HUGE_VAL
-
-=back
-
-=head1 SIGNAL
-
-=over 8
-
-=item Constants
-
-SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART
-SA_SIGINFO SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT
-SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU
-SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK
-SIG_UNBLOCK
-
-=back
-
-=head1 STAT
-
-=over 8
-
-=item Constants
-
-S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR
-
-=item Macros
-
-S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG
-
-=back
-
-=head1 STDLIB
-
-=over 8
-
-=item Constants
-
-EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX RAND_MAX
-
-=back
-
-=head1 STDIO
-
-=over 8
-
-=item Constants
-
-BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid L_tmpname TMP_MAX
-
-=back
-
-=head1 TIME
-
-=over 8
-
-=item Constants
-
-CLK_TCK CLOCKS_PER_SEC
-
-=back
-
-=head1 UNISTD
-
-=over 8
-
-=item Constants
-
-R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STDERR_FILENO W_OK X_OK
-
-=back
-
-=head1 WAIT
-
-=over 8
-
-=item Constants
-
-WNOHANG WUNTRACED
-
-=over 16
-
-=item WNOHANG
-
-Do not suspend the calling process until a child process
-changes state but instead return immediately.
-
-=item WUNTRACED
-
-Catch stopped child processes.
-
-=back
-
-=item Macros
-
-WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG
-
-=over 16
-
-=item WIFEXITED
-
-WIFEXITED($?) returns true if the child process exited normally
-(C<exit()> or by falling off the end of C<main()>)
-
-=item WEXITSTATUS
-
-WEXITSTATUS($?) returns the normal exit status of the child process
-(only meaningful if WIFEXITED($?) is true)
-
-=item WIFSIGNALED
-
-WIFSIGNALED($?) returns true if the child process terminated because
-of a signal
-
-=item WTERMSIG
-
-WTERMSIG($?) returns the signal the child process terminated for
-(only meaningful if WIFSIGNALED($?) is true)
-
-=item WIFSTOPPED
-
-WIFSTOPPED($?) returns true if the child process is currently stopped
-(can happen only if you specified the WUNTRACED flag to waitpid())
-
-=item WSTOPSIG
-
-WSTOPSIG($?) returns the signal the child process was stopped for
-(only meaningful if WIFSTOPPED($?) is true)
-
-=back
-
-=back
-
Deleted: trunk/contrib/perl/ext/POSIX/hints/uts.pl
===================================================================
--- trunk/contrib/perl/ext/POSIX/hints/uts.pl 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/POSIX/hints/uts.pl 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,9 +0,0 @@
-# UTS - Leaving -lm in there results in death of make with the message:
-# LD_RUN_PATH="/usr/ccs/lib" ld -G -z text POSIX.o \
-# -o ../../lib/auto/POS IX/POSIX.so -lm
-# relocations referenced
-# from file(s)
-# /usr/ccs/lib/libm.a(acos.o)
-# ...
-
-$self->{LIBS} = [''];
Deleted: trunk/contrib/perl/ext/Pod-Html/Html.pm
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/Html.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/Pod-Html/Html.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,2247 +0,0 @@
-package Pod::Html;
-use strict;
-require Exporter;
-
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = 1.11;
- at ISA = qw(Exporter);
- at EXPORT = qw(pod2html htmlify);
- at EXPORT_OK = qw(anchorify);
-
-use Carp;
-use Config;
-use Cwd;
-use File::Spec;
-use File::Spec::Unix;
-use Getopt::Long;
-
-use locale; # make \w work right in non-ASCII lands
-
-=head1 NAME
-
-Pod::Html - module to convert pod files to HTML
-
-=head1 SYNOPSIS
-
- use Pod::Html;
- pod2html([options]);
-
-=head1 DESCRIPTION
-
-Converts files from pod format (see L<perlpod>) to HTML format. It
-can automatically generate indexes and cross-references, and it keeps
-a cache of things it knows how to cross-reference.
-
-=head1 FUNCTIONS
-
-=head2 pod2html
-
- pod2html("pod2html",
- "--podpath=lib:ext:pod:vms",
- "--podroot=/usr/src/perl",
- "--htmlroot=/perl/nmanual",
- "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
- "--recurse",
- "--infile=foo.pod",
- "--outfile=/perl/nmanual/foo.html");
-
-pod2html takes the following arguments:
-
-=over 4
-
-=item backlink
-
- --backlink="Back to Top"
-
-Adds "Back to Top" links in front of every C<head1> heading (except for
-the first). By default, no backlinks are generated.
-
-=item cachedir
-
- --cachedir=name
-
-Creates the item and directory caches in the given directory.
-
-=item css
-
- --css=stylesheet
-
-Specify the URL of a cascading style sheet. Also disables all HTML/CSS
-C<style> attributes that are output by default (to avoid conflicts).
-
-=item flush
-
- --flush
-
-Flushes the item and directory caches.
-
-=item header
-
- --header
- --noheader
-
-Creates header and footer blocks containing the text of the C<NAME>
-section. By default, no headers are generated.
-
-=item help
-
- --help
-
-Displays the usage message.
-
-=item hiddendirs
-
- --hiddendirs
- --nohiddendirs
-
-Include hidden directories in the search for POD's in podpath if recurse
-is set.
-The default is not to traverse any directory whose name begins with C<.>.
-See L</"podpath"> and L</"recurse">.
-
-[This option is for backward compatibility only.
-It's hard to imagine that one would usefully create a module with a
-name component beginning with C<.>.]
-
-=item htmldir
-
- --htmldir=name
-
-Sets the directory in which the resulting HTML file is placed. This
-is used to generate relative links to other files. Not passing this
-causes all links to be absolute, since this is the value that tells
-Pod::Html the root of the documentation tree.
-
-=item htmlroot
-
- --htmlroot=name
-
-Sets the base URL for the HTML files. When cross-references are made,
-the HTML root is prepended to the URL.
-
-=item index
-
- --index
- --noindex
-
-Generate an index at the top of the HTML file. This is the default
-behaviour.
-
-=item infile
-
- --infile=name
-
-Specify the pod file to convert. Input is taken from STDIN if no
-infile is specified.
-
-=item libpods
-
- --libpods=name:...:name
-
-List of page names (eg, "perlfunc") which contain linkable C<=item>s.
-
-=item netscape
-
- --netscape
- --nonetscape
-
-B<Deprecated>, has no effect. For backwards compatibility only.
-
-=item outfile
-
- --outfile=name
-
-Specify the HTML file to create. Output goes to STDOUT if no outfile
-is specified.
-
-=item podpath
-
- --podpath=name:...:name
-
-Specify which subdirectories of the podroot contain pod files whose
-HTML converted forms can be linked to in cross references.
-
-=item podroot
-
- --podroot=name
-
-Specify the base directory for finding library pods.
-
-=item quiet
-
- --quiet
- --noquiet
-
-Don't display I<mostly harmless> warning messages. These messages
-will be displayed by default. But this is not the same as C<verbose>
-mode.
-
-=item recurse
-
- --recurse
- --norecurse
-
-Recurse into subdirectories specified in podpath (default behaviour).
-
-=item title
-
- --title=title
-
-Specify the title of the resulting HTML file.
-
-=item verbose
-
- --verbose
- --noverbose
-
-Display progress messages. By default, they won't be displayed.
-
-=back
-
-=head2 htmlify
-
- htmlify($heading);
-
-Converts a pod section specification to a suitable section specification
-for HTML. Note that we keep spaces and special characters except
-C<", ?> (Netscape problem) and the hyphen (writer's problem...).
-
-=head2 anchorify
-
- anchorify(@heading);
-
-Similar to C<htmlify()>, but turns non-alphanumerics into underscores. Note
-that C<anchorify()> is not exported by default.
-
-=head1 ENVIRONMENT
-
-Uses C<$Config{pod2html}> to setup default options.
-
-=head1 AUTHOR
-
-Tom Christiansen, E<lt>tchrist at perl.comE<gt>.
-
-=head1 SEE ALSO
-
-L<perlpod>
-
-=head1 COPYRIGHT
-
-This program is distributed under the Artistic License.
-
-=cut
-
-my($Cachedir);
-my($Dircache, $Itemcache);
-my @Begin_Stack;
-my @Libpods;
-my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl);
-my($Podfile, @Podpath, $Podroot);
-my $Css;
-
-my $Recurse;
-my $Quiet;
-my $HiddenDirs;
-my $Verbose;
-my $Doindex;
-
-my $Backlink;
-my($Listlevel, @Listtype);
-my $ListNewTerm;
-use vars qw($Ignore); # need to localize it later.
-
-my(%Items_Named, @Items_Seen);
-my($Title, $Header);
-
-my $Top;
-my $Paragraph;
-
-my %Sections;
-
-# Caches
-my %Pages = (); # associative array used to find the location
- # of pages referenced by L<> links.
-my %Items = (); # associative array used to find the location
- # of =item directives referenced by C<> links
-
-my %Local_Items;
-my $Is83;
-
-my $Curdir = File::Spec->curdir;
-
-init_globals();
-
-sub init_globals {
- $Cachedir = "."; # The directory to which item and directory
- # caches will be written.
-
- $Dircache = "pod2htmd.tmp";
- $Itemcache = "pod2htmi.tmp";
-
- @Begin_Stack = (); # begin/end stack
-
- @Libpods = (); # files to search for links from C<> directives
- $Htmlroot = "/"; # http-server base directory from which all
- # relative paths in $podpath stem.
- $Htmldir = ""; # The directory to which the html pages
- # will (eventually) be written.
- $Htmlfile = ""; # write to stdout by default
- $Htmlfileurl = ""; # The url that other files would use to
- # refer to this file. This is only used
- # to make relative urls that point to
- # other files.
-
- $Podfile = ""; # read from stdin by default
- @Podpath = (); # list of directories containing library pods.
- $Podroot = $Curdir; # filesystem base directory from which all
- # relative paths in $podpath stem.
- $Css = ''; # Cascading style sheet
- $Recurse = 1; # recurse on subdirectories in $podpath.
- $Quiet = 0; # not quiet by default
- $Verbose = 0; # not verbose by default
- $Doindex = 1; # non-zero if we should generate an index
- $Backlink = ''; # text for "back to top" links
- $Listlevel = 0; # current list depth
- @Listtype = (); # list types for open lists
- $ListNewTerm = 0; # indicates new term in definition list; used
- # to correctly open/close <dd> tags
- $Ignore = 1; # whether or not to format text. we don't
- # format text until we hit our first pod
- # directive.
-
- @Items_Seen = (); # for multiples of the same item in perlfunc
- %Items_Named = ();
- $Header = 0; # produce block header/footer
- $Title = ''; # title to give the pod(s)
- $Top = 1; # true if we are at the top of the doc. used
- # to prevent the first <hr /> directive.
- $Paragraph = ''; # which paragraph we're processing (used
- # for error messages)
- %Sections = (); # sections within this page
-
- %Local_Items = ();
- $Is83 = $^O eq 'dos'; # Is it an 8.3 filesystem?
-}
-
-#
-# clean_data: global clean-up of pod data
-#
-sub clean_data($){
- my( $dataref ) = @_;
- for my $i ( 0..$#{$dataref} ) {
- ${$dataref}[$i] =~ s/\s+\Z//;
-
- # have a look for all-space lines
- if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){
- my @chunks = split( /^\s+$/m, ${$dataref}[$i] );
- splice( @$dataref, $i, 1, @chunks );
- }
- }
-}
-
-
-sub pod2html {
- local(@ARGV) = @_;
- local($/);
- local $_;
-
- init_globals();
-
- $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
-
- # cache of %Pages and %Items from last time we ran pod2html
-
- #undef $opt_help if defined $opt_help;
-
- # parse the command-line parameters
- parse_command_line();
-
- # escape the backlink argument (same goes for title but is done later...)
- $Backlink = html_escape($Backlink) if defined $Backlink;
-
- # set some variables to their default values if necessary
- my $pod;
- unless (@ARGV && $ARGV[0]) {
- if ($Podfile and $Podfile ne '-') {
- open $pod, '<', $Podfile
- or die "$0: cannot open $Podfile file for input: $!\n";
- } else {
- open $pod, '-';
- }
- } else {
- $Podfile = $ARGV[0]; # XXX: might be more filenames
- $pod = *ARGV;
- }
- $Htmlfile = "-" unless $Htmlfile; # stdout
- $Htmlroot = "" if $Htmlroot eq "/"; # so we don't get a //
- $Htmldir =~ s#/\z## ; # so we don't get a //
- if ( $Htmlroot eq ''
- && defined( $Htmldir )
- && $Htmldir ne ''
- && substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir
- )
- {
- # Set the 'base' url for this file, so that we can use it
- # as the location from which to calculate relative links
- # to other files. If this is '', then absolute links will
- # be used throughout.
- $Htmlfileurl= "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1);
- }
-
- # read the pod a paragraph at a time
- warn "Scanning for sections in input file(s)\n" if $Verbose;
- $/ = "";
- my @poddata = <$pod>;
- close $pod;
-
- # be eol agnostic
- for (@poddata) {
- if (/\r/) {
- if (/\r\n/) {
- @poddata = map { s/\r\n/\n/g;
- /\n\n/ ?
- map { "$_\n\n" } split /\n\n/ :
- $_ } @poddata;
- } else {
- @poddata = map { s/\r/\n/g;
- /\n\n/ ?
- map { "$_\n\n" } split /\n\n/ :
- $_ } @poddata;
- }
- last;
- }
- }
-
- clean_data( \@poddata );
-
- # scan the pod for =head[1-6] directives and build an index
- my $index = scan_headings(\%Sections, @poddata);
-
- unless($index) {
- warn "No headings in $Podfile\n" if $Verbose;
- }
-
- # open the output file
- my $html;
- if($Htmlfile and $Htmlfile ne '-') {
- open $html, ">", $Htmlfile
- or die "$0: cannot open $Htmlfile file for output: $!\n";
- } else {
- open $html, ">-";
- }
-
- # put a title in the HTML file if one wasn't specified
- if ($Title eq '') {
- TITLE_SEARCH: {
- for (my $i = 0; $i < @poddata; $i++) {
- if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
- for my $para ( @poddata[$i, $i+1] ) {
- last TITLE_SEARCH
- if ($Title) = $para =~ /(\S+\s+-+.*\S)/s;
- }
- }
-
- }
- }
- }
- if (!$Title and $Podfile =~ /\.pod\z/) {
- # probably a split pod so take first =head[12] as title
- for (my $i = 0; $i < @poddata; $i++) {
- last if ($Title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
- }
- warn "adopted '$Title' as title for $Podfile\n"
- if $Verbose and $Title;
- }
- if ($Title) {
- $Title =~ s/\s*\(.*\)//;
- } else {
- warn "$0: no title for $Podfile.\n" unless $Quiet;
- $Podfile =~ /^(.*)(\.[^.\/]+)?\z/s;
- $Title = ($Podfile eq "-" ? 'No Title' : $1);
- warn "using $Title" if $Verbose;
- }
- $Title = html_escape($Title);
-
- my $csslink = '';
- my $bodystyle = ' style="background-color: white"';
- my $tdstyle = ' style="background-color: #cccccc"';
-
- if ($Css) {
- $csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />);
- $csslink =~ s,\\,/,g;
- $csslink =~ s,(/.):,$1|,;
- $bodystyle = '';
- $tdstyle = '';
- }
-
- my $block = $Header ? <<END_OF_BLOCK : '';
-<table border="0" width="100%" cellspacing="0" cellpadding="3">
-<tr><td class="block"$tdstyle valign="middle">
-<big><strong><span class="block"> $Title</span></strong></big>
-</td></tr>
-</table>
-END_OF_BLOCK
-
- print $html <<END_OF_HEAD;
-<?xml version="1.0" ?>
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
-<title>$Title</title>$csslink
-<meta http-equiv="content-type" content="text/html; charset=utf-8" />
-<link rev="made" href="mailto:$Config{perladmin}" />
-</head>
-
-<body$bodystyle>
-$block
-END_OF_HEAD
-
- # load/reload/validate/cache %Pages and %Items
- get_cache($Dircache, $Itemcache, \@Podpath, $Podroot, $Recurse);
-
- # scan the pod for =item directives
- scan_items( \%Local_Items, "", @poddata);
-
- # put an index at the top of the file. note, if $Doindex is 0 we
- # still generate an index, but surround it with an html comment.
- # that way some other program can extract it if desired.
- $index =~ s/--+/-/g;
-
- my $hr = ($Doindex and $index) ? qq(<hr name="index" />) : "";
-
- unless ($Doindex)
- {
- $index = qq(<!--\n$index\n-->\n);
- }
-
- print $html <<"END_OF_INDEX";
-
-<!-- INDEX BEGIN -->
-<div name="index">
-<p><a name=\"__index__\"></a></p>
-$index
-$hr
-</div>
-<!-- INDEX END -->
-
-END_OF_INDEX
-
- # now convert this file
- my $after_item; # set to true after an =item
- warn "Converting input file $Podfile\n" if $Verbose;
- foreach my $i (0..$#poddata){
- $_ = $poddata[$i];
- $Paragraph = $i+1;
- if (/^(=.*)/s) { # is it a pod directive?
- $Ignore = 0;
- $after_item = 0;
- $_ = $1;
- if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
- process_begin($html, $1, $2);
- } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
- process_end($1, $2);
- } elsif (/^=cut/) { # =cut
- process_cut();
- } elsif (/^=pod/) { # =pod
- process_pod();
- } else {
- next if @Begin_Stack && $Begin_Stack[-1] ne 'html';
-
- if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading
- process_head( $html, $1, $2, $Doindex && $index );
- } elsif (/^=item\s*(.*\S)?/sm) { # =item text
- process_item( $html, $1 );
- $after_item = 1;
- } elsif (/^=over\s*(.*)/) { # =over N
- process_over();
- } elsif (/^=back/) { # =back
- process_back( $html );
- } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for
- process_for( $html, $1, $2 );
- } else {
- /^=(\S*)\s*/;
- warn "$0: $Podfile: unknown pod directive '$1' in "
- . "paragraph $Paragraph. ignoring.\n" unless $Quiet;
- }
- }
- $Top = 0;
- }
- else {
- next if $Ignore;
- if (@Begin_Stack) {
- print $html $_ if $Begin_Stack[-1] eq 'html';
- next;
- }
- my $text = $_;
-
- # Open tag for definition list as we have something to put in it
- if( $ListNewTerm ){
- print $html "<dd>\n";
- $ListNewTerm = 0;
- }
-
- if( $text =~ /\A\s+/ ){
- process_pre( \$text );
- print $html "<pre>\n$text</pre>\n";
-
- } else {
- process_text( \$text );
-
- # experimental: check for a paragraph where all lines
- # have some ...\t...\t...\n pattern
- if( $text =~ /\t/ ){
- my @lines = split( "\n", $text );
- if( @lines > 1 ){
- my $all = 2;
- foreach my $line ( @lines ){
- if( $line =~ /\S/ && $line !~ /\t/ ){
- $all--;
- last if $all == 0;
- }
- }
- if( $all > 0 ){
- $text =~ s/\t+/<td>/g;
- $text =~ s/^/<tr><td>/gm;
- $text = '<table cellspacing="0" cellpadding="0">' .
- $text . '</table>';
- }
- }
- }
- ## end of experimental
-
- print $html "<p>$text</p>\n";
- }
- $after_item = 0;
- }
- }
-
- # finish off any pending directives
- finish_list( $html );
-
- # link to page index
- print $html "<p><a href=\"#__index__\"><small>$Backlink</small></a></p>\n"
- if $Doindex and $index and $Backlink;
-
- print $html <<END_OF_TAIL;
-$block
-</body>
-
-</html>
-END_OF_TAIL
-
- # close the html file
- close $html or die "Failed to close $Htmlfile: $!";
-
- warn "Finished\n" if $Verbose;
-}
-
-##############################################################################
-
-sub usage {
- my $podfile = shift;
- warn "$0: $podfile: @_\n" if @_;
- die <<END_OF_USAGE;
-Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
- --podpath=<name>:...:<name> --podroot=<name>
- --libpods=<name>:...:<name> --recurse --verbose --index
- --netscape --norecurse --noindex --cachedir=<name>
-
- --backlink - set text for "back to top" links (default: none).
- --cachedir - directory for the item and directory cache files.
- --css - stylesheet URL
- --flush - flushes the item and directory caches.
- --[no]header - produce block header/footer (default is no headers).
- --help - prints this message.
- --hiddendirs - search hidden directories in podpath
- --htmldir - directory for resulting HTML files.
- --htmlroot - http-server base directory from which all relative paths
- in podpath stem (default is /).
- --[no]index - generate an index at the top of the resulting html
- (default behaviour).
- --infile - filename for the pod to convert (input taken from stdin
- by default).
- --libpods - colon-separated list of pages to search for =item pod
- directives in as targets of C<> and implicit links (empty
- by default). note, these are not filenames, but rather
- page names like those that appear in L<> links.
- --outfile - filename for the resulting html file (output sent to
- stdout by default).
- --podpath - colon-separated list of directories containing library
- pods (empty by default).
- --podroot - filesystem base directory from which all relative paths
- in podpath stem (default is .).
- --[no]quiet - suppress some benign warning messages (default is off).
- --[no]recurse - recurse on those subdirectories listed in podpath
- (default behaviour).
- --title - title that will appear in resulting html file.
- --[no]verbose - self-explanatory (off by default).
- --[no]netscape - deprecated, has no effect. for backwards compatibility only.
-
-END_OF_USAGE
-
-}
-
-sub parse_command_line {
- my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help,
- $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,
- $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,
- $opt_recurse,$opt_title,$opt_verbose,$opt_hiddendirs);
-
- unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
- my $result = GetOptions(
- 'backlink=s' => \$opt_backlink,
- 'cachedir=s' => \$opt_cachedir,
- 'css=s' => \$opt_css,
- 'flush' => \$opt_flush,
- 'header!' => \$opt_header,
- 'help' => \$opt_help,
- 'hiddendirs!'=> \$opt_hiddendirs,
- 'htmldir=s' => \$opt_htmldir,
- 'htmlroot=s' => \$opt_htmlroot,
- 'index!' => \$opt_index,
- 'infile=s' => \$opt_infile,
- 'libpods=s' => \$opt_libpods,
- 'netscape!' => \$opt_netscape,
- 'outfile=s' => \$opt_outfile,
- 'podpath=s' => \$opt_podpath,
- 'podroot=s' => \$opt_podroot,
- 'quiet!' => \$opt_quiet,
- 'recurse!' => \$opt_recurse,
- 'title=s' => \$opt_title,
- 'verbose!' => \$opt_verbose,
- );
- usage("-", "invalid parameters") if not $result;
-
- usage("-") if defined $opt_help; # see if the user asked for help
- $opt_help = ""; # just to make -w shut-up.
-
- @Podpath = split(":", $opt_podpath) if defined $opt_podpath;
- @Libpods = split(":", $opt_libpods) if defined $opt_libpods;
-
- $Backlink = $opt_backlink if defined $opt_backlink;
- $Cachedir = $opt_cachedir if defined $opt_cachedir;
- $Css = $opt_css if defined $opt_css;
- $Header = $opt_header if defined $opt_header;
- $Htmldir = $opt_htmldir if defined $opt_htmldir;
- $Htmlroot = $opt_htmlroot if defined $opt_htmlroot;
- $Doindex = $opt_index if defined $opt_index;
- $Podfile = $opt_infile if defined $opt_infile;
- $HiddenDirs = $opt_hiddendirs if defined $opt_hiddendirs;
- $Htmlfile = $opt_outfile if defined $opt_outfile;
- $Podroot = $opt_podroot if defined $opt_podroot;
- $Quiet = $opt_quiet if defined $opt_quiet;
- $Recurse = $opt_recurse if defined $opt_recurse;
- $Title = $opt_title if defined $opt_title;
- $Verbose = $opt_verbose if defined $opt_verbose;
-
- warn "Flushing item and directory caches\n"
- if $opt_verbose && defined $opt_flush;
- $Dircache = "$Cachedir/pod2htmd.tmp";
- $Itemcache = "$Cachedir/pod2htmi.tmp";
- if (defined $opt_flush) {
- 1 while unlink($Dircache, $Itemcache);
- }
-}
-
-
-my $Saved_Cache_Key;
-
-sub get_cache {
- my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
- my @cache_key_args = @_;
-
- # A first-level cache:
- # Don't bother reading the cache files if they still apply
- # and haven't changed since we last read them.
-
- my $this_cache_key = cache_key(@cache_key_args);
-
- return if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key;
-
- # load the cache of %Pages and %Items if possible. $tests will be
- # non-zero if successful.
- my $tests = 0;
- if (-f $dircache && -f $itemcache) {
- warn "scanning for item cache\n" if $Verbose;
- $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
- }
-
- # if we didn't succeed in loading the cache then we must (re)build
- # %Pages and %Items.
- if (!$tests) {
- warn "scanning directories in pod-path\n" if $Verbose;
- scan_podpath($podroot, $recurse, 0);
- }
- $Saved_Cache_Key = cache_key(@cache_key_args);
-}
-
-sub cache_key {
- my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
- return join('!', $dircache, $itemcache, $recurse,
- @$podpath, $podroot, stat($dircache), stat($itemcache));
-}
-
-#
-# load_cache - tries to find if the caches stored in $dircache and $itemcache
-# are valid caches of %Pages and %Items. if they are valid then it loads
-# them and returns a non-zero value.
-#
-sub load_cache {
- my($dircache, $itemcache, $podpath, $podroot) = @_;
- my($tests);
- local $_;
-
- $tests = 0;
-
- open(CACHE, "<$itemcache") ||
- die "$0: error opening $itemcache for reading: $!\n";
- $/ = "\n";
-
- # is it the same podpath?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if (join(":", @$podpath) eq $_);
-
- # is it the same podroot?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if ($podroot eq $_);
-
- # load the cache if its good
- if ($tests != 2) {
- close(CACHE);
- return 0;
- }
-
- warn "loading item cache\n" if $Verbose;
- while (<CACHE>) {
- /(.*?) (.*)$/;
- $Items{$1} = $2;
- }
- close(CACHE);
-
- warn "scanning for directory cache\n" if $Verbose;
- open(CACHE, "<$dircache") ||
- die "$0: error opening $dircache for reading: $!\n";
- $/ = "\n";
- $tests = 0;
-
- # is it the same podpath?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if (join(":", @$podpath) eq $_);
-
- # is it the same podroot?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if ($podroot eq $_);
-
- # load the cache if its good
- if ($tests != 2) {
- close(CACHE);
- return 0;
- }
-
- warn "loading directory cache\n" if $Verbose;
- while (<CACHE>) {
- /(.*?) (.*)$/;
- $Pages{$1} = $2;
- }
-
- close(CACHE);
-
- return 1;
-}
-
-#
-# scan_podpath - scans the directories specified in @podpath for directories,
-# .pod files, and .pm files. it also scans the pod files specified in
-# @Libpods for =item directives.
-#
-sub scan_podpath {
- my($podroot, $recurse, $append) = @_;
- my($pwd, $dir);
- my($libpod, $dirname, $pod, @files, @poddata);
-
- unless($append) {
- %Items = ();
- %Pages = ();
- }
-
- # scan each directory listed in @Podpath
- $pwd = getcwd();
- chdir($podroot)
- || die "$0: error changing to directory $podroot: $!\n";
- foreach $dir (@Podpath) {
- scan_dir($dir, $recurse);
- }
-
- # scan the pods listed in @Libpods for =item directives
- foreach $libpod (@Libpods) {
- # if the page isn't defined then we won't know where to find it
- # on the system.
- next unless defined $Pages{$libpod} && $Pages{$libpod};
-
- # if there is a directory then use the .pod and .pm files within it.
- # NOTE: Only finds the first so-named directory in the tree.
-# if ($Pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
- if ($Pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
- # find all the .pod and .pm files within the directory
- $dirname = $1;
- opendir(DIR, $dirname) ||
- die "$0: error opening directory $dirname: $!\n";
- @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR));
- closedir(DIR);
-
- # scan each .pod and .pm file for =item directives
- foreach $pod (@files) {
- open my $fh, '<', "$dirname/$pod"
- or die "$0: error opening $dirname/$pod for input: $!\n";
- @poddata = <$fh>;
- close $fh;
- clean_data( \@poddata );
-
- scan_items( \%Items, "$dirname/$pod", @poddata);
- }
-
- # use the names of files as =item directives too.
-### Don't think this should be done this way - confuses issues.(WL)
-### foreach $pod (@files) {
-### $pod =~ /^(.*)(\.pod|\.pm)$/;
-### $Items{$1} = "$dirname/$1.html" if $1;
-### }
- } elsif ($Pages{$libpod} =~ /([^:]*\.pod):/ ||
- $Pages{$libpod} =~ /([^:]*\.pm):/) {
- # scan the .pod or .pm file for =item directives
- $pod = $1;
- open my $fh, '<', $pod
- or die "$0: error opening $pod for input: $!\n";
- @poddata = <$fh>;
- close $fh;
- clean_data( \@poddata );
-
- scan_items( \%Items, "$pod", @poddata);
- } else {
- warn "$0: shouldn't be here (line ".__LINE__."\n" unless $Quiet;
- }
- }
- @poddata = (); # clean-up a bit
-
- chdir($pwd)
- || die "$0: error changing to directory $pwd: $!\n";
-
- # cache the item list for later use
- warn "caching items for later use\n" if $Verbose;
- open my $cache, '>', $Itemcache
- or die "$0: error open $Itemcache for writing: $!\n";
-
- print $cache join(":", @Podpath) . "\n$podroot\n";
- foreach my $key (keys %Items) {
- print $cache "$key $Items{$key}\n";
- }
-
- close $cache or die "error closing $Itemcache: $!";
-
- # cache the directory list for later use
- warn "caching directories for later use\n" if $Verbose;
- open $cache, '>', $Dircache
- or die "$0: error open $Dircache for writing: $!\n";
-
- print $cache join(":", @Podpath) . "\n$podroot\n";
- foreach my $key (keys %Pages) {
- print $cache "$key $Pages{$key}\n";
- }
-
- close $cache or die "error closing $Dircache: $!";
-}
-
-#
-# scan_dir - scans the directory specified in $dir for subdirectories, .pod
-# files, and .pm files. notes those that it finds. this information will
-# be used later in order to figure out where the pages specified in L<>
-# links are on the filesystem.
-#
-sub scan_dir {
- my($dir, $recurse) = @_;
- my($t, @subdirs, @pods, $pod, $dirname, @dirs);
- local $_;
-
- @subdirs = ();
- @pods = ();
-
- opendir(DIR, $dir) ||
- die "$0: error opening directory $dir: $!\n";
- while (defined($_ = readdir(DIR))) {
- if (-d "$dir/$_" && $_ ne "." && $_ ne ".."
- && ($HiddenDirs || !/^\./)
- ) { # directory
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_:";
- push(@subdirs, $_);
- } elsif (/\.pod\z/) { # .pod
- s/\.pod\z//;
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pod:";
- push(@pods, "$dir/$_.pod");
- } elsif (/\.html\z/) { # .html
- s/\.html\z//;
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pod:";
- } elsif (/\.pm\z/) { # .pm
- s/\.pm\z//;
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pm:";
- push(@pods, "$dir/$_.pm");
- } elsif (-T "$dir/$_") { # script(?)
- local *F;
- if (open(F, "$dir/$_")) {
- my $line;
- while (defined($line = <F>)) {
- if ($line =~ /^=(?:pod|head1)/) {
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pod:";
- last;
- }
- }
- close(F);
- }
- }
- }
- closedir(DIR);
-
- # recurse on the subdirectories if necessary
- if ($recurse) {
- foreach my $subdir (@subdirs) {
- scan_dir("$dir/$subdir", $recurse);
- }
- }
-}
-
-#
-# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
-# build an index.
-#
-sub scan_headings {
- my($sections, @data) = @_;
- my($tag, $which_head, $otitle, $listdepth, $index);
-
- local $Ignore = 0;
-
- $listdepth = 0;
- $index = "";
-
- # scan for =head directives, note their name, and build an index
- # pointing to each of them.
- foreach my $line (@data) {
- if ($line =~ /^=(head)([1-6])\s+(.*)/) {
- ($tag, $which_head, $otitle) = ($1,$2,$3);
-
- my $title = depod( $otitle );
- my $name = anchorify( $title );
- $$sections{$name} = 1;
- $title = process_text( \$otitle );
-
- while ($which_head != $listdepth) {
- if ($which_head > $listdepth) {
- $index .= "\n" . ("\t" x $listdepth) . "<ul>\n";
- $listdepth++;
- } elsif ($which_head < $listdepth) {
- $listdepth--;
- $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
- }
- }
-
- $index .= "\n" . ("\t" x $listdepth) . "<li>" .
- "<a href=\"#" . $name . "\">" .
- $title . "</a></li>";
- }
- }
-
- # finish off the lists
- while ($listdepth--) {
- $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
- }
-
- # get rid of bogus lists
- $index =~ s,\t*<ul>\s*</ul>\n,,g;
-
- return $index;
-}
-
-#
-# scan_items - scans the pod specified by $pod for =item directives. we
-# will use this information later on in resolving C<> links.
-#
-sub scan_items {
- my( $itemref, $pod, @poddata ) = @_;
- my($i, $item);
- local $_;
-
- $pod =~ s/\.pod\z//;
- $pod .= ".html" if $pod;
-
- foreach $i (0..$#poddata) {
- my $txt = depod( $poddata[$i] );
-
- # figure out what kind of item it is.
- # Build string for referencing this item.
- if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bulleted list
- next unless $1;
- $item = $1;
- } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list
- $item = $1;
- } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # definition list
- $item = $1;
- } else {
- next;
- }
- my $fid = fragment_id( $item );
- $$itemref{$fid} = "$pod" if $fid;
- }
-}
-
-#
-# process_head - convert a pod head[1-6] tag and convert it to HTML format.
-#
-sub process_head {
- my($fh, $tag, $heading, $hasindex) = @_;
-
- # figure out the level of the =head
- $tag =~ /head([1-6])/;
- my $level = $1;
-
- finish_list( $fh );
-
- print $fh "<p>\n";
- if( $level == 1 && ! $Top ){
- print $fh "<a href=\"#__index__\"><small>$Backlink</small></a>\n"
- if $hasindex and $Backlink;
- print $fh "</p>\n<hr />\n"
- } else {
- print $fh "</p>\n";
- }
-
- my $name = anchorify( depod( $heading ) );
- my $convert = process_text( \$heading );
- print $fh "<h$level><a name=\"$name\">$convert</a></h$level>\n";
-}
-
-
-#
-# emit_item_tag - print an =item's text
-# Note: The global $EmittedItem is used for inhibiting self-references.
-#
-my $EmittedItem;
-
-sub emit_item_tag {
- my( $fh, $otext, $text, $compact ) = @_;
- my $item = fragment_id( depod($text) , -generate);
- Carp::confess("Undefined fragment '$text' (".depod($text).") from fragment_id() in emit_item_tag() in $Podfile")
- if !defined $item;
- $EmittedItem = $item;
- ### print STDERR "emit_item_tag=$item ($text)\n";
-
- print $fh '<strong>';
- if ($Items_Named{$item}++) {
- print $fh process_text( \$otext );
- } else {
- my $name = $item;
- $name = anchorify($name);
- print $fh qq{<a name="$name" class="item">}, process_text( \$otext ), '</a>';
- }
- print $fh "</strong>";
- undef( $EmittedItem );
-}
-
-sub new_listitem {
- my ($fh, $tag) = @_;
- # Open tag for definition list as we have something to put in it
- if( ($tag ne 'dl') && ($ListNewTerm) ){
- print $fh "<dd>\n";
- $ListNewTerm = 0;
- }
-
- if( $Items_Seen[$Listlevel]++ == 0 ){
- # start of new list
- push( @Listtype, "$tag" );
- print $fh "<$tag>\n";
- } else {
- # if this is not the first item, close the previous one
- if ( $tag eq 'dl' ){
- print $fh "</dd>\n" unless $ListNewTerm;
- } else {
- print $fh "</li>\n";
- }
- }
- my $opentag = $tag eq 'dl' ? 'dt' : 'li';
- print $fh "<$opentag>";
-}
-
-#
-# process_item - convert a pod item tag and convert it to HTML format.
-#
-sub process_item {
- my ($fh, $otext) = @_;
-
- # lots of documents start a list without doing an =over. this is
- # bad! but, the proper thing to do seems to be to just assume
- # they did do an =over. so warn them once and then continue.
- if( $Listlevel == 0 ){
- warn "$0: $Podfile: unexpected =item directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- process_over();
- }
-
- # remove formatting instructions from the text
- my $text = depod( $otext );
-
- # all the list variants:
- if( $text =~ /\A\*/ ){ # bullet
- new_listitem( $fh, 'ul' );
- if ($text =~ /\A\*\s+(\S.*)\Z/s ) { # with additional text
- my $tag = $1;
- $otext =~ s/\A\*\s+//;
- emit_item_tag( $fh, $otext, $tag, 1 );
- print $fh "\n";
- }
-
- } elsif( $text =~ /\A\d+/ ){ # numbered list
- new_listitem( $fh, 'ol' );
- if ($text =~ /\A(?>\d+\.?)\s*(\S.*)\Z/s ) { # with additional text
- my $tag = $1;
- $otext =~ s/\A\d+\.?\s*//;
- emit_item_tag( $fh, $otext, $tag, 1 );
- print $fh "\n";
- }
-
- } else { # definition list
- # new_listitem takes care of opening the <dt> tag
- new_listitem( $fh, 'dl' );
- if ($text =~ /\A(.+)\Z/s ){ # should have text
- emit_item_tag( $fh, $otext, $text, 1 );
- # write the definition term and close <dt> tag
- print $fh "</dt>\n";
- }
- # trigger opening a <dd> tag for the actual definition; will not
- # happen if next paragraph is also a definition term (=item)
- $ListNewTerm = 1;
- }
- print $fh "\n";
-}
-
-#
-# process_over - process a pod over tag and start a corresponding HTML list.
-#
-sub process_over {
- # start a new list
- $Listlevel++;
- push( @Items_Seen, 0 );
-}
-
-#
-# process_back - process a pod back tag and convert it to HTML format.
-#
-sub process_back {
- my $fh = shift;
- if( $Listlevel == 0 ){
- warn "$0: $Podfile: unexpected =back directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- return;
- }
-
- # close off the list. note, I check to see if $Listtype[$Listlevel] is
- # defined because an =item directive may have never appeared and thus
- # $Listtype[$Listlevel] may have never been initialized.
- $Listlevel--;
- if( defined $Listtype[$Listlevel] ){
- if ( $Listtype[$Listlevel] eq 'dl' ){
- print $fh "</dd>\n" unless $ListNewTerm;
- } else {
- print $fh "</li>\n";
- }
- print $fh "</$Listtype[$Listlevel]>\n";
- pop( @Listtype );
- $ListNewTerm = 0;
- }
-
- # clean up item count
- pop( @Items_Seen );
-}
-
-#
-# process_cut - process a pod cut tag, thus start ignoring pod directives.
-#
-sub process_cut {
- $Ignore = 1;
-}
-
-#
-# process_pod - process a pod tag, thus stop ignoring pod directives
-# until we see a corresponding cut.
-#
-sub process_pod {
- # no need to set $Ignore to 0 cause the main loop did it
-}
-
-#
-# process_for - process a =for pod tag. if it's for html, spit
-# it out verbatim, if illustration, center it, otherwise ignore it.
-#
-sub process_for {
- my ($fh, $whom, $text) = @_;
- if ( $whom =~ /^(pod2)?html$/i) {
- print $fh $text;
- } elsif ($whom =~ /^illustration$/i) {
- 1 while chomp $text;
- for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
- $text .= $ext, last if -r "$text$ext";
- }
- print $fh qq{<p align="center"><img src="$text" alt="$text illustration" /></p>};
- }
-}
-
-#
-# process_begin - process a =begin pod tag. this pushes
-# whom we're beginning on the begin stack. if there's a
-# begin stack, we only print if it us.
-#
-sub process_begin {
- my ($fh, $whom, $text) = @_;
- $whom = lc($whom);
- push (@Begin_Stack, $whom);
- if ( $whom =~ /^(pod2)?html$/) {
- print $fh $text if $text;
- }
-}
-
-#
-# process_end - process a =end pod tag. pop the
-# begin stack. die if we're mismatched.
-#
-sub process_end {
- my($whom, $text) = @_;
- $whom = lc($whom);
- if (!defined $Begin_Stack[-1] or $Begin_Stack[-1] ne $whom ) {
- Carp::confess("Unmatched begin/end at chunk $Paragraph in pod $Podfile\n")
- }
- pop( @Begin_Stack );
-}
-
-#
-# process_pre - indented paragraph, made into <pre></pre>
-#
-sub process_pre {
- my( $text ) = @_;
- my( $rest );
- return if $Ignore;
-
- $rest = $$text;
-
- # insert spaces in place of tabs
- $rest =~ s#(.+)#
- my $line = $1;
- 1 while $line =~ s/(\t+)/' ' x ((length($1) * 8) - $-[0] % 8)/e;
- $line;
- #eg;
-
- # convert some special chars to HTML escapes
- $rest = html_escape($rest);
-
- # try and create links for all occurrences of perl.* within
- # the preformatted text.
- $rest =~ s{
- (\s*)(perl\w+)
- }{
- if ( defined $Pages{$2} ){ # is a link
- qq($1<a href="$Htmlroot/$Pages{$2}">$2</a>);
- } elsif (defined $Pages{dosify($2)}) { # is a link
- qq($1<a href="$Htmlroot/$Pages{dosify($2)}">$2</a>);
- } else {
- "$1$2";
- }
- }xeg;
- $rest =~ s{
- (<a\ href="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
- }{
- my $url ;
- if ( $Htmlfileurl ne '' ){
- # Here, we take advantage of the knowledge
- # that $Htmlfileurl ne '' implies $Htmlroot eq ''.
- # Since $Htmlroot eq '', we need to prepend $Htmldir
- # on the fron of the link to get the absolute path
- # of the link's target. We check for a leading '/'
- # to avoid corrupting links that are #, file:, etc.
- my $old_url = $3 ;
- $old_url = "$Htmldir$old_url" if $old_url =~ m{^\/};
- $url = relativize_url( "$old_url.html", $Htmlfileurl );
- } else {
- $url = "$3.html" ;
- }
- "$1$url" ;
- }xeg;
-
- # Look for embedded URLs and make them into links. We don't
- # relativize them since they are best left as the author intended.
-
- my $urls = '(' . join ('|', qw{
- http
- telnet
- mailto
- news
- gopher
- file
- wais
- ftp
- } )
- . ')';
-
- my $ltrs = '\w';
- my $gunk = '/#~:.?+=&%@!\-';
- my $punc = '.:!?\-;';
- my $any = "${ltrs}${gunk}${punc}";
-
- $rest =~ s{
- \b # start at word boundary
- ( # begin $1 {
- $urls : # need resource and a colon
- (?!:) # Ignore File::, among others.
- [$any] +? # followed by one or more of any valid
- # character, but be conservative and
- # take only what you need to....
- ) # end $1 }
- (?=
- " > # maybe pre-quoted '<a href="...">'
- | # or:
- [$punc]* # 0 or more punctuation
- (?: # followed
- [^$any] # by a non-url char
- | # or
- $ # end of the string
- ) #
- | # or else
- $ # then end of the string
- )
- }{<a href="$1">$1</a>}igox;
-
- # text should be as it is (verbatim)
- $$text = $rest;
-}
-
-
-#
-# pure text processing
-#
-# pure_text/inIS_text: differ with respect to automatic C<> recognition.
-# we don't want this to happen within IS
-#
-sub pure_text($){
- my $text = shift();
- process_puretext( $text, 1 );
-}
-
-sub inIS_text($){
- my $text = shift();
- process_puretext( $text, 0 );
-}
-
-#
-# process_puretext - process pure text (without pod-escapes) converting
-# double-quotes and handling implicit C<> links.
-#
-sub process_puretext {
- my($text, $notinIS) = @_;
-
- ## Guessing at func() or [\$\@%&]*var references in plain text is destined
- ## to produce some strange looking ref's. uncomment to disable:
- ## $notinIS = 0;
-
- my(@words, $lead, $trail);
-
- # keep track of leading and trailing white-space
- $lead = ($text =~ s/\A(\s+)//s ? $1 : "");
- $trail = ($text =~ s/(\s+)\Z//s ? $1 : "");
-
- # split at space/non-space boundaries
- @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text );
-
- # process each word individually
- foreach my $word (@words) {
- # skip space runs
- next if $word =~ /^\s*$/;
- # see if we can infer a link or a function call
- #
- # NOTE: This is a word based search, it won't automatically
- # mark "substr($var, 1, 2)" because the 1st word would be "substr($var"
- # User has to enclose those with proper C<>
-
- if( $notinIS && $word =~
- m/
- ^([a-z_]{2,}) # The function name
- \(
- ([0-9][a-z]* # Manual page(1) or page(1M)
- |[^)]*[\$\@\%][^)]+ # ($foo), (1, @foo), (%hash)
- | # ()
- )
- \)
- ([.,;]?)$ # a possible punctuation follows
- /xi
- ) {
- # has parenthesis so should have been a C<> ref
- ## try for a pagename (perlXXX(1))?
- my( $func, $args, $rest ) = ( $1, $2, $3 || '' );
- if( $args =~ /^\d+$/ ){
- my $url = page_sect( $word, '' );
- if( defined $url ){
- $word = qq(<a href="$url" class="man">the $word manpage</a>$rest);
- next;
- }
- }
- ## try function name for a link, append tt'ed argument list
- $word = emit_C( $func, '', "($args)") . $rest;
-
-#### disabled. either all (including $\W, $\w+{.*} etc.) or nothing.
-## } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) {
-## # perl variables, should be a C<> ref
-## $word = emit_C( $word );
-
- } elsif ($word =~ m,^\w+://\w,) {
- # looks like a URL
- # Don't relativize it: leave it as the author intended
- $word = qq(<a href="$word">$word</a>);
- } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
- # looks like an e-mail address
- my ($w1, $w2, $w3) = ("", $word, "");
- ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
- ($w1, $w2, $w3) = ("<", $1, ">$2") if $word =~ /^<(.*?)>(,?)/;
- $word = qq($w1<a href="mailto:$w2">$w2</a>$w3);
- } else {
- $word = html_escape($word) if $word =~ /["&<>]/;
- }
- }
-
- # put everything back together
- return $lead . join( '', @words ) . $trail;
-}
-
-
-#
-# process_text - handles plaintext that appears in the input pod file.
-# there may be pod commands embedded within the text so those must be
-# converted to html commands.
-#
-
-sub process_text1($$;$$);
-sub pattern ($) { $_[0] ? '\s+'.('>' x ($_[0] + 1)) : '>' }
-sub closing ($) { local($_) = shift; (defined && s/\s+\z//) ? length : 0 }
-
-sub process_text {
- return if $Ignore;
- my( $tref ) = @_;
- my $res = process_text1( 0, $tref );
- $res =~ s/\s+$//s;
- $$tref = $res;
-}
-
-sub process_text_rfc_links {
- my $text = shift;
-
- # For every "RFCnnnn" or "RFC nnn", link it to the authoritative
- # ource. Do not use the /i modifier here. Require "RFC" to be written in
- # in capital letters.
-
- $text =~ s{
- (?<=[^<>[:alpha:]]) # Make sure this is not an URL already
- (RFC\s*([0-9]{1,5}))(?![0-9]) # max 5 digits
- }
- {<a href="http://www.ietf.org/rfc/rfc$2.txt" class="rfc">$1</a>}gx;
-
- $text;
-}
-
-sub process_text1($$;$$){
- my( $lev, $rstr, $func, $closing ) = @_;
- my $res = '';
-
- unless (defined $func) {
- $func = '';
- $lev++;
- }
-
- if( $func eq 'B' ){
- # B<text> - boldface
- $res = '<strong>' . process_text1( $lev, $rstr ) . '</strong>';
-
- } elsif( $func eq 'C' ){
- # C<code> - can be a ref or <code></code>
- # need to extract text
- my $par = go_ahead( $rstr, 'C', $closing );
-
- ## clean-up of the link target
- my $text = depod( $par );
-
- ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ;
- ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n";
-
- $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
-
- } elsif( $func eq 'E' ){
- # E<x> - convert to character
- $$rstr =~ s/^([^>]*)>//;
- my $escape = $1;
- $escape =~ s/^0?x([\dA-F]+)$/#x$1/i
- or $escape =~ s/^0([0-7]+)$/'#'.oct($1)/ei
- or $escape =~ s/^(\d+)$/#$1/;
- $res = "&$escape;";
-
- } elsif( $func eq 'F' ){
- # F<filename> - italicize
- $res = '<em class="file">' . process_text1( $lev, $rstr ) . '</em>';
-
- } elsif( $func eq 'I' ){
- # I<text> - italicize
- $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
-
- } elsif( $func eq 'L' ){
- # L<link> - link
- ## L<text|cross-ref> => produce text, use cross-ref for linking
- ## L<cross-ref> => make text from cross-ref
- ## need to extract text
- my $par = go_ahead( $rstr, 'L', $closing );
-
- # some L<>'s that shouldn't be:
- # a) full-blown URL's are emitted as-is
- if( $par =~ m{^\w+://}s ){
- return make_URL_href( $par );
- }
- # b) C<...> is stripped and treated as C<>
- if( $par =~ /^C<(.*)>$/ ){
- my $text = depod( $1 );
- return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
- }
-
- # analyze the contents
- $par =~ s/\n/ /g; # undo word-wrapped tags
- my $opar = $par;
- my $linktext;
- if( $par =~ s{^([^|]+)\|}{} ){
- $linktext = $1;
- }
-
- # make sure sections start with a /
- $par =~ s{^"}{/"};
-
- my( $page, $section, $ident );
-
- # check for link patterns
- if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){ # name/ident
- # we've got a name/ident (no quotes)
- if (length $2) {
- ( $page, $ident ) = ( $1, $2 );
- } else {
- ( $page, $section ) = ( $1, $2 );
- }
- ### print STDERR "--> L<$par> to page $page, ident $ident\n";
-
- } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section"
- # even though this should be a "section", we go for ident first
- ( $page, $ident ) = ( $1, $2 );
- ### print STDERR "--> L<$par> to page $page, section $section\n";
-
- } elsif( $par =~ /\s/ ){ # this must be a section with missing quotes
- ( $page, $section ) = ( '', $par );
- ### print STDERR "--> L<$par> to void page, section $section\n";
-
- } else {
- ( $page, $section ) = ( $par, '' );
- ### print STDERR "--> L<$par> to page $par, void section\n";
- }
-
- # now, either $section or $ident is defined. the convoluted logic
- # below tries to resolve L<> according to what the user specified.
- # failing this, we try to find the next best thing...
- my( $url, $ltext, $fid );
-
- RESOLVE: {
- if( defined $ident ){
- ## try to resolve $ident as an item
- ( $url, $fid ) = coderef( $page, $ident );
- if( $url ){
- if( ! defined( $linktext ) ){
- $linktext = $ident;
- $linktext .= " in " if $ident && $page;
- $linktext .= "the $page manpage" if $page;
- }
- ### print STDERR "got coderef url=$url\n";
- last RESOLVE;
- }
- ## no luck: go for a section (auto-quoting!)
- $section = $ident;
- }
- ## now go for a section
- my $htmlsection = htmlify( $section );
- $url = page_sect( $page, $htmlsection );
- if( $url ){
- if( ! defined( $linktext ) ){
- $linktext = $section;
- $linktext .= " in " if $section && $page;
- $linktext .= "the $page manpage" if $page;
- }
- ### print STDERR "got page/section url=$url\n";
- last RESOLVE;
- }
- ## no luck: go for an ident
- if( $section ){
- $ident = $section;
- } else {
- $ident = $page;
- $page = undef();
- }
- ( $url, $fid ) = coderef( $page, $ident );
- if( $url ){
- if( ! defined( $linktext ) ){
- $linktext = $ident;
- $linktext .= " in " if $ident && $page;
- $linktext .= "the $page manpage" if $page;
- }
- ### print STDERR "got section=>coderef url=$url\n";
- last RESOLVE;
- }
-
- # warning; show some text.
- $linktext = $opar unless defined $linktext;
- warn "$0: $Podfile: cannot resolve L<$opar> in paragraph $Paragraph.\n" unless $Quiet;
- }
-
- # now we have a URL or just plain code
- $$rstr = $linktext . '>' . $$rstr;
- if( defined( $url ) ){
- $res = "<a href=\"$url\">" . process_text1( $lev, $rstr ) . '</a>';
- } else {
- $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
- }
-
- } elsif( $func eq 'S' ){
- # S<text> - non-breaking spaces
- $res = process_text1( $lev, $rstr );
- $res =~ s/ / /g;
-
- } elsif( $func eq 'X' ){
- # X<> - ignore
- warn "$0: $Podfile: invalid X<> in paragraph $Paragraph.\n"
- unless $$rstr =~ s/^[^>]*>// or $Quiet;
- } elsif( $func eq 'Z' ){
- # Z<> - empty
- warn "$0: $Podfile: invalid Z<> in paragraph $Paragraph.\n"
- unless $$rstr =~ s/^>// or $Quiet;
-
- } else {
- my $term = pattern $closing;
- while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
- # all others: either recurse into new function or
- # terminate at closing angle bracket(s)
- my $pt = $1;
- $pt .= $2 if !$3 && $lev == 1;
- $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt );
- return $res if !$3 && $lev > 1;
- if( $3 ){
- $res .= process_text1( $lev, $rstr, $3, closing $4 );
- }
- }
- if( $lev == 1 ){
- $res .= pure_text( $$rstr );
- } elsif( ! $Quiet ) {
- my $snippet = substr($$rstr,0,60);
- warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph: '$snippet'.\n"
-
- }
- $res = process_text_rfc_links($res);
- }
- return $res;
-}
-
-#
-# go_ahead: extract text of an IS (can be nested)
-#
-sub go_ahead($$$){
- my( $rstr, $func, $closing ) = @_;
- my $res = '';
- my @closing = ($closing);
- while( $$rstr =~
- s/\A(.*?)(([BCEFILSXZ])<(<+\s+)?|@{[pattern $closing[0]]})//s ){
- $res .= $1;
- unless( $3 ){
- shift @closing;
- return $res unless @closing;
- } else {
- unshift @closing, closing $4;
- }
- $res .= $2;
- }
- unless ($Quiet) {
- my $snippet = substr($$rstr,0,60);
- warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph (go_ahead): '$snippet'.\n"
- }
- return $res;
-}
-
-#
-# emit_C - output result of C<text>
-# $text is the depod-ed text
-#
-sub emit_C($;$$){
- my( $text, $nocode, $args ) = @_;
- $args = '' unless defined $args;
- my $res;
- my( $url, $fid ) = coderef( undef(), $text );
-
- # need HTML-safe text
- my $linktext = html_escape( "$text$args" );
-
- if( defined( $url ) &&
- (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){
- $res = "<a href=\"$url\"><code>$linktext</code></a>";
- } elsif( 0 && $nocode ){
- $res = $linktext;
- } else {
- $res = "<code>$linktext</code>";
- }
- return $res;
-}
-
-#
-# html_escape: make text safe for HTML
-#
-sub html_escape {
- my $rest = $_[0];
- $rest =~ s/&/&/g;
- $rest =~ s/</</g;
- $rest =~ s/>/>/g;
- $rest =~ s/"/"/g;
- # ' is only in XHTML, not HTML4. Be conservative
- #$rest =~ s/'/'/g;
- return $rest;
-}
-
-
-#
-# dosify - convert filenames to 8.3
-#
-sub dosify {
- my($str) = @_;
- return lc($str) if $^O eq 'VMS'; # VMS just needs casing
- if ($Is83) {
- $str = lc $str;
- $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
- $str =~ s/(\w+)/substr ($1,0,8)/ge;
- }
- return $str;
-}
-
-#
-# page_sect - make a URL from the text of a L<>
-#
-sub page_sect($$) {
- my( $page, $section ) = @_;
- my( $linktext, $page83, $link); # work strings
-
- # check if we know that this is a section in this page
- if (!defined $Pages{$page} && defined $Sections{$page}) {
- $section = $page;
- $page = "";
- ### print STDERR "reset page='', section=$section\n";
- }
-
- $page83=dosify($page);
- $page=$page83 if (defined $Pages{$page83});
- if ($page eq "") {
- $link = "#" . anchorify( $section );
- } elsif ( $page =~ /::/ ) {
- $page =~ s,::,/,g;
- # Search page cache for an entry keyed under the html page name,
- # then look to see what directory that page might be in. NOTE:
- # this will only find one page. A better solution might be to produce
- # an intermediate page that is an index to all such pages.
- my $page_name = $page ;
- $page_name =~ s,^.*/,,s ;
- if ( defined( $Pages{ $page_name } ) &&
- $Pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/
- ) {
- $page = $1 ;
- }
- else {
- # NOTE: This branch assumes that all A::B pages are located in
- # $Htmlroot/A/B.html . This is often incorrect, since they are
- # often in $Htmlroot/lib/A/B.html or such like. Perhaps we could
- # analyze the contents of %Pages and figure out where any
- # cousins of A::B are, then assume that. So, if A::B isn't found,
- # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
- # lib/A/B.pm. This is also limited, but it's an improvement.
- # Maybe a hints file so that the links point to the correct places
- # nonetheless?
-
- }
- $link = "$Htmlroot/$page.html";
- $link .= "#" . anchorify( $section ) if ($section);
- } elsif (!defined $Pages{$page}) {
- $link = "";
- } else {
- $section = anchorify( $section ) if $section ne "";
- ### print STDERR "...section=$section\n";
-
- # if there is a directory by the name of the page, then assume that an
- # appropriate section will exist in the subdirectory
-# if ($section ne "" && $Pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
- if ($section ne "" && $Pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
- $link = "$Htmlroot/$1/$section.html";
- ### print STDERR "...link=$link\n";
-
- # since there is no directory by the name of the page, the section will
- # have to exist within a .html of the same name. thus, make sure there
- # is a .pod or .pm that might become that .html
- } else {
- $section = "#$section" if $section;
- ### print STDERR "...section=$section\n";
-
- # check if there is a .pod with the page name.
- # for L<Foo>, Foo.(pod|pm) is preferred to A/Foo.(pod|pm)
- if ($Pages{$page} =~ /([^:]*)\.(?:pod|pm):/) {
- $link = "$Htmlroot/$1.html$section";
- } else {
- $link = "";
- }
- }
- }
-
- if ($link) {
- # Here, we take advantage of the knowledge that $Htmlfileurl ne ''
- # implies $Htmlroot eq ''. This means that the link in question
- # needs a prefix of $Htmldir if it begins with '/'. The test for
- # the initial '/' is done to avoid '#'-only links, and to allow
- # for other kinds of links, like file:, ftp:, etc.
- my $url ;
- if ( $Htmlfileurl ne '' ) {
- $link = "$Htmldir$link" if $link =~ m{^/}s;
- $url = relativize_url( $link, $Htmlfileurl );
-# print( " b: [$link,$Htmlfileurl,$url]\n" );
- }
- else {
- $url = $link ;
- }
- return $url;
-
- } else {
- return undef();
- }
-}
-
-#
-# relativize_url - convert an absolute URL to one relative to a base URL.
-# Assumes both end in a filename.
-#
-sub relativize_url {
- my ($dest,$source) = @_ ;
-
- my ($dest_volume,$dest_directory,$dest_file) =
- File::Spec::Unix->splitpath( $dest ) ;
- $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
-
- my ($source_volume,$source_directory,$source_file) =
- File::Spec::Unix->splitpath( $source ) ;
- $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
-
- my $rel_path = '' ;
- if ( $dest ne '' ) {
- $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
- }
-
- if ( $rel_path ne '' &&
- substr( $rel_path, -1 ) ne '/' &&
- substr( $dest_file, 0, 1 ) ne '#'
- ) {
- $rel_path .= "/$dest_file" ;
- }
- else {
- $rel_path .= "$dest_file" ;
- }
-
- return $rel_path ;
-}
-
-
-#
-# coderef - make URL from the text of a C<>
-#
-sub coderef($$){
- my( $page, $item ) = @_;
- my( $url );
-
- my $fid = fragment_id( $item );
-
- if( defined( $page ) && $page ne "" ){
- # we have been given a $page...
- $page =~ s{::}{/}g;
-
- Carp::confess("Undefined fragment '$item' from fragment_id() in coderef() in $Podfile")
- if !defined $fid;
- # Do we take it? Item could be a section!
- my $base = $Items{$fid} || "";
- $base =~ s{[^/]*/}{};
- if( $base ne "$page.html" ){
- ### print STDERR "coderef( $page, $item ): items{$fid} = $Items{$fid} = $base => discard page!\n";
- $page = undef();
- }
-
- } else {
- # no page - local items precede cached items
- if( defined( $fid ) ){
- if( exists $Local_Items{$fid} ){
- $page = $Local_Items{$fid};
- } else {
- $page = $Items{$fid};
- }
- }
- }
-
- # if there was a pod file that we found earlier with an appropriate
- # =item directive, then create a link to that page.
- if( defined $page ){
- if( $page ){
- if( exists $Pages{$page} and $Pages{$page} =~ /([^:.]*)\.[^:]*:/){
- $page = $1 . '.html';
- }
- my $link = "$Htmlroot/$page#" . anchorify($fid);
-
- # Here, we take advantage of the knowledge that $Htmlfileurl
- # ne '' implies $Htmlroot eq ''.
- if ( $Htmlfileurl ne '' ) {
- $link = "$Htmldir$link" ;
- $url = relativize_url( $link, $Htmlfileurl ) ;
- } else {
- $url = $link ;
- }
- } else {
- $url = "#" . anchorify($fid);
- }
-
- confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/;
- }
- return( $url, $fid );
-}
-
-
-
-#
-# Adapted from Nick Ing-Simmons' PodToHtml package.
-sub relative_url {
- my $source_file = shift ;
- my $destination_file = shift;
-
- my $source = URI::file->new_abs($source_file);
- my $uo = URI::file->new($destination_file,$source)->abs;
- return $uo->rel->as_string;
-}
-
-
-#
-# finish_list - finish off any pending HTML lists. this should be called
-# after the entire pod file has been read and converted.
-#
-sub finish_list {
- my $fh = shift;
- if( $Listlevel ){
- warn "$0: $Podfile: unterminated list(s) at =head in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- while( $Listlevel ){
- process_back( $fh );
- }
- }
-}
-
-#
-# htmlify - converts a pod section specification to a suitable section
-# specification for HTML. Note that we keep spaces and special characters
-# except ", ? (Netscape problem) and the hyphen (writer's problem...).
-#
-sub htmlify {
- my( $heading) = @_;
- $heading =~ s/(\s+)/ /g;
- $heading =~ s/\s+\Z//;
- $heading =~ s/\A\s+//;
- # The hyphen is a disgrace to the English language.
- # $heading =~ s/[-"?]//g;
- $heading =~ s/["?]//g;
- $heading = lc( $heading );
- return $heading;
-}
-
-#
-# similar to htmlify, but turns non-alphanumerics into underscores
-#
-sub anchorify {
- my ($anchor) = @_;
- $anchor = htmlify($anchor);
- $anchor =~ s/\W/_/g;
- return $anchor;
-}
-
-#
-# depod - convert text by eliminating all interior sequences
-# Note: can be called with copy or modify semantics
-#
-my %E2c;
-$E2c{lt} = '<';
-$E2c{gt} = '>';
-$E2c{sol} = '/';
-$E2c{verbar} = '|';
-$E2c{amp} = '&'; # in Tk's pods
-
-sub depod1($;$$);
-
-sub depod($){
- my $string;
- if( ref( $_[0] ) ){
- $string = ${$_[0]};
- ${$_[0]} = depod1( \$string );
- } else {
- $string = $_[0];
- depod1( \$string );
- }
-}
-
-sub depod1($;$$){
- my( $rstr, $func, $closing ) = @_;
- my $res = '';
- return $res unless defined $$rstr;
- if( ! defined( $func ) ){
- # skip to next begin of an interior sequence
- while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?//s ){
- # recurse into its text
- $res .= $1 . depod1( $rstr, $2, closing $3);
- }
- $res .= $$rstr;
- } elsif( $func eq 'E' ){
- # E<x> - convert to character
- $$rstr =~ s/^([^>]*)>//;
- $res .= $E2c{$1} || "";
- } elsif( $func eq 'X' ){
- # X<> - ignore
- $$rstr =~ s/^[^>]*>//;
- } elsif( $func eq 'Z' ){
- # Z<> - empty
- $$rstr =~ s/^>//;
- } else {
- # all others: either recurse into new function or
- # terminate at closing angle bracket
- my $term = pattern $closing;
- while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
- $res .= $1;
- last unless $3;
- $res .= depod1( $rstr, $3, closing $4 );
- }
- ## If we're here and $2 ne '>': undelimited interior sequence.
- ## Ignored, as this is called without proper indication of where we are.
- ## Rely on process_text to produce diagnostics.
- }
- return $res;
-}
-
-{
- my %seen; # static fragment record hash
-
-sub fragment_id_readable {
- my $text = shift;
- my $generate = shift; # optional flag
-
- my $orig = $text;
-
- # leave the words for the fragment identifier,
- # change everything else to underbars.
- $text =~ s/[^A-Za-z0-9_]+/_/g; # do not use \W to avoid locale dependency.
- $text =~ s/_{2,}/_/g;
- $text =~ s/\A_//;
- $text =~ s/_\Z//;
-
- unless ($text)
- {
- # Nothing left after removing punctuation, so leave it as is
- # E.g. if option is named: "=item -#"
-
- $text = $orig;
- }
-
- if ($generate) {
- if ( exists $seen{$text} ) {
- # This already exists, make it unique
- $seen{$text}++;
- $text = $text . $seen{$text};
- } else {
- $seen{$text} = 1; # first time seen this fragment
- }
- }
-
- $text;
-}}
-
-my @HC;
-sub fragment_id_obfuscated { # This was the old "_2d_2d__"
- my $text = shift;
- my $generate = shift; # optional flag
-
- # text? Normalize by obfuscating the fragment id to make it unique
- $text =~ s/\s+/_/sg;
-
- $text =~ s{(\W)}{
- defined( $HC[ord($1)] ) ? $HC[ord($1)]
- : ( $HC[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe;
- $text = substr( $text, 0, 50 );
-
- $text;
-}
-
-#
-# fragment_id - construct a fragment identifier from:
-# a) =item text
-# b) contents of C<...>
-#
-
-sub fragment_id {
- my $text = shift;
- my $generate = shift; # optional flag
-
- $text =~ s/\s+\Z//s;
- if( $text ){
- # a method or function?
- return $1 if $text =~ /(\w+)\s*\(/;
- return $1 if $text =~ /->\s*(\w+)\s*\(?/;
-
- # a variable name?
- return $1 if $text =~ /^([\$\@%*]\S+)/;
-
- # some pattern matching operator?
- return $1 if $text =~ m|^(\w+/).*/\w*$|;
-
- # fancy stuff... like "do { }"
- return $1 if $text =~ m|^(\w+)\s*{.*}$|;
-
- # honour the perlfunc manpage: func [PAR[,[ ]PAR]...]
- # and some funnies with ... Module ...
- return $1 if $text =~ m{^([a-z\d_]+)(\s+[A-Z,/& ][A-Z\d,/& ]*)?$};
- return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$};
-
- return fragment_id_readable($text, $generate);
- } else {
- return;
- }
-}
-
-#
-# make_URL_href - generate HTML href from URL
-# Special treatment for CGI queries.
-#
-sub make_URL_href($){
- my( $url ) = @_;
- if( $url !~
- s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<a href="$1$2">$1</a>}i ){
- $url = "<a href=\"$url\">$url</a>";
- }
- return $url;
-}
-
-1;
Deleted: trunk/contrib/perl/ext/Pod-Html/pod2html.PL
===================================================================
--- trunk/contrib/perl/ext/Pod-Html/pod2html.PL 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/Pod-Html/pod2html.PL 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,183 +0,0 @@
-#!/usr/local/bin/perl
-
-use Config;
-use File::Basename qw(&basename &dirname);
-use Cwd;
-
-# List explicitly here the variables you want Configure to
-# generate. Metaconfig only looks for shell variables, so you
-# have to mention them as if they were shell variables, not
-# %Config entries. Thus you write
-# $startperl
-# to ensure Configure will look for $Config{startperl}.
-
-# This forces PL files to create target in same directory as PL file.
-# This is so that make depend always knows where to find PL derivatives.
-$origdir = cwd;
-chdir dirname($0);
-$file = basename($0, '.PL');
-$file .= '.com' if $^O eq 'VMS';
-
-open OUT,">$file" or die "Can't create $file: $!";
-
-print "Extracting $file (with variable substitutions)\n";
-
-# In this section, perl variables will be expanded during extraction.
-# You can use $Config{...} to use Configure variables.
-
-print OUT <<"!GROK!THIS!";
-$Config{startperl}
- eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
- if \$running_under_some_shell;
-!GROK!THIS!
-
-# In the following, perl variables are not expanded during extraction.
-
-print OUT <<'!NO!SUBS!';
-=pod
-
-=head1 NAME
-
-pod2html - convert .pod files to .html files
-
-=head1 SYNOPSIS
-
- pod2html --help --htmlroot=<name> --infile=<name> --outfile=<name>
- --podpath=<name>:...:<name> --podroot=<name>
- --libpods=<name>:...:<name> --recurse --norecurse --verbose
- --index --noindex --title=<name>
-
-=head1 DESCRIPTION
-
-Converts files from pod format (see L<perlpod>) to HTML format.
-
-=head1 ARGUMENTS
-
-pod2html takes the following arguments:
-
-=over 4
-
-=item help
-
- --help
-
-Displays the usage message.
-
-=item htmlroot
-
- --htmlroot=name
-
-Sets the base URL for the HTML files. When cross-references are made,
-the HTML root is prepended to the URL.
-
-=item infile
-
- --infile=name
-
-Specify the pod file to convert. Input is taken from STDIN if no
-infile is specified.
-
-=item outfile
-
- --outfile=name
-
-Specify the HTML file to create. Output goes to STDOUT if no outfile
-is specified.
-
-=item podroot
-
- --podroot=name
-
-Specify the base directory for finding library pods.
-
-=item podpath
-
- --podpath=name:...:name
-
-Specify which subdirectories of the podroot contain pod files whose
-HTML converted forms can be linked-to in cross-references.
-
-=item libpods
-
- --libpods=name:...:name
-
-List of page names (eg, "perlfunc") which contain linkable C<=item>s.
-
-=item netscape
-
- --netscape
-
-Use Netscape HTML directives when applicable.
-
-=item nonetscape
-
- --nonetscape
-
-Do not use Netscape HTML directives (default).
-
-=item index
-
- --index
-
-Generate an index at the top of the HTML file (default behaviour).
-
-=item noindex
-
- --noindex
-
-Do not generate an index at the top of the HTML file.
-
-
-=item recurse
-
- --recurse
-
-Recurse into subdirectories specified in podpath (default behaviour).
-
-=item norecurse
-
- --norecurse
-
-Do not recurse into subdirectories specified in podpath.
-
-=item title
-
- --title=title
-
-Specify the title of the resulting HTML file.
-
-=item verbose
-
- --verbose
-
-Display progress messages.
-
-=back
-
-=head1 AUTHOR
-
-Tom Christiansen, E<lt>tchrist at perl.comE<gt>.
-
-=head1 BUGS
-
-See L<Pod::Html> for a list of known bugs in the translator.
-
-=head1 SEE ALSO
-
-L<perlpod>, L<Pod::Html>
-
-=head1 COPYRIGHT
-
-This program is distributed under the Artistic License.
-
-=cut
-
-use Pod::Html;
-
-pod2html @ARGV;
-!NO!SUBS!
-
-close OUT or die "Can't close $file: $!";
-chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
-exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
-chdir $origdir;
Deleted: trunk/contrib/perl/ext/XS-Typemap/typemap
===================================================================
--- trunk/contrib/perl/ext/XS-Typemap/typemap 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/ext/XS-Typemap/typemap 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,19 +0,0 @@
-# Typemap file for typemap testing
-# includes bonus typemap entries
-# Mainly so that all the standard typemaps can be exercised even when
-# there is not a corresponding type explicitly identified in the standard
-# typemap
-
-svtype T_ENUM
-intRef * T_PTRREF
-intRef T_IV
-intObj * T_PTROBJ
-intObj T_IV
-intRefIv * T_REF_IV_PTR
-intRefIv T_IV
-intArray * T_ARRAY
-intOpq T_IV
-intOpq * T_OPAQUEPTR
-shortOPQ T_OPAQUE
-shortOPQ * T_OPAQUEPTR
-astruct * T_OPAQUEPTR
Deleted: trunk/contrib/perl/global.sym
===================================================================
--- trunk/contrib/perl/global.sym 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/global.sym 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,891 +0,0 @@
-# -*- buffer-read-only: t -*-
-#
-# global.sym
-#
-# Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
-# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others
-#
-# You may distribute under the terms of either the GNU General Public
-# License or the Artistic License, as specified in the README file.
-#
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is built by regen/embed.pl from data in embed.fnc,
-# regen/embed.pl, regen/opcodes, intrpvar.h and perlvars.h.
-# Any changes made here will be lost!
-#
-# Edit those files and run 'make regen_headers' to effect changes.
-
-Perl_Gv_AMupdate
-Perl_PerlIO_context_layers
-Perl__append_range_to_invlist
-Perl__new_invlist
-Perl__swash_inversion_hash
-Perl__swash_to_invlist
-Perl__to_uni_fold_flags
-Perl__to_utf8_fold_flags
-Perl_amagic_call
-Perl_amagic_deref_call
-Perl_apply_attrs_string
-Perl_atfork_lock
-Perl_atfork_unlock
-Perl_av_arylen_p
-Perl_av_clear
-Perl_av_delete
-Perl_av_exists
-Perl_av_extend
-Perl_av_fetch
-Perl_av_fill
-Perl_av_iter_p
-Perl_av_len
-Perl_av_make
-Perl_av_pop
-Perl_av_push
-Perl_av_reify
-Perl_av_shift
-Perl_av_store
-Perl_av_undef
-Perl_av_unshift
-Perl_block_gimme
-Perl_blockhook_register
-Perl_bytes_cmp_utf8
-Perl_bytes_from_utf8
-Perl_bytes_to_utf8
-Perl_call_argv
-Perl_call_atexit
-Perl_call_list
-Perl_call_method
-Perl_call_pv
-Perl_call_sv
-Perl_caller_cx
-Perl_calloc
-Perl_cast_i32
-Perl_cast_iv
-Perl_cast_ulong
-Perl_cast_uv
-Perl_ck_entersub_args_list
-Perl_ck_entersub_args_proto
-Perl_ck_entersub_args_proto_or_list
-Perl_ck_warner
-Perl_ck_warner_d
-Perl_ckwarn
-Perl_ckwarn_d
-Perl_croak
-Perl_croak_no_modify
-Perl_croak_sv
-Perl_croak_xs_usage
-Perl_custom_op_desc
-Perl_custom_op_name
-Perl_custom_op_register
-Perl_custom_op_xop
-Perl_cv_const_sv
-Perl_cv_get_call_checker
-Perl_cv_set_call_checker
-Perl_cv_undef
-Perl_cvgv_set
-Perl_cvstash_set
-Perl_cx_dump
-Perl_cxinc
-Perl_deb
-Perl_debop
-Perl_debprofdump
-Perl_debstack
-Perl_debstackptrs
-Perl_delimcpy
-Perl_despatch_signals
-Perl_die
-Perl_die_sv
-Perl_do_aexec
-Perl_do_binmode
-Perl_do_close
-Perl_do_gv_dump
-Perl_do_gvgv_dump
-Perl_do_hv_dump
-Perl_do_join
-Perl_do_magic_dump
-Perl_do_op_dump
-Perl_do_open
-Perl_do_open9
-Perl_do_openn
-Perl_do_pmop_dump
-Perl_do_sprintf
-Perl_do_sv_dump
-Perl_doing_taint
-Perl_doref
-Perl_dounwind
-Perl_dowantarray
-Perl_dump_all
-Perl_dump_eval
-Perl_dump_form
-Perl_dump_indent
-Perl_dump_packsubs
-Perl_dump_sub
-Perl_dump_vindent
-Perl_emulate_cop_io
-Perl_eval_pv
-Perl_eval_sv
-Perl_fbm_compile
-Perl_fbm_instr
-Perl_fetch_cop_label
-Perl_filter_add
-Perl_filter_del
-Perl_filter_read
-Perl_find_runcv
-Perl_find_rundefsv
-Perl_find_rundefsvoffset
-Perl_foldEQ
-Perl_foldEQ_latin1
-Perl_foldEQ_locale
-Perl_foldEQ_utf8_flags
-Perl_form
-Perl_free_tmps
-Perl_get_av
-Perl_get_context
-Perl_get_cv
-Perl_get_cvn_flags
-Perl_get_hv
-Perl_get_op_descs
-Perl_get_op_names
-Perl_get_ppaddr
-Perl_get_re_arg
-Perl_get_sv
-Perl_get_vtbl
-Perl_getcwd_sv
-Perl_gp_free
-Perl_gp_ref
-Perl_grok_bin
-Perl_grok_hex
-Perl_grok_number
-Perl_grok_numeric_radix
-Perl_grok_oct
-Perl_gv_AVadd
-Perl_gv_HVadd
-Perl_gv_IOadd
-Perl_gv_add_by_type
-Perl_gv_autoload4
-Perl_gv_check
-Perl_gv_const_sv
-Perl_gv_dump
-Perl_gv_efullname
-Perl_gv_efullname3
-Perl_gv_efullname4
-Perl_gv_fetchfile
-Perl_gv_fetchfile_flags
-Perl_gv_fetchmeth
-Perl_gv_fetchmeth_autoload
-Perl_gv_fetchmethod
-Perl_gv_fetchmethod_autoload
-Perl_gv_fetchmethod_flags
-Perl_gv_fetchpv
-Perl_gv_fetchpvn_flags
-Perl_gv_fetchsv
-Perl_gv_fullname
-Perl_gv_fullname3
-Perl_gv_fullname4
-Perl_gv_handler
-Perl_gv_init
-Perl_gv_name_set
-Perl_gv_stashpv
-Perl_gv_stashpvn
-Perl_gv_stashsv
-Perl_gv_try_downgrade
-Perl_hv_clear
-Perl_hv_clear_placeholders
-Perl_hv_common
-Perl_hv_common_key_len
-Perl_hv_copy_hints_hv
-Perl_hv_delayfree_ent
-Perl_hv_delete
-Perl_hv_delete_ent
-Perl_hv_eiter_p
-Perl_hv_eiter_set
-Perl_hv_exists
-Perl_hv_exists_ent
-Perl_hv_fetch
-Perl_hv_fetch_ent
-Perl_hv_fill
-Perl_hv_free_ent
-Perl_hv_iterinit
-Perl_hv_iterkey
-Perl_hv_iterkeysv
-Perl_hv_iternext
-Perl_hv_iternext_flags
-Perl_hv_iternextsv
-Perl_hv_iterval
-Perl_hv_ksplit
-Perl_hv_magic
-Perl_hv_name_set
-Perl_hv_placeholders_get
-Perl_hv_placeholders_p
-Perl_hv_placeholders_set
-Perl_hv_riter_p
-Perl_hv_riter_set
-Perl_hv_scalar
-Perl_hv_store
-Perl_hv_store_ent
-Perl_hv_store_flags
-Perl_hv_undef_flags
-Perl_init_i18nl10n
-Perl_init_i18nl14n
-Perl_init_stacks
-Perl_init_tm
-Perl_instr
-Perl_is_ascii_string
-Perl_is_lvalue_sub
-Perl_is_uni_alnum
-Perl_is_uni_alnum_lc
-Perl_is_uni_alpha
-Perl_is_uni_alpha_lc
-Perl_is_uni_ascii
-Perl_is_uni_ascii_lc
-Perl_is_uni_cntrl
-Perl_is_uni_cntrl_lc
-Perl_is_uni_digit
-Perl_is_uni_digit_lc
-Perl_is_uni_graph
-Perl_is_uni_graph_lc
-Perl_is_uni_idfirst
-Perl_is_uni_idfirst_lc
-Perl_is_uni_lower
-Perl_is_uni_lower_lc
-Perl_is_uni_print
-Perl_is_uni_print_lc
-Perl_is_uni_punct
-Perl_is_uni_punct_lc
-Perl_is_uni_space
-Perl_is_uni_space_lc
-Perl_is_uni_upper
-Perl_is_uni_upper_lc
-Perl_is_uni_xdigit
-Perl_is_uni_xdigit_lc
-Perl_is_utf8_X_L
-Perl_is_utf8_X_LV
-Perl_is_utf8_X_LVT
-Perl_is_utf8_X_LV_LVT_V
-Perl_is_utf8_X_T
-Perl_is_utf8_X_V
-Perl_is_utf8_X_begin
-Perl_is_utf8_X_extend
-Perl_is_utf8_X_non_hangul
-Perl_is_utf8_X_prepend
-Perl_is_utf8_alnum
-Perl_is_utf8_alpha
-Perl_is_utf8_ascii
-Perl_is_utf8_char
-Perl_is_utf8_cntrl
-Perl_is_utf8_digit
-Perl_is_utf8_graph
-Perl_is_utf8_idcont
-Perl_is_utf8_idfirst
-Perl_is_utf8_lower
-Perl_is_utf8_mark
-Perl_is_utf8_perl_space
-Perl_is_utf8_perl_word
-Perl_is_utf8_posix_digit
-Perl_is_utf8_print
-Perl_is_utf8_punct
-Perl_is_utf8_space
-Perl_is_utf8_string
-Perl_is_utf8_string_loc
-Perl_is_utf8_string_loclen
-Perl_is_utf8_upper
-Perl_is_utf8_xdigit
-Perl_is_utf8_xidcont
-Perl_is_utf8_xidfirst
-Perl_leave_scope
-Perl_lex_bufutf8
-Perl_lex_discard_to
-Perl_lex_grow_linestr
-Perl_lex_next_chunk
-Perl_lex_peek_unichar
-Perl_lex_read_space
-Perl_lex_read_to
-Perl_lex_read_unichar
-Perl_lex_start
-Perl_lex_stuff_pv
-Perl_lex_stuff_pvn
-Perl_lex_stuff_sv
-Perl_lex_unstuff
-Perl_load_module
-Perl_looks_like_number
-Perl_magic_dump
-Perl_malloc
-Perl_markstack_grow
-Perl_mess
-Perl_mess_sv
-Perl_mfree
-Perl_mg_clear
-Perl_mg_copy
-Perl_mg_find
-Perl_mg_findext
-Perl_mg_free
-Perl_mg_free_type
-Perl_mg_get
-Perl_mg_length
-Perl_mg_magical
-Perl_mg_set
-Perl_mg_size
-Perl_mini_mktime
-Perl_mod
-Perl_moreswitches
-Perl_mro_get_from_name
-Perl_mro_get_linear_isa
-Perl_mro_get_private_data
-Perl_mro_meta_init
-Perl_mro_method_changed_in
-Perl_mro_register
-Perl_mro_set_mro
-Perl_mro_set_private_data
-Perl_my_atof
-Perl_my_atof2
-Perl_my_dirfd
-Perl_my_exit
-Perl_my_failure_exit
-Perl_my_fflush_all
-Perl_my_fork
-Perl_my_lstat
-Perl_my_lstat_flags
-Perl_my_pclose
-Perl_my_popen
-Perl_my_popen_list
-Perl_my_setenv
-Perl_my_snprintf
-Perl_my_socketpair
-Perl_my_stat
-Perl_my_stat_flags
-Perl_my_strftime
-Perl_my_vsnprintf
-Perl_newANONATTRSUB
-Perl_newANONHASH
-Perl_newANONLIST
-Perl_newANONSUB
-Perl_newASSIGNOP
-Perl_newATTRSUB
-Perl_newAV
-Perl_newAVREF
-Perl_newBINOP
-Perl_newCONDOP
-Perl_newCONSTSUB
-Perl_newCVREF
-Perl_newFOROP
-Perl_newGIVENOP
-Perl_newGVOP
-Perl_newGVREF
-Perl_newGVgen
-Perl_newHV
-Perl_newHVREF
-Perl_newHVhv
-Perl_newIO
-Perl_newLISTOP
-Perl_newLOGOP
-Perl_newLOOPEX
-Perl_newLOOPOP
-Perl_newNULLLIST
-Perl_newOP
-Perl_newPMOP
-Perl_newPROG
-Perl_newPVOP
-Perl_newRANGE
-Perl_newRV
-Perl_newRV_noinc
-Perl_newSLICEOP
-Perl_newSTATEOP
-Perl_newSUB
-Perl_newSV
-Perl_newSVOP
-Perl_newSVREF
-Perl_newSV_type
-Perl_newSVhek
-Perl_newSViv
-Perl_newSVnv
-Perl_newSVpv
-Perl_newSVpv_share
-Perl_newSVpvf
-Perl_newSVpvn
-Perl_newSVpvn_flags
-Perl_newSVpvn_share
-Perl_newSVrv
-Perl_newSVsv
-Perl_newSVuv
-Perl_newUNOP
-Perl_newWHENOP
-Perl_newWHILEOP
-Perl_newXS
-Perl_newXS_flags
-Perl_new_collate
-Perl_new_ctype
-Perl_new_numeric
-Perl_new_stackinfo
-Perl_new_version
-Perl_new_warnings_bitfield
-Perl_ninstr
-Perl_nothreadhook
-Perl_op_append_elem
-Perl_op_append_list
-Perl_op_clear
-Perl_op_contextualize
-Perl_op_dump
-Perl_op_free
-Perl_op_linklist
-Perl_op_lvalue
-Perl_op_null
-Perl_op_prepend_elem
-Perl_op_refcnt_lock
-Perl_op_refcnt_unlock
-Perl_op_scope
-Perl_pack_cat
-Perl_packlist
-Perl_pad_findmy
-Perl_pad_push
-Perl_parse_arithexpr
-Perl_parse_barestmt
-Perl_parse_block
-Perl_parse_fullexpr
-Perl_parse_fullstmt
-Perl_parse_label
-Perl_parse_listexpr
-Perl_parse_stmtseq
-Perl_parse_termexpr
-perl_alloc
-perl_construct
-perl_destruct
-perl_free
-perl_parse
-perl_run
-Perl_pmop_dump
-Perl_pop_scope
-Perl_pregcomp
-Perl_pregexec
-Perl_pregfree
-Perl_pregfree2
-Perl_prescan_version
-Perl_ptr_table_clear
-Perl_ptr_table_fetch
-Perl_ptr_table_free
-Perl_ptr_table_new
-Perl_ptr_table_split
-Perl_ptr_table_store
-Perl_push_scope
-Perl_pv_display
-Perl_pv_escape
-Perl_pv_pretty
-Perl_pv_uni_display
-Perl_qerror
-Perl_re_compile
-Perl_re_intuit_start
-Perl_re_intuit_string
-Perl_realloc
-Perl_ref
-Perl_refcounted_he_chain_2hv
-Perl_refcounted_he_fetch_pv
-Perl_refcounted_he_fetch_pvn
-Perl_refcounted_he_fetch_sv
-Perl_refcounted_he_free
-Perl_refcounted_he_inc
-Perl_refcounted_he_new_pv
-Perl_refcounted_he_new_pvn
-Perl_refcounted_he_new_sv
-Perl_reg_named_buff
-Perl_reg_named_buff_all
-Perl_reg_named_buff_exists
-Perl_reg_named_buff_fetch
-Perl_reg_named_buff_firstkey
-Perl_reg_named_buff_iter
-Perl_reg_named_buff_nextkey
-Perl_reg_named_buff_scalar
-Perl_reg_numbered_buff_fetch
-Perl_reg_numbered_buff_length
-Perl_reg_numbered_buff_store
-Perl_reg_qr_package
-Perl_reg_temp_copy
-Perl_regclass_swash
-Perl_regdump
-Perl_regexec_flags
-Perl_regfree_internal
-Perl_reginitcolors
-Perl_regnext
-Perl_repeatcpy
-Perl_report_uninit
-Perl_require_pv
-Perl_rninstr
-Perl_rsignal
-Perl_rsignal_state
-Perl_runops_debug
-Perl_runops_standard
-Perl_rv2cv_op_cv
-Perl_safesyscalloc
-Perl_safesysfree
-Perl_safesysmalloc
-Perl_safesysrealloc
-Perl_save_I16
-Perl_save_I32
-Perl_save_I8
-Perl_save_adelete
-Perl_save_aelem_flags
-Perl_save_alloc
-Perl_save_aptr
-Perl_save_ary
-Perl_save_bool
-Perl_save_clearsv
-Perl_save_delete
-Perl_save_destructor
-Perl_save_destructor_x
-Perl_save_freeop
-Perl_save_freepv
-Perl_save_freesv
-Perl_save_generic_pvref
-Perl_save_generic_svref
-Perl_save_gp
-Perl_save_hash
-Perl_save_hdelete
-Perl_save_helem_flags
-Perl_save_hints
-Perl_save_hptr
-Perl_save_int
-Perl_save_item
-Perl_save_iv
-Perl_save_list
-Perl_save_long
-Perl_save_mortalizesv
-Perl_save_nogv
-Perl_save_op
-Perl_save_padsv_and_mortalize
-Perl_save_pptr
-Perl_save_pushi32ptr
-Perl_save_pushptr
-Perl_save_pushptrptr
-Perl_save_re_context
-Perl_save_scalar
-Perl_save_set_svflags
-Perl_save_shared_pvref
-Perl_save_sptr
-Perl_save_svref
-Perl_save_vptr
-Perl_savepv
-Perl_savepvn
-Perl_savesharedpv
-Perl_savesharedpvn
-Perl_savesharedsvpv
-Perl_savestack_grow
-Perl_savestack_grow_cnt
-Perl_savesvpv
-Perl_scan_bin
-Perl_scan_hex
-Perl_scan_num
-Perl_scan_oct
-Perl_scan_version
-Perl_scan_vstring
-Perl_screaminstr
-Perl_seed
-Perl_set_context
-Perl_set_numeric_local
-Perl_set_numeric_radix
-Perl_set_numeric_standard
-Perl_setdefout
-Perl_share_hek
-Perl_sortsv
-Perl_sortsv_flags
-Perl_stack_grow
-Perl_start_subparse
-Perl_stashpv_hvname_match
-Perl_str_to_version
-Perl_sv_2bool_flags
-Perl_sv_2cv
-Perl_sv_2io
-Perl_sv_2iv
-Perl_sv_2iv_flags
-Perl_sv_2mortal
-Perl_sv_2nv_flags
-Perl_sv_2pv
-Perl_sv_2pv_flags
-Perl_sv_2pv_nolen
-Perl_sv_2pvbyte
-Perl_sv_2pvbyte_nolen
-Perl_sv_2pvutf8
-Perl_sv_2pvutf8_nolen
-Perl_sv_2uv
-Perl_sv_2uv_flags
-Perl_sv_backoff
-Perl_sv_bless
-Perl_sv_cat_decode
-Perl_sv_catpv
-Perl_sv_catpv_flags
-Perl_sv_catpv_mg
-Perl_sv_catpvf
-Perl_sv_catpvf_mg
-Perl_sv_catpvn
-Perl_sv_catpvn_flags
-Perl_sv_catpvn_mg
-Perl_sv_catsv
-Perl_sv_catsv_flags
-Perl_sv_catsv_mg
-Perl_sv_chop
-Perl_sv_clear
-Perl_sv_cmp
-Perl_sv_cmp_flags
-Perl_sv_cmp_locale
-Perl_sv_cmp_locale_flags
-Perl_sv_compile_2op
-Perl_sv_compile_2op_is_broken
-Perl_sv_copypv
-Perl_sv_dec
-Perl_sv_dec_nomg
-Perl_sv_del_backref
-Perl_sv_derived_from
-Perl_sv_destroyable
-Perl_sv_does
-Perl_sv_dump
-Perl_sv_eq_flags
-Perl_sv_force_normal
-Perl_sv_force_normal_flags
-Perl_sv_free
-Perl_sv_free2
-Perl_sv_gets
-Perl_sv_grow
-Perl_sv_inc
-Perl_sv_inc_nomg
-Perl_sv_insert
-Perl_sv_insert_flags
-Perl_sv_isa
-Perl_sv_isobject
-Perl_sv_iv
-Perl_sv_len
-Perl_sv_len_utf8
-Perl_sv_magic
-Perl_sv_magicext
-Perl_sv_mortalcopy
-Perl_sv_newmortal
-Perl_sv_newref
-Perl_sv_nolocking
-Perl_sv_nosharing
-Perl_sv_nv
-Perl_sv_peek
-Perl_sv_pos_b2u
-Perl_sv_pos_u2b
-Perl_sv_pos_u2b_flags
-Perl_sv_pv
-Perl_sv_pvbyte
-Perl_sv_pvbyten
-Perl_sv_pvbyten_force
-Perl_sv_pvn
-Perl_sv_pvn_force
-Perl_sv_pvn_force_flags
-Perl_sv_pvn_nomg
-Perl_sv_pvutf8
-Perl_sv_pvutf8n
-Perl_sv_pvutf8n_force
-Perl_sv_recode_to_utf8
-Perl_sv_reftype
-Perl_sv_replace
-Perl_sv_report_used
-Perl_sv_reset
-Perl_sv_rvweaken
-Perl_sv_setiv
-Perl_sv_setiv_mg
-Perl_sv_setnv
-Perl_sv_setnv_mg
-Perl_sv_setpv
-Perl_sv_setpv_mg
-Perl_sv_setpvf
-Perl_sv_setpvf_mg
-Perl_sv_setpviv
-Perl_sv_setpviv_mg
-Perl_sv_setpvn
-Perl_sv_setpvn_mg
-Perl_sv_setref_iv
-Perl_sv_setref_nv
-Perl_sv_setref_pv
-Perl_sv_setref_pvn
-Perl_sv_setref_uv
-Perl_sv_setsv
-Perl_sv_setsv_flags
-Perl_sv_setsv_mg
-Perl_sv_setuv
-Perl_sv_setuv_mg
-Perl_sv_taint
-Perl_sv_tainted
-Perl_sv_true
-Perl_sv_uni_display
-Perl_sv_unmagic
-Perl_sv_unmagicext
-Perl_sv_unref
-Perl_sv_unref_flags
-Perl_sv_untaint
-Perl_sv_upgrade
-Perl_sv_usepvn
-Perl_sv_usepvn_flags
-Perl_sv_usepvn_mg
-Perl_sv_utf8_decode
-Perl_sv_utf8_downgrade
-Perl_sv_utf8_encode
-Perl_sv_utf8_upgrade
-Perl_sv_utf8_upgrade_flags_grow
-Perl_sv_uv
-Perl_sv_vcatpvf
-Perl_sv_vcatpvf_mg
-Perl_sv_vcatpvfn
-Perl_sv_vsetpvf
-Perl_sv_vsetpvf_mg
-Perl_sv_vsetpvfn
-Perl_swash_fetch
-Perl_swash_init
-Perl_sys_init
-Perl_sys_init3
-Perl_sys_term
-Perl_taint_env
-Perl_taint_proper
-Perl_tmps_grow
-Perl_to_uni_lower
-Perl_to_uni_lower_lc
-Perl_to_uni_title
-Perl_to_uni_title_lc
-Perl_to_uni_upper
-Perl_to_uni_upper_lc
-Perl_to_utf8_case
-Perl_to_utf8_lower
-Perl_to_utf8_title
-Perl_to_utf8_upper
-Perl_try_amagic_bin
-Perl_try_amagic_un
-Perl_unpack_str
-Perl_unpackstring
-Perl_unsharepvn
-Perl_upg_version
-Perl_utf16_to_utf8
-Perl_utf16_to_utf8_reversed
-Perl_utf8_distance
-Perl_utf8_hop
-Perl_utf8_length
-Perl_utf8_to_bytes
-Perl_utf8_to_uvchr
-Perl_utf8_to_uvuni
-Perl_utf8n_to_uvuni
-Perl_uvchr_to_utf8_flags
-Perl_uvuni_to_utf8
-Perl_uvuni_to_utf8_flags
-Perl_vcmp
-Perl_vcroak
-Perl_vdeb
-Perl_vform
-Perl_vivify_defelem
-Perl_vload_module
-Perl_vmess
-Perl_vnewSVpvf
-Perl_vnormal
-Perl_vnumify
-Perl_vstringify
-Perl_vverify
-Perl_vwarn
-Perl_vwarner
-Perl_warn
-Perl_warn_sv
-Perl_warner
-Perl_whichsig
-Perl_xs_apiversion_bootcheck
-Perl_xs_version_bootcheck
-Perl_yylex
-Perl_utf8n_to_uvchr
-Perl_uvchr_to_utf8
-Perl_csighandler
-Perl_sv_nounlocking
-Perl_my_cxt_init
-Perl_newFORM
-Perl_newMYSUB
-Perl_my_bzero
-Perl_my_memcmp
-Perl_my_memset
-Perl_signbit
-Perl_my_strlcat
-Perl_my_strlcpy
-Perl_my_chsize
-Perl_my_sprintf
-Perl_my_bcopy
-Perl_hv_assert
-Perl_pad_sv
-Perl_dump_fds
-Perl_sys_intern_clear
-Perl_sys_intern_init
-Perl_sys_intern_dup
-Perl_dump_mstats
-Perl_get_mstats
-Perl_my_htonl
-Perl_my_ntohl
-Perl_my_swap
-Perl_do_exec
-Perl_gv_SVadd
-Perl_GetVars
-Perl_free_global_struct
-Perl_init_global_struct
-Perl_my_cxt_index
-Perl_croak_nocontext
-Perl_deb_nocontext
-Perl_die_nocontext
-Perl_form_nocontext
-Perl_fprintf_nocontext
-Perl_load_module_nocontext
-Perl_mess_nocontext
-Perl_newSVpvf_nocontext
-Perl_printf_nocontext
-Perl_sv_catpvf_mg_nocontext
-Perl_sv_catpvf_nocontext
-Perl_sv_setpvf_mg_nocontext
-Perl_sv_setpvf_nocontext
-Perl_warn_nocontext
-Perl_warner_nocontext
-perl_alloc_using
-perl_clone_using
-Perl_sv_setsv_cow
-Perl_Slab_Alloc
-Perl_Slab_Free
-Perl_unlnk
-Perl_any_dup
-Perl_clone_params_del
-Perl_clone_params_new
-Perl_cx_dup
-Perl_dirp_dup
-Perl_fp_dup
-Perl_gp_dup
-Perl_he_dup
-Perl_hek_dup
-Perl_mg_dup
-Perl_newPADOP
-Perl_parser_dup
-perl_clone
-Perl_re_dup_guts
-Perl_regdupe_internal
-Perl_rvpv_dup
-Perl_si_dup
-Perl_ss_dup
-Perl_sv_dup
-Perl_sv_dup_inc
-Perl_sv_collxfrm_flags
-Perl_PerlIO_clearerr
-Perl_PerlIO_close
-Perl_PerlIO_eof
-Perl_PerlIO_error
-Perl_PerlIO_fileno
-Perl_PerlIO_fill
-Perl_PerlIO_flush
-Perl_PerlIO_get_base
-Perl_PerlIO_get_bufsiz
-Perl_PerlIO_get_cnt
-Perl_PerlIO_get_ptr
-Perl_PerlIO_read
-Perl_PerlIO_seek
-Perl_PerlIO_set_cnt
-Perl_PerlIO_set_ptrcnt
-Perl_PerlIO_setlinebuf
-Perl_PerlIO_stderr
-Perl_PerlIO_stdin
-Perl_PerlIO_stdout
-Perl_PerlIO_tell
-Perl_PerlIO_unread
-Perl_PerlIO_write
-Perl_reentrant_free
-Perl_reentrant_init
-Perl_reentrant_retry
-Perl_reentrant_size
-Perl_do_aspawn
-Perl_do_spawn
-Perl_do_spawn_nowait
-
-# ex: set ro:
Deleted: trunk/contrib/perl/hints/beos.sh
===================================================================
--- trunk/contrib/perl/hints/beos.sh 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/hints/beos.sh 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,82 +0,0 @@
-# BeOS hints file
-
-if [ ! -f beos/nm ]; then mwcc -w all -o beos/nm beos/nm.c 2>/dev/null; fi
-# If this fails, that's all right - it's only for PPC.
-
-prefix="/boot/home/config"
-
-#cpp="mwcc -e"
-
-libpth='/boot/beos/system/lib /boot/home/config/lib'
-usrinc='/boot/develop/headers/posix'
-locinc='/boot/develop/headers/ /boot/home/config/include'
-
-libc='/boot/beos/system/lib/libroot.so'
-libs=' '
-
-d_bcmp='define'
-d_bcopy='define'
-d_bzero='define'
-d_index='define'
-#d_htonl='define' # It exists, but much hackery would be required to support.
-# a bunch of extra includes would have to be added, and it's only used at
-# one place in the non-socket perl code.
-
-#these are all in libdll.a, which my version of nm doesn't know how to parse.
-#if I can get it to both do that, and scan multiple library files, perhaps
-#these can be gotten rid of.
-
-usemymalloc='n'
-# Hopefully, Be's malloc knows better than perl's.
-
-d_link='undef'
-dont_use_nlink='define'
-# no posix (aka hard) links for us!
-
-d_syserrlst='undef'
-# the array syserrlst[] is useless for the most part.
-# large negative numbers really kind of suck in arrays.
-
-# Sockets didn't use to be real sockets but BONE changes this.
-if [ ! -f /boot/develop/headers/be/bone/sys/socket.h ]; then
- d_socket='undef'
- d_gethbyaddr='undef'
- d_gethbyname='undef'
- d_getsbyname='undef'
-
- libs='-lnet'
-fi
-
-# There's a third party flock() emulation. Check, if it is available.
-echo "#include <flock.h>" > try.c
-if cc -E $CFLAGS try.c 2> /dev/null | grep "flock.*("; then
- d_flock='define'
- d_flockproto='define'
- libs="$libs -lflock"
- ldflags="$ldflags -L/boot/home/config/lib"
-else
- cat << 'EOM' >&4
-
-I couldn't find a <flock.h> header defining a flock() prototype. That header
-comes with the flock server package (available on BeBits). You have to add
-the path to the directory containing the header via the environment variable
-CFLAGS (should contain -I</path/to/dir/of/flock/header>). Perl will be compiled
-without flock() support, if the flock server package is not installed or the
-header not found.
-
-EOM
-
-fi
-rm try.c
-
-ld='gcc'
-
-export PATH="$PATH:$PWD/beos"
-
-case "$ldlibpthname" in
-'') ldlibpthname=LIBRARY_PATH ;;
-esac
-
-# the waitpid() wrapper (among other things)
-archobjs="beos.o"
-test -f beos.c || cp beos/beos.c .
Deleted: trunk/contrib/perl/hints/machten.sh
===================================================================
--- trunk/contrib/perl/hints/machten.sh 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/hints/machten.sh 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,276 +0,0 @@
-#! /bin/bash
-# machten.sh
-# This is for MachTen 4.1.4. It might work on other versions and variants
-# too. MachTen is now obsolete, lacks many features expected in modern UNIX
-# implementations, and suffers from a number of bugs which are likely never
-# to be fixed. This means that, in the absence of extensive work on
-# this file and on the perl source code, versions of perl later than 5.6.x
-# cannot successfully be built on MachTen. This file enforces this
-# restriction. Should you wish to port a later version of perl to MachTen,
-# feel free to contact me for pointers.
-# -- Dominic Dunlop <domo at computer.org> 040213
-#
-# Users of earlier MachTen versions might need a fixed tr from ftp.tenon.com.
-# This should be described in the MachTen release notes.
-#
-# MachTen 2.x has its own hint file.
-#
-# The original version of this file was put together by Andy Dougherty
-# <doughera at lafayette.edu> based on comments from lots of
-# folks, especially
-# Mark Pease <peasem at primenet.com>
-# Martijn Koster <m.koster at webcrawler.com>
-# Richard Yeh <rcyeh at cco.caltech.edu>
-#
-# Prevent building of perls later than 5.6.x, stating why -- see above.
-# -- Dominic Dunlop <domo at computer.org> 040213
-# Deny system's false claims to support mmap() and munmap(); note
-# also that Sys V IPC (re)disabled by jhi due to continuing inadequacy
-# -- Dominic Dunlop <domo at computer.org> 001111
-# Remove dynamic loading libraries from search; enable SysV IPC with
-# MachTen 4.1.4 and above; define SYSTEM_ALIGN_BYTES for old MT versions
-# -- Dominic Dunlop <domo at computer.org> 000224
-# Disable shadow password file access: MT 4.1.1 has necessary library
-# functions, but not header file (or documentation)
-# -- Dominic Dunlop <domo at computer.org> 990804
-# For now, explicitly disable dynamic loading -- MT 4.1.1 has it,
-# but these hints do not yet support it.
-# Define NOTEDEF_MACHTEN to undo gratuitous Tenon hack to signal.h.
-# -- Dominic Dunlop <domo at computer.org> 9800802
-# Completely disable SysV IPC pending more complete support from Tenon
-# -- Dominic Dunlop <domo at computer.org> 980712
-# Use vfork and perl's malloc by default
-# -- Dominic Dunlop <domo at computer.org> 980630
-# Raise perl's stack size again; cut down reg_infty; document
-# -- Dominic Dunlop <domo at computer.org> 980619
-# Use of semctl() can crash system: disable -- Dominic Dunlop 980506
-# Raise stack size further; slight tweaks to accomodate MT 4.1
-# -- Dominic Dunlop <domo at computer.org> 980211
-# Raise perl's stack size -- Dominic Dunlop <domo at tcp.ip.lu> 970922
-# Reinstate sigsetjmp iff version is 4.0.3 or greater; use nm
-# (assumes Configure change); prune libswanted -- Dominic Dunlop 970113
-# Warn about test failure due to old Berkeley db -- Dominic Dunlop 970105
-# Do not use perl's malloc; SysV IPC OK -- Neil Cutcliffe, Tenon 961030
-# File::Find's use of link count disabled by Dominic Dunlop 960528
-# Perl's use of sigsetjmp etc. disabled by Dominic Dunlop 960521
-
-# Assume that PERL_REVISON in patchlevel.h is 5.
-# If you want to try building perl-5.8.x or later, set PERL_VERSION_SAFE_MAX
-# appropriately in your environment before running Configure.
-if [ `awk '$1=="#define" && $2=="PERL_VERSION"{print $3}' patchlevel.h` \
- -gt ${PERL_VERSION_SAFE_MAX:-6} ]
-then
- cat <<EOF >&4
-
-Perl versions greater than 5.6.x have not been ported to MachTen. If you
-wish to build a version from the 5.6 track, please see the notes in
-README.machten
-EOF
- exit 1
-fi
-#
-# MachTen 4.1.1's support for shadow password file access is incomplete:
-# disable its use completely.
-d_getspnam=${d_getspnam:-undef}
-
-# MachTen 4.1.1 does support dynamic loading, but perl doesn't
-# know how to use it yet.
-usedl=${usedl:-undef}
-
-# MachTen 4.1.1 may have an unhelpful hack in /usr/include/signal.h.
-# Undo it if so.
-if grep NOTDEF_MACHTEN /usr/include/signal.h > /dev/null
-then
- ccflags="$ccflags -DNOTDEF_MACHTEN"
-fi
-
-# Power MachTen is a real memory system and its standard malloc
-# has been optimized for this. Using this malloc instead of Perl's
-# malloc may result in significant memory savings. In particular,
-# unlike most UNIX memory allocation subsystems, MachTen's free()
-# really does return unneeded process data memory to the system.
-# However, MachTen's malloc() is woefully slow -- maybe 100 times
-# slower than perl's own, so perl's own is usually the better
-# choice. In order to use perl's malloc(), the sbrk() system call
-# must be simulated using MachTen's malloc(). See malloc.c for
-# precise details of how this is achieved. Recent improvements
-# to perl's malloc() currently crash MachTen, and so are disabled
-# by -DPLAIN_MALLOC and -DNO_FANCY_MALLOC.
-usemymalloc=${usemymalloc:-y}
-
-# Older versions of MachTen malloc() data on a two-byte boundary, which
-# works, but slows down operations on long, float and double data.
-# Perl's malloc() can compensate if SYSTEM_ALLOC_ALIGNMENT is suitably
-# defined.
-if expr "$osvers" \< "4.1" >/dev/null
-then
-system_alloc_alignment=" -DSYSTEM_ALLOC_ALIGNMENT=2"
-fi
-# Do not wrap the following long line
-malloc_cflags='ccflags="$ccflags -DPLAIN_MALLOC -DNO_FANCY_MALLOC -DUSE_PERL_SBRK$system_alloc_alignment"'
-
-# When MachTen does a fork(), it immediately copies the whole of
-# the parent process' data space for the child. This can be
-# expensive. Using vfork() where appropriate avoids this cost.
-d_vfork=${d_vfork:-define}
-
-# Specify a high level of optimization (-O3 wouldn't do much more)
-optimize=${optimize:--O2 -fomit-frame-pointer}
-
-# Make symbol table listings less voluminous
-nmopts=-gp
-
-# Set reg_infty -- the maximum allowable number of repeats in regular
-# expressions such as /a{1,$max_repeats}/, and the maximum number of
-# times /a*/ will match. Setting this too high without having a stack
-# large enough to accommodate deep recursion in the regular expression
-# engine allows perl to crash your Mac due to stack overrun if it
-# encounters a pathological regular expression. The default is a
-# compromise between capability and required stack size (see below).
-# You may override the default value from the Configure command-line
-# like this:
-#
-# Configure -Dreg_infty=16368 ...
-
-reg_infty=${reg_infty:-2047}
-
-# If you want to have many perl processes active simultaneously --
-# processing CGI forms -- for example, you should opt for a small stack.
-# For safety, you should set reg_infty no larger than the corresponding
-# value given in this table:
-#
-# Stack size reg_infty value supported
-# ---------- -------------------------
-# 128k 2**8-1 (256)
-# 256k 2**9-1 (511)
-# 512k 2**10-1 (1023)
-# 1M 2**11-1 (2047)
-# ...
-# 16M 2**15-1 (32767) (perl's default value)
-
-# This script selects a safe stack size based on the value of reg_infty
-# specified above. However, you may choose to take a risk and set
-# stack size lower: pathological regular expressions are rare in real-world
-# programs. But be aware that, if perl does encounter one, it WILL
-# crash your system. Do not set stack size lower than 96k unless
-# you want perl's installation tests ( make test ) to crash your system.
-#
-# You may override the default value from the Configure command-line
-# by specifying the required size in kilobytes like this:
-#
-# Configure -Dstack_size=96
-
-if [ "X$stack_size" = 'X' ]
-then
- stack_size=128
- X=`expr $reg_infty / 256`
-
- while [ $X -gt 0 ]
- do
- X=`expr $X / 2`
- stack_size=`expr $stack_size \* 2`
- done
- X=`expr $stack_size \* 1024`
-fi
-
-ldflags="$ldflags -Xlstack=$X"
-ccflags="$ccflags -DREG_INFTY=$reg_infty"
-
-# Install in /usr/local by default
-prefix='/usr/local'
-
-# At least on PowerMac, doubles must be aligned on 8 byte boundaries.
-# I don't know if this is true for all MachTen systems, or how to
-# determine this automatically.
-alignbytes=8
-
-# 4.0.2 and earlier had a problem with perl's use of sigsetjmp and
-# friends. Use setjmp and friends instead.
-expr "$osvers" \< "4.0.3" > /dev/null && d_sigsetjmp='undef'
-
-# System V IPC before MachTen 4.1.4 is incomplete (missing msg function
-# prototypes, no ftok()), buggy (semctl(.., .., IPC_STATUS, ..) hangs
-# system), and undocumented. Claim it's not there at all before 4.1.4.
-if expr "$osvers" \< "4.1.4" >/dev/null
-then
-d_msg=${d_msg:-undef}
-d_sem=${d_sem:-undef}
-d_shm=${d_shm:-undef}
-fi
-
-
-# As of MachTen 4.1.4 the msg* and shm* are in libc but unimplemented
-# (an attempt to use them causes a runtime error)
-# XXX Configure probe for really functional msg*() is needed XXX
-# XXX Configure probe for really functional shm*() is needed XXX
-if test "$d_msg" = ""; then
- d_msgget=${d_msgget:-undef}
- d_msgctl=${d_msgctl:-undef}
- d_msgsnd=${d_msgsnd:-undef}
- d_msgrcv=${d_msgrcv:-undef}
- case "$d_msgget$d_msgsnd$d_msgctl$d_msgrcv" in
- *"undef"*) d_msg="$undef" ;;
- esac
-fi
-if test "$d_shm" = ""; then
- d_shmat=${d_shmat:-undef}
- d_shmdt=${d_shmdt:-undef}
- d_shmget=${d_shmget:-undef}
- d_shmctl=${d_shmctl:-undef}
- case "$d_shmat$d_shmctl$d_shmdt$d_shmget" in
- *"undef"*) d_shm="$undef" ;;
- esac
-fi
-
-# MachTen has stubs for mmap and munmap(), but they just result in the
-# caller being killed on the grounds of "Bad system call"
-d_mmap=${d_mmap:-undef}
-d_munmap=${d_munmap:-undef}
-
-# Get rid of some extra libs which it takes Configure a tediously
-# long time never to find on MachTen, or which break perl
-set `echo X "$libswanted "|sed -e 's/ net / /' -e 's/ socket / /' \
- -e 's/ inet / /' -e 's/ nsl / /' -e 's/ nm / /' -e 's/ malloc / /' \
- -e 's/ ld / /' -e 's/ sun / /' -e 's/ posix / /' \
- -e 's/ cposix / /' -e 's/ crypt / /' -e 's/ dl / /' -e 's/ dld / /' \
- -e 's/ ucb / /' -e 's/ bsd / /' -e 's/ BSD / /' -e 's/ PW / /'`
-shift
-libswanted="$*"
-
-# While link counts on MachTen 4.1's fast file systems work correctly,
-# on Macintosh Heirarchical File Systems, (and on HFS+)
-# MachTen always reports ony two links to directories, even if they
-# contain subdirectories. Consequently, we use this variable to stop
-# File::Find using the link count to determine whether there are
-# subdirectories to be searched. This will generate a harmless message:
-# Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
-# Propagating recommended variable dont_use_nlink
-dont_use_nlink=define
-
-cat <<EOM >&4
-
-At the end of Configure, you will see a harmless message
-
-Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
- Propagating recommended variable dont_use_nlink
- Propagating recommended variable nmopts
- Propagating recommended variable malloc_cflags...
- Propagating recommended variable reg_infty
- Propagating recommended variable system_alloc_alignment
-Read the File::Find documentation for more information about dont_use_nlink
-
-Your perl will be built with a stack size of ${stack_size}k and a regular
-expression repeat count limit of $reg_infty. If you want alternative
-values, see the file hints/machten.sh for advice on how to change them.
-
-Tests
- io/fs test 4 and
- op/stat test 3
-may fail since MachTen may not return a useful nlinks field to stat
-on directories.
-
-EOM
-expr "$osvers" \< "4.1" >/dev/null && test -r ./broken-db.msg && \
- . ./broken-db.msg
-
-unset stack_size X
Deleted: trunk/contrib/perl/hints/machten_2.sh
===================================================================
--- trunk/contrib/perl/hints/machten_2.sh 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/hints/machten_2.sh 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,91 +0,0 @@
-# machten.sh
-# This file has been put together by Mark Pease <peasem at primenet.com>
-# Comments, questions, and improvements welcome!
-#
-# MachTen does not support dynamic loading. If you wish to, you
-# can fetch, compile, and install the dld package.
-# This ought to work with the ext/DynaLoader/dl_dld.xs in the
-# perl5 package. Have fun!
-# Some possible locations for dld:
-# ftp-swiss.ai.mit.edu:pub/scm/dld-3.2.7.tar.gz
-# prep.ai.mit.edu:/pub/gnu/jacal/dld-3.2.7.tar.gz
-# ftp.cs.indiana.edu:/pub/scheme-repository/imp/SCM-support/dld-3.2.7.tar.gz
-# tsx-11.mit.edu:/pub/linux/sources/libs/dld-3.2.7.tar.gz
-#
-# Original version was for MachTen 2.1.1.
-# Last modified by Andy Dougherty <doughera at lafayette.edu>
-# Tue Aug 13 12:31:01 EDT 1996
-#
-# Warning about tests which no longer fail
-# fixed by Tom Phoenix <rootbeer at teleport.com>
-# March 5, 1997
-#
-# Locale, optimization, and malloc changes by Tom Phoenix Mar 15, 1997
-#
-# groupstype change and note about t/lib/findbin.t by Tom, Mar 24, 1997
-
-# MachTen's ability to have valid filepaths beginning with "//" may
-# be causing lib/FindBin.pm to fail. I don't know how to fix it, but
-# the reader is encouraged to do so! :-) -- Tom
-
-# There seem to be some hard-to-diagnose problems under MachTen's
-# malloc, so we'll use Perl's. If you have problems which Perl's
-# malloc's diagnostics can't help you with, you may wish to use
-# MachTen's malloc after all.
-case "$usemymalloc" in
-'') usemymalloc='y' ;;
-esac
-
-# I (Tom Phoenix) don't know how to test for locales on MachTen. (If
-# you do, please fix this hints file!) But since mine didn't come
-# with locales working out of the box, I'll assume that's the case
-# for most folks.
-case "$d_setlocale" in
-'') d_setlocale=undef
-esac
-
-# MachTen doesn't have secure setid scripts
-d_suidsafe='undef'
-
-# groupstype should be gid_t, as near as I can tell, but it only
-# seems to work right when it's int.
-groupstype='int'
-
-case "$optimize" in
-'') optimize='-O2' ;;
-esac
-
-so='none'
-# These are useful only if you have DLD, but harmless otherwise.
-# Make sure gcc doesn't use -fpic.
-cccdlflags=' ' # That's an empty space.
-lddlflags='-r'
-dlext='o'
-
-# MachTen does not support POSIX enough to compile the POSIX module.
-useposix=false
-
-#MachTen might have an incomplete Berkeley DB implementation.
-i_db=$undef
-
-#MachTen versions 2.X have no hard links. This variable is used
-# by File::Find.
-# This will generate a harmless message:
-# Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
-# Propagating recommended variable dont_use_nlink
-# Without this, tests io/fs #4 and op/stat #3 will fail.
-dont_use_nlink=define
-
-cat <<'EOM' >&4
-
-At the end of Configure, you will see a harmless message
-
-Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
- Propagating recommended variable dont_use_nlink
-
-Read the File::Find documentation for more information.
-
-It's possible that test t/lib/findbin.t will fail on some configurations
-of MachTen.
-
-EOM
Deleted: trunk/contrib/perl/hints/mpeix.sh
===================================================================
--- trunk/contrib/perl/hints/mpeix.sh 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/hints/mpeix.sh 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,136 +0,0 @@
-# Created for 5.003 by Mark Klein, mklein at dis.com.
-# Substantially revised for 5.004_01 by Mark Bixby, markb at cccd.edu.
-# Revised again for 5.004_69 by Mark Bixby, markb at cccd.edu.
-# Revised for 5.6.0 by Mark Bixby, mbixby at power.net.
-# Revised for 5.7.3 by Mark Bixby, mark at bixby.org.
-# Revised for 5.8.0 by Mark Bixby, mark at bixby.org.
-# Revised for 5.8.8/5.9.3 by Ken Hirsch, kenhirsch at ftml.net
-#
-osname='mpeix'
-osvers=`uname -r | sed -e 's/.[A-Z]\.\([0-9]\)\([0-9]\)\.[0-9][0-9]/\1.\2/'`
-
-#
-# Don't use nm. Instead, we'll use the MPEAUTOCONF environment variable
-# to force error for unresolved externals.
-# This is slower than nm (about 70 minutes instead of 35 minutes),
-# but much more reliable.
-
-usenm='false'
-export AUTOCONF=1 MPEAUTOCONF=1
-
-# Work around the broken inline cat bug that corrupts here docs
-#
-alias -x cat=/bin/cat
-#
-# Various directory locations.
-#
-# Which ones of these does Configure get wrong?
-test -z "$prefix" && prefix="/$HPACCOUNT/$HPGROUP"
-archname='PA-RISC1.1'
-bin="$prefix"
-installman1dir="$prefix/man/man1"
-installman3dir="$prefix/man/man3"
-man1dir="$prefix/man/man1"
-man3dir="$prefix/man/man3"
-perlpath="$prefix/PERL"
-scriptdir="$prefix"
-startperl="#!$prefix/perl"
-startsh='#!/bin/sh'
-
-#
-# Compiling.
-#
-test -z "$cc" && cc='gcc'
-cccdlflags='none'
-ccdlflags='-Xlinker -WL,xl=/usr/lib/libcurses.sl,/lib/libsvipc.sl,/usr/lib/libsocket.sl,/usr/lib/libstr.sl,/lib/libm.sl,/lib/libc.sl'
-ccflags="$ccflags -DMPE -D_POSIX_SOURCE -D_SOCKET_SOURCE -D_POSIX_JOB_CONTROL"
-locincpth="$locincpth /usr/local/include /usr/contrib/include /BIND/CURRENT/include /SYSLOG/PUB"
-test -z "$optimize" && optimize="-O2"
-ranlib='/bin/true'
-# Special compiling options for certain source files.
-# But what if you want -g?
-regcomp_cflags='optimize=-O'
-toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"'
-
-#
-# Linking.
-#
-# Build a fixed sigsetjmp that can be used in dynamic libraries
-# This needs to be compiled with -O2, so I do it here, rather
-# than with make
-gcc -c -O2 mpeix/mpeix_setjmp.c
-lddlflags="-b $PWD/mpeix_setjmp.o"
-
-# Delete bsd and BSD from the library list. Remove other randomly ordered
-# libraries and then re-add them in their proper order (the MPE linker is
-# order-sensitive). Add additional MPE-specific libraries.
-for mpe_remove in bind bsd BSD c curses m socket str svipc syslog; do
- set `echo " $libswanted " | sed -e 's/ / /g' -e "s/ $mpe_remove //"`
- libswanted="$*"
-done
-libswanted="$libswanted bind syslog curses svipc socket str m c"
-loclibpth="$loclibpth /usr/local/lib /usr/contrib/lib /BIND/CURRENT/lib /SYSLOG/PUB"
-#
-# External functions and data items.
-#
-# Q: Does Configure *really* get *all* of these wrong?
-#
-# A: Yes. There are two MPE problems here. The 'undef' functions exist on MPE,
-# but are merely dummy routines that return ENOTIMPL or ESYSERR. Since they're
-# useless, let's just tell Perl to avoid them. Also, a few data items are
-# 'undef' because while they may exist in structures, they are uninitialized.
-
-d_Gconvert='gcvt((x),(n),(b))'
-
-d_inetaton='undef'
-
-# these fields exist, but are uninitialized
-d_pwage='undef'
-d_pwcomment='undef'
-d_pwgecos='undef'
-d_pwpasswd='undef'
-d_statblks='undef'
-
-# These functions exist,
-# but either return ENOSYS/ESYSERR/ENOSYS or work so differently
-# that it is not helpful to include them
-
-d_lchown='undef'
-d_link='undef'
-d_setegid='undef'
-d_seteuid='undef'
-d_setitimer='undef'
-d_setpgid='undef'
-d_setsid='undef'
-
-
-# These are defined in mpeix/mpeix.c
-d_gettimeod='define'
-d_truncate='define'
-
-# Include files.
-#
-#??i_gdbm='undef' # the port is currently incomplete
-
-i_termios='undef' # we have termios, but not the full set (just tcget/setattr)
-
-i_time='define'
-i_systime='undef'
-i_systimek='undef'
-timeincl='/usr/include/time.h'
-#
-# Data types.
-#
-timetype='time_t'
-
-# Functionality.
-#
-uselargefiles="$undef"
-
-# Expected functionality provided in mpeix.c.
-#
-
-# Help gmake find mpeix.c
-test -h mpeix.c || ln -s mpeix/mpeix.c mpeix.c
-
-archobjs='mpeix.o mpeix_setjmp.o'
Deleted: trunk/contrib/perl/hints/rhapsody.sh
===================================================================
--- trunk/contrib/perl/hints/rhapsody.sh 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/hints/rhapsody.sh 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,138 +0,0 @@
-##
-# Rhapsody (Mac OS X Server) hints
-# Wilfredo Sanchez <wsanchez at wsanchez.net>
-##
-
-##
-# Paths
-##
-
-# Configure hasn't figured out the version number yet. Bummer.
-perl_revision=`awk '/define[ ]+PERL_REVISION/ {print $3}' $src/patchlevel.h`
-perl_version=`awk '/define[ ]+PERL_VERSION/ {print $3}' $src/patchlevel.h`
-perl_subversion=`awk '/define[ ]+PERL_SUBVERSION/ {print $3}' $src/patchlevel.h`
-version="${perl_revision}.${perl_version}.${perl_subversion}"
-
-# BSD paths
-case "$prefix" in
- '')
- # Default install; use non-system directories
- prefix='/usr/local'; # Built-in perl uses /usr
- siteprefix='/usr/local';
- vendorprefix='/usr'; usevendorprefix='define';
-
- # Where to put modules.
- sitelib="/Local/Library/Perl/${version}"; # FIXME: Want "/Network/Perl/${version}" also
- vendorlib="/System/Library/Perl/${version}"; # Apple-supplied modules
- ;;
-
- '/usr')
- # We are building/replacing the built-in perl
- siteprefix='/usr/local';
- vendorprefix='/usr/local'; usevendorprefix='define';
-
- # Where to put modules.
- sitelib="/Local/Library/Perl/${version}"; # FIXME: Want "/Network/Perl/${version}" also
- vendorlib="/System/Library/Perl/${version}"; # Apple-supplied modules
- ;;
-esac
-
-##
-# Tool chain settings
-##
-
-# Since we can build fat, the archname doesn't need the processor type
-archname='rhapsody';
-
-# nm works.
-usenm='true';
-
-# Libc is in libsystem.
-libc='/System/Library/Frameworks/System.framework/System';
-
-# Optimize.
-optimize='-O3';
-
-# -fno-common because common symbols are not allowed in MH_DYLIB
-ccflags="${ccflags} -fno-common"
-
-# Unverified whether this is necessary on Rhapsody, but the test shouldn't hurt.
-# At least on Darwin 1.3.x:
-#
-# # define INT32_MIN -2147483648
-# int main () {
-# double a = INT32_MIN;
-# printf ("INT32_MIN=%g\n", a);
-# return 0;
-# }
-# will output:
-# INT32_MIN=2.14748e+09
-# Note that the INT32_MIN has become positive.
-# INT32_MIN is set in /usr/include/stdint.h by:
-# #define INT32_MIN -2147483648
-# which seems to break the gcc. Defining INT32_MIN as (-2147483647-1)
-# seems to work. INT64_MIN seems to be similarly broken.
-# -- Nicholas Clark, Ken Williams, and Edward Moy
-#
-case "$(grep '^#define INT32_MIN' /usr/include/stdint.h)" in
- *-2147483648) ccflags="${ccflags} -DINT32_MIN_BROKEN -DINT64_MIN_BROKEN" ;;
-esac
-
-# cpp-precomp is problematic.
-cppflags='${cppflags} -traditional-cpp';
-
-# This is necessary because perl's build system doesn't
-# apply cppflags to cc compile lines as it should.
-ccflags="${ccflags} ${cppflags}"
-
-# Shared library extension is .dylib.
-# Bundle extension is .bundle.
-ld='cc';
-so='dylib';
-dlext='bundle';
-dlsrc='dl_dyld.xs';
-usedl='define';
-cccdlflags='';
-lddlflags="${ldflags} -bundle -undefined suppress";
-ldlibpthname='DYLD_LIBRARY_PATH';
-useshrplib='true';
-
-##
-# System libraries
-##
-
-# vfork works
-usevfork='true';
-
-# our malloc works (but allow users to override)
-case "$usemymalloc" in
-'') usemymalloc='n' ;;
-esac
-
-#
-# The libraries are not threadsafe in Rhapsody
-#
-# Fix when Apple fixes libc.
-#
-case "$usethreads$useithreads" in
- *define*)
- cat <<EOM >&4
-
-
-
-*** Warning, there might be problems with your libraries with
-*** regards to threading. The test ext/threads/t/libc.t is likely
-*** to fail.
-
-EOM
- ;;
-esac
-
-##
-# Build process
-##
-
-# Case-insensitive filesystems don't get along with Makefile and
-# makefile in the same place. Since Darwin uses GNU make, this dodges
-# the problem.
-firstmakefile=GNUmakefile;
Deleted: trunk/contrib/perl/hints/uts.sh
===================================================================
--- trunk/contrib/perl/hints/uts.sh 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/hints/uts.sh 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,32 +0,0 @@
-archname='s390'
-archobjs='uts/strtol_wrap.o uts/sprintf_wrap.o'
-cc='cc -Xa'
-ccflags='-XTSTRINGS=1500000 -DStrtol=strtol_wrap32 -DStrtoul=strtoul_wrap32 -DSPRINTF_E_BUG'
-cccdlflags='-pic'
-d_bincompat3='undef'
-d_csh='undef'
-d_lstat='define'
-d_suidsafe='define'
-dlsrc='dl_dlopen.xs'
-i_ieeefp='undef'
-ld='ld'
-lddlflags='-G -z text'
-libperl='libperl.so'
-libpth='/lib /usr/lib /usr/ccs/lib'
-libs='-lsocket -lnsl -ldl -lm'
-libswanted='m'
-prefix='/usr/local'
-toke_cflags='optimize=""'
-useshrplib='true'
-
-#################################
-# Some less routine stuff:
-#################################
-cc -g -Xa -c -pic -O uts/strtol_wrap.c -o uts/strtol_wrap.o
-cc -g -Xa -c -pic -O uts/sprintf_wrap.c -o uts/sprintf_wrap.o
-# Make POSIX a static extension.
-cat <<'EOSH' > config.over
-static_ext='POSIX B'
-dynamic_ext=`echo " $dynamic_ext " |
- sed -e 's/ POSIX / /' -e 's/ B / /'`
-EOSH
Deleted: trunk/contrib/perl/hints/vmesa.sh
===================================================================
--- trunk/contrib/perl/hints/vmesa.sh 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/hints/vmesa.sh 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,342 +0,0 @@
-# hints/vmesa.sh
-#
-# VM/ESA hints by Neale Ferguson (neale at mailbox.tabnsw.com.au)
-#
-# Currently (1999-Jan-09) Configure cannot be used in VM/ESA because
-# too many things are done differently in the C compiler environment.
-# Therefore the hints file is hand-crafted. --jhi at iki.fi
-#
-
-case "$archname" in
-'') archname="$osname" ;;
-esac
-bin='/usr/local/bin'
-binexp='/usr/local/bin'
-byacc='byacc'
-c='\c'
-cc='c89'
-ccflags="-D_OE_SOCKETS -DOLD_PTHREADS_API -DYYDYNAMIC -DDEBUGGING -I.." \
- "-I/usr/local/include -W c,hwopts\\\(string\\\),langlvl\\\(ansi\\\)"
-clocktype='clock_t'
-cryptlib="n"
-d_Gconvert='gcvt((x),(n),(b))'
-d_access='define'
-d_alarm='define'
-d_archlib='define'
-# randbits='15'
-archobjs="vmesa.o"
-d_attribute_format='undef'
-d_attribute_malloc='undef'
-d_attribute_nonnull='undef'
-d_attribute_noreturn='undef'
-d_attribute_pure='undef'
-d_attribute_unused='undef'
-d_attribute_warn_unused_result='undef'
-d_bcmp='define'
-d_bcopy='define'
-d_bsd='undef'
-d_bsdgetpgrp='undef'
-d_bsdsetpgrp='undef'
-d_bzero='define'
-d_casti32='define'
-d_castneg='define'
-d_charvspr='undef'
-d_chown='define'
-d_chroot='undef'
-d_chsize='undef'
-d_closedir='define'
-d_const='define'
-d_crypt='undef'
-d_csh='undef'
-d_cuserid='define'
-d_dbl_dig='define'
-d_difftime='define'
-d_dirnamlen='undef'
-d_dlerror='define'
-d_dlopen='define'
-d_dlsymun='define'
-d_dosuid='undef'
-d_dup2='define'
-d_endgrent='undef'
-d_endpwent='undef'
-d_eofnblk='define'
-d_eunice='undef'
-d_fchmod='define'
-d_fchown='define'
-d_fcntl='define'
-d_fd_macros='define'
-d_fd_set='define'
-d_fds_bits='define'
-d_fgetpos='define'
-d_flexfnam='define'
-d_flock='undef'
-d_fork='undef'
-d_fpathconf='define'
-d_fsetpos='define'
-d_ftime='undef'
-d_getgrent='undef'
-d_gethent='define'
-d_gethname='undef'
-d_getlogin='define'
-d_getpgid='undef'
-d_getpgrp='define'
-d_getpgrp2='undef'
-d_getppid='define'
-d_getprior='undef'
-d_getpwent='undef'
-d_gettimeod='define'
-d_gnulibc='undef'
-d_htonl='define'
-d_index='define'
-d_inetaton='undef'
-d_isascii='define'
-d_killpg='define'
-d_link='define'
-d_locconv='define'
-d_lockf='define'
-d_longdbl='undef'
-d_longllong='undef'
-d_lstat='define'
-d_mblen='define'
-d_mbstowcs='define'
-d_mbtowc='define'
-d_memcmp='define'
-d_memcpy='define'
-d_memmove='define'
-d_memset='define'
-d_mkdir='define'
-d_mkfifo='define'
-d_mktime='define'
-d_msg='define'
-d_msgctl='define'
-d_msgget='define'
-d_msgrcv='define'
-d_msgsnd='define'
-d_mymalloc='undef'
-d_nice='undef'
-d_oldsock='undef'
-d_open3='define'
-d_pathconf='define'
-d_pause='define'
-d_phostname='undef'
-d_pipe='define'
-d_poll='undef'
-d_portable='define'
-d_pwage='undef'
-d_pwchange='undef'
-d_pwclass='undef'
-d_pwcomment='undef'
-d_pwexpire='undef'
-d_pwquota='undef'
-d_readdir='define'
-d_readlink='define'
-d_rename='define'
-d_rewinddir='define'
-d_rmdir='define'
-d_safebcpy='define'
-d_safemcpy='undef'
-d_sanemcmp='define'
-d_sched_yield='undef'
-d_seekdir='undef'
-d_select='define'
-d_sem='define'
-d_semctl='define'
-d_semctl_semid_ds='define'
-d_semget='define'
-d_semop='define'
-d_setegid='define'
-d_seteuid='define'
-d_setgrent='undef'
-d_setgrps='undef'
-d_setlinebuf='undef'
-d_setlocale='define'
-d_setpgid='define'
-d_setpgrp='define'
-d_setpgrp2='undef'
-d_setprior='undef'
-d_setpwent='undef'
-d_setregid='undef'
-d_setresgid='undef'
-d_setresuid='undef'
-d_setreuid='undef'
-d_setrgid='undef'
-d_setruid='undef'
-d_setsid='define'
-d_sfio='undef'
-d_shm='define'
-d_shmat='define'
-d_shmatprototype='define'
-d_shmctl='define'
-d_shmdt='define'
-d_shmget='define'
-d_sigaction='define'
-d_sigsetjmp='define'
-d_socket='define'
-d_sockpair='undef'
-d_statblks='undef'
-d_stdio_cnt_lval='undef'
-d_stdio_ptr_lval='undef'
-d_stdiobase='undef'
-d_stdstdio='undef'
-d_strchr='define'
-d_strcoll='define'
-d_strctcpy='undef'
-d_strerrm='strerror(e)'
-d_strerror='define'
-d_strtod='define'
-d_strtol='define'
-d_strtoul='define'
-d_strxfrm='define'
-d_suidsafe='undef'
-d_symlink='define'
-d_syscall='undef'
-d_sysconf='define'
-d_sysernlst="n"
-d_syserrlst='undef'
-d_system='define'
-d_tcgetpgrp='define'
-d_tcsetpgrp='define'
-d_telldir='undef'
-d_time='define'
-d_times='define'
-d_truncate='define'
-d_tzname='define'
-d_umask='define'
-d_uname='define'
-d_union_semun='undef'
-d_vfork='define'
-d_void_closedir='undef'
-d_voidsig='define'
-d_voidtty="n"
-d_volatile='define'
-d_vprintf='define'
-d_waitpid='define'
-d_wait4='undef'
-d_wcstombs='define'
-d_wctomb='define'
-d_xenix='undef'
-db_hashtype='u_int32_t'
-db_prefixtype='size_t'
-direntrytype='struct dirent'
-dlext='none'
-dlsrc='dl_vmesa.xs'
-dynamic_ext=''
-eagain='EAGAIN'
-ebcdic='define'
-exe_ext=''
-fpostype='fpos_t'
-freetype='void'
-groupstype='gid_t'
-h_fcntl='false'
-h_sysfile='true'
-hint='recommended'
-i_arpainet="define"
-i_bsdioctl="n"
-i_db='undef'
-i_dbm='define'
-i_dirent='define'
-i_dld='define'
-i_dlfcn='define'
-i_fcntl='undef'
-i_float='define'
-i_gdbm='define'
-i_grp='define'
-i_limits='define'
-i_locale='define'
-i_malloc='undef'
-i_math='define'
-i_memory='define'
-i_ndbm='define'
-i_neterrno='undef'
-i_niin='define'
-i_pwd='define'
-i_rpcsvcdbm='undef'
-i_sfio='undef'
-i_sgtty='undef'
-i_stdarg='define'
-i_stddef='define'
-i_stdlib='define'
-i_string='define'
-i_sysdir='define'
-i_sysfile='define'
-i_sysfilio='undef'
-i_sysin='undef'
-i_sysioctl='define'
-i_sysndir='undef'
-i_sysparam='undef'
-i_sysresrc='define'
-i_sysselct='undef'
-i_syssockio="n"
-i_sysstat='define'
-i_systime='define'
-i_systimek='undef'
-i_systimes='define'
-i_systypes='define'
-i_sysun='define'
-i_syswait='define'
-i_termio='undef'
-i_termios='define'
-i_time='undef'
-i_unistd='define'
-i_utime='define'
-i_values='undef'
-i_varargs='undef'
-i_varhdr='stdarg.h'
-i_vfork='undef'
-ld='c89'
-ldflags='-L/usr/local/lib -L.'
-lib_ext='.a'
-libc=''
-libperl='libperl.a'
-libpth='/usr/local/lib /lib /usr/lib'
-libs='-l//posxsock -l//vmmtlib -lgdbm -lxpg4'
-libswanted='gdbm'
-lint="n"
-locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include'
-loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib'
-make_set_make='#'
-make='gnumake'
-mallocobj=''
-mallocsrc=''
-malloctype='void *'
-netdb_hlen_type='size_t'
-netdb_host_type='char *'
-netdb_name_type='const char *'
-netdb_net_type='in_addr_t'
-o_nonblock='O_NONBLOCK'
-obj_ext='.o'
-optimize='undef'
-prefix='/usr/local'
-prefixexp='/usr/local'
-prototype='define'
-ranlib=':'
-rd_nodata='-1'
-scriptdir='/usr/local/bin'
-scriptdirexp='/usr/local/bin'
-selecttype='fd_set *'
-shmattype='void *'
-shrpenv=''
-signal_t='void'
-sig_name_init='"ZERO","HUP","INT","ABRT","ILL","POLL","URG","STOP","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","NUM18","CONT","CHLD","TTIN","TTOU","IO","QUIT","TSTP","TRAP","NUM27","WINCH","XCPU","XFSZ","VTALRM","PROF","NUM33","NUM34","NUM35","NUM36","NUM3","NUM38","NUM39","NUM40","NUM41","NUM42","NUM43","NUM44","NUM45","NUM46","NUM47","NUM48","NUM49","CLD"'
-sig_num_init='0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,20 '
-sizetype='size_t'
-so='.a'
-ssizetype='ssize_t'
-static_ext='Data/Dumper Digest/MD5 Fcntl Filter/Util/Call GDBM_File IO IPC/SysV List/Util MIME/Base64 NDBM_File Opcode PerlIO/scalar POSIX Socket Storable Time/HiRes Time/Piece attributes re'
-stdchar='char'
-stdio_cnt='(fp)->__countIn'
-stdio_ptr='(fp)->__bufPtr'
-timeincl='sys/time.h '
-timetype='time_t'
-uidtype='uid_t'
-usedl='define'
-usemymalloc='n'
-usenm='false'
-useopcode='true'
-useperlio='undef'
-useposix='true'
-usesfio='false'
-useshrplib='false'
-usethreads='y'
-usevfork='true'
-vi='x'
Deleted: trunk/contrib/perl/lib/AutoLoader.pm
===================================================================
--- trunk/contrib/perl/lib/AutoLoader.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/AutoLoader.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,429 +0,0 @@
-package AutoLoader;
-
-use strict;
-use 5.006_001;
-
-our($VERSION, $AUTOLOAD);
-
-my $is_dosish;
-my $is_epoc;
-my $is_vms;
-my $is_macos;
-
-BEGIN {
- $is_dosish = $^O eq 'dos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'NetWare';
- $is_epoc = $^O eq 'epoc';
- $is_vms = $^O eq 'VMS';
- $is_macos = $^O eq 'MacOS';
- $VERSION = '5.68';
-}
-
-AUTOLOAD {
- my $sub = $AUTOLOAD;
- my $filename = AutoLoader::find_filename( $sub );
-
- my $save = $@;
- local $!; # Do not munge the value.
- eval { local $SIG{__DIE__}; require $filename };
- if ($@) {
- if (substr($sub,-9) eq '::DESTROY') {
- no strict 'refs';
- *$sub = sub {};
- $@ = undef;
- } elsif ($@ =~ /^Can't locate/) {
- # The load might just have failed because the filename was too
- # long for some old SVR3 systems which treat long names as errors.
- # If we can successfully truncate a long name then it's worth a go.
- # There is a slight risk that we could pick up the wrong file here
- # but autosplit should have warned about that when splitting.
- if ($filename =~ s/(\w{12,})\.al$/substr($1,0,11).".al"/e){
- eval { local $SIG{__DIE__}; require $filename };
- }
- }
- if ($@){
- $@ =~ s/ at .*\n//;
- my $error = $@;
- require Carp;
- Carp::croak($error);
- }
- }
- $@ = $save;
- goto &$sub;
-}
-
-sub find_filename {
- my $sub = shift;
- my $filename;
- # Braces used to preserve $1 et al.
- {
- # Try to find the autoloaded file from the package-qualified
- # name of the sub. e.g., if the sub needed is
- # Getopt::Long::GetOptions(), then $INC{Getopt/Long.pm} is
- # something like '/usr/lib/perl5/Getopt/Long.pm', and the
- # autoload file is '/usr/lib/perl5/auto/Getopt/Long/GetOptions.al'.
- #
- # However, if @INC is a relative path, this might not work. If,
- # for example, @INC = ('lib'), then $INC{Getopt/Long.pm} is
- # 'lib/Getopt/Long.pm', and we want to require
- # 'auto/Getopt/Long/GetOptions.al' (without the leading 'lib').
- # In this case, we simple prepend the 'auto/' and let the
- # C<require> take care of the searching for us.
-
- my ($pkg,$func) = ($sub =~ /(.*)::([^:]+)$/);
- $pkg =~ s#::#/#g;
- if (defined($filename = $INC{"$pkg.pm"})) {
- if ($is_macos) {
- $pkg =~ tr#/#:#;
- $filename = undef
- unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto:$pkg:$func.al#s;
- } else {
- $filename = undef
- unless $filename =~ s#^(.*)$pkg\.pm\z#$1auto/$pkg/$func.al#s;
- }
-
- # if the file exists, then make sure that it is a
- # a fully anchored path (i.e either '/usr/lib/auto/foo/bar.al',
- # or './lib/auto/foo/bar.al'. This avoids C<require> searching
- # (and failing) to find the 'lib/auto/foo/bar.al' because it
- # looked for 'lib/lib/auto/foo/bar.al', given @INC = ('lib').
-
- if (defined $filename and -r $filename) {
- unless ($filename =~ m|^/|s) {
- if ($is_dosish) {
- unless ($filename =~ m{^([a-z]:)?[\\/]}is) {
- if ($^O ne 'NetWare') {
- $filename = "./$filename";
- } else {
- $filename = "$filename";
- }
- }
- }
- elsif ($is_epoc) {
- unless ($filename =~ m{^([a-z?]:)?[\\/]}is) {
- $filename = "./$filename";
- }
- }
- elsif ($is_vms) {
- # XXX todo by VMSmiths
- $filename = "./$filename";
- }
- elsif (!$is_macos) {
- $filename = "./$filename";
- }
- }
- }
- else {
- $filename = undef;
- }
- }
- unless (defined $filename) {
- # let C<require> do the searching
- $filename = "auto/$sub.al";
- $filename =~ s#::#/#g;
- }
- }
- return $filename;
-}
-
-sub import {
- my $pkg = shift;
- my $callpkg = caller;
-
- #
- # Export symbols, but not by accident of inheritance.
- #
-
- if ($pkg eq 'AutoLoader') {
- if ( @_ and $_[0] =~ /^&?AUTOLOAD$/ ) {
- no strict 'refs';
- *{ $callpkg . '::AUTOLOAD' } = \&AUTOLOAD;
- }
- }
-
- #
- # Try to find the autosplit index file. Eg., if the call package
- # is POSIX, then $INC{POSIX.pm} is something like
- # '/usr/local/lib/perl5/POSIX.pm', and the autosplit index file is in
- # '/usr/local/lib/perl5/auto/POSIX/autosplit.ix', so we require that.
- #
- # However, if @INC is a relative path, this might not work. If,
- # for example, @INC = ('lib'), then
- # $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
- # 'auto/POSIX/autosplit.ix' (without the leading 'lib').
- #
-
- (my $calldir = $callpkg) =~ s#::#/#g;
- my $path = $INC{$calldir . '.pm'};
- if (defined($path)) {
- # Try absolute path name, but only eval it if the
- # transformation from module path to autosplit.ix path
- # succeeded!
- my $replaced_okay;
- if ($is_macos) {
- (my $malldir = $calldir) =~ tr#/#:#;
- $replaced_okay = ($path =~ s#^(.*)$malldir\.pm\z#$1auto:$malldir:autosplit.ix#s);
- } else {
- $replaced_okay = ($path =~ s#^(.*)$calldir\.pm\z#$1auto/$calldir/autosplit.ix#);
- }
-
- eval { require $path; } if $replaced_okay;
- # If that failed, try relative path with normal @INC searching.
- if (!$replaced_okay or $@) {
- $path ="auto/$calldir/autosplit.ix";
- eval { require $path; };
- }
- if ($@) {
- my $error = $@;
- require Carp;
- Carp::carp($error);
- }
- }
-}
-
-sub unimport {
- my $callpkg = caller;
-
- no strict 'refs';
-
- for my $exported (qw( AUTOLOAD )) {
- my $symname = $callpkg . '::' . $exported;
- undef *{ $symname } if \&{ $symname } == \&{ $exported };
- *{ $symname } = \&{ $symname };
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-AutoLoader - load subroutines only on demand
-
-=head1 SYNOPSIS
-
- package Foo;
- use AutoLoader 'AUTOLOAD'; # import the default AUTOLOAD subroutine
-
- package Bar;
- use AutoLoader; # don't import AUTOLOAD, define our own
- sub AUTOLOAD {
- ...
- $AutoLoader::AUTOLOAD = "...";
- goto &AutoLoader::AUTOLOAD;
- }
-
-=head1 DESCRIPTION
-
-The B<AutoLoader> module works with the B<AutoSplit> module and the
-C<__END__> token to defer the loading of some subroutines until they are
-used rather than loading them all at once.
-
-To use B<AutoLoader>, the author of a module has to place the
-definitions of subroutines to be autoloaded after an C<__END__> token.
-(See L<perldata>.) The B<AutoSplit> module can then be run manually to
-extract the definitions into individual files F<auto/funcname.al>.
-
-B<AutoLoader> implements an AUTOLOAD subroutine. When an undefined
-subroutine in is called in a client module of B<AutoLoader>,
-B<AutoLoader>'s AUTOLOAD subroutine attempts to locate the subroutine in a
-file with a name related to the location of the file from which the
-client module was read. As an example, if F<POSIX.pm> is located in
-F</usr/local/lib/perl5/POSIX.pm>, B<AutoLoader> will look for perl
-subroutines B<POSIX> in F</usr/local/lib/perl5/auto/POSIX/*.al>, where
-the C<.al> file has the same name as the subroutine, sans package. If
-such a file exists, AUTOLOAD will read and evaluate it,
-thus (presumably) defining the needed subroutine. AUTOLOAD will then
-C<goto> the newly defined subroutine.
-
-Once this process completes for a given function, it is defined, so
-future calls to the subroutine will bypass the AUTOLOAD mechanism.
-
-=head2 Subroutine Stubs
-
-In order for object method lookup and/or prototype checking to operate
-correctly even when methods have not yet been defined it is necessary to
-"forward declare" each subroutine (as in C<sub NAME;>). See
-L<perlsub/"SYNOPSIS">. Such forward declaration creates "subroutine
-stubs", which are place holders with no code.
-
-The AutoSplit and B<AutoLoader> modules automate the creation of forward
-declarations. The AutoSplit module creates an 'index' file containing
-forward declarations of all the AutoSplit subroutines. When the
-AutoLoader module is 'use'd it loads these declarations into its callers
-package.
-
-Because of this mechanism it is important that B<AutoLoader> is always
-C<use>d and not C<require>d.
-
-=head2 Using B<AutoLoader>'s AUTOLOAD Subroutine
-
-In order to use B<AutoLoader>'s AUTOLOAD subroutine you I<must>
-explicitly import it:
-
- use AutoLoader 'AUTOLOAD';
-
-=head2 Overriding B<AutoLoader>'s AUTOLOAD Subroutine
-
-Some modules, mainly extensions, provide their own AUTOLOAD subroutines.
-They typically need to check for some special cases (such as constants)
-and then fallback to B<AutoLoader>'s AUTOLOAD for the rest.
-
-Such modules should I<not> import B<AutoLoader>'s AUTOLOAD subroutine.
-Instead, they should define their own AUTOLOAD subroutines along these
-lines:
-
- use AutoLoader;
- use Carp;
-
- sub AUTOLOAD {
- my $sub = $AUTOLOAD;
- (my $constname = $sub) =~ s/.*:://;
- my $val = constant($constname, @_ ? $_[0] : 0);
- if ($! != 0) {
- if ($! =~ /Invalid/ || $!{EINVAL}) {
- $AutoLoader::AUTOLOAD = $sub;
- goto &AutoLoader::AUTOLOAD;
- }
- else {
- croak "Your vendor has not defined constant $constname";
- }
- }
- *$sub = sub { $val }; # same as: eval "sub $sub { $val }";
- goto &$sub;
- }
-
-If any module's own AUTOLOAD subroutine has no need to fallback to the
-AutoLoader's AUTOLOAD subroutine (because it doesn't have any AutoSplit
-subroutines), then that module should not use B<AutoLoader> at all.
-
-=head2 Package Lexicals
-
-Package lexicals declared with C<my> in the main block of a package
-using B<AutoLoader> will not be visible to auto-loaded subroutines, due to
-the fact that the given scope ends at the C<__END__> marker. A module
-using such variables as package globals will not work properly under the
-B<AutoLoader>.
-
-The C<vars> pragma (see L<perlmod/"vars">) may be used in such
-situations as an alternative to explicitly qualifying all globals with
-the package namespace. Variables pre-declared with this pragma will be
-visible to any autoloaded routines (but will not be invisible outside
-the package, unfortunately).
-
-=head2 Not Using AutoLoader
-
-You can stop using AutoLoader by simply
-
- no AutoLoader;
-
-=head2 B<AutoLoader> vs. B<SelfLoader>
-
-The B<AutoLoader> is similar in purpose to B<SelfLoader>: both delay the
-loading of subroutines.
-
-B<SelfLoader> uses the C<__DATA__> marker rather than C<__END__>.
-While this avoids the use of a hierarchy of disk files and the
-associated open/close for each routine loaded, B<SelfLoader> suffers a
-startup speed disadvantage in the one-time parsing of the lines after
-C<__DATA__>, after which routines are cached. B<SelfLoader> can also
-handle multiple packages in a file.
-
-B<AutoLoader> only reads code as it is requested, and in many cases
-should be faster, but requires a mechanism like B<AutoSplit> be used to
-create the individual files. L<ExtUtils::MakeMaker> will invoke
-B<AutoSplit> automatically if B<AutoLoader> is used in a module source
-file.
-
-=head1 CAVEATS
-
-AutoLoaders prior to Perl 5.002 had a slightly different interface. Any
-old modules which use B<AutoLoader> should be changed to the new calling
-style. Typically this just means changing a require to a use, adding
-the explicit C<'AUTOLOAD'> import if needed, and removing B<AutoLoader>
-from C<@ISA>.
-
-On systems with restrictions on file name length, the file corresponding
-to a subroutine may have a shorter name that the routine itself. This
-can lead to conflicting file names. The I<AutoSplit> package warns of
-these potential conflicts when used to split a module.
-
-AutoLoader may fail to find the autosplit files (or even find the wrong
-ones) in cases where C<@INC> contains relative paths, B<and> the program
-does C<chdir>.
-
-=head1 SEE ALSO
-
-L<SelfLoader> - an autoloader that doesn't use external files.
-
-=head1 AUTHOR
-
-C<AutoLoader> is maintained by the perl5-porters. Please direct
-any questions to the canonical mailing list. Anything that
-is applicable to the CPAN release can be sent to its maintainer,
-though.
-
-Author and Maintainer: The Perl5-Porters <perl5-porters at perl.org>
-
-Maintainer of the CPAN release: Steffen Mueller <smueller at cpan.org>
-
-=head1 COPYRIGHT AND LICENSE
-
-This package has been part of the perl core since the first release
-of perl5. It has been released separately to CPAN so older installations
-can benefit from bug fixes.
-
-This package has the same copyright and license as the perl core:
-
- Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
- by Larry Wall and others
-
- All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of either:
-
- a) the GNU General Public License as published by the Free
- Software Foundation; either version 1, or (at your option) any
- later version, or
-
- b) the "Artistic License" which comes with this Kit.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
- the GNU General Public License or the Artistic License for more details.
-
- You should have received a copy of the Artistic License with this
- Kit, in the file named "Artistic". If not, I'll be glad to provide one.
-
- You should also have received a copy of the GNU General Public License
- along with this program in the file named "Copying". If not, write to the
- Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
- 02111-1307, USA or visit their web page on the internet at
- http://www.gnu.org/copyleft/gpl.html.
-
- For those of you that choose to use the GNU General Public License,
- my interpretation of the GNU General Public License is that no Perl
- script falls under the terms of the GPL unless you explicitly put
- said script under the terms of the GPL yourself. Furthermore, any
- object code linked with perl does not automatically fall under the
- terms of the GPL, provided such object code only adds definitions
- of subroutines and variables, and does not otherwise impair the
- resulting interpreter from executing any standard Perl script. I
- consider linking in C subroutines in this manner to be the moral
- equivalent of defining subroutines in the Perl language itself. You
- may sell such an object file as proprietary provided that you provide
- or offer to provide the Perl source, as specified by the GNU General
- Public License. (This is merely an alternate way of specifying input
- to the program.) You may also sell a binary produced by the dumping of
- a running Perl script that belongs to you, provided that you provide or
- offer to provide the Perl source as specified by the GPL. (The
- fact that a Perl interpreter and your code are in the same binary file
- is, in this case, a form of mere aggregation.) This is my interpretation
- of the GPL. If you still have concerns or difficulties understanding
- my intent, feel free to contact me. Of course, the Artistic License
- spells all this out for your protection, so you may prefer to use that.
-
-=cut
Deleted: trunk/contrib/perl/lib/AutoLoader.t
===================================================================
--- trunk/contrib/perl/lib/AutoLoader.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/AutoLoader.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,186 +0,0 @@
-#!./perl -w
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
-use strict;
-use File::Spec;
-use File::Path;
-
-my $dir;
-BEGIN
-{
- $dir = File::Spec->catdir( "auto-$$" );
- unshift @INC, $dir;
-}
-
-use Test::More tests => 22;
-
-# First we must set up some autoloader files
-my $fulldir = File::Spec->catdir( $dir, 'auto', 'Foo' );
-mkpath( $fulldir ) or die "Can't mkdir '$fulldir': $!";
-
-open(FOO, '>', File::Spec->catfile( $fulldir, 'foo.al' ))
- or die "Can't open foo file: $!";
-print FOO <<'EOT';
-package Foo;
-sub foo { shift; shift || "foo" }
-1;
-EOT
-close(FOO);
-
-open(BAR, '>', File::Spec->catfile( $fulldir, 'bar.al' ))
- or die "Can't open bar file: $!";
-print BAR <<'EOT';
-package Foo;
-sub bar { shift; shift || "bar" }
-1;
-EOT
-close(BAR);
-
-open(BAZ, '>', File::Spec->catfile( $fulldir, 'bazmarkhian.al' ))
- or die "Can't open bazmarkhian file: $!";
-print BAZ <<'EOT';
-package Foo;
-sub bazmarkhianish { shift; shift || "baz" }
-1;
-EOT
-close(BAZ);
-
-open(BLECH, '>', File::Spec->catfile( $fulldir, 'blechanawilla.al' ))
- or die "Can't open blech file: $!";
-print BLECH <<'EOT';
-package Foo;
-sub blechanawilla { compilation error (
-EOT
-close(BLECH);
-
-# This is just to keep the old SVR3 systems happy; they may fail
-# to find the above file so we duplicate it where they should find it.
-open(BLECH, '>', File::Spec->catfile( $fulldir, 'blechanawil.al' ))
- or die "Can't open blech file: $!";
-print BLECH <<'EOT';
-package Foo;
-sub blechanawilla { compilation error (
-EOT
-close(BLECH);
-
-# Let's define the package
-package Foo;
-require AutoLoader;
-AutoLoader->import( 'AUTOLOAD' );
-
-sub new { bless {}, shift };
-sub foo;
-sub bazmarkhianish;
-
-package main;
-
-my $foo = Foo->new();
-
-my $result = $foo->can( 'foo' );
-ok( $result, 'can() first time' );
-is( $foo->foo, 'foo', 'autoloaded first time' );
-is( $foo->foo, 'foo', 'regular call' );
-is( $result, \&Foo::foo, 'can() returns ref to regular installed sub' );
-$result = $foo->can( 'bar' );
-ok( $result, 'can() should work when importing AUTOLOAD too' );
-is( $foo->bar, 'bar', 'regular call' );
-is( $result, \&Foo::bar, '... returning ref to regular installed sub' );
-
-eval {
- $foo->will_fail;
-};
-like( $@, qr/^Can't locate/, 'undefined method' );
-
-$result = $foo->can( 'will_fail' );
-ok( ! $result, 'can() should fail on undefined methods' );
-
-# Used to be trouble with this
-eval {
- my $foo = Foo->new();
- die "oops";
-};
-like( $@, qr/oops/, 'indirect method call' );
-
-# Pass regular expression variable to autoloaded function. This used
-# to go wrong because AutoLoader used regular expressions to generate
-# autoloaded filename.
-'foo' =~ /(\w+)/;
-
-is( $foo->bar($1), 'foo', 'autoloaded method should not stomp match vars' );
-is( $foo->bar($1), 'foo', '(again)' );
-is( $foo->bazmarkhianish($1), 'foo', 'for any method call' );
-is( $foo->bazmarkhianish($1), 'foo', '(again)' );
-
-# Used to retry long subnames with shorter filenames on any old
-# exception, including compilation error. Now AutoLoader only
-# tries shorter filenames if it can't find the long one.
-eval {
- $foo->blechanawilla;
-};
-like( $@, qr/syntax error/i, 'require error propagates' );
-
-# test recursive autoloads
-open(F, '>', File::Spec->catfile( $fulldir, 'a.al'))
- or die "Cannot make 'a' file: $!";
-print F <<'EOT';
-package Foo;
-BEGIN { b() }
-sub a { ::ok( 1, 'adding a new autoloaded method' ); }
-1;
-EOT
-close(F);
-
-open(F, '>', File::Spec->catfile( $fulldir, 'b.al'))
- or die "Cannot make 'b' file: $!";
-print F <<'EOT';
-package Foo;
-sub b { ::ok( 1, 'adding a new autoloaded method' ) }
-1;
-EOT
-close(F);
-Foo::a();
-
-package Bar;
-AutoLoader->import();
-::ok( ! defined &AUTOLOAD, 'AutoLoader should not export AUTOLOAD by default' );
-::ok( ! defined &can, '... nor can()' );
-
-package Foo;
-AutoLoader->unimport();
-eval { Foo->baz() };
-::like( $@, qr/locate object method "baz"/,
- 'unimport() should remove imported AUTOLOAD()' );
-
-package Baz;
-
-sub AUTOLOAD { 'i am here' }
-
-AutoLoader->import();
-AutoLoader->unimport();
-
-::is( Baz->AUTOLOAD(), 'i am here', '... but not non-imported AUTOLOAD()' );
-
-
-package SomeClass;
-use AutoLoader 'AUTOLOAD';
-sub new {
- bless {} => shift;
-}
-
-package main;
-
-$INC{"SomeClass.pm"} = $0; # Prepare possible recursion
-{
- my $p = SomeClass->new();
-} # <-- deep recursion in AUTOLOAD looking for SomeClass::DESTROY?
-::ok(1, "AutoLoader shouldn't loop forever if \%INC is modified");
-
-# cleanup
-END {
- return unless $dir && -d $dir;
- rmtree $dir;
-}
Deleted: trunk/contrib/perl/lib/AutoSplit.pm
===================================================================
--- trunk/contrib/perl/lib/AutoSplit.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/AutoSplit.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,592 +0,0 @@
-package AutoSplit;
-
-use Exporter ();
-use Config qw(%Config);
-use File::Basename ();
-use File::Path qw(mkpath);
-use File::Spec::Functions qw(curdir catfile catdir);
-use strict;
-our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen,
- $CheckForAutoloader, $CheckModTime);
-
-$VERSION = "1.06";
- at ISA = qw(Exporter);
- at EXPORT = qw(&autosplit &autosplit_lib_modules);
- at EXPORT_OK = qw($Verbose $Keep $Maxlen $CheckForAutoloader $CheckModTime);
-
-=head1 NAME
-
-AutoSplit - split a package for autoloading
-
-=head1 SYNOPSIS
-
- autosplit($file, $dir, $keep, $check, $modtime);
-
- autosplit_lib_modules(@modules);
-
-=head1 DESCRIPTION
-
-This function will split up your program into files that the AutoLoader
-module can handle. It is used by both the standard perl libraries and by
-the MakeMaker utility, to automatically configure libraries for autoloading.
-
-The C<autosplit> interface splits the specified file into a hierarchy
-rooted at the directory C<$dir>. It creates directories as needed to reflect
-class hierarchy, and creates the file F<autosplit.ix>. This file acts as
-both forward declaration of all package routines, and as timestamp for the
-last update of the hierarchy.
-
-The remaining three arguments to C<autosplit> govern other options to
-the autosplitter.
-
-=over 2
-
-=item $keep
-
-If the third argument, I<$keep>, is false, then any
-pre-existing C<*.al> files in the autoload directory are removed if
-they are no longer part of the module (obsoleted functions).
-$keep defaults to 0.
-
-=item $check
-
-The
-fourth argument, I<$check>, instructs C<autosplit> to check the module
-currently being split to ensure that it includes a C<use>
-specification for the AutoLoader module, and skips the module if
-AutoLoader is not detected.
-$check defaults to 1.
-
-=item $modtime
-
-Lastly, the I<$modtime> argument specifies
-that C<autosplit> is to check the modification time of the module
-against that of the C<autosplit.ix> file, and only split the module if
-it is newer.
-$modtime defaults to 1.
-
-=back
-
-Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
-with:
-
- perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
-
-Defined as a Make macro, it is invoked with file and directory arguments;
-C<autosplit> will split the specified file into the specified directory and
-delete obsolete C<.al> files, after checking first that the module does use
-the AutoLoader, and ensuring that the module is not already currently split
-in its current form (the modtime test).
-
-The C<autosplit_lib_modules> form is used in the building of perl. It takes
-as input a list of files (modules) that are assumed to reside in a directory
-B<lib> relative to the current directory. Each file is sent to the
-autosplitter one at a time, to be split into the directory B<lib/auto>.
-
-In both usages of the autosplitter, only subroutines defined following the
-perl I<__END__> token are split out into separate files. Some
-routines may be placed prior to this marker to force their immediate loading
-and parsing.
-
-=head2 Multiple packages
-
-As of version 1.01 of the AutoSplit module it is possible to have
-multiple packages within a single file. Both of the following cases
-are supported:
-
- package NAME;
- __END__
- sub AAA { ... }
- package NAME::option1;
- sub BBB { ... }
- package NAME::option2;
- sub BBB { ... }
-
- package NAME;
- __END__
- sub AAA { ... }
- sub NAME::option1::BBB { ... }
- sub NAME::option2::BBB { ... }
-
-=head1 DIAGNOSTICS
-
-C<AutoSplit> will inform the user if it is necessary to create the
-top-level directory specified in the invocation. It is preferred that
-the script or installation process that invokes C<AutoSplit> have
-created the full directory path ahead of time. This warning may
-indicate that the module is being split into an incorrect path.
-
-C<AutoSplit> will warn the user of all subroutines whose name causes
-potential file naming conflicts on machines with drastically limited
-(8 characters or less) file name length. Since the subroutine name is
-used as the file name, these warnings can aid in portability to such
-systems.
-
-Warnings are issued and the file skipped if C<AutoSplit> cannot locate
-either the I<__END__> marker or a "package Name;"-style specification.
-
-C<AutoSplit> will also emit general diagnostics for inability to
-create directories or files.
-
-=head1 AUTHOR
-
-C<AutoSplit> is maintained by the perl5-porters. Please direct
-any questions to the canonical mailing list. Anything that
-is applicable to the CPAN release can be sent to its maintainer,
-though.
-
-Author and Maintainer: The Perl5-Porters <perl5-porters at perl.org>
-
-Maintainer of the CPAN release: Steffen Mueller <smueller at cpan.org>
-
-=head1 COPYRIGHT AND LICENSE
-
-This package has been part of the perl core since the first release
-of perl5. It has been released separately to CPAN so older installations
-can benefit from bug fixes.
-
-This package has the same copyright and license as the perl core:
-
- Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
- by Larry Wall and others
-
- All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of either:
-
- a) the GNU General Public License as published by the Free
- Software Foundation; either version 1, or (at your option) any
- later version, or
-
- b) the "Artistic License" which comes with this Kit.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
- the GNU General Public License or the Artistic License for more details.
-
- You should have received a copy of the Artistic License with this
- Kit, in the file named "Artistic". If not, I'll be glad to provide one.
-
- You should also have received a copy of the GNU General Public License
- along with this program in the file named "Copying". If not, write to the
- Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
- 02111-1307, USA or visit their web page on the internet at
- http://www.gnu.org/copyleft/gpl.html.
-
- For those of you that choose to use the GNU General Public License,
- my interpretation of the GNU General Public License is that no Perl
- script falls under the terms of the GPL unless you explicitly put
- said script under the terms of the GPL yourself. Furthermore, any
- object code linked with perl does not automatically fall under the
- terms of the GPL, provided such object code only adds definitions
- of subroutines and variables, and does not otherwise impair the
- resulting interpreter from executing any standard Perl script. I
- consider linking in C subroutines in this manner to be the moral
- equivalent of defining subroutines in the Perl language itself. You
- may sell such an object file as proprietary provided that you provide
- or offer to provide the Perl source, as specified by the GNU General
- Public License. (This is merely an alternate way of specifying input
- to the program.) You may also sell a binary produced by the dumping of
- a running Perl script that belongs to you, provided that you provide or
- offer to provide the Perl source as specified by the GPL. (The
- fact that a Perl interpreter and your code are in the same binary file
- is, in this case, a form of mere aggregation.) This is my interpretation
- of the GPL. If you still have concerns or difficulties understanding
- my intent, feel free to contact me. Of course, the Artistic License
- spells all this out for your protection, so you may prefer to use that.
-
-=cut
-
-# for portability warn about names longer than $maxlen
-$Maxlen = 8; # 8 for dos, 11 (14-".al") for SYSVR3
-$Verbose = 1; # 0=none, 1=minimal, 2=list .al files
-$Keep = 0;
-$CheckForAutoloader = 1;
-$CheckModTime = 1;
-
-my $IndexFile = "autosplit.ix"; # file also serves as timestamp
-my $maxflen = 255;
-$maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
-if (defined (&Dos::UseLFN)) {
- $maxflen = Dos::UseLFN() ? 255 : 11;
-}
-my $Is_VMS = ($^O eq 'VMS');
-
-# allow checking for valid ': attrlist' attachments.
-# extra jugglery required to support both 5.8 and 5.9/5.10 features
-# (support for 5.8 required for cross-compiling environments)
-
-my $attr_list =
- $] >= 5.009005 ?
- eval <<'__QR__'
- qr{
- \s* : \s*
- (?:
- # one attribute
- (?> # no backtrack
- (?! \d) \w+
- (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
- )
- (?: \s* : \s* | \s+ (?! :) )
- )*
- }x
-__QR__
- :
- do {
- # In pre-5.9.5 world we have to do dirty tricks.
- # (we use 'our' rather than 'my' here, due to the rather complex and buggy
- # behaviour of lexicals with qr// and (??{$lex}) )
- our $trick1; # yes, cannot our and assign at the same time.
- $trick1 = qr{ \( (?: (?> [^()]+ ) | (??{ $trick1 }) )* \) }x;
- our $trick2 = qr{ (?> (?! \d) \w+ (?:$trick1)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
- qr{ \s* : \s* (?: $trick2 )* }x;
- };
-
-sub autosplit{
- my($file, $autodir, $keep, $ckal, $ckmt) = @_;
- # $file - the perl source file to be split (after __END__)
- # $autodir - the ".../auto" dir below which to write split subs
- # Handle optional flags:
- $keep = $Keep unless defined $keep;
- $ckal = $CheckForAutoloader unless defined $ckal;
- $ckmt = $CheckModTime unless defined $ckmt;
- autosplit_file($file, $autodir, $keep, $ckal, $ckmt);
-}
-
-sub carp{
- require Carp;
- goto &Carp::carp;
-}
-
-# This function is used during perl building/installation
-# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
-
-sub autosplit_lib_modules {
- my(@modules) = @_; # list of Module names
- local $_; # Avoid clobber.
- while (defined($_ = shift @modules)) {
- while (m#([^:]+)::([^:].*)#) { # in case specified as ABC::XYZ
- $_ = catfile($1, $2);
- }
- s|\\|/|g; # bug in ksh OS/2
- s#^lib/##s; # incase specified as lib/*.pm
- my($lib) = catfile(curdir(), "lib");
- if ($Is_VMS) { # may need to convert VMS-style filespecs
- $lib =~ s#^\[\]#.\/#;
- }
- s#^$lib\W+##s; # incase specified as ./lib/*.pm
- if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs
- my ($dir,$name) = (/(.*])(.*)/s);
- $dir =~ s/.*lib[\.\]]//s;
- $dir =~ s#[\.\]]#/#g;
- $_ = $dir . $name;
- }
- autosplit_file(catfile($lib, $_), catfile($lib, "auto"),
- $Keep, $CheckForAutoloader, $CheckModTime);
- }
- 0;
-}
-
-
-# private functions
-
-my $self_mod_time = (stat __FILE__)[9];
-
-sub autosplit_file {
- my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time)
- = @_;
- my(@outfiles);
- local($_);
- local($/) = "\n";
-
- # where to write output files
- $autodir ||= catfile(curdir(), "lib", "auto");
- if ($Is_VMS) {
- ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||;
- $filename = VMS::Filespec::unixify($filename); # may have dirs
- }
- unless (-d $autodir){
- mkpath($autodir,0,0755);
- # We should never need to create the auto dir
- # here. installperl (or similar) should have done
- # it. Expecting it to exist is a valuable sanity check against
- # autosplitting into some random directory by mistake.
- print "Warning: AutoSplit had to create top-level " .
- "$autodir unexpectedly.\n";
- }
-
- # allow just a package name to be used
- $filename .= ".pm" unless ($filename =~ m/\.pm\z/);
-
- open(my $in, "<$filename") or die "AutoSplit: Can't open $filename: $!\n";
- my($pm_mod_time) = (stat($filename))[9];
- my($autoloader_seen) = 0;
- my($in_pod) = 0;
- my($def_package,$last_package,$this_package,$fnr);
- while (<$in>) {
- # Skip pod text.
- $fnr++;
- $in_pod = 1 if /^=\w/;
- $in_pod = 0 if /^=cut/;
- next if ($in_pod || /^=cut/);
- next if /^\s*#/;
-
- # record last package name seen
- $def_package = $1 if (m/^\s*package\s+([\w:]+)\s*;/);
- ++$autoloader_seen if m/^\s*(use|require)\s+AutoLoader\b/;
- ++$autoloader_seen if m/\bISA\s*=.*\bAutoLoader\b/;
- last if /^__END__/;
- }
- if ($check_for_autoloader && !$autoloader_seen){
- print "AutoSplit skipped $filename: no AutoLoader used\n"
- if ($Verbose>=2);
- return 0;
- }
- $_ or die "Can't find __END__ in $filename\n";
-
- $def_package or die "Can't find 'package Name;' in $filename\n";
-
- my($modpname) = _modpname($def_package);
-
- # this _has_ to match so we have a reasonable timestamp file
- die "Package $def_package ($modpname.pm) does not ".
- "match filename $filename"
- unless ($filename =~ m/\Q$modpname.pm\E$/ or
- ($^O eq 'dos') or ($^O eq 'MSWin32') or ($^O eq 'NetWare') or
- $Is_VMS && $filename =~ m/$modpname.pm/i);
-
- my($al_idx_file) = catfile($autodir, $modpname, $IndexFile);
-
- if ($check_mod_time){
- my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
- if ($al_ts_time >= $pm_mod_time and
- $al_ts_time >= $self_mod_time){
- print "AutoSplit skipped ($al_idx_file newer than $filename)\n"
- if ($Verbose >= 2);
- return undef; # one undef, not a list
- }
- }
-
- my($modnamedir) = catdir($autodir, $modpname);
- print "AutoSplitting $filename ($modnamedir)\n"
- if $Verbose;
-
- unless (-d $modnamedir){
- mkpath($modnamedir,0,0777);
- }
-
- # We must try to deal with some SVR3 systems with a limit of 14
- # characters for file names. Sadly we *cannot* simply truncate all
- # file names to 14 characters on these systems because we *must*
- # create filenames which exactly match the names used by AutoLoader.pm.
- # This is a problem because some systems silently truncate the file
- # names while others treat long file names as an error.
-
- my $Is83 = $maxflen==11; # plain, case INSENSITIVE dos filenames
-
- my(@subnames, $subname, %proto, %package);
- my @cache = ();
- my $caching = 1;
- $last_package = '';
- my $out;
- while (<$in>) {
- $fnr++;
- $in_pod = 1 if /^=\w/;
- $in_pod = 0 if /^=cut/;
- next if ($in_pod || /^=cut/);
- # the following (tempting) old coding gives big troubles if a
- # cut is forgotten at EOF:
- # next if /^=\w/ .. /^=cut/;
- if (/^package\s+([\w:]+)\s*;/) {
- $this_package = $def_package = $1;
- }
-
- if (/^sub\s+([\w:]+)(\s*(?:\(.*?\))?(?:$attr_list)?)/) {
- print $out "# end of $last_package\::$subname\n1;\n"
- if $last_package;
- $subname = $1;
- my $proto = $2 || '';
- if ($subname =~ s/(.*):://){
- $this_package = $1;
- } else {
- $this_package = $def_package;
- }
- my $fq_subname = "$this_package\::$subname";
- $package{$fq_subname} = $this_package;
- $proto{$fq_subname} = $proto;
- push(@subnames, $fq_subname);
- my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
- $modpname = _modpname($this_package);
- my($modnamedir) = catdir($autodir, $modpname);
- mkpath($modnamedir,0,0777);
- my($lpath) = catfile($modnamedir, "$lname.al");
- my($spath) = catfile($modnamedir, "$sname.al");
- my $path;
-
- if (!$Is83 and open($out, ">$lpath")){
- $path=$lpath;
- print " writing $lpath\n" if ($Verbose>=2);
- } else {
- open($out, ">$spath") or die "Can't create $spath: $!\n";
- $path=$spath;
- print " writing $spath (with truncated name)\n"
- if ($Verbose>=1);
- }
- push(@outfiles, $path);
- my $lineno = $fnr - @cache;
- print $out <<EOT;
-# NOTE: Derived from $filename.
-# Changes made here will be lost when autosplit is run again.
-# See AutoSplit.pm.
-package $this_package;
-
-#line $lineno "$filename (autosplit into $path)"
-EOT
- print $out @cache;
- @cache = ();
- $caching = 0;
- }
- if($caching) {
- push(@cache, $_) if @cache || /\S/;
- } else {
- print $out $_;
- }
- if(/^\}/) {
- if($caching) {
- print $out @cache;
- @cache = ();
- }
- print $out "\n";
- $caching = 1;
- }
- $last_package = $this_package if defined $this_package;
- }
- if ($subname) {
- print $out @cache,"1;\n# end of $last_package\::$subname\n";
- close($out);
- }
- close($in);
-
- if (!$keep){ # don't keep any obsolete *.al files in the directory
- my(%outfiles);
- # @outfiles{@outfiles} = @outfiles;
- # perl downcases all filenames on VMS (which upcases all filenames) so
- # we'd better downcase the sub name list too, or subs with upper case
- # letters in them will get their .al files deleted right after they're
- # created. (The mixed case sub name won't match the all-lowercase
- # filename, and so be cleaned up as a scrap file)
- if ($Is_VMS or $Is83) {
- %outfiles = map {lc($_) => lc($_) } @outfiles;
- } else {
- @outfiles{@outfiles} = @outfiles;
- }
- my(%outdirs, at outdirs);
- for (@outfiles) {
- $outdirs{File::Basename::dirname($_)}||=1;
- }
- for my $dir (keys %outdirs) {
- opendir(my $outdir,$dir);
- foreach (sort readdir($outdir)){
- next unless /\.al\z/;
- my($file) = catfile($dir, $_);
- $file = lc $file if $Is83 or $Is_VMS;
- next if $outfiles{$file};
- print " deleting $file\n" if ($Verbose>=2);
- my($deleted,$thistime); # catch all versions on VMS
- do { $deleted += ($thistime = unlink $file) } while ($thistime);
- carp ("Unable to delete $file: $!") unless $deleted;
- }
- closedir($outdir);
- }
- }
-
- open(my $ts,">$al_idx_file") or
- carp ("AutoSplit: unable to create timestamp file ($al_idx_file): $!");
- print $ts "# Index created by AutoSplit for $filename\n";
- print $ts "# (file acts as timestamp)\n";
- $last_package = '';
- for my $fqs (@subnames) {
- my($subname) = $fqs;
- $subname =~ s/.*:://;
- print $ts "package $package{$fqs};\n"
- unless $last_package eq $package{$fqs};
- print $ts "sub $subname $proto{$fqs};\n";
- $last_package = $package{$fqs};
- }
- print $ts "1;\n";
- close($ts);
-
- _check_unique($filename, $Maxlen, 1, @outfiles);
-
- @outfiles;
-}
-
-sub _modpname ($) {
- my($package) = @_;
- my $modpname = $package;
- if ($^O eq 'MSWin32') {
- $modpname =~ s#::#\\#g;
- } else {
- my @modpnames = ();
- while ($modpname =~ m#(.*?[^:])::([^:].*)#) {
- push @modpnames, $1;
- $modpname = $2;
- }
- $modpname = catfile(@modpnames, $modpname);
- }
- if ($Is_VMS) {
- $modpname = VMS::Filespec::unixify($modpname); # may have dirs
- }
- $modpname;
-}
-
-sub _check_unique {
- my($filename, $maxlen, $warn, @outfiles) = @_;
- my(%notuniq) = ();
- my(%shorts) = ();
- my(@toolong) = grep(
- length(File::Basename::basename($_))
- > $maxlen,
- @outfiles
- );
-
- foreach (@toolong){
- my($dir) = File::Basename::dirname($_);
- my($file) = File::Basename::basename($_);
- my($trunc) = substr($file,0,$maxlen);
- $notuniq{$dir}{$trunc} = 1 if $shorts{$dir}{$trunc};
- $shorts{$dir}{$trunc} = $shorts{$dir}{$trunc} ?
- "$shorts{$dir}{$trunc}, $file" : $file;
- }
- if (%notuniq && $warn){
- print "$filename: some names are not unique when " .
- "truncated to $maxlen characters:\n";
- foreach my $dir (sort keys %notuniq){
- print " directory $dir:\n";
- foreach my $trunc (sort keys %{$notuniq{$dir}}) {
- print " $shorts{$dir}{$trunc} truncate to $trunc\n";
- }
- }
- }
-}
-
-1;
-__END__
-
-# test functions so AutoSplit.pm can be applied to itself:
-sub test1 ($) { "test 1\n"; }
-sub test2 ($$) { "test 2\n"; }
-sub test3 ($$$) { "test 3\n"; }
-sub testtesttesttest4_1 { "test 4\n"; }
-sub testtesttesttest4_2 { "duplicate test 4\n"; }
-sub Just::Another::test5 { "another test 5\n"; }
-sub test6 { return join ":", __FILE__,__LINE__; }
-package Yet::Another::AutoSplit;
-sub testtesttesttest4_1 ($) { "another test 4\n"; }
-sub testtesttesttest4_2 ($$) { "another duplicate test 4\n"; }
-package Yet::More::Attributes;
-sub test_a1 ($) : locked :locked { 1; }
-sub test_a2 : locked { 1; }
Deleted: trunk/contrib/perl/lib/AutoSplit.t
===================================================================
--- trunk/contrib/perl/lib/AutoSplit.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/AutoSplit.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,419 +0,0 @@
-#!./perl -w
-
-# AutoLoader.t runs before this test, so it seems safe to assume that it will
-# work.
-
-my($incdir, $lib);
-BEGIN {
- chdir 't' if -d 't';
- if ($^O eq 'dos') {
- print "1..0 # This test is not 8.3-aware.\n";
- exit 0;
- }
- if ($^O eq 'MacOS') {
- $incdir = ":auto-$$";
- $lib = '-I::lib:';
- } else {
- $incdir = "auto-$$";
- $lib = '"-I../lib"'; # ok on unix, nt, The extra \" are for VMS
- }
- @INC = $incdir;
- push @INC, '../lib';
-}
-my $runperl = "$^X $lib";
-
-use warnings;
-use strict;
-use Test::More tests => 58;
-use File::Spec;
-use File::Find;
-
-require AutoSplit; # Run time. Check it compiles.
-ok (1, "AutoSplit loaded");
-
-END {
- use File::Path;
- print "# $incdir being removed...\n";
- rmtree($incdir);
-}
-
-mkdir $incdir,0755;
-
-my @tests;
-{
- # local this else it buggers up the chomp() below.
- # Hmm. Would be nice to have this as a regexp.
- local $/
- = "################################################################\n";
- @tests = <DATA>;
- close DATA;
-}
-
-my $pathsep = $^O eq 'MSWin32' ? '\\' : $^O eq 'MacOS' ? ':' : '/';
-my $endpathsep = $^O eq 'MacOS' ? ':' : '';
-
-sub split_a_file {
- my $contents = shift;
- my $file = $_[0];
- if (defined $contents) {
- open FILE, ">$file" or die "Can't open $file: $!";
- print FILE $contents;
- close FILE or die "Can't close $file: $!";
- }
-
- # Assumption: no characters in arguments need escaping from the shell or perl
- my $com = qq($runperl -e "use AutoSplit; autosplit (qw(@_))");
- print "# command: $com\n";
- # There may be a way to capture STDOUT without spawning a child process, but
- # it's probably worthwhile spawning, as it ensures that nothing in AutoSplit
- # can load functions from split modules into this perl.
- my $output = `$com`;
- warn "Exit status $? from running: >>$com<<" if $?;
- return $output;
-}
-
-my $i = 0;
-my $dir = File::Spec->catdir($incdir, 'auto');
-if ($^O eq 'VMS') {
- $dir = VMS::Filespec::unixify($dir);
- $dir =~ s/\/$//;
-} elsif ($^O eq 'MacOS') {
- $dir =~ s/:$//;
-}
-
-foreach (@tests) {
- my $module = 'A' . $i . '_' . $$ . 'splittest';
- my $file = File::Spec->catfile($incdir,"$module.pm");
- s/\*INC\*/$incdir/gm;
- s/\*DIR\*/$dir/gm;
- s/\*MOD\*/$module/gm;
- s/\*PATHSEP\*/$pathsep/gm;
- s/\*ENDPATHSEP\*/$endpathsep/gm;
- s#//#/#gm;
- # Build a hash for this test.
- my %args = /^\#\#\ ([^\n]*)\n # Key is on a line starting ##
- ((?:[^\#]+ # Any number of characters not #
- | \#(?!\#) # or a # character not followed by #
- | (?<!\n)\# # or a # character not preceded by \n
- )*)/sgmx;
- foreach ($args{Name}, $args{Require}, $args{Extra}) {
- chomp $_ if defined $_;
- }
- $args{Get} ||= '';
-
- my @extra_args = !defined $args{Extra} ? () : split /,/, $args{Extra};
- my ($output, $body);
- if ($args{File}) {
- $body ="package $module;\n" . $args{File};
- $output = split_a_file ($body, $file, $dir, @extra_args);
- } else {
- # Repeat tests
- $output = split_a_file (undef, $file, $dir, @extra_args);
- }
-
- if ($^O eq 'VMS') {
- my ($filespec, $replacement);
- while ($output =~ m/(\[.+\])/) {
- $filespec = $1;
- $replacement = VMS::Filespec::unixify($filespec);
- $replacement =~ s/\/$//;
- $output =~ s/\Q$filespec\E/$replacement/;
- }
- }
-
- # test n+1
- is($output, $args{Get}, "Output from autosplit()ing $args{Name}");
-
- if ($args{Files}) {
- $args{Files} =~ s!/!:!gs if $^O eq 'MacOS';
- my (%missing, %got);
- find (sub {$got{$File::Find::name}++ unless -d $_}, $dir);
- foreach (split /\n/, $args{Files}) {
- next if /^#/;
- $_ = lc($_) if $^O eq 'VMS';
- unless (delete $got{$_}) {
- $missing{$_}++;
- }
- }
- my @missing = keys %missing;
- # test n+2
- unless (ok (!@missing, "Are any expected files missing?")) {
- print "# These files are missing\n";
- print "# $_\n" foreach sort @missing;
- }
- my @extra = keys %got;
- # test n+3
- unless (ok (!@extra, "Are any extra files present?")) {
- print "# These files are unexpectedly present:\n";
- print "# $_\n" foreach sort @extra;
- }
- }
- if ($args{Require}) {
- $args{Require} =~ s|/|:|gm if $^O eq 'MacOS';
- my $com = 'require "' . File::Spec->catfile ('auto', $args{Require}) . '"';
- $com =~ s{\\}{/}gm if ($^O eq 'MSWin32');
- eval $com;
- # test n+3
- ok ($@ eq '', $com) or print "# \$\@ = '$@'\n";
- if (defined $body) {
- eval $body or die $@;
- }
- }
- # match tests to check for prototypes
- if ($args{Match}) {
- local $/;
- my $file = File::Spec->catfile($dir, $args{Require});
- open IX, $file or die "Can't open '$file': $!";
- my $ix = <IX>;
- close IX or die "Can't close '$file': $!";
- foreach my $pat (split /\n/, $args{Match}) {
- next if $pat =~ /^\#/;
- like ($ix, qr/^\s*$pat\s*$/m, "match $pat");
- }
- }
- # code tests contain eval{}ed ok()s etc
- if ($args{Tests}) {
- foreach my $code (split /\n/, $args{Tests}) {
- next if $code =~ /^\#/;
- defined eval $code or fail(), print "# Code: $code\n# Error: $@";
- }
- }
- if (my $sleepfor = $args{Sleep}) {
- # We need to sleep for a while
- # Need the sleep hack else the next test is so fast that the timestamp
- # compare routine in AutoSplit thinks that it shouldn't split the files.
- my $time = time;
- my $until = $time + $sleepfor;
- my $attempts = 3;
- do {
- sleep ($sleepfor)
- } while (time < $until && --$attempts > 0);
- if ($attempts == 0) {
- printf << "EOM", time;
-# Attempted to sleep for $sleepfor second(s), started at $time, now %d.
-# sleep attempt ppears to have failed; some tests may fail as a result.
-EOM
- }
- }
- unless ($args{SameAgain}) {
- $i++;
- rmtree($dir);
- mkdir $dir, 0775;
- }
-}
-
-__DATA__
-## Name
-tests from the end of the AutoSplit module.
-## File
-use AutoLoader 'AUTOLOAD';
-{package Just::Another;
- use AutoLoader 'AUTOLOAD';
-}
- at Yet::Another::AutoSplit::ISA = 'AutoLoader';
-1;
-__END__
-sub test1 ($) { "test 1"; }
-sub test2 ($$) { "test 2"; }
-sub test3 ($$$) { "test 3"; }
-sub testtesttesttest4_1 { "test 4"; }
-sub testtesttesttest4_2 { "duplicate test 4"; }
-sub Just::Another::test5 { "another test 5"; }
-sub test6 { return join ":", __FILE__,__LINE__; }
-package Yet::Another::AutoSplit;
-sub testtesttesttest4_1 ($) { "another test 4"; }
-sub testtesttesttest4_2 ($$) { "another duplicate test 4"; }
-package Yet::More::Attributes;
-sub test_a1 ($) : locked :locked { 1; }
-sub test_a2 : locked { 1; }
-# And that was all it has. You were expected to manually inspect the output
-## Get
-Warning: AutoSplit had to create top-level *DIR* unexpectedly.
-AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
-*INC**PATHSEP**MOD*.pm: some names are not unique when truncated to 8 characters:
- directory *DIR**PATHSEP**MOD**ENDPATHSEP*:
- testtesttesttest4_1.al, testtesttesttest4_2.al truncate to testtest
- directory *DIR**PATHSEP*Yet*PATHSEP*Another*PATHSEP*AutoSplit*ENDPATHSEP*:
- testtesttesttest4_1.al, testtesttesttest4_2.al truncate to testtest
-## Files
-*DIR*/*MOD*/autosplit.ix
-*DIR*/*MOD*/test1.al
-*DIR*/*MOD*/test2.al
-*DIR*/*MOD*/test3.al
-*DIR*/*MOD*/testtesttesttest4_1.al
-*DIR*/*MOD*/testtesttesttest4_2.al
-*DIR*/Just/Another/test5.al
-*DIR*/*MOD*/test6.al
-*DIR*/Yet/Another/AutoSplit/testtesttesttest4_1.al
-*DIR*/Yet/Another/AutoSplit/testtesttesttest4_2.al
-*DIR*/Yet/More/Attributes/test_a1.al
-*DIR*/Yet/More/Attributes/test_a2.al
-## Require
-*MOD*/autosplit.ix
-## Match
-# Need to find these lines somewhere in the required file
-sub test1\s*\(\$\);
-sub test2\s*\(\$\$\);
-sub test3\s*\(\$\$\$\);
-sub testtesttesttest4_1\s*\(\$\);
-sub testtesttesttest4_2\s*\(\$\$\);
-sub test_a1\s*\(\$\)\s*:\s*locked\s*:\s*locked\s*;
-sub test_a2\s*:\s*locked\s*;
-## Tests
-is (*MOD*::test1 (1), 'test 1');
-is (*MOD*::test2 (1,2), 'test 2');
-is (*MOD*::test3 (1,2,3), 'test 3');
-ok (!defined eval "*MOD*::test1 () eq 'test 1'" and $@ =~ /^Not enough arguments for *MOD*::test1/, "Check prototypes mismatch fails") or print "# \$\@='$@'";
-is (&*MOD*::testtesttesttest4_1, "test 4");
-is (&*MOD*::testtesttesttest4_2, "duplicate test 4");
-is (&Just::Another::test5, "another test 5");
-# very messy way to interpolate function into regexp, but it's going to be
-# needed to get : for Mac filespecs
-like (&*MOD*::test6, qr!^\Q*INC**PATHSEP**MOD*\E\.pm \(autosplit into \Q@{[File::Spec->catfile('*DIR*','*MOD*', 'test6.al')]}\E\):\d+$!);
-ok (Yet::Another::AutoSplit->testtesttesttest4_1 eq "another test 4");
-################################################################
-## Name
-missing use AutoLoader;
-## File
-1;
-__END__
-## Get
-## Files
-# There should be no files.
-################################################################
-## Name
-missing use AutoLoader; (but don't skip)
-## Extra
-0, 0
-## File
-1;
-__END__
-## Get
-AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
-## Require
-*MOD*/autosplit.ix
-## Files
-*DIR*/*MOD*/autosplit.ix
-################################################################
-## Name
-Split prior to checking whether obsolete files get deleted
-## File
-use AutoLoader 'AUTOLOAD';
-1;
-__END__
-sub obsolete {our $hidden_a; return $hidden_a++;}
-sub gonner {warn "This gonner function should never get called"}
-## Get
-AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
-## Require
-*MOD*/autosplit.ix
-## Files
-*DIR*/*MOD*/autosplit.ix
-*DIR*/*MOD*/gonner.al
-*DIR*/*MOD*/obsolete.al
-## Tests
-is (&*MOD*::obsolete, 0);
-is (&*MOD*::obsolete, 1);
-## Sleep
-4
-## SameAgain
-True, so don't scrub this directory.
-IIRC DOS FAT filesystems have only 2 second granularity.
-################################################################
-## Name
-Check whether obsolete files get deleted
-## File
-use AutoLoader 'AUTOLOAD';
-1;
-__END__
-sub skeleton {"bones"};
-sub ghost {"scream"}; # This definition gets overwritten with the one below
-sub ghoul {"wail"};
-sub zombie {"You didn't use fire."};
-sub flying_pig {"Oink oink flap flap"};
-## Get
-AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
-## Require
-*MOD*/autosplit.ix
-## Files
-*DIR*/*MOD*/autosplit.ix
-*DIR*/*MOD*/skeleton.al
-*DIR*/*MOD*/zombie.al
-*DIR*/*MOD*/ghost.al
-*DIR*/*MOD*/ghoul.al
-*DIR*/*MOD*/flying_pig.al
-## Tests
-is (&*MOD*::skeleton, "bones", "skeleton");
-eval {&*MOD*::gonner}; ok ($@ =~ m!^Can't locate auto/*MOD*/gonner.al in \@INC!, "Check &*MOD*::gonner is now a gonner") or print "# \$\@='$@'\n";
-## Sleep
-4
-## SameAgain
-True, so don't scrub this directory.
-################################################################
-## Name
-Check whether obsolete files remain when keep is 1
-## Extra
-1, 1
-## File
-use AutoLoader 'AUTOLOAD';
-1;
-__END__
-sub ghost {"bump"};
-sub wraith {9};
-## Get
-AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
-## Require
-*MOD*/autosplit.ix
-## Files
-*DIR*/*MOD*/autosplit.ix
-*DIR*/*MOD*/skeleton.al
-*DIR*/*MOD*/zombie.al
-*DIR*/*MOD*/ghost.al
-*DIR*/*MOD*/ghoul.al
-*DIR*/*MOD*/wraith.al
-*DIR*/*MOD*/flying_pig.al
-## Tests
-is (&*MOD*::ghost, "bump");
-is (&*MOD*::zombie, "You didn't use fire.", "Are our zombies undead?");
-## Sleep
-4
-## SameAgain
-True, so don't scrub this directory.
-################################################################
-## Name
-Without the timestamp check make sure that nothing happens
-## Extra
-0, 1, 1
-## Require
-*MOD*/autosplit.ix
-## Files
-*DIR*/*MOD*/autosplit.ix
-*DIR*/*MOD*/skeleton.al
-*DIR*/*MOD*/zombie.al
-*DIR*/*MOD*/ghost.al
-*DIR*/*MOD*/ghoul.al
-*DIR*/*MOD*/wraith.al
-*DIR*/*MOD*/flying_pig.al
-## Tests
-is (&*MOD*::ghoul, "wail", "still haunted");
-is (&*MOD*::zombie, "You didn't use fire.", "Are our zombies still undead?");
-## Sleep
-4
-## SameAgain
-True, so don't scrub this directory.
-################################################################
-## Name
-With the timestamp check make sure that things happen (stuff gets deleted)
-## Extra
-0, 1, 0
-## Get
-AutoSplitting *INC**PATHSEP**MOD*.pm (*DIR**PATHSEP**MOD**ENDPATHSEP*)
-## Require
-*MOD*/autosplit.ix
-## Files
-*DIR*/*MOD*/autosplit.ix
-*DIR*/*MOD*/ghost.al
-*DIR*/*MOD*/wraith.al
-## Tests
-is (&*MOD*::wraith, 9);
-eval {&*MOD*::flying_pig}; ok ($@ =~ m!^Can't locate auto/*MOD*/flying_pig.al in \@INC!, "There are no flying pigs") or print "# \$\@='$@'\n";
Deleted: trunk/contrib/perl/lib/CGI.pm
===================================================================
--- trunk/contrib/perl/lib/CGI.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/CGI.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,7885 +0,0 @@
-package CGI;
-require 5.004;
-use Carp 'croak';
-
-# See the bottom of this file for the POD documentation. Search for the
-# string '=head'.
-
-# You can run this file through either pod2man or pod2html to produce pretty
-# documentation in manual or html file format (these utilities are part of the
-# Perl 5 distribution).
-
-# Copyright 1995-1998 Lincoln D. Stein. All rights reserved.
-# It may be used and modified freely, but I do request that this copyright
-# notice remain attached to the file. You may modify this module as you
-# wish, but if you redistribute a modified version, please attach a note
-# listing the modifications you have made.
-
-# The most recent version and complete docs are available at:
-# http://stein.cshl.org/WWW/software/CGI/
-
-$CGI::revision = '$Id: CGI.pm,v 1.1.1.2 2011-02-17 12:49:38 laffer1 Exp $';
-$CGI::VERSION='3.43';
-
-# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
-# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
-# $CGITempFile::TMPDIRECTORY = '/usr/tmp';
-use CGI::Util qw(rearrange rearrange_header make_attributes unescape escape expires ebcdic2ascii ascii2ebcdic);
-
-#use constant XHTML_DTD => ['-//W3C//DTD XHTML Basic 1.0//EN',
-# 'http://www.w3.org/TR/xhtml-basic/xhtml-basic10.dtd'];
-
-use constant XHTML_DTD => ['-//W3C//DTD XHTML 1.0 Transitional//EN',
- 'http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd'];
-
-{
- local $^W = 0;
- $TAINTED = substr("$0$^X",0,0);
-}
-
-$MOD_PERL = 0; # no mod_perl by default
-
-#global settings
-$POST_MAX = -1; # no limit to uploaded files
-$DISABLE_UPLOADS = 0;
-
- at SAVED_SYMBOLS = ();
-
-
-# >>>>> Here are some globals that you might want to adjust <<<<<<
-sub initialize_globals {
- # Set this to 1 to enable copious autoloader debugging messages
- $AUTOLOAD_DEBUG = 0;
-
- # Set this to 1 to generate XTML-compatible output
- $XHTML = 1;
-
- # Change this to the preferred DTD to print in start_html()
- # or use default_dtd('text of DTD to use');
- $DEFAULT_DTD = [ '-//W3C//DTD HTML 4.01 Transitional//EN',
- 'http://www.w3.org/TR/html4/loose.dtd' ] ;
-
- # Set this to 1 to enable NOSTICKY scripts
- # or:
- # 1) use CGI qw(-nosticky)
- # 2) $CGI::nosticky(1)
- $NOSTICKY = 0;
-
- # Set this to 1 to enable NPH scripts
- # or:
- # 1) use CGI qw(-nph)
- # 2) CGI::nph(1)
- # 3) print header(-nph=>1)
- $NPH = 0;
-
- # Set this to 1 to enable debugging from @ARGV
- # Set to 2 to enable debugging from STDIN
- $DEBUG = 1;
-
- # Set this to 1 to make the temporary files created
- # during file uploads safe from prying eyes
- # or do...
- # 1) use CGI qw(:private_tempfiles)
- # 2) CGI::private_tempfiles(1);
- $PRIVATE_TEMPFILES = 0;
-
- # Set this to 1 to generate automatic tab indexes
- $TABINDEX = 0;
-
- # Set this to 1 to cause files uploaded in multipart documents
- # to be closed, instead of caching the file handle
- # or:
- # 1) use CGI qw(:close_upload_files)
- # 2) $CGI::close_upload_files(1);
- # Uploads with many files run out of file handles.
- # Also, for performance, since the file is already on disk,
- # it can just be renamed, instead of read and written.
- $CLOSE_UPLOAD_FILES = 0;
-
- # Automatically determined -- don't change
- $EBCDIC = 0;
-
- # Change this to 1 to suppress redundant HTTP headers
- $HEADERS_ONCE = 0;
-
- # separate the name=value pairs by semicolons rather than ampersands
- $USE_PARAM_SEMICOLONS = 1;
-
- # Do not include undefined params parsed from query string
- # use CGI qw(-no_undef_params);
- $NO_UNDEF_PARAMS = 0;
-
- # return everything as utf-8
- $PARAM_UTF8 = 0;
-
- # Other globals that you shouldn't worry about.
- undef $Q;
- $BEEN_THERE = 0;
- $DTD_PUBLIC_IDENTIFIER = "";
- undef @QUERY_PARAM;
- undef %EXPORT;
- undef $QUERY_CHARSET;
- undef %QUERY_FIELDNAMES;
- undef %QUERY_TMPFILES;
-
- # prevent complaints by mod_perl
- 1;
-}
-
-# ------------------ START OF THE LIBRARY ------------
-
-*end_form = \&endform;
-
-# make mod_perlhappy
-initialize_globals();
-
-# FIGURE OUT THE OS WE'RE RUNNING UNDER
-# Some systems support the $^O variable. If not
-# available then require() the Config library
-unless ($OS) {
- unless ($OS = $^O) {
- require Config;
- $OS = $Config::Config{'osname'};
- }
-}
-if ($OS =~ /^MSWin/i) {
- $OS = 'WINDOWS';
-} elsif ($OS =~ /^VMS/i) {
- $OS = 'VMS';
-} elsif ($OS =~ /^dos/i) {
- $OS = 'DOS';
-} elsif ($OS =~ /^MacOS/i) {
- $OS = 'MACINTOSH';
-} elsif ($OS =~ /^os2/i) {
- $OS = 'OS2';
-} elsif ($OS =~ /^epoc/i) {
- $OS = 'EPOC';
-} elsif ($OS =~ /^cygwin/i) {
- $OS = 'CYGWIN';
-} else {
- $OS = 'UNIX';
-}
-
-# Some OS logic. Binary mode enabled on DOS, NT and VMS
-$needs_binmode = $OS=~/^(WINDOWS|DOS|OS2|MSWin|CYGWIN)/;
-
-# This is the default class for the CGI object to use when all else fails.
-$DefaultClass = 'CGI' unless defined $CGI::DefaultClass;
-
-# This is where to look for autoloaded routines.
-$AutoloadClass = $DefaultClass unless defined $CGI::AutoloadClass;
-
-# The path separator is a slash, backslash or semicolon, depending
-# on the paltform.
-$SL = {
- UNIX => '/', OS2 => '\\', EPOC => '/', CYGWIN => '/',
- WINDOWS => '\\', DOS => '\\', MACINTOSH => ':', VMS => '/'
- }->{$OS};
-
-# This no longer seems to be necessary
-# Turn on NPH scripts by default when running under IIS server!
-# $NPH++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
-$IIS++ if defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/;
-
-# Turn on special checking for Doug MacEachern's modperl
-if (exists $ENV{MOD_PERL}) {
- # mod_perl handlers may run system() on scripts using CGI.pm;
- # Make sure so we don't get fooled by inherited $ENV{MOD_PERL}
- if (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2) {
- $MOD_PERL = 2;
- require Apache2::Response;
- require Apache2::RequestRec;
- require Apache2::RequestUtil;
- require Apache2::RequestIO;
- require APR::Pool;
- } else {
- $MOD_PERL = 1;
- require Apache;
- }
-}
-
-# Turn on special checking for ActiveState's PerlEx
-$PERLEX++ if defined($ENV{'GATEWAY_INTERFACE'}) && $ENV{'GATEWAY_INTERFACE'} =~ /^CGI-PerlEx/;
-
-# Define the CRLF sequence. I can't use a simple "\r\n" because the meaning
-# of "\n" is different on different OS's (sometimes it generates CRLF, sometimes LF
-# and sometimes CR). The most popular VMS web server
-# doesn't accept CRLF -- instead it wants a LR. EBCDIC machines don't
-# use ASCII, so \015\012 means something different. I find this all
-# really annoying.
-$EBCDIC = "\t" ne "\011";
-if ($OS eq 'VMS') {
- $CRLF = "\n";
-} elsif ($EBCDIC) {
- $CRLF= "\r\n";
-} else {
- $CRLF = "\015\012";
-}
-
-if ($needs_binmode) {
- $CGI::DefaultClass->binmode(\*main::STDOUT);
- $CGI::DefaultClass->binmode(\*main::STDIN);
- $CGI::DefaultClass->binmode(\*main::STDERR);
-}
-
-%EXPORT_TAGS = (
- ':html2'=>['h1'..'h6',qw/p br hr ol ul li dl dt dd menu code var strong em
- tt u i b blockquote pre img a address cite samp dfn html head
- base body Link nextid title meta kbd start_html end_html
- input Select option comment charset escapeHTML/],
- ':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet Param nobr
- embed basefont style span layer ilayer font frameset frame script small big Area Map/],
- ':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
- ins label legend noframes noscript object optgroup Q
- thead tbody tfoot/],
- ':netscape'=>[qw/blink fontsize center/],
- ':form'=>[qw/textfield textarea filefield password_field hidden checkbox checkbox_group
- submit reset defaults radio_group popup_menu button autoEscape
- scrolling_list image_button start_form end_form startform endform
- start_multipart_form end_multipart_form isindex tmpFileName uploadInfo URL_ENCODED MULTIPART/],
- ':cgi'=>[qw/param upload path_info path_translated request_uri url self_url script_name
- cookie Dump
- raw_cookie request_method query_string Accept user_agent remote_host content_type
- remote_addr referer server_name server_software server_port server_protocol virtual_port
- virtual_host remote_ident auth_type http append
- save_parameters restore_parameters param_fetch
- remote_user user_name header redirect import_names put
- Delete Delete_all url_param cgi_error/],
- ':ssl' => [qw/https/],
- ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam Vars/],
- ':html' => [qw/:html2 :html3 :html4 :netscape/],
- ':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
- ':push' => [qw/multipart_init multipart_start multipart_end multipart_final/],
- ':all' => [qw/:html2 :html3 :netscape :form :cgi :internal :html4/]
- );
-
-# Custom 'can' method for both autoloaded and non-autoloaded subroutines.
-# Author: Cees Hek <cees at sitesuite.com.au>
-
-sub can {
- my($class, $method) = @_;
-
- # See if UNIVERSAL::can finds it.
-
- if (my $func = $class -> SUPER::can($method) ){
- return $func;
- }
-
- # Try to compile the function.
-
- eval {
- # _compile looks at $AUTOLOAD for the function name.
-
- local $AUTOLOAD = join "::", $class, $method;
- &_compile;
- };
-
- # Now that the function is loaded (if it exists)
- # just use UNIVERSAL::can again to do the work.
-
- return $class -> SUPER::can($method);
-}
-
-# to import symbols into caller
-sub import {
- my $self = shift;
-
- # This causes modules to clash.
- undef %EXPORT_OK;
- undef %EXPORT;
-
- $self->_setup_symbols(@_);
- my ($callpack, $callfile, $callline) = caller;
-
- # To allow overriding, search through the packages
- # Till we find one in which the correct subroutine is defined.
- my @packages = ($self,@{"$self\:\:ISA"});
- for $sym (keys %EXPORT) {
- my $pck;
- my $def = ${"$self\:\:AutoloadClass"} || $DefaultClass;
- for $pck (@packages) {
- if (defined(&{"$pck\:\:$sym"})) {
- $def = $pck;
- last;
- }
- }
- *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
- }
-}
-
-sub compile {
- my $pack = shift;
- $pack->_setup_symbols('-compile', at _);
-}
-
-sub expand_tags {
- my($tag) = @_;
- return ("start_$1","end_$1") if $tag=~/^(?:\*|start_|end_)(.+)/;
- my(@r);
- return ($tag) unless $EXPORT_TAGS{$tag};
- for (@{$EXPORT_TAGS{$tag}}) {
- push(@r,&expand_tags($_));
- }
- return @r;
-}
-
-#### Method: new
-# The new routine. This will check the current environment
-# for an existing query string, and initialize itself, if so.
-####
-sub new {
- my($class, at initializer) = @_;
- my $self = {};
-
- bless $self,ref $class || $class || $DefaultClass;
-
- # always use a tempfile
- $self->{'use_tempfile'} = 1;
-
- if (ref($initializer[0])
- && (UNIVERSAL::isa($initializer[0],'Apache')
- ||
- UNIVERSAL::isa($initializer[0],'Apache2::RequestRec')
- )) {
- $self->r(shift @initializer);
- }
- if (ref($initializer[0])
- && (UNIVERSAL::isa($initializer[0],'CODE'))) {
- $self->upload_hook(shift @initializer, shift @initializer);
- $self->{'use_tempfile'} = shift @initializer if (@initializer > 0);
- }
- if ($MOD_PERL) {
- if ($MOD_PERL == 1) {
- $self->r(Apache->request) unless $self->r;
- my $r = $self->r;
- $r->register_cleanup(\&CGI::_reset_globals);
- $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
- }
- else {
- # XXX: once we have the new API
- # will do a real PerlOptions -SetupEnv check
- $self->r(Apache2::RequestUtil->request) unless $self->r;
- my $r = $self->r;
- $r->subprocess_env unless exists $ENV{REQUEST_METHOD};
- $r->pool->cleanup_register(\&CGI::_reset_globals);
- $self->_setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
- }
- undef $NPH;
- }
- $self->_reset_globals if $PERLEX;
- $self->init(@initializer);
- return $self;
-}
-
-# We provide a DESTROY method so that we can ensure that
-# temporary files are closed (via Fh->DESTROY) before they
-# are unlinked (via CGITempFile->DESTROY) because it is not
-# possible to unlink an open file on Win32. We explicitly
-# call DESTROY on each, rather than just undefing them and
-# letting Perl DESTROY them by garbage collection, in case the
-# user is still holding any reference to them as well.
-sub DESTROY {
- my $self = shift;
- if ($OS eq 'WINDOWS') {
- for my $href (values %{$self->{'.tmpfiles'}}) {
- $href->{hndl}->DESTROY if defined $href->{hndl};
- $href->{name}->DESTROY if defined $href->{name};
- }
- }
-}
-
-sub r {
- my $self = shift;
- my $r = $self->{'.r'};
- $self->{'.r'} = shift if @_;
- $r;
-}
-
-sub upload_hook {
- my $self;
- if (ref $_[0] eq 'CODE') {
- $CGI::Q = $self = $CGI::DefaultClass->new(@_);
- } else {
- $self = shift;
- }
- my ($hook,$data,$use_tempfile) = @_;
- $self->{'.upload_hook'} = $hook;
- $self->{'.upload_data'} = $data;
- $self->{'use_tempfile'} = $use_tempfile if defined $use_tempfile;
-}
-
-#### Method: param
-# Returns the value(s)of a named parameter.
-# If invoked in a list context, returns the
-# entire list. Otherwise returns the first
-# member of the list.
-# If name is not provided, return a list of all
-# the known parameters names available.
-# If more than one argument is provided, the
-# second and subsequent arguments are used to
-# set the value of the parameter.
-####
-sub param {
- my($self, at p) = self_or_default(@_);
- return $self->all_parameters unless @p;
- my($name,$value, at other);
-
- # For compatibility between old calling style and use_named_parameters() style,
- # we have to special case for a single parameter present.
- if (@p > 1) {
- ($name,$value, at other) = rearrange([NAME,[DEFAULT,VALUE,VALUES]], at p);
- my(@values);
-
- if (substr($p[0],0,1) eq '-') {
- @values = defined($value) ? (ref($value) && ref($value) eq 'ARRAY' ? @{$value} : $value) : ();
- } else {
- for ($value, at other) {
- push(@values,$_) if defined($_);
- }
- }
- # If values is provided, then we set it.
- if (@values or defined $value) {
- $self->add_parameter($name);
- $self->{param}{$name}=[@values];
- }
- } else {
- $name = $p[0];
- }
-
- return unless defined($name) && $self->{param}{$name};
-
- my @result = @{$self->{param}{$name}};
-
- if ($PARAM_UTF8) {
- eval "require Encode; 1;" unless Encode->can('decode'); # bring in these functions
- @result = map {ref $_ ? $_ : Encode::decode(utf8=>$_) } @result;
- }
-
- return wantarray ? @result : $result[0];
-}
-
-sub self_or_default {
- return @_ if defined($_[0]) && (!ref($_[0])) &&($_[0] eq 'CGI');
- unless (defined($_[0]) &&
- (ref($_[0]) eq 'CGI' || UNIVERSAL::isa($_[0],'CGI')) # slightly optimized for common case
- ) {
- $Q = $CGI::DefaultClass->new unless defined($Q);
- unshift(@_,$Q);
- }
- return wantarray ? @_ : $Q;
-}
-
-sub self_or_CGI {
- local $^W=0; # prevent a warning
- if (defined($_[0]) &&
- (substr(ref($_[0]),0,3) eq 'CGI'
- || UNIVERSAL::isa($_[0],'CGI'))) {
- return @_;
- } else {
- return ($DefaultClass, at _);
- }
-}
-
-########################################
-# THESE METHODS ARE MORE OR LESS PRIVATE
-# GO TO THE __DATA__ SECTION TO SEE MORE
-# PUBLIC METHODS
-########################################
-
-# Initialize the query object from the environment.
-# If a parameter list is found, this object will be set
-# to a hash in which parameter names are keys
-# and the values are stored as lists
-# If a keyword list is found, this method creates a bogus
-# parameter list with the single parameter 'keywords'.
-
-sub init {
- my $self = shift;
- my($query_string,$meth,$content_length,$fh, at lines) = ('','','','');
-
- my $is_xforms;
-
- my $initializer = shift; # for backward compatibility
- local($/) = "\n";
-
- # set autoescaping on by default
- $self->{'escape'} = 1;
-
- # if we get called more than once, we want to initialize
- # ourselves from the original query (which may be gone
- # if it was read from STDIN originally.)
- if (defined(@QUERY_PARAM) && !defined($initializer)) {
- for my $name (@QUERY_PARAM) {
- my $val = $QUERY_PARAM{$name}; # always an arrayref;
- $self->param('-name'=>$name,'-value'=> $val);
- if (defined $val and ref $val eq 'ARRAY') {
- for my $fh (grep {defined(fileno($_))} @$val) {
- seek($fh,0,0); # reset the filehandle.
- }
-
- }
- }
- $self->charset($QUERY_CHARSET);
- $self->{'.fieldnames'} = {%QUERY_FIELDNAMES};
- $self->{'.tmpfiles'} = {%QUERY_TMPFILES};
- return;
- }
-
- $meth=$ENV{'REQUEST_METHOD'} if defined($ENV{'REQUEST_METHOD'});
- $content_length = defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
-
- $fh = to_filehandle($initializer) if $initializer;
-
- # set charset to the safe ISO-8859-1
- $self->charset('ISO-8859-1');
-
- METHOD: {
-
- # avoid unreasonably large postings
- if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
- #discard the post, unread
- $self->cgi_error("413 Request entity too large");
- last METHOD;
- }
-
- # Process multipart postings, but only if the initializer is
- # not defined.
- if ($meth eq 'POST'
- && defined($ENV{'CONTENT_TYPE'})
- && $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|
- && !defined($initializer)
- ) {
- my($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=\"?([^\";,]+)\"?/;
- $self->read_multipart($boundary,$content_length);
- last METHOD;
- }
-
- # Process XForms postings. We know that we have XForms in the
- # following cases:
- # method eq 'POST' && content-type eq 'application/xml'
- # method eq 'POST' && content-type =~ /multipart\/related.+start=/
- # There are more cases, actually, but for now, we don't support other
- # methods for XForm posts.
- # In a XForm POST, the QUERY_STRING is parsed normally.
- # If the content-type is 'application/xml', we just set the param
- # XForms:Model (referring to the xml syntax) param containing the
- # unparsed XML data.
- # In the case of multipart/related we set XForms:Model as above, but
- # the other parts are available as uploads with the Content-ID as the
- # the key.
- # See the URL below for XForms specs on this issue.
- # http://www.w3.org/TR/2006/REC-xforms-20060314/slice11.html#submit-options
- if ($meth eq 'POST' && defined($ENV{'CONTENT_TYPE'})) {
- if ($ENV{'CONTENT_TYPE'} eq 'application/xml') {
- my($param) = 'XForms:Model';
- my($value) = '';
- $self->add_parameter($param);
- $self->read_from_client(\$value,$content_length,0)
- if $content_length > 0;
- push (@{$self->{param}{$param}},$value);
- $is_xforms = 1;
- } elsif ($ENV{'CONTENT_TYPE'} =~ /multipart\/related.+boundary=\"?([^\";,]+)\"?.+start=\"?\<?([^\"\>]+)\>?\"?/) {
- my($boundary,$start) = ($1,$2);
- my($param) = 'XForms:Model';
- $self->add_parameter($param);
- my($value) = $self->read_multipart_related($start,$boundary,$content_length,0);
- push (@{$self->{param}{$param}},$value);
- if ($MOD_PERL) {
- $query_string = $self->r->args;
- } else {
- $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
- $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
- }
- $is_xforms = 1;
- }
- }
-
-
- # If initializer is defined, then read parameters
- # from it.
- if (!$is_xforms && defined($initializer)) {
- if (UNIVERSAL::isa($initializer,'CGI')) {
- $query_string = $initializer->query_string;
- last METHOD;
- }
- if (ref($initializer) && ref($initializer) eq 'HASH') {
- for (keys %$initializer) {
- $self->param('-name'=>$_,'-value'=>$initializer->{$_});
- }
- last METHOD;
- }
-
- if (defined($fh) && ($fh ne '')) {
- while (<$fh>) {
- chomp;
- last if /^=/;
- push(@lines,$_);
- }
- # massage back into standard format
- if ("@lines" =~ /=/) {
- $query_string=join("&", at lines);
- } else {
- $query_string=join("+", at lines);
- }
- last METHOD;
- }
-
- # last chance -- treat it as a string
- $initializer = $$initializer if ref($initializer) eq 'SCALAR';
- $query_string = $initializer;
-
- last METHOD;
- }
-
- # If method is GET or HEAD, fetch the query from
- # the environment.
- if ($is_xforms || $meth=~/^(GET|HEAD)$/) {
- if ($MOD_PERL) {
- $query_string = $self->r->args;
- } else {
- $query_string = $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
- $query_string ||= $ENV{'REDIRECT_QUERY_STRING'} if defined $ENV{'REDIRECT_QUERY_STRING'};
- }
- last METHOD;
- }
-
- if ($meth eq 'POST' || $meth eq 'PUT') {
- $self->read_from_client(\$query_string,$content_length,0)
- if $content_length > 0;
- # Some people want to have their cake and eat it too!
- # Uncomment this line to have the contents of the query string
- # APPENDED to the POST data.
- # $query_string .= (length($query_string) ? '&' : '') . $ENV{'QUERY_STRING'} if defined $ENV{'QUERY_STRING'};
- last METHOD;
- }
-
- # If $meth is not of GET, POST or HEAD, assume we're being debugged offline.
- # Check the command line and then the standard input for data.
- # We use the shellwords package in order to behave the way that
- # UN*X programmers expect.
- if ($DEBUG)
- {
- my $cmdline_ret = read_from_cmdline();
- $query_string = $cmdline_ret->{'query_string'};
- if (defined($cmdline_ret->{'subpath'}))
- {
- $self->path_info($cmdline_ret->{'subpath'});
- }
- }
- }
-
-# YL: Begin Change for XML handler 10/19/2001
- if (!$is_xforms && ($meth eq 'POST' || $meth eq 'PUT')
- && defined($ENV{'CONTENT_TYPE'})
- && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
- && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
- my($param) = $meth . 'DATA' ;
- $self->add_parameter($param) ;
- push (@{$self->{param}{$param}},$query_string);
- undef $query_string ;
- }
-# YL: End Change for XML handler 10/19/2001
-
- # We now have the query string in hand. We do slightly
- # different things for keyword lists and parameter lists.
- if (defined $query_string && length $query_string) {
- if ($query_string =~ /[&=;]/) {
- $self->parse_params($query_string);
- } else {
- $self->add_parameter('keywords');
- $self->{param}{'keywords'} = [$self->parse_keywordlist($query_string)];
- }
- }
-
- # Special case. Erase everything if there is a field named
- # .defaults.
- if ($self->param('.defaults')) {
- $self->delete_all();
- }
-
- # hash containing our defined fieldnames
- $self->{'.fieldnames'} = {};
- for ($self->param('.cgifields')) {
- $self->{'.fieldnames'}->{$_}++;
- }
-
- # Clear out our default submission button flag if present
- $self->delete('.submit');
- $self->delete('.cgifields');
-
- $self->save_request unless defined $initializer;
-}
-
-# FUNCTIONS TO OVERRIDE:
-# Turn a string into a filehandle
-sub to_filehandle {
- my $thingy = shift;
- return undef unless $thingy;
- return $thingy if UNIVERSAL::isa($thingy,'GLOB');
- return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
- if (!ref($thingy)) {
- my $caller = 1;
- while (my $package = caller($caller++)) {
- my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
- return $tmp if defined(fileno($tmp));
- }
- }
- return undef;
-}
-
-# send output to the browser
-sub put {
- my($self, at p) = self_or_default(@_);
- $self->print(@p);
-}
-
-# print to standard output (for overriding in mod_perl)
-sub print {
- shift;
- CORE::print(@_);
-}
-
-# get/set last cgi_error
-sub cgi_error {
- my ($self,$err) = self_or_default(@_);
- $self->{'.cgi_error'} = $err if defined $err;
- return $self->{'.cgi_error'};
-}
-
-sub save_request {
- my($self) = @_;
- # We're going to play with the package globals now so that if we get called
- # again, we initialize ourselves in exactly the same way. This allows
- # us to have several of these objects.
- @QUERY_PARAM = $self->param; # save list of parameters
- for (@QUERY_PARAM) {
- next unless defined $_;
- $QUERY_PARAM{$_}=$self->{param}{$_};
- }
- $QUERY_CHARSET = $self->charset;
- %QUERY_FIELDNAMES = %{$self->{'.fieldnames'}};
- %QUERY_TMPFILES = %{ $self->{'.tmpfiles'} || {} };
-}
-
-sub parse_params {
- my($self,$tosplit) = @_;
- my(@pairs) = split(/[&;]/,$tosplit);
- my($param,$value);
- for (@pairs) {
- ($param,$value) = split('=',$_,2);
- next unless defined $param;
- next if $NO_UNDEF_PARAMS and not defined $value;
- $value = '' unless defined $value;
- $param = unescape($param);
- $value = unescape($value);
- $self->add_parameter($param);
- push (@{$self->{param}{$param}},$value);
- }
-}
-
-sub add_parameter {
- my($self,$param)=@_;
- return unless defined $param;
- push (@{$self->{'.parameters'}},$param)
- unless defined($self->{param}{$param});
-}
-
-sub all_parameters {
- my $self = shift;
- return () unless defined($self) && $self->{'.parameters'};
- return () unless @{$self->{'.parameters'}};
- return @{$self->{'.parameters'}};
-}
-
-# put a filehandle into binary mode (DOS)
-sub binmode {
- return unless defined($_[1]) && defined fileno($_[1]);
- CORE::binmode($_[1]);
-}
-
-sub _make_tag_func {
- my ($self,$tagname) = @_;
- my $func = qq(
- sub $tagname {
- my (\$q,\$a,\@rest) = self_or_default(\@_);
- my(\$attr) = '';
- if (ref(\$a) && ref(\$a) eq 'HASH') {
- my(\@attr) = make_attributes(\$a,\$q->{'escape'});
- \$attr = " \@attr" if \@attr;
- } else {
- unshift \@rest,\$a if defined \$a;
- }
- );
- if ($tagname=~/start_(\w+)/i) {
- $func .= qq! return "<\L$1\E\$attr>";} !;
- } elsif ($tagname=~/end_(\w+)/i) {
- $func .= qq! return "<\L/$1\E>"; } !;
- } else {
- $func .= qq#
- return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless \@rest;
- my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
- my \@result = map { "\$tag\$_\$untag" }
- (ref(\$rest[0]) eq 'ARRAY') ? \@{\$rest[0]} : "\@rest";
- return "\@result";
- }#;
- }
-return $func;
-}
-
-sub AUTOLOAD {
- print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
- my $func = &_compile;
- goto &$func;
-}
-
-sub _compile {
- my($func) = $AUTOLOAD;
- my($pack,$func_name);
- {
- local($1,$2); # this fixes an obscure variable suicide problem.
- $func=~/(.+)::([^:]+)$/;
- ($pack,$func_name) = ($1,$2);
- $pack=~s/::SUPER$//; # fix another obscure problem
- $pack = ${"$pack\:\:AutoloadClass"} || $CGI::DefaultClass
- unless defined(${"$pack\:\:AUTOLOADED_ROUTINES"});
-
- my($sub) = \%{"$pack\:\:SUBS"};
- unless (%$sub) {
- my($auto) = \${"$pack\:\:AUTOLOADED_ROUTINES"};
- local ($@,$!);
- eval "package $pack; $$auto";
- croak("$AUTOLOAD: $@") if $@;
- $$auto = ''; # Free the unneeded storage (but don't undef it!!!)
- }
- my($code) = $sub->{$func_name};
-
- $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
- if (!$code) {
- (my $base = $func_name) =~ s/^(start_|end_)//i;
- if ($EXPORT{':any'} ||
- $EXPORT{'-any'} ||
- $EXPORT{$base} ||
- (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
- && $EXPORT_OK{$base}) {
- $code = $CGI::DefaultClass->_make_tag_func($func_name);
- }
- }
- croak("Undefined subroutine $AUTOLOAD\n") unless $code;
- local ($@,$!);
- eval "package $pack; $code";
- if ($@) {
- $@ =~ s/ at .*\n//;
- croak("$AUTOLOAD: $@");
- }
- }
- CORE::delete($sub->{$func_name}); #free storage
- return "$pack\:\:$func_name";
-}
-
-sub _selected {
- my $self = shift;
- my $value = shift;
- return '' unless $value;
- return $XHTML ? qq(selected="selected" ) : qq(selected );
-}
-
-sub _checked {
- my $self = shift;
- my $value = shift;
- return '' unless $value;
- return $XHTML ? qq(checked="checked" ) : qq(checked );
-}
-
-sub _reset_globals { initialize_globals(); }
-
-sub _setup_symbols {
- my $self = shift;
- my $compile = 0;
-
- # to avoid reexporting unwanted variables
- undef %EXPORT;
-
- for (@_) {
- $HEADERS_ONCE++, next if /^[:-]unique_headers$/;
- $NPH++, next if /^[:-]nph$/;
- $NOSTICKY++, next if /^[:-]nosticky$/;
- $DEBUG=0, next if /^[:-]no_?[Dd]ebug$/;
- $DEBUG=2, next if /^[:-][Dd]ebug$/;
- $USE_PARAM_SEMICOLONS++, next if /^[:-]newstyle_urls$/;
- $PARAM_UTF8++, next if /^[:-]utf8$/;
- $XHTML++, next if /^[:-]xhtml$/;
- $XHTML=0, next if /^[:-]no_?xhtml$/;
- $USE_PARAM_SEMICOLONS=0, next if /^[:-]oldstyle_urls$/;
- $PRIVATE_TEMPFILES++, next if /^[:-]private_tempfiles$/;
- $TABINDEX++, next if /^[:-]tabindex$/;
- $CLOSE_UPLOAD_FILES++, next if /^[:-]close_upload_files$/;
- $EXPORT{$_}++, next if /^[:-]any$/;
- $compile++, next if /^[:-]compile$/;
- $NO_UNDEF_PARAMS++, next if /^[:-]no_undef_params$/;
-
- # This is probably extremely evil code -- to be deleted some day.
- if (/^[-]autoload$/) {
- my($pkg) = caller(1);
- *{"${pkg}::AUTOLOAD"} = sub {
- my($routine) = $AUTOLOAD;
- $routine =~ s/^.*::/CGI::/;
- &$routine;
- };
- next;
- }
-
- for (&expand_tags($_)) {
- tr/a-zA-Z0-9_//cd; # don't allow weird function names
- $EXPORT{$_}++;
- }
- }
- _compile_all(keys %EXPORT) if $compile;
- @SAVED_SYMBOLS = @_;
-}
-
-sub charset {
- my ($self,$charset) = self_or_default(@_);
- $self->{'.charset'} = $charset if defined $charset;
- $self->{'.charset'};
-}
-
-sub element_id {
- my ($self,$new_value) = self_or_default(@_);
- $self->{'.elid'} = $new_value if defined $new_value;
- sprintf('%010d',$self->{'.elid'}++);
-}
-
-sub element_tab {
- my ($self,$new_value) = self_or_default(@_);
- $self->{'.etab'} ||= 1;
- $self->{'.etab'} = $new_value if defined $new_value;
- my $tab = $self->{'.etab'}++;
- return '' unless $TABINDEX or defined $new_value;
- return qq(tabindex="$tab" );
-}
-
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
-$AUTOLOADED_ROUTINES = ''; # get rid of -w warning
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-
-%SUBS = (
-
-'URL_ENCODED'=> <<'END_OF_FUNC',
-sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
-END_OF_FUNC
-
-'MULTIPART' => <<'END_OF_FUNC',
-sub MULTIPART { 'multipart/form-data'; }
-END_OF_FUNC
-
-'SERVER_PUSH' => <<'END_OF_FUNC',
-sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
-END_OF_FUNC
-
-'new_MultipartBuffer' => <<'END_OF_FUNC',
-# Create a new multipart buffer
-sub new_MultipartBuffer {
- my($self,$boundary,$length) = @_;
- return MultipartBuffer->new($self,$boundary,$length);
-}
-END_OF_FUNC
-
-'read_from_client' => <<'END_OF_FUNC',
-# Read data from a file handle
-sub read_from_client {
- my($self, $buff, $len, $offset) = @_;
- local $^W=0; # prevent a warning
- return $MOD_PERL
- ? $self->r->read($$buff, $len, $offset)
- : read(\*STDIN, $$buff, $len, $offset);
-}
-END_OF_FUNC
-
-'delete' => <<'END_OF_FUNC',
-#### Method: delete
-# Deletes the named parameter entirely.
-####
-sub delete {
- my($self, at p) = self_or_default(@_);
- my(@names) = rearrange([NAME], at p);
- my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
- my %to_delete;
- for my $name (@to_delete)
- {
- CORE::delete $self->{param}{$name};
- CORE::delete $self->{'.fieldnames'}->{$name};
- $to_delete{$name}++;
- }
- @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
- return;
-}
-END_OF_FUNC
-
-#### Method: import_names
-# Import all parameters into the given namespace.
-# Assumes namespace 'Q' if not specified
-####
-'import_names' => <<'END_OF_FUNC',
-sub import_names {
- my($self,$namespace,$delete) = self_or_default(@_);
- $namespace = 'Q' unless defined($namespace);
- die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
- if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
- # can anyone find an easier way to do this?
- for (keys %{"${namespace}::"}) {
- local *symbol = "${namespace}::${_}";
- undef $symbol;
- undef @symbol;
- undef %symbol;
- }
- }
- my($param, at value,$var);
- for $param ($self->param) {
- # protect against silly names
- ($var = $param)=~tr/a-zA-Z0-9_/_/c;
- $var =~ s/^(?=\d)/_/;
- local *symbol = "${namespace}::$var";
- @value = $self->param($param);
- @symbol = @value;
- $symbol = $value[0];
- }
-}
-END_OF_FUNC
-
-#### Method: keywords
-# Keywords acts a bit differently. Calling it in a list context
-# returns the list of keywords.
-# Calling it in a scalar context gives you the size of the list.
-####
-'keywords' => <<'END_OF_FUNC',
-sub keywords {
- my($self, at values) = self_or_default(@_);
- # If values is provided, then we set it.
- $self->{param}{'keywords'}=[@values] if @values;
- my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
- @result;
-}
-END_OF_FUNC
-
-# These are some tie() interfaces for compatibility
-# with Steve Brenner's cgi-lib.pl routines
-'Vars' => <<'END_OF_FUNC',
-sub Vars {
- my $q = shift;
- my %in;
- tie(%in,CGI,$q);
- return %in if wantarray;
- return \%in;
-}
-END_OF_FUNC
-
-# These are some tie() interfaces for compatibility
-# with Steve Brenner's cgi-lib.pl routines
-'ReadParse' => <<'END_OF_FUNC',
-sub ReadParse {
- local(*in);
- if (@_) {
- *in = $_[0];
- } else {
- my $pkg = caller();
- *in=*{"${pkg}::in"};
- }
- tie(%in,CGI);
- return scalar(keys %in);
-}
-END_OF_FUNC
-
-'PrintHeader' => <<'END_OF_FUNC',
-sub PrintHeader {
- my($self) = self_or_default(@_);
- return $self->header();
-}
-END_OF_FUNC
-
-'HtmlTop' => <<'END_OF_FUNC',
-sub HtmlTop {
- my($self, at p) = self_or_default(@_);
- return $self->start_html(@p);
-}
-END_OF_FUNC
-
-'HtmlBot' => <<'END_OF_FUNC',
-sub HtmlBot {
- my($self, at p) = self_or_default(@_);
- return $self->end_html(@p);
-}
-END_OF_FUNC
-
-'SplitParam' => <<'END_OF_FUNC',
-sub SplitParam {
- my ($param) = @_;
- my (@params) = split ("\0", $param);
- return (wantarray ? @params : $params[0]);
-}
-END_OF_FUNC
-
-'MethGet' => <<'END_OF_FUNC',
-sub MethGet {
- return request_method() eq 'GET';
-}
-END_OF_FUNC
-
-'MethPost' => <<'END_OF_FUNC',
-sub MethPost {
- return request_method() eq 'POST';
-}
-END_OF_FUNC
-
-'TIEHASH' => <<'END_OF_FUNC',
-sub TIEHASH {
- my $class = shift;
- my $arg = $_[0];
- if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
- return $arg;
- }
- return $Q ||= $class->new(@_);
-}
-END_OF_FUNC
-
-'STORE' => <<'END_OF_FUNC',
-sub STORE {
- my $self = shift;
- my $tag = shift;
- my $vals = shift;
- my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
- $self->param(-name=>$tag,-value=>\@vals);
-}
-END_OF_FUNC
-
-'FETCH' => <<'END_OF_FUNC',
-sub FETCH {
- return $_[0] if $_[1] eq 'CGI';
- return undef unless defined $_[0]->param($_[1]);
- return join("\0",$_[0]->param($_[1]));
-}
-END_OF_FUNC
-
-'FIRSTKEY' => <<'END_OF_FUNC',
-sub FIRSTKEY {
- $_[0]->{'.iterator'}=0;
- $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
-}
-END_OF_FUNC
-
-'NEXTKEY' => <<'END_OF_FUNC',
-sub NEXTKEY {
- $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
-}
-END_OF_FUNC
-
-'EXISTS' => <<'END_OF_FUNC',
-sub EXISTS {
- exists $_[0]->{param}{$_[1]};
-}
-END_OF_FUNC
-
-'DELETE' => <<'END_OF_FUNC',
-sub DELETE {
- $_[0]->delete($_[1]);
-}
-END_OF_FUNC
-
-'CLEAR' => <<'END_OF_FUNC',
-sub CLEAR {
- %{$_[0]}=();
-}
-####
-END_OF_FUNC
-
-####
-# Append a new value to an existing query
-####
-'append' => <<'EOF',
-sub append {
- my($self, at p) = self_or_default(@_);
- my($name,$value) = rearrange([NAME,[VALUE,VALUES]], at p);
- my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
- if (@values) {
- $self->add_parameter($name);
- push(@{$self->{param}{$name}}, at values);
- }
- return $self->param($name);
-}
-EOF
-
-#### Method: delete_all
-# Delete all parameters
-####
-'delete_all' => <<'EOF',
-sub delete_all {
- my($self) = self_or_default(@_);
- my @param = $self->param();
- $self->delete(@param);
-}
-EOF
-
-'Delete' => <<'EOF',
-sub Delete {
- my($self, at p) = self_or_default(@_);
- $self->delete(@p);
-}
-EOF
-
-'Delete_all' => <<'EOF',
-sub Delete_all {
- my($self, at p) = self_or_default(@_);
- $self->delete_all(@p);
-}
-EOF
-
-#### Method: autoescape
-# If you want to turn off the autoescaping features,
-# call this method with undef as the argument
-'autoEscape' => <<'END_OF_FUNC',
-sub autoEscape {
- my($self,$escape) = self_or_default(@_);
- my $d = $self->{'escape'};
- $self->{'escape'} = $escape;
- $d;
-}
-END_OF_FUNC
-
-
-#### Method: version
-# Return the current version
-####
-'version' => <<'END_OF_FUNC',
-sub version {
- return $VERSION;
-}
-END_OF_FUNC
-
-#### Method: url_param
-# Return a parameter in the QUERY_STRING, regardless of
-# whether this was a POST or a GET
-####
-'url_param' => <<'END_OF_FUNC',
-sub url_param {
- my ($self, at p) = self_or_default(@_);
- my $name = shift(@p);
- return undef unless exists($ENV{QUERY_STRING});
- unless (exists($self->{'.url_param'})) {
- $self->{'.url_param'}={}; # empty hash
- if ($ENV{QUERY_STRING} =~ /=/) {
- my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
- my($param,$value);
- for (@pairs) {
- ($param,$value) = split('=',$_,2);
- $param = unescape($param);
- $value = unescape($value);
- push(@{$self->{'.url_param'}->{$param}},$value);
- }
- } else {
- $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
- }
- }
- return keys %{$self->{'.url_param'}} unless defined($name);
- return () unless $self->{'.url_param'}->{$name};
- return wantarray ? @{$self->{'.url_param'}->{$name}}
- : $self->{'.url_param'}->{$name}->[0];
-}
-END_OF_FUNC
-
-#### Method: Dump
-# Returns a string in which all the known parameter/value
-# pairs are represented as nested lists, mainly for the purposes
-# of debugging.
-####
-'Dump' => <<'END_OF_FUNC',
-sub Dump {
- my($self) = self_or_default(@_);
- my($param,$value, at result);
- return '<ul></ul>' unless $self->param;
- push(@result,"<ul>");
- for $param ($self->param) {
- my($name)=$self->escapeHTML($param);
- push(@result,"<li><strong>$param</strong></li>");
- push(@result,"<ul>");
- for $value ($self->param($param)) {
- $value = $self->escapeHTML($value);
- $value =~ s/\n/<br \/>\n/g;
- push(@result,"<li>$value</li>");
- }
- push(@result,"</ul>");
- }
- push(@result,"</ul>");
- return join("\n", at result);
-}
-END_OF_FUNC
-
-#### Method as_string
-#
-# synonym for "dump"
-####
-'as_string' => <<'END_OF_FUNC',
-sub as_string {
- &Dump(@_);
-}
-END_OF_FUNC
-
-#### Method: save
-# Write values out to a filehandle in such a way that they can
-# be reinitialized by the filehandle form of the new() method
-####
-'save' => <<'END_OF_FUNC',
-sub save {
- my($self,$filehandle) = self_or_default(@_);
- $filehandle = to_filehandle($filehandle);
- my($param);
- local($,) = ''; # set print field separator back to a sane value
- local($\) = ''; # set output line separator to a sane value
- for $param ($self->param) {
- my($escaped_param) = escape($param);
- my($value);
- for $value ($self->param($param)) {
- print $filehandle "$escaped_param=",escape("$value"),"\n";
- }
- }
- for (keys %{$self->{'.fieldnames'}}) {
- print $filehandle ".cgifields=",escape("$_"),"\n";
- }
- print $filehandle "=\n"; # end of record
-}
-END_OF_FUNC
-
-
-#### Method: save_parameters
-# An alias for save() that is a better name for exportation.
-# Only intended to be used with the function (non-OO) interface.
-####
-'save_parameters' => <<'END_OF_FUNC',
-sub save_parameters {
- my $fh = shift;
- return save(to_filehandle($fh));
-}
-END_OF_FUNC
-
-#### Method: restore_parameters
-# A way to restore CGI parameters from an initializer.
-# Only intended to be used with the function (non-OO) interface.
-####
-'restore_parameters' => <<'END_OF_FUNC',
-sub restore_parameters {
- $Q = $CGI::DefaultClass->new(@_);
-}
-END_OF_FUNC
-
-#### Method: multipart_init
-# Return a Content-Type: style header for server-push
-# This has to be NPH on most web servers, and it is advisable to set $| = 1
-#
-# Many thanks to Ed Jordan <ed at fidalgo.net> for this
-# contribution, updated by Andrew Benham (adsb at bigfoot.com)
-####
-'multipart_init' => <<'END_OF_FUNC',
-sub multipart_init {
- my($self, at p) = self_or_default(@_);
- my($boundary, at other) = rearrange_header([BOUNDARY], at p);
- $boundary = $boundary || '------- =_aaaaaaaaaa0';
- $self->{'separator'} = "$CRLF--$boundary$CRLF";
- $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
- $type = SERVER_PUSH($boundary);
- return $self->header(
- -nph => 0,
- -type => $type,
- (map { split "=", $_, 2 } @other),
- ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
-}
-END_OF_FUNC
-
-
-#### Method: multipart_start
-# Return a Content-Type: style header for server-push, start of section
-#
-# Many thanks to Ed Jordan <ed at fidalgo.net> for this
-# contribution, updated by Andrew Benham (adsb at bigfoot.com)
-####
-'multipart_start' => <<'END_OF_FUNC',
-sub multipart_start {
- my(@header);
- my($self, at p) = self_or_default(@_);
- my($type, at other) = rearrange([TYPE], at p);
- $type = $type || 'text/html';
- push(@header,"Content-Type: $type");
-
- # rearrange() was designed for the HTML portion, so we
- # need to fix it up a little.
- for (@other) {
- # Don't use \s because of perl bug 21951
- next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
- ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
- }
- push(@header, at other);
- my $header = join($CRLF, at header)."${CRLF}${CRLF}";
- return $header;
-}
-END_OF_FUNC
-
-
-#### Method: multipart_end
-# Return a MIME boundary separator for server-push, end of section
-#
-# Many thanks to Ed Jordan <ed at fidalgo.net> for this
-# contribution
-####
-'multipart_end' => <<'END_OF_FUNC',
-sub multipart_end {
- my($self, at p) = self_or_default(@_);
- return $self->{'separator'};
-}
-END_OF_FUNC
-
-
-#### Method: multipart_final
-# Return a MIME boundary separator for server-push, end of all sections
-#
-# Contributed by Andrew Benham (adsb at bigfoot.com)
-####
-'multipart_final' => <<'END_OF_FUNC',
-sub multipart_final {
- my($self, at p) = self_or_default(@_);
- return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
-}
-END_OF_FUNC
-
-
-#### Method: header
-# Return a Content-Type: style header
-#
-####
-'header' => <<'END_OF_FUNC',
-sub header {
- my($self, at p) = self_or_default(@_);
- my(@header);
-
- return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
-
- my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p, at other) =
- rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
- 'STATUS',['COOKIE','COOKIES'],'TARGET',
- 'EXPIRES','NPH','CHARSET',
- 'ATTACHMENT','P3P'], at p);
-
- $nph ||= $NPH;
-
- $type ||= 'text/html' unless defined($type);
-
- if (defined $charset) {
- $self->charset($charset);
- } else {
- $charset = $self->charset if $type =~ /^text\//;
- }
- $charset ||= '';
-
- # rearrange() was designed for the HTML portion, so we
- # need to fix it up a little.
- for (@other) {
- # Don't use \s because of perl bug 21951
- next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
- ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
- }
-
- $type .= "; charset=$charset"
- if $type ne ''
- and $type !~ /\bcharset\b/
- and defined $charset
- and $charset ne '';
-
- # Maybe future compatibility. Maybe not.
- my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
- push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
- push(@header,"Server: " . &server_software()) if $nph;
-
- push(@header,"Status: $status") if $status;
- push(@header,"Window-Target: $target") if $target;
- if ($p3p) {
- $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
- push(@header,qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
- }
- # push all the cookies -- there may be several
- if ($cookie) {
- my(@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
- for (@cookie) {
- my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
- push(@header,"Set-Cookie: $cs") if $cs ne '';
- }
- }
- # if the user indicates an expiration time, then we need
- # both an Expires and a Date header (so that the browser is
- # uses OUR clock)
- push(@header,"Expires: " . expires($expires,'http'))
- if $expires;
- push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
- push(@header,"Pragma: no-cache") if $self->cache();
- push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
- push(@header,map {ucfirst $_} @other);
- push(@header,"Content-Type: $type") if $type ne '';
- my $header = join($CRLF, at header)."${CRLF}${CRLF}";
- if (($MOD_PERL >= 1) && !$nph) {
- $self->r->send_cgi_header($header);
- return '';
- }
- return $header;
-}
-END_OF_FUNC
-
-
-#### Method: cache
-# Control whether header() will produce the no-cache
-# Pragma directive.
-####
-'cache' => <<'END_OF_FUNC',
-sub cache {
- my($self,$new_value) = self_or_default(@_);
- $new_value = '' unless $new_value;
- if ($new_value ne '') {
- $self->{'cache'} = $new_value;
- }
- return $self->{'cache'};
-}
-END_OF_FUNC
-
-
-#### Method: redirect
-# Return a Location: style header
-#
-####
-'redirect' => <<'END_OF_FUNC',
-sub redirect {
- my($self, at p) = self_or_default(@_);
- my($url,$target,$status,$cookie,$nph, at other) =
- rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH], at p);
- $status = '302 Found' unless defined $status;
- $url ||= $self->self_url;
- my(@o);
- for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
- unshift(@o,
- '-Status' => $status,
- '-Location'=> $url,
- '-nph' => $nph);
- unshift(@o,'-Target'=>$target) if $target;
- unshift(@o,'-Type'=>'');
- my @unescaped;
- unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
- return $self->header((map {$self->unescapeHTML($_)} @o), at unescaped);
-}
-END_OF_FUNC
-
-
-#### Method: start_html
-# Canned HTML header
-#
-# Parameters:
-# $title -> (optional) The title for this HTML document (-title)
-# $author -> (optional) e-mail address of the author (-author)
-# $base -> (optional) if set to true, will enter the BASE address of this document
-# for resolving relative references (-base)
-# $xbase -> (optional) alternative base at some remote location (-xbase)
-# $target -> (optional) target window to load all links into (-target)
-# $script -> (option) Javascript code (-script)
-# $no_script -> (option) Javascript <noscript> tag (-noscript)
-# $meta -> (optional) Meta information tags
-# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
-# (a scalar or array ref)
-# $style -> (optional) reference to an external style sheet
-# @other -> (optional) any other named parameters you'd like to incorporate into
-# the <body> tag.
-####
-'start_html' => <<'END_OF_FUNC',
-sub start_html {
- my($self, at p) = &self_or_default(@_);
- my($title,$author,$base,$xbase,$script,$noscript,
- $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml, at other) =
- rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
- META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML], at p);
-
- $self->element_id(0);
- $self->element_tab(0);
-
- $encoding = lc($self->charset) unless defined $encoding;
-
- # Need to sort out the DTD before it's okay to call escapeHTML().
- my(@result,$xml_dtd);
- if ($dtd) {
- if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
- $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
- } else {
- $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
- }
- } else {
- $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
- }
-
- $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
- $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
- push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
-
- if (ref($dtd) && ref($dtd) eq 'ARRAY') {
- push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
- $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
- } else {
- push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
- $DTD_PUBLIC_IDENTIFIER = $dtd;
- }
-
- # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
- # call escapeHTML(). Strangely enough, the title needs to be escaped as
- # HTML while the author needs to be escaped as a URL.
- $title = $self->escapeHTML($title || 'Untitled Document');
- $author = $self->escape($author);
-
- if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
- $lang = "" unless defined $lang;
- $XHTML = 0;
- }
- else {
- $lang = 'en-US' unless defined $lang;
- }
-
- my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
- my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
- if $XHTML && $encoding && !$declare_xml;
-
- push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
- : ($lang ? qq(<html lang="$lang">) : "<html>")
- . "<head><title>$title</title>");
- if (defined $author) {
- push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
- : "<link rev=\"made\" href=\"mailto:$author\">");
- }
-
- if ($base || $xbase || $target) {
- my $href = $xbase || $self->url('-path'=>1);
- my $t = $target ? qq/ target="$target"/ : '';
- push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
- }
-
- if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
- for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
- : qq(<meta name="$_" content="$meta->{$_}">)); }
- }
-
- my $meta_bits_set = 0;
- if( $head ) {
- if( ref $head ) {
- push @result, @$head;
- $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head;
- }
- else {
- push @result, $head;
- $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i;
- }
- }
-
- # handle the infrequently-used -style and -script parameters
- push(@result,$self->_style($style)) if defined $style;
- push(@result,$self->_script($script)) if defined $script;
- push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set;
-
- # handle -noscript parameter
- push(@result,<<END) if $noscript;
-<noscript>
-$noscript
-</noscript>
-END
- ;
- my($other) = @other ? " @other" : '';
- push(@result,"</head>\n<body$other>\n");
- return join("\n", at result);
-}
-END_OF_FUNC
-
-### Method: _style
-# internal method for generating a CSS style section
-####
-'_style' => <<'END_OF_FUNC',
-sub _style {
- my ($self,$style) = @_;
- my (@result);
-
- my $type = 'text/css';
- my $rel = 'stylesheet';
-
-
- my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
- my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
-
- my @s = ref($style) eq 'ARRAY' ? @$style : $style;
- my $other = '';
-
- for my $s (@s) {
- if (ref($s)) {
- my($src,$code,$verbatim,$stype,$alternate,$foo, at other) =
- rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
- ('-foo'=>'bar',
- ref($s) eq 'ARRAY' ? @$s : %$s));
- my $type = defined $stype ? $stype : 'text/css';
- my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
- $other = "@other" if @other;
-
- if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
- { # If it is, push a LINK tag for each one
- for $src (@$src)
- {
- push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
- : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
- }
- }
- else
- { # Otherwise, push the single -src, if it exists.
- push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
- : qq(<link rel="$rel" type="$type" href="$src"$other>)
- ) if $src;
- }
- if ($verbatim) {
- my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
- push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v;
- }
- my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
- push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
-
- } else {
- my $src = $s;
- push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
- : qq(<link rel="$rel" type="$type" href="$src"$other>));
- }
- }
- @result;
-}
-END_OF_FUNC
-
-'_script' => <<'END_OF_FUNC',
-sub _script {
- my ($self,$script) = @_;
- my (@result);
-
- my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
- for $script (@scripts) {
- my($src,$code,$language);
- if (ref($script)) { # script is a hash
- ($src,$code,$type) =
- rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
- '-foo'=>'bar', # a trick to allow the '-' to be omitted
- ref($script) eq 'ARRAY' ? @$script : %$script);
- $type ||= 'text/javascript';
- unless ($type =~ m!\w+/\w+!) {
- $type =~ s/[\d.]+$//;
- $type = "text/$type";
- }
- } else {
- ($src,$code,$type) = ('',$script, 'text/javascript');
- }
-
- my $comment = '//'; # javascript by default
- $comment = '#' if $type=~/perl|tcl/i;
- $comment = "'" if $type=~/vbscript/i;
-
- my ($cdata_start,$cdata_end);
- if ($XHTML) {
- $cdata_start = "$comment<![CDATA[\n";
- $cdata_end .= "\n$comment]]>";
- } else {
- $cdata_start = "\n<!-- Hide script\n";
- $cdata_end = $comment;
- $cdata_end .= " End script hiding -->\n";
- }
- my(@satts);
- push(@satts,'src'=>$src) if $src;
- push(@satts,'type'=>$type);
- $code = $cdata_start . $code . $cdata_end if defined $code;
- push(@result,$self->script({@satts},$code || ''));
- }
- @result;
-}
-END_OF_FUNC
-
-#### Method: end_html
-# End an HTML document.
-# Trivial method for completeness. Just returns "</body>"
-####
-'end_html' => <<'END_OF_FUNC',
-sub end_html {
- return "\n</body>\n</html>";
-}
-END_OF_FUNC
-
-
-################################
-# METHODS USED IN BUILDING FORMS
-################################
-
-#### Method: isindex
-# Just prints out the isindex tag.
-# Parameters:
-# $action -> optional URL of script to run
-# Returns:
-# A string containing a <isindex> tag
-'isindex' => <<'END_OF_FUNC',
-sub isindex {
- my($self, at p) = self_or_default(@_);
- my($action, at other) = rearrange([ACTION], at p);
- $action = qq/ action="$action"/ if $action;
- my($other) = @other ? " @other" : '';
- return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
-}
-END_OF_FUNC
-
-
-#### Method: startform
-# Start a form
-# Parameters:
-# $method -> optional submission method to use (GET or POST)
-# $action -> optional URL of script to run
-# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
-'startform' => <<'END_OF_FUNC',
-sub startform {
- my($self, at p) = self_or_default(@_);
-
- my($method,$action,$enctype, at other) =
- rearrange([METHOD,ACTION,ENCTYPE], at p);
-
- $method = $self->escapeHTML(lc($method || 'post'));
- $enctype = $self->escapeHTML($enctype || &URL_ENCODED);
- if (defined $action) {
- $action = $self->escapeHTML($action);
- }
- else {
- $action = $self->escapeHTML($self->request_uri || $self->self_url);
- }
- $action = qq(action="$action");
- my($other) = @other ? " @other" : '';
- $self->{'.parametersToAdd'}={};
- return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
-}
-END_OF_FUNC
-
-
-#### Method: start_form
-# synonym for startform
-'start_form' => <<'END_OF_FUNC',
-sub start_form {
- $XHTML ? &start_multipart_form : &startform;
-}
-END_OF_FUNC
-
-'end_multipart_form' => <<'END_OF_FUNC',
-sub end_multipart_form {
- &endform;
-}
-END_OF_FUNC
-
-#### Method: start_multipart_form
-# synonym for startform
-'start_multipart_form' => <<'END_OF_FUNC',
-sub start_multipart_form {
- my($self, at p) = self_or_default(@_);
- if (defined($p[0]) && substr($p[0],0,1) eq '-') {
- return $self->startform(-enctype=>&MULTIPART, at p);
- } else {
- my($method,$action, at other) =
- rearrange([METHOD,ACTION], at p);
- return $self->startform($method,$action,&MULTIPART, at other);
- }
-}
-END_OF_FUNC
-
-
-#### Method: endform
-# End a form
-'endform' => <<'END_OF_FUNC',
-sub endform {
- my($self, at p) = self_or_default(@_);
- if ( $NOSTICKY ) {
- return wantarray ? ("</form>") : "\n</form>";
- } else {
- if (my @fields = $self->get_fields) {
- return wantarray ? ("<div>", at fields,"</div>","</form>")
- : "<div>".(join '', at fields)."</div>\n</form>";
- } else {
- return "</form>";
- }
- }
-}
-END_OF_FUNC
-
-
-'_textfield' => <<'END_OF_FUNC',
-sub _textfield {
- my($self,$tag, at p) = self_or_default(@_);
- my($name,$default,$size,$maxlength,$override,$tabindex, at other) =
- rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX], at p);
-
- my $current = $override ? $default :
- (defined($self->param($name)) ? $self->param($name) : $default);
-
- $current = defined($current) ? $self->escapeHTML($current,1) : '';
- $name = defined($name) ? $self->escapeHTML($name) : '';
- my($s) = defined($size) ? qq/ size="$size"/ : '';
- my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
- my($other) = @other ? " @other" : '';
- # this entered at cristy's request to fix problems with file upload fields
- # and WebTV -- not sure it won't break stuff
- my($value) = $current ne '' ? qq(value="$current") : '';
- $tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
- : qq(<input type="$tag" name="$name" $value$s$m$other>);
-}
-END_OF_FUNC
-
-#### Method: textfield
-# Parameters:
-# $name -> Name of the text field
-# $default -> Optional default value of the field if not
-# already defined.
-# $size -> Optional width of field in characaters.
-# $maxlength -> Optional maximum number of characters.
-# Returns:
-# A string containing a <input type="text"> field
-#
-'textfield' => <<'END_OF_FUNC',
-sub textfield {
- my($self, at p) = self_or_default(@_);
- $self->_textfield('text', at p);
-}
-END_OF_FUNC
-
-
-#### Method: filefield
-# Parameters:
-# $name -> Name of the file upload field
-# $size -> Optional width of field in characaters.
-# $maxlength -> Optional maximum number of characters.
-# Returns:
-# A string containing a <input type="file"> field
-#
-'filefield' => <<'END_OF_FUNC',
-sub filefield {
- my($self, at p) = self_or_default(@_);
- $self->_textfield('file', at p);
-}
-END_OF_FUNC
-
-
-#### Method: password
-# Create a "secret password" entry field
-# Parameters:
-# $name -> Name of the field
-# $default -> Optional default value of the field if not
-# already defined.
-# $size -> Optional width of field in characters.
-# $maxlength -> Optional maximum characters that can be entered.
-# Returns:
-# A string containing a <input type="password"> field
-#
-'password_field' => <<'END_OF_FUNC',
-sub password_field {
- my ($self, at p) = self_or_default(@_);
- $self->_textfield('password', at p);
-}
-END_OF_FUNC
-
-#### Method: textarea
-# Parameters:
-# $name -> Name of the text field
-# $default -> Optional default value of the field if not
-# already defined.
-# $rows -> Optional number of rows in text area
-# $columns -> Optional number of columns in text area
-# Returns:
-# A string containing a <textarea></textarea> tag
-#
-'textarea' => <<'END_OF_FUNC',
-sub textarea {
- my($self, at p) = self_or_default(@_);
- my($name,$default,$rows,$cols,$override,$tabindex, at other) =
- rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX], at p);
-
- my($current)= $override ? $default :
- (defined($self->param($name)) ? $self->param($name) : $default);
-
- $name = defined($name) ? $self->escapeHTML($name) : '';
- $current = defined($current) ? $self->escapeHTML($current) : '';
- my($r) = $rows ? qq/ rows="$rows"/ : '';
- my($c) = $cols ? qq/ cols="$cols"/ : '';
- my($other) = @other ? " @other" : '';
- $tabindex = $self->element_tab($tabindex);
- return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
-}
-END_OF_FUNC
-
-
-#### Method: button
-# Create a javascript button.
-# Parameters:
-# $name -> (optional) Name for the button. (-name)
-# $value -> (optional) Value of the button when selected (and visible name) (-value)
-# $onclick -> (optional) Text of the JavaScript to run when the button is
-# clicked.
-# Returns:
-# A string containing a <input type="button"> tag
-####
-'button' => <<'END_OF_FUNC',
-sub button {
- my($self, at p) = self_or_default(@_);
-
- my($label,$value,$script,$tabindex, at other) = rearrange([NAME,[VALUE,LABEL],
- [ONCLICK,SCRIPT],TABINDEX], at p);
-
- $label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value,1);
- $script=$self->escapeHTML($script);
-
- my($name) = '';
- $name = qq/ name="$label"/ if $label;
- $value = $value || $label;
- my($val) = '';
- $val = qq/ value="$value"/ if $value;
- $script = qq/ onclick="$script"/ if $script;
- my($other) = @other ? " @other" : '';
- $tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
- : qq(<input type="button"$name$val$script$other>);
-}
-END_OF_FUNC
-
-
-#### Method: submit
-# Create a "submit query" button.
-# Parameters:
-# $name -> (optional) Name for the button.
-# $value -> (optional) Value of the button when selected (also doubles as label).
-# $label -> (optional) Label printed on the button(also doubles as the value).
-# Returns:
-# A string containing a <input type="submit"> tag
-####
-'submit' => <<'END_OF_FUNC',
-sub submit {
- my($self, at p) = self_or_default(@_);
-
- my($label,$value,$tabindex, at other) = rearrange([NAME,[VALUE,LABEL],TABINDEX], at p);
-
- $label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value,1);
-
- my $name = $NOSTICKY ? '' : 'name=".submit" ';
- $name = qq/name="$label" / if defined($label);
- $value = defined($value) ? $value : $label;
- my $val = '';
- $val = qq/value="$value" / if defined($value);
- $tabindex = $self->element_tab($tabindex);
- my($other) = @other ? "@other " : '';
- return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
- : qq(<input type="submit" $name$val$other>);
-}
-END_OF_FUNC
-
-
-#### Method: reset
-# Create a "reset" button.
-# Parameters:
-# $name -> (optional) Name for the button.
-# Returns:
-# A string containing a <input type="reset"> tag
-####
-'reset' => <<'END_OF_FUNC',
-sub reset {
- my($self, at p) = self_or_default(@_);
- my($label,$value,$tabindex, at other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX], at p);
- $label=$self->escapeHTML($label);
- $value=$self->escapeHTML($value,1);
- my ($name) = ' name=".reset"';
- $name = qq/ name="$label"/ if defined($label);
- $value = defined($value) ? $value : $label;
- my($val) = '';
- $val = qq/ value="$value"/ if defined($value);
- my($other) = @other ? " @other" : '';
- $tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
- : qq(<input type="reset"$name$val$other>);
-}
-END_OF_FUNC
-
-
-#### Method: defaults
-# Create a "defaults" button.
-# Parameters:
-# $name -> (optional) Name for the button.
-# Returns:
-# A string containing a <input type="submit" name=".defaults"> tag
-#
-# Note: this button has a special meaning to the initialization script,
-# and tells it to ERASE the current query string so that your defaults
-# are used again!
-####
-'defaults' => <<'END_OF_FUNC',
-sub defaults {
- my($self, at p) = self_or_default(@_);
-
- my($label,$tabindex, at other) = rearrange([[NAME,VALUE],TABINDEX], at p);
-
- $label=$self->escapeHTML($label,1);
- $label = $label || "Defaults";
- my($value) = qq/ value="$label"/;
- my($other) = @other ? " @other" : '';
- $tabindex = $self->element_tab($tabindex);
- return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
- : qq/<input type="submit" NAME=".defaults"$value$other>/;
-}
-END_OF_FUNC
-
-
-#### Method: comment
-# Create an HTML <!-- comment -->
-# Parameters: a string
-'comment' => <<'END_OF_FUNC',
-sub comment {
- my($self, at p) = self_or_CGI(@_);
- return "<!-- @p -->";
-}
-END_OF_FUNC
-
-#### Method: checkbox
-# Create a checkbox that is not logically linked to any others.
-# The field value is "on" when the button is checked.
-# Parameters:
-# $name -> Name of the checkbox
-# $checked -> (optional) turned on by default if true
-# $value -> (optional) value of the checkbox, 'on' by default
-# $label -> (optional) a user-readable label printed next to the box.
-# Otherwise the checkbox name is used.
-# Returns:
-# A string containing a <input type="checkbox"> field
-####
-'checkbox' => <<'END_OF_FUNC',
-sub checkbox {
- my($self, at p) = self_or_default(@_);
-
- my($name,$checked,$value,$label,$labelattributes,$override,$tabindex, at other) =
- rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
- [OVERRIDE,FORCE],TABINDEX], at p);
-
- $value = defined $value ? $value : 'on';
-
- if (!$override && ($self->{'.fieldnames'}->{$name} ||
- defined $self->param($name))) {
- $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
- } else {
- $checked = $self->_checked($checked);
- }
- my($the_label) = defined $label ? $label : $name;
- $name = $self->escapeHTML($name);
- $value = $self->escapeHTML($value,1);
- $the_label = $self->escapeHTML($the_label);
- my($other) = @other ? "@other " : '';
- $tabindex = $self->element_tab($tabindex);
- $self->register_parameter($name);
- return $XHTML ? CGI::label($labelattributes,
- qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
- : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
-}
-END_OF_FUNC
-
-
-
-# Escape HTML -- used internally
-'escapeHTML' => <<'END_OF_FUNC',
-sub escapeHTML {
- # hack to work around earlier hacks
- push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
- my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
- return undef unless defined($toencode);
- return $toencode if ref($self) && !$self->{'escape'};
- $toencode =~ s{&}{&}gso;
- $toencode =~ s{<}{<}gso;
- $toencode =~ s{>}{>}gso;
- if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
- # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
- # <http://validator.w3.org/docs/errors.html#bad-entity> /
- # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
- $toencode =~ s{"}{"}gso;
- }
- else {
- $toencode =~ s{"}{"}gso;
- }
- # Handle bug in some browsers with Latin charsets
- if ($self->{'.charset'} &&
- (uc($self->{'.charset'}) eq 'ISO-8859-1' ||
- uc($self->{'.charset'}) eq 'WINDOWS-1252'))
- {
- $toencode =~ s{'}{'}gso;
- $toencode =~ s{\x8b}{‹}gso;
- $toencode =~ s{\x9b}{›}gso;
- if (defined $newlinestoo && $newlinestoo) {
- $toencode =~ s{\012}{
}gso;
- $toencode =~ s{\015}{
}gso;
- }
- }
- return $toencode;
-}
-END_OF_FUNC
-
-# unescape HTML -- used internally
-'unescapeHTML' => <<'END_OF_FUNC',
-sub unescapeHTML {
- # hack to work around earlier hacks
- push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
- my ($self,$string) = CGI::self_or_default(@_);
- return undef unless defined($string);
- my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
- : 1;
- # thanks to Randal Schwartz for the correct solution to this one
- $string=~ s[&(.*?);]{
- local $_ = $1;
- /^amp$/i ? "&" :
- /^quot$/i ? '"' :
- /^gt$/i ? ">" :
- /^lt$/i ? "<" :
- /^#(\d+)$/ && $latin ? chr($1) :
- /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
- $_
- }gex;
- return $string;
-}
-END_OF_FUNC
-
-# Internal procedure - don't use
-'_tableize' => <<'END_OF_FUNC',
-sub _tableize {
- my($rows,$columns,$rowheaders,$colheaders, at elements) = @_;
- my @rowheaders = $rowheaders ? @$rowheaders : ();
- my @colheaders = $colheaders ? @$colheaders : ();
- my($result);
-
- if (defined($columns)) {
- $rows = int(0.99 + @elements/$columns) unless defined($rows);
- }
- if (defined($rows)) {
- $columns = int(0.99 + @elements/$rows) unless defined($columns);
- }
-
- # rearrange into a pretty table
- $result = "<table>";
- my($row,$column);
- unshift(@colheaders,'') if @colheaders && @rowheaders;
- $result .= "<tr>" if @colheaders;
- for (@colheaders) {
- $result .= "<th>$_</th>";
- }
- for ($row=0;$row<$rows;$row++) {
- $result .= "<tr>";
- $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
- for ($column=0;$column<$columns;$column++) {
- $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
- if defined($elements[$column*$rows + $row]);
- }
- $result .= "</tr>";
- }
- $result .= "</table>";
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: radio_group
-# Create a list of logically-linked radio buttons.
-# Parameters:
-# $name -> Common name for all the buttons.
-# $values -> A pointer to a regular array containing the
-# values for each button in the group.
-# $default -> (optional) Value of the button to turn on by default. Pass '-'
-# to turn _nothing_ on.
-# $linebreak -> (optional) Set to true to place linebreaks
-# between the buttons.
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# An ARRAY containing a series of <input type="radio"> fields
-####
-'radio_group' => <<'END_OF_FUNC',
-sub radio_group {
- my($self, at p) = self_or_default(@_);
- $self->_box_group('radio', at p);
-}
-END_OF_FUNC
-
-#### Method: checkbox_group
-# Create a list of logically-linked checkboxes.
-# Parameters:
-# $name -> Common name for all the check boxes
-# $values -> A pointer to a regular array containing the
-# values for each checkbox in the group.
-# $defaults -> (optional)
-# 1. If a pointer to a regular array of checkbox values,
-# then this will be used to decide which
-# checkboxes to turn on by default.
-# 2. If a scalar, will be assumed to hold the
-# value of a single checkbox in the group to turn on.
-# $linebreak -> (optional) Set to true to place linebreaks
-# between the buttons.
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# An ARRAY containing a series of <input type="checkbox"> fields
-####
-
-'checkbox_group' => <<'END_OF_FUNC',
-sub checkbox_group {
- my($self, at p) = self_or_default(@_);
- $self->_box_group('checkbox', at p);
-}
-END_OF_FUNC
-
-'_box_group' => <<'END_OF_FUNC',
-sub _box_group {
- my $self = shift;
- my $box_type = shift;
-
- my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
- $attributes,$rows,$columns,$rowheaders,$colheaders,
- $override,$nolabels,$tabindex,$disabled, at other) =
- rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
- ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
- [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
- ], at _);
-
-
- my($result,$checked, at elements, at values);
-
- @values = $self->_set_values_and_labels($values,\$labels,$name);
- my %checked = $self->previous_or_default($name,$defaults,$override);
-
- # If no check array is specified, check the first by default
- $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
-
- $name=$self->escapeHTML($name);
-
- my %tabs = ();
- if ($TABINDEX && $tabindex) {
- if (!ref $tabindex) {
- $self->element_tab($tabindex);
- } elsif (ref $tabindex eq 'ARRAY') {
- %tabs = map {$_=>$self->element_tab} @$tabindex;
- } elsif (ref $tabindex eq 'HASH') {
- %tabs = %$tabindex;
- }
- }
- %tabs = map {$_=>$self->element_tab} @values unless %tabs;
- my $other = @other ? "@other " : '';
- my $radio_checked;
-
- # for disabling groups of radio/checkbox buttons
- my %disabled;
- for (@{$disabled}) {
- $disabled{$_}=1;
- }
-
- for (@values) {
- my $disable="";
- if ($disabled{$_}) {
- $disable="disabled='1'";
- }
-
- my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
- : $checked{$_});
- my($break);
- if ($linebreak) {
- $break = $XHTML ? "<br />" : "<br>";
- }
- else {
- $break = '';
- }
- my($label)='';
- unless (defined($nolabels) && $nolabels) {
- $label = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label = $self->escapeHTML($label,1);
- $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
- }
- my $attribs = $self->_set_attributes($_, $attributes);
- my $tab = $tabs{$_};
- $_=$self->escapeHTML($_);
-
- if ($XHTML) {
- push @elements,
- CGI::label($labelattributes,
- qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
- } else {
- push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/);
- }
- }
- $self->register_parameter($name);
- return wantarray ? @elements : "@elements"
- unless defined($columns) || defined($rows);
- return _tableize($rows,$columns,$rowheaders,$colheaders, at elements);
-}
-END_OF_FUNC
-
-
-#### Method: popup_menu
-# Create a popup menu.
-# Parameters:
-# $name -> Name for all the menu
-# $values -> A pointer to a regular array containing the
-# text of each menu item.
-# $default -> (optional) Default item to display
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# A string containing the definition of a popup menu.
-####
-'popup_menu' => <<'END_OF_FUNC',
-sub popup_menu {
- my($self, at p) = self_or_default(@_);
-
- my($name,$values,$default,$labels,$attributes,$override,$tabindex, at other) =
- rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
- ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX], at p);
- my($result,%selected);
-
- if (!$override && defined($self->param($name))) {
- $selected{$self->param($name)}++;
- } elsif (defined $default) {
- %selected = map {$_=>1} ref($default) eq 'ARRAY'
- ? @$default
- : $default;
- }
- $name=$self->escapeHTML($name);
- my($other) = @other ? " @other" : '';
-
- my(@values);
- @values = $self->_set_values_and_labels($values,\$labels,$name);
- $tabindex = $self->element_tab($tabindex);
- $result = qq/<select name="$name" $tabindex$other>\n/;
- for (@values) {
- if (/<optgroup/) {
- for my $v (split(/\n/)) {
- my $selectit = $XHTML ? 'selected="selected"' : 'selected';
- for my $selected (keys %selected) {
- $v =~ s/(value="$selected")/$selectit $1/;
- }
- $result .= "$v\n";
- }
- }
- else {
- my $attribs = $self->_set_attributes($_, $attributes);
- my($selectit) = $self->_selected($selected{$_});
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- my($value) = $self->escapeHTML($_);
- $label = $self->escapeHTML($label,1);
- $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
- }
- }
-
- $result .= "</select>";
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: optgroup
-# Create a optgroup.
-# Parameters:
-# $name -> Label for the group
-# $values -> A pointer to a regular array containing the
-# values for each option line in the group.
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each item
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# $labeled -> (optional)
-# A true value indicates the value should be used as the label attribute
-# in the option elements.
-# The label attribute specifies the option label presented to the user.
-# This defaults to the content of the <option> element, but the label
-# attribute allows authors to more easily use optgroup without sacrificing
-# compatibility with browsers that do not support option groups.
-# $novals -> (optional)
-# A true value indicates to suppress the val attribute in the option elements
-# Returns:
-# A string containing the definition of an option group.
-####
-'optgroup' => <<'END_OF_FUNC',
-sub optgroup {
- my($self, at p) = self_or_default(@_);
- my($name,$values,$attributes,$labeled,$noval,$labels, at other)
- = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS], at p);
-
- my($result, at values);
- @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
- my($other) = @other ? " @other" : '';
-
- $name=$self->escapeHTML($name);
- $result = qq/<optgroup label="$name"$other>\n/;
- for (@values) {
- if (/<optgroup/) {
- for (split(/\n/)) {
- my $selectit = $XHTML ? 'selected="selected"' : 'selected';
- s/(value="$selected")/$selectit $1/ if defined $selected;
- $result .= "$_\n";
- }
- }
- else {
- my $attribs = $self->_set_attributes($_, $attributes);
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label=$self->escapeHTML($label);
- my($value)=$self->escapeHTML($_,1);
- $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
- : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
- : $novals ? "<option$attribs>$label</option>\n"
- : "<option$attribs value=\"$value\">$label</option>\n";
- }
- }
- $result .= "</optgroup>";
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: scrolling_list
-# Create a scrolling list.
-# Parameters:
-# $name -> name for the list
-# $values -> A pointer to a regular array containing the
-# values for each option line in the list.
-# $defaults -> (optional)
-# 1. If a pointer to a regular array of options,
-# then this will be used to decide which
-# lines to turn on by default.
-# 2. Otherwise holds the value of the single line to turn on.
-# $size -> (optional) Size of the list.
-# $multiple -> (optional) If set, allow multiple selections.
-# $labels -> (optional)
-# A pointer to a hash of labels to print next to each checkbox
-# in the form $label{'value'}="Long explanatory label".
-# Otherwise the provided values are used as the labels.
-# Returns:
-# A string containing the definition of a scrolling list.
-####
-'scrolling_list' => <<'END_OF_FUNC',
-sub scrolling_list {
- my($self, at p) = self_or_default(@_);
- my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex, at other)
- = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
- SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX], at p);
-
- my($result, at values);
- @values = $self->_set_values_and_labels($values,\$labels,$name);
-
- $size = $size || scalar(@values);
-
- my(%selected) = $self->previous_or_default($name,$defaults,$override);
-
- my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
- my($has_size) = $size ? qq/ size="$size"/: '';
- my($other) = @other ? " @other" : '';
-
- $name=$self->escapeHTML($name);
- $tabindex = $self->element_tab($tabindex);
- $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
- for (@values) {
- my($selectit) = $self->_selected($selected{$_});
- my($label) = $_;
- $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
- $label=$self->escapeHTML($label);
- my($value)=$self->escapeHTML($_,1);
- my $attribs = $self->_set_attributes($_, $attributes);
- $result .= "<option ${selectit}${attribs}value=\"$value\">$label</option>\n";
- }
- $result .= "</select>";
- $self->register_parameter($name);
- return $result;
-}
-END_OF_FUNC
-
-
-#### Method: hidden
-# Parameters:
-# $name -> Name of the hidden field
-# @default -> (optional) Initial values of field (may be an array)
-# or
-# $default->[initial values of field]
-# Returns:
-# A string containing a <input type="hidden" name="name" value="value">
-####
-'hidden' => <<'END_OF_FUNC',
-sub hidden {
- my($self, at p) = self_or_default(@_);
-
- # this is the one place where we departed from our standard
- # calling scheme, so we have to special-case (darn)
- my(@result, at value);
- my($name,$default,$override, at other) =
- rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]], at p);
-
- my $do_override = 0;
- if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
- @value = ref($default) ? @{$default} : $default;
- $do_override = $override;
- } else {
- for ($default,$override, at other) {
- push(@value,$_) if defined($_);
- }
- }
-
- # use previous values if override is not set
- my @prev = $self->param($name);
- @value = @prev if !$do_override && @prev;
-
- $name=$self->escapeHTML($name);
- for (@value) {
- $_ = defined($_) ? $self->escapeHTML($_,1) : '';
- push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
- : qq(<input type="hidden" name="$name" value="$_" @other>);
- }
- return wantarray ? @result : join('', at result);
-}
-END_OF_FUNC
-
-
-#### Method: image_button
-# Parameters:
-# $name -> Name of the button
-# $src -> URL of the image source
-# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
-# Returns:
-# A string containing a <input type="image" name="name" src="url" align="alignment">
-####
-'image_button' => <<'END_OF_FUNC',
-sub image_button {
- my($self, at p) = self_or_default(@_);
-
- my($name,$src,$alignment, at other) =
- rearrange([NAME,SRC,ALIGN], at p);
-
- my($align) = $alignment ? " align=\L\"$alignment\"" : '';
- my($other) = @other ? " @other" : '';
- $name=$self->escapeHTML($name);
- return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
- : qq/<input type="image" name="$name" src="$src"$align$other>/;
-}
-END_OF_FUNC
-
-
-#### Method: self_url
-# Returns a URL containing the current script and all its
-# param/value pairs arranged as a query. You can use this
-# to create a link that, when selected, will reinvoke the
-# script with all its state information preserved.
-####
-'self_url' => <<'END_OF_FUNC',
-sub self_url {
- my($self, at p) = self_or_default(@_);
- return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1, at p);
-}
-END_OF_FUNC
-
-
-# This is provided as a synonym to self_url() for people unfortunate
-# enough to have incorporated it into their programs already!
-'state' => <<'END_OF_FUNC',
-sub state {
- &self_url;
-}
-END_OF_FUNC
-
-
-#### Method: url
-# Like self_url, but doesn't return the query string part of
-# the URL.
-####
-'url' => <<'END_OF_FUNC',
-sub url {
- my($self, at p) = self_or_default(@_);
- my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
- rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'], at p);
- my $url = '';
- $full++ if $base || !($relative || $absolute);
- $rewrite++ unless defined $rewrite;
-
- my $path = $self->path_info;
- my $script_name = $self->script_name;
- my $request_uri = unescape($self->request_uri) || '';
- my $query_str = $self->query_string;
-
- my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
- undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
-
- my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
- $uri =~ s/\?.*$//s; # remove query string
- $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO};
-# $uri =~ s/\Q$path\E$// if defined $path; # remove path
-
- if ($full) {
- my $protocol = $self->protocol();
- $url = "$protocol://";
- my $vh = http('x_forwarded_host') || http('host') || '';
- $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
- if ($vh) {
- $url .= $vh;
- } else {
- $url .= server_name();
- }
- my $port = $self->server_port;
- $url .= ":" . $port
- unless (lc($protocol) eq 'http' && $port == 80)
- || (lc($protocol) eq 'https' && $port == 443);
- return $url if $base;
- $url .= $uri;
- } elsif ($relative) {
- ($url) = $uri =~ m!([^/]+)$!;
- } elsif ($absolute) {
- $url = $uri;
- }
-
- $url .= $path if $path_info and defined $path;
- $url .= "?$query_str" if $query and $query_str ne '';
- $url ||= '';
- $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
- return $url;
-}
-
-END_OF_FUNC
-
-#### Method: cookie
-# Set or read a cookie from the specified name.
-# Cookie can then be passed to header().
-# Usual rules apply to the stickiness of -value.
-# Parameters:
-# -name -> name for this cookie (optional)
-# -value -> value of this cookie (scalar, array or hash)
-# -path -> paths for which this cookie is valid (optional)
-# -domain -> internet domain in which this cookie is valid (optional)
-# -secure -> if true, cookie only passed through secure channel (optional)
-# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
-####
-'cookie' => <<'END_OF_FUNC',
-sub cookie {
- my($self, at p) = self_or_default(@_);
- my($name,$value,$path,$domain,$secure,$expires,$httponly) =
- rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY], at p);
-
- require CGI::Cookie;
-
- # if no value is supplied, then we retrieve the
- # value of the cookie, if any. For efficiency, we cache the parsed
- # cookies in our state variables.
- unless ( defined($value) ) {
- $self->{'.cookies'} = CGI::Cookie->fetch
- unless $self->{'.cookies'};
-
- # If no name is supplied, then retrieve the names of all our cookies.
- return () unless $self->{'.cookies'};
- return keys %{$self->{'.cookies'}} unless $name;
- return () unless $self->{'.cookies'}->{$name};
- return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
- }
-
- # If we get here, we're creating a new cookie
- return undef unless defined($name) && $name ne ''; # this is an error
-
- my @param;
- push(@param,'-name'=>$name);
- push(@param,'-value'=>$value);
- push(@param,'-domain'=>$domain) if $domain;
- push(@param,'-path'=>$path) if $path;
- push(@param,'-expires'=>$expires) if $expires;
- push(@param,'-secure'=>$secure) if $secure;
- push(@param,'-httponly'=>$httponly) if $httponly;
-
- return new CGI::Cookie(@param);
-}
-END_OF_FUNC
-
-'parse_keywordlist' => <<'END_OF_FUNC',
-sub parse_keywordlist {
- my($self,$tosplit) = @_;
- $tosplit = unescape($tosplit); # unescape the keywords
- $tosplit=~tr/+/ /; # pluses to spaces
- my(@keywords) = split(/\s+/,$tosplit);
- return @keywords;
-}
-END_OF_FUNC
-
-'param_fetch' => <<'END_OF_FUNC',
-sub param_fetch {
- my($self, at p) = self_or_default(@_);
- my($name) = rearrange([NAME], at p);
- unless (exists($self->{param}{$name})) {
- $self->add_parameter($name);
- $self->{param}{$name} = [];
- }
-
- return $self->{param}{$name};
-}
-END_OF_FUNC
-
-###############################################
-# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
-###############################################
-
-#### Method: path_info
-# Return the extra virtual path information provided
-# after the URL (if any)
-####
-'path_info' => <<'END_OF_FUNC',
-sub path_info {
- my ($self,$info) = self_or_default(@_);
- if (defined($info)) {
- $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
- $self->{'.path_info'} = $info;
- } elsif (! defined($self->{'.path_info'}) ) {
- my (undef,$path_info) = $self->_name_and_path_from_env;
- $self->{'.path_info'} = $path_info || '';
- }
- return $self->{'.path_info'};
-}
-END_OF_FUNC
-
-# This function returns a potentially modified version of SCRIPT_NAME
-# and PATH_INFO. Some HTTP servers do sanitise the paths in those
-# variables. It is the case of at least Apache 2. If for instance the
-# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
-# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
-# SCRIPT_NAME=/path/to/env.cgi
-# PATH_INFO=/x/y/x
-#
-# This is all fine except that some bogus CGI scripts expect
-# PATH_INFO=/http://foo when the user requests
-# http://xxx/script.cgi/http://foo
-#
-# Old versions of this module used to accomodate with those scripts, so
-# this is why we do this here to keep those scripts backward compatible.
-# Basically, we accomodate with those scripts but within limits, that is
-# we only try to preserve the number of / that were provided by the user
-# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
-# of consecutive /.
-#
-# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
-# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
-# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
-# possibly sanitised by the HTTP server, so in the case of Apache 2:
-# script_name == /foo/x/z/script.cgi and path_info == /b/c.
-#
-# Future versions of this module may no longer do that, so one should
-# avoid relying on the browser, proxy, server, and CGI.pm preserving the
-# number of consecutive slashes as no guarantee can be made there.
-'_name_and_path_from_env' => <<'END_OF_FUNC',
-sub _name_and_path_from_env {
- my $self = shift;
- my $script_name = $ENV{SCRIPT_NAME} || '';
- my $path_info = $ENV{PATH_INFO} || '';
- my $uri = $self->request_uri || '';
-
- $uri =~ s/\?.*//s;
- $uri = unescape($uri);
-
- if ($uri ne "$script_name$path_info") {
- my $script_name_pattern = quotemeta($script_name);
- my $path_info_pattern = quotemeta($path_info);
- $script_name_pattern =~ s{(?:\\/)+}{/+}g;
- $path_info_pattern =~ s{(?:\\/)+}{/+}g;
-
- if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
- # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
- # numer of consecutive slashes, so we can extract the info from
- # REQUEST_URI:
- ($script_name, $path_info) = ($1, $2);
- }
- }
- return ($script_name,$path_info);
-}
-END_OF_FUNC
-
-
-#### Method: request_method
-# Returns 'POST', 'GET', 'PUT' or 'HEAD'
-####
-'request_method' => <<'END_OF_FUNC',
-sub request_method {
- return $ENV{'REQUEST_METHOD'};
-}
-END_OF_FUNC
-
-#### Method: content_type
-# Returns the content_type string
-####
-'content_type' => <<'END_OF_FUNC',
-sub content_type {
- return $ENV{'CONTENT_TYPE'};
-}
-END_OF_FUNC
-
-#### Method: path_translated
-# Return the physical path information provided
-# by the URL (if any)
-####
-'path_translated' => <<'END_OF_FUNC',
-sub path_translated {
- return $ENV{'PATH_TRANSLATED'};
-}
-END_OF_FUNC
-
-
-#### Method: request_uri
-# Return the literal request URI
-####
-'request_uri' => <<'END_OF_FUNC',
-sub request_uri {
- return $ENV{'REQUEST_URI'};
-}
-END_OF_FUNC
-
-
-#### Method: query_string
-# Synthesize a query string from our current
-# parameters
-####
-'query_string' => <<'END_OF_FUNC',
-sub query_string {
- my($self) = self_or_default(@_);
- my($param,$value, at pairs);
- for $param ($self->param) {
- my($eparam) = escape($param);
- for $value ($self->param($param)) {
- $value = escape($value);
- next unless defined $value;
- push(@pairs,"$eparam=$value");
- }
- }
- for (keys %{$self->{'.fieldnames'}}) {
- push(@pairs,".cgifields=".escape("$_"));
- }
- return join($USE_PARAM_SEMICOLONS ? ';' : '&', at pairs);
-}
-END_OF_FUNC
-
-
-#### Method: accept
-# Without parameters, returns an array of the
-# MIME types the browser accepts.
-# With a single parameter equal to a MIME
-# type, will return undef if the browser won't
-# accept it, 1 if the browser accepts it but
-# doesn't give a preference, or a floating point
-# value between 0.0 and 1.0 if the browser
-# declares a quantitative score for it.
-# This handles MIME type globs correctly.
-####
-'Accept' => <<'END_OF_FUNC',
-sub Accept {
- my($self,$search) = self_or_CGI(@_);
- my(%prefs,$type,$pref,$pat);
-
- my(@accept) = defined $self->http('accept')
- ? split(',',$self->http('accept'))
- : ();
-
- for (@accept) {
- ($pref) = /q=(\d\.\d+|\d+)/;
- ($type) = m#(\S+/[^;]+)#;
- next unless $type;
- $prefs{$type}=$pref || 1;
- }
-
- return keys %prefs unless $search;
-
- # if a search type is provided, we may need to
- # perform a pattern matching operation.
- # The MIME types use a glob mechanism, which
- # is easily translated into a perl pattern match
-
- # First return the preference for directly supported
- # types:
- return $prefs{$search} if $prefs{$search};
-
- # Didn't get it, so try pattern matching.
- for (keys %prefs) {
- next unless /\*/; # not a pattern match
- ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
- $pat =~ s/\*/.*/g; # turn it into a pattern
- return $prefs{$_} if $search=~/$pat/;
- }
-}
-END_OF_FUNC
-
-
-#### Method: user_agent
-# If called with no parameters, returns the user agent.
-# If called with one parameter, does a pattern match (case
-# insensitive) on the user agent.
-####
-'user_agent' => <<'END_OF_FUNC',
-sub user_agent {
- my($self,$match)=self_or_CGI(@_);
- return $self->http('user_agent') unless $match;
- return $self->http('user_agent') =~ /$match/i;
-}
-END_OF_FUNC
-
-
-#### Method: raw_cookie
-# Returns the magic cookies for the session.
-# The cookies are not parsed or altered in any way, i.e.
-# cookies are returned exactly as given in the HTTP
-# headers. If a cookie name is given, only that cookie's
-# value is returned, otherwise the entire raw cookie
-# is returned.
-####
-'raw_cookie' => <<'END_OF_FUNC',
-sub raw_cookie {
- my($self,$key) = self_or_CGI(@_);
-
- require CGI::Cookie;
-
- if (defined($key)) {
- $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
- unless $self->{'.raw_cookies'};
-
- return () unless $self->{'.raw_cookies'};
- return () unless $self->{'.raw_cookies'}->{$key};
- return $self->{'.raw_cookies'}->{$key};
- }
- return $self->http('cookie') || $ENV{'COOKIE'} || '';
-}
-END_OF_FUNC
-
-#### Method: virtual_host
-# Return the name of the virtual_host, which
-# is not always the same as the server
-######
-'virtual_host' => <<'END_OF_FUNC',
-sub virtual_host {
- my $vh = http('x_forwarded_host') || http('host') || server_name();
- $vh =~ s/:\d+$//; # get rid of port number
- return $vh;
-}
-END_OF_FUNC
-
-#### Method: remote_host
-# Return the name of the remote host, or its IP
-# address if unavailable. If this variable isn't
-# defined, it returns "localhost" for debugging
-# purposes.
-####
-'remote_host' => <<'END_OF_FUNC',
-sub remote_host {
- return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
- || 'localhost';
-}
-END_OF_FUNC
-
-
-#### Method: remote_addr
-# Return the IP addr of the remote host.
-####
-'remote_addr' => <<'END_OF_FUNC',
-sub remote_addr {
- return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
-}
-END_OF_FUNC
-
-
-#### Method: script_name
-# Return the partial URL to this script for
-# self-referencing scripts. Also see
-# self_url(), which returns a URL with all state information
-# preserved.
-####
-'script_name' => <<'END_OF_FUNC',
-sub script_name {
- my ($self, at p) = self_or_default(@_);
- if (@p) {
- $self->{'.script_name'} = shift @p;
- } elsif (!exists $self->{'.script_name'}) {
- my ($script_name,$path_info) = $self->_name_and_path_from_env();
- $self->{'.script_name'} = $script_name;
- }
- return $self->{'.script_name'};
-}
-END_OF_FUNC
-
-
-#### Method: referer
-# Return the HTTP_REFERER: useful for generating
-# a GO BACK button.
-####
-'referer' => <<'END_OF_FUNC',
-sub referer {
- my($self) = self_or_CGI(@_);
- return $self->http('referer');
-}
-END_OF_FUNC
-
-
-#### Method: server_name
-# Return the name of the server
-####
-'server_name' => <<'END_OF_FUNC',
-sub server_name {
- return $ENV{'SERVER_NAME'} || 'localhost';
-}
-END_OF_FUNC
-
-#### Method: server_software
-# Return the name of the server software
-####
-'server_software' => <<'END_OF_FUNC',
-sub server_software {
- return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
-}
-END_OF_FUNC
-
-#### Method: virtual_port
-# Return the server port, taking virtual hosts into account
-####
-'virtual_port' => <<'END_OF_FUNC',
-sub virtual_port {
- my($self) = self_or_default(@_);
- my $vh = $self->http('x_forwarded_host') || $self->http('host');
- my $protocol = $self->protocol;
- if ($vh) {
- return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
- } else {
- return $self->server_port();
- }
-}
-END_OF_FUNC
-
-#### Method: server_port
-# Return the tcp/ip port the server is running on
-####
-'server_port' => <<'END_OF_FUNC',
-sub server_port {
- return $ENV{'SERVER_PORT'} || 80; # for debugging
-}
-END_OF_FUNC
-
-#### Method: server_protocol
-# Return the protocol (usually HTTP/1.0)
-####
-'server_protocol' => <<'END_OF_FUNC',
-sub server_protocol {
- return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
-}
-END_OF_FUNC
-
-#### Method: http
-# Return the value of an HTTP variable, or
-# the list of variables if none provided
-####
-'http' => <<'END_OF_FUNC',
-sub http {
- my ($self,$parameter) = self_or_CGI(@_);
- return $ENV{$parameter} if $parameter=~/^HTTP/;
- $parameter =~ tr/-/_/;
- return $ENV{"HTTP_\U$parameter\E"} if $parameter;
- my(@p);
- for (keys %ENV) {
- push(@p,$_) if /^HTTP/;
- }
- return @p;
-}
-END_OF_FUNC
-
-#### Method: https
-# Return the value of HTTPS
-####
-'https' => <<'END_OF_FUNC',
-sub https {
- local($^W)=0;
- my ($self,$parameter) = self_or_CGI(@_);
- return $ENV{HTTPS} unless $parameter;
- return $ENV{$parameter} if $parameter=~/^HTTPS/;
- $parameter =~ tr/-/_/;
- return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
- my(@p);
- for (keys %ENV) {
- push(@p,$_) if /^HTTPS/;
- }
- return @p;
-}
-END_OF_FUNC
-
-#### Method: protocol
-# Return the protocol (http or https currently)
-####
-'protocol' => <<'END_OF_FUNC',
-sub protocol {
- local($^W)=0;
- my $self = shift;
- return 'https' if uc($self->https()) eq 'ON';
- return 'https' if $self->server_port == 443;
- my $prot = $self->server_protocol;
- my($protocol,$version) = split('/',$prot);
- return "\L$protocol\E";
-}
-END_OF_FUNC
-
-#### Method: remote_ident
-# Return the identity of the remote user
-# (but only if his host is running identd)
-####
-'remote_ident' => <<'END_OF_FUNC',
-sub remote_ident {
- return $ENV{'REMOTE_IDENT'};
-}
-END_OF_FUNC
-
-
-#### Method: auth_type
-# Return the type of use verification/authorization in use, if any.
-####
-'auth_type' => <<'END_OF_FUNC',
-sub auth_type {
- return $ENV{'AUTH_TYPE'};
-}
-END_OF_FUNC
-
-
-#### Method: remote_user
-# Return the authorization name used for user
-# verification.
-####
-'remote_user' => <<'END_OF_FUNC',
-sub remote_user {
- return $ENV{'REMOTE_USER'};
-}
-END_OF_FUNC
-
-
-#### Method: user_name
-# Try to return the remote user's name by hook or by
-# crook
-####
-'user_name' => <<'END_OF_FUNC',
-sub user_name {
- my ($self) = self_or_CGI(@_);
- return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
-}
-END_OF_FUNC
-
-#### Method: nosticky
-# Set or return the NOSTICKY global flag
-####
-'nosticky' => <<'END_OF_FUNC',
-sub nosticky {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::NOSTICKY = $param if defined($param);
- return $CGI::NOSTICKY;
-}
-END_OF_FUNC
-
-#### Method: nph
-# Set or return the NPH global flag
-####
-'nph' => <<'END_OF_FUNC',
-sub nph {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::NPH = $param if defined($param);
- return $CGI::NPH;
-}
-END_OF_FUNC
-
-#### Method: private_tempfiles
-# Set or return the private_tempfiles global flag
-####
-'private_tempfiles' => <<'END_OF_FUNC',
-sub private_tempfiles {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::PRIVATE_TEMPFILES = $param if defined($param);
- return $CGI::PRIVATE_TEMPFILES;
-}
-END_OF_FUNC
-#### Method: close_upload_files
-# Set or return the close_upload_files global flag
-####
-'close_upload_files' => <<'END_OF_FUNC',
-sub close_upload_files {
- my ($self,$param) = self_or_CGI(@_);
- $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
- return $CGI::CLOSE_UPLOAD_FILES;
-}
-END_OF_FUNC
-
-
-#### Method: default_dtd
-# Set or return the default_dtd global
-####
-'default_dtd' => <<'END_OF_FUNC',
-sub default_dtd {
- my ($self,$param,$param2) = self_or_CGI(@_);
- if (defined $param2 && defined $param) {
- $CGI::DEFAULT_DTD = [ $param, $param2 ];
- } elsif (defined $param) {
- $CGI::DEFAULT_DTD = $param;
- }
- return $CGI::DEFAULT_DTD;
-}
-END_OF_FUNC
-
-# -------------- really private subroutines -----------------
-'previous_or_default' => <<'END_OF_FUNC',
-sub previous_or_default {
- my($self,$name,$defaults,$override) = @_;
- my(%selected);
-
- if (!$override && ($self->{'.fieldnames'}->{$name} ||
- defined($self->param($name)) ) ) {
- $selected{$_}++ for $self->param($name);
- } elsif (defined($defaults) && ref($defaults) &&
- (ref($defaults) eq 'ARRAY')) {
- $selected{$_}++ for @{$defaults};
- } else {
- $selected{$defaults}++ if defined($defaults);
- }
-
- return %selected;
-}
-END_OF_FUNC
-
-'register_parameter' => <<'END_OF_FUNC',
-sub register_parameter {
- my($self,$param) = @_;
- $self->{'.parametersToAdd'}->{$param}++;
-}
-END_OF_FUNC
-
-'get_fields' => <<'END_OF_FUNC',
-sub get_fields {
- my($self) = @_;
- return $self->CGI::hidden('-name'=>'.cgifields',
- '-values'=>[keys %{$self->{'.parametersToAdd'}}],
- '-override'=>1);
-}
-END_OF_FUNC
-
-'read_from_cmdline' => <<'END_OF_FUNC',
-sub read_from_cmdline {
- my($input, at words);
- my($query_string);
- my($subpath);
- if ($DEBUG && @ARGV) {
- @words = @ARGV;
- } elsif ($DEBUG > 1) {
- require "shellwords.pl";
- print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
- chomp(@lines = <STDIN>); # remove newlines
- $input = join(" ", at lines);
- @words = &shellwords($input);
- }
- for (@words) {
- s/\\=/%3D/g;
- s/\\&/%26/g;
- }
-
- if ("@words"=~/=/) {
- $query_string = join('&', at words);
- } else {
- $query_string = join('+', at words);
- }
- if ($query_string =~ /^(.*?)\?(.*)$/)
- {
- $query_string = $2;
- $subpath = $1;
- }
- return { 'query_string' => $query_string, 'subpath' => $subpath };
-}
-END_OF_FUNC
-
-#####
-# subroutine: read_multipart
-#
-# Read multipart data and store it into our parameters.
-# An interesting feature is that if any of the parts is a file, we
-# create a temporary file and open up a filehandle on it so that the
-# caller can read from it if necessary.
-#####
-'read_multipart' => <<'END_OF_FUNC',
-sub read_multipart {
- my($self,$boundary,$length) = @_;
- my($buffer) = $self->new_MultipartBuffer($boundary,$length);
- return unless $buffer;
- my(%header,$body);
- my $filenumber = 0;
- while (!$buffer->eof) {
- %header = $buffer->readHeader;
-
- unless (%header) {
- $self->cgi_error("400 Bad request (malformed multipart POST)");
- return;
- }
-
- $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
-
- my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
- $param .= $TAINTED;
-
- # See RFC 1867, 2183, 2045
- # NB: File content will be loaded into memory should
- # content-disposition parsing fail.
- my ($filename) = $header{'Content-Disposition'}
- =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
-
- $filename ||= ''; # quench uninit variable warning
-
- $filename =~ s/^"([^"]*)"$/$1/;
- # Test for Opera's multiple upload feature
- my($multipart) = ( defined( $header{'Content-Type'} ) &&
- $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
- 1 : 0;
-
- # add this parameter to our list
- $self->add_parameter($param);
-
- # If no filename specified, then just read the data and assign it
- # to our parameter list.
- if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
- my($value) = $buffer->readBody;
- $value .= $TAINTED;
- push(@{$self->{param}{$param}},$value);
- next;
- }
-
- my ($tmpfile,$tmp,$filehandle);
- UPLOADS: {
- # If we get here, then we are dealing with a potentially large
- # uploaded form. Save the data to a temporary file, then open
- # the file for reading.
-
- # skip the file if uploads disabled
- if ($DISABLE_UPLOADS) {
- while (defined($data = $buffer->read)) { }
- last UPLOADS;
- }
-
- # set the filename to some recognizable value
- if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
- $filename = "multipart/mixed";
- }
-
- # choose a relatively unpredictable tmpfile sequence number
- my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
- for (my $cnt=10;$cnt>0;$cnt--) {
- next unless $tmpfile = new CGITempFile($seqno);
- $tmp = $tmpfile->as_string;
- last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
- $seqno += int rand(100);
- }
- die "CGI open of tmpfile: $!\n" unless defined $filehandle;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
- && defined fileno($filehandle);
-
- # if this is an multipart/mixed attachment, save the header
- # together with the body for later parsing with an external
- # MIME parser module
- if ( $multipart ) {
- for ( keys %header ) {
- print $filehandle "$_: $header{$_}${CRLF}";
- }
- print $filehandle "${CRLF}";
- }
-
- my ($data);
- local($\) = '';
- my $totalbytes = 0;
- while (defined($data = $buffer->read)) {
- if (defined $self->{'.upload_hook'})
- {
- $totalbytes += length($data);
- &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
- }
- print $filehandle $data if ($self->{'use_tempfile'});
- }
-
- # back up to beginning of file
- seek($filehandle,0,0);
-
- ## Close the filehandle if requested this allows a multipart MIME
- ## upload to contain many files, and we won't die due to too many
- ## open file handles. The user can access the files using the hash
- ## below.
- close $filehandle if $CLOSE_UPLOAD_FILES;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
-
- # Save some information about the uploaded file where we can get
- # at it later.
- # Use the typeglob as the key, as this is guaranteed to be
- # unique for each filehandle. Don't use the file descriptor as
- # this will be re-used for each filehandle if the
- # close_upload_files feature is used.
- $self->{'.tmpfiles'}->{$$filehandle}= {
- hndl => $filehandle,
- name => $tmpfile,
- info => {%header},
- };
- push(@{$self->{param}{$param}},$filehandle);
- }
- }
-}
-END_OF_FUNC
-
-#####
-# subroutine: read_multipart_related
-#
-# Read multipart/related data and store it into our parameters. The
-# first parameter sets the start of the data. The part identified by
-# this Content-ID will not be stored as a file upload, but will be
-# returned by this method. All other parts will be available as file
-# uploads accessible by their Content-ID
-#####
-'read_multipart_related' => <<'END_OF_FUNC',
-sub read_multipart_related {
- my($self,$start,$boundary,$length) = @_;
- my($buffer) = $self->new_MultipartBuffer($boundary,$length);
- return unless $buffer;
- my(%header,$body);
- my $filenumber = 0;
- my $returnvalue;
- while (!$buffer->eof) {
- %header = $buffer->readHeader;
-
- unless (%header) {
- $self->cgi_error("400 Bad request (malformed multipart POST)");
- return;
- }
-
- my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
- $param .= $TAINTED;
-
- # If this is the start part, then just read the data and assign it
- # to our return variable.
- if ( $param eq $start ) {
- $returnvalue = $buffer->readBody;
- $returnvalue .= $TAINTED;
- next;
- }
-
- # add this parameter to our list
- $self->add_parameter($param);
-
- my ($tmpfile,$tmp,$filehandle);
- UPLOADS: {
- # If we get here, then we are dealing with a potentially large
- # uploaded form. Save the data to a temporary file, then open
- # the file for reading.
-
- # skip the file if uploads disabled
- if ($DISABLE_UPLOADS) {
- while (defined($data = $buffer->read)) { }
- last UPLOADS;
- }
-
- # choose a relatively unpredictable tmpfile sequence number
- my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
- for (my $cnt=10;$cnt>0;$cnt--) {
- next unless $tmpfile = new CGITempFile($seqno);
- $tmp = $tmpfile->as_string;
- last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
- $seqno += int rand(100);
- }
- die "CGI open of tmpfile: $!\n" unless defined $filehandle;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
- && defined fileno($filehandle);
-
- my ($data);
- local($\) = '';
- my $totalbytes;
- while (defined($data = $buffer->read)) {
- if (defined $self->{'.upload_hook'})
- {
- $totalbytes += length($data);
- &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
- }
- print $filehandle $data if ($self->{'use_tempfile'});
- }
-
- # back up to beginning of file
- seek($filehandle,0,0);
-
- ## Close the filehandle if requested this allows a multipart MIME
- ## upload to contain many files, and we won't die due to too many
- ## open file handles. The user can access the files using the hash
- ## below.
- close $filehandle if $CLOSE_UPLOAD_FILES;
- $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
-
- # Save some information about the uploaded file where we can get
- # at it later.
- # Use the typeglob as the key, as this is guaranteed to be
- # unique for each filehandle. Don't use the file descriptor as
- # this will be re-used for each filehandle if the
- # close_upload_files feature is used.
- $self->{'.tmpfiles'}->{$$filehandle}= {
- hndl => $filehandle,
- name => $tmpfile,
- info => {%header},
- };
- push(@{$self->{param}{$param}},$filehandle);
- }
- }
- return $returnvalue;
-}
-END_OF_FUNC
-
-
-'upload' =><<'END_OF_FUNC',
-sub upload {
- my($self,$param_name) = self_or_default(@_);
- my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
- return unless @param;
- return wantarray ? @param : $param[0];
-}
-END_OF_FUNC
-
-'tmpFileName' => <<'END_OF_FUNC',
-sub tmpFileName {
- my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$$filename}->{name} ?
- $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
- : '';
-}
-END_OF_FUNC
-
-'uploadInfo' => <<'END_OF_FUNC',
-sub uploadInfo {
- my($self,$filename) = self_or_default(@_);
- return $self->{'.tmpfiles'}->{$$filename}->{info};
-}
-END_OF_FUNC
-
-# internal routine, don't use
-'_set_values_and_labels' => <<'END_OF_FUNC',
-sub _set_values_and_labels {
- my $self = shift;
- my ($v,$l,$n) = @_;
- $$l = $v if ref($v) eq 'HASH' && !ref($$l);
- return $self->param($n) if !defined($v);
- return $v if !ref($v);
- return ref($v) eq 'HASH' ? keys %$v : @$v;
-}
-END_OF_FUNC
-
-# internal routine, don't use
-'_set_attributes' => <<'END_OF_FUNC',
-sub _set_attributes {
- my $self = shift;
- my($element, $attributes) = @_;
- return '' unless defined($attributes->{$element});
- $attribs = ' ';
- for my $attrib (keys %{$attributes->{$element}}) {
- (my $clean_attrib = $attrib) =~ s/^-//;
- $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
- }
- $attribs =~ s/ $//;
- return $attribs;
-}
-END_OF_FUNC
-
-'_compile_all' => <<'END_OF_FUNC',
-sub _compile_all {
- for (@_) {
- next if defined(&$_);
- $AUTOLOAD = "CGI::$_";
- _compile();
- }
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-;
-
-#########################################################
-# Globals and stubs for other packages that we use.
-#########################################################
-
-################### Fh -- lightweight filehandle ###############
-package Fh;
-
-use overload
- '""' => \&asString,
- 'cmp' => \&compare,
- 'fallback'=>1;
-
-$FH='fh00000';
-
-*Fh::AUTOLOAD = \&CGI::AUTOLOAD;
-
-sub DESTROY {
- my $self = shift;
- close $self;
-}
-
-$AUTOLOADED_ROUTINES = ''; # prevent -w error
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-%SUBS = (
-'asString' => <<'END_OF_FUNC',
-sub asString {
- my $self = shift;
- # get rid of package name
- (my $i = $$self) =~ s/^\*(\w+::fh\d{5})+//;
- $i =~ s/%(..)/ chr(hex($1)) /eg;
- return $i.$CGI::TAINTED;
-# BEGIN DEAD CODE
-# This was an extremely clever patch that allowed "use strict refs".
-# Unfortunately it relied on another bug that caused leaky file descriptors.
-# The underlying bug has been fixed, so this no longer works. However
-# "strict refs" still works for some reason.
-# my $self = shift;
-# return ${*{$self}{SCALAR}};
-# END DEAD CODE
-}
-END_OF_FUNC
-
-'compare' => <<'END_OF_FUNC',
-sub compare {
- my $self = shift;
- my $value = shift;
- return "$self" cmp $value;
-}
-END_OF_FUNC
-
-'new' => <<'END_OF_FUNC',
-sub new {
- my($pack,$name,$file,$delete) = @_;
- _setup_symbols(@SAVED_SYMBOLS) if @SAVED_SYMBOLS;
- require Fcntl unless defined &Fcntl::O_RDWR;
- (my $safename = $name) =~ s/([':%])/ sprintf '%%%02X', ord $1 /eg;
- my $fv = ++$FH . $safename;
- my $ref = \*{"Fh::$fv"};
- $file =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\~-]+)$! || return;
- my $safe = $1;
- sysopen($ref,$safe,Fcntl::O_RDWR()|Fcntl::O_CREAT()|Fcntl::O_EXCL(),0600) || return;
- unlink($safe) if $delete;
- CORE::delete $Fh::{$fv};
- return bless $ref,$pack;
-}
-END_OF_FUNC
-
-'handle' => <<'END_OF_FUNC',
-sub handle {
- my $self = shift;
- eval "require IO::Handle" unless IO::Handle->can('new_from_fd');
- return IO::Handle->new_from_fd(fileno $self,"<");
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-
-######################## MultipartBuffer ####################
-package MultipartBuffer;
-
-use constant DEBUG => 0;
-
-# how many bytes to read at a time. We use
-# a 4K buffer by default.
-$INITIAL_FILLUNIT = 1024 * 4;
-$TIMEOUT = 240*60; # 4 hour timeout for big files
-$SPIN_LOOP_MAX = 2000; # bug fix for some Netscape servers
-$CRLF=$CGI::CRLF;
-
-#reuse the autoload function
-*MultipartBuffer::AUTOLOAD = \&CGI::AUTOLOAD;
-
-# avoid autoloader warnings
-sub DESTROY {}
-
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
-$AUTOLOADED_ROUTINES = ''; # prevent -w error
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-%SUBS = (
-
-'new' => <<'END_OF_FUNC',
-sub new {
- my($package,$interface,$boundary,$length) = @_;
- $FILLUNIT = $INITIAL_FILLUNIT;
- $CGI::DefaultClass->binmode($IN); # if $CGI::needs_binmode; # just do it always
-
- # If the user types garbage into the file upload field,
- # then Netscape passes NOTHING to the server (not good).
- # We may hang on this read in that case. So we implement
- # a read timeout. If nothing is ready to read
- # by then, we return.
-
- # Netscape seems to be a little bit unreliable
- # about providing boundary strings.
- my $boundary_read = 0;
- if ($boundary) {
-
- # Under the MIME spec, the boundary consists of the
- # characters "--" PLUS the Boundary string
-
- # BUG: IE 3.01 on the Macintosh uses just the boundary -- not
- # the two extra hyphens. We do a special case here on the user-agent!!!!
- $boundary = "--$boundary" unless CGI::user_agent('MSIE\s+3\.0[12];\s*Mac|DreamPassport');
-
- } else { # otherwise we find it ourselves
- my($old);
- ($old,$/) = ($/,$CRLF); # read a CRLF-delimited line
- $boundary = <STDIN>; # BUG: This won't work correctly under mod_perl
- $length -= length($boundary);
- chomp($boundary); # remove the CRLF
- $/ = $old; # restore old line separator
- $boundary_read++;
- }
-
- my $self = {LENGTH=>$length,
- CHUNKED=>!$length,
- BOUNDARY=>$boundary,
- INTERFACE=>$interface,
- BUFFER=>'',
- };
-
- $FILLUNIT = length($boundary)
- if length($boundary) > $FILLUNIT;
-
- my $retval = bless $self,ref $package || $package;
-
- # Read the preamble and the topmost (boundary) line plus the CRLF.
- unless ($boundary_read) {
- while ($self->read(0)) { }
- }
- die "Malformed multipart POST: data truncated\n" if $self->eof;
-
- return $retval;
-}
-END_OF_FUNC
-
-'readHeader' => <<'END_OF_FUNC',
-sub readHeader {
- my($self) = @_;
- my($end);
- my($ok) = 0;
- my($bad) = 0;
-
- local($CRLF) = "\015\012" if $CGI::OS eq 'VMS' || $CGI::EBCDIC;
-
- do {
- $self->fillBuffer($FILLUNIT);
- $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
- $ok++ if $self->{BUFFER} eq '';
- $bad++ if !$ok && $self->{LENGTH} <= 0;
- # this was a bad idea
- # $FILLUNIT *= 2 if length($self->{BUFFER}) >= $FILLUNIT;
- } until $ok || $bad;
- return () if $bad;
-
- #EBCDIC NOTE: translate header into EBCDIC, but watch out for continuation lines!
-
- my($header) = substr($self->{BUFFER},0,$end+2);
- substr($self->{BUFFER},0,$end+4) = '';
- my %return;
-
- if ($CGI::EBCDIC) {
- warn "untranslated header=$header\n" if DEBUG;
- $header = CGI::Util::ascii2ebcdic($header);
- warn "translated header=$header\n" if DEBUG;
- }
-
- # See RFC 2045 Appendix A and RFC 822 sections 3.4.8
- # (Folding Long Header Fields), 3.4.3 (Comments)
- # and 3.4.5 (Quoted-Strings).
-
- my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
- $header=~s/$CRLF\s+/ /og; # merge continuation lines
-
- while ($header=~/($token+):\s+([^$CRLF]*)/mgox) {
- my ($field_name,$field_value) = ($1,$2);
- $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
- $return{$field_name}=$field_value;
- }
- return %return;
-}
-END_OF_FUNC
-
-# This reads and returns the body as a single scalar value.
-'readBody' => <<'END_OF_FUNC',
-sub readBody {
- my($self) = @_;
- my($data);
- my($returnval)='';
-
- #EBCDIC NOTE: want to translate returnval into EBCDIC HERE
-
- while (defined($data = $self->read)) {
- $returnval .= $data;
- }
-
- if ($CGI::EBCDIC) {
- warn "untranslated body=$returnval\n" if DEBUG;
- $returnval = CGI::Util::ascii2ebcdic($returnval);
- warn "translated body=$returnval\n" if DEBUG;
- }
- return $returnval;
-}
-END_OF_FUNC
-
-# This will read $bytes or until the boundary is hit, whichever happens
-# first. After the boundary is hit, we return undef. The next read will
-# skip over the boundary and begin reading again;
-'read' => <<'END_OF_FUNC',
-sub read {
- my($self,$bytes) = @_;
-
- # default number of bytes to read
- $bytes = $bytes || $FILLUNIT;
-
- # Fill up our internal buffer in such a way that the boundary
- # is never split between reads.
- $self->fillBuffer($bytes);
-
- my $boundary_start = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}) : $self->{BOUNDARY};
- my $boundary_end = $CGI::EBCDIC ? CGI::Util::ebcdic2ascii($self->{BOUNDARY}.'--') : $self->{BOUNDARY}.'--';
-
- # Find the boundary in the buffer (it may not be there).
- my $start = index($self->{BUFFER},$boundary_start);
-
- warn "boundary=$self->{BOUNDARY} length=$self->{LENGTH} start=$start\n" if DEBUG;
-
- # protect against malformed multipart POST operations
- die "Malformed multipart POST\n" unless $self->{CHUNKED} || ($start >= 0 || $self->{LENGTH} > 0);
-
- #EBCDIC NOTE: want to translate boundary search into ASCII here.
-
- # If the boundary begins the data, then skip past it
- # and return undef.
- if ($start == 0) {
-
- # clear us out completely if we've hit the last boundary.
- if (index($self->{BUFFER},$boundary_end)==0) {
- $self->{BUFFER}='';
- $self->{LENGTH}=0;
- return undef;
- }
-
- # just remove the boundary.
- substr($self->{BUFFER},0,length($boundary_start))='';
- $self->{BUFFER} =~ s/^\012\015?//;
- return undef;
- }
-
- my $bytesToReturn;
- if ($start > 0) { # read up to the boundary
- $bytesToReturn = $start-2 > $bytes ? $bytes : $start;
- } else { # read the requested number of bytes
- # leave enough bytes in the buffer to allow us to read
- # the boundary. Thanks to Kevin Hendrick for finding
- # this one.
- $bytesToReturn = $bytes - (length($boundary_start)+1);
- }
-
- my $returnval=substr($self->{BUFFER},0,$bytesToReturn);
- substr($self->{BUFFER},0,$bytesToReturn)='';
-
- # If we hit the boundary, remove the CRLF from the end.
- return ($bytesToReturn==$start)
- ? substr($returnval,0,-2) : $returnval;
-}
-END_OF_FUNC
-
-
-# This fills up our internal buffer in such a way that the
-# boundary is never split between reads
-'fillBuffer' => <<'END_OF_FUNC',
-sub fillBuffer {
- my($self,$bytes) = @_;
- return unless $self->{CHUNKED} || $self->{LENGTH};
-
- my($boundaryLength) = length($self->{BOUNDARY});
- my($bufferLength) = length($self->{BUFFER});
- my($bytesToRead) = $bytes - $bufferLength + $boundaryLength + 2;
- $bytesToRead = $self->{LENGTH} if !$self->{CHUNKED} && $self->{LENGTH} < $bytesToRead;
-
- # Try to read some data. We may hang here if the browser is screwed up.
- my $bytesRead = $self->{INTERFACE}->read_from_client(\$self->{BUFFER},
- $bytesToRead,
- $bufferLength);
- warn "bytesToRead=$bytesToRead, bufferLength=$bufferLength, buffer=$self->{BUFFER}\n" if DEBUG;
- $self->{BUFFER} = '' unless defined $self->{BUFFER};
-
- # An apparent bug in the Apache server causes the read()
- # to return zero bytes repeatedly without blocking if the
- # remote user aborts during a file transfer. I don't know how
- # they manage this, but the workaround is to abort if we get
- # more than SPIN_LOOP_MAX consecutive zero reads.
- if ($bytesRead <= 0) {
- die "CGI.pm: Server closed socket during multipart read (client aborted?).\n"
- if ($self->{ZERO_LOOP_COUNTER}++ >= $SPIN_LOOP_MAX);
- } else {
- $self->{ZERO_LOOP_COUNTER}=0;
- }
-
- $self->{LENGTH} -= $bytesRead if !$self->{CHUNKED} && $bytesRead;
-}
-END_OF_FUNC
-
-
-# Return true when we've finished reading
-'eof' => <<'END_OF_FUNC'
-sub eof {
- my($self) = @_;
- return 1 if (length($self->{BUFFER}) == 0)
- && ($self->{LENGTH} <= 0);
- undef;
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-
-####################################################################################
-################################## TEMPORARY FILES #################################
-####################################################################################
-package CGITempFile;
-
-sub find_tempdir {
- $SL = $CGI::SL;
- $MAC = $CGI::OS eq 'MACINTOSH';
- my ($vol) = $MAC ? MacPerl::Volumes() =~ /:(.*)/ : "";
- unless (defined $TMPDIRECTORY) {
- @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp",
- "C:${SL}temp","${SL}tmp","${SL}temp",
- "${vol}${SL}Temporary Items",
- "${SL}WWW_ROOT", "${SL}SYS\$SCRATCH",
- "C:${SL}system${SL}temp");
-
- if( $CGI::OS eq 'WINDOWS' ){
- unshift @TEMP,
- $ENV{TEMP},
- $ENV{TMP},
- $ENV{WINDIR} . $SL . 'TEMP';
- }
-
- unshift(@TEMP,$ENV{'TMPDIR'}) if defined $ENV{'TMPDIR'};
-
- # this feature was supposed to provide per-user tmpfiles, but
- # it is problematic.
- # unshift(@TEMP,(getpwuid($<))[7].'/tmp') if $CGI::OS eq 'UNIX';
- # Rob: getpwuid() is unfortunately UNIX specific. On brain dead OS'es this
- # : can generate a 'getpwuid() not implemented' exception, even though
- # : it's never called. Found under DOS/Win with the DJGPP perl port.
- # : Refer to getpwuid() only at run-time if we're fortunate and have UNIX.
- # unshift(@TEMP,(eval {(getpwuid($>))[7]}).'/tmp') if $CGI::OS eq 'UNIX' and $> != 0;
-
- for (@TEMP) {
- do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
- }
- }
- $TMPDIRECTORY = $MAC ? "" : "." unless $TMPDIRECTORY;
-}
-
-find_tempdir();
-
-$MAXTRIES = 5000;
-
-# cute feature, but overload implementation broke it
-# %OVERLOAD = ('""'=>'as_string');
-*CGITempFile::AUTOLOAD = \&CGI::AUTOLOAD;
-
-sub DESTROY {
- my($self) = @_;
- $$self =~ m!^([a-zA-Z0-9_ \'\":/.\$\\~-]+)$! || return;
- my $safe = $1; # untaint operation
- unlink $safe; # get rid of the file
-}
-
-###############################################################################
-################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
-###############################################################################
-$AUTOLOADED_ROUTINES = ''; # prevent -w error
-$AUTOLOADED_ROUTINES=<<'END_OF_AUTOLOAD';
-%SUBS = (
-
-'new' => <<'END_OF_FUNC',
-sub new {
- my($package,$sequence) = @_;
- my $filename;
- find_tempdir() unless -w $TMPDIRECTORY;
- for (my $i = 0; $i < $MAXTRIES; $i++) {
- last if ! -f ($filename = sprintf("\%s${SL}CGItemp%d", $TMPDIRECTORY, $sequence++));
- }
- # check that it is a more-or-less valid filename
- return unless $filename =~ m!^([a-zA-Z0-9_\+ \'\":/.\$\\~-]+)$!;
- # this used to untaint, now it doesn't
- # $filename = $1;
- return bless \$filename;
-}
-END_OF_FUNC
-
-'as_string' => <<'END_OF_FUNC'
-sub as_string {
- my($self) = @_;
- return $$self;
-}
-END_OF_FUNC
-
-);
-END_OF_AUTOLOAD
-
-package CGI;
-
-# We get a whole bunch of warnings about "possibly uninitialized variables"
-# when running with the -w switch. Touch them all once to get rid of the
-# warnings. This is ugly and I hate it.
-if ($^W) {
- $CGI::CGI = '';
- $CGI::CGI=<<EOF;
- $CGI::VERSION;
- $MultipartBuffer::SPIN_LOOP_MAX;
- $MultipartBuffer::CRLF;
- $MultipartBuffer::TIMEOUT;
- $MultipartBuffer::INITIAL_FILLUNIT;
-EOF
- ;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-CGI - Handle Common Gateway Interface requests and responses
-
-=head1 SYNOPSIS
-
- use CGI;
-
- my $q = CGI->new;
-
- # Process an HTTP request
- @values = $q->param('form_field');
-
- $fh = $q->upload('file_field');
-
- $riddle = $query->cookie('riddle_name');
- %answers = $query->cookie('answers');
-
- # Prepare various HTTP responses
- print $q->header();
- print $q->header('application/json');
-
- $cookie1 = $q->cookie(-name=>'riddle_name', -value=>"The Sphynx's Question");
- $cookie2 = $q->cookie(-name=>'answers', -value=>\%answers);
- print $q->header(
- -type => 'image/gif',
- -expires => '+3d',
- -cookie => [$cookie1,$cookie2]
- );
-
- print $q->redirect('http://somewhere.else/in/movie/land');
-
-=head1 DESCRIPTION
-
-CGI.pm is a stable, complete and mature solution for processing and preparing
-HTTP requests and responses. Major features including processing form
-submissions, file uploads, reading and writing cookies, query string generation
-and manipulation, and processing and preparing HTTP headers. Some HTML
-generation utilities are included as well.
-
-CGI.pm performs very well in in a vanilla CGI.pm environment and also comes
-with built-in support for mod_perl and mod_perl2 as well as FastCGI.
-
-It has the benefit of having developed and refined over 10 years with input
-from dozens of contributors and being deployed on thousands of websites.
-CGI.pm has been included in the Perl distribution since Perl 5.4, and has
-become a de-facto standard.
-
-=head2 PROGRAMMING STYLE
-
-There are two styles of programming with CGI.pm, an object-oriented
-style and a function-oriented style. In the object-oriented style you
-create one or more CGI objects and then use object methods to create
-the various elements of the page. Each CGI object starts out with the
-list of named parameters that were passed to your CGI script by the
-server. You can modify the objects, save them to a file or database
-and recreate them. Because each object corresponds to the "state" of
-the CGI script, and because each object's parameter list is
-independent of the others, this allows you to save the state of the
-script and restore it later.
-
-For example, using the object oriented style, here is how you create
-a simple "Hello World" HTML page:
-
- #!/usr/local/bin/perl -w
- use CGI; # load CGI routines
- $q = new CGI; # create new CGI object
- print $q->header, # create the HTTP header
- $q->start_html('hello world'), # start the HTML
- $q->h1('hello world'), # level 1 header
- $q->end_html; # end the HTML
-
-In the function-oriented style, there is one default CGI object that
-you rarely deal with directly. Instead you just call functions to
-retrieve CGI parameters, create HTML tags, manage cookies, and so
-on. This provides you with a cleaner programming interface, but
-limits you to using one CGI object at a time. The following example
-prints the same page, but uses the function-oriented interface.
-The main differences are that we now need to import a set of functions
-into our name space (usually the "standard" functions), and we don't
-need to create the CGI object.
-
- #!/usr/local/bin/perl
- use CGI qw/:standard/; # load standard CGI routines
- print header, # create the HTTP header
- start_html('hello world'), # start the HTML
- h1('hello world'), # level 1 header
- end_html; # end the HTML
-
-The examples in this document mainly use the object-oriented style.
-See HOW TO IMPORT FUNCTIONS for important information on
-function-oriented programming in CGI.pm
-
-=head2 CALLING CGI.PM ROUTINES
-
-Most CGI.pm routines accept several arguments, sometimes as many as 20
-optional ones! To simplify this interface, all routines use a named
-argument calling style that looks like this:
-
- print $q->header(-type=>'image/gif',-expires=>'+3d');
-
-Each argument name is preceded by a dash. Neither case nor order
-matters in the argument list. -type, -Type, and -TYPE are all
-acceptable. In fact, only the first argument needs to begin with a
-dash. If a dash is present in the first argument, CGI.pm assumes
-dashes for the subsequent ones.
-
-Several routines are commonly called with just one argument. In the
-case of these routines you can provide the single argument without an
-argument name. header() happens to be one of these routines. In this
-case, the single argument is the document type.
-
- print $q->header('text/html');
-
-Other such routines are documented below.
-
-Sometimes named arguments expect a scalar, sometimes a reference to an
-array, and sometimes a reference to a hash. Often, you can pass any
-type of argument and the routine will do whatever is most appropriate.
-For example, the param() routine is used to set a CGI parameter to a
-single or a multi-valued value. The two cases are shown below:
-
- $q->param(-name=>'veggie',-value=>'tomato');
- $q->param(-name=>'veggie',-value=>['tomato','tomahto','potato','potahto']);
-
-A large number of routines in CGI.pm actually aren't specifically
-defined in the module, but are generated automatically as needed.
-These are the "HTML shortcuts," routines that generate HTML tags for
-use in dynamically-generated pages. HTML tags have both attributes
-(the attribute="value" pairs within the tag itself) and contents (the
-part between the opening and closing pairs.) To distinguish between
-attributes and contents, CGI.pm uses the convention of passing HTML
-attributes as a hash reference as the first argument, and the
-contents, if any, as any subsequent arguments. It works out like
-this:
-
- Code Generated HTML
- ---- --------------
- h1() <h1>
- h1('some','contents'); <h1>some contents</h1>
- h1({-align=>left}); <h1 align="LEFT">
- h1({-align=>left},'contents'); <h1 align="LEFT">contents</h1>
-
-HTML tags are described in more detail later.
-
-Many newcomers to CGI.pm are puzzled by the difference between the
-calling conventions for the HTML shortcuts, which require curly braces
-around the HTML tag attributes, and the calling conventions for other
-routines, which manage to generate attributes without the curly
-brackets. Don't be confused. As a convenience the curly braces are
-optional in all but the HTML shortcuts. If you like, you can use
-curly braces when calling any routine that takes named arguments. For
-example:
-
- print $q->header( {-type=>'image/gif',-expires=>'+3d'} );
-
-If you use the B<-w> switch, you will be warned that some CGI.pm argument
-names conflict with built-in Perl functions. The most frequent of
-these is the -values argument, used to create multi-valued menus,
-radio button clusters and the like. To get around this warning, you
-have several choices:
-
-=over 4
-
-=item 1.
-
-Use another name for the argument, if one is available.
-For example, -value is an alias for -values.
-
-=item 2.
-
-Change the capitalization, e.g. -Values
-
-=item 3.
-
-Put quotes around the argument name, e.g. '-values'
-
-=back
-
-Many routines will do something useful with a named argument that it
-doesn't recognize. For example, you can produce non-standard HTTP
-header fields by providing them as named arguments:
-
- print $q->header(-type => 'text/html',
- -cost => 'Three smackers',
- -annoyance_level => 'high',
- -complaints_to => 'bit bucket');
-
-This will produce the following nonstandard HTTP header:
-
- HTTP/1.0 200 OK
- Cost: Three smackers
- Annoyance-level: high
- Complaints-to: bit bucket
- Content-type: text/html
-
-Notice the way that underscores are translated automatically into
-hyphens. HTML-generating routines perform a different type of
-translation.
-
-This feature allows you to keep up with the rapidly changing HTTP and
-HTML "standards".
-
-=head2 CREATING A NEW QUERY OBJECT (OBJECT-ORIENTED STYLE):
-
- $query = new CGI;
-
-This will parse the input (from both POST and GET methods) and store
-it into a perl5 object called $query.
-
-Any filehandles from file uploads will have their position reset to
-the beginning of the file.
-
-=head2 CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
-
- $query = new CGI(INPUTFILE);
-
-If you provide a file handle to the new() method, it will read
-parameters from the file (or STDIN, or whatever). The file can be in
-any of the forms describing below under debugging (i.e. a series of
-newline delimited TAG=VALUE pairs will work). Conveniently, this type
-of file is created by the save() method (see below). Multiple records
-can be saved and restored.
-
-Perl purists will be pleased to know that this syntax accepts
-references to file handles, or even references to filehandle globs,
-which is the "official" way to pass a filehandle:
-
- $query = new CGI(\*STDIN);
-
-You can also initialize the CGI object with a FileHandle or IO::File
-object.
-
-If you are using the function-oriented interface and want to
-initialize CGI state from a file handle, the way to do this is with
-B<restore_parameters()>. This will (re)initialize the
-default CGI object from the indicated file handle.
-
- open (IN,"test.in") || die;
- restore_parameters(IN);
- close IN;
-
-You can also initialize the query object from a hash
-reference:
-
- $query = new CGI( {'dinosaur'=>'barney',
- 'song'=>'I love you',
- 'friends'=>[qw/Jessica George Nancy/]}
- );
-
-or from a properly formatted, URL-escaped query string:
-
- $query = new CGI('dinosaur=barney&color=purple');
-
-or from a previously existing CGI object (currently this clones the
-parameter list, but none of the other object-specific fields, such as
-autoescaping):
-
- $old_query = new CGI;
- $new_query = new CGI($old_query);
-
-To create an empty query, initialize it from an empty string or hash:
-
- $empty_query = new CGI("");
-
- -or-
-
- $empty_query = new CGI({});
-
-=head2 FETCHING A LIST OF KEYWORDS FROM THE QUERY:
-
- @keywords = $query->keywords
-
-If the script was invoked as the result of an <ISINDEX> search, the
-parsed keywords can be obtained as an array using the keywords() method.
-
-=head2 FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
-
- @names = $query->param
-
-If the script was invoked with a parameter list
-(e.g. "name1=value1&name2=value2&name3=value3"), the param() method
-will return the parameter names as a list. If the script was invoked
-as an <ISINDEX> script and contains a string without ampersands
-(e.g. "value1+value2+value3") , there will be a single parameter named
-"keywords" containing the "+"-delimited keywords.
-
-NOTE: As of version 1.5, the array of parameter names returned will
-be in the same order as they were submitted by the browser.
-Usually this order is the same as the order in which the
-parameters are defined in the form (however, this isn't part
-of the spec, and so isn't guaranteed).
-
-=head2 FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
-
- @values = $query->param('foo');
-
- -or-
-
- $value = $query->param('foo');
-
-Pass the param() method a single argument to fetch the value of the
-named parameter. If the parameter is multivalued (e.g. from multiple
-selections in a scrolling list), you can ask to receive an array. Otherwise
-the method will return a single value.
-
-If a value is not given in the query string, as in the queries
-"name1=&name2=", it will be returned as an empty string.
-
-
-If the parameter does not exist at all, then param() will return undef
-in a scalar context, and the empty list in a list context.
-
-
-=head2 SETTING THE VALUE(S) OF A NAMED PARAMETER:
-
- $query->param('foo','an','array','of','values');
-
-This sets the value for the named parameter 'foo' to an array of
-values. This is one way to change the value of a field AFTER
-the script has been invoked once before. (Another way is with
-the -override parameter accepted by all methods that generate
-form elements.)
-
-param() also recognizes a named parameter style of calling described
-in more detail later:
-
- $query->param(-name=>'foo',-values=>['an','array','of','values']);
-
- -or-
-
- $query->param(-name=>'foo',-value=>'the value');
-
-=head2 APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
-
- $query->append(-name=>'foo',-values=>['yet','more','values']);
-
-This adds a value or list of values to the named parameter. The
-values are appended to the end of the parameter if it already exists.
-Otherwise the parameter is created. Note that this method only
-recognizes the named argument calling syntax.
-
-=head2 IMPORTING ALL PARAMETERS INTO A NAMESPACE:
-
- $query->import_names('R');
-
-This creates a series of variables in the 'R' namespace. For example,
-$R::foo, @R:foo. For keyword lists, a variable @R::keywords will appear.
-If no namespace is given, this method will assume 'Q'.
-WARNING: don't import anything into 'main'; this is a major security
-risk!!!!
-
-NOTE 1: Variable names are transformed as necessary into legal Perl
-variable names. All non-legal characters are transformed into
-underscores. If you need to keep the original names, you should use
-the param() method instead to access CGI variables by name.
-
-NOTE 2: In older versions, this method was called B<import()>. As of version 2.20,
-this name has been removed completely to avoid conflict with the built-in
-Perl module B<import> operator.
-
-=head2 DELETING A PARAMETER COMPLETELY:
-
- $query->delete('foo','bar','baz');
-
-This completely clears a list of parameters. It sometimes useful for
-resetting parameters that you don't want passed down between script
-invocations.
-
-If you are using the function call interface, use "Delete()" instead
-to avoid conflicts with Perl's built-in delete operator.
-
-=head2 DELETING ALL PARAMETERS:
-
- $query->delete_all();
-
-This clears the CGI object completely. It might be useful to ensure
-that all the defaults are taken when you create a fill-out form.
-
-Use Delete_all() instead if you are using the function call interface.
-
-=head2 HANDLING NON-URLENCODED ARGUMENTS
-
-
-If POSTed data is not of type application/x-www-form-urlencoded or
-multipart/form-data, then the POSTed data will not be processed, but
-instead be returned as-is in a parameter named POSTDATA. To retrieve
-it, use code like this:
-
- my $data = $query->param('POSTDATA');
-
-Likewise if PUTed data can be retrieved with code like this:
-
- my $data = $query->param('PUTDATA');
-
-(If you don't know what the preceding means, don't worry about it. It
-only affects people trying to use CGI for XML processing and other
-specialized tasks.)
-
-
-=head2 DIRECT ACCESS TO THE PARAMETER LIST:
-
- $q->param_fetch('address')->[1] = '1313 Mockingbird Lane';
- unshift @{$q->param_fetch(-name=>'address')},'George Munster';
-
-If you need access to the parameter list in a way that isn't covered
-by the methods above, you can obtain a direct reference to it by
-calling the B<param_fetch()> method with the name of the . This
-will return an array reference to the named parameters, which you then
-can manipulate in any way you like.
-
-You can also use a named argument style using the B<-name> argument.
-
-=head2 FETCHING THE PARAMETER LIST AS A HASH:
-
- $params = $q->Vars;
- print $params->{'address'};
- @foo = split("\0",$params->{'foo'});
- %params = $q->Vars;
-
- use CGI ':cgi-lib';
- $params = Vars;
-
-Many people want to fetch the entire parameter list as a hash in which
-the keys are the names of the CGI parameters, and the values are the
-parameters' values. The Vars() method does this. Called in a scalar
-context, it returns the parameter list as a tied hash reference.
-Changing a key changes the value of the parameter in the underlying
-CGI parameter list. Called in a list context, it returns the
-parameter list as an ordinary hash. This allows you to read the
-contents of the parameter list, but not to change it.
-
-When using this, the thing you must watch out for are multivalued CGI
-parameters. Because a hash cannot distinguish between scalar and
-list context, multivalued parameters will be returned as a packed
-string, separated by the "\0" (null) character. You must split this
-packed string in order to get at the individual values. This is the
-convention introduced long ago by Steve Brenner in his cgi-lib.pl
-module for Perl version 4.
-
-If you wish to use Vars() as a function, import the I<:cgi-lib> set of
-function calls (also see the section on CGI-LIB compatibility).
-
-=head2 SAVING THE STATE OF THE SCRIPT TO A FILE:
-
- $query->save(\*FILEHANDLE)
-
-This will write the current state of the form to the provided
-filehandle. You can read it back in by providing a filehandle
-to the new() method. Note that the filehandle can be a file, a pipe,
-or whatever!
-
-The format of the saved file is:
-
- NAME1=VALUE1
- NAME1=VALUE1'
- NAME2=VALUE2
- NAME3=VALUE3
- =
-
-Both name and value are URL escaped. Multi-valued CGI parameters are
-represented as repeated names. A session record is delimited by a
-single = symbol. You can write out multiple records and read them
-back in with several calls to B<new>. You can do this across several
-sessions by opening the file in append mode, allowing you to create
-primitive guest books, or to keep a history of users' queries. Here's
-a short example of creating multiple session records:
-
- use CGI;
-
- open (OUT,">>test.out") || die;
- $records = 5;
- for (0..$records) {
- my $q = new CGI;
- $q->param(-name=>'counter',-value=>$_);
- $q->save(\*OUT);
- }
- close OUT;
-
- # reopen for reading
- open (IN,"test.out") || die;
- while (!eof(IN)) {
- my $q = new CGI(\*IN);
- print $q->param('counter'),"\n";
- }
-
-The file format used for save/restore is identical to that used by the
-Whitehead Genome Center's data exchange format "Boulderio", and can be
-manipulated and even databased using Boulderio utilities. See
-
- http://stein.cshl.org/boulder/
-
-for further details.
-
-If you wish to use this method from the function-oriented (non-OO)
-interface, the exported name for this method is B<save_parameters()>.
-
-=head2 RETRIEVING CGI ERRORS
-
-Errors can occur while processing user input, particularly when
-processing uploaded files. When these errors occur, CGI will stop
-processing and return an empty parameter list. You can test for
-the existence and nature of errors using the I<cgi_error()> function.
-The error messages are formatted as HTTP status codes. You can either
-incorporate the error text into an HTML page, or use it as the value
-of the HTTP status:
-
- my $error = $q->cgi_error;
- if ($error) {
- print $q->header(-status=>$error),
- $q->start_html('Problems'),
- $q->h2('Request not processed'),
- $q->strong($error);
- exit 0;
- }
-
-When using the function-oriented interface (see the next section),
-errors may only occur the first time you call I<param()>. Be ready
-for this!
-
-=head2 USING THE FUNCTION-ORIENTED INTERFACE
-
-To use the function-oriented interface, you must specify which CGI.pm
-routines or sets of routines to import into your script's namespace.
-There is a small overhead associated with this importation, but it
-isn't much.
-
- use CGI <list of methods>;
-
-The listed methods will be imported into the current package; you can
-call them directly without creating a CGI object first. This example
-shows how to import the B<param()> and B<header()>
-methods, and then use them directly:
-
- use CGI 'param','header';
- print header('text/plain');
- $zipcode = param('zipcode');
-
-More frequently, you'll import common sets of functions by referring
-to the groups by name. All function sets are preceded with a ":"
-character as in ":html3" (for tags defined in the HTML 3 standard).
-
-Here is a list of the function sets you can import:
-
-=over 4
-
-=item B<:cgi>
-
-Import all CGI-handling methods, such as B<param()>, B<path_info()>
-and the like.
-
-=item B<:form>
-
-Import all fill-out form generating methods, such as B<textfield()>.
-
-=item B<:html2>
-
-Import all methods that generate HTML 2.0 standard elements.
-
-=item B<:html3>
-
-Import all methods that generate HTML 3.0 elements (such as
-<table>, <super> and <sub>).
-
-=item B<:html4>
-
-Import all methods that generate HTML 4 elements (such as
-<abbrev>, <acronym> and <thead>).
-
-=item B<:netscape>
-
-Import all methods that generate Netscape-specific HTML extensions.
-
-=item B<:html>
-
-Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
-'netscape')...
-
-=item B<:standard>
-
-Import "standard" features, 'html2', 'html3', 'html4', 'form' and 'cgi'.
-
-=item B<:all>
-
-Import all the available methods. For the full list, see the CGI.pm
-code, where the variable %EXPORT_TAGS is defined.
-
-=back
-
-If you import a function name that is not part of CGI.pm, the module
-will treat it as a new HTML tag and generate the appropriate
-subroutine. You can then use it like any other HTML tag. This is to
-provide for the rapidly-evolving HTML "standard." For example, say
-Microsoft comes out with a new tag called <gradient> (which causes the
-user's desktop to be flooded with a rotating gradient fill until his
-machine reboots). You don't need to wait for a new version of CGI.pm
-to start using it immediately:
-
- use CGI qw/:standard :html3 gradient/;
- print gradient({-start=>'red',-end=>'blue'});
-
-Note that in the interests of execution speed CGI.pm does B<not> use
-the standard L<Exporter> syntax for specifying load symbols. This may
-change in the future.
-
-If you import any of the state-maintaining CGI or form-generating
-methods, a default CGI object will be created and initialized
-automatically the first time you use any of the methods that require
-one to be present. This includes B<param()>, B<textfield()>,
-B<submit()> and the like. (If you need direct access to the CGI
-object, you can find it in the global variable B<$CGI::Q>). By
-importing CGI.pm methods, you can create visually elegant scripts:
-
- use CGI qw/:standard/;
- print
- header,
- start_html('Simple Script'),
- h1('Simple Script'),
- start_form,
- "What's your name? ",textfield('name'),p,
- "What's the combination?",
- checkbox_group(-name=>'words',
- -values=>['eenie','meenie','minie','moe'],
- -defaults=>['eenie','moe']),p,
- "What's your favorite color?",
- popup_menu(-name=>'color',
- -values=>['red','green','blue','chartreuse']),p,
- submit,
- end_form,
- hr,"\n";
-
- if (param) {
- print
- "Your name is ",em(param('name')),p,
- "The keywords are: ",em(join(", ",param('words'))),p,
- "Your favorite color is ",em(param('color')),".\n";
- }
- print end_html;
-
-=head2 PRAGMAS
-
-In addition to the function sets, there are a number of pragmas that
-you can import. Pragmas, which are always preceded by a hyphen,
-change the way that CGI.pm functions in various ways. Pragmas,
-function sets, and individual functions can all be imported in the
-same use() line. For example, the following use statement imports the
-standard set of functions and enables debugging mode (pragma
--debug):
-
- use CGI qw/:standard -debug/;
-
-The current list of pragmas is as follows:
-
-=over 4
-
-=item -any
-
-When you I<use CGI -any>, then any method that the query object
-doesn't recognize will be interpreted as a new HTML tag. This allows
-you to support the next I<ad hoc> Netscape or Microsoft HTML
-extension. This lets you go wild with new and unsupported tags:
-
- use CGI qw(-any);
- $q=new CGI;
- print $q->gradient({speed=>'fast',start=>'red',end=>'blue'});
-
-Since using <cite>any</cite> causes any mistyped method name
-to be interpreted as an HTML tag, use it with care or not at
-all.
-
-=item -compile
-
-This causes the indicated autoloaded methods to be compiled up front,
-rather than deferred to later. This is useful for scripts that run
-for an extended period of time under FastCGI or mod_perl, and for
-those destined to be crunched by Malcolm Beattie's Perl compiler. Use
-it in conjunction with the methods or method families you plan to use.
-
- use CGI qw(-compile :standard :html3);
-
-or even
-
- use CGI qw(-compile :all);
-
-Note that using the -compile pragma in this way will always have
-the effect of importing the compiled functions into the current
-namespace. If you want to compile without importing use the
-compile() method instead:
-
- use CGI();
- CGI->compile();
-
-This is particularly useful in a mod_perl environment, in which you
-might want to precompile all CGI routines in a startup script, and
-then import the functions individually in each mod_perl script.
-
-=item -nosticky
-
-By default the CGI module implements a state-preserving behavior
-called "sticky" fields. The way this works is that if you are
-regenerating a form, the methods that generate the form field values
-will interrogate param() to see if similarly-named parameters are
-present in the query string. If they find a like-named parameter, they
-will use it to set their default values.
-
-Sometimes this isn't what you want. The B<-nosticky> pragma prevents
-this behavior. You can also selectively change the sticky behavior in
-each element that you generate.
-
-=item -tabindex
-
-Automatically add tab index attributes to each form field. With this
-option turned off, you can still add tab indexes manually by passing a
--tabindex option to each field-generating method.
-
-=item -no_undef_params
-
-This keeps CGI.pm from including undef params in the parameter list.
-
-=item -no_xhtml
-
-By default, CGI.pm versions 2.69 and higher emit XHTML
-(http://www.w3.org/TR/xhtml1/). The -no_xhtml pragma disables this
-feature. Thanks to Michalis Kabrianis <kabrianis at hellug.gr> for this
-feature.
-
-If start_html()'s -dtd parameter specifies an HTML 2.0 or 3.2 DTD,
-XHTML will automatically be disabled without needing to use this
-pragma.
-
-=item -utf8
-
-This makes CGI.pm treat all parameters as UTF-8 strings. Use this with
-care, as it will interfere with the processing of binary uploads. It
-is better to manually select which fields are expected to return utf-8
-strings and convert them using code like this:
-
- use Encode;
- my $arg = decode utf8=>param('foo');
-
-=item -nph
-
-This makes CGI.pm produce a header appropriate for an NPH (no
-parsed header) script. You may need to do other things as well
-to tell the server that the script is NPH. See the discussion
-of NPH scripts below.
-
-=item -newstyle_urls
-
-Separate the name=value pairs in CGI parameter query strings with
-semicolons rather than ampersands. For example:
-
- ?name=fred;age=24;favorite_color=3
-
-Semicolon-delimited query strings are always accepted, but will not be
-emitted by self_url() and query_string() unless the -newstyle_urls
-pragma is specified.
-
-This became the default in version 2.64.
-
-=item -oldstyle_urls
-
-Separate the name=value pairs in CGI parameter query strings with
-ampersands rather than semicolons. This is no longer the default.
-
-=item -autoload
-
-This overrides the autoloader so that any function in your program
-that is not recognized is referred to CGI.pm for possible evaluation.
-This allows you to use all the CGI.pm functions without adding them to
-your symbol table, which is of concern for mod_perl users who are
-worried about memory consumption. I<Warning:> when
-I<-autoload> is in effect, you cannot use "poetry mode"
-(functions without the parenthesis). Use I<hr()> rather
-than I<hr>, or add something like I<use subs qw/hr p header/>
-to the top of your script.
-
-=item -no_debug
-
-This turns off the command-line processing features. If you want to
-run a CGI.pm script from the command line to produce HTML, and you
-don't want it to read CGI parameters from the command line or STDIN,
-then use this pragma:
-
- use CGI qw(-no_debug :standard);
-
-=item -debug
-
-This turns on full debugging. In addition to reading CGI arguments
-from the command-line processing, CGI.pm will pause and try to read
-arguments from STDIN, producing the message "(offline mode: enter
-name=value pairs on standard input)" features.
-
-See the section on debugging for more details.
-
-=item -private_tempfiles
-
-CGI.pm can process uploaded file. Ordinarily it spools the uploaded
-file to a temporary directory, then deletes the file when done.
-However, this opens the risk of eavesdropping as described in the file
-upload section. Another CGI script author could peek at this data
-during the upload, even if it is confidential information. On Unix
-systems, the -private_tempfiles pragma will cause the temporary file
-to be unlinked as soon as it is opened and before any data is written
-into it, reducing, but not eliminating the risk of eavesdropping
-(there is still a potential race condition). To make life harder for
-the attacker, the program chooses tempfile names by calculating a 32
-bit checksum of the incoming HTTP headers.
-
-To ensure that the temporary file cannot be read by other CGI scripts,
-use suEXEC or a CGI wrapper program to run your script. The temporary
-file is created with mode 0600 (neither world nor group readable).
-
-The temporary directory is selected using the following algorithm:
-
- 1. if the current user (e.g. "nobody") has a directory named
- "tmp" in its home directory, use that (Unix systems only).
-
- 2. if the environment variable TMPDIR exists, use the location
- indicated.
-
- 3. Otherwise try the locations /usr/tmp, /var/tmp, C:\temp,
- /tmp, /temp, ::Temporary Items, and \WWW_ROOT.
-
-Each of these locations is checked that it is a directory and is
-writable. If not, the algorithm tries the next choice.
-
-=back
-
-=head2 SPECIAL FORMS FOR IMPORTING HTML-TAG FUNCTIONS
-
-Many of the methods generate HTML tags. As described below, tag
-functions automatically generate both the opening and closing tags.
-For example:
-
- print h1('Level 1 Header');
-
-produces
-
- <h1>Level 1 Header</h1>
-
-There will be some times when you want to produce the start and end
-tags yourself. In this case, you can use the form start_I<tag_name>
-and end_I<tag_name>, as in:
-
- print start_h1,'Level 1 Header',end_h1;
-
-With a few exceptions (described below), start_I<tag_name> and
-end_I<tag_name> functions are not generated automatically when you
-I<use CGI>. However, you can specify the tags you want to generate
-I<start/end> functions for by putting an asterisk in front of their
-name, or, alternatively, requesting either "start_I<tag_name>" or
-"end_I<tag_name>" in the import list.
-
-Example:
-
- use CGI qw/:standard *table start_ul/;
-
-In this example, the following functions are generated in addition to
-the standard ones:
-
-=over 4
-
-=item 1. start_table() (generates a <table> tag)
-
-=item 2. end_table() (generates a </table> tag)
-
-=item 3. start_ul() (generates a <ul> tag)
-
-=item 4. end_ul() (generates a </ul> tag)
-
-=back
-
-=head1 GENERATING DYNAMIC DOCUMENTS
-
-Most of CGI.pm's functions deal with creating documents on the fly.
-Generally you will produce the HTTP header first, followed by the
-document itself. CGI.pm provides functions for generating HTTP
-headers of various types as well as for generating HTML. For creating
-GIF images, see the GD.pm module.
-
-Each of these functions produces a fragment of HTML or HTTP which you
-can print out directly so that it displays in the browser window,
-append to a string, or save to a file for later use.
-
-=head2 CREATING A STANDARD HTTP HEADER:
-
-Normally the first thing you will do in any CGI script is print out an
-HTTP header. This tells the browser what type of document to expect,
-and gives other optional information, such as the language, expiration
-date, and whether to cache the document. The header can also be
-manipulated for special purposes, such as server push and pay per view
-pages.
-
- print header;
-
- -or-
-
- print header('image/gif');
-
- -or-
-
- print header('text/html','204 No response');
-
- -or-
-
- print header(-type=>'image/gif',
- -nph=>1,
- -status=>'402 Payment required',
- -expires=>'+3d',
- -cookie=>$cookie,
- -charset=>'utf-7',
- -attachment=>'foo.gif',
- -Cost=>'$2.00');
-
-header() returns the Content-type: header. You can provide your own
-MIME type if you choose, otherwise it defaults to text/html. An
-optional second parameter specifies the status code and a human-readable
-message. For example, you can specify 204, "No response" to create a
-script that tells the browser to do nothing at all.
-
-The last example shows the named argument style for passing arguments
-to the CGI methods using named parameters. Recognized parameters are
-B<-type>, B<-status>, B<-expires>, and B<-cookie>. Any other named
-parameters will be stripped of their initial hyphens and turned into
-header fields, allowing you to specify any HTTP header you desire.
-Internal underscores will be turned into hyphens:
-
- print header(-Content_length=>3002);
-
-Most browsers will not cache the output from CGI scripts. Every time
-the browser reloads the page, the script is invoked anew. You can
-change this behavior with the B<-expires> parameter. When you specify
-an absolute or relative expiration interval with this parameter, some
-browsers and proxy servers will cache the script's output until the
-indicated expiration date. The following forms are all valid for the
--expires field:
-
- +30s 30 seconds from now
- +10m ten minutes from now
- +1h one hour from now
- -1d yesterday (i.e. "ASAP!")
- now immediately
- +3M in three months
- +10y in ten years time
- Thursday, 25-Apr-1999 00:40:33 GMT at the indicated time & date
-
-The B<-cookie> parameter generates a header that tells the browser to provide
-a "magic cookie" during all subsequent transactions with your script.
-Netscape cookies have a special format that includes interesting attributes
-such as expiration time. Use the cookie() method to create and retrieve
-session cookies.
-
-The B<-nph> parameter, if set to a true value, will issue the correct
-headers to work with a NPH (no-parse-header) script. This is important
-to use with certain servers that expect all their scripts to be NPH.
-
-The B<-charset> parameter can be used to control the character set
-sent to the browser. If not provided, defaults to ISO-8859-1. As a
-side effect, this sets the charset() method as well.
-
-The B<-attachment> parameter can be used to turn the page into an
-attachment. Instead of displaying the page, some browsers will prompt
-the user to save it to disk. The value of the argument is the
-suggested name for the saved file. In order for this to work, you may
-have to set the B<-type> to "application/octet-stream".
-
-The B<-p3p> parameter will add a P3P tag to the outgoing header. The
-parameter can be an arrayref or a space-delimited string of P3P tags.
-For example:
-
- print header(-p3p=>[qw(CAO DSP LAW CURa)]);
- print header(-p3p=>'CAO DSP LAW CURa');
-
-In either case, the outgoing header will be formatted as:
-
- P3P: policyref="/w3c/p3p.xml" cp="CAO DSP LAW CURa"
-
-=head2 GENERATING A REDIRECTION HEADER
-
- print redirect('http://somewhere.else/in/movie/land');
-
-Sometimes you don't want to produce a document yourself, but simply
-redirect the browser elsewhere, perhaps choosing a URL based on the
-time of day or the identity of the user.
-
-The redirect() function redirects the browser to a different URL. If
-you use redirection like this, you should B<not> print out a header as
-well.
-
-You should always use full URLs (including the http: or ftp: part) in
-redirection requests. Relative URLs will not work correctly.
-
-You can also use named arguments:
-
- print redirect(-uri=>'http://somewhere.else/in/movie/land',
- -nph=>1,
- -status=>301);
-
-The B<-nph> parameter, if set to a true value, will issue the correct
-headers to work with a NPH (no-parse-header) script. This is important
-to use with certain servers, such as Microsoft IIS, which
-expect all their scripts to be NPH.
-
-The B<-status> parameter will set the status of the redirect. HTTP
-defines three different possible redirection status codes:
-
- 301 Moved Permanently
- 302 Found
- 303 See Other
-
-The default if not specified is 302, which means "moved temporarily."
-You may change the status to another status code if you wish. Be
-advised that changing the status to anything other than 301, 302 or
-303 will probably break redirection.
-
-=head2 CREATING THE HTML DOCUMENT HEADER
-
- print start_html(-title=>'Secrets of the Pyramids',
- -author=>'fred at capricorn.org',
- -base=>'true',
- -target=>'_blank',
- -meta=>{'keywords'=>'pharaoh secret mummy',
- 'copyright'=>'copyright 1996 King Tut'},
- -style=>{'src'=>'/styles/style1.css'},
- -BGCOLOR=>'blue');
-
-After creating the HTTP header, most CGI scripts will start writing
-out an HTML document. The start_html() routine creates the top of the
-page, along with a lot of optional information that controls the
-page's appearance and behavior.
-
-This method returns a canned HTML header and the opening <body> tag.
-All parameters are optional. In the named parameter form, recognized
-parameters are -title, -author, -base, -xbase, -dtd, -lang and -target
-(see below for the explanation). Any additional parameters you
-provide, such as the Netscape unofficial BGCOLOR attribute, are added
-to the <body> tag. Additional parameters must be proceeded by a
-hyphen.
-
-The argument B<-xbase> allows you to provide an HREF for the <base> tag
-different from the current location, as in
-
- -xbase=>"http://home.mcom.com/"
-
-All relative links will be interpreted relative to this tag.
-
-The argument B<-target> allows you to provide a default target frame
-for all the links and fill-out forms on the page. B<This is a
-non-standard HTTP feature which only works with Netscape browsers!>
-See the Netscape documentation on frames for details of how to
-manipulate this.
-
- -target=>"answer_window"
-
-All relative links will be interpreted relative to this tag.
-You add arbitrary meta information to the header with the B<-meta>
-argument. This argument expects a reference to a hash
-containing name/value pairs of meta information. These will be turned
-into a series of header <meta> tags that look something like this:
-
- <meta name="keywords" content="pharaoh secret mummy">
- <meta name="description" content="copyright 1996 King Tut">
-
-To create an HTTP-EQUIV type of <meta> tag, use B<-head>, described
-below.
-
-The B<-style> argument is used to incorporate cascading stylesheets
-into your code. See the section on CASCADING STYLESHEETS for more
-information.
-
-The B<-lang> argument is used to incorporate a language attribute into
-the <html> tag. For example:
-
- print $q->start_html(-lang=>'fr-CA');
-
-The default if not specified is "en-US" for US English, unless the
--dtd parameter specifies an HTML 2.0 or 3.2 DTD, in which case the
-lang attribute is left off. You can force the lang attribute to left
-off in other cases by passing an empty string (-lang=>'').
-
-The B<-encoding> argument can be used to specify the character set for
-XHTML. It defaults to iso-8859-1 if not specified.
-
-The B<-declare_xml> argument, when used in conjunction with XHTML,
-will put a <?xml> declaration at the top of the HTML header. The sole
-purpose of this declaration is to declare the character set
-encoding. In the absence of -declare_xml, the output HTML will contain
-a <meta> tag that specifies the encoding, allowing the HTML to pass
-most validators. The default for -declare_xml is false.
-
-You can place other arbitrary HTML elements to the <head> section with the
-B<-head> tag. For example, to place the rarely-used <link> element in the
-head section, use this:
-
- print start_html(-head=>Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}));
-
-To incorporate multiple HTML elements into the <head> section, just pass an
-array reference:
-
- print start_html(-head=>[
- Link({-rel=>'next',
- -href=>'http://www.capricorn.com/s2.html'}),
- Link({-rel=>'previous',
- -href=>'http://www.capricorn.com/s1.html'})
- ]
- );
-
-And here's how to create an HTTP-EQUIV <meta> tag:
-
- print start_html(-head=>meta({-http_equiv => 'Content-Type',
- -content => 'text/html'}))
-
-
-JAVASCRIPTING: The B<-script>, B<-noScript>, B<-onLoad>,
-B<-onMouseOver>, B<-onMouseOut> and B<-onUnload> parameters are used
-to add Netscape JavaScript calls to your pages. B<-script> should
-point to a block of text containing JavaScript function definitions.
-This block will be placed within a <script> block inside the HTML (not
-HTTP) header. The block is placed in the header in order to give your
-page a fighting chance of having all its JavaScript functions in place
-even if the user presses the stop button before the page has loaded
-completely. CGI.pm attempts to format the script in such a way that
-JavaScript-naive browsers will not choke on the code: unfortunately
-there are some browsers, such as Chimera for Unix, that get confused
-by it nevertheless.
-
-The B<-onLoad> and B<-onUnload> parameters point to fragments of JavaScript
-code to execute when the page is respectively opened and closed by the
-browser. Usually these parameters are calls to functions defined in the
-B<-script> field:
-
- $query = new CGI;
- print header;
- $JSCRIPT=<<END;
- // Ask a silly question
- function riddle_me_this() {
- var r = prompt("What walks on four legs in the morning, " +
- "two legs in the afternoon, " +
- "and three legs in the evening?");
- response(r);
- }
- // Get a silly answer
- function response(answer) {
- if (answer == "man")
- alert("Right you are!");
- else
- alert("Wrong! Guess again.");
- }
- END
- print start_html(-title=>'The Riddle of the Sphinx',
- -script=>$JSCRIPT);
-
-Use the B<-noScript> parameter to pass some HTML text that will be displayed on
-browsers that do not have JavaScript (or browsers where JavaScript is turned
-off).
-
-The <script> tag, has several attributes including "type" and src.
-The latter is particularly interesting, as it allows you to keep the
-JavaScript code in a file or CGI script rather than cluttering up each
-page with the source. To use these attributes pass a HASH reference
-in the B<-script> parameter containing one or more of -type, -src, or
--code:
-
- print $q->start_html(-title=>'The Riddle of the Sphinx',
- -script=>{-type=>'JAVASCRIPT',
- -src=>'/javascript/sphinx.js'}
- );
-
- print $q->(-title=>'The Riddle of the Sphinx',
- -script=>{-type=>'PERLSCRIPT',
- -code=>'print "hello world!\n;"'}
- );
-
-
-A final feature allows you to incorporate multiple <script> sections into the
-header. Just pass the list of script sections as an array reference.
-this allows you to specify different source files for different dialects
-of JavaScript. Example:
-
- print $q->start_html(-title=>'The Riddle of the Sphinx',
- -script=>[
- { -type => 'text/javascript',
- -src => '/javascript/utilities10.js'
- },
- { -type => 'text/javascript',
- -src => '/javascript/utilities11.js'
- },
- { -type => 'text/jscript',
- -src => '/javascript/utilities12.js'
- },
- { -type => 'text/ecmascript',
- -src => '/javascript/utilities219.js'
- }
- ]
- );
-
-The option "-language" is a synonym for -type, and is supported for
-backwad compatibility.
-
-The old-style positional parameters are as follows:
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The title
-
-=item 2.
-
-The author's e-mail address (will create a <link rev="MADE"> tag if present
-
-=item 3.
-
-A 'true' flag if you want to include a <base> tag in the header. This
-helps resolve relative addresses to absolute ones when the document is moved,
-but makes the document hierarchy non-portable. Use with care!
-
-=item 4, 5, 6...
-
-Any other parameters you want to include in the <body> tag. This is a good
-place to put Netscape extensions, such as colors and wallpaper patterns.
-
-=back
-
-=head2 ENDING THE HTML DOCUMENT:
-
- print end_html
-
-This ends an HTML document by printing the </body></html> tags.
-
-=head2 CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
-
- $myself = self_url;
- print q(<a href="$myself">I'm talking to myself.</a>);
-
-self_url() will return a URL, that, when selected, will reinvoke
-this script with all its state information intact. This is most
-useful when you want to jump around within the document using
-internal anchors but you don't want to disrupt the current contents
-of the form(s). Something like this will do the trick.
-
- $myself = self_url;
- print "<a href=\"$myself#table1\">See table 1</a>";
- print "<a href=\"$myself#table2\">See table 2</a>";
- print "<a href=\"$myself#yourself\">See for yourself</a>";
-
-If you want more control over what's returned, using the B<url()>
-method instead.
-
-You can also retrieve the unprocessed query string with query_string():
-
- $the_string = query_string;
-
-=head2 OBTAINING THE SCRIPT'S URL
-
- $full_url = url();
- $full_url = url(-full=>1); #alternative syntax
- $relative_url = url(-relative=>1);
- $absolute_url = url(-absolute=>1);
- $url_with_path = url(-path_info=>1);
- $url_with_path_and_query = url(-path_info=>1,-query=>1);
- $netloc = url(-base => 1);
-
-B<url()> returns the script's URL in a variety of formats. Called
-without any arguments, it returns the full form of the URL, including
-host name and port number
-
- http://your.host.com/path/to/script.cgi
-
-You can modify this format with the following named arguments:
-
-=over 4
-
-=item B<-absolute>
-
-If true, produce an absolute URL, e.g.
-
- /path/to/script.cgi
-
-=item B<-relative>
-
-Produce a relative URL. This is useful if you want to reinvoke your
-script with different parameters. For example:
-
- script.cgi
-
-=item B<-full>
-
-Produce the full URL, exactly as if called without any arguments.
-This overrides the -relative and -absolute arguments.
-
-=item B<-path> (B<-path_info>)
-
-Append the additional path information to the URL. This can be
-combined with B<-full>, B<-absolute> or B<-relative>. B<-path_info>
-is provided as a synonym.
-
-=item B<-query> (B<-query_string>)
-
-Append the query string to the URL. This can be combined with
-B<-full>, B<-absolute> or B<-relative>. B<-query_string> is provided
-as a synonym.
-
-=item B<-base>
-
-Generate just the protocol and net location, as in http://www.foo.com:8000
-
-=item B<-rewrite>
-
-If Apache's mod_rewrite is turned on, then the script name and path
-info probably won't match the request that the user sent. Set
--rewrite=>1 (default) to return URLs that match what the user sent
-(the original request URI). Set -rewrite=>0 to return URLs that match
-the URL after mod_rewrite's rules have run. Because the additional
-path information only makes sense in the context of the rewritten URL,
--rewrite is set to false when you request path info in the URL.
-
-=back
-
-=head2 MIXING POST AND URL PARAMETERS
-
- $color = url_param('color');
-
-It is possible for a script to receive CGI parameters in the URL as
-well as in the fill-out form by creating a form that POSTs to a URL
-containing a query string (a "?" mark followed by arguments). The
-B<param()> method will always return the contents of the POSTed
-fill-out form, ignoring the URL's query string. To retrieve URL
-parameters, call the B<url_param()> method. Use it in the same way as
-B<param()>. The main difference is that it allows you to read the
-parameters, but not set them.
-
-
-Under no circumstances will the contents of the URL query string
-interfere with similarly-named CGI parameters in POSTed forms. If you
-try to mix a URL query string with a form submitted with the GET
-method, the results will not be what you expect.
-
-=head1 CREATING STANDARD HTML ELEMENTS:
-
-CGI.pm defines general HTML shortcut methods for most, if not all of
-the HTML 3 and HTML 4 tags. HTML shortcuts are named after a single
-HTML element and return a fragment of HTML text that you can then
-print or manipulate as you like. Each shortcut returns a fragment of
-HTML code that you can append to a string, save to a file, or, most
-commonly, print out so that it displays in the browser window.
-
-This example shows how to use the HTML methods:
-
- print $q->blockquote(
- "Many years ago on the island of",
- $q->a({href=>"http://crete.org/"},"Crete"),
- "there lived a Minotaur named",
- $q->strong("Fred."),
- ),
- $q->hr;
-
-This results in the following HTML code (extra newlines have been
-added for readability):
-
- <blockquote>
- Many years ago on the island of
- <a href="http://crete.org/">Crete</a> there lived
- a minotaur named <strong>Fred.</strong>
- </blockquote>
- <hr>
-
-If you find the syntax for calling the HTML shortcuts awkward, you can
-import them into your namespace and dispense with the object syntax
-completely (see the next section for more details):
-
- use CGI ':standard';
- print blockquote(
- "Many years ago on the island of",
- a({href=>"http://crete.org/"},"Crete"),
- "there lived a minotaur named",
- strong("Fred."),
- ),
- hr;
-
-=head2 PROVIDING ARGUMENTS TO HTML SHORTCUTS
-
-The HTML methods will accept zero, one or multiple arguments. If you
-provide no arguments, you get a single tag:
-
- print hr; # <hr>
-
-If you provide one or more string arguments, they are concatenated
-together with spaces and placed between opening and closing tags:
-
- print h1("Chapter","1"); # <h1>Chapter 1</h1>"
-
-If the first argument is a hash reference, then the keys
-and values of the hash become the HTML tag's attributes:
-
- print a({-href=>'fred.html',-target=>'_new'},
- "Open a new frame");
-
- <a href="fred.html",target="_new">Open a new frame</a>
-
-You may dispense with the dashes in front of the attribute names if
-you prefer:
-
- print img {src=>'fred.gif',align=>'LEFT'};
-
- <img align="LEFT" src="fred.gif">
-
-Sometimes an HTML tag attribute has no argument. For example, ordered
-lists can be marked as COMPACT. The syntax for this is an argument that
-that points to an undef string:
-
- print ol({compact=>undef},li('one'),li('two'),li('three'));
-
-Prior to CGI.pm version 2.41, providing an empty ('') string as an
-attribute argument was the same as providing undef. However, this has
-changed in order to accommodate those who want to create tags of the form
-<img alt="">. The difference is shown in these two pieces of code:
-
- CODE RESULT
- img({alt=>undef}) <img alt>
- img({alt=>''}) <img alt="">
-
-=head2 THE DISTRIBUTIVE PROPERTY OF HTML SHORTCUTS
-
-One of the cool features of the HTML shortcuts is that they are
-distributive. If you give them an argument consisting of a
-B<reference> to a list, the tag will be distributed across each
-element of the list. For example, here's one way to make an ordered
-list:
-
- print ul(
- li({-type=>'disc'},['Sneezy','Doc','Sleepy','Happy'])
- );
-
-This example will result in HTML output that looks like this:
-
- <ul>
- <li type="disc">Sneezy</li>
- <li type="disc">Doc</li>
- <li type="disc">Sleepy</li>
- <li type="disc">Happy</li>
- </ul>
-
-This is extremely useful for creating tables. For example:
-
- print table({-border=>undef},
- caption('When Should You Eat Your Vegetables?'),
- Tr({-align=>CENTER,-valign=>TOP},
- [
- th(['Vegetable', 'Breakfast','Lunch','Dinner']),
- td(['Tomatoes' , 'no', 'yes', 'yes']),
- td(['Broccoli' , 'no', 'no', 'yes']),
- td(['Onions' , 'yes','yes', 'yes'])
- ]
- )
- );
-
-=head2 HTML SHORTCUTS AND LIST INTERPOLATION
-
-Consider this bit of code:
-
- print blockquote(em('Hi'),'mom!'));
-
-It will ordinarily return the string that you probably expect, namely:
-
- <blockquote><em>Hi</em> mom!</blockquote>
-
-Note the space between the element "Hi" and the element "mom!".
-CGI.pm puts the extra space there using array interpolation, which is
-controlled by the magic $" variable. Sometimes this extra space is
-not what you want, for example, when you are trying to align a series
-of images. In this case, you can simply change the value of $" to an
-empty string.
-
- {
- local($") = '';
- print blockquote(em('Hi'),'mom!'));
- }
-
-I suggest you put the code in a block as shown here. Otherwise the
-change to $" will affect all subsequent code until you explicitly
-reset it.
-
-=head2 NON-STANDARD HTML SHORTCUTS
-
-A few HTML tags don't follow the standard pattern for various
-reasons.
-
-B<comment()> generates an HTML comment (<!-- comment -->). Call it
-like
-
- print comment('here is my comment');
-
-Because of conflicts with built-in Perl functions, the following functions
-begin with initial caps:
-
- Select
- Tr
- Link
- Delete
- Accept
- Sub
-
-In addition, start_html(), end_html(), start_form(), end_form(),
-start_multipart_form() and all the fill-out form tags are special.
-See their respective sections.
-
-=head2 AUTOESCAPING HTML
-
-By default, all HTML that is emitted by the form-generating functions
-is passed through a function called escapeHTML():
-
-=over 4
-
-=item $escaped_string = escapeHTML("unescaped string");
-
-Escape HTML formatting characters in a string.
-
-=back
-
-Provided that you have specified a character set of ISO-8859-1 (the
-default), the standard HTML escaping rules will be used. The "<"
-character becomes "<", ">" becomes ">", "&" becomes "&", and
-the quote character becomes """. In addition, the hexadecimal
-0x8b and 0x9b characters, which some browsers incorrectly interpret
-as the left and right angle-bracket characters, are replaced by their
-numeric character entities ("‹" and "›"). If you manually change
-the charset, either by calling the charset() method explicitly or by
-passing a -charset argument to header(), then B<all> characters will
-be replaced by their numeric entities, since CGI.pm has no lookup
-table for all the possible encodings.
-
-The automatic escaping does not apply to other shortcuts, such as
-h1(). You should call escapeHTML() yourself on untrusted data in
-order to protect your pages against nasty tricks that people may enter
-into guestbooks, etc.. To change the character set, use charset().
-To turn autoescaping off completely, use autoEscape(0):
-
-=over 4
-
-=item $charset = charset([$charset]);
-
-Get or set the current character set.
-
-=item $flag = autoEscape([$flag]);
-
-Get or set the value of the autoescape flag.
-
-=back
-
-=head2 PRETTY-PRINTING HTML
-
-By default, all the HTML produced by these functions comes out as one
-long line without carriage returns or indentation. This is yuck, but
-it does reduce the size of the documents by 10-20%. To get
-pretty-printed output, please use L<CGI::Pretty>, a subclass
-contributed by Brian Paulsen.
-
-=head1 CREATING FILL-OUT FORMS:
-
-I<General note> The various form-creating methods all return strings
-to the caller, containing the tag or tags that will create the requested
-form element. You are responsible for actually printing out these strings.
-It's set up this way so that you can place formatting tags
-around the form elements.
-
-I<Another note> The default values that you specify for the forms are only
-used the B<first> time the script is invoked (when there is no query
-string). On subsequent invocations of the script (when there is a query
-string), the former values are used even if they are blank.
-
-If you want to change the value of a field from its previous value, you have two
-choices:
-
-(1) call the param() method to set it.
-
-(2) use the -override (alias -force) parameter (a new feature in version 2.15).
-This forces the default value to be used, regardless of the previous value:
-
- print textfield(-name=>'field_name',
- -default=>'starting value',
- -override=>1,
- -size=>50,
- -maxlength=>80);
-
-I<Yet another note> By default, the text and labels of form elements are
-escaped according to HTML rules. This means that you can safely use
-"<CLICK ME>" as the label for a button. However, it also interferes with
-your ability to incorporate special HTML character sequences, such as Á,
-into your fields. If you wish to turn off automatic escaping, call the
-autoEscape() method with a false value immediately after creating the CGI object:
-
- $query = new CGI;
- autoEscape(undef);
-
-I<A Lurking Trap!> Some of the form-element generating methods return
-multiple tags. In a scalar context, the tags will be concatenated
-together with spaces, or whatever is the current value of the $"
-global. In a list context, the methods will return a list of
-elements, allowing you to modify them if you wish. Usually you will
-not notice this behavior, but beware of this:
-
- printf("%s\n",end_form())
-
-end_form() produces several tags, and only the first of them will be
-printed because the format only expects one value.
-
-<p>
-
-
-=head2 CREATING AN ISINDEX TAG
-
- print isindex(-action=>$action);
-
- -or-
-
- print isindex($action);
-
-Prints out an <isindex> tag. Not very exciting. The parameter
--action specifies the URL of the script to process the query. The
-default is to process the query with the current script.
-
-=head2 STARTING AND ENDING A FORM
-
- print start_form(-method=>$method,
- -action=>$action,
- -enctype=>$encoding);
- <... various form stuff ...>
- print endform;
-
- -or-
-
- print start_form($method,$action,$encoding);
- <... various form stuff ...>
- print endform;
-
-start_form() will return a <form> tag with the optional method,
-action and form encoding that you specify. The defaults are:
-
- method: POST
- action: this script
- enctype: application/x-www-form-urlencoded
-
-endform() returns the closing </form> tag.
-
-Start_form()'s enctype argument tells the browser how to package the various
-fields of the form before sending the form to the server. Two
-values are possible:
-
-B<Note:> This method was previously named startform(), and startform()
-is still recognized as an alias.
-
-=over 4
-
-=item B<application/x-www-form-urlencoded>
-
-This is the older type of encoding used by all browsers prior to
-Netscape 2.0. It is compatible with many CGI scripts and is
-suitable for short fields containing text data. For your
-convenience, CGI.pm stores the name of this encoding
-type in B<&CGI::URL_ENCODED>.
-
-=item B<multipart/form-data>
-
-This is the newer type of encoding introduced by Netscape 2.0.
-It is suitable for forms that contain very large fields or that
-are intended for transferring binary data. Most importantly,
-it enables the "file upload" feature of Netscape 2.0 forms. For
-your convenience, CGI.pm stores the name of this encoding type
-in B<&CGI::MULTIPART>
-
-Forms that use this type of encoding are not easily interpreted
-by CGI scripts unless they use CGI.pm or another library designed
-to handle them.
-
-If XHTML is activated (the default), then forms will be automatically
-created using this type of encoding.
-
-=back
-
-For compatibility, the start_form() method uses the older form of
-encoding by default. If you want to use the newer form of encoding
-by default, you can call B<start_multipart_form()> instead of
-B<start_form()>.
-
-JAVASCRIPTING: The B<-name> and B<-onSubmit> parameters are provided
-for use with JavaScript. The -name parameter gives the
-form a name so that it can be identified and manipulated by
-JavaScript functions. -onSubmit should point to a JavaScript
-function that will be executed just before the form is submitted to your
-server. You can use this opportunity to check the contents of the form
-for consistency and completeness. If you find something wrong, you
-can put up an alert box or maybe fix things up yourself. You can
-abort the submission by returning false from this function.
-
-Usually the bulk of JavaScript functions are defined in a <script>
-block in the HTML header and -onSubmit points to one of these function
-call. See start_html() for details.
-
-=head2 FORM ELEMENTS
-
-After starting a form, you will typically create one or more
-textfields, popup menus, radio groups and other form elements. Each
-of these elements takes a standard set of named arguments. Some
-elements also have optional arguments. The standard arguments are as
-follows:
-
-=over 4
-
-=item B<-name>
-
-The name of the field. After submission this name can be used to
-retrieve the field's value using the param() method.
-
-=item B<-value>, B<-values>
-
-The initial value of the field which will be returned to the script
-after form submission. Some form elements, such as text fields, take
-a single scalar -value argument. Others, such as popup menus, take a
-reference to an array of values. The two arguments are synonyms.
-
-=item B<-tabindex>
-
-A numeric value that sets the order in which the form element receives
-focus when the user presses the tab key. Elements with lower values
-receive focus first.
-
-=item B<-id>
-
-A string identifier that can be used to identify this element to
-JavaScript and DHTML.
-
-=item B<-override>
-
-A boolean, which, if true, forces the element to take on the value
-specified by B<-value>, overriding the sticky behavior described
-earlier for the B<-no_sticky> pragma.
-
-=item B<-onChange>, B<-onFocus>, B<-onBlur>, B<-onMouseOver>, B<-onMouseOut>, B<-onSelect>
-
-These are used to assign JavaScript event handlers. See the
-JavaScripting section for more details.
-
-=back
-
-Other common arguments are described in the next section. In addition
-to these, all attributes described in the HTML specifications are
-supported.
-
-=head2 CREATING A TEXT FIELD
-
- print textfield(-name=>'field_name',
- -value=>'starting value',
- -size=>50,
- -maxlength=>80);
- -or-
-
- print textfield('field_name','starting value',50,80);
-
-textfield() will return a text input field.
-
-=over 4
-
-=item B<Parameters>
-
-=item 1.
-
-The first parameter is the required name for the field (-name).
-
-=item 2.
-
-The optional second parameter is the default starting value for the field
-contents (-value, formerly known as -default).
-
-=item 3.
-
-The optional third parameter is the size of the field in
- characters (-size).
-
-=item 4.
-
-The optional fourth parameter is the maximum number of characters the
- field will accept (-maxlength).
-
-=back
-
-As with all these methods, the field will be initialized with its
-previous contents from earlier invocations of the script.
-When the form is processed, the value of the text field can be
-retrieved with:
-
- $value = param('foo');
-
-If you want to reset it from its initial value after the script has been
-called once, you can do so like this:
-
- param('foo',"I'm taking over this value!");
-
-=head2 CREATING A BIG TEXT FIELD
-
- print textarea(-name=>'foo',
- -default=>'starting value',
- -rows=>10,
- -columns=>50);
-
- -or
-
- print textarea('foo','starting value',10,50);
-
-textarea() is just like textfield, but it allows you to specify
-rows and columns for a multiline text entry box. You can provide
-a starting value for the field, which can be long and contain
-multiple lines.
-
-=head2 CREATING A PASSWORD FIELD
-
- print password_field(-name=>'secret',
- -value=>'starting value',
- -size=>50,
- -maxlength=>80);
- -or-
-
- print password_field('secret','starting value',50,80);
-
-password_field() is identical to textfield(), except that its contents
-will be starred out on the web page.
-
-=head2 CREATING A FILE UPLOAD FIELD
-
- print filefield(-name=>'uploaded_file',
- -default=>'starting value',
- -size=>50,
- -maxlength=>80);
- -or-
-
- print filefield('uploaded_file','starting value',50,80);
-
-filefield() will return a file upload field for Netscape 2.0 browsers.
-In order to take full advantage of this I<you must use the new
-multipart encoding scheme> for the form. You can do this either
-by calling B<start_form()> with an encoding type of B<&CGI::MULTIPART>,
-or by calling the new method B<start_multipart_form()> instead of
-vanilla B<start_form()>.
-
-=over 4
-
-=item B<Parameters>
-
-=item 1.
-
-The first parameter is the required name for the field (-name).
-
-=item 2.
-
-The optional second parameter is the starting value for the field contents
-to be used as the default file name (-default).
-
-For security reasons, browsers don't pay any attention to this field,
-and so the starting value will always be blank. Worse, the field
-loses its "sticky" behavior and forgets its previous contents. The
-starting value field is called for in the HTML specification, however,
-and possibly some browser will eventually provide support for it.
-
-=item 3.
-
-The optional third parameter is the size of the field in
-characters (-size).
-
-=item 4.
-
-The optional fourth parameter is the maximum number of characters the
-field will accept (-maxlength).
-
-=back
-
-When the form is processed, you can retrieve the entered filename
-by calling param():
-
- $filename = param('uploaded_file');
-
-Different browsers will return slightly different things for the
-name. Some browsers return the filename only. Others return the full
-path to the file, using the path conventions of the user's machine.
-Regardless, the name returned is always the name of the file on the
-I<user's> machine, and is unrelated to the name of the temporary file
-that CGI.pm creates during upload spooling (see below).
-
-The filename returned is also a file handle. You can read the contents
-of the file using standard Perl file reading calls:
-
- # Read a text file and print it out
- while (<$filename>) {
- print;
- }
-
- # Copy a binary file to somewhere safe
- open (OUTFILE,">>/usr/local/web/users/feedback");
- while ($bytesread=read($filename,$buffer,1024)) {
- print OUTFILE $buffer;
- }
-
-However, there are problems with the dual nature of the upload fields.
-If you C<use strict>, then Perl will complain when you try to use a
-string as a filehandle. You can get around this by placing the file
-reading code in a block containing the C<no strict> pragma. More
-seriously, it is possible for the remote user to type garbage into the
-upload field, in which case what you get from param() is not a
-filehandle at all, but a string.
-
-To be safe, use the I<upload()> function (new in version 2.47). When
-called with the name of an upload field, I<upload()> returns a
-filehandle-like object, or undef if the parameter is not a valid
-filehandle.
-
- $fh = upload('uploaded_file');
- while (<$fh>) {
- print;
- }
-
-In a list context, upload() will return an array of filehandles.
-This makes it possible to create forms that use the same name for
-multiple upload fields.
-
-This is the recommended idiom.
-
-The lightweight filehandle returned by CGI.pm is not compatible with
-IO::Handle; for example, it does not have read() or getline()
-functions, but instead must be manipulated using read($fh) or
-<$fh>. To get a compatible IO::Handle object, call the handle's
-handle() method:
-
- my $real_io_handle = upload('uploaded_file')->handle;
-
-When a file is uploaded the browser usually sends along some
-information along with it in the format of headers. The information
-usually includes the MIME content type. Future browsers may send
-other information as well (such as modification date and size). To
-retrieve this information, call uploadInfo(). It returns a reference to
-a hash containing all the document headers.
-
- $filename = param('uploaded_file');
- $type = uploadInfo($filename)->{'Content-Type'};
- unless ($type eq 'text/html') {
- die "HTML FILES ONLY!";
- }
-
-If you are using a machine that recognizes "text" and "binary" data
-modes, be sure to understand when and how to use them (see the Camel book).
-Otherwise you may find that binary files are corrupted during file
-uploads.
-
-There are occasionally problems involving parsing the uploaded file.
-This usually happens when the user presses "Stop" before the upload is
-finished. In this case, CGI.pm will return undef for the name of the
-uploaded file and set I<cgi_error()> to the string "400 Bad request
-(malformed multipart POST)". This error message is designed so that
-you can incorporate it into a status code to be sent to the browser.
-Example:
-
- $file = upload('uploaded_file');
- if (!$file && cgi_error) {
- print header(-status=>cgi_error);
- exit 0;
- }
-
-You are free to create a custom HTML page to complain about the error,
-if you wish.
-
-You can set up a callback that will be called whenever a file upload
-is being read during the form processing. This is much like the
-UPLOAD_HOOK facility available in Apache::Request, with the exception
-that the first argument to the callback is an Apache::Upload object,
-here it's the remote filename.
-
- $q = CGI->new(\&hook [,$data [,$use_tempfile]]);
-
- sub hook
- {
- my ($filename, $buffer, $bytes_read, $data) = @_;
- print "Read $bytes_read bytes of $filename\n";
- }
-
-The $data field is optional; it lets you pass configuration
-information (e.g. a database handle) to your hook callback.
-
-The $use_tempfile field is a flag that lets you turn on and off
-CGI.pm's use of a temporary disk-based file during file upload. If you
-set this to a FALSE value (default true) then param('uploaded_file')
-will no longer work, and the only way to get at the uploaded data is
-via the hook you provide.
-
-If using the function-oriented interface, call the CGI::upload_hook()
-method before calling param() or any other CGI functions:
-
- CGI::upload_hook(\&hook [,$data [,$use_tempfile]]);
-
-This method is not exported by default. You will have to import it
-explicitly if you wish to use it without the CGI:: prefix.
-
-If you are using CGI.pm on a Windows platform and find that binary
-files get slightly larger when uploaded but that text files remain the
-same, then you have forgotten to activate binary mode on the output
-filehandle. Be sure to call binmode() on any handle that you create
-to write the uploaded file to disk.
-
-JAVASCRIPTING: The B<-onChange>, B<-onFocus>, B<-onBlur>,
-B<-onMouseOver>, B<-onMouseOut> and B<-onSelect> parameters are
-recognized. See textfield() for details.
-
-=head2 CREATING A POPUP MENU
-
- print popup_menu('menu_name',
- ['eenie','meenie','minie'],
- 'meenie');
-
- -or-
-
- %labels = ('eenie'=>'your first choice',
- 'meenie'=>'your second choice',
- 'minie'=>'your third choice');
- %attributes = ('eenie'=>{'class'=>'class of first choice'});
- print popup_menu('menu_name',
- ['eenie','meenie','minie'],
- 'meenie',\%labels,\%attributes);
-
- -or (named parameter style)-
-
- print popup_menu(-name=>'menu_name',
- -values=>['eenie','meenie','minie'],
- -default=>['meenie','minie'],
- -labels=>\%labels,
- -attributes=>\%attributes);
-
-popup_menu() creates a menu.
-
-=over 4
-
-=item 1.
-
-The required first argument is the menu's name (-name).
-
-=item 2.
-
-The required second argument (-values) is an array B<reference>
-containing the list of menu items in the menu. You can pass the
-method an anonymous array, as shown in the example, or a reference to
-a named array, such as "\@foo".
-
-=item 3.
-
-The optional third parameter (-default) is the name of the default
-menu choice. If not specified, the first item will be the default.
-The values of the previous choice will be maintained across
-queries. Pass an array reference to select multiple defaults.
-
-=item 4.
-
-The optional fourth parameter (-labels) is provided for people who
-want to use different values for the user-visible label inside the
-popup menu and the value returned to your script. It's a pointer to an
-hash relating menu values to user-visible labels. If you
-leave this parameter blank, the menu values will be displayed by
-default. (You can also leave a label undefined if you want to).
-
-=item 5.
-
-The optional fifth parameter (-attributes) is provided to assign
-any of the common HTML attributes to an individual menu item. It's
-a pointer to a hash relating menu values to another
-hash with the attribute's name as the key and the
-attribute's value as the value.
-
-=back
-
-When the form is processed, the selected value of the popup menu can
-be retrieved using:
-
- $popup_menu_value = param('menu_name');
-
-=head2 CREATING AN OPTION GROUP
-
-Named parameter style
-
- print popup_menu(-name=>'menu_name',
- -values=>[qw/eenie meenie minie/,
- optgroup(-name=>'optgroup_name',
- -values => ['moe','catch'],
- -attributes=>{'catch'=>{'class'=>'red'}})],
- -labels=>{'eenie'=>'one',
- 'meenie'=>'two',
- 'minie'=>'three'},
- -default=>'meenie');
-
- Old style
- print popup_menu('menu_name',
- ['eenie','meenie','minie',
- optgroup('optgroup_name', ['moe', 'catch'],
- {'catch'=>{'class'=>'red'}})],'meenie',
- {'eenie'=>'one','meenie'=>'two','minie'=>'three'});
-
-optgroup() creates an option group within a popup menu.
-
-=over 4
-
-=item 1.
-
-The required first argument (B<-name>) is the label attribute of the
-optgroup and is B<not> inserted in the parameter list of the query.
-
-=item 2.
-
-The required second argument (B<-values>) is an array reference
-containing the list of menu items in the menu. You can pass the
-method an anonymous array, as shown in the example, or a reference
-to a named array, such as \@foo. If you pass a HASH reference,
-the keys will be used for the menu values, and the values will be
-used for the menu labels (see -labels below).
-
-=item 3.
-
-The optional third parameter (B<-labels>) allows you to pass a reference
-to a hash containing user-visible labels for one or more
-of the menu items. You can use this when you want the user to see one
-menu string, but have the browser return your program a different one.
-If you don't specify this, the value string will be used instead
-("eenie", "meenie" and "minie" in this example). This is equivalent
-to using a hash reference for the -values parameter.
-
-=item 4.
-
-An optional fourth parameter (B<-labeled>) can be set to a true value
-and indicates that the values should be used as the label attribute
-for each option element within the optgroup.
-
-=item 5.
-
-An optional fifth parameter (-novals) can be set to a true value and
-indicates to suppress the val attribute in each option element within
-the optgroup.
-
-See the discussion on optgroup at W3C
-(http://www.w3.org/TR/REC-html40/interact/forms.html#edef-OPTGROUP)
-for details.
-
-=item 6.
-
-An optional sixth parameter (-attributes) is provided to assign
-any of the common HTML attributes to an individual menu item. It's
-a pointer to a hash relating menu values to another
-hash with the attribute's name as the key and the
-attribute's value as the value.
-
-=back
-
-=head2 CREATING A SCROLLING LIST
-
- print scrolling_list('list_name',
- ['eenie','meenie','minie','moe'],
- ['eenie','moe'],5,'true',{'moe'=>{'class'=>'red'}});
- -or-
-
- print scrolling_list('list_name',
- ['eenie','meenie','minie','moe'],
- ['eenie','moe'],5,'true',
- \%labels,%attributes);
-
- -or-
-
- print scrolling_list(-name=>'list_name',
- -values=>['eenie','meenie','minie','moe'],
- -default=>['eenie','moe'],
- -size=>5,
- -multiple=>'true',
- -labels=>\%labels,
- -attributes=>\%attributes);
-
-scrolling_list() creates a scrolling list.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first and second arguments are the list name (-name) and values
-(-values). As in the popup menu, the second argument should be an
-array reference.
-
-=item 2.
-
-The optional third argument (-default) can be either a reference to a
-list containing the values to be selected by default, or can be a
-single value to select. If this argument is missing or undefined,
-then nothing is selected when the list first appears. In the named
-parameter version, you can use the synonym "-defaults" for this
-parameter.
-
-=item 3.
-
-The optional fourth argument is the size of the list (-size).
-
-=item 4.
-
-The optional fifth argument can be set to true to allow multiple
-simultaneous selections (-multiple). Otherwise only one selection
-will be allowed at a time.
-
-=item 5.
-
-The optional sixth argument is a pointer to a hash
-containing long user-visible labels for the list items (-labels).
-If not provided, the values will be displayed.
-
-=item 6.
-
-The optional sixth parameter (-attributes) is provided to assign
-any of the common HTML attributes to an individual menu item. It's
-a pointer to a hash relating menu values to another
-hash with the attribute's name as the key and the
-attribute's value as the value.
-
-When this form is processed, all selected list items will be returned as
-a list under the parameter name 'list_name'. The values of the
-selected items can be retrieved with:
-
- @selected = param('list_name');
-
-=back
-
-=head2 CREATING A GROUP OF RELATED CHECKBOXES
-
- print checkbox_group(-name=>'group_name',
- -values=>['eenie','meenie','minie','moe'],
- -default=>['eenie','moe'],
- -linebreak=>'true',
- -disabled => ['moe'],
- -labels=>\%labels,
- -attributes=>\%attributes);
-
- print checkbox_group('group_name',
- ['eenie','meenie','minie','moe'],
- ['eenie','moe'],'true',\%labels,
- {'moe'=>{'class'=>'red'}});
-
- HTML3-COMPATIBLE BROWSERS ONLY:
-
- print checkbox_group(-name=>'group_name',
- -values=>['eenie','meenie','minie','moe'],
- -rows=2,-columns=>2);
-
-
-checkbox_group() creates a list of checkboxes that are related
-by the same name.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first and second arguments are the checkbox name and values,
-respectively (-name and -values). As in the popup menu, the second
-argument should be an array reference. These values are used for the
-user-readable labels printed next to the checkboxes as well as for the
-values passed to your script in the query string.
-
-=item 2.
-
-The optional third argument (-default) can be either a reference to a
-list containing the values to be checked by default, or can be a
-single value to checked. If this argument is missing or undefined,
-then nothing is selected when the list first appears.
-
-=item 3.
-
-The optional fourth argument (-linebreak) can be set to true to place
-line breaks between the checkboxes so that they appear as a vertical
-list. Otherwise, they will be strung together on a horizontal line.
-
-=back
-
-
-The optional B<-labels> argument is a pointer to a hash
-relating the checkbox values to the user-visible labels that will be
-printed next to them. If not provided, the values will be used as the
-default.
-
-
-The optional parameters B<-rows>, and B<-columns> cause
-checkbox_group() to return an HTML3 compatible table containing the
-checkbox group formatted with the specified number of rows and
-columns. You can provide just the -columns parameter if you wish;
-checkbox_group will calculate the correct number of rows for you.
-
-The option B<-disabled> takes an array of checkbox values and disables
-them by greying them out (this may not be supported by all browsers).
-
-The optional B<-attributes> argument is provided to assign any of the
-common HTML attributes to an individual menu item. It's a pointer to
-a hash relating menu values to another hash
-with the attribute's name as the key and the attribute's value as the
-value.
-
-The optional B<-tabindex> argument can be used to control the order in which
-radio buttons receive focus when the user presses the tab button. If
-passed a scalar numeric value, the first element in the group will
-receive this tab index and subsequent elements will be incremented by
-one. If given a reference to an array of radio button values, then
-the indexes will be jiggered so that the order specified in the array
-will correspond to the tab order. You can also pass a reference to a
-hash in which the hash keys are the radio button values and the values
-are the tab indexes of each button. Examples:
-
- -tabindex => 100 # this group starts at index 100 and counts up
- -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
- -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
-
-The optional B<-labelattributes> argument will contain attributes
-attached to the <label> element that surrounds each button.
-
-When the form is processed, all checked boxes will be returned as
-a list under the parameter name 'group_name'. The values of the
-"on" checkboxes can be retrieved with:
-
- @turned_on = param('group_name');
-
-The value returned by checkbox_group() is actually an array of button
-elements. You can capture them and use them within tables, lists,
-or in other creative ways:
-
- @h = checkbox_group(-name=>'group_name',-values=>\@values);
- &use_in_creative_way(@h);
-
-=head2 CREATING A STANDALONE CHECKBOX
-
- print checkbox(-name=>'checkbox_name',
- -checked=>1,
- -value=>'ON',
- -label=>'CLICK ME');
-
- -or-
-
- print checkbox('checkbox_name','checked','ON','CLICK ME');
-
-checkbox() is used to create an isolated checkbox that isn't logically
-related to any others.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first parameter is the required name for the checkbox (-name). It
-will also be used for the user-readable label printed next to the
-checkbox.
-
-=item 2.
-
-The optional second parameter (-checked) specifies that the checkbox
-is turned on by default. Synonyms are -selected and -on.
-
-=item 3.
-
-The optional third parameter (-value) specifies the value of the
-checkbox when it is checked. If not provided, the word "on" is
-assumed.
-
-=item 4.
-
-The optional fourth parameter (-label) is the user-readable label to
-be attached to the checkbox. If not provided, the checkbox name is
-used.
-
-=back
-
-The value of the checkbox can be retrieved using:
-
- $turned_on = param('checkbox_name');
-
-=head2 CREATING A RADIO BUTTON GROUP
-
- print radio_group(-name=>'group_name',
- -values=>['eenie','meenie','minie'],
- -default=>'meenie',
- -linebreak=>'true',
- -labels=>\%labels,
- -attributes=>\%attributes);
-
- -or-
-
- print radio_group('group_name',['eenie','meenie','minie'],
- 'meenie','true',\%labels,\%attributes);
-
-
- HTML3-COMPATIBLE BROWSERS ONLY:
-
- print radio_group(-name=>'group_name',
- -values=>['eenie','meenie','minie','moe'],
- -rows=2,-columns=>2);
-
-radio_group() creates a set of logically-related radio buttons
-(turning one member of the group on turns the others off)
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first argument is the name of the group and is required (-name).
-
-=item 2.
-
-The second argument (-values) is the list of values for the radio
-buttons. The values and the labels that appear on the page are
-identical. Pass an array I<reference> in the second argument, either
-using an anonymous array, as shown, or by referencing a named array as
-in "\@foo".
-
-=item 3.
-
-The optional third parameter (-default) is the name of the default
-button to turn on. If not specified, the first item will be the
-default. You can provide a nonexistent button name, such as "-" to
-start up with no buttons selected.
-
-=item 4.
-
-The optional fourth parameter (-linebreak) can be set to 'true' to put
-line breaks between the buttons, creating a vertical list.
-
-=item 5.
-
-The optional fifth parameter (-labels) is a pointer to an associative
-array relating the radio button values to user-visible labels to be
-used in the display. If not provided, the values themselves are
-displayed.
-
-=back
-
-
-All modern browsers can take advantage of the optional parameters
-B<-rows>, and B<-columns>. These parameters cause radio_group() to
-return an HTML3 compatible table containing the radio group formatted
-with the specified number of rows and columns. You can provide just
-the -columns parameter if you wish; radio_group will calculate the
-correct number of rows for you.
-
-To include row and column headings in the returned table, you
-can use the B<-rowheaders> and B<-colheaders> parameters. Both
-of these accept a pointer to an array of headings to use.
-The headings are just decorative. They don't reorganize the
-interpretation of the radio buttons -- they're still a single named
-unit.
-
-The optional B<-tabindex> argument can be used to control the order in which
-radio buttons receive focus when the user presses the tab button. If
-passed a scalar numeric value, the first element in the group will
-receive this tab index and subsequent elements will be incremented by
-one. If given a reference to an array of radio button values, then
-the indexes will be jiggered so that the order specified in the array
-will correspond to the tab order. You can also pass a reference to a
-hash in which the hash keys are the radio button values and the values
-are the tab indexes of each button. Examples:
-
- -tabindex => 100 # this group starts at index 100 and counts up
- -tabindex => ['moe','minie','eenie','meenie'] # tab in this order
- -tabindex => {meenie=>100,moe=>101,minie=>102,eenie=>200} # tab in this order
-
-
-The optional B<-attributes> argument is provided to assign any of the
-common HTML attributes to an individual menu item. It's a pointer to
-a hash relating menu values to another hash
-with the attribute's name as the key and the attribute's value as the
-value.
-
-The optional B<-labelattributes> argument will contain attributes
-attached to the <label> element that surrounds each button.
-
-When the form is processed, the selected radio button can
-be retrieved using:
-
- $which_radio_button = param('group_name');
-
-The value returned by radio_group() is actually an array of button
-elements. You can capture them and use them within tables, lists,
-or in other creative ways:
-
- @h = radio_group(-name=>'group_name',-values=>\@values);
- &use_in_creative_way(@h);
-
-=head2 CREATING A SUBMIT BUTTON
-
- print submit(-name=>'button_name',
- -value=>'value');
-
- -or-
-
- print submit('button_name','value');
-
-submit() will create the query submission button. Every form
-should have one of these.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first argument (-name) is optional. You can give the button a
-name if you have several submission buttons in your form and you want
-to distinguish between them.
-
-=item 2.
-
-The second argument (-value) is also optional. This gives the button
-a value that will be passed to your script in the query string. The
-name will also be used as the user-visible label.
-
-=item 3.
-
-You can use -label as an alias for -value. I always get confused
-about which of -name and -value changes the user-visible label on the
-button.
-
-=back
-
-You can figure out which button was pressed by using different
-values for each one:
-
- $which_one = param('button_name');
-
-=head2 CREATING A RESET BUTTON
-
- print reset
-
-reset() creates the "reset" button. Note that it restores the
-form to its value from the last time the script was called,
-NOT necessarily to the defaults.
-
-Note that this conflicts with the Perl reset() built-in. Use
-CORE::reset() to get the original reset function.
-
-=head2 CREATING A DEFAULT BUTTON
-
- print defaults('button_label')
-
-defaults() creates a button that, when invoked, will cause the
-form to be completely reset to its defaults, wiping out all the
-changes the user ever made.
-
-=head2 CREATING A HIDDEN FIELD
-
- print hidden(-name=>'hidden_name',
- -default=>['value1','value2'...]);
-
- -or-
-
- print hidden('hidden_name','value1','value2'...);
-
-hidden() produces a text field that can't be seen by the user. It
-is useful for passing state variable information from one invocation
-of the script to the next.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first argument is required and specifies the name of this
-field (-name).
-
-=item 2.
-
-The second argument is also required and specifies its value
-(-default). In the named parameter style of calling, you can provide
-a single value here or a reference to a whole list
-
-=back
-
-Fetch the value of a hidden field this way:
-
- $hidden_value = param('hidden_name');
-
-Note, that just like all the other form elements, the value of a
-hidden field is "sticky". If you want to replace a hidden field with
-some other values after the script has been called once you'll have to
-do it manually:
-
- param('hidden_name','new','values','here');
-
-=head2 CREATING A CLICKABLE IMAGE BUTTON
-
- print image_button(-name=>'button_name',
- -src=>'/source/URL',
- -align=>'MIDDLE');
-
- -or-
-
- print image_button('button_name','/source/URL','MIDDLE');
-
-image_button() produces a clickable image. When it's clicked on the
-position of the click is returned to your script as "button_name.x"
-and "button_name.y", where "button_name" is the name you've assigned
-to it.
-
-=over 4
-
-=item B<Parameters:>
-
-=item 1.
-
-The first argument (-name) is required and specifies the name of this
-field.
-
-=item 2.
-
-The second argument (-src) is also required and specifies the URL
-
-=item 3.
-The third option (-align, optional) is an alignment type, and may be
-TOP, BOTTOM or MIDDLE
-
-=back
-
-Fetch the value of the button this way:
- $x = param('button_name.x');
- $y = param('button_name.y');
-
-=head2 CREATING A JAVASCRIPT ACTION BUTTON
-
- print button(-name=>'button_name',
- -value=>'user visible label',
- -onClick=>"do_something()");
-
- -or-
-
- print button('button_name',"do_something()");
-
-button() produces a button that is compatible with Netscape 2.0's
-JavaScript. When it's pressed the fragment of JavaScript code
-pointed to by the B<-onClick> parameter will be executed.
-
-=head1 HTTP COOKIES
-
-Browsers support a so-called "cookie" designed to help maintain state
-within a browser session. CGI.pm has several methods that support
-cookies.
-
-A cookie is a name=value pair much like the named parameters in a CGI
-query string. CGI scripts create one or more cookies and send
-them to the browser in the HTTP header. The browser maintains a list
-of cookies that belong to a particular Web server, and returns them
-to the CGI script during subsequent interactions.
-
-In addition to the required name=value pair, each cookie has several
-optional attributes:
-
-=over 4
-
-=item 1. an expiration time
-
-This is a time/date string (in a special GMT format) that indicates
-when a cookie expires. The cookie will be saved and returned to your
-script until this expiration date is reached if the user exits
-the browser and restarts it. If an expiration date isn't specified, the cookie
-will remain active until the user quits the browser.
-
-=item 2. a domain
-
-This is a partial or complete domain name for which the cookie is
-valid. The browser will return the cookie to any host that matches
-the partial domain name. For example, if you specify a domain name
-of ".capricorn.com", then the browser will return the cookie to
-Web servers running on any of the machines "www.capricorn.com",
-"www2.capricorn.com", "feckless.capricorn.com", etc. Domain names
-must contain at least two periods to prevent attempts to match
-on top level domains like ".edu". If no domain is specified, then
-the browser will only return the cookie to servers on the host the
-cookie originated from.
-
-=item 3. a path
-
-If you provide a cookie path attribute, the browser will check it
-against your script's URL before returning the cookie. For example,
-if you specify the path "/cgi-bin", then the cookie will be returned
-to each of the scripts "/cgi-bin/tally.pl", "/cgi-bin/order.pl",
-and "/cgi-bin/customer_service/complain.pl", but not to the script
-"/cgi-private/site_admin.pl". By default, path is set to "/", which
-causes the cookie to be sent to any CGI script on your site.
-
-=item 4. a "secure" flag
-
-If the "secure" attribute is set, the cookie will only be sent to your
-script if the CGI request is occurring on a secure channel, such as SSL.
-
-=back
-
-The interface to HTTP cookies is the B<cookie()> method:
-
- $cookie = cookie(-name=>'sessionID',
- -value=>'xyzzy',
- -expires=>'+1h',
- -path=>'/cgi-bin/database',
- -domain=>'.capricorn.org',
- -secure=>1);
- print header(-cookie=>$cookie);
-
-B<cookie()> creates a new cookie. Its parameters include:
-
-=over 4
-
-=item B<-name>
-
-The name of the cookie (required). This can be any string at all.
-Although browsers limit their cookie names to non-whitespace
-alphanumeric characters, CGI.pm removes this restriction by escaping
-and unescaping cookies behind the scenes.
-
-=item B<-value>
-
-The value of the cookie. This can be any scalar value,
-array reference, or even hash reference. For example,
-you can store an entire hash into a cookie this way:
-
- $cookie=cookie(-name=>'family information',
- -value=>\%childrens_ages);
-
-=item B<-path>
-
-The optional partial path for which this cookie will be valid, as described
-above.
-
-=item B<-domain>
-
-The optional partial domain for which this cookie will be valid, as described
-above.
-
-=item B<-expires>
-
-The optional expiration date for this cookie. The format is as described
-in the section on the B<header()> method:
-
- "+1h" one hour from now
-
-=item B<-secure>
-
-If set to true, this cookie will only be used within a secure
-SSL session.
-
-=back
-
-The cookie created by cookie() must be incorporated into the HTTP
-header within the string returned by the header() method:
-
- use CGI ':standard';
- print header(-cookie=>$my_cookie);
-
-To create multiple cookies, give header() an array reference:
-
- $cookie1 = cookie(-name=>'riddle_name',
- -value=>"The Sphynx's Question");
- $cookie2 = cookie(-name=>'answers',
- -value=>\%answers);
- print header(-cookie=>[$cookie1,$cookie2]);
-
-To retrieve a cookie, request it by name by calling cookie() method
-without the B<-value> parameter. This example uses the object-oriented
-form:
-
- use CGI;
- $query = new CGI;
- $riddle = $query->cookie('riddle_name');
- %answers = $query->cookie('answers');
-
-Cookies created with a single scalar value, such as the "riddle_name"
-cookie, will be returned in that form. Cookies with array and hash
-values can also be retrieved.
-
-The cookie and CGI namespaces are separate. If you have a parameter
-named 'answers' and a cookie named 'answers', the values retrieved by
-param() and cookie() are independent of each other. However, it's
-simple to turn a CGI parameter into a cookie, and vice-versa:
-
- # turn a CGI parameter into a cookie
- $c=cookie(-name=>'answers',-value=>[param('answers')]);
- # vice-versa
- param(-name=>'answers',-value=>[cookie('answers')]);
-
-If you call cookie() without any parameters, it will return a list of
-the names of all cookies passed to your script:
-
- @cookies = cookie();
-
-See the B<cookie.cgi> example script for some ideas on how to use
-cookies effectively.
-
-=head1 WORKING WITH FRAMES
-
-It's possible for CGI.pm scripts to write into several browser panels
-and windows using the HTML 4 frame mechanism. There are three
-techniques for defining new frames programmatically:
-
-=over 4
-
-=item 1. Create a <Frameset> document
-
-After writing out the HTTP header, instead of creating a standard
-HTML document using the start_html() call, create a <frameset>
-document that defines the frames on the page. Specify your script(s)
-(with appropriate parameters) as the SRC for each of the frames.
-
-There is no specific support for creating <frameset> sections
-in CGI.pm, but the HTML is very simple to write. See the frame
-documentation in Netscape's home pages for details
-
- http://wp.netscape.com/assist/net_sites/frames.html
-
-=item 2. Specify the destination for the document in the HTTP header
-
-You may provide a B<-target> parameter to the header() method:
-
- print header(-target=>'ResultsWindow');
-
-This will tell the browser to load the output of your script into the
-frame named "ResultsWindow". If a frame of that name doesn't already
-exist, the browser will pop up a new window and load your script's
-document into that. There are a number of magic names that you can
-use for targets. See the frame documents on Netscape's home pages for
-details.
-
-=item 3. Specify the destination for the document in the <form> tag
-
-You can specify the frame to load in the FORM tag itself. With
-CGI.pm it looks like this:
-
- print start_form(-target=>'ResultsWindow');
-
-When your script is reinvoked by the form, its output will be loaded
-into the frame named "ResultsWindow". If one doesn't already exist
-a new window will be created.
-
-=back
-
-The script "frameset.cgi" in the examples directory shows one way to
-create pages in which the fill-out form and the response live in
-side-by-side frames.
-
-=head1 SUPPORT FOR JAVASCRIPT
-
-The usual way to use JavaScript is to define a set of functions in a
-<SCRIPT> block inside the HTML header and then to register event
-handlers in the various elements of the page. Events include such
-things as the mouse passing over a form element, a button being
-clicked, the contents of a text field changing, or a form being
-submitted. When an event occurs that involves an element that has
-registered an event handler, its associated JavaScript code gets
-called.
-
-The elements that can register event handlers include the <BODY> of an
-HTML document, hypertext links, all the various elements of a fill-out
-form, and the form itself. There are a large number of events, and
-each applies only to the elements for which it is relevant. Here is a
-partial list:
-
-=over 4
-
-=item B<onLoad>
-
-The browser is loading the current document. Valid in:
-
- + The HTML <BODY> section only.
-
-=item B<onUnload>
-
-The browser is closing the current page or frame. Valid for:
-
- + The HTML <BODY> section only.
-
-=item B<onSubmit>
-
-The user has pressed the submit button of a form. This event happens
-just before the form is submitted, and your function can return a
-value of false in order to abort the submission. Valid for:
-
- + Forms only.
-
-=item B<onClick>
-
-The mouse has clicked on an item in a fill-out form. Valid for:
-
- + Buttons (including submit, reset, and image buttons)
- + Checkboxes
- + Radio buttons
-
-=item B<onChange>
-
-The user has changed the contents of a field. Valid for:
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=item B<onFocus>
-
-The user has selected a field to work with. Valid for:
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=item B<onBlur>
-
-The user has deselected a field (gone to work somewhere else). Valid
-for:
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=item B<onSelect>
-
-The user has changed the part of a text field that is selected. Valid
-for:
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
-
-=item B<onMouseOver>
-
-The mouse has moved over an element.
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=item B<onMouseOut>
-
-The mouse has moved off an element.
-
- + Text fields
- + Text areas
- + Password fields
- + File fields
- + Popup Menus
- + Scrolling lists
-
-=back
-
-In order to register a JavaScript event handler with an HTML element,
-just use the event name as a parameter when you call the corresponding
-CGI method. For example, to have your validateAge() JavaScript code
-executed every time the textfield named "age" changes, generate the
-field like this:
-
- print textfield(-name=>'age',-onChange=>"validateAge(this)");
-
-This example assumes that you've already declared the validateAge()
-function by incorporating it into a <SCRIPT> block. The CGI.pm
-start_html() method provides a convenient way to create this section.
-
-Similarly, you can create a form that checks itself over for
-consistency and alerts the user if some essential value is missing by
-creating it this way:
- print startform(-onSubmit=>"validateMe(this)");
-
-See the javascript.cgi script for a demonstration of how this all
-works.
-
-
-=head1 LIMITED SUPPORT FOR CASCADING STYLE SHEETS
-
-CGI.pm has limited support for HTML3's cascading style sheets (css).
-To incorporate a stylesheet into your document, pass the
-start_html() method a B<-style> parameter. The value of this
-parameter may be a scalar, in which case it is treated as the source
-URL for the stylesheet, or it may be a hash reference. In the latter
-case you should provide the hash with one or more of B<-src> or
-B<-code>. B<-src> points to a URL where an externally-defined
-stylesheet can be found. B<-code> points to a scalar value to be
-incorporated into a <style> section. Style definitions in B<-code>
-override similarly-named ones in B<-src>, hence the name "cascading."
-
-You may also specify the type of the stylesheet by adding the optional
-B<-type> parameter to the hash pointed to by B<-style>. If not
-specified, the style defaults to 'text/css'.
-
-To refer to a style within the body of your document, add the
-B<-class> parameter to any HTML element:
-
- print h1({-class=>'Fancy'},'Welcome to the Party');
-
-Or define styles on the fly with the B<-style> parameter:
-
- print h1({-style=>'Color: red;'},'Welcome to Hell');
-
-You may also use the new B<span()> element to apply a style to a
-section of text:
-
- print span({-style=>'Color: red;'},
- h1('Welcome to Hell'),
- "Where did that handbasket get to?"
- );
-
-Note that you must import the ":html3" definitions to have the
-B<span()> method available. Here's a quick and dirty example of using
-CSS's. See the CSS specification at
-http://www.w3.org/pub/WWW/TR/Wd-css-1.html for more information.
-
- use CGI qw/:standard :html3/;
-
- #here's a stylesheet incorporated directly into the page
- $newStyle=<<END;
- <!--
- P.Tip {
- margin-right: 50pt;
- margin-left: 50pt;
- color: red;
- }
- P.Alert {
- font-size: 30pt;
- font-family: sans-serif;
- color: red;
- }
- -->
- END
- print header();
- print start_html( -title=>'CGI with Style',
- -style=>{-src=>'http://www.capricorn.com/style/st1.css',
- -code=>$newStyle}
- );
- print h1('CGI with Style'),
- p({-class=>'Tip'},
- "Better read the cascading style sheet spec before playing with this!"),
- span({-style=>'color: magenta'},
- "Look Mom, no hands!",
- p(),
- "Whooo wee!"
- );
- print end_html;
-
-Pass an array reference to B<-code> or B<-src> in order to incorporate
-multiple stylesheets into your document.
-
-Should you wish to incorporate a verbatim stylesheet that includes
-arbitrary formatting in the header, you may pass a -verbatim tag to
-the -style hash, as follows:
-
-print start_html (-style => {-verbatim => '@import url("/server-common/css/'.$cssFile.'");',
- -src => '/server-common/css/core.css'});
-
-
-This will generate an HTML header that contains this:
-
- <link rel="stylesheet" type="text/css" href="/server-common/css/core.css">
- <style type="text/css">
- @import url("/server-common/css/main.css");
- </style>
-
-Any additional arguments passed in the -style value will be
-incorporated into the <link> tag. For example:
-
- start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
- -media => 'all'});
-
-This will give:
-
- <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
- <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
-
-<p>
-
-To make more complicated <link> tags, use the Link() function
-and pass it to start_html() in the -head argument, as in:
-
- @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
- Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
- print start_html({-head=>\@h})
-
-To create primary and "alternate" stylesheet, use the B<-alternate> option:
-
- start_html(-style=>{-src=>[
- {-src=>'/styles/print.css'},
- {-src=>'/styles/alt.css',-alternate=>1}
- ]
- });
-
-=head1 DEBUGGING
-
-If you are running the script from the command line or in the perl
-debugger, you can pass the script a list of keywords or
-parameter=value pairs on the command line or from standard input (you
-don't have to worry about tricking your script into reading from
-environment variables). You can pass keywords like this:
-
- your_script.pl keyword1 keyword2 keyword3
-
-or this:
-
- your_script.pl keyword1+keyword2+keyword3
-
-or this:
-
- your_script.pl name1=value1 name2=value2
-
-or this:
-
- your_script.pl name1=value1&name2=value2
-
-To turn off this feature, use the -no_debug pragma.
-
-To test the POST method, you may enable full debugging with the -debug
-pragma. This will allow you to feed newline-delimited name=value
-pairs to the script on standard input.
-
-When debugging, you can use quotes and backslashes to escape
-characters in the familiar shell manner, letting you place
-spaces and other funny characters in your parameter=value
-pairs:
-
- your_script.pl "name1='I am a long value'" "name2=two\ words"
-
-Finally, you can set the path info for the script by prefixing the first
-name/value parameter with the path followed by a question mark (?):
-
- your_script.pl /your/path/here?name1=value1&name2=value2
-
-=head2 DUMPING OUT ALL THE NAME/VALUE PAIRS
-
-The Dump() method produces a string consisting of all the query's
-name/value pairs formatted nicely as a nested list. This is useful
-for debugging purposes:
-
- print Dump
-
-
-Produces something that looks like:
-
- <ul>
- <li>name1
- <ul>
- <li>value1
- <li>value2
- </ul>
- <li>name2
- <ul>
- <li>value1
- </ul>
- </ul>
-
-As a shortcut, you can interpolate the entire CGI object into a string
-and it will be replaced with the a nice HTML dump shown above:
-
- $query=new CGI;
- print "<h2>Current Values</h2> $query\n";
-
-=head1 FETCHING ENVIRONMENT VARIABLES
-
-Some of the more useful environment variables can be fetched
-through this interface. The methods are as follows:
-
-=over 4
-
-=item B<Accept()>
-
-Return a list of MIME types that the remote browser accepts. If you
-give this method a single argument corresponding to a MIME type, as in
-Accept('text/html'), it will return a floating point value
-corresponding to the browser's preference for this type from 0.0
-(don't want) to 1.0. Glob types (e.g. text/*) in the browser's accept
-list are handled correctly.
-
-Note that the capitalization changed between version 2.43 and 2.44 in
-order to avoid conflict with Perl's accept() function.
-
-=item B<raw_cookie()>
-
-Returns the HTTP_COOKIE variable. Cookies have a special format, and
-this method call just returns the raw form (?cookie dough). See
-cookie() for ways of setting and retrieving cooked cookies.
-
-Called with no parameters, raw_cookie() returns the packed cookie
-structure. You can separate it into individual cookies by splitting
-on the character sequence "; ". Called with the name of a cookie,
-retrieves the B<unescaped> form of the cookie. You can use the
-regular cookie() method to get the names, or use the raw_fetch()
-method from the CGI::Cookie module.
-
-=item B<user_agent()>
-
-Returns the HTTP_USER_AGENT variable. If you give
-this method a single argument, it will attempt to
-pattern match on it, allowing you to do something
-like user_agent(Mozilla);
-
-=item B<path_info()>
-
-Returns additional path information from the script URL.
-E.G. fetching /cgi-bin/your_script/additional/stuff will result in
-path_info() returning "/additional/stuff".
-
-NOTE: The Microsoft Internet Information Server
-is broken with respect to additional path information. If
-you use the Perl DLL library, the IIS server will attempt to
-execute the additional path information as a Perl script.
-If you use the ordinary file associations mapping, the
-path information will be present in the environment,
-but incorrect. The best thing to do is to avoid using additional
-path information in CGI scripts destined for use with IIS.
-
-=item B<path_translated()>
-
-As per path_info() but returns the additional
-path information translated into a physical path, e.g.
-"/usr/local/etc/httpd/htdocs/additional/stuff".
-
-The Microsoft IIS is broken with respect to the translated
-path as well.
-
-=item B<remote_host()>
-
-Returns either the remote host name or IP address.
-if the former is unavailable.
-
-=item B<script_name()>
-Return the script name as a partial URL, for self-refering
-scripts.
-
-=item B<referer()>
-
-Return the URL of the page the browser was viewing
-prior to fetching your script. Not available for all
-browsers.
-
-=item B<auth_type ()>
-
-Return the authorization/verification method in use for this
-script, if any.
-
-=item B<server_name ()>
-
-Returns the name of the server, usually the machine's host
-name.
-
-=item B<virtual_host ()>
-
-When using virtual hosts, returns the name of the host that
-the browser attempted to contact
-
-=item B<server_port ()>
-
-Return the port that the server is listening on.
-
-=item B<virtual_port ()>
-
-Like server_port() except that it takes virtual hosts into account.
-Use this when running with virtual hosts.
-
-=item B<server_software ()>
-
-Returns the server software and version number.
-
-=item B<remote_user ()>
-
-Return the authorization/verification name used for user
-verification, if this script is protected.
-
-=item B<user_name ()>
-
-Attempt to obtain the remote user's name, using a variety of different
-techniques. This only works with older browsers such as Mosaic.
-Newer browsers do not report the user name for privacy reasons!
-
-=item B<request_method()>
-
-Returns the method used to access your script, usually
-one of 'POST', 'GET' or 'HEAD'.
-
-=item B<content_type()>
-
-Returns the content_type of data submitted in a POST, generally
-multipart/form-data or application/x-www-form-urlencoded
-
-=item B<http()>
-
-Called with no arguments returns the list of HTTP environment
-variables, including such things as HTTP_USER_AGENT,
-HTTP_ACCEPT_LANGUAGE, and HTTP_ACCEPT_CHARSET, corresponding to the
-like-named HTTP header fields in the request. Called with the name of
-an HTTP header field, returns its value. Capitalization and the use
-of hyphens versus underscores are not significant.
-
-For example, all three of these examples are equivalent:
-
- $requested_language = http('Accept-language');
- $requested_language = http('Accept_language');
- $requested_language = http('HTTP_ACCEPT_LANGUAGE');
-
-=item B<https()>
-
-The same as I<http()>, but operates on the HTTPS environment variables
-present when the SSL protocol is in effect. Can be used to determine
-whether SSL is turned on.
-
-=back
-
-=head1 USING NPH SCRIPTS
-
-NPH, or "no-parsed-header", scripts bypass the server completely by
-sending the complete HTTP header directly to the browser. This has
-slight performance benefits, but is of most use for taking advantage
-of HTTP extensions that are not directly supported by your server,
-such as server push and PICS headers.
-
-Servers use a variety of conventions for designating CGI scripts as
-NPH. Many Unix servers look at the beginning of the script's name for
-the prefix "nph-". The Macintosh WebSTAR server and Microsoft's
-Internet Information Server, in contrast, try to decide whether a
-program is an NPH script by examining the first line of script output.
-
-
-CGI.pm supports NPH scripts with a special NPH mode. When in this
-mode, CGI.pm will output the necessary extra header information when
-the header() and redirect() methods are
-called.
-
-The Microsoft Internet Information Server requires NPH mode. As of
-version 2.30, CGI.pm will automatically detect when the script is
-running under IIS and put itself into this mode. You do not need to
-do this manually, although it won't hurt anything if you do. However,
-note that if you have applied Service Pack 6, much of the
-functionality of NPH scripts, including the ability to redirect while
-setting a cookie, B<do not work at all> on IIS without a special patch
-from Microsoft. See
-http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
-Non-Parsed Headers Stripped From CGI Applications That Have nph-
-Prefix in Name.
-
-=over 4
-
-=item In the B<use> statement
-
-Simply add the "-nph" pragmato the list of symbols to be imported into
-your script:
-
- use CGI qw(:standard -nph)
-
-=item By calling the B<nph()> method:
-
-Call B<nph()> with a non-zero parameter at any point after using CGI.pm in your program.
-
- CGI->nph(1)
-
-=item By using B<-nph> parameters
-
-in the B<header()> and B<redirect()> statements:
-
- print header(-nph=>1);
-
-=back
-
-=head1 Server Push
-
-CGI.pm provides four simple functions for producing multipart
-documents of the type needed to implement server push. These
-functions were graciously provided by Ed Jordan <ed at fidalgo.net>. To
-import these into your namespace, you must import the ":push" set.
-You are also advised to put the script into NPH mode and to set $| to
-1 to avoid buffering problems.
-
-Here is a simple script that demonstrates server push:
-
- #!/usr/local/bin/perl
- use CGI qw/:push -nph/;
- $| = 1;
- print multipart_init(-boundary=>'----here we go!');
- for (0 .. 4) {
- print multipart_start(-type=>'text/plain'),
- "The current time is ",scalar(localtime),"\n";
- if ($_ < 4) {
- print multipart_end;
- } else {
- print multipart_final;
- }
- sleep 1;
- }
-
-This script initializes server push by calling B<multipart_init()>.
-It then enters a loop in which it begins a new multipart section by
-calling B<multipart_start()>, prints the current local time,
-and ends a multipart section with B<multipart_end()>. It then sleeps
-a second, and begins again. On the final iteration, it ends the
-multipart section with B<multipart_final()> rather than with
-B<multipart_end()>.
-
-=over 4
-
-=item multipart_init()
-
- multipart_init(-boundary=>$boundary);
-
-Initialize the multipart system. The -boundary argument specifies
-what MIME boundary string to use to separate parts of the document.
-If not provided, CGI.pm chooses a reasonable boundary for you.
-
-=item multipart_start()
-
- multipart_start(-type=>$type)
-
-Start a new part of the multipart document using the specified MIME
-type. If not specified, text/html is assumed.
-
-=item multipart_end()
-
- multipart_end()
-
-End a part. You must remember to call multipart_end() once for each
-multipart_start(), except at the end of the last part of the multipart
-document when multipart_final() should be called instead of multipart_end().
-
-=item multipart_final()
-
- multipart_final()
-
-End all parts. You should call multipart_final() rather than
-multipart_end() at the end of the last part of the multipart document.
-
-=back
-
-Users interested in server push applications should also have a look
-at the CGI::Push module.
-
-=head1 Avoiding Denial of Service Attacks
-
-A potential problem with CGI.pm is that, by default, it attempts to
-process form POSTings no matter how large they are. A wily hacker
-could attack your site by sending a CGI script a huge POST of many
-megabytes. CGI.pm will attempt to read the entire POST into a
-variable, growing hugely in size until it runs out of memory. While
-the script attempts to allocate the memory the system may slow down
-dramatically. This is a form of denial of service attack.
-
-Another possible attack is for the remote user to force CGI.pm to
-accept a huge file upload. CGI.pm will accept the upload and store it
-in a temporary directory even if your script doesn't expect to receive
-an uploaded file. CGI.pm will delete the file automatically when it
-terminates, but in the meantime the remote user may have filled up the
-server's disk space, causing problems for other programs.
-
-The best way to avoid denial of service attacks is to limit the amount
-of memory, CPU time and disk space that CGI scripts can use. Some Web
-servers come with built-in facilities to accomplish this. In other
-cases, you can use the shell I<limit> or I<ulimit>
-commands to put ceilings on CGI resource usage.
-
-
-CGI.pm also has some simple built-in protections against denial of
-service attacks, but you must activate them before you can use them.
-These take the form of two global variables in the CGI name space:
-
-=over 4
-
-=item B<$CGI::POST_MAX>
-
-If set to a non-negative integer, this variable puts a ceiling
-on the size of POSTings, in bytes. If CGI.pm detects a POST
-that is greater than the ceiling, it will immediately exit with an error
-message. This value will affect both ordinary POSTs and
-multipart POSTs, meaning that it limits the maximum size of file
-uploads as well. You should set this to a reasonably high
-value, such as 1 megabyte.
-
-=item B<$CGI::DISABLE_UPLOADS>
-
-If set to a non-zero value, this will disable file uploads
-completely. Other fill-out form values will work as usual.
-
-=back
-
-You can use these variables in either of two ways.
-
-=over 4
-
-=item B<1. On a script-by-script basis>
-
-Set the variable at the top of the script, right after the "use" statement:
-
- use CGI qw/:standard/;
- use CGI::Carp 'fatalsToBrowser';
- $CGI::POST_MAX=1024 * 100; # max 100K posts
- $CGI::DISABLE_UPLOADS = 1; # no uploads
-
-=item B<2. Globally for all scripts>
-
-Open up CGI.pm, find the definitions for $POST_MAX and
-$DISABLE_UPLOADS, and set them to the desired values. You'll
-find them towards the top of the file in a subroutine named
-initialize_globals().
-
-=back
-
-An attempt to send a POST larger than $POST_MAX bytes will cause
-I<param()> to return an empty CGI parameter list. You can test for
-this event by checking I<cgi_error()>, either after you create the CGI
-object or, if you are using the function-oriented interface, call
-<param()> for the first time. If the POST was intercepted, then
-cgi_error() will return the message "413 POST too large".
-
-This error message is actually defined by the HTTP protocol, and is
-designed to be returned to the browser as the CGI script's status
- code. For example:
-
- $uploaded_file = param('upload');
- if (!$uploaded_file && cgi_error()) {
- print header(-status=>cgi_error());
- exit 0;
- }
-
-However it isn't clear that any browser currently knows what to do
-with this status code. It might be better just to create an
-HTML page that warns the user of the problem.
-
-=head1 COMPATIBILITY WITH CGI-LIB.PL
-
-To make it easier to port existing programs that use cgi-lib.pl the
-compatibility routine "ReadParse" is provided. Porting is simple:
-
-OLD VERSION
- require "cgi-lib.pl";
- &ReadParse;
- print "The value of the antique is $in{antique}.\n";
-
-NEW VERSION
- use CGI;
- CGI::ReadParse();
- print "The value of the antique is $in{antique}.\n";
-
-CGI.pm's ReadParse() routine creates a tied variable named %in,
-which can be accessed to obtain the query variables. Like
-ReadParse, you can also provide your own variable. Infrequently
-used features of ReadParse, such as the creation of @in and $in
-variables, are not supported.
-
-Once you use ReadParse, you can retrieve the query object itself
-this way:
-
- $q = $in{CGI};
- print textfield(-name=>'wow',
- -value=>'does this really work?');
-
-This allows you to start using the more interesting features
-of CGI.pm without rewriting your old scripts from scratch.
-
-=head1 AUTHOR INFORMATION
-
-The GD.pm interface is copyright 1995-2007, Lincoln D. Stein. It is
-distributed under GPL and the Artistic License 2.0.
-
-Address bug reports and comments to: lstein at cshl.org. When sending
-bug reports, please provide the version of CGI.pm, the version of
-Perl, the name and version of your Web server, and the name and
-version of the operating system you are using. If the problem is even
-remotely browser dependent, please provide information about the
-affected browers as well.
-
-=head1 CREDITS
-
-Thanks very much to:
-
-=over 4
-
-=item Matt Heffron (heffron at falstaff.css.beckman.com)
-
-=item James Taylor (james.taylor at srs.gov)
-
-=item Scott Anguish <sanguish at digifix.com>
-
-=item Mike Jewell (mlj3u at virginia.edu)
-
-=item Timothy Shimmin (tes at kbs.citri.edu.au)
-
-=item Joergen Haegg (jh at axis.se)
-
-=item Laurent Delfosse (delfosse at delfosse.com)
-
-=item Richard Resnick (applepi1 at aol.com)
-
-=item Craig Bishop (csb at barwonwater.vic.gov.au)
-
-=item Tony Curtis (tc at vcpc.univie.ac.at)
-
-=item Tim Bunce (Tim.Bunce at ig.co.uk)
-
-=item Tom Christiansen (tchrist at convex.com)
-
-=item Andreas Koenig (k at franz.ww.TU-Berlin.DE)
-
-=item Tim MacKenzie (Tim.MacKenzie at fulcrum.com.au)
-
-=item Kevin B. Hendricks (kbhend at dogwood.tyler.wm.edu)
-
-=item Stephen Dahmen (joyfire at inxpress.net)
-
-=item Ed Jordan (ed at fidalgo.net)
-
-=item David Alan Pisoni (david at cnation.com)
-
-=item Doug MacEachern (dougm at opengroup.org)
-
-=item Robin Houston (robin at oneworld.org)
-
-=item ...and many many more...
-
-for suggestions and bug fixes.
-
-=back
-
-=head1 A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
-
-
- #!/usr/local/bin/perl
-
- use CGI ':standard';
-
- print header;
- print start_html("Example CGI.pm Form");
- print "<h1> Example CGI.pm Form</h1>\n";
- print_prompt();
- do_work();
- print_tail();
- print end_html;
-
- sub print_prompt {
- print start_form;
- print "<em>What's your name?</em><br>";
- print textfield('name');
- print checkbox('Not my real name');
-
- print "<p><em>Where can you find English Sparrows?</em><br>";
- print checkbox_group(
- -name=>'Sparrow locations',
- -values=>[England,France,Spain,Asia,Hoboken],
- -linebreak=>'yes',
- -defaults=>[England,Asia]);
-
- print "<p><em>How far can they fly?</em><br>",
- radio_group(
- -name=>'how far',
- -values=>['10 ft','1 mile','10 miles','real far'],
- -default=>'1 mile');
-
- print "<p><em>What's your favorite color?</em> ";
- print popup_menu(-name=>'Color',
- -values=>['black','brown','red','yellow'],
- -default=>'red');
-
- print hidden('Reference','Monty Python and the Holy Grail');
-
- print "<p><em>What have you got there?</em><br>";
- print scrolling_list(
- -name=>'possessions',
- -values=>['A Coconut','A Grail','An Icon',
- 'A Sword','A Ticket'],
- -size=>5,
- -multiple=>'true');
-
- print "<p><em>Any parting comments?</em><br>";
- print textarea(-name=>'Comments',
- -rows=>10,
- -columns=>50);
-
- print "<p>",reset;
- print submit('Action','Shout');
- print submit('Action','Scream');
- print endform;
- print "<hr>\n";
- }
-
- sub do_work {
- my(@values,$key);
-
- print "<h2>Here are the current settings in this form</h2>";
-
- for $key (param) {
- print "<strong>$key</strong> -> ";
- @values = param($key);
- print join(", ", at values),"<br>\n";
- }
- }
-
- sub print_tail {
- print <<END;
- <hr>
- <address>Lincoln D. Stein</address><br>
- <a href="/">Home Page</a>
- END
- }
-
-=head1 BUGS
-
-Please report them.
-
-=head1 SEE ALSO
-
-L<CGI::Carp>, L<CGI::Fast>, L<CGI::Pretty>
-
-=cut
-
Deleted: trunk/contrib/perl/lib/CPAN.pm
===================================================================
--- trunk/contrib/perl/lib/CPAN.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/CPAN.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,3717 +0,0 @@
-# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
-# vim: ts=4 sts=4 sw=4:
-use strict;
-package CPAN;
-$CPAN::VERSION = '1.9402';
-$CPAN::VERSION =~ s/_//;
-
-# we need to run chdir all over and we would get at wrong libraries
-# there
-use File::Spec ();
-BEGIN {
- if (File::Spec->can("rel2abs")) {
- for my $inc (@INC) {
- $inc = File::Spec->rel2abs($inc) unless ref $inc;
- }
- }
-}
-use CPAN::Author;
-use CPAN::HandleConfig;
-use CPAN::Version;
-use CPAN::Bundle;
-use CPAN::CacheMgr;
-use CPAN::Complete;
-use CPAN::Debug;
-use CPAN::Distribution;
-use CPAN::Distrostatus;
-use CPAN::FTP;
-use CPAN::Index 1.93; # https://rt.cpan.org/Ticket/Display.html?id=43349
-use CPAN::InfoObj;
-use CPAN::Module;
-use CPAN::Prompt;
-use CPAN::URL;
-use CPAN::Queue;
-use CPAN::Tarzip;
-use CPAN::DeferredCode;
-use CPAN::Shell;
-use CPAN::LWP::UserAgent;
-use CPAN::Exception::RecursiveDependency;
-use CPAN::Exception::yaml_not_installed;
-
-use Carp ();
-use Config ();
-use Cwd qw(chdir);
-use DirHandle ();
-use Exporter ();
-use ExtUtils::MakeMaker qw(prompt); # for some unknown reason,
- # 5.005_04 does not work without
- # this
-use File::Basename ();
-use File::Copy ();
-use File::Find;
-use File::Path ();
-use FileHandle ();
-use Fcntl qw(:flock);
-use Safe ();
-use Sys::Hostname qw(hostname);
-use Text::ParseWords ();
-use Text::Wrap ();
-
-# protect against "called too early"
-sub find_perl ();
-sub anycwd ();
-sub _uniq;
-
-no lib ".";
-
-require Mac::BuildTools if $^O eq 'MacOS';
-if ($ENV{PERL5_CPAN_IS_RUNNING} && $$ != $ENV{PERL5_CPAN_IS_RUNNING}) {
- $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} ||= $ENV{PERL5_CPAN_IS_RUNNING};
- my @rec = _uniq split(/,/, $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION}), $$;
- $ENV{PERL5_CPAN_IS_RUNNING_IN_RECURSION} = join ",", @rec;
- # warn "# Note: Recursive call of CPAN.pm detected\n";
- my $w = sprintf "# Note: CPAN.pm is running in process %d now", pop @rec;
- my %sleep = (
- 5 => 30,
- 6 => 60,
- 7 => 120,
- );
- my $sleep = @rec > 7 ? 300 : ($sleep{scalar @rec}||0);
- my $verbose = @rec >= 4;
- while (@rec) {
- $w .= sprintf " which has been called by process %d", pop @rec;
- }
- if ($sleep) {
- $w .= ".\n\n# Sleeping $sleep seconds to protect other processes\n";
- }
- if ($verbose) {
- warn $w;
- }
- local $| = 1;
- while ($sleep > 0) {
- printf "\r#%5d", --$sleep;
- sleep 1;
- }
- print "\n";
-}
-$ENV{PERL5_CPAN_IS_RUNNING}=$$;
-$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$; # https://rt.cpan.org/Ticket/Display.html?id=23735
-
-END { $CPAN::End++; &cleanup; }
-
-$CPAN::Signal ||= 0;
-$CPAN::Frontend ||= "CPAN::Shell";
-unless (@CPAN::Defaultsites) {
- @CPAN::Defaultsites = map {
- CPAN::URL->new(TEXT => $_, FROM => "DEF")
- }
- "http://www.perl.org/CPAN/",
- "ftp://ftp.perl.org/pub/CPAN/";
-}
-# $CPAN::iCwd (i for initial)
-$CPAN::iCwd ||= CPAN::anycwd();
-$CPAN::Perl ||= CPAN::find_perl();
-$CPAN::Defaultdocs ||= "http://search.cpan.org/perldoc?";
-$CPAN::Defaultrecent ||= "http://search.cpan.org/uploads.rdf";
-$CPAN::Defaultrecent ||= "http://cpan.uwinnipeg.ca/htdocs/cpan.xml";
-
-# our globals are getting a mess
-use vars qw(
- $AUTOLOAD
- $Be_Silent
- $CONFIG_DIRTY
- $Defaultdocs
- $Echo_readline
- $Frontend
- $GOTOSHELL
- $HAS_USABLE
- $Have_warned
- $MAX_RECURSION
- $META
- $RUN_DEGRADED
- $Signal
- $SQLite
- $Suppress_readline
- $VERSION
- $autoload_recursion
- $term
- @Defaultsites
- @EXPORT
- );
-
-$MAX_RECURSION = 32;
-
- at CPAN::ISA = qw(CPAN::Debug Exporter);
-
-# note that these functions live in CPAN::Shell and get executed via
-# AUTOLOAD when called directly
- at EXPORT = qw(
- autobundle
- bundle
- clean
- cvs_import
- expand
- force
- fforce
- get
- install
- install_tested
- is_tested
- make
- mkmyconfig
- notest
- perldoc
- readme
- recent
- recompile
- report
- shell
- smoke
- test
- upgrade
- );
-
-sub soft_chdir_with_alternatives ($);
-
-{
- $autoload_recursion ||= 0;
-
- #-> sub CPAN::AUTOLOAD ;
- sub AUTOLOAD { ## no critic
- $autoload_recursion++;
- my($l) = $AUTOLOAD;
- $l =~ s/.*:://;
- if ($CPAN::Signal) {
- warn "Refusing to autoload '$l' while signal pending";
- $autoload_recursion--;
- return;
- }
- if ($autoload_recursion > 1) {
- my $fullcommand = join " ", map { "'$_'" } $l, @_;
- warn "Refusing to autoload $fullcommand in recursion\n";
- $autoload_recursion--;
- return;
- }
- my(%export);
- @export{@EXPORT} = '';
- CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
- if (exists $export{$l}) {
- CPAN::Shell->$l(@_);
- } else {
- die(qq{Unknown CPAN command "$AUTOLOAD". }.
- qq{Type ? for help.\n});
- }
- $autoload_recursion--;
- }
-}
-
-{
- my $x = *SAVEOUT; # avoid warning
- open($x,">&STDOUT") or die "dup failed";
- my $redir = 0;
- sub _redirect(@) {
- #die if $redir;
- local $_;
- push(@_,undef);
- while(defined($_=shift)) {
- if (s/^\s*>//){
- my ($m) = s/^>// ? ">" : "";
- s/\s+//;
- $_=shift unless length;
- die "no dest" unless defined;
- open(STDOUT,">$m$_") or die "open:$_:$!\n";
- $redir=1;
- } elsif ( s/^\s*\|\s*// ) {
- my $pipe="| $_";
- while(defined($_[0])){
- $pipe .= ' ' . shift;
- }
- open(STDOUT,$pipe) or die "open:$pipe:$!\n";
- $redir=1;
- } else {
- push(@_,$_);
- }
- }
- return @_;
- }
- sub _unredirect {
- return unless $redir;
- $redir = 0;
- ## redirect: unredirect and propagate errors. explicit close to wait for pipe.
- close(STDOUT);
- open(STDOUT,">&SAVEOUT");
- die "$@" if "$@";
- ## redirect: done
- }
-}
-
-sub _uniq {
- my(@list) = @_;
- my %seen;
- return grep { !$seen{$_}++ } @list;
-}
-
-#-> sub CPAN::shell ;
-sub shell {
- my($self) = @_;
- $Suppress_readline = ! -t STDIN unless defined $Suppress_readline;
- CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
-
- my $oprompt = shift || CPAN::Prompt->new;
- my $prompt = $oprompt;
- my $commandline = shift || "";
- $CPAN::CurrentCommandId ||= 1;
-
- local($^W) = 1;
- unless ($Suppress_readline) {
- require Term::ReadLine;
- if (! $term
- or
- $term->ReadLine eq "Term::ReadLine::Stub"
- ) {
- $term = Term::ReadLine->new('CPAN Monitor');
- }
- if ($term->ReadLine eq "Term::ReadLine::Gnu") {
- my $attribs = $term->Attribs;
- $attribs->{attempted_completion_function} = sub {
- &CPAN::Complete::gnu_cpl;
- }
- } else {
- $readline::rl_completion_function =
- $readline::rl_completion_function = 'CPAN::Complete::cpl';
- }
- if (my $histfile = $CPAN::Config->{'histfile'}) {{
- unless ($term->can("AddHistory")) {
- $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n");
- last;
- }
- $META->readhist($term,$histfile);
- }}
- for ($CPAN::Config->{term_ornaments}) { # alias
- local $Term::ReadLine::termcap_nowarn = 1;
- $term->ornaments($_) if defined;
- }
- # $term->OUT is autoflushed anyway
- my $odef = select STDERR;
- $| = 1;
- select STDOUT;
- $| = 1;
- select $odef;
- }
-
- $META->checklock();
- my @cwd = grep { defined $_ and length $_ }
- CPAN::anycwd(),
- File::Spec->can("tmpdir") ? File::Spec->tmpdir() : (),
- File::Spec->rootdir();
- my $try_detect_readline;
- $try_detect_readline = $term->ReadLine eq "Term::ReadLine::Stub" if $term;
- unless ($CPAN::Config->{inhibit_startup_message}) {
- my $rl_avail = $Suppress_readline ? "suppressed" :
- ($term->ReadLine ne "Term::ReadLine::Stub") ? "enabled" :
- "available (maybe install Bundle::CPAN or Bundle::CPANxxl?)";
- $CPAN::Frontend->myprint(
- sprintf qq{
-cpan shell -- CPAN exploration and modules installation (v%s)
-Enter 'h' for help.
-
-},
- $CPAN::VERSION,
- $rl_avail
- )
- }
- my($continuation) = "";
- my $last_term_ornaments;
- SHELLCOMMAND: while () {
- if ($Suppress_readline) {
- if ($Echo_readline) {
- $|=1;
- }
- print $prompt;
- last SHELLCOMMAND unless defined ($_ = <> );
- if ($Echo_readline) {
- # backdoor: I could not find a way to record sessions
- print $_;
- }
- chomp;
- } else {
- last SHELLCOMMAND unless
- defined ($_ = $term->readline($prompt, $commandline));
- }
- $_ = "$continuation$_" if $continuation;
- s/^\s+//;
- next SHELLCOMMAND if /^$/;
- s/^\s*\?\s*/help /;
- if (/^(?:q(?:uit)?|bye|exit)$/i) {
- last SHELLCOMMAND;
- } elsif (s/\\$//s) {
- chomp;
- $continuation = $_;
- $prompt = " > ";
- } elsif (/^\!/) {
- s/^\!//;
- my($eval) = $_;
- package
- CPAN::Eval; # hide from the indexer
- use strict;
- use vars qw($import_done);
- CPAN->import(':DEFAULT') unless $import_done++;
- CPAN->debug("eval[$eval]") if $CPAN::DEBUG;
- eval($eval);
- warn $@ if $@;
- $continuation = "";
- $prompt = $oprompt;
- } elsif (/./) {
- my(@line);
- eval { @line = Text::ParseWords::shellwords($_) };
- warn($@), next SHELLCOMMAND if $@;
- warn("Text::Parsewords could not parse the line [$_]"),
- next SHELLCOMMAND unless @line;
- $CPAN::META->debug("line[".join("|", at line)."]") if $CPAN::DEBUG;
- my $command = shift @line;
- eval {
- local (*STDOUT)=*STDOUT;
- @line = _redirect(@line);
- CPAN::Shell->$command(@line)
- };
- my $command_error = $@;
- _unredirect;
- my $reported_error;
- if ($command_error) {
- my $err = $command_error;
- if (ref $err and $err->isa('CPAN::Exception::blocked_urllist')) {
- $CPAN::Frontend->mywarn("Client not fully configured, please proceed with configuring.$err");
- $reported_error = ref $err;
- } else {
- # I'd prefer never to arrive here and make all errors exception objects
- if ($err =~ /\S/) {
- require Carp;
- require Dumpvalue;
- my $dv = Dumpvalue->new(tick => '"');
- Carp::cluck(sprintf "Catching error: %s", $dv->stringify($err));
- }
- }
- }
- if ($command =~ /^(
- # classic commands
- make
- |test
- |install
- |clean
-
- # pragmas for classic commands
- |ff?orce
- |notest
-
- # compounds
- |report
- |smoke
- |upgrade
- )$/x) {
- # only commands that tell us something about failed distros
- # eval necessary for people without an urllist
- eval {CPAN::Shell->failed($CPAN::CurrentCommandId,1);};
- if (my $err = $@) {
- unless (ref $err and $reported_error eq ref $err) {
- die $@;
- }
- }
- }
- soft_chdir_with_alternatives(\@cwd);
- $CPAN::Frontend->myprint("\n");
- $continuation = "";
- $CPAN::CurrentCommandId++;
- $prompt = $oprompt;
- }
- } continue {
- $commandline = ""; # I do want to be able to pass a default to
- # shell, but on the second command I see no
- # use in that
- $Signal=0;
- CPAN::Queue->nullify_queue;
- if ($try_detect_readline) {
- if ($CPAN::META->has_inst("Term::ReadLine::Gnu")
- ||
- $CPAN::META->has_inst("Term::ReadLine::Perl")
- ) {
- delete $INC{"Term/ReadLine.pm"};
- my $redef = 0;
- local($SIG{__WARN__}) = CPAN::Shell::paintdots_onreload(\$redef);
- require Term::ReadLine;
- $CPAN::Frontend->myprint("\n$redef subroutines in ".
- "Term::ReadLine redefined\n");
- $GOTOSHELL = 1;
- }
- }
- if ($term and $term->can("ornaments")) {
- for ($CPAN::Config->{term_ornaments}) { # alias
- if (defined $_) {
- if (not defined $last_term_ornaments
- or $_ != $last_term_ornaments
- ) {
- local $Term::ReadLine::termcap_nowarn = 1;
- $term->ornaments($_);
- $last_term_ornaments = $_;
- }
- } else {
- undef $last_term_ornaments;
- }
- }
- }
- for my $class (qw(Module Distribution)) {
- # again unsafe meta access?
- for my $dm (keys %{$CPAN::META->{readwrite}{"CPAN::$class"}}) {
- next unless $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
- CPAN->debug("BUG: $class '$dm' was in command state, resetting");
- delete $CPAN::META->{readwrite}{"CPAN::$class"}{$dm}{incommandcolor};
- }
- }
- if ($GOTOSHELL) {
- $GOTOSHELL = 0; # not too often
- $META->savehist if $CPAN::term && $CPAN::term->can("GetHistory");
- @_ = ($oprompt,"");
- goto &shell;
- }
- }
- soft_chdir_with_alternatives(\@cwd);
-}
-
-#-> CPAN::soft_chdir_with_alternatives ;
-sub soft_chdir_with_alternatives ($) {
- my($cwd) = @_;
- unless (@$cwd) {
- my $root = File::Spec->rootdir();
- $CPAN::Frontend->mywarn(qq{Warning: no good directory to chdir to!
-Trying '$root' as temporary haven.
-});
- push @$cwd, $root;
- }
- while () {
- if (chdir $cwd->[0]) {
- return;
- } else {
- if (@$cwd>1) {
- $CPAN::Frontend->mywarn(qq{Could not chdir to "$cwd->[0]": $!
-Trying to chdir to "$cwd->[1]" instead.
-});
- shift @$cwd;
- } else {
- $CPAN::Frontend->mydie(qq{Could not chdir to "$cwd->[0]": $!});
- }
- }
- }
-}
-
-sub _flock {
- my($fh,$mode) = @_;
- if ( $Config::Config{d_flock} || $Config::Config{d_fcntl_can_lock} ) {
- return flock $fh, $mode;
- } elsif (!$Have_warned->{"d_flock"}++) {
- $CPAN::Frontend->mywarn("Your OS does not seem to support locking; continuing and ignoring all locking issues\n");
- $CPAN::Frontend->mysleep(5);
- return 1;
- } else {
- return 1;
- }
-}
-
-sub _yaml_module () {
- my $yaml_module = $CPAN::Config->{yaml_module} || "YAML";
- if (
- $yaml_module ne "YAML"
- &&
- !$CPAN::META->has_inst($yaml_module)
- ) {
- # $CPAN::Frontend->mywarn("'$yaml_module' not installed, falling back to 'YAML'\n");
- $yaml_module = "YAML";
- }
- if ($yaml_module eq "YAML"
- &&
- $CPAN::META->has_inst($yaml_module)
- &&
- $YAML::VERSION < 0.60
- &&
- !$Have_warned->{"YAML"}++
- ) {
- $CPAN::Frontend->mywarn("Warning: YAML version '$YAML::VERSION' is too low, please upgrade!\n".
- "I'll continue but problems are *very* likely to happen.\n"
- );
- $CPAN::Frontend->mysleep(5);
- }
- return $yaml_module;
-}
-
-# CPAN::_yaml_loadfile
-sub _yaml_loadfile {
- my($self,$local_file) = @_;
- return +[] unless -s $local_file;
- my $yaml_module = _yaml_module;
- if ($CPAN::META->has_inst($yaml_module)) {
- # temporarly enable yaml code deserialisation
- no strict 'refs';
- # 5.6.2 could not do the local() with the reference
- # so we do it manually instead
- my $old_loadcode = ${"$yaml_module\::LoadCode"};
- ${ "$yaml_module\::LoadCode" } = $CPAN::Config->{yaml_load_code} || 0;
-
- my ($code, @yaml);
- if ($code = UNIVERSAL::can($yaml_module, "LoadFile")) {
- eval { @yaml = $code->($local_file); };
- if ($@) {
- # this shall not be done by the frontend
- die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
- }
- } elsif ($code = UNIVERSAL::can($yaml_module, "Load")) {
- local *FH;
- open FH, $local_file or die "Could not open '$local_file': $!";
- local $/;
- my $ystream = <FH>;
- eval { @yaml = $code->($ystream); };
- if ($@) {
- # this shall not be done by the frontend
- die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"parse",$@);
- }
- }
- ${"$yaml_module\::LoadCode"} = $old_loadcode;
- return \@yaml;
- } else {
- # this shall not be done by the frontend
- die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "parse");
- }
- return +[];
-}
-
-# CPAN::_yaml_dumpfile
-sub _yaml_dumpfile {
- my($self,$local_file, at what) = @_;
- my $yaml_module = _yaml_module;
- if ($CPAN::META->has_inst($yaml_module)) {
- my $code;
- if (UNIVERSAL::isa($local_file, "FileHandle")) {
- $code = UNIVERSAL::can($yaml_module, "Dump");
- eval { print $local_file $code->(@what) };
- } elsif ($code = UNIVERSAL::can($yaml_module, "DumpFile")) {
- eval { $code->($local_file, at what); };
- } elsif ($code = UNIVERSAL::can($yaml_module, "Dump")) {
- local *FH;
- open FH, ">$local_file" or die "Could not open '$local_file': $!";
- print FH $code->(@what);
- }
- if ($@) {
- die CPAN::Exception::yaml_process_error->new($yaml_module,$local_file,"dump",$@);
- }
- } else {
- if (UNIVERSAL::isa($local_file, "FileHandle")) {
- # I think this case does not justify a warning at all
- } else {
- die CPAN::Exception::yaml_not_installed->new($yaml_module, $local_file, "dump");
- }
- }
-}
-
-sub _init_sqlite () {
- unless ($CPAN::META->has_inst("CPAN::SQLite")) {
- $CPAN::Frontend->mywarn(qq{CPAN::SQLite not installed, trying to work without\n})
- unless $Have_warned->{"CPAN::SQLite"}++;
- return;
- }
- require CPAN::SQLite::META; # not needed since CVS version of 2006-12-17
- $CPAN::SQLite ||= CPAN::SQLite::META->new($CPAN::META);
-}
-
-{
- my $negative_cache = {};
- sub _sqlite_running {
- if ($negative_cache->{time} && time < $negative_cache->{time} + 60) {
- # need to cache the result, otherwise too slow
- return $negative_cache->{fact};
- } else {
- $negative_cache = {}; # reset
- }
- my $ret = $CPAN::Config->{use_sqlite} && ($CPAN::SQLite || _init_sqlite());
- return $ret if $ret; # fast anyway
- $negative_cache->{time} = time;
- return $negative_cache->{fact} = $ret;
- }
-}
-
-$META ||= CPAN->new; # In case we re-eval ourselves we need the ||
-
-# from here on only subs.
-################################################################################
-
-sub _perl_fingerprint {
- my($self,$other_fingerprint) = @_;
- my $dll = eval {OS2::DLLname()};
- my $mtime_dll = 0;
- if (defined $dll) {
- $mtime_dll = (-f $dll ? (stat(_))[9] : '-1');
- }
- my $mtime_perl = (-f CPAN::find_perl ? (stat(_))[9] : '-1');
- my $this_fingerprint = {
- '$^X' => CPAN::find_perl,
- sitearchexp => $Config::Config{sitearchexp},
- 'mtime_$^X' => $mtime_perl,
- 'mtime_dll' => $mtime_dll,
- };
- if ($other_fingerprint) {
- if (exists $other_fingerprint->{'stat($^X)'}) { # repair fp from rev. 1.88_57
- $other_fingerprint->{'mtime_$^X'} = $other_fingerprint->{'stat($^X)'}[9];
- }
- # mandatory keys since 1.88_57
- for my $key (qw($^X sitearchexp mtime_dll mtime_$^X)) {
- return unless $other_fingerprint->{$key} eq $this_fingerprint->{$key};
- }
- return 1;
- } else {
- return $this_fingerprint;
- }
-}
-
-sub suggest_myconfig () {
- SUGGEST_MYCONFIG: if(!$INC{'CPAN/MyConfig.pm'}) {
- $CPAN::Frontend->myprint("You don't seem to have a user ".
- "configuration (MyConfig.pm) yet.\n");
- my $new = CPAN::Shell::colorable_makemaker_prompt("Do you want to create a ".
- "user configuration now? (Y/n)",
- "yes");
- if($new =~ m{^y}i) {
- CPAN::Shell->mkmyconfig();
- return &checklock;
- } else {
- $CPAN::Frontend->mydie("OK, giving up.");
- }
- }
-}
-
-#-> sub CPAN::all_objects ;
-sub all_objects {
- my($mgr,$class) = @_;
- CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
- CPAN->debug("mgr[$mgr] class[$class]") if $CPAN::DEBUG;
- CPAN::Index->reload;
- values %{ $META->{readwrite}{$class} }; # unsafe meta access, ok
-}
-
-# Called by shell, not in batch mode. In batch mode I see no risk in
-# having many processes updating something as installations are
-# continually checked at runtime. In shell mode I suspect it is
-# unintentional to open more than one shell at a time
-
-#-> sub CPAN::checklock ;
-sub checklock {
- my($self) = @_;
- my $lockfile = File::Spec->catfile($CPAN::Config->{cpan_home},".lock");
- if (-f $lockfile && -M _ > 0) {
- my $fh = FileHandle->new($lockfile) or
- $CPAN::Frontend->mydie("Could not open lockfile '$lockfile': $!");
- my $otherpid = <$fh>;
- my $otherhost = <$fh>;
- $fh->close;
- if (defined $otherpid && $otherpid) {
- chomp $otherpid;
- }
- if (defined $otherhost && $otherhost) {
- chomp $otherhost;
- }
- my $thishost = hostname();
- if (defined $otherhost && defined $thishost &&
- $otherhost ne '' && $thishost ne '' &&
- $otherhost ne $thishost) {
- $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Lockfile '$lockfile'\n".
- "reports other host $otherhost and other ".
- "process $otherpid.\n".
- "Cannot proceed.\n"));
- } elsif ($RUN_DEGRADED) {
- $CPAN::Frontend->mywarn("Running in downgraded mode (experimental)\n");
- } elsif (defined $otherpid && $otherpid) {
- return if $$ == $otherpid; # should never happen
- $CPAN::Frontend->mywarn(
- qq{
-There seems to be running another CPAN process (pid $otherpid). Contacting...
-});
- if (kill 0, $otherpid or $!{EPERM}) {
- $CPAN::Frontend->mywarn(qq{Other job is running.\n});
- my($ans) =
- CPAN::Shell::colorable_makemaker_prompt
- (qq{Shall I try to run in downgraded }.
- qq{mode? (Y/n)},"y");
- if ($ans =~ /^y/i) {
- $CPAN::Frontend->mywarn("Running in downgraded mode (experimental).
-Please report if something unexpected happens\n");
- $RUN_DEGRADED = 1;
- for ($CPAN::Config) {
- # XXX
- # $_->{build_dir_reuse} = 0; # 2006-11-17 akoenig Why was that?
- $_->{commandnumber_in_prompt} = 0; # visibility
- $_->{histfile} = ""; # who should win otherwise?
- $_->{cache_metadata} = 0; # better would be a lock?
- $_->{use_sqlite} = 0; # better would be a write lock!
- $_->{auto_commit} = 0; # we are violent, do not persist
- $_->{test_report} = 0; # Oliver Paukstadt had sent wrong reports in degraded mode
- }
- } else {
- $CPAN::Frontend->mydie("
-You may want to kill the other job and delete the lockfile. On UNIX try:
- kill $otherpid
- rm $lockfile
-");
- }
- } elsif (-w $lockfile) {
- my($ans) =
- CPAN::Shell::colorable_makemaker_prompt
- (qq{Other job not responding. Shall I overwrite }.
- qq{the lockfile '$lockfile'? (Y/n)},"y");
- $CPAN::Frontend->myexit("Ok, bye\n")
- unless $ans =~ /^y/i;
- } else {
- Carp::croak(
- qq{Lockfile '$lockfile' not writable by you. }.
- qq{Cannot proceed.\n}.
- qq{ On UNIX try:\n}.
- qq{ rm '$lockfile'\n}.
- qq{ and then rerun us.\n}
- );
- }
- } else {
- $CPAN::Frontend->mydie(sprintf("CPAN.pm panic: Found invalid lockfile ".
- "'$lockfile', please remove. Cannot proceed.\n"));
- }
- }
- my $dotcpan = $CPAN::Config->{cpan_home};
- eval { File::Path::mkpath($dotcpan);};
- if ($@) {
- # A special case at least for Jarkko.
- my $firsterror = $@;
- my $seconderror;
- my $symlinkcpan;
- if (-l $dotcpan) {
- $symlinkcpan = readlink $dotcpan;
- die "readlink $dotcpan failed: $!" unless defined $symlinkcpan;
- eval { File::Path::mkpath($symlinkcpan); };
- if ($@) {
- $seconderror = $@;
- } else {
- $CPAN::Frontend->mywarn(qq{
-Working directory $symlinkcpan created.
-});
- }
- }
- unless (-d $dotcpan) {
- my $mess = qq{
-Your configuration suggests "$dotcpan" as your
-CPAN.pm working directory. I could not create this directory due
-to this error: $firsterror\n};
- $mess .= qq{
-As "$dotcpan" is a symlink to "$symlinkcpan",
-I tried to create that, but I failed with this error: $seconderror
-} if $seconderror;
- $mess .= qq{
-Please make sure the directory exists and is writable.
-};
- $CPAN::Frontend->mywarn($mess);
- return suggest_myconfig;
- }
- } # $@ after eval mkpath $dotcpan
- if (0) { # to test what happens when a race condition occurs
- for (reverse 1..10) {
- print $_, "\n";
- sleep 1;
- }
- }
- # locking
- if (!$RUN_DEGRADED && !$self->{LOCKFH}) {
- my $fh;
- unless ($fh = FileHandle->new("+>>$lockfile")) {
- if ($! =~ /Permission/) {
- $CPAN::Frontend->mywarn(qq{
-
-Your configuration suggests that CPAN.pm should use a working
-directory of
- $CPAN::Config->{cpan_home}
-Unfortunately we could not create the lock file
- $lockfile
-due to permission problems.
-
-Please make sure that the configuration variable
- \$CPAN::Config->{cpan_home}
-points to a directory where you can write a .lock file. You can set
-this variable in either a CPAN/MyConfig.pm or a CPAN/Config.pm in your
-\@INC path;
-});
- return suggest_myconfig;
- }
- }
- my $sleep = 1;
- while (!CPAN::_flock($fh, LOCK_EX|LOCK_NB)) {
- if ($sleep>10) {
- $CPAN::Frontend->mydie("Giving up\n");
- }
- $CPAN::Frontend->mysleep($sleep++);
- $CPAN::Frontend->mywarn("Could not lock lockfile with flock: $!; retrying\n");
- }
-
- seek $fh, 0, 0;
- truncate $fh, 0;
- $fh->autoflush(1);
- $fh->print($$, "\n");
- $fh->print(hostname(), "\n");
- $self->{LOCK} = $lockfile;
- $self->{LOCKFH} = $fh;
- }
- $SIG{TERM} = sub {
- my $sig = shift;
- &cleanup;
- $CPAN::Frontend->mydie("Got SIG$sig, leaving");
- };
- $SIG{INT} = sub {
- # no blocks!!!
- my $sig = shift;
- &cleanup if $Signal;
- die "Got yet another signal" if $Signal > 1;
- $CPAN::Frontend->mydie("Got another SIG$sig") if $Signal;
- $CPAN::Frontend->mywarn("Caught SIG$sig, trying to continue\n");
- $Signal++;
- };
-
-# From: Larry Wall <larry at wall.org>
-# Subject: Re: deprecating SIGDIE
-# To: perl5-porters at perl.org
-# Date: Thu, 30 Sep 1999 14:58:40 -0700 (PDT)
-#
-# The original intent of __DIE__ was only to allow you to substitute one
-# kind of death for another on an application-wide basis without respect
-# to whether you were in an eval or not. As a global backstop, it should
-# not be used any more lightly (or any more heavily :-) than class
-# UNIVERSAL. Any attempt to build a general exception model on it should
-# be politely squashed. Any bug that causes every eval {} to have to be
-# modified should be not so politely squashed.
-#
-# Those are my current opinions. It is also my optinion that polite
-# arguments degenerate to personal arguments far too frequently, and that
-# when they do, it's because both people wanted it to, or at least didn't
-# sufficiently want it not to.
-#
-# Larry
-
- # global backstop to cleanup if we should really die
- $SIG{__DIE__} = \&cleanup;
- $self->debug("Signal handler set.") if $CPAN::DEBUG;
-}
-
-#-> sub CPAN::DESTROY ;
-sub DESTROY {
- &cleanup; # need an eval?
-}
-
-#-> sub CPAN::anycwd ;
-sub anycwd () {
- my $getcwd;
- $getcwd = $CPAN::Config->{'getcwd'} || 'cwd';
- CPAN->$getcwd();
-}
-
-#-> sub CPAN::cwd ;
-sub cwd {Cwd::cwd();}
-
-#-> sub CPAN::getcwd ;
-sub getcwd {Cwd::getcwd();}
-
-#-> sub CPAN::fastcwd ;
-sub fastcwd {Cwd::fastcwd();}
-
-#-> sub CPAN::backtickcwd ;
-sub backtickcwd {my $cwd = `cwd`; chomp $cwd; $cwd}
-
-#-> sub CPAN::find_perl ;
-sub find_perl () {
- my($perl) = File::Spec->file_name_is_absolute($^X) ? $^X : "";
- unless ($perl) {
- my $candidate = File::Spec->catfile($CPAN::iCwd,$^X);
- $^X = $perl = $candidate if MM->maybe_command($candidate);
- }
- unless ($perl) {
- my ($component,$perl_name);
- DIST_PERLNAME: foreach $perl_name ($^X, 'perl', 'perl5', "perl$]") {
- PATH_COMPONENT: foreach $component (File::Spec->path(),
- $Config::Config{'binexp'}) {
- next unless defined($component) && $component;
- my($abs) = File::Spec->catfile($component,$perl_name);
- if (MM->maybe_command($abs)) {
- $^X = $perl = $abs;
- last DIST_PERLNAME;
- }
- }
- }
- }
- return $perl;
-}
-
-
-#-> sub CPAN::exists ;
-sub exists {
- my($mgr,$class,$id) = @_;
- CPAN::HandleConfig->load unless $CPAN::Config_loaded++;
- CPAN::Index->reload;
- ### Carp::croak "exists called without class argument" unless $class;
- $id ||= "";
- $id =~ s/:+/::/g if $class eq "CPAN::Module";
- my $exists;
- if (CPAN::_sqlite_running) {
- $exists = (exists $META->{readonly}{$class}{$id} or
- $CPAN::SQLite->set($class, $id));
- } else {
- $exists = exists $META->{readonly}{$class}{$id};
- }
- $exists ||= exists $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
-}
-
-#-> sub CPAN::delete ;
-sub delete {
- my($mgr,$class,$id) = @_;
- delete $META->{readonly}{$class}{$id}; # unsafe meta access, ok
- delete $META->{readwrite}{$class}{$id}; # unsafe meta access, ok
-}
-
-#-> sub CPAN::has_usable
-# has_inst is sometimes too optimistic, we should replace it with this
-# has_usable whenever a case is given
-sub has_usable {
- my($self,$mod,$message) = @_;
- return 1 if $HAS_USABLE->{$mod};
- my $has_inst = $self->has_inst($mod,$message);
- return unless $has_inst;
- my $usable;
- $usable = {
- LWP => [ # we frequently had "Can't locate object
- # method "new" via package "LWP::UserAgent" at
- # (eval 69) line 2006
- sub {require LWP},
- sub {require LWP::UserAgent},
- sub {require HTTP::Request},
- sub {require URI::URL},
- ],
- 'Net::FTP' => [
- sub {require Net::FTP},
- sub {require Net::Config},
- ],
- 'File::HomeDir' => [
- sub {require File::HomeDir;
- unless (CPAN::Version->vge(File::HomeDir::->VERSION, 0.52)) {
- for ("Will not use File::HomeDir, need 0.52\n") {
- $CPAN::Frontend->mywarn($_);
- die $_;
- }
- }
- },
- ],
- 'Archive::Tar' => [
- sub {require Archive::Tar;
- unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.50)) {
- for ("Will not use Archive::Tar, need 1.00\n") {
- $CPAN::Frontend->mywarn($_);
- die $_;
- }
- }
- unless (CPAN::Version->vge(Archive::Tar::->VERSION, 1.50)) {
- my $atv = Archive::Tar->VERSION;
- $CPAN::Frontend->mywarn("You have Archive::Tar $atv, but 1.50 or later is recommended. Please upgrade.\n");
- }
- },
- ],
- 'File::Temp' => [
- # XXX we should probably delete from
- # %INC too so we can load after we
- # installed a new enough version --
- # I'm not sure.
- sub {require File::Temp;
- unless (CPAN::Version->vge(File::Temp::->VERSION,0.16)) {
- for ("Will not use File::Temp, need 0.16\n") {
- $CPAN::Frontend->mywarn($_);
- die $_;
- }
- }
- },
- ]
- };
- if ($usable->{$mod}) {
- for my $c (0..$#{$usable->{$mod}}) {
- my $code = $usable->{$mod}[$c];
- my $ret = eval { &$code() };
- $ret = "" unless defined $ret;
- if ($@) {
- # warn "DEBUG: c[$c]\$\@[$@]ret[$ret]";
- return;
- }
- }
- }
- return $HAS_USABLE->{$mod} = 1;
-}
-
-#-> sub CPAN::has_inst
-sub has_inst {
- my($self,$mod,$message) = @_;
- Carp::croak("CPAN->has_inst() called without an argument")
- unless defined $mod;
- my %dont = map { $_ => 1 } keys %{$CPAN::META->{dontload_hash}||{}},
- keys %{$CPAN::Config->{dontload_hash}||{}},
- @{$CPAN::Config->{dontload_list}||[]};
- if (defined $message && $message eq "no" # afair only used by Nox
- ||
- $dont{$mod}
- ) {
- $CPAN::META->{dontload_hash}{$mod}||=1; # unsafe meta access, ok
- return 0;
- }
- my $file = $mod;
- my $obj;
- $file =~ s|::|/|g;
- $file .= ".pm";
- if ($INC{$file}) {
- # checking %INC is wrong, because $INC{LWP} may be true
- # although $INC{"URI/URL.pm"} may have failed. But as
- # I really want to say "bla loaded OK", I have to somehow
- # cache results.
- ### warn "$file in %INC"; #debug
- return 1;
- } elsif (eval { require $file }) {
- # eval is good: if we haven't yet read the database it's
- # perfect and if we have installed the module in the meantime,
- # it tries again. The second require is only a NOOP returning
- # 1 if we had success, otherwise it's retrying
-
- my $mtime = (stat $INC{$file})[9];
- # privileged files loaded by has_inst; Note: we use $mtime
- # as a proxy for a checksum.
- $CPAN::Shell::reload->{$file} = $mtime;
- my $v = eval "\$$mod\::VERSION";
- $v = $v ? " (v$v)" : "";
- CPAN::Shell->optprint("load_module","CPAN: $mod loaded ok$v\n");
- if ($mod eq "CPAN::WAIT") {
- push @CPAN::Shell::ISA, 'CPAN::WAIT';
- }
- return 1;
- } elsif ($mod eq "Net::FTP") {
- $CPAN::Frontend->mywarn(qq{
- Please, install Net::FTP as soon as possible. CPAN.pm installs it for you
- if you just type
- install Bundle::libnet
-
-}) unless $Have_warned->{"Net::FTP"}++;
- $CPAN::Frontend->mysleep(3);
- } elsif ($mod eq "Digest::SHA") {
- if ($Have_warned->{"Digest::SHA"}++) {
- $CPAN::Frontend->mywarn(qq{CPAN: checksum security checks disabled }.
- qq{because Digest::SHA not installed.\n});
- } else {
- $CPAN::Frontend->mywarn(qq{
- CPAN: checksum security checks disabled because Digest::SHA not installed.
- Please consider installing the Digest::SHA module.
-
-});
- $CPAN::Frontend->mysleep(2);
- }
- } elsif ($mod eq "Module::Signature") {
- # NOT prefs_lookup, we are not a distro
- my $check_sigs = $CPAN::Config->{check_sigs};
- if (not $check_sigs) {
- # they do not want us:-(
- } elsif (not $Have_warned->{"Module::Signature"}++) {
- # No point in complaining unless the user can
- # reasonably install and use it.
- if (eval { require Crypt::OpenPGP; 1 } ||
- (
- defined $CPAN::Config->{'gpg'}
- &&
- $CPAN::Config->{'gpg'} =~ /\S/
- )
- ) {
- $CPAN::Frontend->mywarn(qq{
- CPAN: Module::Signature security checks disabled because Module::Signature
- not installed. Please consider installing the Module::Signature module.
- You may also need to be able to connect over the Internet to the public
- keyservers like pgp.mit.edu (port 11371).
-
-});
- $CPAN::Frontend->mysleep(2);
- }
- }
- } else {
- delete $INC{$file}; # if it inc'd LWP but failed during, say, URI
- }
- return 0;
-}
-
-#-> sub CPAN::instance ;
-sub instance {
- my($mgr,$class,$id) = @_;
- CPAN::Index->reload;
- $id ||= "";
- # unsafe meta access, ok?
- return $META->{readwrite}{$class}{$id} if exists $META->{readwrite}{$class}{$id};
- $META->{readwrite}{$class}{$id} ||= $class->new(ID => $id);
-}
-
-#-> sub CPAN::new ;
-sub new {
- bless {}, shift;
-}
-
-#-> sub CPAN::cleanup ;
-sub cleanup {
- # warn "cleanup called with arg[@_] End[$CPAN::End] Signal[$Signal]";
- local $SIG{__DIE__} = '';
- my($message) = @_;
- my $i = 0;
- my $ineval = 0;
- my($subroutine);
- while ((undef,undef,undef,$subroutine) = caller(++$i)) {
- $ineval = 1, last if
- $subroutine eq '(eval)';
- }
- return if $ineval && !$CPAN::End;
- return unless defined $META->{LOCK};
- return unless -f $META->{LOCK};
- $META->savehist;
- close $META->{LOCKFH};
- unlink $META->{LOCK};
- # require Carp;
- # Carp::cluck("DEBUGGING");
- if ( $CPAN::CONFIG_DIRTY ) {
- $CPAN::Frontend->mywarn("Warning: Configuration not saved.\n");
- }
- $CPAN::Frontend->myprint("Lockfile removed.\n");
-}
-
-#-> sub CPAN::readhist
-sub readhist {
- my($self,$term,$histfile) = @_;
- my $histsize = $CPAN::Config->{'histsize'} || 100;
- $term->Attribs->{'MaxHistorySize'} = $histsize if (defined($term->Attribs->{'MaxHistorySize'}));
- my($fh) = FileHandle->new;
- open $fh, "<$histfile" or return;
- local $/ = "\n";
- while (<$fh>) {
- chomp;
- $term->AddHistory($_);
- }
- close $fh;
-}
-
-#-> sub CPAN::savehist
-sub savehist {
- my($self) = @_;
- my($histfile,$histsize);
- unless ($histfile = $CPAN::Config->{'histfile'}) {
- $CPAN::Frontend->mywarn("No history written (no histfile specified).\n");
- return;
- }
- $histsize = $CPAN::Config->{'histsize'} || 100;
- if ($CPAN::term) {
- unless ($CPAN::term->can("GetHistory")) {
- $CPAN::Frontend->mywarn("Terminal does not support GetHistory.\n");
- return;
- }
- } else {
- return;
- }
- my @h = $CPAN::term->GetHistory;
- splice @h, 0, @h-$histsize if @h>$histsize;
- my($fh) = FileHandle->new;
- open $fh, ">$histfile" or $CPAN::Frontend->mydie("Couldn't open >$histfile: $!");
- local $\ = local $, = "\n";
- print $fh @h;
- close $fh;
-}
-
-#-> sub CPAN::is_tested
-sub is_tested {
- my($self,$what,$when) = @_;
- unless ($what) {
- Carp::cluck("DEBUG: empty what");
- return;
- }
- $self->{is_tested}{$what} = $when;
-}
-
-#-> sub CPAN::reset_tested
-# forget all distributions tested -- resets what gets included in PERL5LIB
-sub reset_tested {
- my ($self) = @_;
- $self->{is_tested} = {};
-}
-
-#-> sub CPAN::is_installed
-# unsets the is_tested flag: as soon as the thing is installed, it is
-# not needed in set_perl5lib anymore
-sub is_installed {
- my($self,$what) = @_;
- delete $self->{is_tested}{$what};
-}
-
-sub _list_sorted_descending_is_tested {
- my($self) = @_;
- sort
- { ($self->{is_tested}{$b}||0) <=> ($self->{is_tested}{$a}||0) }
- keys %{$self->{is_tested}}
-}
-
-#-> sub CPAN::set_perl5lib
-# Notes on max environment variable length:
-# - Win32 : XP or later, 8191; Win2000 or NT4, 2047
-{
-my $fh;
-sub set_perl5lib {
- my($self,$for) = @_;
- unless ($for) {
- (undef,undef,undef,$for) = caller(1);
- $for =~ s/.*://;
- }
- $self->{is_tested} ||= {};
- return unless %{$self->{is_tested}};
- my $env = $ENV{PERL5LIB};
- $env = $ENV{PERLLIB} unless defined $env;
- my @env;
- push @env, split /\Q$Config::Config{path_sep}\E/, $env if defined $env and length $env;
- #my @dirs = map {("$_/blib/arch", "$_/blib/lib")} keys %{$self->{is_tested}};
- #$CPAN::Frontend->myprint("Prepending @dirs to PERL5LIB.\n");
-
- my @dirs = map {("$_/blib/arch", "$_/blib/lib")} $self->_list_sorted_descending_is_tested;
- return if !@dirs;
-
- if (@dirs < 12) {
- $CPAN::Frontend->optprint('perl5lib', "Prepending @dirs to PERL5LIB for '$for'\n");
- $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
- } elsif (@dirs < 24 ) {
- my @d = map {my $cp = $_;
- $cp =~ s/^\Q$CPAN::Config->{build_dir}\E/%BUILDDIR%/;
- $cp
- } @dirs;
- $CPAN::Frontend->optprint('perl5lib', "Prepending @d to PERL5LIB; ".
- "%BUILDDIR%=$CPAN::Config->{build_dir} ".
- "for '$for'\n"
- );
- $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
- } else {
- my $cnt = keys %{$self->{is_tested}};
- $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ".
- "$cnt build dirs to PERL5LIB; ".
- "for '$for'\n"
- );
- $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env;
- }
-}}
-
-
-1;
-
-
-__END__
-
-=head1 NAME
-
-CPAN - query, download and build perl modules from CPAN sites
-
-=head1 SYNOPSIS
-
-Interactive mode:
-
- perl -MCPAN -e shell
-
---or--
-
- cpan
-
-Basic commands:
-
- # Modules:
-
- cpan> install Acme::Meta # in the shell
-
- CPAN::Shell->install("Acme::Meta"); # in perl
-
- # Distributions:
-
- cpan> install NWCLARK/Acme-Meta-0.02.tar.gz # in the shell
-
- CPAN::Shell->
- install("NWCLARK/Acme-Meta-0.02.tar.gz"); # in perl
-
- # module objects:
-
- $mo = CPAN::Shell->expandany($mod);
- $mo = CPAN::Shell->expand("Module",$mod); # same thing
-
- # distribution objects:
-
- $do = CPAN::Shell->expand("Module",$mod)->distribution;
- $do = CPAN::Shell->expandany($distro); # same thing
- $do = CPAN::Shell->expand("Distribution",
- $distro); # same thing
-
-=head1 DESCRIPTION
-
-The CPAN module automates or at least simplifies the make and install
-of perl modules and extensions. It includes some primitive searching
-capabilities and knows how to use Net::FTP, LWP, and certain external
-download clients to fetch distributions from the net.
-
-These are fetched from one or more mirrored CPAN (Comprehensive
-Perl Archive Network) sites and unpacked in a dedicated directory.
-
-The CPAN module also supports named and versioned
-I<bundles> of modules. Bundles simplify handling of sets of
-related modules. See Bundles below.
-
-The package contains a session manager and a cache manager. The
-session manager keeps track of what has been fetched, built, and
-installed in the current session. The cache manager keeps track of the
-disk space occupied by the make processes and deletes excess space
-using a simple FIFO mechanism.
-
-All methods provided are accessible in a programmer style and in an
-interactive shell style.
-
-=head2 CPAN::shell([$prompt, $command]) Starting Interactive Mode
-
-Enter interactive mode by running
-
- perl -MCPAN -e shell
-
-or
-
- cpan
-
-which puts you into a readline interface. If C<Term::ReadKey> and
-either of C<Term::ReadLine::Perl> or C<Term::ReadLine::Gnu> are installed,
-history and command completion are supported.
-
-Once at the command line, type C<h> for one-page help
-screen; the rest should be self-explanatory.
-
-The function call C<shell> takes two optional arguments: one the
-prompt, the second the default initial command line (the latter
-only works if a real ReadLine interface module is installed).
-
-The most common uses of the interactive modes are
-
-=over 2
-
-=item Searching for authors, bundles, distribution files and modules
-
-There are corresponding one-letter commands C<a>, C<b>, C<d>, and C<m>
-for each of the four categories and another, C<i> for any of the
-mentioned four. Each of the four entities is implemented as a class
-with slightly differing methods for displaying an object.
-
-Arguments to these commands are either strings exactly matching
-the identification string of an object, or regular expressions
-matched case-insensitively against various attributes of the
-objects. The parser only recognizes a regular expression when you
-enclose it with slashes.
-
-The principle is that the number of objects found influences how an
-item is displayed. If the search finds one item, the result is
-displayed with the rather verbose method C<as_string>, but if
-more than one is found, each object is displayed with the terse method
-C<as_glimpse>.
-
-Examples:
-
- cpan> m Acme::MetaSyntactic
- Module id = Acme::MetaSyntactic
- CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
- CPAN_VERSION 0.99
- CPAN_FILE B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
- UPLOAD_DATE 2006-11-06
- MANPAGE Acme::MetaSyntactic - Themed metasyntactic variables names
- INST_FILE /usr/local/lib/perl/5.10.0/Acme/MetaSyntactic.pm
- INST_VERSION 0.99
- cpan> a BOOK
- Author id = BOOK
- EMAIL [...]
- FULLNAME Philippe Bruhat (BooK)
- cpan> d BOOK/Acme-MetaSyntactic-0.99.tar.gz
- Distribution id = B/BO/BOOK/Acme-MetaSyntactic-0.99.tar.gz
- CPAN_USERID BOOK (Philippe Bruhat (BooK) <[...]>)
- CONTAINSMODS Acme::MetaSyntactic Acme::MetaSyntactic::Alias [...]
- UPLOAD_DATE 2006-11-06
- cpan> m /lorem/
- Module = Acme::MetaSyntactic::loremipsum (BOOK/Acme-MetaSyntactic-0.99.tar.gz)
- Module Text::Lorem (ADEOLA/Text-Lorem-0.3.tar.gz)
- Module Text::Lorem::More (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
- Module Text::Lorem::More::Source (RKRIMEN/Text-Lorem-More-0.12.tar.gz)
- cpan> i /berlin/
- Distribution BEATNIK/Filter-NumberLines-0.02.tar.gz
- Module = DateTime::TimeZone::Europe::Berlin (DROLSKY/DateTime-TimeZone-0.7904.tar.gz)
- Module Filter::NumberLines (BEATNIK/Filter-NumberLines-0.02.tar.gz)
- Author [...]
-
-The examples illustrate several aspects: the first three queries
-target modules, authors, or distros directly and yield exactly one
-result. The last two use regular expressions and yield several
-results. The last one targets all of bundles, modules, authors, and
-distros simultaneously. When more than one result is available, they
-are printed in one-line format.
-
-=item C<get>, C<make>, C<test>, C<install>, C<clean> modules or distributions
-
-These commands take any number of arguments and investigate what is
-necessary to perform the action. If the argument is a distribution
-file name (recognized by embedded slashes), it is processed. If it is
-a module, CPAN determines the distribution file in which this module
-is included and processes that, following any dependencies named in
-the module's META.yml or Makefile.PL (this behavior is controlled by
-the configuration parameter C<prerequisites_policy>.)
-
-C<get> downloads a distribution file and untars or unzips it, C<make>
-builds it, C<test> runs the test suite, and C<install> installs it.
-
-Any C<make> or C<test> is run unconditionally. An
-
- install <distribution_file>
-
-is also run unconditionally. But for
-
- install <module>
-
-CPAN checks whether an install is needed and prints
-I<module up to date> if the distribution file containing
-the module doesn't need updating.
-
-CPAN also keeps track of what it has done within the current session
-and doesn't try to build a package a second time regardless of whether it
-succeeded or not. It does not repeat a test run if the test
-has been run successfully before. Same for install runs.
-
-The C<force> pragma may precede another command (currently: C<get>,
-C<make>, C<test>, or C<install>) to execute the command from scratch
-and attempt to continue past certain errors. See the section below on
-the C<force> and the C<fforce> pragma.
-
-The C<notest> pragma skips the test part in the build
-process.
-
-Example:
-
- cpan> notest install Tk
-
-A C<clean> command results in a
-
- make clean
-
-being executed within the distribution file's working directory.
-
-=item C<readme>, C<perldoc>, C<look> module or distribution
-
-C<readme> displays the README file of the associated distribution.
-C<Look> gets and untars (if not yet done) the distribution file,
-changes to the appropriate directory and opens a subshell process in
-that directory. C<perldoc> displays the module's pod documentation
-in html or plain text format.
-
-=item C<ls> author
-
-=item C<ls> globbing_expression
-
-The first form lists all distribution files in and below an author's
-CPAN directory as stored in the CHECKUMS files distributed on
-CPAN. The listing recurses into subdirectories.
-
-The second form limits or expands the output with shell
-globbing as in the following examples:
-
- ls JV/make*
- ls GSAR/*make*
- ls */*make*
-
-The last example is very slow and outputs extra progress indicators
-that break the alignment of the result.
-
-Note that globbing only lists directories explicitly asked for, for
-example FOO/* will not list FOO/bar/Acme-Sthg-n.nn.tar.gz. This may be
-regarded as a bug that may be changed in some future version.
-
-=item C<failed>
-
-The C<failed> command reports all distributions that failed on one of
-C<make>, C<test> or C<install> for some reason in the currently
-running shell session.
-
-=item Persistence between sessions
-
-If the C<YAML> or the C<YAML::Syck> module is installed a record of
-the internal state of all modules is written to disk after each step.
-The files contain a signature of the currently running perl version
-for later perusal.
-
-If the configurations variable C<build_dir_reuse> is set to a true
-value, then CPAN.pm reads the collected YAML files. If the stored
-signature matches the currently running perl, the stored state is
-loaded into memory such that persistence between sessions
-is effectively established.
-
-=item The C<force> and the C<fforce> pragma
-
-To speed things up in complex installation scenarios, CPAN.pm keeps
-track of what it has already done and refuses to do some things a
-second time. A C<get>, a C<make>, and an C<install> are not repeated.
-A C<test> is repeated only if the previous test was unsuccessful. The
-diagnostic message when CPAN.pm refuses to do something a second time
-is one of I<Has already been >C<unwrapped|made|tested successfully> or
-something similar. Another situation where CPAN refuses to act is an
-C<install> if the corresponding C<test> was not successful.
-
-In all these cases, the user can override this stubborn behaviour by
-prepending the command with the word force, for example:
-
- cpan> force get Foo
- cpan> force make AUTHOR/Bar-3.14.tar.gz
- cpan> force test Baz
- cpan> force install Acme::Meta
-
-Each I<forced> command is executed with the corresponding part of its
-memory erased.
-
-The C<fforce> pragma is a variant that emulates a C<force get> which
-erases the entire memory followed by the action specified, effectively
-restarting the whole get/make/test/install procedure from scratch.
-
-=item Lockfile
-
-Interactive sessions maintain a lockfile, by default C<~/.cpan/.lock>.
-Batch jobs can run without a lockfile and not disturb each other.
-
-The shell offers to run in I<downgraded mode> when another process is
-holding the lockfile. This is an experimental feature that is not yet
-tested very well. This second shell then does not write the history
-file, does not use the metadata file, and has a different prompt.
-
-=item Signals
-
-CPAN.pm installs signal handlers for SIGINT and SIGTERM. While you are
-in the cpan-shell, it is intended that you can press C<^C> anytime and
-return to the cpan-shell prompt. A SIGTERM will cause the cpan-shell
-to clean up and leave the shell loop. You can emulate the effect of a
-SIGTERM by sending two consecutive SIGINTs, which usually means by
-pressing C<^C> twice.
-
-CPAN.pm ignores SIGPIPE. If the user sets C<inactivity_timeout>, a
-SIGALRM is used during the run of the C<perl Makefile.PL> or C<perl
-Build.PL> subprocess.
-
-=back
-
-=head2 CPAN::Shell
-
-The commands available in the shell interface are methods in
-the package CPAN::Shell. If you enter the shell command, your
-input is split by the Text::ParseWords::shellwords() routine, which
-acts like most shells do. The first word is interpreted as the
-method to be invoked, and the rest of the words are treated as the method's arguments.
-Continuation lines are supported by ending a line with a
-literal backslash.
-
-=head2 autobundle
-
-C<autobundle> writes a bundle file into the
-C<$CPAN::Config-E<gt>{cpan_home}/Bundle> directory. The file contains
-a list of all modules that are both available from CPAN and currently
-installed within @INC. The name of the bundle file is based on the
-current date and a counter.
-
-=head2 hosts
-
-Note: this feature is still in alpha state and may change in future
-versions of CPAN.pm
-
-This commands provides a statistical overview over recent download
-activities. The data for this is collected in the YAML file
-C<FTPstats.yml> in your C<cpan_home> directory. If no YAML module is
-configured or YAML not installed, no stats are provided.
-
-=head2 mkmyconfig
-
-mkmyconfig() writes your own CPAN::MyConfig file into your C<~/.cpan/>
-directory so that you can save your own preferences instead of the
-system-wide ones.
-
-=head2 recent ***EXPERIMENTAL COMMAND***
-
-The C<recent> command downloads a list of recent uploads to CPAN and
-displays them I<slowly>. While the command is running, a $SIG{INT}
-exits the loop after displaying the current item.
-
-B<Note>: This command requires XML::LibXML installed.
-
-B<Note>: This whole command currently is just a hack and will
-probably change in future versions of CPAN.pm, but the general
-approach will likely remain.
-
-B<Note>: See also L<smoke>
-
-=head2 recompile
-
-recompile() is a special command that takes no argument and
-runs the make/test/install cycle with brute force over all installed
-dynamically loadable extensions (aka XS modules) with 'force' in
-effect. The primary purpose of this command is to finish a network
-installation. Imagine you have a common source tree for two different
-architectures. You decide to do a completely independent fresh
-installation. You start on one architecture with the help of a Bundle
-file produced earlier. CPAN installs the whole Bundle for you, but
-when you try to repeat the job on the second architecture, CPAN
-responds with a C<"Foo up to date"> message for all modules. So you
-invoke CPAN's recompile on the second architecture and you're done.
-
-Another popular use for C<recompile> is to act as a rescue in case your
-perl breaks binary compatibility. If one of the modules that CPAN uses
-is in turn depending on binary compatibility (so you cannot run CPAN
-commands), then you should try the CPAN::Nox module for recovery.
-
-=head2 report Bundle|Distribution|Module
-
-The C<report> command temporarily turns on the C<test_report> config
-variable, then runs the C<force test> command with the given
-arguments. The C<force> pragma reruns the tests and repeats
-every step that might have failed before.
-
-=head2 smoke ***EXPERIMENTAL COMMAND***
-
-B<*** WARNING: this command downloads and executes software from CPAN to
-your computer of completely unknown status. You should never do
-this with your normal account and better have a dedicated well
-separated and secured machine to do this. ***>
-
-The C<smoke> command takes the list of recent uploads to CPAN as
-provided by the C<recent> command and tests them all. While the
-command is running $SIG{INT} is defined to mean that the current item
-shall be skipped.
-
-B<Note>: This whole command currently is just a hack and will
-probably change in future versions of CPAN.pm, but the general
-approach will likely remain.
-
-B<Note>: See also L<recent>
-
-=head2 upgrade [Module|/Regex/]...
-
-The C<upgrade> command first runs an C<r> command with the given
-arguments and then installs the newest versions of all modules that
-were listed by that.
-
-=head2 The four C<CPAN::*> Classes: Author, Bundle, Module, Distribution
-
-Although it may be considered internal, the class hierarchy does matter
-for both users and programmer. CPAN.pm deals with the four
-classes mentioned above, and those classes all share a set of methods. Classical
-single polymorphism is in effect. A metaclass object registers all
-objects of all kinds and indexes them with a string. The strings
-referencing objects have a separated namespace (well, not completely
-separated):
-
- Namespace Class
-
- words containing a "/" (slash) Distribution
- words starting with Bundle:: Bundle
- everything else Module or Author
-
-Modules know their associated Distribution objects. They always refer
-to the most recent official release. Developers may mark their releases
-as unstable development versions (by inserting an underbar into the
-module version number which will also be reflected in the distribution
-name when you run 'make dist'), so the really hottest and newest
-distribution is not always the default. If a module Foo circulates
-on CPAN in both version 1.23 and 1.23_90, CPAN.pm offers a convenient
-way to install version 1.23 by saying
-
- install Foo
-
-This would install the complete distribution file (say
-BAR/Foo-1.23.tar.gz) with all accompanying material. But if you would
-like to install version 1.23_90, you need to know where the
-distribution file resides on CPAN relative to the authors/id/
-directory. If the author is BAR, this might be BAR/Foo-1.23_90.tar.gz;
-so you would have to say
-
- install BAR/Foo-1.23_90.tar.gz
-
-The first example will be driven by an object of the class
-CPAN::Module, the second by an object of class CPAN::Distribution.
-
-=head2 Integrating local directories
-
-Note: this feature is still in alpha state and may change in future
-versions of CPAN.pm
-
-Distribution objects are normally distributions from the CPAN, but
-there is a slightly degenerate case for Distribution objects, too, of
-projects held on the local disk. These distribution objects have the
-same name as the local directory and end with a dot. A dot by itself
-is also allowed for the current directory at the time CPAN.pm was
-used. All actions such as C<make>, C<test>, and C<install> are applied
-directly to that directory. This gives the command C<cpan .> an
-interesting touch: while the normal mantra of installing a CPAN module
-without CPAN.pm is one of
-
- perl Makefile.PL perl Build.PL
- ( go and get prerequisites )
- make ./Build
- make test ./Build test
- make install ./Build install
-
-the command C<cpan .> does all of this at once. It figures out which
-of the two mantras is appropriate, fetches and installs all
-prerequisites, takes care of them recursively, and finally finishes the
-installation of the module in the current directory, be it a CPAN
-module or not.
-
-The typical usage case is for private modules or working copies of
-projects from remote repositories on the local disk.
-
-=head2 Redirection
-
-The usual shell redirection symbols C< | > and C<< > >> are recognized
-by the cpan shell B<only when surrounded by whitespace>. So piping to
-pager or redirecting output into a file works somewhat as in a normal
-shell, with the stipulation that you must type extra spaces.
-
-=head1 CONFIGURATION
-
-When the CPAN module is used for the first time, a configuration
-dialogue tries to determine a couple of site specific options. The
-result of the dialog is stored in a hash reference C< $CPAN::Config >
-in a file CPAN/Config.pm.
-
-Default values defined in the CPAN/Config.pm file can be
-overridden in a user specific file: CPAN/MyConfig.pm. Such a file is
-best placed in C<$HOME/.cpan/CPAN/MyConfig.pm>, because C<$HOME/.cpan> is
-added to the search path of the CPAN module before the use() or
-require() statements. The mkmyconfig command writes this file for you.
-
-The C<o conf> command has various bells and whistles:
-
-=over
-
-=item completion support
-
-If you have a ReadLine module installed, you can hit TAB at any point
-of the commandline and C<o conf> will offer you completion for the
-built-in subcommands and/or config variable names.
-
-=item displaying some help: o conf help
-
-Displays a short help
-
-=item displaying current values: o conf [KEY]
-
-Displays the current value(s) for this config variable. Without KEY,
-displays all subcommands and config variables.
-
-Example:
-
- o conf shell
-
-If KEY starts and ends with a slash, the string in between is
-treated as a regular expression and only keys matching this regex
-are displayed
-
-Example:
-
- o conf /color/
-
-=item changing of scalar values: o conf KEY VALUE
-
-Sets the config variable KEY to VALUE. The empty string can be
-specified as usual in shells, with C<''> or C<"">
-
-Example:
-
- o conf wget /usr/bin/wget
-
-=item changing of list values: o conf KEY SHIFT|UNSHIFT|PUSH|POP|SPLICE|LIST
-
-If a config variable name ends with C<list>, it is a list. C<o conf
-KEY shift> removes the first element of the list, C<o conf KEY pop>
-removes the last element of the list. C<o conf KEYS unshift LIST>
-prepends a list of values to the list, C<o conf KEYS push LIST>
-appends a list of valued to the list.
-
-Likewise, C<o conf KEY splice LIST> passes the LIST to the corresponding
-splice command.
-
-Finally, any other list of arguments is taken as a new list value for
-the KEY variable discarding the previous value.
-
-Examples:
-
- o conf urllist unshift http://cpan.dev.local/CPAN
- o conf urllist splice 3 1
- o conf urllist http://cpan1.local http://cpan2.local ftp://ftp.perl.org
-
-=item reverting to saved: o conf defaults
-
-Reverts all config variables to the state in the saved config file.
-
-=item saving the config: o conf commit
-
-Saves all config variables to the current config file (CPAN/Config.pm
-or CPAN/MyConfig.pm that was loaded at start).
-
-=back
-
-The configuration dialog can be started any time later again by
-issuing the command C< o conf init > in the CPAN shell. A subset of
-the configuration dialog can be run by issuing C<o conf init WORD>
-where WORD is any valid config variable or a regular expression.
-
-=head2 Config Variables
-
-The following keys in the hash reference $CPAN::Config are
-currently defined:
-
- applypatch path to external prg
- auto_commit commit all changes to config variables to disk
- build_cache size of cache for directories to build modules
- build_dir locally accessible directory to build modules
- build_dir_reuse boolean if distros in build_dir are persistent
- build_requires_install_policy
- to install or not to install when a module is
- only needed for building. yes|no|ask/yes|ask/no
- bzip2 path to external prg
- cache_metadata use serializer to cache metadata
- check_sigs if signatures should be verified
- colorize_debug Term::ANSIColor attributes for debugging output
- colorize_output boolean if Term::ANSIColor should colorize output
- colorize_print Term::ANSIColor attributes for normal output
- colorize_warn Term::ANSIColor attributes for warnings
- commandnumber_in_prompt
- boolean if you want to see current command number
- commands_quote preferred character to use for quoting external
- commands when running them. Defaults to double
- quote on Windows, single tick everywhere else;
- can be set to space to disable quoting
- connect_to_internet_ok
- whether to ask if opening a connection is ok before
- urllist is specified
- cpan_home local directory reserved for this package
- curl path to external prg
- dontload_hash DEPRECATED
- dontload_list arrayref: modules in the list will not be
- loaded by the CPAN::has_inst() routine
- ftp path to external prg
- ftp_passive if set, the envariable FTP_PASSIVE is set for downloads
- ftp_proxy proxy host for ftp requests
- ftpstats_period max number of days to keep download statistics
- ftpstats_size max number of items to keep in the download statistics
- getcwd see below
- gpg path to external prg
- gzip location of external program gzip
- halt_on_failure stop processing after the first failure of queued
- items or dependencies
- histfile file to maintain history between sessions
- histsize maximum number of lines to keep in histfile
- http_proxy proxy host for http requests
- inactivity_timeout breaks interactive Makefile.PLs or Build.PLs
- after this many seconds inactivity. Set to 0 to
- disable timeouts.
- index_expire refetch index files after this many days
- inhibit_startup_message
- if true, suppress the startup message
- keep_source_where directory in which to keep the source (if we do)
- load_module_verbosity
- report loading of optional modules used by CPAN.pm
- lynx path to external prg
- make location of external make program
- make_arg arguments that should always be passed to 'make'
- make_install_make_command
- the make command for running 'make install', for
- example 'sudo make'
- make_install_arg same as make_arg for 'make install'
- makepl_arg arguments passed to 'perl Makefile.PL'
- mbuild_arg arguments passed to './Build'
- mbuild_install_arg arguments passed to './Build install'
- mbuild_install_build_command
- command to use instead of './Build' when we are
- in the install stage, for example 'sudo ./Build'
- mbuildpl_arg arguments passed to 'perl Build.PL'
- ncftp path to external prg
- ncftpget path to external prg
- no_proxy don't proxy to these hosts/domains (comma separated list)
- pager location of external program more (or any pager)
- password your password if you CPAN server wants one
- patch path to external prg
- patches_dir local directory containing patch files
- perl5lib_verbosity verbosity level for PERL5LIB additions
- prefer_installer legal values are MB and EUMM: if a module comes
- with both a Makefile.PL and a Build.PL, use the
- former (EUMM) or the latter (MB); if the module
- comes with only one of the two, that one will be
- used no matter the setting
- prerequisites_policy
- what to do if you are missing module prerequisites
- ('follow' automatically, 'ask' me, or 'ignore')
- prefs_dir local directory to store per-distro build options
- proxy_user username for accessing an authenticating proxy
- proxy_pass password for accessing an authenticating proxy
- randomize_urllist add some randomness to the sequence of the urllist
- scan_cache controls scanning of cache ('atstart' or 'never')
- shell your favorite shell
- show_unparsable_versions
- boolean if r command tells which modules are versionless
- show_upload_date boolean if commands should try to determine upload date
- show_zero_versions boolean if r command tells for which modules $version==0
- tar location of external program tar
- tar_verbosity verbosity level for the tar command
- term_is_latin deprecated: if true Unicode is translated to ISO-8859-1
- (and nonsense for characters outside latin range)
- term_ornaments boolean to turn ReadLine ornamenting on/off
- test_report email test reports (if CPAN::Reporter is installed)
- trust_test_report_history
- skip testing when previously tested ok (according to
- CPAN::Reporter history)
- unzip location of external program unzip
- urllist arrayref to nearby CPAN sites (or equivalent locations)
- use_sqlite use CPAN::SQLite for metadata storage (fast and lean)
- username your username if you CPAN server wants one
- wait_list arrayref to a wait server to try (See CPAN::WAIT)
- wget path to external prg
- yaml_load_code enable YAML code deserialisation via CPAN::DeferredCode
- yaml_module which module to use to read/write YAML files
-
-You can set and query each of these options interactively in the cpan
-shell with the C<o conf> or the C<o conf init> command as specified below.
-
-=over 2
-
-=item C<o conf E<lt>scalar optionE<gt>>
-
-prints the current value of the I<scalar option>
-
-=item C<o conf E<lt>scalar optionE<gt> E<lt>valueE<gt>>
-
-Sets the value of the I<scalar option> to I<value>
-
-=item C<o conf E<lt>list optionE<gt>>
-
-prints the current value of the I<list option> in MakeMaker's
-neatvalue format.
-
-=item C<o conf E<lt>list optionE<gt> [shift|pop]>
-
-shifts or pops the array in the I<list option> variable
-
-=item C<o conf E<lt>list optionE<gt> [unshift|push|splice] E<lt>listE<gt>>
-
-works like the corresponding perl commands.
-
-=item interactive editing: o conf init [MATCH|LIST]
-
-Runs an interactive configuration dialog for matching variables.
-Without argument runs the dialog over all supported config variables.
-To specify a MATCH the argument must be enclosed by slashes.
-
-Examples:
-
- o conf init ftp_passive ftp_proxy
- o conf init /color/
-
-Note: this method of setting config variables often provides more
-explanation about the functioning of a variable than the manpage.
-
-=back
-
-=head2 CPAN::anycwd($path): Note on config variable getcwd
-
-CPAN.pm changes the current working directory often and needs to
-determine its own current working directory. By default it uses
-Cwd::cwd, but if for some reason this doesn't work on your system,
-configure alternatives according to the following table:
-
-=over 4
-
-=item cwd
-
-Calls Cwd::cwd
-
-=item getcwd
-
-Calls Cwd::getcwd
-
-=item fastcwd
-
-Calls Cwd::fastcwd
-
-=item backtickcwd
-
-Calls the external command cwd.
-
-=back
-
-=head2 Note on the format of the urllist parameter
-
-urllist parameters are URLs according to RFC 1738. We do a little
-guessing if your URL is not compliant, but if you have problems with
-C<file> URLs, please try the correct format. Either:
-
- file://localhost/whatever/ftp/pub/CPAN/
-
-or
-
- file:///home/ftp/pub/CPAN/
-
-=head2 The urllist parameter has CD-ROM support
-
-The C<urllist> parameter of the configuration table contains a list of
-URLs used for downloading. If the list contains any
-C<file> URLs, CPAN always tries there first. This
-feature is disabled for index files. So the recommendation for the
-owner of a CD-ROM with CPAN contents is: include your local, possibly
-outdated CD-ROM as a C<file> URL at the end of urllist, e.g.
-
- o conf urllist push file://localhost/CDROM/CPAN
-
-CPAN.pm will then fetch the index files from one of the CPAN sites
-that come at the beginning of urllist. It will later check for each
-module to see whether there is a local copy of the most recent version.
-
-Another peculiarity of urllist is that the site that we could
-successfully fetch the last file from automatically gets a preference
-token and is tried as the first site for the next request. So if you
-add a new site at runtime it may happen that the previously preferred
-site will be tried another time. This means that if you want to disallow
-a site for the next transfer, it must be explicitly removed from
-urllist.
-
-=head2 Maintaining the urllist parameter
-
-If you have YAML.pm (or some other YAML module configured in
-C<yaml_module>) installed, CPAN.pm collects a few statistical data
-about recent downloads. You can view the statistics with the C<hosts>
-command or inspect them directly by looking into the C<FTPstats.yml>
-file in your C<cpan_home> directory.
-
-To get some interesting statistics, it is recommended that
-C<randomize_urllist> be set; this introduces some amount of
-randomness into the URL selection.
-
-=head2 The C<requires> and C<build_requires> dependency declarations
-
-Since CPAN.pm version 1.88_51 modules declared as C<build_requires> by
-a distribution are treated differently depending on the config
-variable C<build_requires_install_policy>. By setting
-C<build_requires_install_policy> to C<no>, such a module is not
-installed. It is only built and tested, and then kept in the list of
-tested but uninstalled modules. As such, it is available during the
-build of the dependent module by integrating the path to the
-C<blib/arch> and C<blib/lib> directories in the environment variable
-PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then
-both modules declared as C<requires> and those declared as
-C<build_requires> are treated alike. By setting to C<ask/yes> or
-C<ask/no>, CPAN.pm asks the user and sets the default accordingly.
-
-=head2 Configuration for individual distributions (I<Distroprefs>)
-
-(B<Note:> This feature has been introduced in CPAN.pm 1.8854 and is
-still considered beta quality)
-
-Distributions on CPAN usually behave according to what we call the
-CPAN mantra. Or since the advent of Module::Build we should talk about
-two mantras:
-
- perl Makefile.PL perl Build.PL
- make ./Build
- make test ./Build test
- make install ./Build install
-
-But some modules cannot be built with this mantra. They try to get
-some extra data from the user via the environment, extra arguments, or
-interactively--thus disturbing the installation of large bundles like
-Phalanx100 or modules with many dependencies like Plagger.
-
-The distroprefs system of C<CPAN.pm> addresses this problem by
-allowing the user to specify extra informations and recipes in YAML
-files to either
-
-=over
-
-=item
-
-pass additional arguments to one of the four commands,
-
-=item
-
-set environment variables
-
-=item
-
-instantiate an Expect object that reads from the console, waits for
-some regular expressions and enters some answers
-
-=item
-
-temporarily override assorted C<CPAN.pm> configuration variables
-
-=item
-
-specify dependencies the original maintainer forgot
-
-=item
-
-disable the installation of an object altogether
-
-=back
-
-See the YAML and Data::Dumper files that come with the C<CPAN.pm>
-distribution in the C<distroprefs/> directory for examples.
-
-=head2 Filenames
-
-The YAML files themselves must have the C<.yml> extension; all other
-files are ignored (for two exceptions see I<Fallback Data::Dumper and
-Storable> below). The containing directory can be specified in
-C<CPAN.pm> in the C<prefs_dir> config variable. Try C<o conf init
-prefs_dir> in the CPAN shell to set and activate the distroprefs
-system.
-
-Every YAML file may contain arbitrary documents according to the YAML
-specification, and every document is treated as an entity that
-can specify the treatment of a single distribution.
-
-Filenames can be picked arbitrarily; C<CPAN.pm> always reads
-all files (in alphabetical order) and takes the key C<match> (see
-below in I<Language Specs>) as a hashref containing match criteria
-that determine if the current distribution matches the YAML document
-or not.
-
-=head2 Fallback Data::Dumper and Storable
-
-If neither your configured C<yaml_module> nor YAML.pm is installed,
-CPAN.pm falls back to using Data::Dumper and Storable and looks for
-files with the extensions C<.dd> or C<.st> in the C<prefs_dir>
-directory. These files are expected to contain one or more hashrefs.
-For Data::Dumper generated files, this is expected to be done with by
-defining C<$VAR1>, C<$VAR2>, etc. The YAML shell would produce these
-with the command
-
- ysh < somefile.yml > somefile.dd
-
-For Storable files the rule is that they must be constructed such that
-C<Storable::retrieve(file)> returns an array reference and the array
-elements represent one distropref object each. The conversion from
-YAML would look like so:
-
- perl -MYAML=LoadFile -MStorable=nstore -e '
- @y=LoadFile(shift);
- nstore(\@y, shift)' somefile.yml somefile.st
-
-In bootstrapping situations it is usually sufficient to translate only
-a few YAML files to Data::Dumper for crucial modules like
-C<YAML::Syck>, C<YAML.pm> and C<Expect.pm>. If you prefer Storable
-over Data::Dumper, remember to pull out a Storable version that writes
-an older format than all the other Storable versions that will need to
-read them.
-
-=head2 Blueprint
-
-The following example contains all supported keywords and structures
-with the exception of C<eexpect> which can be used instead of
-C<expect>.
-
- ---
- comment: "Demo"
- match:
- module: "Dancing::Queen"
- distribution: "^CHACHACHA/Dancing-"
- not_distribution: "\.zip$"
- perl: "/usr/local/cariba-perl/bin/perl"
- perlconfig:
- archname: "freebsd"
- not_cc: "gcc"
- env:
- DANCING_FLOOR: "Shubiduh"
- disabled: 1
- cpanconfig:
- make: gmake
- pl:
- args:
- - "--somearg=specialcase"
-
- env: {}
-
- expect:
- - "Which is your favorite fruit"
- - "apple\n"
-
- make:
- args:
- - all
- - extra-all
-
- env: {}
-
- expect: []
-
- commendline: "echo SKIPPING make"
-
- test:
- args: []
-
- env: {}
-
- expect: []
-
- install:
- args: []
-
- env:
- WANT_TO_INSTALL: YES
-
- expect:
- - "Do you really want to install"
- - "y\n"
-
- patches:
- - "ABCDE/Fedcba-3.14-ABCDE-01.patch"
-
- depends:
- configure_requires:
- LWP: 5.8
- build_requires:
- Test::Exception: 0.25
- requires:
- Spiffy: 0.30
-
-
-=head2 Language Specs
-
-Every YAML document represents a single hash reference. The valid keys
-in this hash are as follows:
-
-=over
-
-=item comment [scalar]
-
-A comment
-
-=item cpanconfig [hash]
-
-Temporarily override assorted C<CPAN.pm> configuration variables.
-
-Supported are: C<build_requires_install_policy>, C<check_sigs>,
-C<make>, C<make_install_make_command>, C<prefer_installer>,
-C<test_report>. Please report as a bug when you need another one
-supported.
-
-=item depends [hash] *** EXPERIMENTAL FEATURE ***
-
-All three types, namely C<configure_requires>, C<build_requires>, and
-C<requires> are supported in the way specified in the META.yml
-specification. The current implementation I<merges> the specified
-dependencies with those declared by the package maintainer. In a
-future implementation this may be changed to override the original
-declaration.
-
-=item disabled [boolean]
-
-Specifies that this distribution shall not be processed at all.
-
-=item features [array] *** EXPERIMENTAL FEATURE ***
-
-Experimental implementation to deal with optional_features from
-META.yml. Still needs coordination with installer software and
-currently works only for META.yml declaring C<dynamic_config=0>. Use
-with caution.
-
-=item goto [string]
-
-The canonical name of a delegate distribution to install
-instead. Useful when a new version, although it tests OK itself,
-breaks something else or a developer release or a fork is already
-uploaded that is better than the last released version.
-
-=item install [hash]
-
-Processing instructions for the C<make install> or C<./Build install>
-phase of the CPAN mantra. See below under I<Processing Instructions>.
-
-=item make [hash]
-
-Processing instructions for the C<make> or C<./Build> phase of the
-CPAN mantra. See below under I<Processing Instructions>.
-
-=item match [hash]
-
-A hashref with one or more of the keys C<distribution>, C<modules>,
-C<perl>, C<perlconfig>, and C<env> that specify whether a document is
-targeted at a specific CPAN distribution or installation.
-Keys prefixed with C<not_> negates the corresponding match.
-
-The corresponding values are interpreted as regular expressions. The
-C<distribution> related one will be matched against the canonical
-distribution name, e.g. "AUTHOR/Foo-Bar-3.14.tar.gz".
-
-The C<module> related one will be matched against I<all> modules
-contained in the distribution until one module matches.
-
-The C<perl> related one will be matched against C<$^X> (but with the
-absolute path).
-
-The value associated with C<perlconfig> is itself a hashref that is
-matched against corresponding values in the C<%Config::Config> hash
-living in the C<Config.pm> module.
-Keys prefixed with C<not_> negates the corresponding match.
-
-The value associated with C<env> is itself a hashref that is
-matched against corresponding values in the C<%ENV> hash.
-Keys prefixed with C<not_> negates the corresponding match.
-
-If more than one restriction of C<module>, C<distribution>, etc. is
-specified, the results of the separately computed match values must
-all match. If so, the hashref represented by the
-YAML document is returned as the preference structure for the current
-distribution.
-
-=item patches [array]
-
-An array of patches on CPAN or on the local disk to be applied in
-order via an external patch program. If the value for the C<-p>
-parameter is C<0> or C<1> is determined by reading the patch
-beforehand. The path to each patch is either an absolute path on the
-local filesystem or relative to a patch directory specified in the
-C<patches_dir> configuration variable or in the format of a canonical
-distroname. For examples please consult the distroprefs/ directory in
-the CPAN.pm distribution (these examples are not installed by
-default).
-
-Note: if the C<applypatch> program is installed and C<CPAN::Config>
-knows about it B<and> a patch is written by the C<makepatch> program,
-then C<CPAN.pm> lets C<applypatch> apply the patch. Both C<makepatch>
-and C<applypatch> are available from CPAN in the C<JV/makepatch-*>
-distribution.
-
-=item pl [hash]
-
-Processing instructions for the C<perl Makefile.PL> or C<perl
-Build.PL> phase of the CPAN mantra. See below under I<Processing
-Instructions>.
-
-=item test [hash]
-
-Processing instructions for the C<make test> or C<./Build test> phase
-of the CPAN mantra. See below under I<Processing Instructions>.
-
-=back
-
-=head2 Processing Instructions
-
-=over
-
-=item args [array]
-
-Arguments to be added to the command line
-
-=item commandline
-
-A full commandline to run via C<system()>.
-During execution, the environment variable PERL is set
-to $^X (but with an absolute path). If C<commandline> is specified,
-C<args> is not used.
-
-=item eexpect [hash]
-
-Extended C<expect>. This is a hash reference with four allowed keys,
-C<mode>, C<timeout>, C<reuse>, and C<talk>.
-
-C<mode> may have the values C<deterministic> for the case where all
-questions come in the order written down and C<anyorder> for the case
-where the questions may come in any order. The default mode is
-C<deterministic>.
-
-C<timeout> denotes a timeout in seconds. Floating-point timeouts are
-OK. With C<mode=deterministic>, the timeout denotes the
-timeout per question; with C<mode=anyorder> it denotes the
-timeout per byte received from the stream or questions.
-
-C<talk> is a reference to an array that contains alternating questions
-and answers. Questions are regular expressions and answers are literal
-strings. The Expect module watches the stream from the
-execution of the external program (C<perl Makefile.PL>, C<perl
-Build.PL>, C<make>, etc.).
-
-For C<mode=deterministic>, the CPAN.pm injects the
-corresponding answer as soon as the stream matches the regular expression.
-
-For C<mode=anyorder> CPAN.pm answers a question as soon
-as the timeout is reached for the next byte in the input stream. In
-this mode you can use the C<reuse> parameter to decide what will
-happen with a question-answer pair after it has been used. In the
-default case (reuse=0) it is removed from the array, avoiding being
-used again accidentally. If you want to answer the
-question C<Do you really want to do that> several times, then it must
-be included in the array at least as often as you want this answer to
-be given. Setting the parameter C<reuse> to 1 makes this repetition
-unnecessary.
-
-=item env [hash]
-
-Environment variables to be set during the command
-
-=item expect [array]
-
-C<< expect: <array> >> is a short notation for
-
-eexpect:
- mode: deterministic
- timeout: 15
- talk: <array>
-
-=back
-
-=head2 Schema verification with C<Kwalify>
-
-If you have the C<Kwalify> module installed (which is part of the
-Bundle::CPANxxl), then all your distroprefs files are checked for
-syntactic correctness.
-
-=head2 Example Distroprefs Files
-
-C<CPAN.pm> comes with a collection of example YAML files. Note that these
-are really just examples and should not be used without care because
-they cannot fit everybody's purpose. After all, the authors of the
-packages that ask questions had a need to ask, so you should watch
-their questions and adjust the examples to your environment and your
-needs. You have been warned:-)
-
-=head1 PROGRAMMER'S INTERFACE
-
-If you do not enter the shell, shell commands are
-available both as methods (C<CPAN::Shell-E<gt>install(...)>) and as
-functions in the calling package (C<install(...)>). Before calling low-level
-commands, it makes sense to initialize components of CPAN you need, e.g.:
-
- CPAN::HandleConfig->load;
- CPAN::Shell::setup_output;
- CPAN::Index->reload;
-
-High-level commands do such initializations automatically.
-
-There's currently only one class that has a stable interface -
-CPAN::Shell. All commands that are available in the CPAN shell are
-methods of the class CPAN::Shell. Each of the commands that produce
-listings of modules (C<r>, C<autobundle>, C<u>) also return a list of
-the IDs of all modules within the list.
-
-=over 2
-
-=item expand($type, at things)
-
-The IDs of all objects available within a program are strings that can
-be expanded to the corresponding real objects with the
-C<CPAN::Shell-E<gt>expand("Module", at things)> method. Expand returns a
-list of CPAN::Module objects according to the C<@things> arguments
-given. In scalar context, it returns only the first element of the
-list.
-
-=item expandany(@things)
-
-Like expand, but returns objects of the appropriate type, i.e.
-CPAN::Bundle objects for bundles, CPAN::Module objects for modules, and
-CPAN::Distribution objects for distributions. Note: it does not expand
-to CPAN::Author objects.
-
-=item Programming Examples
-
-This enables the programmer to do operations that combine
-functionalities that are available in the shell.
-
- # install everything that is outdated on my disk:
- perl -MCPAN -e 'CPAN::Shell->install(CPAN::Shell->r)'
-
- # install my favorite programs if necessary:
- for $mod (qw(Net::FTP Digest::SHA Data::Dumper)) {
- CPAN::Shell->install($mod);
- }
-
- # list all modules on my disk that have no VERSION number
- for $mod (CPAN::Shell->expand("Module","/./")) {
- next unless $mod->inst_file;
- # MakeMaker convention for undefined $VERSION:
- next unless $mod->inst_version eq "undef";
- print "No VERSION in ", $mod->id, "\n";
- }
-
- # find out which distribution on CPAN contains a module:
- print CPAN::Shell->expand("Module","Apache::Constants")->cpan_file
-
-Or if you want to schedule a I<cron> job to watch CPAN, you could list
-all modules that need updating. First a quick and dirty way:
-
- perl -e 'use CPAN; CPAN::Shell->r;'
-
-If you don't want any output should all modules be
-up to date, parse the output of above command for the regular
-expression C</modules are up to date/> and decide to mail the output
-only if it doesn't match.
-
-If you prefer to do it more in a programmerish style in one single
-process, something like this may better suit you:
-
- # list all modules on my disk that have newer versions on CPAN
- for $mod (CPAN::Shell->expand("Module","/./")) {
- next unless $mod->inst_file;
- next if $mod->uptodate;
- printf "Module %s is installed as %s, could be updated to %s from CPAN\n",
- $mod->id, $mod->inst_version, $mod->cpan_version;
- }
-
-If that gives too much output every day, you may want to
-watch only for three modules. You can write
-
- for $mod (CPAN::Shell->expand("Module","/Apache|LWP|CGI/")) {
-
-as the first line instead. Or you can combine some of the above
-tricks:
-
- # watch only for a new mod_perl module
- $mod = CPAN::Shell->expand("Module","mod_perl");
- exit if $mod->uptodate;
- # new mod_perl arrived, let me know all update recommendations
- CPAN::Shell->r;
-
-=back
-
-=head2 Methods in the other Classes
-
-=over 4
-
-=item CPAN::Author::as_glimpse()
-
-Returns a one-line description of the author
-
-=item CPAN::Author::as_string()
-
-Returns a multi-line description of the author
-
-=item CPAN::Author::email()
-
-Returns the author's email address
-
-=item CPAN::Author::fullname()
-
-Returns the author's name
-
-=item CPAN::Author::name()
-
-An alias for fullname
-
-=item CPAN::Bundle::as_glimpse()
-
-Returns a one-line description of the bundle
-
-=item CPAN::Bundle::as_string()
-
-Returns a multi-line description of the bundle
-
-=item CPAN::Bundle::clean()
-
-Recursively runs the C<clean> method on all items contained in the bundle.
-
-=item CPAN::Bundle::contains()
-
-Returns a list of objects' IDs contained in a bundle. The associated
-objects may be bundles, modules or distributions.
-
-=item CPAN::Bundle::force($method, at args)
-
-Forces CPAN to perform a task that it normally would have refused to
-do. Force takes as arguments a method name to be called and any number
-of additional arguments that should be passed to the called method.
-The internals of the object get the needed changes so that CPAN.pm
-does not refuse to take the action. The C<force> is passed recursively
-to all contained objects. See also the section above on the C<force>
-and the C<fforce> pragma.
-
-=item CPAN::Bundle::get()
-
-Recursively runs the C<get> method on all items contained in the bundle
-
-=item CPAN::Bundle::inst_file()
-
-Returns the highest installed version of the bundle in either @INC or
-C<$CPAN::Config->{cpan_home}>. Note that this is different from
-CPAN::Module::inst_file.
-
-=item CPAN::Bundle::inst_version()
-
-Like CPAN::Bundle::inst_file, but returns the $VERSION
-
-=item CPAN::Bundle::uptodate()
-
-Returns 1 if the bundle itself and all its members are uptodate.
-
-=item CPAN::Bundle::install()
-
-Recursively runs the C<install> method on all items contained in the bundle
-
-=item CPAN::Bundle::make()
-
-Recursively runs the C<make> method on all items contained in the bundle
-
-=item CPAN::Bundle::readme()
-
-Recursively runs the C<readme> method on all items contained in the bundle
-
-=item CPAN::Bundle::test()
-
-Recursively runs the C<test> method on all items contained in the bundle
-
-=item CPAN::Distribution::as_glimpse()
-
-Returns a one-line description of the distribution
-
-=item CPAN::Distribution::as_string()
-
-Returns a multi-line description of the distribution
-
-=item CPAN::Distribution::author
-
-Returns the CPAN::Author object of the maintainer who uploaded this
-distribution
-
-=item CPAN::Distribution::pretty_id()
-
-Returns a string of the form "AUTHORID/TARBALL", where AUTHORID is the
-author's PAUSE ID and TARBALL is the distribution filename.
-
-=item CPAN::Distribution::base_id()
-
-Returns the distribution filename without any archive suffix. E.g
-"Foo-Bar-0.01"
-
-=item CPAN::Distribution::clean()
-
-Changes to the directory where the distribution has been unpacked and
-runs C<make clean> there.
-
-=item CPAN::Distribution::containsmods()
-
-Returns a list of IDs of modules contained in a distribution file.
-Works only for distributions listed in the 02packages.details.txt.gz
-file. This typically means that just most recent version of a
-distribution is covered.
-
-=item CPAN::Distribution::cvs_import()
-
-Changes to the directory where the distribution has been unpacked and
-runs something like
-
- cvs -d $cvs_root import -m $cvs_log $cvs_dir $userid v$version
-
-there.
-
-=item CPAN::Distribution::dir()
-
-Returns the directory into which this distribution has been unpacked.
-
-=item CPAN::Distribution::force($method, at args)
-
-Forces CPAN to perform a task that it normally would have refused to
-do. Force takes as arguments a method name to be called and any number
-of additional arguments that should be passed to the called method.
-The internals of the object get the needed changes so that CPAN.pm
-does not refuse to take the action. See also the section above on the
-C<force> and the C<fforce> pragma.
-
-=item CPAN::Distribution::get()
-
-Downloads the distribution from CPAN and unpacks it. Does nothing if
-the distribution has already been downloaded and unpacked within the
-current session.
-
-=item CPAN::Distribution::install()
-
-Changes to the directory where the distribution has been unpacked and
-runs the external command C<make install> there. If C<make> has not
-yet been run, it will be run first. A C<make test> is issued in
-any case and if this fails, the install is cancelled. The
-cancellation can be avoided by letting C<force> run the C<install> for
-you.
-
-This install method only has the power to install the distribution if
-there are no dependencies in the way. To install an object along with all
-its dependencies, use CPAN::Shell->install.
-
-Note that install() gives no meaningful return value. See uptodate().
-
-=item CPAN::Distribution::install_tested()
-
-Install all distributions that have tested sucessfully but
-not yet installed. See also C<is_tested>.
-
-=item CPAN::Distribution::isa_perl()
-
-Returns 1 if this distribution file seems to be a perl distribution.
-Normally this is derived from the file name only, but the index from
-CPAN can contain a hint to achieve a return value of true for other
-filenames too.
-
-=item CPAN::Distribution::look()
-
-Changes to the directory where the distribution has been unpacked and
-opens a subshell there. Exiting the subshell returns.
-
-=item CPAN::Distribution::make()
-
-First runs the C<get> method to make sure the distribution is
-downloaded and unpacked. Changes to the directory where the
-distribution has been unpacked and runs the external commands C<perl
-Makefile.PL> or C<perl Build.PL> and C<make> there.
-
-=item CPAN::Distribution::perldoc()
-
-Downloads the pod documentation of the file associated with a
-distribution (in HTML format) and runs it through the external
-command I<lynx> specified in C<$CPAN::Config->{lynx}>. If I<lynx>
-isn't available, it converts it to plain text with the external
-command I<html2text> and runs it through the pager specified
-in C<$CPAN::Config->{pager}>
-
-=item CPAN::Distribution::prefs()
-
-Returns the hash reference from the first matching YAML file that the
-user has deposited in the C<prefs_dir/> directory. The first
-succeeding match wins. The files in the C<prefs_dir/> are processed
-alphabetically, and the canonical distroname (e.g.
-AUTHOR/Foo-Bar-3.14.tar.gz) is matched against the regular expressions
-stored in the $root->{match}{distribution} attribute value.
-Additionally all module names contained in a distribution are matched
-against the regular expressions in the $root->{match}{module} attribute
-value. The two match values are ANDed together. Each of the two
-attributes are optional.
-
-=item CPAN::Distribution::prereq_pm()
-
-Returns the hash reference that has been announced by a distribution
-as the C<requires> and C<build_requires> elements. These can be
-declared either by the C<META.yml> (if authoritative) or can be
-deposited after the run of C<Build.PL> in the file C<./_build/prereqs>
-or after the run of C<Makfile.PL> written as the C<PREREQ_PM> hash in
-a comment in the produced C<Makefile>. I<Note>: this method only works
-after an attempt has been made to C<make> the distribution. Returns
-undef otherwise.
-
-=item CPAN::Distribution::readme()
-
-Downloads the README file associated with a distribution and runs it
-through the pager specified in C<$CPAN::Config->{pager}>.
-
-=item CPAN::Distribution::reports()
-
-Downloads report data for this distribution from www.cpantesters.org
-and displays a subset of them.
-
-=item CPAN::Distribution::read_yaml()
-
-Returns the content of the META.yml of this distro as a hashref. Note:
-works only after an attempt has been made to C<make> the distribution.
-Returns undef otherwise. Also returns undef if the content of META.yml
-is not authoritative. (The rules about what exactly makes the content
-authoritative are still in flux.)
-
-=item CPAN::Distribution::test()
-
-Changes to the directory where the distribution has been unpacked and
-runs C<make test> there.
-
-=item CPAN::Distribution::uptodate()
-
-Returns 1 if all the modules contained in the distribution are
-uptodate. Relies on containsmods.
-
-=item CPAN::Index::force_reload()
-
-Forces a reload of all indices.
-
-=item CPAN::Index::reload()
-
-Reloads all indices if they have not been read for more than
-C<$CPAN::Config->{index_expire}> days.
-
-=item CPAN::InfoObj::dump()
-
-CPAN::Author, CPAN::Bundle, CPAN::Module, and CPAN::Distribution
-inherit this method. It prints the data structure associated with an
-object. Useful for debugging. Note: the data structure is considered
-internal and thus subject to change without notice.
-
-=item CPAN::Module::as_glimpse()
-
-Returns a one-line description of the module in four columns: The
-first column contains the word C<Module>, the second column consists
-of one character: an equals sign if this module is already installed
-and uptodate, a less-than sign if this module is installed but can be
-upgraded, and a space if the module is not installed. The third column
-is the name of the module and the fourth column gives maintainer or
-distribution information.
-
-=item CPAN::Module::as_string()
-
-Returns a multi-line description of the module
-
-=item CPAN::Module::clean()
-
-Runs a clean on the distribution associated with this module.
-
-=item CPAN::Module::cpan_file()
-
-Returns the filename on CPAN that is associated with the module.
-
-=item CPAN::Module::cpan_version()
-
-Returns the latest version of this module available on CPAN.
-
-=item CPAN::Module::cvs_import()
-
-Runs a cvs_import on the distribution associated with this module.
-
-=item CPAN::Module::description()
-
-Returns a 44 character description of this module. Only available for
-modules listed in The Module List (CPAN/modules/00modlist.long.html
-or 00modlist.long.txt.gz)
-
-=item CPAN::Module::distribution()
-
-Returns the CPAN::Distribution object that contains the current
-version of this module.
-
-=item CPAN::Module::dslip_status()
-
-Returns a hash reference. The keys of the hash are the letters C<D>,
-C<S>, C<L>, C<I>, and <P>, for development status, support level,
-language, interface and public licence respectively. The data for the
-DSLIP status are collected by pause.perl.org when authors register
-their namespaces. The values of the 5 hash elements are one-character
-words whose meaning is described in the table below. There are also 5
-hash elements C<DV>, C<SV>, C<LV>, C<IV>, and <PV> that carry a more
-verbose value of the 5 status variables.
-
-Where the 'DSLIP' characters have the following meanings:
-
- D - Development Stage (Note: *NO IMPLIED TIMESCALES*):
- i - Idea, listed to gain consensus or as a placeholder
- c - under construction but pre-alpha (not yet released)
- a/b - Alpha/Beta testing
- R - Released
- M - Mature (no rigorous definition)
- S - Standard, supplied with Perl 5
-
- S - Support Level:
- m - Mailing-list
- d - Developer
- u - Usenet newsgroup comp.lang.perl.modules
- n - None known, try comp.lang.perl.modules
- a - abandoned; volunteers welcome to take over maintainance
-
- L - Language Used:
- p - Perl-only, no compiler needed, should be platform independent
- c - C and perl, a C compiler will be needed
- h - Hybrid, written in perl with optional C code, no compiler needed
- + - C++ and perl, a C++ compiler will be needed
- o - perl and another language other than C or C++
-
- I - Interface Style
- f - plain Functions, no references used
- h - hybrid, object and function interfaces available
- n - no interface at all (huh?)
- r - some use of unblessed References or ties
- O - Object oriented using blessed references and/or inheritance
-
- P - Public License
- p - Standard-Perl: user may choose between GPL and Artistic
- g - GPL: GNU General Public License
- l - LGPL: "GNU Lesser General Public License" (previously known as
- "GNU Library General Public License")
- b - BSD: The BSD License
- a - Artistic license alone
- 2 - Artistic license 2.0 or later
- o - open source: appoved by www.opensource.org
- d - allows distribution without restrictions
- r - restricted distribtion
- n - no license at all
-
-=item CPAN::Module::force($method, at args)
-
-Forces CPAN to perform a task it would normally refuse to
-do. Force takes as arguments a method name to be invoked and any number
-of additional arguments to pass that method.
-The internals of the object get the needed changes so that CPAN.pm
-does not refuse to take the action. See also the section above on the
-C<force> and the C<fforce> pragma.
-
-=item CPAN::Module::get()
-
-Runs a get on the distribution associated with this module.
-
-=item CPAN::Module::inst_file()
-
-Returns the filename of the module found in @INC. The first file found
-is reported, just as perl itself stops searching @INC once it finds a
-module.
-
-=item CPAN::Module::available_file()
-
-Returns the filename of the module found in PERL5LIB or @INC. The
-first file found is reported. The advantage of this method over
-C<inst_file> is that modules that have been tested but not yet
-installed are included because PERL5LIB keeps track of tested modules.
-
-=item CPAN::Module::inst_version()
-
-Returns the version number of the installed module in readable format.
-
-=item CPAN::Module::available_version()
-
-Returns the version number of the available module in readable format.
-
-=item CPAN::Module::install()
-
-Runs an C<install> on the distribution associated with this module.
-
-=item CPAN::Module::look()
-
-Changes to the directory where the distribution associated with this
-module has been unpacked and opens a subshell there. Exiting the
-subshell returns.
-
-=item CPAN::Module::make()
-
-Runs a C<make> on the distribution associated with this module.
-
-=item CPAN::Module::manpage_headline()
-
-If module is installed, peeks into the module's manpage, reads the
-headline, and returns it. Moreover, if the module has been downloaded
-within this session, does the equivalent on the downloaded module even
-if it hasn't been installed yet.
-
-=item CPAN::Module::perldoc()
-
-Runs a C<perldoc> on this module.
-
-=item CPAN::Module::readme()
-
-Runs a C<readme> on the distribution associated with this module.
-
-=item CPAN::Module::reports()
-
-Calls the reports() method on the associated distribution object.
-
-=item CPAN::Module::test()
-
-Runs a C<test> on the distribution associated with this module.
-
-=item CPAN::Module::uptodate()
-
-Returns 1 if the module is installed and up-to-date.
-
-=item CPAN::Module::userid()
-
-Returns the author's ID of the module.
-
-=back
-
-=head2 Cache Manager
-
-Currently the cache manager only keeps track of the build directory
-($CPAN::Config->{build_dir}). It is a simple FIFO mechanism that
-deletes complete directories below C<build_dir> as soon as the size of
-all directories there gets bigger than $CPAN::Config->{build_cache}
-(in MB). The contents of this cache may be used for later
-re-installations that you intend to do manually, but will never be
-trusted by CPAN itself. This is due to the fact that the user might
-use these directories for building modules on different architectures.
-
-There is another directory ($CPAN::Config->{keep_source_where}) where
-the original distribution files are kept. This directory is not
-covered by the cache manager and must be controlled by the user. If
-you choose to have the same directory as build_dir and as
-keep_source_where directory, then your sources will be deleted with
-the same fifo mechanism.
-
-=head2 Bundles
-
-A bundle is just a perl module in the namespace Bundle:: that does not
-define any functions or methods. It usually only contains documentation.
-
-It starts like a perl module with a package declaration and a $VERSION
-variable. After that the pod section looks like any other pod with the
-only difference being that I<one special pod section> exists starting with
-(verbatim):
-
- =head1 CONTENTS
-
-In this pod section each line obeys the format
-
- Module_Name [Version_String] [- optional text]
-
-The only required part is the first field, the name of a module
-(e.g. Foo::Bar, ie. I<not> the name of the distribution file). The rest
-of the line is optional. The comment part is delimited by a dash just
-as in the man page header.
-
-The distribution of a bundle should follow the same convention as
-other distributions.
-
-Bundles are treated specially in the CPAN package. If you say 'install
-Bundle::Tkkit' (assuming such a bundle exists), CPAN will install all
-the modules in the CONTENTS section of the pod. You can install your
-own Bundles locally by placing a conformant Bundle file somewhere into
-your @INC path. The autobundle() command which is available in the
-shell interface does that for you by including all currently installed
-modules in a snapshot bundle file.
-
-=head1 PREREQUISITES
-
-If you have a local mirror of CPAN and can access all files with
-"file:" URLs, then you only need a perl later than perl5.003 to run
-this module. Otherwise Net::FTP is strongly recommended. LWP may be
-required for non-UNIX systems, or if your nearest CPAN site is
-associated with a URL that is not C<ftp:>.
-
-If you have neither Net::FTP nor LWP, there is a fallback mechanism
-implemented for an external ftp command or for an external lynx
-command.
-
-=head1 UTILITIES
-
-=head2 Finding packages and VERSION
-
-This module presumes that all packages on CPAN
-
-=over 2
-
-=item *
-
-declare their $VERSION variable in an easy to parse manner. This
-prerequisite can hardly be relaxed because it consumes far too much
-memory to load all packages into the running program just to determine
-the $VERSION variable. Currently all programs that are dealing with
-version use something like this
-
- perl -MExtUtils::MakeMaker -le \
- 'print MM->parse_version(shift)' filename
-
-If you are author of a package and wonder if your $VERSION can be
-parsed, please try the above method.
-
-=item *
-
-come as compressed or gzipped tarfiles or as zip files and contain a
-C<Makefile.PL> or C<Build.PL> (well, we try to handle a bit more, but
-with little enthusiasm).
-
-=back
-
-=head2 Debugging
-
-Debugging this module is more than a bit complex due to interference from
-the software producing the indices on CPAN, the mirroring process on CPAN,
-packaging, configuration, synchronicity, and even (gasp!) due to bugs
-within the CPAN.pm module itself.
-
-For debugging the code of CPAN.pm itself in interactive mode, some
-debugging aid can be turned on for most packages within
-CPAN.pm with one of
-
-=over 2
-
-=item o debug package...
-
-sets debug mode for packages.
-
-=item o debug -package...
-
-unsets debug mode for packages.
-
-=item o debug all
-
-turns debugging on for all packages.
-
-=item o debug number
-
-=back
-
-which sets the debugging packages directly. Note that C<o debug 0>
-turns debugging off.
-
-What seems a successful strategy is the combination of C<reload
-cpan> and the debugging switches. Add a new debug statement while
-running in the shell and then issue a C<reload cpan> and see the new
-debugging messages immediately without losing the current context.
-
-C<o debug> without an argument lists the valid package names and the
-current set of packages in debugging mode. C<o debug> has built-in
-completion support.
-
-For debugging of CPAN data there is the C<dump> command which takes
-the same arguments as make/test/install and outputs each object's
-Data::Dumper dump. If an argument looks like a perl variable and
-contains one of C<$>, C<@> or C<%>, it is eval()ed and fed to
-Data::Dumper directly.
-
-=head2 Floppy, Zip, Offline Mode
-
-CPAN.pm works nicely without network access, too. If you maintain machines
-that are not networked at all, you should consider working with C<file:>
-URLs. You'll have to collect your modules somewhere first. So
-you might use CPAN.pm to put together all you need on a networked
-machine. Then copy the $CPAN::Config->{keep_source_where} (but not
-$CPAN::Config->{build_dir}) directory on a floppy. This floppy is kind
-of a personal CPAN. CPAN.pm on the non-networked machines works nicely
-with this floppy. See also below the paragraph about CD-ROM support.
-
-=head2 Basic Utilities for Programmers
-
-=over 2
-
-=item has_inst($module)
-
-Returns true if the module is installed. Used to load all modules into
-the running CPAN.pm that are considered optional. The config variable
-C<dontload_list> intercepts the C<has_inst()> call such
-that an optional module is not loaded despite being available. For
-example, the following command will prevent C<YAML.pm> from being
-loaded:
-
- cpan> o conf dontload_list push YAML
-
-See the source for details.
-
-=item has_usable($module)
-
-Returns true if the module is installed and in a usable state. Only
-useful for a handful of modules that are used internally. See the
-source for details.
-
-=item instance($module)
-
-The constructor for all the singletons used to represent modules,
-distributions, authors, and bundles. If the object already exists, this
-method returns the object; otherwise, it calls the constructor.
-
-=back
-
-=head1 SECURITY
-
-There's no strong security layer in CPAN.pm. CPAN.pm helps you to
-install foreign, unmasked, unsigned code on your machine. We compare
-to a checksum that comes from the net just as the distribution file
-itself. But we try to make it easy to add security on demand:
-
-=head2 Cryptographically signed modules
-
-Since release 1.77, CPAN.pm has been able to verify cryptographically
-signed module distributions using Module::Signature. The CPAN modules
-can be signed by their authors, thus giving more security. The simple
-unsigned MD5 checksums that were used before by CPAN protect mainly
-against accidental file corruption.
-
-You will need to have Module::Signature installed, which in turn
-requires that you have at least one of Crypt::OpenPGP module or the
-command-line F<gpg> tool installed.
-
-You will also need to be able to connect over the Internet to the public
-keyservers, like pgp.mit.edu, and their port 11731 (the HKP protocol).
-
-The configuration parameter check_sigs is there to turn signature
-checking on or off.
-
-=head1 EXPORT
-
-Most functions in package CPAN are exported by default. The reason
-for this is that the primary use is intended for the cpan shell or for
-one-liners.
-
-=head1 ENVIRONMENT
-
-When the CPAN shell enters a subshell via the look command, it sets
-the environment CPAN_SHELL_LEVEL to 1, or increments that variable if it is
-already set.
-
-When CPAN runs, it sets the environment variable PERL5_CPAN_IS_RUNNING
-to the ID of the running process. It also sets
-PERL5_CPANPLUS_IS_RUNNING to prevent runaway processes which could
-happen with older versions of Module::Install.
-
-When running C<perl Makefile.PL>, the environment variable
-C<PERL5_CPAN_IS_EXECUTING> is set to the full path of the
-C<Makefile.PL> that is being executed. This prevents runaway processes
-with newer versions of Module::Install.
-
-When the config variable ftp_passive is set, all downloads will be run
-with the environment variable FTP_PASSIVE set to this value. This is
-in general a good idea as it influences both Net::FTP and LWP based
-connections. The same effect can be achieved by starting the cpan
-shell with this environment variable set. For Net::FTP alone, one can
-also always set passive mode by running libnetcfg.
-
-=head1 POPULATE AN INSTALLATION WITH LOTS OF MODULES
-
-Populating a freshly installed perl with one's favorite modules is pretty
-easy if you maintain a private bundle definition file. To get a useful
-blueprint of a bundle definition file, the command autobundle can be used
-on the CPAN shell command line. This command writes a bundle definition
-file for all modules installed for the current perl
-interpreter. It's recommended to run this command once only, and from then
-on maintain the file manually under a private name, say
-Bundle/my_bundle.pm. With a clever bundle file you can then simply say
-
- cpan> install Bundle::my_bundle
-
-then answer a few questions and go out for coffee (possibly
-even in a different city).
-
-Maintaining a bundle definition file means keeping track of two
-things: dependencies and interactivity. CPAN.pm sometimes fails on
-calculating dependencies because not all modules define all MakeMaker
-attributes correctly, so a bundle definition file should specify
-prerequisites as early as possible. On the other hand, it's
-annoying that so many distributions need some interactive configuring. So
-what you can try to accomplish in your private bundle file is to have the
-packages that need to be configured early in the file and the gentle
-ones later, so you can go out for cofeee after a few minutes and leave CPAN.pm
-to churn away untended.
-
-=head1 WORKING WITH CPAN.pm BEHIND FIREWALLS
-
-Thanks to Graham Barr for contributing the following paragraphs about
-the interaction between perl, and various firewall configurations. For
-further information on firewalls, it is recommended to consult the
-documentation that comes with the I<ncftp> program. If you are unable to
-go through the firewall with a simple Perl setup, it is likely
-that you can configure I<ncftp> so that it works through your firewall.
-
-=head2 Three basic types of firewalls
-
-Firewalls can be categorized into three basic types.
-
-=over 4
-
-=item http firewall
-
-This is when the firewall machine runs a web server, and to access the
-outside world, you must do so via that web server. If you set environment
-variables like http_proxy or ftp_proxy to values beginning with http://,
-or in your web browser you've proxy information set, then you know
-you are running behind an http firewall.
-
-To access servers outside these types of firewalls with perl (even for
-ftp), you need LWP.
-
-=item ftp firewall
-
-This where the firewall machine runs an ftp server. This kind of
-firewall will only let you access ftp servers outside the firewall.
-This is usually done by connecting to the firewall with ftp, then
-entering a username like "user at outside.host.com".
-
-To access servers outside these type of firewalls with perl, you
-need Net::FTP.
-
-=item One-way visibility
-
-One-way visibility means these firewalls try to make themselves
-invisible to users inside the firewall. An FTP data connection is
-normally created by sending your IP address to the remote server and then
-listening for the return connection. But the remote server will not be able to
-connect to you because of the firewall. For these types of firewall,
-FTP connections need to be done in a passive mode.
-
-There are two that I can think off.
-
-=over 4
-
-=item SOCKS
-
-If you are using a SOCKS firewall, you will need to compile perl and link
-it with the SOCKS library. This is what is normally called a 'socksified'
-perl. With this executable you will be able to connect to servers outside
-the firewall as if it were not there.
-
-=item IP Masquerade
-
-This is when the firewall implemented in the kernel (via NAT, or networking
-address translation), it allows you to hide a complete network behind one
-IP address. With this firewall no special compiling is needed as you can
-access hosts directly.
-
-For accessing ftp servers behind such firewalls you usually need to
-set the environment variable C<FTP_PASSIVE> or the config variable
-ftp_passive to a true value.
-
-=back
-
-=back
-
-=head2 Configuring lynx or ncftp for going through a firewall
-
-If you can go through your firewall with e.g. lynx, presumably with a
-command such as
-
- /usr/local/bin/lynx -pscott:tiger
-
-then you would configure CPAN.pm with the command
-
- o conf lynx "/usr/local/bin/lynx -pscott:tiger"
-
-That's all. Similarly for ncftp or ftp, you would configure something
-like
-
- o conf ncftp "/usr/bin/ncftp -f /home/scott/ncftplogin.cfg"
-
-Your mileage may vary...
-
-=head1 FAQ
-
-=over 4
-
-=item 1)
-
-I installed a new version of module X but CPAN keeps saying,
-I have the old version installed
-
-Probably you B<do> have the old version installed. This can
-happen if a module installs itself into a different directory in the
- at INC path than it was previously installed. This is not really a
-CPAN.pm problem, you would have the same problem when installing the
-module manually. The easiest way to prevent this behaviour is to add
-the argument C<UNINST=1> to the C<make install> call, and that is why
-many people add this argument permanently by configuring
-
- o conf make_install_arg UNINST=1
-
-=item 2)
-
-So why is UNINST=1 not the default?
-
-Because there are people who have their precise expectations about who
-may install where in the @INC path and who uses which @INC array. In
-fine tuned environments C<UNINST=1> can cause damage.
-
-=item 3)
-
-I want to clean up my mess, and install a new perl along with
-all modules I have. How do I go about it?
-
-Run the autobundle command for your old perl and optionally rename the
-resulting bundle file (e.g. Bundle/mybundle.pm), install the new perl
-with the Configure option prefix, e.g.
-
- ./Configure -Dprefix=/usr/local/perl-5.6.78.9
-
-Install the bundle file you produced in the first step with something like
-
- cpan> install Bundle::mybundle
-
-and you're done.
-
-=item 4)
-
-When I install bundles or multiple modules with one command
-there is too much output to keep track of.
-
-You may want to configure something like
-
- o conf make_arg "| tee -ai /root/.cpan/logs/make.out"
- o conf make_install_arg "| tee -ai /root/.cpan/logs/make_install.out"
-
-so that STDOUT is captured in a file for later inspection.
-
-
-=item 5)
-
-I am not root, how can I install a module in a personal directory?
-
-First of all, you will want to use your own configuration, not the one
-that your root user installed. If you do not have permission to write
-in the cpan directory that root has configured, you will be asked if
-you want to create your own config. Answering "yes" will bring you into
-CPAN's configuration stage, using the system config for all defaults except
-things that have to do with CPAN's work directory, saving your choices to
-your MyConfig.pm file.
-
-You can also manually initiate this process with the following command:
-
- % perl -MCPAN -e 'mkmyconfig'
-
-or by running
-
- mkmyconfig
-
-from the CPAN shell.
-
-You will most probably also want to configure something like this:
-
- o conf makepl_arg "LIB=~/myperl/lib \
- INSTALLMAN1DIR=~/myperl/man/man1 \
- INSTALLMAN3DIR=~/myperl/man/man3 \
- INSTALLSCRIPT=~/myperl/bin \
- INSTALLBIN=~/myperl/bin"
-
-and then the equivalent command for Module::Build, which is
-
- o conf mbuildpl_arg "--lib=~/myperl/lib \
- --installman1dir=~/myperl/man/man1 \
- --installman3dir=~/myperl/man/man3 \
- --installscript=~/myperl/bin \
- --installbin=~/myperl/bin"
-
-You can make this setting permanent like all C<o conf> settings with
-C<o conf commit> or by setting C<auto_commit> beforehand.
-
-You will have to add ~/myperl/man to the MANPATH environment variable
-and also tell your perl programs to look into ~/myperl/lib, e.g. by
-including
-
- use lib "$ENV{HOME}/myperl/lib";
-
-or setting the PERL5LIB environment variable.
-
-While we're speaking about $ENV{HOME}, it might be worth mentioning,
-that for Windows we use the File::HomeDir module that provides an
-equivalent to the concept of the home directory on Unix.
-
-Another thing you should bear in mind is that the UNINST parameter can
-be dangerous when you are installing into a private area because you
-might accidentally remove modules that other people depend on that are
-not using the private area.
-
-=item 6)
-
-How to get a package, unwrap it, and make a change before building it?
-
-Have a look at the C<look> (!) command.
-
-=item 7)
-
-I installed a Bundle and had a couple of fails. When I
-retried, everything resolved nicely. Can this be fixed to work
-on first try?
-
-The reason for this is that CPAN does not know the dependencies of all
-modules when it starts out. To decide about the additional items to
-install, it just uses data found in the META.yml file or the generated
-Makefile. An undetected missing piece breaks the process. But it may
-well be that your Bundle installs some prerequisite later than some
-depending item and thus your second try is able to resolve everything.
-Please note, CPAN.pm does not know the dependency tree in advance and
-cannot sort the queue of things to install in a topologically correct
-order. It resolves perfectly well B<if> all modules declare the
-prerequisites correctly with the PREREQ_PM attribute to MakeMaker or
-the C<requires> stanza of Module::Build. For bundles which fail and
-you need to install often, it is recommended to sort the Bundle
-definition file manually.
-
-=item 8)
-
-In our intranet, we have many modules for internal use. How
-can I integrate these modules with CPAN.pm but without uploading
-the modules to CPAN?
-
-Have a look at the CPAN::Site module.
-
-=item 9)
-
-When I run CPAN's shell, I get an error message about things in my
-C</etc/inputrc> (or C<~/.inputrc>) file.
-
-These are readline issues and can only be fixed by studying readline
-configuration on your architecture and adjusting the referenced file
-accordingly. Please make a backup of the C</etc/inputrc> or C<~/.inputrc>
-and edit them. Quite often harmless changes like uppercasing or
-lowercasing some arguments solves the problem.
-
-=item 10)
-
-Some authors have strange characters in their names.
-
-Internally CPAN.pm uses the UTF-8 charset. If your terminal is
-expecting ISO-8859-1 charset, a converter can be activated by setting
-term_is_latin to a true value in your config file. One way of doing so
-would be
-
- cpan> o conf term_is_latin 1
-
-If other charset support is needed, please file a bugreport against
-CPAN.pm at rt.cpan.org and describe your needs. Maybe we can extend
-the support or maybe UTF-8 terminals become widely available.
-
-Note: this config variable is deprecated and will be removed in a
-future version of CPAN.pm. It will be replaced with the conventions
-around the family of $LANG and $LC_* environment variables.
-
-=item 11)
-
-When an install fails for some reason and then I correct the error
-condition and retry, CPAN.pm refuses to install the module, saying
-C<Already tried without success>.
-
-Use the force pragma like so
-
- force install Foo::Bar
-
-Or you can use
-
- look Foo::Bar
-
-and then C<make install> directly in the subshell.
-
-=item 12)
-
-How do I install a "DEVELOPER RELEASE" of a module?
-
-By default, CPAN will install the latest non-developer release of a
-module. If you want to install a dev release, you have to specify the
-partial path starting with the author id to the tarball you wish to
-install, like so:
-
- cpan> install KWILLIAMS/Module-Build-0.27_07.tar.gz
-
-Note that you can use the C<ls> command to get this path listed.
-
-=item 13)
-
-How do I install a module and all its dependencies from the commandline,
-without being prompted for anything, despite my CPAN configuration
-(or lack thereof)?
-
-CPAN uses ExtUtils::MakeMaker's prompt() function to ask its questions, so
-if you set the PERL_MM_USE_DEFAULT environment variable, you shouldn't be
-asked any questions at all (assuming the modules you are installing are
-nice about obeying that variable as well):
-
- % PERL_MM_USE_DEFAULT=1 perl -MCPAN -e 'install My::Module'
-
-=item 14)
-
-How do I create a Module::Build based Build.PL derived from an
-ExtUtils::MakeMaker focused Makefile.PL?
-
-http://search.cpan.org/search?query=Module::Build::Convert
-
-http://www.refcnt.org/papers/module-build-convert
-
-=item 15)
-
-I'm frequently irritated with the CPAN shell's inability to help me
-select a good mirror.
-
-The urllist config parameter is yours. You can add and remove sites at
-will. You should find out which sites have the best uptodateness,
-bandwidth, reliability, etc. and are topologically close to you. Some
-people prefer fast downloads, others uptodateness, others reliability.
-You decide which to try in which order.
-
-Henk P. Penning maintains a site that collects data about CPAN sites:
-
- http://www.cs.uu.nl/people/henkp/mirmon/cpan.html
-
-Also, feel free to play with experimental features. Run
-
- o conf init randomize_urllist ftpstats_period ftpstats_size
-
-and choose your favorite parameters. After a few downloads running the
-C<hosts> command will probably assist you in choosing the best mirror
-sites.
-
-=item 16)
-
-Why do I get asked the same questions every time I start the shell?
-
-You can make your configuration changes permanent by calling the
-command C<o conf commit>. Alternatively set the C<auto_commit>
-variable to true by running C<o conf init auto_commit> and answering
-the following question with yes.
-
-=item 17)
-
-Older versions of CPAN.pm had the original root directory of all
-tarballs in the build directory. Now there are always random
-characters appended to these directory names. Why was this done?
-
-The random characters are provided by File::Temp and ensure that each
-module's individual build directory is unique. This makes running
-CPAN.pm in concurrent processes simultaneously safe.
-
-=item 18)
-
-Speaking of the build directory. Do I have to clean it up myself?
-
-You have the choice to set the config variable C<scan_cache> to
-C<never>. Then you must clean it up yourself. The other possible
-value, C<atstart> only cleans up the build directory when you start
-the CPAN shell. If you never start up the CPAN shell, you probably
-also have to clean up the build directory yourself.
-
-=back
-
-=head1 COMPATIBILITY
-
-=head2 OLD PERL VERSIONS
-
-CPAN.pm is regularly tested to run under 5.004, 5.005, and assorted
-newer versions. It is getting more and more difficult to get the
-minimal prerequisites working on older perls. It is close to
-impossible to get the whole Bundle::CPAN working there. If you're in
-the position to have only these old versions, be advised that CPAN is
-designed to work fine without the Bundle::CPAN installed.
-
-To get things going, note that GBARR/Scalar-List-Utils-1.18.tar.gz is
-compatible with ancient perls and that File::Temp is listed as a
-prerequisite but CPAN has reasonable workarounds if it is missing.
-
-=head2 CPANPLUS
-
-This module and its competitor, the CPANPLUS module, are both much
-cooler than the other. CPAN.pm is older. CPANPLUS was designed to be
-more modular, but it was never intended to be compatible with CPAN.pm.
-
-=head1 SECURITY ADVICE
-
-This software enables you to upgrade software on your computer and so
-is inherently dangerous because the newly installed software may
-contain bugs and may alter the way your computer works or even make it
-unusable. Please consider backing up your data before every upgrade.
-
-=head1 BUGS
-
-Please report bugs via L<http://rt.cpan.org/>
-
-Before submitting a bug, please make sure that the traditional method
-of building a Perl module package from a shell by following the
-installation instructions of that package still works in your
-environment.
-
-=head1 AUTHOR
-
-Andreas Koenig C<< <andk at cpan.org> >>
-
-=head1 LICENSE
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See L<http://www.perl.com/perl/misc/Artistic.html>
-
-=head1 TRANSLATIONS
-
-Kawai,Takanori provides a Japanese translation of this manpage at
-L<http://homepage3.nifty.com/hippo2000/perltips/CPAN.htm>
-
-=head1 SEE ALSO
-
-L<cpan>, L<CPAN::Nox>, L<CPAN::Version>
-
-=cut
Deleted: trunk/contrib/perl/lib/CPANPLUS.pm
===================================================================
--- trunk/contrib/perl/lib/CPANPLUS.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/CPANPLUS.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,271 +0,0 @@
-package CPANPLUS;
-
-use strict;
-use Carp;
-
-use CPANPLUS::Error;
-use CPANPLUS::Backend;
-
-use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
-
-BEGIN {
- use Exporter ();
- use vars qw( @EXPORT @ISA $VERSION );
- @EXPORT = qw( shell fetch get install );
- @ISA = qw( Exporter );
- $VERSION = "0.88"; #have to hardcode or cpan.org gets unhappy
-}
-
-### purely for backward compatibility, so we can call it from the commandline:
-### perl -MCPANPLUS -e 'install Net::SMTP'
-sub install {
- my $cpan = CPANPLUS::Backend->new;
- my $mod = shift or (
- error(loc("No module specified!")), return
- );
-
- if ( ref $mod ) {
- error( loc( "You passed an object. Use %1 for OO style interaction",
- 'CPANPLUS::Backend' ));
- return;
-
- } else {
- my $obj = $cpan->module_tree($mod) or (
- error(loc("No such module '%1'", $mod)),
- return
- );
-
- my $ok = $obj->install;
-
- $ok
- ? msg(loc("Installing of %1 successful", $mod),1)
- : msg(loc("Installing of %1 failed", $mod),1);
-
- return $ok;
- }
-}
-
-### simply downloads a module and stores it
-sub fetch {
- my $cpan = CPANPLUS::Backend->new;
-
- my $mod = shift or (
- error(loc("No module specified!")), return
- );
-
- if ( ref $mod ) {
- error( loc( "You passed an object. Use %1 for OO style interaction",
- 'CPANPLUS::Backend' ));
- return;
-
- } else {
- my $obj = $cpan->module_tree($mod) or (
- error(loc("No such module '%1'", $mod)),
- return
- );
-
- my $ok = $obj->fetch( fetchdir => '.' );
-
- $ok
- ? msg(loc("Fetching of %1 successful", $mod),1)
- : msg(loc("Fetching of %1 failed", $mod),1);
-
- return $ok;
- }
-}
-
-### alias to fetch() due to compatibility with cpan.pm ###
-sub get { fetch(@_) }
-
-
-### purely for backwards compatibility, so we can call it from the commandline:
-### perl -MCPANPLUS -e 'shell'
-sub shell {
- my $option = shift;
-
- ### since the user can specify the type of shell they wish to start
- ### when they call the shell() function, we have to eval the usage
- ### of CPANPLUS::Shell so we can set up all the checks properly
- eval { require CPANPLUS::Shell; CPANPLUS::Shell->import($option) };
- die $@ if $@;
-
- my $cpan = CPANPLUS::Shell->new();
-
- $cpan->shell();
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-CPANPLUS - API & CLI access to the CPAN mirrors
-
-=head1 SYNOPSIS
-
- ### standard invocation from the command line
- $ cpanp
- $ cpanp -i Some::Module
-
- $ perl -MCPANPLUS -eshell
- $ perl -MCPANPLUS -e'fetch Some::Module'
-
-
-=head1 DESCRIPTION
-
-The C<CPANPLUS> library is an API to the C<CPAN> mirrors and a
-collection of interactive shells, commandline programs, etc,
-that use this API.
-
-=head1 GUIDE TO DOCUMENTATION
-
-=head2 GENERAL USAGE
-
-This is the document you are currently reading. It describes
-basic usage and background information. Its main purpose is to
-assist the user who wants to learn how to invoke CPANPLUS
-and install modules from the commandline and to point you
-to more indepth reading if required.
-
-=head2 API REFERENCE
-
-The C<CPANPLUS> API is meant to let you programmatically
-interact with the C<CPAN> mirrors. The documentation in
-L<CPANPLUS::Backend> shows you how to create an object
-capable of interacting with those mirrors, letting you
-create & retrieve module objects.
-L<CPANPLUS::Module> shows you how you can use these module
-objects to perform actions like installing and testing.
-
-The default shell, documented in L<CPANPLUS::Shell::Default>
-is also scriptable. You can use its API to dispatch calls
-from your script to the CPANPLUS Shell.
-
-=cut
-
-=head1 COMMANDLINE TOOLS
-
-=head2 STARTING AN INTERACTIVE SHELL
-
-You can start an interactive shell by running either of
-the two following commands:
-
- $ cpanp
-
- $ perl -MCPANPLUS -eshell
-
-All commans available are listed in the interactive shells
-help menu. See C<cpanp -h> or L<CPANPLUS::Shell::Default>
-for instructions on using the default shell.
-
-=head2 CHOOSE A SHELL
-
-By running C<cpanp> without arguments, you will start up
-the shell specified in your config, which defaults to
-L<CPANPLUS::Shell::Default>. There are more shells available.
-C<CPANPLUS> itself ships with an emulation shell called
-L<CPANPLUS::Shell::Classic> that looks and feels just like
-the old C<CPAN.pm> shell.
-
-You can start this shell by typing:
-
- $ perl -MCPANPLUS -e'shell Classic'
-
-Even more shells may be available from C<CPAN>.
-
-Note that if you have changed your default shell in your
-configuration, that shell will be used instead. If for
-some reason there was an error with your specified shell,
-you will be given the default shell.
-
-=head2 BUILDING PACKAGES
-
-C<cpan2dist> is a commandline tool to convert any distribution
-from C<CPAN> into a package in the format of your choice, like
-for example C<.deb> or C<FreeBSD ports>.
-
-See C<cpan2dist -h> for details.
-
-
-=head1 FUNCTIONS
-
-For quick access to common commands, you may use this module,
-C<CPANPLUS> rather than the full programmatic API situated in
-C<CPANPLUS::Backend>. This module offers the following functions:
-
-=head2 $bool = install( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
-
-This function requires the full name of the module, which is case
-sensitive. The module name can also be provided as a fully
-qualified file name, beginning with a I</>, relative to
-the /authors/id directory on a CPAN mirror.
-
-It will download, extract and install the module.
-
-=head2 $where = fetch( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
-
-Like install, fetch needs the full name of a module or the fully
-qualified file name, and is case sensitive.
-
-It will download the specified module to the current directory.
-
-=head2 $where = get( Module::Name | /A/AU/AUTHOR/Module-Name-1.tgz )
-
-Get is provided as an alias for fetch for compatibility with
-CPAN.pm.
-
-=head2 shell()
-
-Shell starts the default CPAN shell. You can also start the shell
-by using the C<cpanp> command, which will be installed in your
-perl bin.
-
-=head1 FAQ
-
-For frequently asked questions and answers, please consult the
-C<CPANPLUS::FAQ> manual.
-
-=head1 BUG REPORTS
-
-Please report bugs or other issues to E<lt>bug-cpanplus at rt.cpan.org<gt>.
-
-=head1 AUTHOR
-
-This module by Jos Boumans E<lt>kane at cpan.orgE<gt>.
-
-=head1 COPYRIGHT
-
-The CPAN++ interface (of which this module is a part of) is copyright (c)
-2001 - 2007, Jos Boumans E<lt>kane at cpan.orgE<gt>. All rights reserved.
-
-This library is free software; you may redistribute and/or modify it
-under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-L<CPANPLUS::Shell::Default>, L<CPANPLUS::FAQ>, L<CPANPLUS::Backend>, L<CPANPLUS::Module>, L<cpanp>, L<cpan2dist>
-
-=head1 CONTACT INFORMATION
-
-=over 4
-
-=item * Bug reporting:
-I<bug-cpanplus at rt.cpan.org>
-
-=item * Questions & suggestions:
-I<cpanplus-devel at lists.sourceforge.net>
-
-=back
-
-
-=cut
-
-# Local variables:
-# c-indentation-style: bsd
-# c-basic-offset: 4
-# indent-tabs-mode: nil
-# End:
-# vim: expandtab shiftwidth=4:
Deleted: trunk/contrib/perl/lib/Carp.pm
===================================================================
--- trunk/contrib/perl/lib/Carp.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Carp.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,578 +0,0 @@
-package Carp;
-
-use strict;
-use warnings;
-
-our $VERSION = '1.20';
-
-our $MaxEvalLen = 0;
-our $Verbose = 0;
-our $CarpLevel = 0;
-our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
-our $MaxArgNums = 8; # How many arguments to print. 0 = all.
-
-require Exporter;
-our @ISA = ('Exporter');
-our @EXPORT = qw(confess croak carp);
-our @EXPORT_OK = qw(cluck verbose longmess shortmess);
-our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
-
-# The members of %Internal are packages that are internal to perl.
-# Carp will not report errors from within these packages if it
-# can. The members of %CarpInternal are internal to Perl's warning
-# system. Carp will not report errors from within these packages
-# either, and will not report calls *to* these packages for carp and
-# croak. They replace $CarpLevel, which is deprecated. The
-# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
-# text and function arguments should be formatted when printed.
-
-our %CarpInternal;
-our %Internal;
-
-# disable these by default, so they can live w/o require Carp
-$CarpInternal{Carp}++;
-$CarpInternal{warnings}++;
-$Internal{Exporter}++;
-$Internal{'Exporter::Heavy'}++;
-
-# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
-# then the following method will be called by the Exporter which knows
-# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
-# 'verbose'.
-
-sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
-
-sub _cgc {
- no strict 'refs';
- return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
- return;
-}
-
-sub longmess {
- # Icky backwards compatibility wrapper. :-(
- #
- # The story is that the original implementation hard-coded the
- # number of call levels to go back, so calls to longmess were off
- # by one. Other code began calling longmess and expecting this
- # behaviour, so the replacement has to emulate that behaviour.
- my $cgc = _cgc();
- my $call_pack = $cgc ? $cgc->() : caller();
- if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
- return longmess_heavy(@_);
- }
- else {
- local $CarpLevel = $CarpLevel + 1;
- return longmess_heavy(@_);
- }
-}
-
-our @CARP_NOT;
-
-sub shortmess {
- my $cgc = _cgc();
-
- # Icky backwards compatibility wrapper. :-(
- local @CARP_NOT = $cgc ? $cgc->() : caller();
- shortmess_heavy(@_);
-}
-
-sub croak { die shortmess @_ }
-sub confess { die longmess @_ }
-sub carp { warn shortmess @_ }
-sub cluck { warn longmess @_ }
-
-sub caller_info {
- my $i = shift(@_) + 1;
- my %call_info;
- my $cgc = _cgc();
- {
- package DB;
- @DB::args = \$i; # A sentinel, which no-one else has the address of
- @call_info{
- qw(pack file line sub has_args wantarray evaltext is_require) }
- = $cgc ? $cgc->($i) : caller($i);
- }
-
- unless ( defined $call_info{pack} ) {
- return ();
- }
-
- my $sub_name = Carp::get_subname( \%call_info );
- if ( $call_info{has_args} ) {
- my @args;
- if ( @DB::args == 1
- && ref $DB::args[0] eq ref \$i
- && $DB::args[0] == \$i ) {
- @DB::args = (); # Don't let anyone see the address of $i
- local $@;
- my $where = eval {
- my $func = $cgc or return '';
- my $gv = B::svref_2object($func)->GV;
- my $package = $gv->STASH->NAME;
- my $subname = $gv->NAME;
- return unless defined $package && defined $subname;
-
- # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
- return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
- " in &${package}::$subname";
- } // '';
- @args
- = "** Incomplete caller override detected$where; \@DB::args were not set **";
- }
- else {
- @args = map { Carp::format_arg($_) } @DB::args;
- }
- if ( $MaxArgNums and @args > $MaxArgNums )
- { # More than we want to show?
- $#args = $MaxArgNums;
- push @args, '...';
- }
-
- # Push the args onto the subroutine
- $sub_name .= '(' . join( ', ', @args ) . ')';
- }
- $call_info{sub_name} = $sub_name;
- return wantarray() ? %call_info : \%call_info;
-}
-
-# Transform an argument to a function into a string.
-sub format_arg {
- my $arg = shift;
- if ( ref($arg) ) {
- $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
- }
- if ( defined($arg) ) {
- $arg =~ s/'/\\'/g;
- $arg = str_len_trim( $arg, $MaxArgLen );
-
- # Quote it?
- $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/;
- } # 0-9, not \d, as \d will try to
- else { # load Unicode tables
- $arg = 'undef';
- }
-
- # The following handling of "control chars" is direct from
- # the original code - it is broken on Unicode though.
- # Suggestions?
- utf8::is_utf8($arg)
- or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
- return $arg;
-}
-
-# Takes an inheritance cache and a package and returns
-# an anon hash of known inheritances and anon array of
-# inheritances which consequences have not been figured
-# for.
-sub get_status {
- my $cache = shift;
- my $pkg = shift;
- $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
- return @{ $cache->{$pkg} };
-}
-
-# Takes the info from caller() and figures out the name of
-# the sub/require/eval
-sub get_subname {
- my $info = shift;
- if ( defined( $info->{evaltext} ) ) {
- my $eval = $info->{evaltext};
- if ( $info->{is_require} ) {
- return "require $eval";
- }
- else {
- $eval =~ s/([\\\'])/\\$1/g;
- return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
- }
- }
-
- return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
-}
-
-# Figures out what call (from the point of view of the caller)
-# the long error backtrace should start at.
-sub long_error_loc {
- my $i;
- my $lvl = $CarpLevel;
- {
- ++$i;
- my $cgc = _cgc();
- my $pkg = $cgc ? $cgc->($i) : caller($i);
- unless ( defined($pkg) ) {
-
- # This *shouldn't* happen.
- if (%Internal) {
- local %Internal;
- $i = long_error_loc();
- last;
- }
- else {
-
- # OK, now I am irritated.
- return 2;
- }
- }
- redo if $CarpInternal{$pkg};
- redo unless 0 > --$lvl;
- redo if $Internal{$pkg};
- }
- return $i - 1;
-}
-
-sub longmess_heavy {
- return @_ if ref( $_[0] ); # don't break references as exceptions
- my $i = long_error_loc();
- return ret_backtrace( $i, @_ );
-}
-
-# Returns a full stack backtrace starting from where it is
-# told.
-sub ret_backtrace {
- my ( $i, @error ) = @_;
- my $mess;
- my $err = join '', @error;
- $i++;
-
- my $tid_msg = '';
- if ( defined &threads::tid ) {
- my $tid = threads->tid;
- $tid_msg = " thread $tid" if $tid;
- }
-
- my %i = caller_info($i);
- $mess = "$err at $i{file} line $i{line}$tid_msg\n";
-
- while ( my %i = caller_info( ++$i ) ) {
- $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
- }
-
- return $mess;
-}
-
-sub ret_summary {
- my ( $i, @error ) = @_;
- my $err = join '', @error;
- $i++;
-
- my $tid_msg = '';
- if ( defined &threads::tid ) {
- my $tid = threads->tid;
- $tid_msg = " thread $tid" if $tid;
- }
-
- my %i = caller_info($i);
- return "$err at $i{file} line $i{line}$tid_msg\n";
-}
-
-sub short_error_loc {
- # You have to create your (hash)ref out here, rather than defaulting it
- # inside trusts *on a lexical*, as you want it to persist across calls.
- # (You can default it on $_[2], but that gets messy)
- my $cache = {};
- my $i = 1;
- my $lvl = $CarpLevel;
- {
- my $cgc = _cgc();
- my $called = $cgc ? $cgc->($i) : caller($i);
- $i++;
- my $caller = $cgc ? $cgc->($i) : caller($i);
-
- return 0 unless defined($caller); # What happened?
- redo if $Internal{$caller};
- redo if $CarpInternal{$caller};
- redo if $CarpInternal{$called};
- redo if trusts( $called, $caller, $cache );
- redo if trusts( $caller, $called, $cache );
- redo unless 0 > --$lvl;
- }
- return $i - 1;
-}
-
-sub shortmess_heavy {
- return longmess_heavy(@_) if $Verbose;
- return @_ if ref( $_[0] ); # don't break references as exceptions
- my $i = short_error_loc();
- if ($i) {
- ret_summary( $i, @_ );
- }
- else {
- longmess_heavy(@_);
- }
-}
-
-# If a string is too long, trims it with ...
-sub str_len_trim {
- my $str = shift;
- my $max = shift || 0;
- if ( 2 < $max and $max < length($str) ) {
- substr( $str, $max - 3 ) = '...';
- }
- return $str;
-}
-
-# Takes two packages and an optional cache. Says whether the
-# first inherits from the second.
-#
-# Recursive versions of this have to work to avoid certain
-# possible endless loops, and when following long chains of
-# inheritance are less efficient.
-sub trusts {
- my $child = shift;
- my $parent = shift;
- my $cache = shift;
- my ( $known, $partial ) = get_status( $cache, $child );
-
- # Figure out consequences until we have an answer
- while ( @$partial and not exists $known->{$parent} ) {
- my $anc = shift @$partial;
- next if exists $known->{$anc};
- $known->{$anc}++;
- my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
- my @found = keys %$anc_knows;
- @$known{@found} = ();
- push @$partial, @$anc_partial;
- }
- return exists $known->{$parent};
-}
-
-# Takes a package and gives a list of those trusted directly
-sub trusts_directly {
- my $class = shift;
- no strict 'refs';
- no warnings 'once';
- return @{"$class\::CARP_NOT"}
- ? @{"$class\::CARP_NOT"}
- : @{"$class\::ISA"};
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Carp - alternative warn and die for modules
-
-=head1 SYNOPSIS
-
- use Carp;
-
- # warn user (from perspective of caller)
- carp "string trimmed to 80 chars";
-
- # die of errors (from perspective of caller)
- croak "We're outta here!";
-
- # die of errors with stack backtrace
- confess "not implemented";
-
- # cluck not exported by default
- use Carp qw(cluck);
- cluck "This is how we got here!";
-
-=head1 DESCRIPTION
-
-The Carp routines are useful in your own modules because
-they act like die() or warn(), but with a message which is more
-likely to be useful to a user of your module. In the case of
-cluck, confess, and longmess that context is a summary of every
-call in the call-stack. For a shorter message you can use C<carp>
-or C<croak> which report the error as being from where your module
-was called. There is no guarantee that that is where the error
-was, but it is a good educated guess.
-
-You can also alter the way the output and logic of C<Carp> works, by
-changing some global variables in the C<Carp> namespace. See the
-section on C<GLOBAL VARIABLES> below.
-
-Here is a more complete description of how C<carp> and C<croak> work.
-What they do is search the call-stack for a function call stack where
-they have not been told that there shouldn't be an error. If every
-call is marked safe, they give up and give a full stack backtrace
-instead. In other words they presume that the first likely looking
-potential suspect is guilty. Their rules for telling whether
-a call shouldn't generate errors work as follows:
-
-=over 4
-
-=item 1.
-
-Any call from a package to itself is safe.
-
-=item 2.
-
-Packages claim that there won't be errors on calls to or from
-packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
-(if that array is empty) C<@ISA>. The ability to override what
- at ISA says is new in 5.8.
-
-=item 3.
-
-The trust in item 2 is transitive. If A trusts B, and B
-trusts C, then A trusts C. So if you do not override C<@ISA>
-with C<@CARP_NOT>, then this trust relationship is identical to,
-"inherits from".
-
-=item 4.
-
-Any call from an internal Perl module is safe. (Nothing keeps
-user modules from marking themselves as internal to Perl, but
-this practice is discouraged.)
-
-=item 5.
-
-Any call to Perl's warning system (eg Carp itself) is safe.
-(This rule is what keeps it from reporting the error at the
-point where you call C<carp> or C<croak>.)
-
-=item 6.
-
-C<$Carp::CarpLevel> can be set to skip a fixed number of additional
-call levels. Using this is not recommended because it is very
-difficult to get it to behave correctly.
-
-=back
-
-=head2 Forcing a Stack Trace
-
-As a debugging aid, you can force Carp to treat a croak as a confess
-and a carp as a cluck across I<all> modules. In other words, force a
-detailed stack trace to be given. This can be very helpful when trying
-to understand why, or from where, a warning or error is being generated.
-
-This feature is enabled by 'importing' the non-existent symbol
-'verbose'. You would typically enable it by saying
-
- perl -MCarp=verbose script.pl
-
-or by including the string C<-MCarp=verbose> in the PERL5OPT
-environment variable.
-
-Alternately, you can set the global variable C<$Carp::Verbose> to true.
-See the C<GLOBAL VARIABLES> section below.
-
-=head1 GLOBAL VARIABLES
-
-=head2 $Carp::MaxEvalLen
-
-This variable determines how many characters of a string-eval are to
-be shown in the output. Use a value of C<0> to show all text.
-
-Defaults to C<0>.
-
-=head2 $Carp::MaxArgLen
-
-This variable determines how many characters of each argument to a
-function to print. Use a value of C<0> to show the full length of the
-argument.
-
-Defaults to C<64>.
-
-=head2 $Carp::MaxArgNums
-
-This variable determines how many arguments to each function to show.
-Use a value of C<0> to show all arguments to a function call.
-
-Defaults to C<8>.
-
-=head2 $Carp::Verbose
-
-This variable makes C<carp> and C<croak> generate stack backtraces
-just like C<cluck> and C<confess>. This is how C<use Carp 'verbose'>
-is implemented internally.
-
-Defaults to C<0>.
-
-=head2 @CARP_NOT
-
-This variable, I<in your package>, says which packages are I<not> to be
-considered as the location of an error. The C<carp()> and C<cluck()>
-functions will skip over callers when reporting where an error occurred.
-
-NB: This variable must be in the package's symbol table, thus:
-
- # These work
- our @CARP_NOT; # file scope
- use vars qw(@CARP_NOT); # package scope
- @My::Package::CARP_NOT = ... ; # explicit package variable
-
- # These don't work
- sub xyz { ... @CARP_NOT = ... } # w/o declarations above
- my @CARP_NOT; # even at top-level
-
-Example of use:
-
- package My::Carping::Package;
- use Carp;
- our @CARP_NOT;
- sub bar { .... or _error('Wrong input') }
- sub _error {
- # temporary control of where'ness, __PACKAGE__ is implicit
- local @CARP_NOT = qw(My::Friendly::Caller);
- carp(@_)
- }
-
-This would make C<Carp> report the error as coming from a caller not
-in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
-
-Also read the L</DESCRIPTION> section above, about how C<Carp> decides
-where the error is reported from.
-
-Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
-
-Overrides C<Carp>'s use of C<@ISA>.
-
-=head2 %Carp::Internal
-
-This says what packages are internal to Perl. C<Carp> will never
-report an error as being from a line in a package that is internal to
-Perl. For example:
-
- $Carp::Internal{ (__PACKAGE__) }++;
- # time passes...
- sub foo { ... or confess("whatever") };
-
-would give a full stack backtrace starting from the first caller
-outside of __PACKAGE__. (Unless that package was also internal to
-Perl.)
-
-=head2 %Carp::CarpInternal
-
-This says which packages are internal to Perl's warning system. For
-generating a full stack backtrace this is the same as being internal
-to Perl, the stack backtrace will not start inside packages that are
-listed in C<%Carp::CarpInternal>. But it is slightly different for
-the summary message generated by C<carp> or C<croak>. There errors
-will not be reported on any lines that are calling packages in
-C<%Carp::CarpInternal>.
-
-For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
-Therefore the full stack backtrace from C<confess> will not start
-inside of C<Carp>, and the short message from calling C<croak> is
-not placed on the line where C<croak> was called.
-
-=head2 $Carp::CarpLevel
-
-This variable determines how many additional call frames are to be
-skipped that would not otherwise be when reporting where an error
-occurred on a call to one of C<Carp>'s functions. It is fairly easy
-to count these call frames on calls that generate a full stack
-backtrace. However it is much harder to do this accounting for calls
-that generate a short message. Usually people skip too many call
-frames. If they are lucky they skip enough that C<Carp> goes all of
-the way through the call stack, realizes that something is wrong, and
-then generates a full stack backtrace. If they are unlucky then the
-error is reported from somewhere misleading very high in the call
-stack.
-
-Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use
-C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
-
-Defaults to C<0>.
-
-=head1 BUGS
-
-The Carp routines don't handle exception objects currently.
-If called with a first argument that is a reference, they simply
-call die() or warn(), as appropriate.
-
Deleted: trunk/contrib/perl/lib/Carp.t
===================================================================
--- trunk/contrib/perl/lib/Carp.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Carp.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,442 +0,0 @@
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- require './test.pl';
-}
-
-use warnings;
-no warnings "once";
-
-my $Is_VMS = $^O eq 'VMS';
-
-use Carp qw(carp cluck croak confess);
-
-BEGIN {
- plan tests => 57;
-
- # This test must be run at BEGIN time, because code later in this file
- # sets CORE::GLOBAL::caller
- ok !exists $CORE::GLOBAL::{caller},
- "Loading doesn't create CORE::GLOBAL::caller";
-}
-
-{
- local $SIG{__WARN__} = sub {
- like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n';
- };
-
- carp "ok 2\n";
-}
-
-{
- local $SIG{__WARN__} = sub {
- like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3';
- };
-
- carp 3;
-}
-
-sub sub_4 {
- local $SIG{__WARN__} = sub {
- like $_[0],
- qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/,
- 'cluck 4';
- };
-
- cluck 4;
-}
-
-sub_4;
-
-{
- local $SIG{__DIE__} = sub {
- like $_[0],
- qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/,
- 'croak 5';
- };
-
- eval { croak 5 };
-}
-
-sub sub_6 {
- local $SIG{__DIE__} = sub {
- like $_[0],
- qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at.+\b(?i:carp\.t) line \d+$/,
- 'confess 6';
- };
-
- eval { confess 6 };
-}
-
-sub_6;
-
-ok(1);
-
-# test for caller_info API
-my $eval = "use Carp; return Carp::caller_info(0);";
-my %info = eval($eval);
-is( $info{sub_name}, "eval '$eval'", 'caller_info API' );
-
-# test for '...::CARP_NOT used only once' warning from Carp
-my $warning;
-eval {
- BEGIN {
- local $SIG{__WARN__} = sub {
- if ( defined $^S ) { warn $_[0] }
- else { $warning = $_[0] }
- }
- }
-
- package Z;
-
- BEGIN {
- eval { Carp::croak() };
- }
-};
-ok !$warning, q/'...::CARP_NOT used only once' warning from Carp/;
-
-# Test the location of error messages.
-like( A::short(), qr/^Error at C/, "Short messages skip carped package" );
-
-{
- local @C::ISA = "D";
- like( A::short(), qr/^Error at B/, "Short messages skip inheritance" );
-}
-
-{
- local @D::ISA = "C";
- like( A::short(), qr/^Error at B/, "Short messages skip inheritance" );
-}
-
-{
- local @D::ISA = "B";
- local @B::ISA = "C";
- like( A::short(), qr/^Error at A/, "Inheritance is transitive" );
-}
-
-{
- local @B::ISA = "D";
- local @C::ISA = "B";
- like( A::short(), qr/^Error at A/, "Inheritance is transitive" );
-}
-
-{
- local @C::CARP_NOT = "D";
- like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" );
-}
-
-{
- local @D::CARP_NOT = "C";
- like( A::short(), qr/^Error at B/, "Short messages see \@CARP_NOT" );
-}
-
-{
- local @D::CARP_NOT = "B";
- local @B::CARP_NOT = "C";
- like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" );
-}
-
-{
- local @B::CARP_NOT = "D";
- local @C::CARP_NOT = "B";
- like( A::short(), qr/^Error at A/, "\@CARP_NOT is transitive" );
-}
-
-{
- local @D::ISA = "C";
- local @D::CARP_NOT = "B";
- like( A::short(), qr/^Error at C/, "\@CARP_NOT overrides inheritance" );
-}
-
-{
- local @D::ISA = "B";
- local @D::CARP_NOT = "C";
- like( A::short(), qr/^Error at B/, "\@CARP_NOT overrides inheritance" );
-}
-
-# %Carp::Internal
-{
- local $Carp::Internal{C} = 1;
- like( A::short(), qr/^Error at B/, "Short doesn't report Internal" );
-}
-
-{
- local $Carp::Internal{D} = 1;
- like( A::long(), qr/^Error at C/, "Long doesn't report Internal" );
-}
-
-# %Carp::CarpInternal
-{
- local $Carp::CarpInternal{D} = 1;
- like(
- A::short(), qr/^Error at B/,
- "Short doesn't report calls to CarpInternal"
- );
-}
-
-{
- local $Carp::CarpInternal{D} = 1;
- like( A::long(), qr/^Error at C/, "Long doesn't report CarpInternal" );
-}
-
-# tests for global variables
-sub x { carp @_ }
-sub w { cluck @_ }
-
-# $Carp::Verbose;
-{
- my $aref = [
- qr/t at \S*(?i:carp.t) line \d+/,
- qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/
- ];
- my $i = 0;
-
- for my $re (@$aref) {
- local $Carp::Verbose = $i++;
- local $SIG{__WARN__} = sub {
- like $_[0], $re, 'Verbose';
- };
-
- package Z;
- main::x('t');
- }
-}
-
-# $Carp::MaxEvalLen
-{
- my $test_num = 1;
- for ( 0, 4 ) {
- my $txt = "Carp::cluck($test_num)";
- local $Carp::MaxEvalLen = $_;
- local $SIG{__WARN__} = sub {
- "@_" =~ /'(.+?)(?:\n|')/s;
- is length($1),
- length( $_ ? substr( $txt, 0, $_ ) : substr( $txt, 0 ) ),
- 'MaxEvalLen';
- };
- eval "$txt";
- $test_num++;
- }
-}
-
-# $Carp::MaxArgLen
-{
- for ( 0, 4 ) {
- my $arg = 'testtest';
- local $Carp::MaxArgLen = $_;
- local $SIG{__WARN__} = sub {
- "@_" =~ /'(.+?)'/;
- is length($1),
- length( $_ ? substr( $arg, 0, $_ ) : substr( $arg, 0 ) ),
- 'MaxArgLen';
- };
-
- package Z;
- main::w($arg);
- }
-}
-
-# $Carp::MaxArgNums
-{
- my $i = 0;
- my $aref = [
- qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, 3, 4\) called at \S*(?i:carp.t) line \d+/,
- qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/,
- ];
-
- for (@$aref) {
- local $Carp::MaxArgNums = $i++;
- local $SIG{__WARN__} = sub {
- like "@_", $_, 'MaxArgNums';
- };
-
- package Z;
- main::w( 1 .. 4 );
- }
-}
-
-# $Carp::CarpLevel
-{
- my $i = 0;
- my $aref = [
- qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/,
- qr/1 at \S*(?i:carp.t) line \d+$/,
- ];
-
- for (@$aref) {
- local $Carp::CarpLevel = $i++;
- local $SIG{__WARN__} = sub {
- like "@_", $_, 'CarpLevel';
- };
-
- package Z;
- main::w(1);
- }
-}
-
-{
- local $TODO = "VMS exit status semantics don't work this way" if $Is_VMS;
-
- # Check that croak() and confess() don't clobber $!
- runperl(
- prog => 'use Carp; $@=q{Phooey}; $!=42; croak(q{Dead})',
- stderr => 1
- );
-
- is( $? >> 8, 42, 'croak() doesn\'t clobber $!' );
-
- runperl(
- prog => 'use Carp; $@=q{Phooey}; $!=42; confess(q{Dead})',
- stderr => 1
- );
-
- is( $? >> 8, 42, 'confess() doesn\'t clobber $!' );
-}
-
-# undef used to be incorrectly reported as the string "undef"
-sub cluck_undef {
-
- local $SIG{__WARN__} = sub {
- like $_[0],
- qr/^Bang! at.+\b(?i:carp\.t) line \d+\n\tmain::cluck_undef\(0, 'undef', 2, undef, 4\) called at.+\b(?i:carp\.t) line \d+$/,
- "cluck doesn't quote undef";
- };
-
- cluck "Bang!"
-
-}
-
-cluck_undef( 0, "undef", 2, undef, 4 );
-
-# check that Carp respects CORE::GLOBAL::caller override after Carp
-# has been compiled
-for my $bodge_job ( 2, 1, 0 ) {
- print '# ', ( $bodge_job ? 'Not ' : '' ),
- "setting \@DB::args in caller override\n";
- if ( $bodge_job == 1 ) {
- require B;
- print "# required B\n";
- }
- my $accum = '';
- local *CORE::GLOBAL::caller = sub {
- local *__ANON__ = "fakecaller";
- my @c = CORE::caller(@_);
- $c[0] ||= 'undef';
- $accum .= "@c[0..3]\n";
- if ( !$bodge_job && CORE::caller() eq 'DB' ) {
-
- package DB;
- return CORE::caller( ( $_[0] || 0 ) + 1 );
- }
- else {
- return CORE::caller( ( $_[0] || 0 ) + 1 );
- }
- };
- eval "scalar caller()";
- like( $accum, qr/main::fakecaller/,
- "test CORE::GLOBAL::caller override in eval" );
- $accum = '';
- my $got = A::long(42);
- like( $accum, qr/main::fakecaller/,
- "test CORE::GLOBAL::caller override in Carp" );
- my $package = 'A';
- my $where = $bodge_job == 1 ? ' in &main::__ANON__' : '';
- my $warning
- = $bodge_job
- ? "\Q** Incomplete caller override detected$where; \@DB::args were not set **\E"
- : '';
-
- for ( 0 .. 2 ) {
- my $previous_package = $package;
- ++$package;
- like( $got,
- qr/${package}::long\($warning\) called at $previous_package line \d+/,
- "Correct arguments for $package" );
- }
- my $arg = $bodge_job ? $warning : 42;
- like(
- $got, qr!A::long\($arg\) called at.+\b(?i:carp\.t) line \d+!,
- 'Correct arguments for A'
- );
-}
-
-eval <<'EOT';
-no warnings 'redefine';
-sub CORE::GLOBAL::caller {
- my $height = $_[0];
- $height++;
- return CORE::caller($height);
-}
-EOT
-
-my $got = A::long(42);
-
-like(
- $got,
- qr!A::long\(\Q** Incomplete caller override detected; \E\@DB::args\Q were not set **\E\) called at.+\b(?i:carp\.t) line \d+!,
- 'Correct arguments for A'
-);
-
-# UTF8-flagged strings should not cause Carp to try to load modules (even
-# implicitly via utf8_heavy.pl) after a syntax error [perl #82854].
-fresh_perl_like(
- q<
- use utf8; use strict; use Carp;
- BEGIN { $SIG{__DIE__} = sub { Carp::croak "aaaaa$_[0]" } }
- $c
- >,
- qr/aaaaa/,
- {stderr=>1},
- 'Carp can handle UTF8-flagged strings after a syntax error',
-);
-
-# New tests go here
-
-# line 1 "A"
-package A;
-
-sub short {
- B::short();
-}
-
-sub long {
- B::long();
-}
-
-# line 1 "B"
-package B;
-
-sub short {
- C::short();
-}
-
-sub long {
- C::long();
-}
-
-# line 1 "C"
-package C;
-
-sub short {
- D::short();
-}
-
-sub long {
- D::long();
-}
-
-# line 1 "D"
-package D;
-
-sub short {
- eval { Carp::croak("Error") };
- return $@;
-}
-
-sub long {
- eval { Carp::confess("Error") };
- return $@;
-}
-
-# Put new tests at "new tests go here"
-__END__
Deleted: trunk/contrib/perl/lib/Class/ISA.pm
===================================================================
--- trunk/contrib/perl/lib/Class/ISA.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Class/ISA.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,214 +0,0 @@
-#!/usr/local/bin/perl
-# Time-stamp: "2004-12-29 20:01:02 AST" -*-Perl-*-
-
-package Class::ISA;
-require 5;
-use strict;
-use vars qw($Debug $VERSION);
-$VERSION = '0.33';
-$Debug = 0 unless defined $Debug;
-
-=head1 NAME
-
-Class::ISA -- report the search path for a class's ISA tree
-
-=head1 SYNOPSIS
-
- # Suppose you go: use Food::Fishstick, and that uses and
- # inherits from other things, which in turn use and inherit
- # from other things. And suppose, for sake of brevity of
- # example, that their ISA tree is the same as:
-
- @Food::Fishstick::ISA = qw(Food::Fish Life::Fungus Chemicals);
- @Food::Fish::ISA = qw(Food);
- @Food::ISA = qw(Matter);
- @Life::Fungus::ISA = qw(Life);
- @Chemicals::ISA = qw(Matter);
- @Life::ISA = qw(Matter);
- @Matter::ISA = qw();
-
- use Class::ISA;
- print "Food::Fishstick path is:\n ",
- join(", ", Class::ISA::super_path('Food::Fishstick')),
- "\n";
-
-That prints:
-
- Food::Fishstick path is:
- Food::Fish, Food, Matter, Life::Fungus, Life, Chemicals
-
-=head1 DESCRIPTION
-
-Suppose you have a class (like Food::Fish::Fishstick) that is derived,
-via its @ISA, from one or more superclasses (as Food::Fish::Fishstick
-is from Food::Fish, Life::Fungus, and Chemicals), and some of those
-superclasses may themselves each be derived, via its @ISA, from one or
-more superclasses (as above).
-
-When, then, you call a method in that class ($fishstick->calories),
-Perl first searches there for that method, but if it's not there, it
-goes searching in its superclasses, and so on, in a depth-first (or
-maybe "height-first" is the word) search. In the above example, it'd
-first look in Food::Fish, then Food, then Matter, then Life::Fungus,
-then Life, then Chemicals.
-
-This library, Class::ISA, provides functions that return that list --
-the list (in order) of names of classes Perl would search to find a
-method, with no duplicates.
-
-=head1 FUNCTIONS
-
-=over
-
-=item the function Class::ISA::super_path($CLASS)
-
-This returns the ordered list of names of classes that Perl would
-search thru in order to find a method, with no duplicates in the list.
-$CLASS is not included in the list. UNIVERSAL is not included -- if
-you need to consider it, add it to the end.
-
-
-=item the function Class::ISA::self_and_super_path($CLASS)
-
-Just like C<super_path>, except that $CLASS is included as the first
-element.
-
-=item the function Class::ISA::self_and_super_versions($CLASS)
-
-This returns a hash whose keys are $CLASS and its
-(super-)superclasses, and whose values are the contents of each
-class's $VERSION (or undef, for classes with no $VERSION).
-
-The code for self_and_super_versions is meant to serve as an example
-for precisely the kind of tasks I anticipate that self_and_super_path
-and super_path will be used for. You are strongly advised to read the
-source for self_and_super_versions, and the comments there.
-
-=back
-
-=head1 CAUTIONARY NOTES
-
-* Class::ISA doesn't export anything. You have to address the
-functions with a "Class::ISA::" on the front.
-
-* Contrary to its name, Class::ISA isn't a class; it's just a package.
-Strange, isn't it?
-
-* Say you have a loop in the ISA tree of the class you're calling one
-of the Class::ISA functions on: say that Food inherits from Matter,
-but Matter inherits from Food (for sake of argument). If Perl, while
-searching for a method, actually discovers this cyclicity, it will
-throw a fatal error. The functions in Class::ISA effectively ignore
-this cyclicity; the Class::ISA algorithm is "never go down the same
-path twice", and cyclicities are just a special case of that.
-
-* The Class::ISA functions just look at @ISAs. But theoretically, I
-suppose, AUTOLOADs could bypass Perl's ISA-based search mechanism and
-do whatever they please. That would be bad behavior, tho; and I try
-not to think about that.
-
-* If Perl can't find a method anywhere in the ISA tree, it then looks
-in the magical class UNIVERSAL. This is rarely relevant to the tasks
-that I expect Class::ISA functions to be put to, but if it matters to
-you, then instead of this:
-
- @supers = Class::Tree::super_path($class);
-
-do this:
-
- @supers = (Class::Tree::super_path($class), 'UNIVERSAL');
-
-And don't say no-one ever told ya!
-
-* When you call them, the Class::ISA functions look at @ISAs anew --
-that is, there is no memoization, and so if ISAs change during
-runtime, you get the current ISA tree's path, not anything memoized.
-However, changing ISAs at runtime is probably a sign that you're out
-of your mind!
-
-=head1 COPYRIGHT
-
-Copyright (c) 1999, 2000 Sean M. Burke. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 AUTHOR
-
-Sean M. Burke C<sburke at cpan.org>
-
-=cut
-
-###########################################################################
-
-sub self_and_super_versions {
- no strict 'refs';
- map {
- $_ => (defined(${"$_\::VERSION"}) ? ${"$_\::VERSION"} : undef)
- } self_and_super_path($_[0])
-}
-
-# Also consider magic like:
-# no strict 'refs';
-# my %class2SomeHashr =
-# map { defined(%{"$_\::SomeHash"}) ? ($_ => \%{"$_\::SomeHash"}) : () }
-# Class::ISA::self_and_super_path($class);
-# to get a hash of refs to all the defined (and non-empty) hashes in
-# $class and its superclasses.
-#
-# Or even consider this incantation for doing something like hash-data
-# inheritance:
-# no strict 'refs';
-# %union_hash =
-# map { defined(%{"$_\::SomeHash"}) ? %{"$_\::SomeHash"}) : () }
-# reverse(Class::ISA::self_and_super_path($class));
-# Consider that reverse() is necessary because with
-# %foo = ('a', 'wun', 'b', 'tiw', 'a', 'foist');
-# $foo{'a'} is 'foist', not 'wun'.
-
-###########################################################################
-sub super_path {
- my @ret = &self_and_super_path(@_);
- shift @ret if @ret;
- return @ret;
-}
-
-#--------------------------------------------------------------------------
-sub self_and_super_path {
- # Assumption: searching is depth-first.
- # Assumption: '' (empty string) can't be a class package name.
- # Note: 'UNIVERSAL' is not given any special treatment.
- return () unless @_;
-
- my @out = ();
-
- my @in_stack = ($_[0]);
- my %seen = ($_[0] => 1);
-
- my $current;
- while(@in_stack) {
- next unless defined($current = shift @in_stack) && length($current);
- print "At $current\n" if $Debug;
- push @out, $current;
- no strict 'refs';
- unshift @in_stack,
- map
- { my $c = $_; # copy, to avoid being destructive
- substr($c,0,2) = "main::" if substr($c,0,2) eq '::';
- # Canonize the :: -> main::, ::foo -> main::foo thing.
- # Should I ever canonize the Foo'Bar = Foo::Bar thing?
- $seen{$c}++ ? () : $c;
- }
- @{"$current\::ISA"}
- ;
- # I.e., if this class has any parents (at least, ones I've never seen
- # before), push them, in order, onto the stack of classes I need to
- # explore.
- }
-
- return @out;
-}
-#--------------------------------------------------------------------------
-1;
-
-__END__
Deleted: trunk/contrib/perl/lib/Cwd.pm
===================================================================
--- trunk/contrib/perl/lib/Cwd.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Cwd.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,824 +0,0 @@
-package Cwd;
-
-=head1 NAME
-
-Cwd - get pathname of current working directory
-
-=head1 SYNOPSIS
-
- use Cwd;
- my $dir = getcwd;
-
- use Cwd 'abs_path';
- my $abs_path = abs_path($file);
-
-=head1 DESCRIPTION
-
-This module provides functions for determining the pathname of the
-current working directory. It is recommended that getcwd (or another
-*cwd() function) be used in I<all> code to ensure portability.
-
-By default, it exports the functions cwd(), getcwd(), fastcwd(), and
-fastgetcwd() (and, on Win32, getdcwd()) into the caller's namespace.
-
-
-=head2 getcwd and friends
-
-Each of these functions are called without arguments and return the
-absolute path of the current working directory.
-
-=over 4
-
-=item getcwd
-
- my $cwd = getcwd();
-
-Returns the current working directory.
-
-Exposes the POSIX function getcwd(3) or re-implements it if it's not
-available.
-
-=item cwd
-
- my $cwd = cwd();
-
-The cwd() is the most natural form for the current architecture. For
-most systems it is identical to `pwd` (but without the trailing line
-terminator).
-
-=item fastcwd
-
- my $cwd = fastcwd();
-
-A more dangerous version of getcwd(), but potentially faster.
-
-It might conceivably chdir() you out of a directory that it can't
-chdir() you back into. If fastcwd encounters a problem it will return
-undef but will probably leave you in a different directory. For a
-measure of extra security, if everything appears to have worked, the
-fastcwd() function will check that it leaves you in the same directory
-that it started in. If it has changed it will C<die> with the message
-"Unstable directory path, current directory changed
-unexpectedly". That should never happen.
-
-=item fastgetcwd
-
- my $cwd = fastgetcwd();
-
-The fastgetcwd() function is provided as a synonym for cwd().
-
-=item getdcwd
-
- my $cwd = getdcwd();
- my $cwd = getdcwd('C:');
-
-The getdcwd() function is also provided on Win32 to get the current working
-directory on the specified drive, since Windows maintains a separate current
-working directory for each drive. If no drive is specified then the current
-drive is assumed.
-
-This function simply calls the Microsoft C library _getdcwd() function.
-
-=back
-
-
-=head2 abs_path and friends
-
-These functions are exported only on request. They each take a single
-argument and return the absolute pathname for it. If no argument is
-given they'll use the current working directory.
-
-=over 4
-
-=item abs_path
-
- my $abs_path = abs_path($file);
-
-Uses the same algorithm as getcwd(). Symbolic links and relative-path
-components ("." and "..") are resolved to return the canonical
-pathname, just like realpath(3).
-
-=item realpath
-
- my $abs_path = realpath($file);
-
-A synonym for abs_path().
-
-=item fast_abs_path
-
- my $abs_path = fast_abs_path($file);
-
-A more dangerous, but potentially faster version of abs_path.
-
-=back
-
-=head2 $ENV{PWD}
-
-If you ask to override your chdir() built-in function,
-
- use Cwd qw(chdir);
-
-then your PWD environment variable will be kept up to date. Note that
-it will only be kept up to date if all packages which use chdir import
-it from Cwd.
-
-
-=head1 NOTES
-
-=over 4
-
-=item *
-
-Since the path seperators are different on some operating systems ('/'
-on Unix, ':' on MacPerl, etc...) we recommend you use the File::Spec
-modules wherever portability is a concern.
-
-=item *
-
-Actually, on Mac OS, the C<getcwd()>, C<fastgetcwd()> and C<fastcwd()>
-functions are all aliases for the C<cwd()> function, which, on Mac OS,
-calls `pwd`. Likewise, the C<abs_path()> function is an alias for
-C<fast_abs_path()>.
-
-=back
-
-=head1 AUTHOR
-
-Originally by the perl5-porters.
-
-Maintained by Ken Williams <KWILLIAMS at cpan.org>
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Portions of the C code in this library are copyright (c) 1994 by the
-Regents of the University of California. All rights reserved. The
-license on this code is compatible with the licensing of the rest of
-the distribution - please see the source code in F<Cwd.xs> for the
-details.
-
-=head1 SEE ALSO
-
-L<File::chdir>
-
-=cut
-
-use strict;
-use Exporter;
-use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
-
-$VERSION = '3.30';
-my $xs_version = $VERSION;
-$VERSION = eval $VERSION;
-
- at ISA = qw/ Exporter /;
- at EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
-push @EXPORT, qw(getdcwd) if $^O eq 'MSWin32';
- at EXPORT_OK = qw(chdir abs_path fast_abs_path realpath fast_realpath);
-
-# sys_cwd may keep the builtin command
-
-# All the functionality of this module may provided by builtins,
-# there is no sense to process the rest of the file.
-# The best choice may be to have this in BEGIN, but how to return from BEGIN?
-
-if ($^O eq 'os2') {
- local $^W = 0;
-
- *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
- *getcwd = \&cwd;
- *fastgetcwd = \&cwd;
- *fastcwd = \&cwd;
-
- *fast_abs_path = \&sys_abspath if defined &sys_abspath;
- *abs_path = \&fast_abs_path;
- *realpath = \&fast_abs_path;
- *fast_realpath = \&fast_abs_path;
-
- return 1;
-}
-
-# Need to look up the feature settings on VMS. The preferred way is to use the
-# VMS::Feature module, but that may not be available to dual life modules.
-
-my $use_vms_feature;
-BEGIN {
- if ($^O eq 'VMS') {
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
- $use_vms_feature = 1;
- }
- }
-}
-
-# Need to look up the UNIX report mode. This may become a dynamic mode
-# in the future.
-sub _vms_unix_rpt {
- my $unix_rpt;
- if ($use_vms_feature) {
- $unix_rpt = VMS::Feature::current("filename_unix_report");
- } else {
- my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
- $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
- }
- return $unix_rpt;
-}
-
-# Need to look up the EFS character set mode. This may become a dynamic
-# mode in the future.
-sub _vms_efs {
- my $efs;
- if ($use_vms_feature) {
- $efs = VMS::Feature::current("efs_charset");
- } else {
- my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
- $efs = $env_efs =~ /^[ET1]/i;
- }
- return $efs;
-}
-
-
-# If loading the XS stuff doesn't work, we can fall back to pure perl
-eval {
- if ( $] >= 5.006 ) {
- require XSLoader;
- XSLoader::load( __PACKAGE__, $xs_version);
- } else {
- require DynaLoader;
- push @ISA, 'DynaLoader';
- __PACKAGE__->bootstrap( $xs_version );
- }
-};
-
-# Must be after the DynaLoader stuff:
-$VERSION = eval $VERSION;
-
-# Big nasty table of function aliases
-my %METHOD_MAP =
- (
- VMS =>
- {
- cwd => '_vms_cwd',
- getcwd => '_vms_cwd',
- fastcwd => '_vms_cwd',
- fastgetcwd => '_vms_cwd',
- abs_path => '_vms_abs_path',
- fast_abs_path => '_vms_abs_path',
- },
-
- MSWin32 =>
- {
- # We assume that &_NT_cwd is defined as an XSUB or in the core.
- cwd => '_NT_cwd',
- getcwd => '_NT_cwd',
- fastcwd => '_NT_cwd',
- fastgetcwd => '_NT_cwd',
- abs_path => 'fast_abs_path',
- realpath => 'fast_abs_path',
- },
-
- dos =>
- {
- cwd => '_dos_cwd',
- getcwd => '_dos_cwd',
- fastgetcwd => '_dos_cwd',
- fastcwd => '_dos_cwd',
- abs_path => 'fast_abs_path',
- },
-
- # QNX4. QNX6 has a $os of 'nto'.
- qnx =>
- {
- cwd => '_qnx_cwd',
- getcwd => '_qnx_cwd',
- fastgetcwd => '_qnx_cwd',
- fastcwd => '_qnx_cwd',
- abs_path => '_qnx_abs_path',
- fast_abs_path => '_qnx_abs_path',
- },
-
- cygwin =>
- {
- getcwd => 'cwd',
- fastgetcwd => 'cwd',
- fastcwd => 'cwd',
- abs_path => 'fast_abs_path',
- realpath => 'fast_abs_path',
- },
-
- epoc =>
- {
- cwd => '_epoc_cwd',
- getcwd => '_epoc_cwd',
- fastgetcwd => '_epoc_cwd',
- fastcwd => '_epoc_cwd',
- abs_path => 'fast_abs_path',
- },
-
- MacOS =>
- {
- getcwd => 'cwd',
- fastgetcwd => 'cwd',
- fastcwd => 'cwd',
- abs_path => 'fast_abs_path',
- },
- );
-
-$METHOD_MAP{NT} = $METHOD_MAP{MSWin32};
-
-
-# Find the pwd command in the expected locations. We assume these
-# are safe. This prevents _backtick_pwd() consulting $ENV{PATH}
-# so everything works under taint mode.
-my $pwd_cmd;
-foreach my $try ('/bin/pwd',
- '/usr/bin/pwd',
- '/QOpenSys/bin/pwd', # OS/400 PASE.
- ) {
-
- if( -x $try ) {
- $pwd_cmd = $try;
- last;
- }
-}
-my $found_pwd_cmd = defined($pwd_cmd);
-unless ($pwd_cmd) {
- # Isn't this wrong? _backtick_pwd() will fail if somenone has
- # pwd in their path but it is not /bin/pwd or /usr/bin/pwd?
- # See [perl #16774]. --jhi
- $pwd_cmd = 'pwd';
-}
-
-# Lazy-load Carp
-sub _carp { require Carp; Carp::carp(@_) }
-sub _croak { require Carp; Carp::croak(@_) }
-
-# The 'natural and safe form' for UNIX (pwd may be setuid root)
-sub _backtick_pwd {
- # Localize %ENV entries in a way that won't create new hash keys
- my @localize = grep exists $ENV{$_}, qw(PATH IFS CDPATH ENV BASH_ENV);
- local @ENV{@localize};
-
- my $cwd = `$pwd_cmd`;
- # Belt-and-suspenders in case someone said "undef $/".
- local $/ = "\n";
- # `pwd` may fail e.g. if the disk is full
- chomp($cwd) if defined $cwd;
- $cwd;
-}
-
-# Since some ports may predefine cwd internally (e.g., NT)
-# we take care not to override an existing definition for cwd().
-
-unless ($METHOD_MAP{$^O}{cwd} or defined &cwd) {
- # The pwd command is not available in some chroot(2)'ed environments
- my $sep = $Config::Config{path_sep} || ':';
- my $os = $^O; # Protect $^O from tainting
-
-
- # Try again to find a pwd, this time searching the whole PATH.
- if (defined $ENV{PATH} and $os ne 'MSWin32') { # no pwd on Windows
- my @candidates = split($sep, $ENV{PATH});
- while (!$found_pwd_cmd and @candidates) {
- my $candidate = shift @candidates;
- $found_pwd_cmd = 1 if -x "$candidate/pwd";
- }
- }
-
- # MacOS has some special magic to make `pwd` work.
- if( $os eq 'MacOS' || $found_pwd_cmd )
- {
- *cwd = \&_backtick_pwd;
- }
- else {
- *cwd = \&getcwd;
- }
-}
-
-if ($^O eq 'cygwin') {
- # We need to make sure cwd() is called with no args, because it's
- # got an arg-less prototype and will die if args are present.
- local $^W = 0;
- my $orig_cwd = \&cwd;
- *cwd = sub { &$orig_cwd() }
-}
-
-
-# set a reasonable (and very safe) default for fastgetcwd, in case it
-# isn't redefined later (20001212 rspier)
-*fastgetcwd = \&cwd;
-
-# A non-XS version of getcwd() - also used to bootstrap the perl build
-# process, when miniperl is running and no XS loading happens.
-sub _perl_getcwd
-{
- abs_path('.');
-}
-
-# By John Bazik
-#
-# Usage: $cwd = &fastcwd;
-#
-# This is a faster version of getcwd. It's also more dangerous because
-# you might chdir out of a directory that you can't chdir back into.
-
-sub fastcwd_ {
- my($odev, $oino, $cdev, $cino, $tdev, $tino);
- my(@path, $path);
- local(*DIR);
-
- my($orig_cdev, $orig_cino) = stat('.');
- ($cdev, $cino) = ($orig_cdev, $orig_cino);
- for (;;) {
- my $direntry;
- ($odev, $oino) = ($cdev, $cino);
- CORE::chdir('..') || return undef;
- ($cdev, $cino) = stat('.');
- last if $odev == $cdev && $oino == $cino;
- opendir(DIR, '.') || return undef;
- for (;;) {
- $direntry = readdir(DIR);
- last unless defined $direntry;
- next if $direntry eq '.';
- next if $direntry eq '..';
-
- ($tdev, $tino) = lstat($direntry);
- last unless $tdev != $odev || $tino != $oino;
- }
- closedir(DIR);
- return undef unless defined $direntry; # should never happen
- unshift(@path, $direntry);
- }
- $path = '/' . join('/', @path);
- if ($^O eq 'apollo') { $path = "/".$path; }
- # At this point $path may be tainted (if tainting) and chdir would fail.
- # Untaint it then check that we landed where we started.
- $path =~ /^(.*)\z/s # untaint
- && CORE::chdir($1) or return undef;
- ($cdev, $cino) = stat('.');
- die "Unstable directory path, current directory changed unexpectedly"
- if $cdev != $orig_cdev || $cino != $orig_cino;
- $path;
-}
-if (not defined &fastcwd) { *fastcwd = \&fastcwd_ }
-
-
-# Keeps track of current working directory in PWD environment var
-# Usage:
-# use Cwd 'chdir';
-# chdir $newdir;
-
-my $chdir_init = 0;
-
-sub chdir_init {
- if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'dos' and $^O ne 'MSWin32') {
- my($dd,$di) = stat('.');
- my($pd,$pi) = stat($ENV{'PWD'});
- if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
- $ENV{'PWD'} = cwd();
- }
- }
- else {
- my $wd = cwd();
- $wd = Win32::GetFullPathName($wd) if $^O eq 'MSWin32';
- $ENV{'PWD'} = $wd;
- }
- # Strip an automounter prefix (where /tmp_mnt/foo/bar == /foo/bar)
- if ($^O ne 'MSWin32' and $ENV{'PWD'} =~ m|(/[^/]+(/[^/]+/[^/]+))(.*)|s) {
- my($pd,$pi) = stat($2);
- my($dd,$di) = stat($1);
- if (defined $pd and defined $dd and $di == $pi and $dd == $pd) {
- $ENV{'PWD'}="$2$3";
- }
- }
- $chdir_init = 1;
-}
-
-sub chdir {
- my $newdir = @_ ? shift : ''; # allow for no arg (chdir to HOME dir)
- $newdir =~ s|///*|/|g unless $^O eq 'MSWin32';
- chdir_init() unless $chdir_init;
- my $newpwd;
- if ($^O eq 'MSWin32') {
- # get the full path name *before* the chdir()
- $newpwd = Win32::GetFullPathName($newdir);
- }
-
- return 0 unless CORE::chdir $newdir;
-
- if ($^O eq 'VMS') {
- return $ENV{'PWD'} = $ENV{'DEFAULT'}
- }
- elsif ($^O eq 'MacOS') {
- return $ENV{'PWD'} = cwd();
- }
- elsif ($^O eq 'MSWin32') {
- $ENV{'PWD'} = $newpwd;
- return 1;
- }
-
- if (ref $newdir eq 'GLOB') { # in case a file/dir handle is passed in
- $ENV{'PWD'} = cwd();
- } elsif ($newdir =~ m#^/#s) {
- $ENV{'PWD'} = $newdir;
- } else {
- my @curdir = split(m#/#,$ENV{'PWD'});
- @curdir = ('') unless @curdir;
- my $component;
- foreach $component (split(m#/#, $newdir)) {
- next if $component eq '.';
- pop(@curdir),next if $component eq '..';
- push(@curdir,$component);
- }
- $ENV{'PWD'} = join('/', at curdir) || '/';
- }
- 1;
-}
-
-
-sub _perl_abs_path
-{
- my $start = @_ ? shift : '.';
- my($dotdots, $cwd, @pst, @cst, $dir, @tst);
-
- unless (@cst = stat( $start ))
- {
- _carp("stat($start): $!");
- return '';
- }
-
- unless (-d _) {
- # Make sure we can be invoked on plain files, not just directories.
- # NOTE that this routine assumes that '/' is the only directory separator.
-
- my ($dir, $file) = $start =~ m{^(.*)/(.+)$}
- or return cwd() . '/' . $start;
-
- # Can't use "-l _" here, because the previous stat was a stat(), not an lstat().
- if (-l $start) {
- my $link_target = readlink($start);
- die "Can't resolve link $start: $!" unless defined $link_target;
-
- require File::Spec;
- $link_target = $dir . '/' . $link_target
- unless File::Spec->file_name_is_absolute($link_target);
-
- return abs_path($link_target);
- }
-
- return $dir ? abs_path($dir) . "/$file" : "/$file";
- }
-
- $cwd = '';
- $dotdots = $start;
- do
- {
- $dotdots .= '/..';
- @pst = @cst;
- local *PARENT;
- unless (opendir(PARENT, $dotdots))
- {
- # probably a permissions issue. Try the native command.
- return File::Spec->rel2abs( $start, _backtick_pwd() );
- }
- unless (@cst = stat($dotdots))
- {
- _carp("stat($dotdots): $!");
- closedir(PARENT);
- return '';
- }
- if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
- {
- $dir = undef;
- }
- else
- {
- do
- {
- unless (defined ($dir = readdir(PARENT)))
- {
- _carp("readdir($dotdots): $!");
- closedir(PARENT);
- return '';
- }
- $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
- }
- while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
- $tst[1] != $pst[1]);
- }
- $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
- closedir(PARENT);
- } while (defined $dir);
- chop($cwd) unless $cwd eq '/'; # drop the trailing /
- $cwd;
-}
-
-
-my $Curdir;
-sub fast_abs_path {
- local $ENV{PWD} = $ENV{PWD} || ''; # Guard against clobberage
- my $cwd = getcwd();
- require File::Spec;
- my $path = @_ ? shift : ($Curdir ||= File::Spec->curdir);
-
- # Detaint else we'll explode in taint mode. This is safe because
- # we're not doing anything dangerous with it.
- ($path) = $path =~ /(.*)/;
- ($cwd) = $cwd =~ /(.*)/;
-
- unless (-e $path) {
- _croak("$path: No such file or directory");
- }
-
- unless (-d _) {
- # Make sure we can be invoked on plain files, not just directories.
-
- my ($vol, $dir, $file) = File::Spec->splitpath($path);
- return File::Spec->catfile($cwd, $path) unless length $dir;
-
- if (-l $path) {
- my $link_target = readlink($path);
- die "Can't resolve link $path: $!" unless defined $link_target;
-
- $link_target = File::Spec->catpath($vol, $dir, $link_target)
- unless File::Spec->file_name_is_absolute($link_target);
-
- return fast_abs_path($link_target);
- }
-
- return $dir eq File::Spec->rootdir
- ? File::Spec->catpath($vol, $dir, $file)
- : fast_abs_path(File::Spec->catpath($vol, $dir, '')) . '/' . $file;
- }
-
- if (!CORE::chdir($path)) {
- _croak("Cannot chdir to $path: $!");
- }
- my $realpath = getcwd();
- if (! ((-d $cwd) && (CORE::chdir($cwd)))) {
- _croak("Cannot chdir back to $cwd: $!");
- }
- $realpath;
-}
-
-# added function alias to follow principle of least surprise
-# based on previous aliasing. --tchrist 27-Jan-00
-*fast_realpath = \&fast_abs_path;
-
-
-# --- PORTING SECTION ---
-
-# VMS: $ENV{'DEFAULT'} points to default directory at all times
-# 06-Mar-1996 Charles Bailey bailey at newman.upenn.edu
-# Note: Use of Cwd::chdir() causes the logical name PWD to be defined
-# in the process logical name table as the default device and directory
-# seen by Perl. This may not be the same as the default device
-# and directory seen by DCL after Perl exits, since the effects
-# the CRTL chdir() function persist only until Perl exits.
-
-sub _vms_cwd {
- return $ENV{'DEFAULT'};
-}
-
-sub _vms_abs_path {
- return $ENV{'DEFAULT'} unless @_;
- my $path = shift;
-
- my $efs = _vms_efs;
- my $unix_rpt = _vms_unix_rpt;
-
- if (defined &VMS::Filespec::vmsrealpath) {
- my $path_unix = 0;
- my $path_vms = 0;
-
- $path_unix = 1 if ($path =~ m#(?<=\^)/#);
- $path_unix = 1 if ($path =~ /^\.\.?$/);
- $path_vms = 1 if ($path =~ m#[\[<\]]#);
- $path_vms = 1 if ($path =~ /^--?$/);
-
- my $unix_mode = $path_unix;
- if ($efs) {
- # In case of a tie, the Unix report mode decides.
- if ($path_vms == $path_unix) {
- $unix_mode = $unix_rpt;
- } else {
- $unix_mode = 0 if $path_vms;
- }
- }
-
- if ($unix_mode) {
- # Unix format
- return VMS::Filespec::unixrealpath($path);
- }
-
- # VMS format
-
- my $new_path = VMS::Filespec::vmsrealpath($path);
-
- # Perl expects directories to be in directory format
- $new_path = VMS::Filespec::pathify($new_path) if -d $path;
- return $new_path;
- }
-
- # Fallback to older algorithm if correct ones are not
- # available.
-
- if (-l $path) {
- my $link_target = readlink($path);
- die "Can't resolve link $path: $!" unless defined $link_target;
-
- return _vms_abs_path($link_target);
- }
-
- # may need to turn foo.dir into [.foo]
- my $pathified = VMS::Filespec::pathify($path);
- $path = $pathified if defined $pathified;
-
- return VMS::Filespec::rmsexpand($path);
-}
-
-sub _os2_cwd {
- $ENV{'PWD'} = `cmd /c cd`;
- chomp $ENV{'PWD'};
- $ENV{'PWD'} =~ s:\\:/:g ;
- return $ENV{'PWD'};
-}
-
-sub _win32_cwd {
- if (defined &DynaLoader::boot_DynaLoader) {
- $ENV{'PWD'} = Win32::GetCwd();
- }
- else { # miniperl
- chomp($ENV{'PWD'} = `cd`);
- }
- $ENV{'PWD'} =~ s:\\:/:g ;
- return $ENV{'PWD'};
-}
-
-*_NT_cwd = defined &Win32::GetCwd ? \&_win32_cwd : \&_os2_cwd;
-
-sub _dos_cwd {
- if (!defined &Dos::GetCwd) {
- $ENV{'PWD'} = `command /c cd`;
- chomp $ENV{'PWD'};
- $ENV{'PWD'} =~ s:\\:/:g ;
- } else {
- $ENV{'PWD'} = Dos::GetCwd();
- }
- return $ENV{'PWD'};
-}
-
-sub _qnx_cwd {
- local $ENV{PATH} = '';
- local $ENV{CDPATH} = '';
- local $ENV{ENV} = '';
- $ENV{'PWD'} = `/usr/bin/fullpath -t`;
- chomp $ENV{'PWD'};
- return $ENV{'PWD'};
-}
-
-sub _qnx_abs_path {
- local $ENV{PATH} = '';
- local $ENV{CDPATH} = '';
- local $ENV{ENV} = '';
- my $path = @_ ? shift : '.';
- local *REALPATH;
-
- defined( open(REALPATH, '-|') || exec '/usr/bin/fullpath', '-t', $path ) or
- die "Can't open /usr/bin/fullpath: $!";
- my $realpath = <REALPATH>;
- close REALPATH;
- chomp $realpath;
- return $realpath;
-}
-
-sub _epoc_cwd {
- $ENV{'PWD'} = EPOC::getcwd();
- return $ENV{'PWD'};
-}
-
-
-# Now that all the base-level functions are set up, alias the
-# user-level functions to the right places
-
-if (exists $METHOD_MAP{$^O}) {
- my $map = $METHOD_MAP{$^O};
- foreach my $name (keys %$map) {
- local $^W = 0; # assignments trigger 'subroutine redefined' warning
- no strict 'refs';
- *{$name} = \&{$map->{$name}};
- }
-}
-
-# In case the XS version doesn't load.
-*abs_path = \&_perl_abs_path unless defined &abs_path;
-*getcwd = \&_perl_getcwd unless defined &getcwd;
-
-# added function alias for those of us more
-# used to the libc function. --tchrist 27-Jan-00
-*realpath = \&abs_path;
-
-1;
Deleted: trunk/contrib/perl/lib/Digest.pm
===================================================================
--- trunk/contrib/perl/lib/Digest.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Digest.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,316 +0,0 @@
-package Digest;
-
-use strict;
-use vars qw($VERSION %MMAP $AUTOLOAD);
-
-$VERSION = "1.16";
-
-%MMAP = (
- "SHA-1" => [["Digest::SHA", 1], "Digest::SHA1", ["Digest::SHA2", 1]],
- "SHA-224" => [["Digest::SHA", 224]],
- "SHA-256" => [["Digest::SHA", 256], ["Digest::SHA2", 256]],
- "SHA-384" => [["Digest::SHA", 384], ["Digest::SHA2", 384]],
- "SHA-512" => [["Digest::SHA", 512], ["Digest::SHA2", 512]],
- "HMAC-MD5" => "Digest::HMAC_MD5",
- "HMAC-SHA-1" => "Digest::HMAC_SHA1",
- "CRC-16" => [["Digest::CRC", type => "crc16"]],
- "CRC-32" => [["Digest::CRC", type => "crc32"]],
- "CRC-CCITT" => [["Digest::CRC", type => "crcccitt"]],
- "RIPEMD-160" => "Crypt::PIPEMD160",
-);
-
-sub new
-{
- shift; # class ignored
- my $algorithm = shift;
- my $impl = $MMAP{$algorithm} || do {
- $algorithm =~ s/\W+//;
- "Digest::$algorithm";
- };
- $impl = [$impl] unless ref($impl);
- my $err;
- for (@$impl) {
- my $class = $_;
- my @args;
- ($class, @args) = @$class if ref($class);
- no strict 'refs';
- unless (exists ${"$class\::"}{"VERSION"}) {
- eval "require $class";
- if ($@) {
- $err ||= $@;
- next;
- }
- }
- return $class->new(@args, @_);
- }
- die $err;
-}
-
-sub AUTOLOAD
-{
- my $class = shift;
- my $algorithm = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
- $class->new($algorithm, @_);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Digest - Modules that calculate message digests
-
-=head1 SYNOPSIS
-
- $md5 = Digest->new("MD5");
- $sha1 = Digest->new("SHA-1");
- $sha256 = Digest->new("SHA-256");
- $sha384 = Digest->new("SHA-384");
- $sha512 = Digest->new("SHA-512");
-
- $hmac = Digest->HMAC_MD5($key);
-
-=head1 DESCRIPTION
-
-The C<Digest::> modules calculate digests, also called "fingerprints"
-or "hashes", of some data, called a message. The digest is (usually)
-some small/fixed size string. The actual size of the digest depend of
-the algorithm used. The message is simply a sequence of arbitrary
-bytes or bits.
-
-An important property of the digest algorithms is that the digest is
-I<likely> to change if the message change in some way. Another
-property is that digest functions are one-way functions, that is it
-should be I<hard> to find a message that correspond to some given
-digest. Algorithms differ in how "likely" and how "hard", as well as
-how efficient they are to compute.
-
-Note that the properties of the algorithms change over time, as the
-algorithms are analyzed and machines grow faster. If your application
-for instance depends on it being "impossible" to generate the same
-digest for a different message it is wise to make it easy to plug in
-stronger algorithms as the one used grow weaker. Using the interface
-documented here should make it easy to change algorithms later.
-
-All C<Digest::> modules provide the same programming interface. A
-functional interface for simple use, as well as an object oriented
-interface that can handle messages of arbitrary length and which can
-read files directly.
-
-The digest can be delivered in three formats:
-
-=over 8
-
-=item I<binary>
-
-This is the most compact form, but it is not well suited for printing
-or embedding in places that can't handle arbitrary data.
-
-=item I<hex>
-
-A twice as long string of lowercase hexadecimal digits.
-
-=item I<base64>
-
-A string of portable printable characters. This is the base64 encoded
-representation of the digest with any trailing padding removed. The
-string will be about 30% longer than the binary version.
-L<MIME::Base64> tells you more about this encoding.
-
-=back
-
-
-The functional interface is simply importable functions with the same
-name as the algorithm. The functions take the message as argument and
-return the digest. Example:
-
- use Digest::MD5 qw(md5);
- $digest = md5($message);
-
-There are also versions of the functions with "_hex" or "_base64"
-appended to the name, which returns the digest in the indicated form.
-
-=head1 OO INTERFACE
-
-The following methods are available for all C<Digest::> modules:
-
-=over 4
-
-=item $ctx = Digest->XXX($arg,...)
-
-=item $ctx = Digest->new(XXX => $arg,...)
-
-=item $ctx = Digest::XXX->new($arg,...)
-
-The constructor returns some object that encapsulate the state of the
-message-digest algorithm. You can add data to the object and finally
-ask for the digest. The "XXX" should of course be replaced by the proper
-name of the digest algorithm you want to use.
-
-The two first forms are simply syntactic sugar which automatically
-load the right module on first use. The second form allow you to use
-algorithm names which contains letters which are not legal perl
-identifiers, e.g. "SHA-1". If no implementation for the given algorithm
-can be found, then an exception is raised.
-
-If new() is called as an instance method (i.e. $ctx->new) it will just
-reset the state the object to the state of a newly created object. No
-new object is created in this case, and the return value is the
-reference to the object (i.e. $ctx).
-
-=item $other_ctx = $ctx->clone
-
-The clone method creates a copy of the digest state object and returns
-a reference to the copy.
-
-=item $ctx->reset
-
-This is just an alias for $ctx->new.
-
-=item $ctx->add( $data )
-
-=item $ctx->add( $chunk1, $chunk2, ... )
-
-The string value of the $data provided as argument is appended to the
-message we calculate the digest for. The return value is the $ctx
-object itself.
-
-If more arguments are provided then they are all appended to the
-message, thus all these lines will have the same effect on the state
-of the $ctx object:
-
- $ctx->add("a"); $ctx->add("b"); $ctx->add("c");
- $ctx->add("a")->add("b")->add("c");
- $ctx->add("a", "b", "c");
- $ctx->add("abc");
-
-Most algorithms are only defined for strings of bytes and this method
-might therefore croak if the provided arguments contain chars with
-ordinal number above 255.
-
-=item $ctx->addfile( $io_handle )
-
-The $io_handle is read until EOF and the content is appended to the
-message we calculate the digest for. The return value is the $ctx
-object itself.
-
-The addfile() method will croak() if it fails reading data for some
-reason. If it croaks it is unpredictable what the state of the $ctx
-object will be in. The addfile() method might have been able to read
-the file partially before it failed. It is probably wise to discard
-or reset the $ctx object if this occurs.
-
-In most cases you want to make sure that the $io_handle is in
-"binmode" before you pass it as argument to the addfile() method.
-
-=item $ctx->add_bits( $data, $nbits )
-
-=item $ctx->add_bits( $bitstring )
-
-The add_bits() method is an alternative to add() that allow partial
-bytes to be appended to the message. Most users should just ignore
-this method as partial bytes is very unlikely to be of any practical
-use.
-
-The two argument form of add_bits() will add the first $nbits bits
-from $data. For the last potentially partial byte only the high order
-C<< $nbits % 8 >> bits are used. If $nbits is greater than C<<
-length($data) * 8 >>, then this method would do the same as C<<
-$ctx->add($data) >>.
-
-The one argument form of add_bits() takes a $bitstring of "1" and "0"
-chars as argument. It's a shorthand for C<< $ctx->add_bits(pack("B*",
-$bitstring), length($bitstring)) >>.
-
-The return value is the $ctx object itself.
-
-This example shows two calls that should have the same effect:
-
- $ctx->add_bits("111100001010");
- $ctx->add_bits("\xF0\xA0", 12);
-
-Most digest algorithms are byte based and for these it is not possible
-to add bits that are not a multiple of 8, and the add_bits() method
-will croak if you try.
-
-=item $ctx->digest
-
-Return the binary digest for the message.
-
-Note that the C<digest> operation is effectively a destructive,
-read-once operation. Once it has been performed, the $ctx object is
-automatically C<reset> and can be used to calculate another digest
-value. Call $ctx->clone->digest if you want to calculate the digest
-without resetting the digest state.
-
-=item $ctx->hexdigest
-
-Same as $ctx->digest, but will return the digest in hexadecimal form.
-
-=item $ctx->b64digest
-
-Same as $ctx->digest, but will return the digest as a base64 encoded
-string.
-
-=back
-
-=head1 Digest speed
-
-This table should give some indication on the relative speed of
-different algorithms. It is sorted by throughput based on a benchmark
-done with of some implementations of this API:
-
- Algorithm Size Implementation MB/s
-
- MD4 128 Digest::MD4 v1.3 165.0
- MD5 128 Digest::MD5 v2.33 98.8
- SHA-256 256 Digest::SHA2 v1.1.0 66.7
- SHA-1 160 Digest::SHA v4.3.1 58.9
- SHA-1 160 Digest::SHA1 v2.10 48.8
- SHA-256 256 Digest::SHA v4.3.1 41.3
- Haval-256 256 Digest::Haval256 v1.0.4 39.8
- SHA-384 384 Digest::SHA2 v1.1.0 19.6
- SHA-512 512 Digest::SHA2 v1.1.0 19.3
- SHA-384 384 Digest::SHA v4.3.1 19.2
- SHA-512 512 Digest::SHA v4.3.1 19.2
- Whirlpool 512 Digest::Whirlpool v1.0.2 13.0
- MD2 128 Digest::MD2 v2.03 9.5
-
- Adler-32 32 Digest::Adler32 v0.03 1.3
- CRC-16 16 Digest::CRC v0.05 1.1
- CRC-32 32 Digest::CRC v0.05 1.1
- MD5 128 Digest::Perl::MD5 v1.5 1.0
- CRC-CCITT 16 Digest::CRC v0.05 0.8
-
-These numbers was achieved Apr 2004 with ActivePerl-5.8.3 running
-under Linux on a P4 2.8 GHz CPU. The last 5 entries differ by being
-pure perl implementations of the algorithms, which explains why they
-are so slow.
-
-=head1 SEE ALSO
-
-L<Digest::Adler32>, L<Digest::CRC>, L<Digest::Haval256>,
-L<Digest::HMAC>, L<Digest::MD2>, L<Digest::MD4>, L<Digest::MD5>,
-L<Digest::SHA>, L<Digest::SHA1>, L<Digest::SHA2>, L<Digest::Whirlpool>
-
-New digest implementations should consider subclassing from L<Digest::base>.
-
-L<MIME::Base64>
-
-http://en.wikipedia.org/wiki/Cryptographic_hash_function
-
-=head1 AUTHOR
-
-Gisle Aas <gisle at aas.no>
-
-The C<Digest::> interface is based on the interface originally
-developed by Neil Winton for his C<MD5> module.
-
-This library is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
- Copyright 1998-2006 Gisle Aas.
- Copyright 1995,1996 Neil Winton.
-
-=cut
Deleted: trunk/contrib/perl/lib/Dumpvalue.pm
===================================================================
--- trunk/contrib/perl/lib/Dumpvalue.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Dumpvalue.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,648 +0,0 @@
-use 5.006_001; # for (defined ref) and $#$v and our
-package Dumpvalue;
-use strict;
-our $VERSION = '1.13';
-our(%address, $stab, @stab, %stab, %subs);
-
-# documentation nits, handle complex data structures better by chromatic
-# translate control chars to ^X - Randal Schwartz
-# Modifications to print types by Peter Gordon v1.0
-
-# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
-
-# Won't dump symbol tables and contents of debugged files by default
-
-# (IZ) changes for objectification:
-# c) quote() renamed to method set_quote();
-# d) unctrlSet() renamed to method set_unctrl();
-# f) Compiles with `use strict', but in two places no strict refs is needed:
-# maybe more problems are waiting...
-
-my %defaults = (
- globPrint => 0,
- printUndef => 1,
- tick => "auto",
- unctrl => 'quote',
- subdump => 1,
- dumpReused => 0,
- bareStringify => 1,
- hashDepth => '',
- arrayDepth => '',
- dumpDBFiles => '',
- dumpPackages => '',
- quoteHighBit => '',
- usageOnly => '',
- compactDump => '',
- veryCompact => '',
- stopDbSignal => '',
- );
-
-sub new {
- my $class = shift;
- my %opt = (%defaults, @_);
- bless \%opt, $class;
-}
-
-sub set {
- my $self = shift;
- my %opt = @_;
- @$self{keys %opt} = values %opt;
-}
-
-sub get {
- my $self = shift;
- wantarray ? @$self{@_} : $$self{pop @_};
-}
-
-sub dumpValue {
- my $self = shift;
- die "usage: \$dumper->dumpValue(value)" unless @_ == 1;
- local %address;
- local $^W=0;
- (print "undef\n"), return unless defined $_[0];
- (print $self->stringify($_[0]), "\n"), return unless ref $_[0];
- $self->unwrap($_[0],0);
-}
-
-sub dumpValues {
- my $self = shift;
- local %address;
- local $^W=0;
- (print "undef\n"), return unless defined $_[0];
- $self->unwrap(\@_,0);
-}
-
-# This one is good for variable names:
-
-sub unctrl {
- local($_) = @_;
-
- return \$_ if ref \$_ eq "GLOB";
- s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
- $_;
-}
-
-sub stringify {
- my $self = shift;
- local $_ = shift;
- my $noticks = shift;
- my $tick = $self->{tick};
-
- return 'undef' unless defined $_ or not $self->{printUndef};
- return $_ . "" if ref \$_ eq 'GLOB';
- { no strict 'refs';
- $_ = &{'overload::StrVal'}($_)
- if $self->{bareStringify} and ref $_
- and %overload:: and defined &{'overload::StrVal'};
- }
-
- if ($tick eq 'auto') {
- if (/[\000-\011\013-\037\177]/) {
- $tick = '"';
- } else {
- $tick = "'";
- }
- }
- if ($tick eq "'") {
- s/([\'\\])/\\$1/g;
- } elsif ($self->{unctrl} eq 'unctrl') {
- s/([\"\\])/\\$1/g ;
- s/([\000-\037\177])/'^'.pack('c',ord($1)^64)/eg;
- s/([\200-\377])/'\\0x'.sprintf('%2X',ord($1))/eg
- if $self->{quoteHighBit};
- } elsif ($self->{unctrl} eq 'quote') {
- s/([\"\\\$\@])/\\$1/g if $tick eq '"';
- s/\033/\\e/g;
- s/([\000-\037\177])/'\\c'.chr(ord($1)^64)/eg;
- }
- s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg if $self->{quoteHighBit};
- ($noticks || /^\d+(\.\d*)?\Z/)
- ? $_
- : $tick . $_ . $tick;
-}
-
-sub DumpElem {
- my ($self, $v) = (shift, shift);
- my $short = $self->stringify($v, ref $v);
- my $shortmore = '';
- if ($self->{veryCompact} && ref $v
- && (ref $v eq 'ARRAY' and !grep(ref $_, @$v) )) {
- my $depth = $#$v;
- ($shortmore, $depth) = (' ...', $self->{arrayDepth} - 1)
- if $self->{arrayDepth} and $depth >= $self->{arrayDepth};
- my @a = map $self->stringify($_), @$v[0..$depth];
- print "0..$#{$v} @a$shortmore\n";
- } elsif ($self->{veryCompact} && ref $v
- && (ref $v eq 'HASH') and !grep(ref $_, values %$v)) {
- my @a = sort keys %$v;
- my $depth = $#a;
- ($shortmore, $depth) = (' ...', $self->{hashDepth} - 1)
- if $self->{hashDepth} and $depth >= $self->{hashDepth};
- my @b = map {$self->stringify($_) . " => " . $self->stringify($$v{$_})}
- @a[0..$depth];
- local $" = ', ';
- print "@b$shortmore\n";
- } else {
- print "$short\n";
- $self->unwrap($v,shift);
- }
-}
-
-sub unwrap {
- my $self = shift;
- return if $DB::signal and $self->{stopDbSignal};
- my ($v) = shift ;
- my ($s) = shift ; # extra no of spaces
- my $sp;
- my (%v, at v,$address,$short,$fileno);
-
- $sp = " " x $s ;
- $s += 3 ;
-
- # Check for reused addresses
- if (ref $v) {
- my $val = $v;
- { no strict 'refs';
- $val = &{'overload::StrVal'}($v)
- if %overload:: and defined &{'overload::StrVal'};
- }
- ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
- if (!$self->{dumpReused} && defined $address) {
- $address{$address}++ ;
- if ( $address{$address} > 1 ) {
- print "${sp}-> REUSED_ADDRESS\n" ;
- return ;
- }
- }
- } elsif (ref \$v eq 'GLOB') {
- $address = "$v" . ""; # To avoid a bug with globs
- $address{$address}++ ;
- if ( $address{$address} > 1 ) {
- print "${sp}*DUMPED_GLOB*\n" ;
- return ;
- }
- }
-
- if (ref $v eq 'Regexp') {
- my $re = "$v";
- $re =~ s,/,\\/,g;
- print "$sp-> qr/$re/\n";
- return;
- }
-
- if ( UNIVERSAL::isa($v, 'HASH') ) {
- my @sortKeys = sort keys(%$v) ;
- my $more;
- my $tHashDepth = $#sortKeys ;
- $tHashDepth = $#sortKeys < $self->{hashDepth}-1 ? $#sortKeys : $self->{hashDepth}-1
- unless $self->{hashDepth} eq '' ;
- $more = "....\n" if $tHashDepth < $#sortKeys ;
- my $shortmore = "";
- $shortmore = ", ..." if $tHashDepth < $#sortKeys ;
- $#sortKeys = $tHashDepth ;
- if ($self->{compactDump} && !grep(ref $_, values %{$v})) {
- $short = $sp;
- my @keys;
- for (@sortKeys) {
- push @keys, $self->stringify($_) . " => " . $self->stringify($v->{$_});
- }
- $short .= join ', ', @keys;
- $short .= $shortmore;
- (print "$short\n"), return if length $short <= $self->{compactDump};
- }
- for my $key (@sortKeys) {
- return if $DB::signal and $self->{stopDbSignal};
- my $value = $ {$v}{$key} ;
- print $sp, $self->stringify($key), " => ";
- $self->DumpElem($value, $s);
- }
- print "$sp empty hash\n" unless @sortKeys;
- print "$sp$more" if defined $more ;
- } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
- my $tArrayDepth = $#{$v} ;
- my $more ;
- $tArrayDepth = $#$v < $self->{arrayDepth}-1 ? $#$v : $self->{arrayDepth}-1
- unless $self->{arrayDepth} eq '' ;
- $more = "....\n" if $tArrayDepth < $#{$v} ;
- my $shortmore = "";
- $shortmore = " ..." if $tArrayDepth < $#{$v} ;
- if ($self->{compactDump} && !grep(ref $_, @{$v})) {
- if ($#$v >= 0) {
- $short = $sp . "0..$#{$v} " .
- join(" ",
- map {exists $v->[$_] ? $self->stringify($v->[$_]) : "empty"} ($[..$tArrayDepth)
- ) . "$shortmore";
- } else {
- $short = $sp . "empty array";
- }
- (print "$short\n"), return if length $short <= $self->{compactDump};
- }
- for my $num ($[ .. $tArrayDepth) {
- return if $DB::signal and $self->{stopDbSignal};
- print "$sp$num ";
- if (exists $v->[$num]) {
- $self->DumpElem($v->[$num], $s);
- } else {
- print "empty slot\n";
- }
- }
- print "$sp empty array\n" unless @$v;
- print "$sp$more" if defined $more ;
- } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
- print "$sp-> ";
- $self->DumpElem($$v, $s);
- } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
- print "$sp-> ";
- $self->dumpsub(0, $v);
- } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
- print "$sp-> ",$self->stringify($$v,1),"\n";
- if ($self->{globPrint}) {
- $s += 3;
- $self->dumpglob('', $s, "{$$v}", $$v, 1);
- } elsif (defined ($fileno = fileno($v))) {
- print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
- }
- } elsif (ref \$v eq 'GLOB') {
- if ($self->{globPrint}) {
- $self->dumpglob('', $s, "{$v}", $v, 1);
- } elsif (defined ($fileno = fileno(\$v))) {
- print( (' ' x $s) . "FileHandle({$v}) => fileno($fileno)\n" );
- }
- }
-}
-
-sub matchvar {
- $_[0] eq $_[1] or
- ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
- ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
-}
-
-sub compactDump {
- my $self = shift;
- $self->{compactDump} = shift if @_;
- $self->{compactDump} = 6*80-1
- if $self->{compactDump} and $self->{compactDump} < 2;
- $self->{compactDump};
-}
-
-sub veryCompact {
- my $self = shift;
- $self->{veryCompact} = shift if @_;
- $self->compactDump(1) if !$self->{compactDump} and $self->{veryCompact};
- $self->{veryCompact};
-}
-
-sub set_unctrl {
- my $self = shift;
- if (@_) {
- my $in = shift;
- if ($in eq 'unctrl' or $in eq 'quote') {
- $self->{unctrl} = $in;
- } else {
- print "Unknown value for `unctrl'.\n";
- }
- }
- $self->{unctrl};
-}
-
-sub set_quote {
- my $self = shift;
- if (@_ and $_[0] eq '"') {
- $self->{tick} = '"';
- $self->{unctrl} = 'quote';
- } elsif (@_ and $_[0] eq 'auto') {
- $self->{tick} = 'auto';
- $self->{unctrl} = 'quote';
- } elsif (@_) { # Need to set
- $self->{tick} = "'";
- $self->{unctrl} = 'unctrl';
- }
- $self->{tick};
-}
-
-sub dumpglob {
- my $self = shift;
- return if $DB::signal and $self->{stopDbSignal};
- my ($package, $off, $key, $val, $all) = @_;
- local(*stab) = $val;
- my $fileno;
- if (($key !~ /^_</ or $self->{dumpDBFiles}) and defined $stab) {
- print( (' ' x $off) . "\$", &unctrl($key), " = " );
- $self->DumpElem($stab, 3+$off);
- }
- if (($key !~ /^_</ or $self->{dumpDBFiles}) and @stab) {
- print( (' ' x $off) . "\@$key = (\n" );
- $self->unwrap(\@stab,3+$off) ;
- print( (' ' x $off) . ")\n" );
- }
- if ($key ne "main::" && $key ne "DB::" && %stab
- && ($self->{dumpPackages} or $key !~ /::$/)
- && ($key !~ /^_</ or $self->{dumpDBFiles})
- && !($package eq "Dumpvalue" and $key eq "stab")) {
- print( (' ' x $off) . "\%$key = (\n" );
- $self->unwrap(\%stab,3+$off) ;
- print( (' ' x $off) . ")\n" );
- }
- if (defined ($fileno = fileno(*stab))) {
- print( (' ' x $off) . "FileHandle($key) => fileno($fileno)\n" );
- }
- if ($all) {
- if (defined &stab) {
- $self->dumpsub($off, $key);
- }
- }
-}
-
-sub CvGV_name {
- my $self = shift;
- my $in = shift;
- return if $self->{skipCvGV}; # Backdoor to avoid problems if XS broken...
- $in = \&$in; # Hard reference...
- eval {require Devel::Peek; 1} or return;
- my $gv = Devel::Peek::CvGV($in) or return;
- *$gv{PACKAGE} . '::' . *$gv{NAME};
-}
-
-sub dumpsub {
- my $self = shift;
- my ($off,$sub) = @_;
- my $ini = $sub;
- my $s;
- $sub = $1 if $sub =~ /^\{\*(.*)\}$/;
- my $subref = defined $1 ? \&$sub : \&$ini;
- my $place = $DB::sub{$sub} || (($s = $subs{"$subref"}) && $DB::sub{$s})
- || (($s = $self->CvGV_name($subref)) && $DB::sub{$s})
- || ($self->{subdump} && ($s = $self->findsubs("$subref"))
- && $DB::sub{$s});
- $s = $sub unless defined $s;
- $place = '???' unless defined $place;
- print( (' ' x $off) . "&$s in $place\n" );
-}
-
-sub findsubs {
- my $self = shift;
- return undef unless %DB::sub;
- my ($addr, $name, $loc);
- while (($name, $loc) = each %DB::sub) {
- $addr = \&$name;
- $subs{"$addr"} = $name;
- }
- $self->{subdump} = 0;
- $subs{ shift() };
-}
-
-sub dumpvars {
- my $self = shift;
- my ($package, at vars) = @_;
- local(%address,$^W);
- my ($key,$val);
- $package .= "::" unless $package =~ /::$/;
- *stab = *main::;
-
- while ($package =~ /(\w+?::)/g) {
- *stab = $ {stab}{$1};
- }
- $self->{TotalStrings} = 0;
- $self->{Strings} = 0;
- $self->{CompleteTotal} = 0;
- while (($key,$val) = each(%stab)) {
- return if $DB::signal and $self->{stopDbSignal};
- next if @vars && !grep( matchvar($key, $_), @vars );
- if ($self->{usageOnly}) {
- $self->globUsage(\$val, $key)
- if ($package ne 'Dumpvalue' or $key ne 'stab')
- and ref(\$val) eq 'GLOB';
- } else {
- $self->dumpglob($package, 0,$key, $val);
- }
- }
- if ($self->{usageOnly}) {
- print <<EOP;
-String space: $self->{TotalStrings} bytes in $self->{Strings} strings.
-EOP
- $self->{CompleteTotal} += $self->{TotalStrings};
- print <<EOP;
-Grand total = $self->{CompleteTotal} bytes (1 level deep) + overhead.
-EOP
- }
-}
-
-sub scalarUsage {
- my $self = shift;
- my $size;
- if (UNIVERSAL::isa($_[0], 'ARRAY')) {
- $size = $self->arrayUsage($_[0]);
- } elsif (UNIVERSAL::isa($_[0], 'HASH')) {
- $size = $self->hashUsage($_[0]);
- } elsif (!ref($_[0])) {
- $size = length($_[0]);
- }
- $self->{TotalStrings} += $size;
- $self->{Strings}++;
- $size;
-}
-
-sub arrayUsage { # array ref, name
- my $self = shift;
- my $size = 0;
- map {$size += $self->scalarUsage($_)} @{$_[0]};
- my $len = @{$_[0]};
- print "\@$_[1] = $len item", ($len > 1 ? "s" : ""), " (data: $size bytes)\n"
- if defined $_[1];
- $self->{CompleteTotal} += $size;
- $size;
-}
-
-sub hashUsage { # hash ref, name
- my $self = shift;
- my @keys = keys %{$_[0]};
- my @values = values %{$_[0]};
- my $keys = $self->arrayUsage(\@keys);
- my $values = $self->arrayUsage(\@values);
- my $len = @keys;
- my $total = $keys + $values;
- print "\%$_[1] = $len item", ($len > 1 ? "s" : ""),
- " (keys: $keys; values: $values; total: $total bytes)\n"
- if defined $_[1];
- $total;
-}
-
-sub globUsage { # glob ref, name
- my $self = shift;
- local *stab = *{$_[0]};
- my $total = 0;
- $total += $self->scalarUsage($stab) if defined $stab;
- $total += $self->arrayUsage(\@stab, $_[1]) if @stab;
- $total += $self->hashUsage(\%stab, $_[1])
- if %stab and $_[1] ne "main::" and $_[1] ne "DB::";
- #and !($package eq "Dumpvalue" and $key eq "stab"));
- $total;
-}
-
-1;
-
-=head1 NAME
-
-Dumpvalue - provides screen dump of Perl data.
-
-=head1 SYNOPSIS
-
- use Dumpvalue;
- my $dumper = Dumpvalue->new;
- $dumper->set(globPrint => 1);
- $dumper->dumpValue(\*::);
- $dumper->dumpvars('main');
- my $dump = $dumper->stringify($some_value);
-
-=head1 DESCRIPTION
-
-=head2 Creation
-
-A new dumper is created by a call
-
- $d = Dumpvalue->new(option1 => value1, option2 => value2)
-
-Recognized options:
-
-=over 4
-
-=item C<arrayDepth>, C<hashDepth>
-
-Print only first N elements of arrays and hashes. If false, prints all the
-elements.
-
-=item C<compactDump>, C<veryCompact>
-
-Change style of array and hash dump. If true, short array
-may be printed on one line.
-
-=item C<globPrint>
-
-Whether to print contents of globs.
-
-=item C<dumpDBFiles>
-
-Dump arrays holding contents of debugged files.
-
-=item C<dumpPackages>
-
-Dump symbol tables of packages.
-
-=item C<dumpReused>
-
-Dump contents of "reused" addresses.
-
-=item C<tick>, C<quoteHighBit>, C<printUndef>
-
-Change style of string dump. Default value of C<tick> is C<auto>, one
-can enable either double-quotish dump, or single-quotish by setting it
-to C<"> or C<'>. By default, characters with high bit set are printed
-I<as is>. If C<quoteHighBit> is set, they will be quoted.
-
-=item C<usageOnly>
-
-rudimentally per-package memory usage dump. If set,
-C<dumpvars> calculates total size of strings in variables in the package.
-
-=item unctrl
-
-Changes the style of printout of strings. Possible values are
-C<unctrl> and C<quote>.
-
-=item subdump
-
-Whether to try to find the subroutine name given the reference.
-
-=item bareStringify
-
-Whether to write the non-overloaded form of the stringify-overloaded objects.
-
-=item quoteHighBit
-
-Whether to print chars with high bit set in binary or "as is".
-
-=item stopDbSignal
-
-Whether to abort printing if debugger signal flag is raised.
-
-=back
-
-Later in the life of the object the methods may be queries with get()
-method and set() method (which accept multiple arguments).
-
-=head2 Methods
-
-=over 4
-
-=item dumpValue
-
- $dumper->dumpValue($value);
- $dumper->dumpValue([$value1, $value2]);
-
-Prints a dump to the currently selected filehandle.
-
-=item dumpValues
-
- $dumper->dumpValues($value1, $value2);
-
-Same as C< $dumper->dumpValue([$value1, $value2]); >.
-
-=item stringify
-
- my $dump = $dumper->stringify($value [,$noticks] );
-
-Returns the dump of a single scalar without printing. If the second
-argument is true, the return value does not contain enclosing ticks.
-Does not handle data structures.
-
-=item dumpvars
-
- $dumper->dumpvars('my_package');
- $dumper->dumpvars('my_package', 'foo', '~bar$', '!......');
-
-The optional arguments are considered as literal strings unless they
-start with C<~> or C<!>, in which case they are interpreted as regular
-expressions (possibly negated).
-
-The second example prints entries with names C<foo>, and also entries
-with names which ends on C<bar>, or are shorter than 5 chars.
-
-=item set_quote
-
- $d->set_quote('"');
-
-Sets C<tick> and C<unctrl> options to suitable values for printout with the
-given quote char. Possible values are C<auto>, C<'> and C<">.
-
-=item set_unctrl
-
- $d->set_unctrl('unctrl');
-
-Sets C<unctrl> option with checking for an invalid argument.
-Possible values are C<unctrl> and C<quote>.
-
-=item compactDump
-
- $d->compactDump(1);
-
-Sets C<compactDump> option. If the value is 1, sets to a reasonable
-big number.
-
-=item veryCompact
-
- $d->veryCompact(1);
-
-Sets C<compactDump> and C<veryCompact> options simultaneously.
-
-=item set
-
- $d->set(option1 => value1, option2 => value2);
-
-=item get
-
- @values = $d->get('option1', 'option2');
-
-=back
-
-=cut
-
Deleted: trunk/contrib/perl/lib/Dumpvalue.t
===================================================================
--- trunk/contrib/perl/lib/Dumpvalue.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Dumpvalue.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,295 +0,0 @@
-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- if (ord('A') == 193) {
- print "1..0 # skip: EBCDIC\n";
- exit 0;
- }
- require Config;
- if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
- print "1..0 # Skip -- Perl configured without List::Util module\n";
- exit 0;
- }
-}
-
-use vars qw( $foo @bar %baz );
-
-use Test::More tests => 88;
-
-use_ok( 'Dumpvalue' );
-
-my $d;
-ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' );
-
-$d->set( globPrint => 1, dumpReused => 1 );
-is( $d->{globPrint}, 1, 'set an option correctly' );
-is( $d->get('globPrint'), 1, 'get an option correctly' );
-is( $d->get('globPrint', 'dumpReused'), qw( 1 1 ), 'get multiple options' );
-
-# check to see if unctrl works
-is( ref( Dumpvalue::unctrl(*FOO) ), 'GLOB', 'unctrl should not modify GLOB' );
-is( Dumpvalue::unctrl('donotchange'), 'donotchange', "unctrl shouldn't modify");
-like( Dumpvalue::unctrl("bo\007nd"), qr/bo\^.nd/, 'unctrl should escape' );
-
-# check to see if stringify works
-is( $d->stringify(), 'undef', 'stringify handles undef okay' );
-
-# the default is 1, but we want two single quotes
-$d->{printUndef} = 0;
-is( $d->stringify(), "''", 'stringify skips undef when asked nicely' );
-
-is( $d->stringify(*FOO), *FOO . "", 'stringify stringifies globs alright' );
-
-# check for double-quotes if there's an unprintable character
-$d->{tick} = 'auto';
-like( $d->stringify("hi\005"), qr/^"hi/, 'added double-quotes when necessary' );
-
-# if no unprintable character, escape ticks or backslashes
-is( $d->stringify('hi'), "'hi'", 'used single-quotes when appropriate' );
-
-# if 'unctrl' is set
-$d->{unctrl} = 'unctrl';
-like( $d->stringify('double and whack:\ "'), qr!\\ \"!, 'escaped with unctrl' );
-like( $d->stringify("a\005"), qr/^"a\^/, 'escaped ASCII value in unctrl' );
-like( $d->stringify("b\205"), qr!^'b.'$!, 'no high-bit escape value in unctrl');
-
-$d->{quoteHighBit} = 1;
-like( $d->stringify("b\205"), qr!^'b\\205!, 'high-bit now escaped in unctrl');
-
-# if 'quote' is set
-$d->{unctrl} = 'quote';
-is( $d->stringify('5@ $1'), "'5\@ \$1'", 'quoted $ and @ fine' );
-is( $d->stringify("5@\033\$1"), '"5\@\e\$1"', 'quoted $ and @ and \033 fine' );
-like( $d->stringify("\037"), qr/^"\\c/, 'escaped ASCII value okay' );
-
-# add ticks, if necessary
-is( $d->stringify("no ticks", 1), 'no ticks', 'avoid ticks if asked' );
-
-my $out = tie *OUT, 'TieOut';
-select(OUT);
-
-# test DumpElem, it does its magic with veryCompact set
-$d->{veryCompact} = 1;
-$d->DumpElem([1, 2, 3]);
-is( $out->read, "0..2 1 2 3\n", 'DumpElem worked on array ref');
-$d->DumpElem({ one => 1, two => 2 });
-is( $out->read, "'one' => 1, 'two' => 2\n", 'DumpElem worked on hash ref' );
-$d->DumpElem('hi');
-is( $out->read, "'hi'\n", 'DumpElem worked on simple scalar' );
-$d->{veryCompact} = 0;
-$d->DumpElem([]);
-like( $out->read, qr/ARRAY/, 'DumpElem okay with reference and no veryCompact');
-
-# should compact simple arrays just fine
-$d->{veryCompact} = 1;
-$d->DumpElem([1, 2, 3]);
-is( $out->read, "0..2 1 2 3\n", 'dumped array fine' );
-$d->{arrayDepth} = 2;
-$d->DumpElem([1, 2, 3]);
-is( $out->read, "0..2 1 2 ...\n", 'dumped limited array fine' );
-
-# should compact simple hashes just fine
-$d->DumpElem({ a => 1, b => 2, c => 3 });
-is( $out->read, "'a' => 1, 'b' => 2, 'c' => 3\n", 'dumped hash fine' );
-$d->{hashDepth} = 2;
-$d->DumpElem({ a => 1, b => 2, c => 3 });
-is( $out->read, "'a' => 1, 'b' => 2 ...\n", 'dumped limited hash fine' );
-
-# should just stringify what it is
-$d->{veryCompact} = 0;
-$d->DumpElem([]);
-like( $out->read, qr/ARRAY.+empty array/s, 'stringified empty array ref' );
-$d->DumpElem({});
-like( $out->read, qr/HASH.+empty hash/s, 'stringified empty hash ref' );
-$d->DumpElem(1);
-is( $out->read, "1\n", 'stringified simple scalar' );
-
-# test unwrap
-$DB::signal = $d->{stopDbSignal} = 1;
-is( $d->unwrap(), undef, 'unwrap returns if DB signal is set' );
-undef $DB::signal;
-
-my $foo = 7;
-$d->{dumpReused} = 0;
-$d->unwrap(\$foo);
-is( $out->read, "-> 7\n", 'unwrap worked on scalar' );
-$d->unwrap(\$foo);
-is( $out->read, "-> REUSED_ADDRESS\n", 'unwrap worked on scalar' );
-$d->unwrap({ one => 1 });
-
-# leaving this at zero may cause some subsequent tests to fail
-# if they reuse an address creating an anonymous variable
-$d->{dumpReused} = 1;
-is( $out->read, "'one' => 1\n", 'unwrap worked on hash' );
-$d->unwrap([ 2, 3 ]);
-is( $out->read, "0 2\n1 3\n", 'unwrap worked on array' );
-$d->unwrap(*FOO);
-is( $out->read, '', 'unwrap ignored glob on first try');
-$d->unwrap(*FOO);
-is( $out->read, "*DUMPED_GLOB*\n", 'unwrap worked on glob');
-$d->unwrap(qr/foo(.+)/);
-is( $out->read, "-> qr/(?-xism:foo(.+))/\n", 'unwrap worked on Regexp' );
-$d->unwrap( sub {} );
-like( $out->read, qr/^-> &CODE/, 'unwrap worked on sub ref' );
-
-# test matchvar
-# test to see if first arg 'eq' second
-ok( Dumpvalue::matchvar(1, 1), 'matchvar matched numbers fine' );
-ok( Dumpvalue::matchvar('hi', 'hi'), 'matchvar matched strings fine' );
-ok( !Dumpvalue::matchvar('hello', 1), 'matchvar caught failed match fine' );
-
-# test compactDump, which doesn't do much
-is( $d->compactDump(3), 3, 'set compactDump to 3' );
-is( $d->compactDump(1), 479, 'compactDump reset to 6*80-1 when less than 2' );
-
-# test veryCompact, which does slightly more, setting compactDump sometimes
-$d->{compactDump} = 0;
-is( $d->veryCompact(1), 1, 'set veryCompact successfully' );
-ok( $d->compactDump(), 'and it set compactDump as well' );
-
-# test set_unctrl
-$d->set_unctrl('impossible value');
-like( $out->read, qr/^Unknown value/, 'set_unctrl caught bad value' );
-is( $d->set_unctrl('quote'), 'quote', 'set quote fine' );
-is( $d->set_unctrl(), 'quote', 'retrieved quote fine' );
-
-# test set_quote
-$d->set_quote('"');
-is( $d->{tick}, '"', 'set_quote set tick right' );
-is( $d->{unctrl}, 'quote', 'set unctrl right too' );
-$d->set_quote('auto');
-is( $d->{tick}, 'auto', 'set_quote set auto right' );
-$d->set_quote('foo');
-is( $d->{tick}, "'", 'default value set to " correctly' );
-
-# test dumpglob
-# should do nothing if debugger signal flag is raised
-$d->{stopDbSignal} = $DB::signal = 1;
-is( $d->dumpglob(*DB::signal), undef, 'returned early with DB signal set' );
-undef $DB::signal;
-
-# test dumping "normal" variables, this is a nasty glob trick
-$foo = 1;
-$d->dumpglob( '', 2, 'foo', local *foo = \$foo );
-is( $out->read, " \$foo = 1\n", 'dumped glob for $foo correctly' );
- at bar = (1, 2);
-
-# the key name is a little different here
-$d->dumpglob( '', 0, 'boo', *bar );
-is( $out->read, "\@boo = (\n 0..1 1 2\n)\n", 'dumped glob for @bar fine' );
-
-%baz = ( one => 1, two => 2 );
-$d->dumpglob( '', 0, 'baz', *baz );
-is( $out->read, "\%baz = (\n 'one' => 1, 'two' => 2\n)\n",
- 'dumped glob for %baz fine' );
-
-SKIP: {
- skip( "Couldn't open $0 for reading", 1 ) unless open(FILE, $0);
- my $fileno = fileno(FILE);
- $d->dumpglob( '', 0, 'FILE', *FILE );
- is( $out->read, "FileHandle(FILE) => fileno($fileno)\n",
- 'dumped filehandle from glob fine' );
-}
-
-$d->dumpglob( '', 0, 'read', *TieOut::read );
-is( $out->read, '', 'no sub dumped without $all set' );
-$d->dumpglob( '', 0, 'read', \&TieOut::read, 1 );
-is( $out->read, "&read in ???\n", 'sub dumped when requested' );
-
-# see if it dumps DB-like values correctly
-$d->{dumpDBFiles} = 1;
-$d->dumpglob( '', 0, '_<foo', *foo );
-is( $out->read, "\$_<foo = 1\n", 'dumped glob for $_<foo correctly (DB)' );
-
-# test CvGV name
-SKIP: {
- if (" $Config::Config{'extensions'} " !~ m[ Devel/Peek ]) {
- skip( 'no Devel::Peek', 2 );
- }
- use_ok( 'Devel::Peek' );
- is( $d->CvGV_name(\&TieOut::read), 'TieOut::read', 'CvGV_name found sub' );
-}
-
-# test dumpsub
-$d->dumpsub( '', 'TieOut::read' );
-like( $out->read, qr/&TieOut::read in/, 'dumpsub found sub fine' );
-
-# test findsubs
-is( $d->findsubs(), undef, 'findsubs returns nothing without %DB::sub' );
-$DB::sub{'TieOut::read'} = 'TieOut';
-is( $d->findsubs( \&TieOut::read ), 'TieOut::read', 'findsubs reported sub' );
-
-# now that it's capable of finding the package...
-$d->dumpsub( '', 'TieOut::read' );
-is( $out->read, "&TieOut::read in TieOut\n", 'dumpsub found sub fine again' );
-
-# this should print just a usage message
-$d->{usageOnly} = 1;
-$d->dumpvars( 'Fake', 'veryfake' );
-like( $out->read, qr/^String space:/, 'printed usage message fine' );
-delete $d->{usageOnly};
-
-# this should report @INC and %INC
-$d->dumpvars( 'main', 'INC' );
-like( $out->read, qr/\@INC =/, 'dumped variables from a package' );
-
-# this should report nothing
-$DB::signal = 1;
-$d->dumpvars( 'main', 'INC' );
-is( $out->read, '', 'no dump when $DB::signal is set' );
-undef $DB::signal;
-
-is( $d->scalarUsage('12345'), 5, 'scalarUsage reports length correctly' );
-is( $d->arrayUsage( [1, 2, 3], 'a' ), 3, 'arrayUsage reports correct lengths' );
-is( $out->read, "\@a = 3 items (data: 3 bytes)\n", 'arrayUsage message okay' );
-is( $d->hashUsage({ one => 1 }, 'b'), 4, 'hashUsage reports correct lengths' );
-is( $out->read, "\%b = 1 item (keys: 3; values: 1; total: 4 bytes)\n",
- 'hashUsage message okay' );
-is( $d->hashUsage({ one => [ 1, 2, 3 ]}, 'c'), 6, 'complex hash okay' );
-is( $out->read, "\%c = 1 item (keys: 3; values: 3; total: 6 bytes)\n",
- 'hashUsage complex message okay' );
-
-$foo = 'one';
- at foo = ('two');
-%foo = ( three => '123' );
-is( $d->globUsage(\*foo, 'foo'), 14, 'globUsage reports length correctly' );
-like( $out->read, qr/\@foo =.+\%foo =/s, 'globValue message okay' );
-
-# and now, the real show
-$d->dumpValue(undef);
-is( $out->read, "undef\n", 'dumpValue caught undef value okay' );
-$d->dumpValue($foo);
-is( $out->read, "'one'\n", 'dumpValue worked' );
-$d->dumpValue(@foo);
-is( $out->read, "'two'\n", 'dumpValue worked on array' );
-$d->dumpValue(\$foo);
-is( $out->read, "-> 'one'\n", 'dumpValue worked on scalar ref' );
-
-# dumpValues (the rest of these should be caught by unwrap)
-$d->dumpValues(undef);
-is( $out->read, "undef\n", 'dumpValues caught undef value fine' );
-$d->dumpValues(\@foo);
-is( $out->read, "0 0..0 'two'\n", 'dumpValues worked on array ref' );
-$d->dumpValues('one', 'two');
-is( $out->read, "0..1 'one' 'two'\n", 'dumpValues worked on multiple values' );
-
-
-package TieOut;
-use overload '"' => sub { "overloaded!" };
-
-sub TIEHANDLE {
- my $class = shift;
- bless(\( my $ref), $class);
-}
-
-sub PRINT {
- my $self = shift;
- $$self .= join('', @_);
-}
-
-sub read {
- my $self = shift;
- return substr($$self, 0, length($$self), '');
-}
Deleted: trunk/contrib/perl/lib/Env.pm
===================================================================
--- trunk/contrib/perl/lib/Env.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Env.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,235 +0,0 @@
-package Env;
-
-our $VERSION = '1.00';
-
-=head1 NAME
-
-Env - perl module that imports environment variables as scalars or arrays
-
-=head1 SYNOPSIS
-
- use Env;
- use Env qw(PATH HOME TERM);
- use Env qw($SHELL @LD_LIBRARY_PATH);
-
-=head1 DESCRIPTION
-
-Perl maintains environment variables in a special hash named C<%ENV>. For
-when this access method is inconvenient, the Perl module C<Env> allows
-environment variables to be treated as scalar or array variables.
-
-The C<Env::import()> function ties environment variables with suitable
-names to global Perl variables with the same names. By default it
-ties all existing environment variables (C<keys %ENV>) to scalars. If
-the C<import> function receives arguments, it takes them to be a list of
-variables to tie; it's okay if they don't yet exist. The scalar type
-prefix '$' is inferred for any element of this list not prefixed by '$'
-or '@'. Arrays are implemented in terms of C<split> and C<join>, using
-C<$Config::Config{path_sep}> as the delimiter.
-
-After an environment variable is tied, merely use it like a normal variable.
-You may access its value
-
- @path = split(/:/, $PATH);
- print join("\n", @LD_LIBRARY_PATH), "\n";
-
-or modify it
-
- $PATH .= ":.";
- push @LD_LIBRARY_PATH, $dir;
-
-however you'd like. Bear in mind, however, that each access to a tied array
-variable requires splitting the environment variable's string anew.
-
-The code:
-
- use Env qw(@PATH);
- push @PATH, '.';
-
-is equivalent to:
-
- use Env qw(PATH);
- $PATH .= ":.";
-
-except that if C<$ENV{PATH}> started out empty, the second approach leaves
-it with the (odd) value "C<:.>", but the first approach leaves it with "C<.>".
-
-To remove a tied environment variable from
-the environment, assign it the undefined value
-
- undef $PATH;
- undef @LD_LIBRARY_PATH;
-
-=head1 LIMITATIONS
-
-On VMS systems, arrays tied to environment variables are read-only. Attempting
-to change anything will cause a warning.
-
-=head1 AUTHOR
-
-Chip Salzenberg E<lt>F<chip at fin.uucp>E<gt>
-and
-Gregor N. Purdy E<lt>F<gregor at focusresearch.com>E<gt>
-
-=cut
-
-sub import {
- my ($callpack) = caller(0);
- my $pack = shift;
- my @vars = grep /^[\$\@]?[A-Za-z_]\w*$/, (@_ ? @_ : keys(%ENV));
- return unless @vars;
-
- @vars = map { m/^[\$\@]/ ? $_ : '$'.$_ } @vars;
-
- eval "package $callpack; use vars qw(" . join(' ', @vars) . ")";
- die $@ if $@;
- foreach (@vars) {
- my ($type, $name) = m/^([\$\@])(.*)$/;
- if ($type eq '$') {
- tie ${"${callpack}::$name"}, Env, $name;
- } else {
- if ($^O eq 'VMS') {
- tie @{"${callpack}::$name"}, Env::Array::VMS, $name;
- } else {
- tie @{"${callpack}::$name"}, Env::Array, $name;
- }
- }
- }
-}
-
-sub TIESCALAR {
- bless \($_[1]);
-}
-
-sub FETCH {
- my ($self) = @_;
- $ENV{$$self};
-}
-
-sub STORE {
- my ($self, $value) = @_;
- if (defined($value)) {
- $ENV{$$self} = $value;
- } else {
- delete $ENV{$$self};
- }
-}
-
-######################################################################
-
-package Env::Array;
-
-use Config;
-use Tie::Array;
-
- at ISA = qw(Tie::Array);
-
-my $sep = $Config::Config{path_sep};
-
-sub TIEARRAY {
- bless \($_[1]);
-}
-
-sub FETCHSIZE {
- my ($self) = @_;
- my @temp = split($sep, $ENV{$$self});
- return scalar(@temp);
-}
-
-sub STORESIZE {
- my ($self, $size) = @_;
- my @temp = split($sep, $ENV{$$self});
- $#temp = $size - 1;
- $ENV{$$self} = join($sep, @temp);
-}
-
-sub CLEAR {
- my ($self) = @_;
- $ENV{$$self} = '';
-}
-
-sub FETCH {
- my ($self, $index) = @_;
- return (split($sep, $ENV{$$self}))[$index];
-}
-
-sub STORE {
- my ($self, $index, $value) = @_;
- my @temp = split($sep, $ENV{$$self});
- $temp[$index] = $value;
- $ENV{$$self} = join($sep, @temp);
- return $value;
-}
-
-sub PUSH {
- my $self = shift;
- my @temp = split($sep, $ENV{$$self});
- push @temp, @_;
- $ENV{$$self} = join($sep, @temp);
- return scalar(@temp);
-}
-
-sub POP {
- my ($self) = @_;
- my @temp = split($sep, $ENV{$$self});
- my $result = pop @temp;
- $ENV{$$self} = join($sep, @temp);
- return $result;
-}
-
-sub UNSHIFT {
- my $self = shift;
- my @temp = split($sep, $ENV{$$self});
- my $result = unshift @temp, @_;
- $ENV{$$self} = join($sep, @temp);
- return $result;
-}
-
-sub SHIFT {
- my ($self) = @_;
- my @temp = split($sep, $ENV{$$self});
- my $result = shift @temp;
- $ENV{$$self} = join($sep, @temp);
- return $result;
-}
-
-sub SPLICE {
- my $self = shift;
- my $offset = shift;
- my $length = shift;
- my @temp = split($sep, $ENV{$$self});
- if (wantarray) {
- my @result = splice @temp, $self, $offset, $length, @_;
- $ENV{$$self} = join($sep, @temp);
- return @result;
- } else {
- my $result = scalar splice @temp, $offset, $length, @_;
- $ENV{$$self} = join($sep, @temp);
- return $result;
- }
-}
-
-######################################################################
-
-package Env::Array::VMS;
-use Tie::Array;
-
- at ISA = qw(Tie::Array);
-
-sub TIEARRAY {
- bless \($_[1]);
-}
-
-sub FETCHSIZE {
- my ($self) = @_;
- my $i = 0;
- while ($i < 127 and defined $ENV{$$self . ';' . $i}) { $i++; };
- return $i;
-}
-
-sub FETCH {
- my ($self, $index) = @_;
- return $ENV{$$self . ';' . $index};
-}
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/CBuilder.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/CBuilder.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/CBuilder.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,322 +0,0 @@
-package ExtUtils::CBuilder;
-
-use File::Spec ();
-use File::Path ();
-use File::Basename ();
-
-use vars qw($VERSION @ISA);
-$VERSION = '0.2602';
-$VERSION = eval $VERSION;
-
-# Okay, this is the brute-force method of finding out what kind of
-# platform we're on. I don't know of a systematic way. These values
-# came from the latest (bleadperl) perlport.pod.
-
-my %OSTYPES = qw(
- aix Unix
- bsdos Unix
- dgux Unix
- dynixptx Unix
- freebsd Unix
- linux Unix
- hpux Unix
- irix Unix
- darwin Unix
- machten Unix
- next Unix
- openbsd Unix
- netbsd Unix
- dec_osf Unix
- svr4 Unix
- svr5 Unix
- sco_sv Unix
- unicos Unix
- unicosmk Unix
- solaris Unix
- sunos Unix
- cygwin Unix
- os2 Unix
- gnu Unix
- gnukfreebsd Unix
- haiku Unix
-
- dos Windows
- MSWin32 Windows
-
- os390 EBCDIC
- os400 EBCDIC
- posix-bc EBCDIC
- vmesa EBCDIC
-
- MacOS MacOS
- VMS VMS
- VOS VOS
- riscos RiscOS
- amigaos Amiga
- mpeix MPEiX
- );
-
-# We only use this once - don't waste a symbol table entry on it.
-# More importantly, don't make it an inheritable method.
-my $load = sub {
- my $mod = shift;
- eval "use $mod";
- die $@ if $@;
- @ISA = ($mod);
-};
-
-{
- my @package = split /::/, __PACKAGE__;
-
- if (grep {-e File::Spec->catfile($_, @package, 'Platform', $^O) . '.pm'} @INC) {
- $load->(__PACKAGE__ . "::Platform::$^O");
-
- } elsif (exists $OSTYPES{$^O} and
- grep {-e File::Spec->catfile($_, @package, 'Platform', $OSTYPES{$^O}) . '.pm'} @INC) {
- $load->(__PACKAGE__ . "::Platform::$OSTYPES{$^O}");
-
- } else {
- $load->(__PACKAGE__ . "::Base");
- }
-}
-
-sub os_type { $OSTYPES{$^O} }
-
-1;
-__END__
-
-=head1 NAME
-
-ExtUtils::CBuilder - Compile and link C code for Perl modules
-
-=head1 SYNOPSIS
-
- use ExtUtils::CBuilder;
-
- my $b = ExtUtils::CBuilder->new(%options);
- $obj_file = $b->compile(source => 'MyModule.c');
- $lib_file = $b->link(objects => $obj_file);
-
-=head1 DESCRIPTION
-
-This module can build the C portions of Perl modules by invoking the
-appropriate compilers and linkers in a cross-platform manner. It was
-motivated by the C<Module::Build> project, but may be useful for other
-purposes as well. However, it is I<not> intended as a general
-cross-platform interface to all your C building needs. That would
-have been a much more ambitious goal!
-
-=head1 METHODS
-
-=over 4
-
-=item new
-
-Returns a new C<ExtUtils::CBuilder> object. A C<config> parameter
-lets you override C<Config.pm> settings for all operations performed
-by the object, as in the following example:
-
- # Use a different compiler than Config.pm says
- my $b = ExtUtils::CBuilder->new( config =>
- { ld => 'gcc' } );
-
-A C<quiet> parameter tells C<CBuilder> to not print its C<system()>
-commands before executing them:
-
- # Be quieter than normal
- my $b = ExtUtils::CBuilder->new( quiet => 1 );
-
-=item have_compiler
-
-Returns true if the current system has a working C compiler and
-linker, false otherwise. To determine this, we actually compile and
-link a sample C library. The sample will be compiled in the system
-tempdir or, if that fails for some reason, in the current directory.
-
-=item compile
-
-Compiles a C source file and produces an object file. The name of the
-object file is returned. The source file is specified in a C<source>
-parameter, which is required; the other parameters listed below are
-optional.
-
-=over 4
-
-=item C<object_file>
-
-Specifies the name of the output file to create. Otherwise the
-C<object_file()> method will be consulted, passing it the name of the
-C<source> file.
-
-=item C<include_dirs>
-
-Specifies any additional directories in which to search for header
-files. May be given as a string indicating a single directory, or as
-a list reference indicating multiple directories.
-
-=item C<extra_compiler_flags>
-
-Specifies any additional arguments to pass to the compiler. Should be
-given as a list reference containing the arguments individually, or if
-this is not possible, as a string containing all the arguments
-together.
-
-=back
-
-The operation of this method is also affected by the
-C<archlibexp>, C<cccdlflags>, C<ccflags>, C<optimize>, and C<cc>
-entries in C<Config.pm>.
-
-=item link
-
-Invokes the linker to produce a library file from object files. In
-scalar context, the name of the library file is returned. In list
-context, the library file and any temporary files created are
-returned. A required C<objects> parameter contains the name of the
-object files to process, either in a string (for one object file) or
-list reference (for one or more files). The following parameters are
-optional:
-
-
-=over 4
-
-=item lib_file
-
-Specifies the name of the output library file to create. Otherwise
-the C<lib_file()> method will be consulted, passing it the name of
-the first entry in C<objects>.
-
-=item module_name
-
-Specifies the name of the Perl module that will be created by linking.
-On platforms that need to do prelinking (Win32, OS/2, etc.) this is a
-required parameter.
-
-=item extra_linker_flags
-
-Any additional flags you wish to pass to the linker.
-
-=back
-
-On platforms where C<need_prelink()> returns true, C<prelink()>
-will be called automatically.
-
-The operation of this method is also affected by the C<lddlflags>,
-C<shrpenv>, and C<ld> entries in C<Config.pm>.
-
-=item link_executable
-
-Invokes the linker to produce an executable file from object files. In
-scalar context, the name of the executable file is returned. In list
-context, the executable file and any temporary files created are
-returned. A required C<objects> parameter contains the name of the
-object files to process, either in a string (for one object file) or
-list reference (for one or more files). The optional parameters are
-the same as C<link> with exception for
-
-
-=over 4
-
-=item exe_file
-
-Specifies the name of the output executable file to create. Otherwise
-the C<exe_file()> method will be consulted, passing it the name of the
-first entry in C<objects>.
-
-=back
-
-=item object_file
-
- my $object_file = $b->object_file($source_file);
-
-Converts the name of a C source file to the most natural name of an
-output object file to create from it. For instance, on Unix the
-source file F<foo.c> would result in the object file F<foo.o>.
-
-=item lib_file
-
- my $lib_file = $b->lib_file($object_file);
-
-Converts the name of an object file to the most natural name of a
-output library file to create from it. For instance, on Mac OS X the
-object file F<foo.o> would result in the library file F<foo.bundle>.
-
-=item exe_file
-
- my $exe_file = $b->exe_file($object_file);
-
-Converts the name of an object file to the most natural name of an
-executable file to create from it. For instance, on Mac OS X the
-object file F<foo.o> would result in the executable file F<foo>, and
-on Windows it would result in F<foo.exe>.
-
-
-=item prelink
-
-On certain platforms like Win32, OS/2, VMS, and AIX, it is necessary
-to perform some actions before invoking the linker. The
-C<ExtUtils::Mksymlists> module does this, writing files used by the
-linker during the creation of shared libraries for dynamic extensions.
-The names of any files written will be returned as a list.
-
-Several parameters correspond to C<ExtUtils::Mksymlists::Mksymlists()>
-options, as follows:
-
- Mksymlists() prelink() type
- -------------|-------------------|-------------------
- NAME | dl_name | string (required)
- DLBASE | dl_base | string
- FILE | dl_file | string
- DL_VARS | dl_vars | array reference
- DL_FUNCS | dl_funcs | hash reference
- FUNCLIST | dl_func_list | array reference
- IMPORTS | dl_imports | hash reference
- VERSION | dl_version | string
-
-Please see the documentation for C<ExtUtils::Mksymlists> for the
-details of what these parameters do.
-
-=item need_prelink
-
-Returns true on platforms where C<prelink()> should be called
-during linking, and false otherwise.
-
-=item extra_link_args_after_prelink
-
-Returns list of extra arguments to give to the link command; the arguments
-are the same as for prelink(), with addition of array reference to the
-results of prelink(); this reference is indexed by key C<prelink_res>.
-
-=back
-
-=head1 TO DO
-
-Currently this has only been tested on Unix and doesn't contain any of
-the Windows-specific code from the C<Module::Build> project. I'll do
-that next.
-
-=head1 HISTORY
-
-This module is an outgrowth of the C<Module::Build> project, to which
-there have been many contributors. Notably, Randy W. Sims submitted
-lots of code to support 3 compilers on Windows and helped with various
-other platform-specific issues. Ilya Zakharevich has contributed
-fixes for OS/2; John E. Malmberg and Peter Prymmer have done likewise
-for VMS.
-
-=head1 AUTHOR
-
-Ken Williams, kwilliams at cpan.org
-
-=head1 COPYRIGHT
-
-Copyright (c) 2003-2005 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
-
-perl(1), Module::Build(3)
-
-=cut
Deleted: trunk/contrib/perl/lib/ExtUtils/Command.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Command.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/Command.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,369 +0,0 @@
-package ExtUtils::Command;
-
-use 5.00503;
-use strict;
-use Carp;
-use File::Copy;
-use File::Compare;
-use File::Basename;
-use File::Path qw(rmtree);
-require Exporter;
-use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
- at ISA = qw(Exporter);
- at EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
- dos2unix);
-$VERSION = '1.16';
-
-my $Is_VMS = $^O eq 'VMS';
-my $Is_VMS_mode = $Is_VMS;
-my $Is_VMS_noefs = $Is_VMS;
-my $Is_Win32 = $^O eq 'MSWin32';
-
-if( $Is_VMS ) {
- my $vms_unix_rpt;
- my $vms_efs;
- my $vms_case;
-
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
- $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
- $vms_efs = VMS::Feature::current("efs_charset");
- $vms_case = VMS::Feature::current("efs_case_preserve");
- } else {
- my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
- my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
- my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
- $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
- $vms_efs = $efs_charset =~ /^[ET1]/i;
- $vms_case = $efs_case =~ /^[ET1]/i;
- }
- $Is_VMS_mode = 0 if $vms_unix_rpt;
- $Is_VMS_noefs = 0 if ($vms_efs);
-}
-
-
-=head1 NAME
-
-ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc.
-
-=head1 SYNOPSIS
-
- perl -MExtUtils::Command -e cat files... > destination
- perl -MExtUtils::Command -e mv source... destination
- perl -MExtUtils::Command -e cp source... destination
- perl -MExtUtils::Command -e touch files...
- perl -MExtUtils::Command -e rm_f files...
- perl -MExtUtils::Command -e rm_rf directories...
- perl -MExtUtils::Command -e mkpath directories...
- perl -MExtUtils::Command -e eqtime source destination
- perl -MExtUtils::Command -e test_f file
- perl -MExtUtils::Command -e test_d directory
- perl -MExtUtils::Command -e chmod mode files...
- ...
-
-=head1 DESCRIPTION
-
-The module is used to replace common UNIX commands. In all cases the
-functions work from @ARGV rather than taking arguments. This makes
-them easier to deal with in Makefiles. Call them like this:
-
- perl -MExtUtils::Command -e some_command some files to work on
-
-and I<NOT> like this:
-
- perl -MExtUtils::Command -e 'some_command qw(some files to work on)'
-
-For that use L<Shell::Command>.
-
-Filenames with * and ? will be glob expanded.
-
-
-=head2 FUNCTIONS
-
-=over 4
-
-=cut
-
-# VMS uses % instead of ? to mean "one character"
-my $wild_regex = $Is_VMS ? '*%' : '*?';
-sub expand_wildcards
-{
- @ARGV = map(/[$wild_regex]/o ? glob($_) : $_, at ARGV);
-}
-
-
-=item cat
-
- cat file ...
-
-Concatenates all files mentioned on command line to STDOUT.
-
-=cut
-
-sub cat ()
-{
- expand_wildcards();
- print while (<>);
-}
-
-=item eqtime
-
- eqtime source destination
-
-Sets modified time of destination to that of source.
-
-=cut
-
-sub eqtime
-{
- my ($src,$dst) = @ARGV;
- local @ARGV = ($dst); touch(); # in case $dst doesn't exist
- utime((stat($src))[8,9],$dst);
-}
-
-=item rm_rf
-
- rm_rf files or directories ...
-
-Removes files and directories - recursively (even if readonly)
-
-=cut
-
-sub rm_rf
-{
- expand_wildcards();
- rmtree([grep -e $_, at ARGV],0,0);
-}
-
-=item rm_f
-
- rm_f file ...
-
-Removes files (even if readonly)
-
-=cut
-
-sub rm_f {
- expand_wildcards();
-
- foreach my $file (@ARGV) {
- next unless -f $file;
-
- next if _unlink($file);
-
- chmod(0777, $file);
-
- next if _unlink($file);
-
- carp "Cannot delete $file: $!";
- }
-}
-
-sub _unlink {
- my $files_unlinked = 0;
- foreach my $file (@_) {
- my $delete_count = 0;
- $delete_count++ while unlink $file;
- $files_unlinked++ if $delete_count;
- }
- return $files_unlinked;
-}
-
-
-=item touch
-
- touch file ...
-
-Makes files exist, with current timestamp
-
-=cut
-
-sub touch {
- my $t = time;
- expand_wildcards();
- foreach my $file (@ARGV) {
- open(FILE,">>$file") || die "Cannot write $file:$!";
- close(FILE);
- utime($t,$t,$file);
- }
-}
-
-=item mv
-
- mv source_file destination_file
- mv source_file source_file destination_dir
-
-Moves source to destination. Multiple sources are allowed if
-destination is an existing directory.
-
-Returns true if all moves succeeded, false otherwise.
-
-=cut
-
-sub mv {
- expand_wildcards();
- my @src = @ARGV;
- my $dst = pop @src;
-
- croak("Too many arguments") if (@src > 1 && ! -d $dst);
-
- my $nok = 0;
- foreach my $src (@src) {
- $nok ||= !move($src,$dst);
- }
- return !$nok;
-}
-
-=item cp
-
- cp source_file destination_file
- cp source_file source_file destination_dir
-
-Copies sources to the destination. Multiple sources are allowed if
-destination is an existing directory.
-
-Returns true if all copies succeeded, false otherwise.
-
-=cut
-
-sub cp {
- expand_wildcards();
- my @src = @ARGV;
- my $dst = pop @src;
-
- croak("Too many arguments") if (@src > 1 && ! -d $dst);
-
- my $nok = 0;
- foreach my $src (@src) {
- $nok ||= !copy($src,$dst);
-
- # Win32 does not update the mod time of a copied file, just the
- # created time which make does not look at.
- utime(time, time, $dst) if $Is_Win32;
- }
- return $nok;
-}
-
-=item chmod
-
- chmod mode files ...
-
-Sets UNIX like permissions 'mode' on all the files. e.g. 0666
-
-=cut
-
-sub chmod {
- local @ARGV = @ARGV;
- my $mode = shift(@ARGV);
- expand_wildcards();
-
- if( $Is_VMS_mode && $Is_VMS_noefs) {
- foreach my $idx (0..$#ARGV) {
- my $path = $ARGV[$idx];
- next unless -d $path;
-
- # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do
- # chmod 0777, [.foo]bar.dir
- my @dirs = File::Spec->splitdir( $path );
- $dirs[-1] .= '.dir';
- $path = File::Spec->catfile(@dirs);
-
- $ARGV[$idx] = $path;
- }
- }
-
- chmod(oct $mode, at ARGV) || die "Cannot chmod ".join(' ',$mode, at ARGV).":$!";
-}
-
-=item mkpath
-
- mkpath directory ...
-
-Creates directories, including any parent directories.
-
-=cut
-
-sub mkpath
-{
- expand_wildcards();
- File::Path::mkpath([@ARGV],0,0777);
-}
-
-=item test_f
-
- test_f file
-
-Tests if a file exists. I<Exits> with 0 if it does, 1 if it does not (ie.
-shell's idea of true and false).
-
-=cut
-
-sub test_f
-{
- exit(-f $ARGV[0] ? 0 : 1);
-}
-
-=item test_d
-
- test_d directory
-
-Tests if a directory exists. I<Exits> with 0 if it does, 1 if it does
-not (ie. shell's idea of true and false).
-
-=cut
-
-sub test_d
-{
- exit(-d $ARGV[0] ? 0 : 1);
-}
-
-=item dos2unix
-
- dos2unix files or dirs ...
-
-Converts DOS and OS/2 linefeeds to Unix style recursively.
-
-=cut
-
-sub dos2unix {
- require File::Find;
- File::Find::find(sub {
- return if -d;
- return unless -w _;
- return unless -r _;
- return if -B _;
-
- local $\;
-
- my $orig = $_;
- my $temp = '.dos2unix_tmp';
- open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return };
- open TEMP, ">$temp" or
- do { warn "dos2unix can't create .dos2unix_tmp: $!"; return };
- while (my $line = <ORIG>) {
- $line =~ s/\015\012/\012/g;
- print TEMP $line;
- }
- close ORIG;
- close TEMP;
- rename $temp, $orig;
-
- }, @ARGV);
-}
-
-=back
-
-=head1 SEE ALSO
-
-Shell::Command which is these same functions but take arguments normally.
-
-
-=head1 AUTHOR
-
-Nick Ing-Simmons C<ni-s at cpan.org>
-
-Maintained by Michael G Schwern C<schwern at pobox.com> within the
-ExtUtils-MakeMaker package and, as a separate CPAN package, by
-Randy Kobes C<r.kobes at uwinnipeg.ca>.
-
-=cut
-
Deleted: trunk/contrib/perl/lib/ExtUtils/Constant.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Constant.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/Constant.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,565 +0,0 @@
-package ExtUtils::Constant;
-use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS);
-$VERSION = 0.22;
-
-=head1 NAME
-
-ExtUtils::Constant - generate XS code to import C header constants
-
-=head1 SYNOPSIS
-
- use ExtUtils::Constant qw (WriteConstants);
- WriteConstants(
- NAME => 'Foo',
- NAMES => [qw(FOO BAR BAZ)],
- );
- # Generates wrapper code to make the values of the constants FOO BAR BAZ
- # available to perl
-
-=head1 DESCRIPTION
-
-ExtUtils::Constant facilitates generating C and XS wrapper code to allow
-perl modules to AUTOLOAD constants defined in C library header files.
-It is principally used by the C<h2xs> utility, on which this code is based.
-It doesn't contain the routines to scan header files to extract these
-constants.
-
-=head1 USAGE
-
-Generally one only needs to call the C<WriteConstants> function, and then
-
- #include "const-c.inc"
-
-in the C section of C<Foo.xs>
-
- INCLUDE: const-xs.inc
-
-in the XS section of C<Foo.xs>.
-
-For greater flexibility use C<constant_types()>, C<C_constant> and
-C<XS_constant>, with which C<WriteConstants> is implemented.
-
-Currently this module understands the following types. h2xs may only know
-a subset. The sizes of the numeric types are chosen by the C<Configure>
-script at compile time.
-
-=over 4
-
-=item IV
-
-signed integer, at least 32 bits.
-
-=item UV
-
-unsigned integer, the same size as I<IV>
-
-=item NV
-
-floating point type, probably C<double>, possibly C<long double>
-
-=item PV
-
-NUL terminated string, length will be determined with C<strlen>
-
-=item PVN
-
-A fixed length thing, given as a [pointer, length] pair. If you know the
-length of a string at compile time you may use this instead of I<PV>
-
-=item SV
-
-A B<mortal> SV.
-
-=item YES
-
-Truth. (C<PL_sv_yes>) The value is not needed (and ignored).
-
-=item NO
-
-Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored).
-
-=item UNDEF
-
-C<undef>. The value of the macro is not needed.
-
-=back
-
-=head1 FUNCTIONS
-
-=over 4
-
-=cut
-
-if ($] >= 5.006) {
- eval "use warnings; 1" or die $@;
-}
-use strict;
-use Carp qw(croak cluck);
-
-use Exporter;
-use ExtUtils::Constant::Utils qw(C_stringify);
-use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet);
-
- at ISA = 'Exporter';
-
-%EXPORT_TAGS = ( 'all' => [ qw(
- XS_constant constant_types return_clause memEQ_clause C_stringify
- C_constant autoload WriteConstants WriteMakefileSnippet
-) ] );
-
- at EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
-
-=item constant_types
-
-A function returning a single scalar with C<#define> definitions for the
-constants used internally between the generated C and XS functions.
-
-=cut
-
-sub constant_types {
- ExtUtils::Constant::XS->header();
-}
-
-sub memEQ_clause {
- cluck "ExtUtils::Constant::memEQ_clause is deprecated";
- ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1],
- indent=>$_[2]});
-}
-
-sub return_clause ($$) {
- cluck "ExtUtils::Constant::return_clause is deprecated";
- my $indent = shift;
- ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_);
-}
-
-sub switch_clause {
- cluck "ExtUtils::Constant::switch_clause is deprecated";
- my $indent = shift;
- my $comment = shift;
- ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment},
- @_);
-}
-
-sub C_constant {
- my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
- = @_;
- ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname,
- default_type => $default_type,
- types => $what, indent => $indent,
- breakout => $breakout}, @items);
-}
-
-=item XS_constant PACKAGE, TYPES, XS_SUBNAME, C_SUBNAME
-
-A function to generate the XS code to implement the perl subroutine
-I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
-This XS code is a wrapper around a C subroutine usually generated by
-C<C_constant>, and usually named C<constant>.
-
-I<TYPES> should be given either as a comma separated list of types that the
-C subroutine C<constant> will generate or as a reference to a hash. It should
-be the same list of types as C<C_constant> was given.
-[Otherwise C<XS_constant> and C<C_constant> may have different ideas about
-the number of parameters passed to the C function C<constant>]
-
-You can call the perl visible subroutine something other than C<constant> if
-you give the parameter I<XS_SUBNAME>. The C subroutine it calls defaults to
-the name of the perl visible subroutine, unless you give the parameter
-I<C_SUBNAME>.
-
-=cut
-
-sub XS_constant {
- my $package = shift;
- my $what = shift;
- my $XS_subname = shift;
- my $C_subname = shift;
- $XS_subname ||= 'constant';
- $C_subname ||= $XS_subname;
-
- if (!ref $what) {
- # Convert line of the form IV,UV,NV to hash
- $what = {map {$_ => 1} split /,\s*/, ($what)};
- }
- my $params = ExtUtils::Constant::XS->params ($what);
- my $type;
-
- my $xs = <<"EOT";
-void
-$XS_subname(sv)
- PREINIT:
-#ifdef dXSTARG
- dXSTARG; /* Faster if we have it. */
-#else
- dTARGET;
-#endif
- STRLEN len;
- int type;
-EOT
-
- if ($params->{IV}) {
- $xs .= " IV iv;\n";
- } else {
- $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
- }
- if ($params->{NV}) {
- $xs .= " NV nv;\n";
- } else {
- $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
- }
- if ($params->{PV}) {
- $xs .= " const char *pv;\n";
- } else {
- $xs .=
- " /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
- }
-
- $xs .= << 'EOT';
- INPUT:
- SV * sv;
- const char * s = SvPV(sv, len);
-EOT
- if ($params->{''}) {
- $xs .= << 'EOT';
- INPUT:
- int utf8 = SvUTF8(sv);
-EOT
- }
- $xs .= << 'EOT';
- PPCODE:
-EOT
-
- if ($params->{IV} xor $params->{NV}) {
- $xs .= << "EOT";
- /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
- if you need to return both NVs and IVs */
-EOT
- }
- $xs .= " type = $C_subname(aTHX_ s, len";
- $xs .= ', utf8' if $params->{''};
- $xs .= ', &iv' if $params->{IV};
- $xs .= ', &nv' if $params->{NV};
- $xs .= ', &pv' if $params->{PV};
- $xs .= ', &sv' if $params->{SV};
- $xs .= ");\n";
-
- # If anyone is insane enough to suggest a package name containing %
- my $package_sprintf_safe = $package;
- $package_sprintf_safe =~ s/%/%%/g;
-
- $xs .= << "EOT";
- /* Return 1 or 2 items. First is error message, or undef if no error.
- Second, if present, is found value */
- switch (type) {
- case PERL_constant_NOTFOUND:
- sv =
- sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s));
- PUSHs(sv);
- break;
- case PERL_constant_NOTDEF:
- sv = sv_2mortal(newSVpvf(
- "Your vendor has not defined $package_sprintf_safe macro %s, used",
- s));
- PUSHs(sv);
- break;
-EOT
-
- foreach $type (sort keys %XS_Constant) {
- # '' marks utf8 flag needed.
- next if $type eq '';
- $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
- unless $what->{$type};
- $xs .= " case PERL_constant_IS$type:\n";
- if (length $XS_Constant{$type}) {
- $xs .= << "EOT";
- EXTEND(SP, 1);
- PUSHs(&PL_sv_undef);
- $XS_Constant{$type};
-EOT
- } else {
- # Do nothing. return (), which will be correctly interpreted as
- # (undef, undef)
- }
- $xs .= " break;\n";
- unless ($what->{$type}) {
- chop $xs; # Yes, another need for chop not chomp.
- $xs .= " */\n";
- }
- }
- $xs .= << "EOT";
- default:
- sv = sv_2mortal(newSVpvf(
- "Unexpected return type %d while processing $package_sprintf_safe macro %s, used",
- type, s));
- PUSHs(sv);
- }
-EOT
-
- return $xs;
-}
-
-
-=item autoload PACKAGE, VERSION, AUTOLOADER
-
-A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
-I<VERSION> is the perl version the code should be backwards compatible with.
-It defaults to the version of perl running the subroutine. If I<AUTOLOADER>
-is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
-names that the constant() routine doesn't recognise.
-
-=cut
-
-# ' # Grr. syntax highlighters that don't grok pod.
-
-sub autoload {
- my ($module, $compat_version, $autoloader) = @_;
- $compat_version ||= $];
- croak "Can't maintain compatibility back as far as version $compat_version"
- if $compat_version < 5;
- my $func = "sub AUTOLOAD {\n"
- . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
- . " # XS function.";
- $func .= " If a constant is not found then control is passed\n"
- . " # to the AUTOLOAD in AutoLoader." if $autoloader;
-
-
- $func .= "\n\n"
- . " my \$constname;\n";
- $func .=
- " our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
-
- $func .= <<"EOT";
- (\$constname = \$AUTOLOAD) =~ s/.*:://;
- croak "&${module}::constant not defined" if \$constname eq 'constant';
- my (\$error, \$val) = constant(\$constname);
-EOT
-
- if ($autoloader) {
- $func .= <<'EOT';
- if ($error) {
- if ($error =~ /is not a valid/) {
- $AutoLoader::AUTOLOAD = $AUTOLOAD;
- goto &AutoLoader::AUTOLOAD;
- } else {
- croak $error;
- }
- }
-EOT
- } else {
- $func .=
- " if (\$error) { croak \$error; }\n";
- }
-
- $func .= <<'END';
- {
- no strict 'refs';
- # Fixed between 5.005_53 and 5.005_61
-#XXX if ($] >= 5.00561) {
-#XXX *$AUTOLOAD = sub () { $val };
-#XXX }
-#XXX else {
- *$AUTOLOAD = sub { $val };
-#XXX }
- }
- goto &$AUTOLOAD;
-}
-
-END
-
- return $func;
-}
-
-
-=item WriteMakefileSnippet
-
-WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
-
-A function to generate perl code for Makefile.PL that will regenerate
-the constant subroutines. Parameters are named as passed to C<WriteConstants>,
-with the addition of C<INDENT> to specify the number of leading spaces
-(default 2).
-
-Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
-C<XS_FILE> are recognised.
-
-=cut
-
-sub WriteMakefileSnippet {
- my %args = @_;
- my $indent = $args{INDENT} || 2;
-
- my $result = <<"EOT";
-ExtUtils::Constant::WriteConstants(
- NAME => '$args{NAME}',
- NAMES => \\\@names,
- DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
-EOT
- foreach (qw (C_FILE XS_FILE)) {
- next unless exists $args{$_};
- $result .= sprintf " %-12s => '%s',\n",
- $_, $args{$_};
- }
- $result .= <<'EOT';
- );
-EOT
-
- $result =~ s/^/' 'x$indent/gem;
- return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE},
- indent=>$indent,},
- @{$args{NAMES}})
- . $result;
-}
-
-=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
-
-Writes a file of C code and a file of XS code which you should C<#include>
-and C<INCLUDE> in the C and XS sections respectively of your module's XS
-code. You probably want to do this in your C<Makefile.PL>, so that you can
-easily edit the list of constants without touching the rest of your module.
-The attributes supported are
-
-=over 4
-
-=item NAME
-
-Name of the module. This must be specified
-
-=item DEFAULT_TYPE
-
-The default type for the constants. If not specified C<IV> is assumed.
-
-=item BREAKOUT_AT
-
-The names of the constants are grouped by length. Generate child subroutines
-for each group with this number or more names in.
-
-=item NAMES
-
-An array of constants' names, either scalars containing names, or hashrefs
-as detailed in L<"C_constant">.
-
-=item PROXYSUBS
-
-If true, uses proxy subs. See L<ExtUtils::Constant::ProxySubs>.
-
-=item C_FH
-
-A filehandle to write the C code to. If not given, then I<C_FILE> is opened
-for writing.
-
-=item C_FILE
-
-The name of the file to write containing the C code. The default is
-C<const-c.inc>. The C<-> in the name ensures that the file can't be
-mistaken for anything related to a legitimate perl package name, and
-not naming the file C<.c> avoids having to override Makefile.PL's
-C<.xs> to C<.c> rules.
-
-=item XS_FH
-
-A filehandle to write the XS code to. If not given, then I<XS_FILE> is opened
-for writing.
-
-=item XS_FILE
-
-The name of the file to write containing the XS code. The default is
-C<const-xs.inc>.
-
-=item XS_SUBNAME
-
-The perl visible name of the XS subroutine generated which will return the
-constants. The default is C<constant>.
-
-=item C_SUBNAME
-
-The name of the C subroutine generated which will return the constants.
-The default is I<XS_SUBNAME>. Child subroutines have C<_> and the name
-length appended, so constants with 10 character names would be in
-C<constant_10> with the default I<XS_SUBNAME>.
-
-=back
-
-=cut
-
-sub WriteConstants {
- my %ARGS =
- ( # defaults
- C_FILE => 'const-c.inc',
- XS_FILE => 'const-xs.inc',
- XS_SUBNAME => 'constant',
- DEFAULT_TYPE => 'IV',
- @_);
-
- $ARGS{C_SUBNAME} ||= $ARGS{XS_SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
-
- croak "Module name not specified" unless length $ARGS{NAME};
-
- my $c_fh = $ARGS{C_FH};
- if (!$c_fh) {
- if ($] <= 5.008) {
- # We need these little games, rather than doing things
- # unconditionally, because we're used in core Makefile.PLs before
- # IO is available (needed by filehandle), but also we want to work on
- # older perls where undefined scalars do not automatically turn into
- # anonymous file handles.
- require FileHandle;
- $c_fh = FileHandle->new();
- }
- open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
- }
-
- my $xs_fh = $ARGS{XS_FH};
- if (!$xs_fh) {
- if ($] <= 5.008) {
- require FileHandle;
- $xs_fh = FileHandle->new();
- }
- open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
- }
-
- # As this subroutine is intended to make code that isn't edited, there's no
- # need for the user to specify any types that aren't found in the list of
- # names.
-
- if ($ARGS{PROXYSUBS}) {
- require ExtUtils::Constant::ProxySubs;
- $ARGS{C_FH} = $c_fh;
- $ARGS{XS_FH} = $xs_fh;
- ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS);
- } else {
- my $types = {};
-
- print $c_fh constant_types(); # macro defs
- print $c_fh "\n";
-
- # indent is still undef. Until anyone implements indent style rules with
- # it.
- foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME},
- subname => $ARGS{C_SUBNAME},
- default_type =>
- $ARGS{DEFAULT_TYPE},
- types => $types,
- breakout =>
- $ARGS{BREAKOUT_AT}},
- @{$ARGS{NAMES}})) {
- print $c_fh $_, "\n"; # C constant subs
- }
- print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
- $ARGS{C_SUBNAME});
- }
-
- close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH};
- close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH};
-}
-
-1;
-__END__
-
-=back
-
-=head1 AUTHOR
-
-Nicholas Clark <nick at ccl4.org> based on the code in C<h2xs> by Larry Wall and
-others
-
-=cut
Deleted: trunk/contrib/perl/lib/ExtUtils/Install.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Install.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/Install.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1356 +0,0 @@
-package ExtUtils::Install;
-use strict;
-
-use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config);
-
-use AutoSplit;
-use Carp ();
-use Config qw(%Config);
-use Cwd qw(cwd);
-use Exporter;
-use ExtUtils::Packlist;
-use File::Basename qw(dirname);
-use File::Compare qw(compare);
-use File::Copy;
-use File::Find qw(find);
-use File::Path;
-use File::Spec;
-
-
- at ISA = ('Exporter');
- at EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
-
-=pod
-
-=head1 NAME
-
-ExtUtils::Install - install files from here to there
-
-=head1 SYNOPSIS
-
- use ExtUtils::Install;
-
- install({ 'blib/lib' => 'some/install/dir' } );
-
- uninstall($packlist);
-
- pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' });
-
-=head1 VERSION
-
-1.54
-
-=cut
-
-$VERSION = '1.54'; # <---- dont forget to update the POD section just above this line!
-$VERSION = eval $VERSION;
-
-=pod
-
-=head1 DESCRIPTION
-
-Handles the installing and uninstalling of perl modules, scripts, man
-pages, etc...
-
-Both install() and uninstall() are specific to the way
-ExtUtils::MakeMaker handles the installation and deinstallation of
-perl modules. They are not designed as general purpose tools.
-
-On some operating systems such as Win32 installation may not be possible
-until after a reboot has occured. This can have varying consequences:
-removing an old DLL does not impact programs using the new one, but if
-a new DLL cannot be installed properly until reboot then anything
-depending on it must wait. The package variable
-
- $ExtUtils::Install::MUST_REBOOT
-
-is used to store this status.
-
-If this variable is true then such an operation has occured and
-anything depending on this module cannot proceed until a reboot
-has occured.
-
-If this value is defined but false then such an operation has
-ocurred, but should not impact later operations.
-
-=begin _private
-
-=item _chmod($$;$)
-
-Wrapper to chmod() for debugging and error trapping.
-
-=item _warnonce(@)
-
-Warns about something only once.
-
-=item _choke(@)
-
-Dies with a special message.
-
-=end _private
-
-=cut
-
-my $Is_VMS = $^O eq 'VMS';
-my $Is_VMS_noefs = $Is_VMS;
-my $Is_MacPerl = $^O eq 'MacOS';
-my $Is_Win32 = $^O eq 'MSWin32';
-my $Is_cygwin = $^O eq 'cygwin';
-my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin);
-
- if( $Is_VMS ) {
- my $vms_unix_rpt;
- my $vms_efs;
- my $vms_case;
-
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
- $vms_unix_rpt = VMS::Feature::current("filename_unix_report");
- $vms_efs = VMS::Feature::current("efs_charset");
- $vms_case = VMS::Feature::current("efs_case_preserve");
- } else {
- my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
- my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || '';
- my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
- $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i;
- $vms_efs = $efs_charset =~ /^[ET1]/i;
- $vms_case = $efs_case =~ /^[ET1]/i;
- }
- $Is_VMS_noefs = 0 if ($vms_efs);
- }
-
-
-
-# *note* CanMoveAtBoot is only incidentally the same condition as below
-# this needs not hold true in the future.
-my $Has_Win32API_File = ($Is_Win32 || $Is_cygwin)
- ? (eval {require Win32API::File; 1} || 0)
- : 0;
-
-
-my $Inc_uninstall_warn_handler;
-
-# install relative to here
-
-my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT};
-
-my $Curdir = File::Spec->curdir;
-my $Updir = File::Spec->updir;
-
-sub _estr(@) {
- return join "\n",'!' x 72, at _,'!' x 72,'';
-}
-
-{my %warned;
-sub _warnonce(@) {
- my $first=shift;
- my $msg=_estr "WARNING: $first", at _;
- warn $msg unless $warned{$msg}++;
-}}
-
-sub _choke(@) {
- my $first=shift;
- my $msg=_estr "ERROR: $first", at _;
- Carp::croak($msg);
-}
-
-
-sub _chmod($$;$) {
- my ( $mode, $item, $verbose )=@_;
- $verbose ||= 0;
- if (chmod $mode, $item) {
- printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1;
- } else {
- my $err="$!";
- _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n",
- $mode, $item, $err
- if -e $item;
- }
-}
-
-=begin _private
-
-=item _move_file_at_boot( $file, $target, $moan )
-
-OS-Specific, Win32/Cygwin
-
-Schedules a file to be moved/renamed/deleted at next boot.
-$file should be a filespec of an existing file
-$target should be a ref to an array if the file is to be deleted
-otherwise it should be a filespec for a rename. If the file is existing
-it will be replaced.
-
-Sets $MUST_REBOOT to 0 to indicate a deletion operation has occured
-and sets it to 1 to indicate that a move operation has been requested.
-
-returns 1 on success, on failure if $moan is false errors are fatal.
-If $moan is true then returns 0 on error and warns instead of dies.
-
-=end _private
-
-=cut
-
-
-
-sub _move_file_at_boot { #XXX OS-SPECIFIC
- my ( $file, $target, $moan )= @_;
- Carp::confess("Panic: Can't _move_file_at_boot on this platform!")
- unless $CanMoveAtBoot;
-
- my $descr= ref $target
- ? "'$file' for deletion"
- : "'$file' for installation as '$target'";
-
- if ( ! $Has_Win32API_File ) {
-
- my @msg=(
- "Cannot schedule $descr at reboot.",
- "Try installing Win32API::File to allow operations on locked files",
- "to be scheduled during reboot. Or try to perform the operation by",
- "hand yourself. (You may need to close other perl processes first)"
- );
- if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
- return 0;
- }
- my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT();
- $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING()
- unless ref $target;
-
- _chmod( 0666, $file );
- _chmod( 0666, $target ) unless ref $target;
-
- if (Win32API::File::MoveFileEx( $file, $target, $opts )) {
- $MUST_REBOOT ||= ref $target ? 0 : 1;
- return 1;
- } else {
- my @msg=(
- "MoveFileEx $descr at reboot failed: $^E",
- "You may try to perform the operation by hand yourself. ",
- "(You may need to close other perl processes first).",
- );
- if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) }
- }
- return 0;
-}
-
-
-=begin _private
-
-=item _unlink_or_rename( $file, $tryhard, $installing )
-
-OS-Specific, Win32/Cygwin
-
-Tries to get a file out of the way by unlinking it or renaming it. On
-some OS'es (Win32 based) DLL files can end up locked such that they can
-be renamed but not deleted. Likewise sometimes a file can be locked such
-that it cant even be renamed or changed except at reboot. To handle
-these cases this routine finds a tempfile name that it can either rename
-the file out of the way or use as a proxy for the install so that the
-rename can happen later (at reboot).
-
- $file : the file to remove.
- $tryhard : should advanced tricks be used for deletion
- $installing : we are not merely deleting but we want to overwrite
-
-When $tryhard is not true if the unlink fails its fatal. When $tryhard
-is true then the file is attempted to be renamed. The renamed file is
-then scheduled for deletion. If the rename fails then $installing
-governs what happens. If it is false the failure is fatal. If it is true
-then an attempt is made to schedule installation at boot using a
-temporary file to hold the new file. If this fails then a fatal error is
-thrown, if it succeeds it returns the temporary file name (which will be
-a derivative of the original in the same directory) so that the caller can
-use it to install under. In all other cases of success returns $file.
-On failure throws a fatal error.
-
-=end _private
-
-=cut
-
-
-
-sub _unlink_or_rename { #XXX OS-SPECIFIC
- my ( $file, $tryhard, $installing )= @_;
-
- _chmod( 0666, $file );
- my $unlink_count = 0;
- while (unlink $file) { $unlink_count++; }
- return $file if $unlink_count > 0;
- my $error="$!";
-
- _choke("Cannot unlink '$file': $!")
- unless $CanMoveAtBoot && $tryhard;
-
- my $tmp= "AAA";
- ++$tmp while -e "$file.$tmp";
- $tmp= "$file.$tmp";
-
- warn "WARNING: Unable to unlink '$file': $error\n",
- "Going to try to rename it to '$tmp'.\n";
-
- if ( rename $file, $tmp ) {
- warn "Rename succesful. Scheduling '$tmp'\nfor deletion at reboot.\n";
- # when $installing we can set $moan to true.
- # IOW, if we cant delete the renamed file at reboot its
- # not the end of the world. The other cases are more serious
- # and need to be fatal.
- _move_file_at_boot( $tmp, [], $installing );
- return $file;
- } elsif ( $installing ) {
- _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor".
- " installation as '$file' at reboot.\n");
- _move_file_at_boot( $tmp, $file );
- return $tmp;
- } else {
- _choke("Rename failed:$!", "Cannot procede.");
- }
-
-}
-
-
-=pod
-
-=head2 Functions
-
-=begin _private
-
-=item _get_install_skip
-
-Handles loading the INSTALL.SKIP file. Returns an array of patterns to use.
-
-=cut
-
-
-
-sub _get_install_skip {
- my ( $skip, $verbose )= @_;
- if ($ENV{EU_INSTALL_IGNORE_SKIP}) {
- print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n"
- if $verbose>2;
- return [];
- }
- if ( ! defined $skip ) {
- print "Looking for install skip list\n"
- if $verbose>2;
- for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) {
- next unless $file;
- print "\tChecking for $file\n"
- if $verbose>2;
- if (-e $file) {
- $skip= $file;
- last;
- }
- }
- }
- if ($skip && !ref $skip) {
- print "Reading skip patterns from '$skip'.\n"
- if $verbose;
- if (open my $fh,$skip ) {
- my @patterns;
- while (<$fh>) {
- chomp;
- next if /^\s*(?:#|$)/;
- print "\tSkip pattern: $_\n" if $verbose>3;
- push @patterns, $_;
- }
- $skip= \@patterns;
- } else {
- warn "Can't read skip file:'$skip':$!\n";
- $skip=[];
- }
- } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) {
- print "Using array for skip list\n"
- if $verbose>2;
- } elsif ($verbose) {
- print "No skip list found.\n"
- if $verbose>1;
- $skip= [];
- }
- warn "Got @{[0+@$skip]} skip patterns.\n"
- if $verbose>3;
- return $skip
-}
-
-=pod
-
-=item _have_write_access
-
-Abstract a -w check that tries to use POSIX::access() if possible.
-
-=cut
-
-{
- my $has_posix;
- sub _have_write_access {
- my $dir=shift;
- unless (defined $has_posix) {
- $has_posix= (!$Is_cygwin && !$Is_Win32
- && eval 'local $^W; require POSIX; 1') || 0;
- }
- if ($has_posix) {
- return POSIX::access($dir, POSIX::W_OK());
- } else {
- return -w $dir;
- }
- }
-}
-
-=pod
-
-=item _can_write_dir(C<$dir>)
-
-Checks whether a given directory is writable, taking account
-the possibility that the directory might not exist and would have to
-be created first.
-
-Returns a list, containing: C<($writable, $determined_by, @create)>
-
-C<$writable> says whether whether the directory is (hypothetically) writable
-
-C<$determined_by> is the directory the status was determined from. It will be
-either the C<$dir>, or one of its parents.
-
-C<@create> is a list of directories that would probably have to be created
-to make the requested directory. It may not actually be correct on
-relative paths with C<..> in them. But for our purposes it should work ok
-
-=cut
-
-
-sub _can_write_dir {
- my $dir=shift;
- return
- unless defined $dir and length $dir;
-
- my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1);
- my @dirs = File::Spec->splitdir($dirs);
- unshift @dirs, File::Spec->curdir
- unless File::Spec->file_name_is_absolute($dir);
-
- my $path='';
- my @make;
- while (@dirs) {
- if ($Is_VMS_noefs) {
- # There is a bug in catdir that is fixed when the EFS character
- # set is enabled, which requires this VMS specific code.
- $dir = File::Spec->catdir($vol, at dirs);
- }
- else {
- $dir = File::Spec->catdir(@dirs);
- $dir = File::Spec->catpath($vol,$dir,'')
- if defined $vol and length $vol;
- }
- next if ( $dir eq $path );
- if ( ! -e $dir ) {
- unshift @make,$dir;
- next;
- }
- if ( _have_write_access($dir) ) {
- return 1,$dir, at make
- } else {
- return 0,$dir, at make
- }
- } continue {
- pop @dirs;
- }
- return 0;
-}
-
-=pod
-
-=item _mkpath($dir,$show,$mode,$verbose,$dry_run)
-
-Wrapper around File::Path::mkpath() to handle errors.
-
-If $verbose is true and >1 then additional diagnostics will be produced, also
-this will force $show to true.
-
-If $dry_run is true then the directory will not be created but a check will be
-made to see whether it would be possible to write to the directory, or that
-it would be possible to create the directory.
-
-If $dry_run is not true dies if the directory can not be created or is not
-writable.
-
-=cut
-
-sub _mkpath {
- my ($dir,$show,$mode,$verbose,$dry_run)=@_;
- if ( $verbose && $verbose > 1 && ! -d $dir) {
- $show= 1;
- printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode;
- }
- if (!$dry_run) {
- if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) {
- _choke("Can't create '$dir'","$@");
- }
-
- }
- my ($can,$root, at make)=_can_write_dir($dir);
- if (!$can) {
- my @msg=(
- "Can't create '$dir'",
- $root ? "Do not have write permissions on '$root'"
- : "Unknown Error"
- );
- if ($dry_run) {
- _warnonce @msg;
- } else {
- _choke @msg;
- }
- } elsif ($show and $dry_run) {
- print "$_\n" for @make;
- }
-
-}
-
-=pod
-
-=item _copy($from,$to,$verbose,$dry_run)
-
-Wrapper around File::Copy::copy to handle errors.
-
-If $verbose is true and >1 then additional dignostics will be emitted.
-
-If $dry_run is true then the copy will not actually occur.
-
-Dies if the copy fails.
-
-=cut
-
-
-sub _copy {
- my ( $from, $to, $verbose, $dry_run)=@_;
- if ($verbose && $verbose>1) {
- printf "copy(%s,%s)\n", $from, $to;
- }
- if (!$dry_run) {
- File::Copy::copy($from,$to)
- or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" );
- }
-}
-
-=pod
-
-=item _chdir($from)
-
-Wrapper around chdir to catch errors.
-
-If not called in void context returns the cwd from before the chdir.
-
-dies on error.
-
-=cut
-
-sub _chdir {
- my ($dir)= @_;
- my $ret;
- if (defined wantarray) {
- $ret= cwd;
- }
- chdir $dir
- or _choke("Couldn't chdir to '$dir': $!");
- return $ret;
-}
-
-=pod
-
-=end _private
-
-=over 4
-
-=item B<install>
-
- # deprecated forms
- install(\%from_to);
- install(\%from_to, $verbose, $dry_run, $uninstall_shadows,
- $skip, $always_copy, \%result);
-
- # recommended form as of 1.47
- install([
- from_to => \%from_to,
- verbose => 1,
- dry_run => 0,
- uninstall_shadows => 1,
- skip => undef,
- always_copy => 1,
- result => \%install_results,
- ]);
-
-
-Copies each directory tree of %from_to to its corresponding value
-preserving timestamps and permissions.
-
-There are two keys with a special meaning in the hash: "read" and
-"write". These contain packlist files. After the copying is done,
-install() will write the list of target files to $from_to{write}. If
-$from_to{read} is given the contents of this file will be merged into
-the written file. The read and the written file may be identical, but
-on AFS it is quite likely that people are installing to a different
-directory than the one where the files later appear.
-
-If $verbose is true, will print out each file removed. Default is
-false. This is "make install VERBINST=1". $verbose values going
-up to 5 show increasingly more diagnostics output.
-
-If $dry_run is true it will only print what it was going to do
-without actually doing it. Default is false.
-
-If $uninstall_shadows is true any differing versions throughout @INC
-will be uninstalled. This is "make install UNINST=1"
-
-As of 1.37_02 install() supports the use of a list of patterns to filter out
-files that shouldn't be installed. If $skip is omitted or undefined then
-install will try to read the list from INSTALL.SKIP in the CWD. This file is
-a list of regular expressions and is just like the MANIFEST.SKIP file used
-by L<ExtUtils::Manifest>.
-
-A default site INSTALL.SKIP may be provided by setting then environment
-variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there isn't a
-distribution specific INSTALL.SKIP. If the environment variable
-EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be
-performed.
-
-If $skip is undefined then the skip file will be autodetected and used if it
-is found. If $skip is a reference to an array then it is assumed the array
-contains the list of patterns, if $skip is a true non reference it is
-assumed to be the filename holding the list of patterns, any other value of
-$skip is taken to mean that no install filtering should occur.
-
-B<Changes As of Version 1.47>
-
-As of version 1.47 the following additions were made to the install interface.
-Note that the new argument style and use of the %result hash is recommended.
-
-The $always_copy parameter which when true causes files to be updated
-regardles as to whether they have changed, if it is defined but false then
-copies are made only if the files have changed, if it is undefined then the
-value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default.
-
-The %result hash will be populated with the various keys/subhashes reflecting
-the install. Currently these keys and their structure are:
-
- install => { $target => $source },
- install_fail => { $target => $source },
- install_unchanged => { $target => $source },
-
- install_filtered => { $source => $pattern },
-
- uninstall => { $uninstalled => $source },
- uninstall_fail => { $uninstalled => $source },
-
-where C<$source> is the filespec of the file being installed. C<$target> is where
-it is being installed to, and C<$uninstalled> is any shadow file that is in C<@INC>
-or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the pattern that
-caused a source file to be skipped. In future more keys will be added, such as to
-show created directories, however this requires changes in other modules and must
-therefore wait.
-
-These keys will be populated before any exceptions are thrown should there be an
-error.
-
-Note that all updates of the %result are additive, the hash will not be
-cleared before use, thus allowing status results of many installs to be easily
-aggregated.
-
-B<NEW ARGUMENT STYLE>
-
-If there is only one argument and it is a reference to an array then
-the array is assumed to contain a list of key-value pairs specifying
-the options. In this case the option "from_to" is mandatory. This style
-means that you dont have to supply a cryptic list of arguments and can
-use a self documenting argument list that is easier to understand.
-
-This is now the recommended interface to install().
-
-B<RETURN>
-
-If all actions were successful install will return a hashref of the results
-as described above for the $result parameter. If any action is a failure
-then install will die, therefore it is recommended to pass in the $result
-parameter instead of using the return value. If the result parameter is
-provided then the returned hashref will be the passed in hashref.
-
-=cut
-
-sub install { #XXX OS-SPECIFIC
- my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_;
- if (@_==1 and eval { 1+@$from_to }) {
- my %opts = @$from_to;
- $from_to = $opts{from_to}
- or Carp::confess("from_to is a mandatory parameter");
- $verbose = $opts{verbose};
- $dry_run = $opts{dry_run};
- $uninstall_shadows = $opts{uninstall_shadows};
- $skip = $opts{skip};
- $always_copy = $opts{always_copy};
- $result = $opts{result};
- }
-
- $result ||= {};
- $verbose ||= 0;
- $dry_run ||= 0;
-
- $skip= _get_install_skip($skip,$verbose);
- $always_copy = $ENV{EU_INSTALL_ALWAYS_COPY}
- || $ENV{EU_ALWAYS_COPY}
- || 0
- unless defined $always_copy;
-
- my(%from_to) = %$from_to;
- my(%pack, $dir, %warned);
- my($packlist) = ExtUtils::Packlist->new();
-
- local(*DIR);
- for (qw/read write/) {
- $pack{$_}=$from_to{$_};
- delete $from_to{$_};
- }
- my $tmpfile = install_rooted_file($pack{"read"});
- $packlist->read($tmpfile) if (-f $tmpfile);
- my $cwd = cwd();
- my @found_files;
- my %check_dirs;
-
- MOD_INSTALL: foreach my $source (sort keys %from_to) {
- #copy the tree to the target directory without altering
- #timestamp and permission and remember for the .packlist
- #file. The packlist file contains the absolute paths of the
- #install locations. AFS users may call this a bug. We'll have
- #to reconsider how to add the means to satisfy AFS users also.
-
- #October 1997: we want to install .pm files into archlib if
- #there are any files in arch. So we depend on having ./blib/arch
- #hardcoded here.
-
- my $targetroot = install_rooted_dir($from_to{$source});
-
- my $blib_lib = File::Spec->catdir('blib', 'lib');
- my $blib_arch = File::Spec->catdir('blib', 'arch');
- if ($source eq $blib_lib and
- exists $from_to{$blib_arch} and
- directory_not_empty($blib_arch)
- ){
- $targetroot = install_rooted_dir($from_to{$blib_arch});
- print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n";
- }
-
- next unless -d $source;
- _chdir($source);
- # 5.5.3's File::Find missing no_chdir option
- # XXX OS-SPECIFIC
- # File::Find seems to always be Unixy except on MacPerl :(
- my $current_directory= $Is_MacPerl ? $Curdir : '.';
- find(sub {
- my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9];
-
- return if !-f _;
- my $origfile = $_;
-
- return if $origfile eq ".exists";
- my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir);
- my $targetfile = File::Spec->catfile($targetdir, $origfile);
- my $sourcedir = File::Spec->catdir($source, $File::Find::dir);
- my $sourcefile = File::Spec->catfile($sourcedir, $origfile);
-
- for my $pat (@$skip) {
- if ( $sourcefile=~/$pat/ ) {
- print "Skipping $targetfile (filtered)\n"
- if $verbose>1;
- $result->{install_filtered}{$sourcefile} = $pat;
- return;
- }
- }
- # we have to do this for back compat with old File::Finds
- # and because the target is relative
- my $save_cwd = _chdir($cwd);
- my $diff = 0;
- # XXX: I wonder how useful this logic is actually -- demerphq
- if ( $always_copy or !-f $targetfile or -s $targetfile != $size) {
- $diff++;
- } else {
- # we might not need to copy this file
- $diff = compare($sourcefile, $targetfile);
- }
- $check_dirs{$targetdir}++
- unless -w $targetfile;
-
- push @found_files,
- [ $diff, $File::Find::dir, $origfile,
- $mode, $size, $atime, $mtime,
- $targetdir, $targetfile, $sourcedir, $sourcefile,
-
- ];
- #restore the original directory we were in when File::Find
- #called us so that it doesnt get horribly confused.
- _chdir($save_cwd);
- }, $current_directory );
- _chdir($cwd);
- }
- foreach my $targetdir (sort keys %check_dirs) {
- _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
- }
- foreach my $found (@found_files) {
- my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime,
- $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found;
-
- my $realtarget= $targetfile;
- if ($diff) {
- eval {
- if (-f $targetfile) {
- print "_unlink_or_rename($targetfile)\n" if $verbose>1;
- $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' )
- unless $dry_run;
- } elsif ( ! -d $targetdir ) {
- _mkpath( $targetdir, 0, 0755, $verbose, $dry_run );
- }
- print "Installing $targetfile\n";
-
- _copy( $sourcefile, $targetfile, $verbose, $dry_run, );
-
-
- #XXX OS-SPECIFIC
- print "utime($atime,$mtime,$targetfile)\n" if $verbose>1;
- utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1;
-
-
- $mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
- $mode = $mode | 0222
- if $realtarget ne $targetfile;
- _chmod( $mode, $targetfile, $verbose );
- $result->{install}{$targetfile} = $sourcefile;
- 1
- } or do {
- $result->{install_fail}{$targetfile} = $sourcefile;
- die $@;
- };
- } else {
- $result->{install_unchanged}{$targetfile} = $sourcefile;
- print "Skipping $targetfile (unchanged)\n" if $verbose;
- }
-
- if ( $uninstall_shadows ) {
- inc_uninstall($sourcefile,$ffd, $verbose,
- $dry_run,
- $realtarget ne $targetfile ? $realtarget : "",
- $result);
- }
-
- # Record the full pathname.
- $packlist->{$targetfile}++;
- }
-
- if ($pack{'write'}) {
- $dir = install_rooted_dir(dirname($pack{'write'}));
- _mkpath( $dir, 0, 0755, $verbose, $dry_run );
- print "Writing $pack{'write'}\n" if $verbose;
- $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run;
- }
-
- _do_cleanup($verbose);
- return $result;
-}
-
-=begin _private
-
-=item _do_cleanup
-
-Standardize finish event for after another instruction has occured.
-Handles converting $MUST_REBOOT to a die for instance.
-
-=end _private
-
-=cut
-
-sub _do_cleanup {
- my ($verbose) = @_;
- if ($MUST_REBOOT) {
- die _estr "Operation not completed! ",
- "You must reboot to complete the installation.",
- "Sorry.";
- } elsif (defined $MUST_REBOOT & $verbose) {
- warn _estr "Installation will be completed at the next reboot.\n",
- "However it is not necessary to reboot immediately.\n";
- }
-}
-
-=begin _undocumented
-
-=item install_rooted_file( $file )
-
-Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT
-is defined.
-
-=item install_rooted_dir( $dir )
-
-Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT
-is defined.
-
-=end _undocumented
-
-=cut
-
-
-sub install_rooted_file {
- if (defined $INSTALL_ROOT) {
- File::Spec->catfile($INSTALL_ROOT, $_[0]);
- } else {
- $_[0];
- }
-}
-
-
-sub install_rooted_dir {
- if (defined $INSTALL_ROOT) {
- File::Spec->catdir($INSTALL_ROOT, $_[0]);
- } else {
- $_[0];
- }
-}
-
-=begin _undocumented
-
-=item forceunlink( $file, $tryhard )
-
-Tries to delete a file. If $tryhard is true then we will use whatever
-devious tricks we can to delete the file. Currently this only applies to
-Win32 in that it will try to use Win32API::File to schedule a delete at
-reboot. A wrapper for _unlink_or_rename().
-
-=end _undocumented
-
-=cut
-
-
-sub forceunlink {
- my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC
- _unlink_or_rename( $file, $tryhard, not("installing") );
-}
-
-=begin _undocumented
-
-=item directory_not_empty( $dir )
-
-Returns 1 if there is an .exists file somewhere in a directory tree.
-Returns 0 if there is not.
-
-=end _undocumented
-
-=cut
-
-sub directory_not_empty ($) {
- my($dir) = @_;
- my $files = 0;
- find(sub {
- return if $_ eq ".exists";
- if (-f) {
- $File::Find::prune++;
- $files = 1;
- }
- }, $dir);
- return $files;
-}
-
-=pod
-
-=item B<install_default> I<DISCOURAGED>
-
- install_default();
- install_default($fullext);
-
-Calls install() with arguments to copy a module from blib/ to the
-default site installation location.
-
-$fullext is the name of the module converted to a directory
-(ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it
-will attempt to read it from @ARGV.
-
-This is primarily useful for install scripts.
-
-B<NOTE> This function is not really useful because of the hard-coded
-install location with no way to control site vs core vs vendor
-directories and the strange way in which the module name is given.
-Consider its use discouraged.
-
-=cut
-
-sub install_default {
- @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument");
- my $FULLEXT = @_ ? shift : $ARGV[0];
- defined $FULLEXT or die "Do not know to where to write install log";
- my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib");
- my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch");
- my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin');
- my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script');
- my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1');
- my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3');
-
- my @INST_HTML;
- if($Config{installhtmldir}) {
- my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html');
- @INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir});
- }
-
- install({
- read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist",
- write => "$Config{installsitearch}/auto/$FULLEXT/.packlist",
- $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ?
- $Config{installsitearch} :
- $Config{installsitelib},
- $INST_ARCHLIB => $Config{installsitearch},
- $INST_BIN => $Config{installbin} ,
- $INST_SCRIPT => $Config{installscript},
- $INST_MAN1DIR => $Config{installman1dir},
- $INST_MAN3DIR => $Config{installman3dir},
- @INST_HTML,
- },1,0,0);
-}
-
-
-=item B<uninstall>
-
- uninstall($packlist_file);
- uninstall($packlist_file, $verbose, $dont_execute);
-
-Removes the files listed in a $packlist_file.
-
-If $verbose is true, will print out each file removed. Default is
-false.
-
-If $dont_execute is true it will only print what it was going to do
-without actually doing it. Default is false.
-
-=cut
-
-sub uninstall {
- my($fil,$verbose,$dry_run) = @_;
- $verbose ||= 0;
- $dry_run ||= 0;
-
- die _estr "ERROR: no packlist file found: '$fil'"
- unless -f $fil;
- # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
- # require $my_req; # Hairy, but for the first
- my ($packlist) = ExtUtils::Packlist->new($fil);
- foreach (sort(keys(%$packlist))) {
- chomp;
- print "unlink $_\n" if $verbose;
- forceunlink($_,'tryhard') unless $dry_run;
- }
- print "unlink $fil\n" if $verbose;
- forceunlink($fil, 'tryhard') unless $dry_run;
- _do_cleanup($verbose);
-}
-
-=begin _undocumented
-
-=item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results)
-
-Remove shadowed files. If $ignore is true then it is assumed to hold
-a filename to ignore. This is used to prevent spurious warnings from
-occuring when doing an install at reboot.
-
-We now only die when failing to remove a file that has precedence over
-our own, when our install has precedence we only warn.
-
-$results is assumed to contain a hashref which will have the keys
-'uninstall' and 'uninstall_fail' populated with keys for the files
-removed and values of the source files they would shadow.
-
-=end _undocumented
-
-=cut
-
-sub inc_uninstall {
- my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_;
- my($dir);
- $ignore||="";
- my $file = (File::Spec->splitpath($filepath))[2];
- my %seen_dir = ();
-
- my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'}
- ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || '';
-
- my @dirs=( @PERL_ENV_LIB,
- @INC,
- @Config{qw(archlibexp
- privlibexp
- sitearchexp
- sitelibexp)});
-
- #warn join "\n","---", at dirs,"---";
- my $seen_ours;
- foreach $dir ( @dirs ) {
- my $canonpath = $Is_VMS ? $dir : File::Spec->canonpath($dir);
- next if $canonpath eq $Curdir;
- next if $seen_dir{$canonpath}++;
- my $targetfile = File::Spec->catfile($canonpath,$libdir,$file);
- next unless -f $targetfile;
-
- # The reason why we compare file's contents is, that we cannot
- # know, which is the file we just installed (AFS). So we leave
- # an identical file in place
- my $diff = 0;
- if ( -f $targetfile && -s _ == -s $filepath) {
- # We have a good chance, we can skip this one
- $diff = compare($filepath,$targetfile);
- } else {
- $diff++;
- }
- print "#$file and $targetfile differ\n" if $diff && $verbose > 1;
-
- if (!$diff or $targetfile eq $ignore) {
- $seen_ours = 1;
- next;
- }
- if ($dry_run) {
- $results->{uninstall}{$targetfile} = $filepath;
- if ($verbose) {
- $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new();
- $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier.
- $Inc_uninstall_warn_handler->add(
- File::Spec->catfile($libdir, $file),
- $targetfile
- );
- }
- # if not verbose, we just say nothing
- } else {
- print "Unlinking $targetfile (shadowing?)\n" if $verbose;
- eval {
- die "Fake die for testing"
- if $ExtUtils::Install::Testing and
- ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile);
- forceunlink($targetfile,'tryhard');
- $results->{uninstall}{$targetfile} = $filepath;
- 1;
- } or do {
- $results->{fail_uninstall}{$targetfile} = $filepath;
- if ($seen_ours) {
- warn "Failed to remove probably harmless shadow file '$targetfile'\n";
- } else {
- die "$@\n";
- }
- };
- }
- }
-}
-
-=begin _undocumented
-
-=item run_filter($cmd,$src,$dest)
-
-Filter $src using $cmd into $dest.
-
-=end _undocumented
-
-=cut
-
-sub run_filter {
- my ($cmd, $src, $dest) = @_;
- local(*CMD, *SRC);
- open(CMD, "|$cmd >$dest") || die "Cannot fork: $!";
- open(SRC, $src) || die "Cannot open $src: $!";
- my $buf;
- my $sz = 1024;
- while (my $len = sysread(SRC, $buf, $sz)) {
- syswrite(CMD, $buf, $len);
- }
- close SRC;
- close CMD or die "Filter command '$cmd' failed for $src";
-}
-
-=pod
-
-=item B<pm_to_blib>
-
- pm_to_blib(\%from_to, $autosplit_dir);
- pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd);
-
-Copies each key of %from_to to its corresponding value efficiently.
-Filenames with the extension .pm are autosplit into the $autosplit_dir.
-Any destination directories are created.
-
-$filter_cmd is an optional shell command to run each .pm file through
-prior to splitting and copying. Input is the contents of the module,
-output the new module contents.
-
-You can have an environment variable PERL_INSTALL_ROOT set which will
-be prepended as a directory to each installed file (and directory).
-
-=cut
-
-sub pm_to_blib {
- my($fromto,$autodir,$pm_filter) = @_;
-
- _mkpath($autodir,0,0755);
- while(my($from, $to) = each %$fromto) {
- if( -f $to && -s $from == -s $to && -M $to < -M $from ) {
- print "Skip $to (unchanged)\n";
- next;
- }
-
- # When a pm_filter is defined, we need to pre-process the source first
- # to determine whether it has changed or not. Therefore, only perform
- # the comparison check when there's no filter to be ran.
- # -- RAM, 03/01/2001
-
- my $need_filtering = defined $pm_filter && length $pm_filter &&
- $from =~ /\.pm$/;
-
- if (!$need_filtering && 0 == compare($from,$to)) {
- print "Skip $to (unchanged)\n";
- next;
- }
- if (-f $to){
- # we wont try hard here. its too likely to mess things up.
- forceunlink($to);
- } else {
- _mkpath(dirname($to),0,0755);
- }
- if ($need_filtering) {
- run_filter($pm_filter, $from, $to);
- print "$pm_filter <$from >$to\n";
- } else {
- _copy( $from, $to );
- print "cp $from $to\n";
- }
- my($mode,$atime,$mtime) = (stat $from)[2,8,9];
- utime($atime,$mtime+$Is_VMS,$to);
- _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to);
- next unless $from =~ /\.pm$/;
- _autosplit($to,$autodir);
- }
-}
-
-
-=begin _private
-
-=item _autosplit
-
-From 1.0307 back, AutoSplit will sometimes leave an open filehandle to
-the file being split. This causes problems on systems with mandatory
-locking (ie. Windows). So we wrap it and close the filehandle.
-
-=end _private
-
-=cut
-
-sub _autosplit { #XXX OS-SPECIFIC
- my $retval = autosplit(@_);
- close *AutoSplit::IN if defined *AutoSplit::IN{IO};
-
- return $retval;
-}
-
-
-package ExtUtils::Install::Warn;
-
-sub new { bless {}, shift }
-
-sub add {
- my($self,$file,$targetfile) = @_;
- push @{$self->{$file}}, $targetfile;
-}
-
-sub DESTROY {
- unless(defined $INSTALL_ROOT) {
- my $self = shift;
- my($file,$i,$plural);
- foreach $file (sort keys %$self) {
- $plural = @{$self->{$file}} > 1 ? "s" : "";
- print "## Differing version$plural of $file found. You might like to\n";
- for (0..$#{$self->{$file}}) {
- print "rm ", $self->{$file}[$_], "\n";
- $i++;
- }
- }
- $plural = $i>1 ? "all those files" : "this file";
- my $inst = (_invokant() eq 'ExtUtils::MakeMaker')
- ? ( $Config::Config{make} || 'make' ).' install'
- . ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' )
- : './Build install uninst=1';
- print "## Running '$inst' will unlink $plural for you.\n";
- }
-}
-
-=begin _private
-
-=item _invokant
-
-Does a heuristic on the stack to see who called us for more intelligent
-error messages. Currently assumes we will be called only by Module::Build
-or by ExtUtils::MakeMaker.
-
-=end _private
-
-=cut
-
-sub _invokant {
- my @stack;
- my $frame = 0;
- while (my $file = (caller($frame++))[1]) {
- push @stack, (File::Spec->splitpath($file))[2];
- }
-
- my $builder;
- my $top = pop @stack;
- if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) {
- $builder = 'Module::Build';
- } else {
- $builder = 'ExtUtils::MakeMaker';
- }
- return $builder;
-}
-
-=pod
-
-=back
-
-=head1 ENVIRONMENT
-
-=over 4
-
-=item B<PERL_INSTALL_ROOT>
-
-Will be prepended to each install path.
-
-=item B<EU_INSTALL_IGNORE_SKIP>
-
-Will prevent the automatic use of INSTALL.SKIP as the install skip file.
-
-=item B<EU_INSTALL_SITE_SKIPFILE>
-
-If there is no INSTALL.SKIP file in the make directory then this value
-can be used to provide a default.
-
-=item B<EU_INSTALL_ALWAYS_COPY>
-
-If this environment variable is true then normal install processes will
-always overwrite older identical files during the install process.
-
-Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY
-is not defined until at least the 1.50 release. Please ensure you use the
-correct EU_INSTALL_ALWAYS_COPY.
-
-=back
-
-=head1 AUTHOR
-
-Original author lost in the mists of time. Probably the same as Makemaker.
-
-Production release currently maintained by demerphq C<yves at cpan.org>,
-extensive changes by Michael G. Schwern.
-
-Send bug reports via http://rt.cpan.org/. Please send your
-generated Makefile along with your report.
-
-=head1 LICENSE
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See L<http://www.perl.com/perl/misc/Artistic.html>
-
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/Installed.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Installed.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/Installed.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,462 +0,0 @@
-package ExtUtils::Installed;
-
-use 5.00503;
-use strict;
-#use warnings; # XXX requires 5.6
-use Carp qw();
-use ExtUtils::Packlist;
-use ExtUtils::MakeMaker;
-use Config;
-use File::Find;
-use File::Basename;
-use File::Spec;
-
-my $Is_VMS = $^O eq 'VMS';
-my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
-
-require VMS::Filespec if $Is_VMS;
-
-use vars qw($VERSION);
-$VERSION = '1.999_001';
-$VERSION = eval $VERSION;
-
-sub _is_prefix {
- my ($self, $path, $prefix) = @_;
- return unless defined $prefix && defined $path;
-
- if( $Is_VMS ) {
- $prefix = VMS::Filespec::unixify($prefix);
- $path = VMS::Filespec::unixify($path);
- }
-
- # Unix path normalization.
- $prefix = File::Spec->canonpath($prefix);
-
- return 1 if substr($path, 0, length($prefix)) eq $prefix;
-
- if ($DOSISH) {
- $path =~ s|\\|/|g;
- $prefix =~ s|\\|/|g;
- return 1 if $path =~ m{^\Q$prefix\E}i;
- }
- return(0);
-}
-
-sub _is_doc {
- my ($self, $path) = @_;
-
- my $man1dir = $self->{':private:'}{Config}{man1direxp};
- my $man3dir = $self->{':private:'}{Config}{man3direxp};
- return(($man1dir && $self->_is_prefix($path, $man1dir))
- ||
- ($man3dir && $self->_is_prefix($path, $man3dir))
- ? 1 : 0)
-}
-
-sub _is_type {
- my ($self, $path, $type) = @_;
- return 1 if $type eq "all";
-
- return($self->_is_doc($path)) if $type eq "doc";
- my $conf= $self->{':private:'}{Config};
- if ($type eq "prog") {
- return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp})
- && !($self->_is_doc($path)) ? 1 : 0);
- }
- return(0);
-}
-
-sub _is_under {
- my ($self, $path, @under) = @_;
- $under[0] = "" if (! @under);
- foreach my $dir (@under) {
- return(1) if ($self->_is_prefix($path, $dir));
- }
-
- return(0);
-}
-
-sub _fix_dirs {
- my ($self, @dirs)= @_;
- # File::Find does not know how to deal with VMS filepaths.
- if( $Is_VMS ) {
- $_ = VMS::Filespec::unixify($_)
- for @dirs;
- }
-
- if ($DOSISH) {
- s|\\|/|g for @dirs;
- }
- return wantarray ? @dirs : $dirs[0];
-}
-
-sub _make_entry {
- my ($self, $module, $packlist_file, $modfile)= @_;
-
- my $data= {
- module => $module,
- packlist => scalar(ExtUtils::Packlist->new($packlist_file)),
- packlist_file => $packlist_file,
- };
-
- if (!$modfile) {
- $data->{version} = $self->{':private:'}{Config}{version};
- } else {
- $data->{modfile} = $modfile;
- # Find the top-level module file in @INC
- $data->{version} = '';
- foreach my $dir (@{$self->{':private:'}{INC}}) {
- my $p = File::Spec->catfile($dir, $modfile);
- if (-r $p) {
- $module = _module_name($p, $module) if $Is_VMS;
-
- $data->{version} = MM->parse_version($p);
- $data->{version_from} = $p;
- $data->{packlist_valid} = exists $data->{packlist}{$p};
- last;
- }
- }
- }
- $self->{$module}= $data;
-}
-
-our $INSTALLED;
-sub new {
- my ($class) = shift(@_);
- $class = ref($class) || $class;
-
- my %args = @_;
-
- return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default});
-
- my $self = bless {}, $class;
-
- $INSTALLED= $self if $args{default_set} || $args{default};
-
-
- if ($args{config_override}) {
- eval {
- $self->{':private:'}{Config} = { %{$args{config_override}} };
- } or Carp::croak(
- "The 'config_override' parameter must be a hash reference."
- );
- }
- else {
- $self->{':private:'}{Config} = \%Config;
- }
-
- for my $tuple ([inc_override => INC => [ @INC ] ],
- [ extra_libs => EXTRA => [] ])
- {
- my ($arg,$key,$val)=@$tuple;
- if ( $args{$arg} ) {
- eval {
- $self->{':private:'}{$key} = [ @{$args{$arg}} ];
- } or Carp::croak(
- "The '$arg' parameter must be an array reference."
- );
- }
- elsif ($val) {
- $self->{':private:'}{$key} = $val;
- }
- }
- {
- my %dupe;
- @{$self->{':private:'}{LIBDIRS}} = grep { -e $_ && !$dupe{$_}++ }
- @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}};
- }
-
- my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}});
-
- # Read the core packlist
- my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp});
- $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist'));
-
- my $root;
- # Read the module packlists
- my $sub = sub {
- # Only process module .packlists
- return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
-
- # Hack of the leading bits of the paths & convert to a module name
- my $module = $File::Find::name;
- my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s
- or do {
- # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n",
- # join ("\n", at dirs);
- return;
- };
-
- my $modfile = "$module.pm";
- $module =~ s!/!::!g;
-
- return if $self->{$module}; #shadowing?
- $self->_make_entry($module,$File::Find::name,$modfile);
- };
- while (@dirs) {
- $root= shift @dirs;
- next if !-d $root;
- find($sub,$root);
- }
-
- return $self;
-}
-
-# VMS's non-case preserving file-system means the package name can't
-# be reconstructed from the filename.
-sub _module_name {
- my($file, $orig_module) = @_;
-
- my $module = '';
- if (open PACKFH, $file) {
- while (<PACKFH>) {
- if (/package\s+(\S+)\s*;/) {
- my $pack = $1;
- # Make a sanity check, that lower case $module
- # is identical to lowercase $pack before
- # accepting it
- if (lc($pack) eq lc($orig_module)) {
- $module = $pack;
- last;
- }
- }
- }
- close PACKFH;
- }
-
- print STDERR "Couldn't figure out the package name for $file\n"
- unless $module;
-
- return $module;
-}
-
-sub modules {
- my ($self) = @_;
- $self= $self->new(default=>1) if !ref $self;
-
- # Bug/feature of sort in scalar context requires this.
- return wantarray
- ? sort grep { not /^:private:$/ } keys %$self
- : grep { not /^:private:$/ } keys %$self;
-}
-
-sub files {
- my ($self, $module, $type, @under) = @_;
- $self= $self->new(default=>1) if !ref $self;
-
- # Validate arguments
- Carp::croak("$module is not installed") if (! exists($self->{$module}));
- $type = "all" if (! defined($type));
- Carp::croak('type must be "all", "prog" or "doc"')
- if ($type ne "all" && $type ne "prog" && $type ne "doc");
-
- my (@files);
- foreach my $file (keys(%{$self->{$module}{packlist}})) {
- push(@files, $file)
- if ($self->_is_type($file, $type) &&
- $self->_is_under($file, @under));
- }
- return(@files);
-}
-
-sub directories {
- my ($self, $module, $type, @under) = @_;
- $self= $self->new(default=>1) if !ref $self;
- my (%dirs);
- foreach my $file ($self->files($module, $type, @under)) {
- $dirs{dirname($file)}++;
- }
- return sort keys %dirs;
-}
-
-sub directory_tree {
- my ($self, $module, $type, @under) = @_;
- $self= $self->new(default=>1) if !ref $self;
- my (%dirs);
- foreach my $dir ($self->directories($module, $type, @under)) {
- $dirs{$dir}++;
- my ($last) = ("");
- while ($last ne $dir) {
- $last = $dir;
- $dir = dirname($dir);
- last if !$self->_is_under($dir, @under);
- $dirs{$dir}++;
- }
- }
- return(sort(keys(%dirs)));
-}
-
-sub validate {
- my ($self, $module, $remove) = @_;
- $self= $self->new(default=>1) if !ref $self;
- Carp::croak("$module is not installed") if (! exists($self->{$module}));
- return($self->{$module}{packlist}->validate($remove));
-}
-
-sub packlist {
- my ($self, $module) = @_;
- $self= $self->new(default=>1) if !ref $self;
- Carp::croak("$module is not installed") if (! exists($self->{$module}));
- return($self->{$module}{packlist});
-}
-
-sub version {
- my ($self, $module) = @_;
- $self= $self->new(default=>1) if !ref $self;
- Carp::croak("$module is not installed") if (! exists($self->{$module}));
- return($self->{$module}{version});
-}
-
-sub debug_dump {
- my ($self, $module) = @_;
- $self= $self->new(default=>1) if !ref $self;
- local $self->{":private:"}{Config};
- require Data::Dumper;
- print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump();
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-ExtUtils::Installed - Inventory management of installed modules
-
-=head1 SYNOPSIS
-
- use ExtUtils::Installed;
- my ($inst) = ExtUtils::Installed->new();
- my (@modules) = $inst->modules();
- my (@missing) = $inst->validate("DBI");
- my $all_files = $inst->files("DBI");
- my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local");
- my $all_dirs = $inst->directories("DBI");
- my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog");
- my $packlist = $inst->packlist("DBI");
-
-=head1 DESCRIPTION
-
-ExtUtils::Installed provides a standard way to find out what core and module
-files have been installed. It uses the information stored in .packlist files
-created during installation to provide this information. In addition it
-provides facilities to classify the installed files and to extract directory
-information from the .packlist files.
-
-=head1 USAGE
-
-The new() function searches for all the installed .packlists on the system, and
-stores their contents. The .packlists can be queried with the functions
-described below. Where it searches by default is determined by the settings found
-in C<%Config::Config>, and what the value is of the PERL5LIB environment variable.
-
-=head1 METHODS
-
-Unless specified otherwise all method can be called as class methods, or as object
-methods. If called as class methods then the "default" object will be used, and if
-necessary created using the current processes %Config and @INC. See the
-'default' option to new() for details.
-
-
-=over 4
-
-=item new()
-
-This takes optional named parameters. Without parameters, this
-searches for all the installed .packlists on the system using
-information from C<%Config::Config> and the default module search
-paths C<@INC>. The packlists are read using the
-L<ExtUtils::Packlist> module.
-
-If the named parameter C<config_override> is specified,
-it should be a reference to a hash which contains all information
-usually found in C<%Config::Config>. For example, you can obtain
-the configuration information for a separate perl installation and
-pass that in.
-
- my $yoda_cfg = get_fake_config('yoda');
- my $yoda_inst = ExtUtils::Installed->new(config_override=>$yoda_cfg);
-
-Similarly, the parameter C<inc_override> may be a reference to an
-array which is used in place of the default module search paths
-from C<@INC>.
-
- use Config;
- my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB});
- my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs);
-
-B<Note>: You probably do not want to use these options alone, almost always
-you will want to set both together.
-
-The parameter c<extra_libs> can be used to specify B<additional> paths to
-search for installed modules. For instance
-
- my $installed = ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]);
-
-This should only be necessary if C</my/lib/path> is not in PERL5LIB.
-
-Finally there is the 'default', and the related 'default_get' and 'default_set'
-options. These options control the "default" object which is provided by the
-class interface to the methods. Setting C<default_get> to true tells the constructor
-to return the default object if it is defined. Setting C<default_set> to true tells
-the constructor to make the default object the constructed object. Setting the
-C<default> option is like setting both to true. This is used primarily internally
-and probably isn't interesting to any real user.
-
-=item modules()
-
-This returns a list of the names of all the installed modules. The perl 'core'
-is given the special name 'Perl'.
-
-=item files()
-
-This takes one mandatory parameter, the name of a module. It returns a list of
-all the filenames from the package. To obtain a list of core perl files, use
-the module name 'Perl'. Additional parameters are allowed. The first is one
-of the strings "prog", "doc" or "all", to select either just program files,
-just manual files or all files. The remaining parameters are a list of
-directories. The filenames returned will be restricted to those under the
-specified directories.
-
-=item directories()
-
-This takes one mandatory parameter, the name of a module. It returns a list of
-all the directories from the package. Additional parameters are allowed. The
-first is one of the strings "prog", "doc" or "all", to select either just
-program directories, just manual directories or all directories. The remaining
-parameters are a list of directories. The directories returned will be
-restricted to those under the specified directories. This method returns only
-the leaf directories that contain files from the specified module.
-
-=item directory_tree()
-
-This is identical in operation to directories(), except that it includes all the
-intermediate directories back up to the specified directories.
-
-=item validate()
-
-This takes one mandatory parameter, the name of a module. It checks that all
-the files listed in the modules .packlist actually exist, and returns a list of
-any missing files. If an optional second argument which evaluates to true is
-given any missing files will be removed from the .packlist
-
-=item packlist()
-
-This returns the ExtUtils::Packlist object for the specified module.
-
-=item version()
-
-This returns the version number for the specified module.
-
-=back
-
-=head1 EXAMPLE
-
-See the example in L<ExtUtils::Packlist>.
-
-=head1 AUTHOR
-
-Alan Burlison <Alan.Burlison at uk.sun.com>
-
-=cut
Deleted: trunk/contrib/perl/lib/ExtUtils/Liblist.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Liblist.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/Liblist.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,286 +0,0 @@
-package ExtUtils::Liblist;
-
-use strict;
-
-our $VERSION = '6.55_02';
-
-use File::Spec;
-require ExtUtils::Liblist::Kid;
-our @ISA = qw(ExtUtils::Liblist::Kid File::Spec);
-
-# Backwards compatibility with old interface.
-sub ext {
- goto &ExtUtils::Liblist::Kid::ext;
-}
-
-sub lsdir {
- shift;
- my $rex = qr/$_[1]/;
- opendir DIR, $_[0];
- my @out = grep /$rex/, readdir DIR;
- closedir DIR;
- return @out;
-}
-
-__END__
-
-=head1 NAME
-
-ExtUtils::Liblist - determine libraries to use and how to use them
-
-=head1 SYNOPSIS
-
- require ExtUtils::Liblist;
-
- $MM->ext($potential_libs, $verbose, $need_names);
-
- # Usually you can get away with:
- ExtUtils::Liblist->ext($potential_libs, $verbose, $need_names)
-
-=head1 DESCRIPTION
-
-This utility takes a list of libraries in the form C<-llib1 -llib2
--llib3> and returns lines suitable for inclusion in an extension
-Makefile. Extra library paths may be included with the form
-C<-L/another/path> this will affect the searches for all subsequent
-libraries.
-
-It returns an array of four or five scalar values: EXTRALIBS,
-BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to
-the array of the filenames of actual libraries. Some of these don't
-mean anything unless on Unix. See the details about those platform
-specifics below. The list of the filenames is returned only if
-$need_names argument is true.
-
-Dependent libraries can be linked in one of three ways:
-
-=over 2
-
-=item * For static extensions
-
-by the ld command when the perl binary is linked with the extension
-library. See EXTRALIBS below.
-
-=item * For dynamic extensions at build/link time
-
-by the ld command when the shared object is built/linked. See
-LDLOADLIBS below.
-
-=item * For dynamic extensions at load time
-
-by the DynaLoader when the shared object is loaded. See BSLOADLIBS
-below.
-
-=back
-
-=head2 EXTRALIBS
-
-List of libraries that need to be linked with when linking a perl
-binary which includes this extension. Only those libraries that
-actually exist are included. These are written to a file and used
-when linking perl.
-
-=head2 LDLOADLIBS and LD_RUN_PATH
-
-List of those libraries which can or must be linked into the shared
-library when created using ld. These may be static or dynamic
-libraries. LD_RUN_PATH is a colon separated list of the directories
-in LDLOADLIBS. It is passed as an environment variable to the process
-that links the shared library.
-
-=head2 BSLOADLIBS
-
-List of those libraries that are needed but can be linked in
-dynamically at run time on this platform. SunOS/Solaris does not need
-this because ld records the information (from LDLOADLIBS) into the
-object file. This list is used to create a .bs (bootstrap) file.
-
-=head1 PORTABILITY
-
-This module deals with a lot of system dependencies and has quite a
-few architecture specific C<if>s in the code.
-
-=head2 VMS implementation
-
-The version of ext() which is executed under VMS differs from the
-Unix-OS/2 version in several respects:
-
-=over 2
-
-=item *
-
-Input library and path specifications are accepted with or without the
-C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is
-present, a token is considered a directory to search if it is in fact
-a directory, and a library to search for otherwise. Authors who wish
-their extensions to be portable to Unix or OS/2 should use the Unix
-prefixes, since the Unix-OS/2 version of ext() requires them.
-
-=item *
-
-Wherever possible, shareable images are preferred to object libraries,
-and object libraries to plain object files. In accordance with VMS
-naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl;
-it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions
-used in some ported software.
-
-=item *
-
-For each library that is found, an appropriate directive for a linker options
-file is generated. The return values are space-separated strings of
-these directives, rather than elements used on the linker command line.
-
-=item *
-
-LDLOADLIBS contains both the libraries found based on C<$potential_libs> and
-the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those
-libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH
-are always empty.
-
-=back
-
-In addition, an attempt is made to recognize several common Unix library
-names, and filter them out or convert them to their VMS equivalents, as
-appropriate.
-
-In general, the VMS version of ext() should properly handle input from
-extensions originally designed for a Unix or VMS environment. If you
-encounter problems, or discover cases where the search could be improved,
-please let us know.
-
-=head2 Win32 implementation
-
-The version of ext() which is executed under Win32 differs from the
-Unix-OS/2 version in several respects:
-
-=over 2
-
-=item *
-
-If C<$potential_libs> is empty, the return value will be empty.
-Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm)
-will be appended to the list of C<$potential_libs>. The libraries
-will be searched for in the directories specified in C<$potential_libs>,
-C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>.
-For each library that is found, a space-separated list of fully qualified
-library pathnames is generated.
-
-=item *
-
-Input library and path specifications are accepted with or without the
-C<-l> and C<-L> prefixes used by Unix linkers.
-
-An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look
-for the libraries that follow.
-
-An entry of the form C<-lfoo> specifies the library C<foo>, which may be
-spelled differently depending on what kind of compiler you are using. If
-you are using GCC, it gets translated to C<libfoo.a>, but for other win32
-compilers, it becomes C<foo.lib>. If no files are found by those translated
-names, one more attempt is made to find them using either C<foo.a> or
-C<libfoo.lib>, depending on whether GCC or some other win32 compiler is
-being used, respectively.
-
-If neither the C<-L> or C<-l> prefix is present in an entry, the entry is
-considered a directory to search if it is in fact a directory, and a
-library to search for otherwise. The C<$Config{lib_ext}> suffix will
-be appended to any entries that are not directories and don't already have
-the suffix.
-
-Note that the C<-L> and C<-l> prefixes are B<not required>, but authors
-who wish their extensions to be portable to Unix or OS/2 should use the
-prefixes, since the Unix-OS/2 version of ext() requires them.
-
-=item *
-
-Entries cannot be plain object files, as many Win32 compilers will
-not handle object files in the place of libraries.
-
-=item *
-
-Entries in C<$potential_libs> beginning with a colon and followed by
-alphanumeric characters are treated as flags. Unknown flags will be ignored.
-
-An entry that matches C</:nodefault/i> disables the appending of default
-libraries found in C<$Config{perllibs}> (this should be only needed very rarely).
-
-An entry that matches C</:nosearch/i> disables all searching for
-the libraries specified after it. Translation of C<-Lfoo> and
-C<-lfoo> still happens as appropriate (depending on compiler being used,
-as reflected by C<$Config{cc}>), but the entries are not verified to be
-valid files or directories.
-
-An entry that matches C</:search/i> reenables searching for
-the libraries specified after it. You can put it at the end to
-enable searching for default libraries specified by C<$Config{perllibs}>.
-
-=item *
-
-The libraries specified may be a mixture of static libraries and
-import libraries (to link with DLLs). Since both kinds are used
-pretty transparently on the Win32 platform, we do not attempt to
-distinguish between them.
-
-=item *
-
-LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS
-and LD_RUN_PATH are always empty (this may change in future).
-
-=item *
-
-You must make sure that any paths and path components are properly
-surrounded with double-quotes if they contain spaces. For example,
-C<$potential_libs> could be (literally):
-
- "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib"
-
-Note how the first and last entries are protected by quotes in order
-to protect the spaces.
-
-=item *
-
-Since this module is most often used only indirectly from extension
-C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add
-a library to the build process for an extension:
-
- LIBS => ['-lgl']
-
-When using GCC, that entry specifies that MakeMaker should first look
-for C<libgl.a> (followed by C<gl.a>) in all the locations specified by
-C<$Config{libpth}>.
-
-When using a compiler other than GCC, the above entry will search for
-C<gl.lib> (followed by C<libgl.lib>).
-
-If the library happens to be in a location not in C<$Config{libpth}>,
-you need:
-
- LIBS => ['-Lc:\gllibs -lgl']
-
-Here is a less often used example:
-
- LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32']
-
-This specifies a search for library C<gl> as before. If that search
-fails to find the library, it looks at the next item in the list. The
-C<:nosearch> flag will prevent searching for the libraries that follow,
-so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>,
-since GCC can use that value as is with its linker.
-
-When using the Visual C compiler, the second item is returned as
-C<-libpath:d:\mesalibs mesa.lib user32.lib>.
-
-When using the Borland compiler, the second item is returned as
-C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of
-moving the C<-Ld:\mesalibs> to the correct place in the linker
-command line.
-
-=back
-
-
-=head1 SEE ALSO
-
-L<ExtUtils::MakeMaker>
-
-=cut
-
Deleted: trunk/contrib/perl/lib/ExtUtils/MANIFEST.SKIP
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MANIFEST.SKIP 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MANIFEST.SKIP 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,32 +0,0 @@
-# Avoid version control files.
-\bRCS\b
-\bCVS\b
-\bSCCS\b
-,v$
-\B\.svn\b
-\B\.git\b
-\B\.gitignore\b
-\b_darcs\b
-
-# Avoid Makemaker generated and utility files.
-\bMANIFEST\.bak
-\bMakefile$
-\bblib/
-\bMakeMaker-\d
-\bpm_to_blib\.ts$
-\bpm_to_blib$
-\bblibdirs\.ts$ # 6.18 through 6.25 generated this
-
-# Avoid Module::Build generated and utility files.
-\bBuild$
-\b_build/
-
-# Avoid temp and backup files.
-~$
-\.old$
-\#$
-\b\.#
-\.bak$
-
-# Avoid Devel::Cover files.
-\bcover_db\b
Deleted: trunk/contrib/perl/lib/ExtUtils/MM.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,90 +0,0 @@
-package ExtUtils::MM;
-
-use strict;
-use ExtUtils::MakeMaker::Config;
-
-our $VERSION = '6.55_02';
-
-require ExtUtils::Liblist;
-require ExtUtils::MakeMaker;
-our @ISA = qw(ExtUtils::Liblist ExtUtils::MakeMaker);
-
-=head1 NAME
-
-ExtUtils::MM - OS adjusted ExtUtils::MakeMaker subclass
-
-=head1 SYNOPSIS
-
- require ExtUtils::MM;
- my $mm = MM->new(...);
-
-=head1 DESCRIPTION
-
-B<FOR INTERNAL USE ONLY>
-
-ExtUtils::MM is a subclass of ExtUtils::MakeMaker which automatically
-chooses the appropriate OS specific subclass for you
-(ie. ExtUils::MM_Unix, etc...).
-
-It also provides a convenient alias via the MM class (I didn't want
-MakeMaker modules outside of ExtUtils/).
-
-This class might turn out to be a temporary solution, but MM won't go
-away.
-
-=cut
-
-{
- # Convenient alias.
- package MM;
- our @ISA = qw(ExtUtils::MM);
- sub DESTROY {}
-}
-
-sub _is_win95 {
- # miniperl might not have the Win32 functions available and we need
- # to run in miniperl.
- my $have_win32 = eval { require Win32 };
- return $have_win32 && defined &Win32::IsWin95 ? Win32::IsWin95()
- : ! defined $ENV{SYSTEMROOT};
-}
-
-my %Is = ();
-$Is{VMS} = $^O eq 'VMS';
-$Is{OS2} = $^O eq 'os2';
-$Is{MacOS} = $^O eq 'MacOS';
-if( $^O eq 'MSWin32' ) {
- _is_win95() ? $Is{Win95} = 1 : $Is{Win32} = 1;
-}
-$Is{UWIN} = $^O =~ /^uwin(-nt)?$/;
-$Is{Cygwin} = $^O eq 'cygwin';
-$Is{NW5} = $Config{osname} eq 'NetWare'; # intentional
-$Is{BeOS} = ($^O =~ /beos/i or $^O eq 'haiku');
-$Is{DOS} = $^O eq 'dos';
-if( $Is{NW5} ) {
- $^O = 'NetWare';
- delete $Is{Win32};
-}
-$Is{VOS} = $^O eq 'vos';
-$Is{QNX} = $^O eq 'qnx';
-$Is{AIX} = $^O eq 'aix';
-$Is{Darwin} = $^O eq 'darwin';
-
-$Is{Unix} = !grep { $_ } values %Is;
-
-map { delete $Is{$_} unless $Is{$_} } keys %Is;
-_assert( keys %Is == 1 );
-my($OS) = keys %Is;
-
-
-my $class = "ExtUtils::MM_$OS";
-eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"}; ## no critic
-die $@ if $@;
-unshift @ISA, $class;
-
-
-sub _assert {
- my $sanity = shift;
- die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity;
- return;
-}
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_AIX.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_AIX.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_AIX.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,79 +0,0 @@
-package ExtUtils::MM_AIX;
-
-use strict;
-our $VERSION = '6.55_02';
-
-require ExtUtils::MM_Unix;
-our @ISA = qw(ExtUtils::MM_Unix);
-
-use ExtUtils::MakeMaker qw(neatvalue);
-
-
-=head1 NAME
-
-ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix
-
-=head1 SYNOPSIS
-
- Don't use this module directly.
- Use ExtUtils::MM and let it choose.
-
-=head1 DESCRIPTION
-
-This is a subclass of ExtUtils::MM_Unix which contains functionality for
-AIX.
-
-Unless otherwise stated it works just like ExtUtils::MM_Unix
-
-=head2 Overridden methods
-
-=head3 dlsyms
-
-Define DL_FUNCS and DL_VARS and write the *.exp files.
-
-=cut
-
-sub dlsyms {
- my($self,%attribs) = @_;
-
- return '' unless $self->needs_linking();
-
- my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
- my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
- my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
- my(@m);
-
- push(@m,"
-dynamic :: $self->{BASEEXT}.exp
-
-") unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so...
-
- push(@m,"
-static :: $self->{BASEEXT}.exp
-
-") unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them
-
- push(@m,"
-$self->{BASEEXT}.exp: Makefile.PL
-",' $(PERLRUN) -e \'use ExtUtils::Mksymlists; \\
- Mksymlists("NAME" => "',$self->{NAME},'", "DL_FUNCS" => ',
- neatvalue($funcs), ', "FUNCLIST" => ', neatvalue($funclist),
- ', "DL_VARS" => ', neatvalue($vars), ');\'
-');
-
- join('', at m);
-}
-
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
-
-=head1 SEE ALSO
-
-L<ExtUtils::MakeMaker>
-
-=cut
-
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_Any.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Any.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Any.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,2332 +0,0 @@
-package ExtUtils::MM_Any;
-
-use strict;
-our $VERSION = '6.55_02';
-
-use Carp;
-use File::Spec;
-use File::Basename;
-BEGIN { our @ISA = qw(File::Spec); }
-
-# We need $Verbose
-use ExtUtils::MakeMaker qw($Verbose);
-
-use ExtUtils::MakeMaker::Config;
-
-
-# So we don't have to keep calling the methods over and over again,
-# we have these globals to cache the values. Faster and shrtr.
-my $Curdir = __PACKAGE__->curdir;
-my $Rootdir = __PACKAGE__->rootdir;
-my $Updir = __PACKAGE__->updir;
-
-
-=head1 NAME
-
-ExtUtils::MM_Any - Platform-agnostic MM methods
-
-=head1 SYNOPSIS
-
- FOR INTERNAL USE ONLY!
-
- package ExtUtils::MM_SomeOS;
-
- # Temporarily, you have to subclass both. Put MM_Any first.
- require ExtUtils::MM_Any;
- require ExtUtils::MM_Unix;
- @ISA = qw(ExtUtils::MM_Any ExtUtils::Unix);
-
-=head1 DESCRIPTION
-
-B<FOR INTERNAL USE ONLY!>
-
-ExtUtils::MM_Any is a superclass for the ExtUtils::MM_* set of
-modules. It contains methods which are either inherently
-cross-platform or are written in a cross-platform manner.
-
-Subclass off of ExtUtils::MM_Any I<and> ExtUtils::MM_Unix. This is a
-temporary solution.
-
-B<THIS MAY BE TEMPORARY!>
-
-
-=head1 METHODS
-
-Any methods marked I<Abstract> must be implemented by subclasses.
-
-
-=head2 Cross-platform helper methods
-
-These are methods which help writing cross-platform code.
-
-
-
-=head3 os_flavor I<Abstract>
-
- my @os_flavor = $mm->os_flavor;
-
- at os_flavor is the style of operating system this is, usually
-corresponding to the MM_*.pm file we're using.
-
-The first element of @os_flavor is the major family (ie. Unix,
-Windows, VMS, OS/2, etc...) and the rest are sub families.
-
-Some examples:
-
- Cygwin98 ('Unix', 'Cygwin', 'Cygwin9x')
- Windows ('Win32')
- Win98 ('Win32', 'Win9x')
- Linux ('Unix', 'Linux')
- MacOS X ('Unix', 'Darwin', 'MacOS', 'MacOS X')
- OS/2 ('OS/2')
-
-This is used to write code for styles of operating system.
-See os_flavor_is() for use.
-
-
-=head3 os_flavor_is
-
- my $is_this_flavor = $mm->os_flavor_is($this_flavor);
- my $is_this_flavor = $mm->os_flavor_is(@one_of_these_flavors);
-
-Checks to see if the current operating system is one of the given flavors.
-
-This is useful for code like:
-
- if( $mm->os_flavor_is('Unix') ) {
- $out = `foo 2>&1`;
- }
- else {
- $out = `foo`;
- }
-
-=cut
-
-sub os_flavor_is {
- my $self = shift;
- my %flavors = map { ($_ => 1) } $self->os_flavor;
- return (grep { $flavors{$_} } @_) ? 1 : 0;
-}
-
-
-=head3 can_load_xs
-
- my $can_load_xs = $self->can_load_xs;
-
-Returns true if we have the ability to load XS.
-
-This is important because miniperl, used to build XS modules in the
-core, can not load XS.
-
-=cut
-
-sub can_load_xs {
- return defined &DynaLoader::boot_DynaLoader ? 1 : 0;
-}
-
-
-=head3 split_command
-
- my @cmds = $MM->split_command($cmd, @args);
-
-Most OS have a maximum command length they can execute at once. Large
-modules can easily generate commands well past that limit. Its
-necessary to split long commands up into a series of shorter commands.
-
-C<split_command> will return a series of @cmds each processing part of
-the args. Collectively they will process all the arguments. Each
-individual line in @cmds will not be longer than the
-$self->max_exec_len being careful to take into account macro expansion.
-
-$cmd should include any switches and repeated initial arguments.
-
-If no @args are given, no @cmds will be returned.
-
-Pairs of arguments will always be preserved in a single command, this
-is a heuristic for things like pm_to_blib and pod2man which work on
-pairs of arguments. This makes things like this safe:
-
- $self->split_command($cmd, %pod2man);
-
-
-=cut
-
-sub split_command {
- my($self, $cmd, @args) = @_;
-
- my @cmds = ();
- return(@cmds) unless @args;
-
- # If the command was given as a here-doc, there's probably a trailing
- # newline.
- chomp $cmd;
-
- # set aside 30% for macro expansion.
- my $len_left = int($self->max_exec_len * 0.70);
- $len_left -= length $self->_expand_macros($cmd);
-
- do {
- my $arg_str = '';
- my @next_args;
- while( @next_args = splice(@args, 0, 2) ) {
- # Two at a time to preserve pairs.
- my $next_arg_str = "\t ". join ' ', @next_args, "\n";
-
- if( !length $arg_str ) {
- $arg_str .= $next_arg_str
- }
- elsif( length($arg_str) + length($next_arg_str) > $len_left ) {
- unshift @args, @next_args;
- last;
- }
- else {
- $arg_str .= $next_arg_str;
- }
- }
- chop $arg_str;
-
- push @cmds, $self->escape_newlines("$cmd \n$arg_str");
- } while @args;
-
- return @cmds;
-}
-
-
-sub _expand_macros {
- my($self, $cmd) = @_;
-
- $cmd =~ s{\$\((\w+)\)}{
- defined $self->{$1} ? $self->{$1} : "\$($1)"
- }e;
- return $cmd;
-}
-
-
-=head3 echo
-
- my @commands = $MM->echo($text);
- my @commands = $MM->echo($text, $file);
- my @commands = $MM->echo($text, $file, $appending);
-
-Generates a set of @commands which print the $text to a $file.
-
-If $file is not given, output goes to STDOUT.
-
-If $appending is true the $file will be appended to rather than
-overwritten.
-
-=cut
-
-sub echo {
- my($self, $text, $file, $appending) = @_;
- $appending ||= 0;
-
- my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_) }
- split /\n/, $text;
- if( $file ) {
- my $redirect = $appending ? '>>' : '>';
- $cmds[0] .= " $redirect $file";
- $_ .= " >> $file" foreach @cmds[1..$#cmds];
- }
-
- return @cmds;
-}
-
-
-=head3 wraplist
-
- my $args = $mm->wraplist(@list);
-
-Takes an array of items and turns them into a well-formatted list of
-arguments. In most cases this is simply something like:
-
- FOO \
- BAR \
- BAZ
-
-=cut
-
-sub wraplist {
- my $self = shift;
- return join " \\\n\t", @_;
-}
-
-
-=head3 maketext_filter
-
- my $filter_make_text = $mm->maketext_filter($make_text);
-
-The text of the Makefile is run through this method before writing to
-disk. It allows systems a chance to make portability fixes to the
-Makefile.
-
-By default it does nothing.
-
-This method is protected and not intended to be called outside of
-MakeMaker.
-
-=cut
-
-sub maketext_filter { return $_[1] }
-
-
-=head3 cd I<Abstract>
-
- my $subdir_cmd = $MM->cd($subdir, @cmds);
-
-This will generate a make fragment which runs the @cmds in the given
-$dir. The rough equivalent to this, except cross platform.
-
- cd $subdir && $cmd
-
-Currently $dir can only go down one level. "foo" is fine. "foo/bar" is
-not. "../foo" is right out.
-
-The resulting $subdir_cmd has no leading tab nor trailing newline. This
-makes it easier to embed in a make string. For example.
-
- my $make = sprintf <<'CODE', $subdir_cmd;
- foo :
- $(ECHO) what
- %s
- $(ECHO) mouche
- CODE
-
-
-=head3 oneliner I<Abstract>
-
- my $oneliner = $MM->oneliner($perl_code);
- my $oneliner = $MM->oneliner($perl_code, \@switches);
-
-This will generate a perl one-liner safe for the particular platform
-you're on based on the given $perl_code and @switches (a -e is
-assumed) suitable for using in a make target. It will use the proper
-shell quoting and escapes.
-
-$(PERLRUN) will be used as perl.
-
-Any newlines in $perl_code will be escaped. Leading and trailing
-newlines will be stripped. Makes this idiom much easier:
-
- my $code = $MM->oneliner(<<'CODE', [...switches...]);
-some code here
-another line here
-CODE
-
-Usage might be something like:
-
- # an echo emulation
- $oneliner = $MM->oneliner('print "Foo\n"');
- $make = '$oneliner > somefile';
-
-All dollar signs must be doubled in the $perl_code if you expect them
-to be interpreted normally, otherwise it will be considered a make
-macro. Also remember to quote make macros else it might be used as a
-bareword. For example:
-
- # Assign the value of the $(VERSION_FROM) make macro to $vf.
- $oneliner = $MM->oneliner('$$vf = "$(VERSION_FROM)"');
-
-Its currently very simple and may be expanded sometime in the figure
-to include more flexible code and switches.
-
-
-=head3 quote_literal I<Abstract>
-
- my $safe_text = $MM->quote_literal($text);
-
-This will quote $text so it is interpreted literally in the shell.
-
-For example, on Unix this would escape any single-quotes in $text and
-put single-quotes around the whole thing.
-
-
-=head3 escape_newlines I<Abstract>
-
- my $escaped_text = $MM->escape_newlines($text);
-
-Shell escapes newlines in $text.
-
-
-=head3 max_exec_len I<Abstract>
-
- my $max_exec_len = $MM->max_exec_len;
-
-Calculates the maximum command size the OS can exec. Effectively,
-this is the max size of a shell command line.
-
-=for _private
-$self->{_MAX_EXEC_LEN} is set by this method, but only for testing purposes.
-
-
-=head3 make
-
- my $make = $MM->make;
-
-Returns the make variant we're generating the Makefile for. This attempts
-to do some normalization on the information from %Config or the user.
-
-=cut
-
-sub make {
- my $self = shift;
-
- my $make = lc $self->{MAKE};
-
- # Truncate anything like foomake6 to just foomake.
- $make =~ s/^(\w+make).*/$1/;
-
- # Turn gnumake into gmake.
- $make =~ s/^gnu/g/;
-
- return $make;
-}
-
-
-=head2 Targets
-
-These are methods which produce make targets.
-
-
-=head3 all_target
-
-Generate the default target 'all'.
-
-=cut
-
-sub all_target {
- my $self = shift;
-
- return <<'MAKE_EXT';
-all :: pure_all
- $(NOECHO) $(NOOP)
-MAKE_EXT
-
-}
-
-
-=head3 blibdirs_target
-
- my $make_frag = $mm->blibdirs_target;
-
-Creates the blibdirs target which creates all the directories we use
-in blib/.
-
-The blibdirs.ts target is deprecated. Depend on blibdirs instead.
-
-
-=cut
-
-sub blibdirs_target {
- my $self = shift;
-
- my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib
- autodir archautodir
- bin script
- man1dir man3dir
- );
-
- my @exists = map { $_.'$(DFSEP).exists' } @dirs;
-
- my $make = sprintf <<'MAKE', join(' ', @exists);
-blibdirs : %s
- $(NOECHO) $(NOOP)
-
-# Backwards compat with 6.18 through 6.25
-blibdirs.ts : blibdirs
- $(NOECHO) $(NOOP)
-
-MAKE
-
- $make .= $self->dir_target(@dirs);
-
- return $make;
-}
-
-
-=head3 clean (o)
-
-Defines the clean target.
-
-=cut
-
-sub clean {
-# --- Cleanup and Distribution Sections ---
-
- my($self, %attribs) = @_;
- my @m;
- push(@m, '
-# Delete temporary files but do not touch installed files. We don\'t delete
-# the Makefile here so a later make realclean still has a makefile to use.
-
-clean :: clean_subdirs
-');
-
- my @files = values %{$self->{XS}}; # .c files from *.xs files
- my @dirs = qw(blib);
-
- # Normally these are all under blib but they might have been
- # redefined.
- # XXX normally this would be a good idea, but the Perl core sets
- # INST_LIB = ../../lib rather than actually installing the files.
- # So a "make clean" in an ext/ directory would blow away lib.
- # Until the core is adjusted let's leave this out.
-# push @dirs, qw($(INST_ARCHLIB) $(INST_LIB)
-# $(INST_BIN) $(INST_SCRIPT)
-# $(INST_MAN1DIR) $(INST_MAN3DIR)
-# $(INST_LIBDIR) $(INST_ARCHLIBDIR) $(INST_AUTODIR)
-# $(INST_STATIC) $(INST_DYNAMIC) $(INST_BOOT)
-# );
-
-
- if( $attribs{FILES} ) {
- # Use @dirs because we don't know what's in here.
- push @dirs, ref $attribs{FILES} ?
- @{$attribs{FILES}} :
- split /\s+/, $attribs{FILES} ;
- }
-
- push(@files, qw[$(MAKE_APERL_FILE)
- perlmain.c tmon.out mon.out so_locations
- blibdirs.ts pm_to_blib pm_to_blib.ts
- *$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT)
- $(BOOTSTRAP) $(BASEEXT).bso
- $(BASEEXT).def lib$(BASEEXT).def
- $(BASEEXT).exp $(BASEEXT).x
- ]);
-
- push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'));
- push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.ld'));
-
- # core files
- push(@files, qw[core core.*perl.*.? *perl.core]);
- push(@files, map { "core." . "[0-9]"x$_ } (1..5));
-
- # OS specific things to clean up. Use @dirs since we don't know
- # what might be in here.
- push @dirs, $self->extra_clean_files;
-
- # Occasionally files are repeated several times from different sources
- { my(%f) = map { ($_ => 1) } @files; @files = keys %f; }
- { my(%d) = map { ($_ => 1) } @dirs; @dirs = keys %d; }
-
- push @m, map "\t$_\n", $self->split_command('- $(RM_F)', @files);
- push @m, map "\t$_\n", $self->split_command('- $(RM_RF)', @dirs);
-
- # Leave Makefile.old around for realclean
- push @m, <<'MAKE';
- - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL)
-MAKE
-
- push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP};
-
- join("", @m);
-}
-
-
-=head3 clean_subdirs_target
-
- my $make_frag = $MM->clean_subdirs_target;
-
-Returns the clean_subdirs target. This is used by the clean target to
-call clean on any subdirectories which contain Makefiles.
-
-=cut
-
-sub clean_subdirs_target {
- my($self) = shift;
-
- # No subdirectories, no cleaning.
- return <<'NOOP_FRAG' unless @{$self->{DIR}};
-clean_subdirs :
- $(NOECHO) $(NOOP)
-NOOP_FRAG
-
-
- my $clean = "clean_subdirs :\n";
-
- for my $dir (@{$self->{DIR}}) {
- my $subclean = $self->oneliner(sprintf <<'CODE', $dir);
-chdir '%s'; system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)';
-CODE
-
- $clean .= "\t$subclean\n";
- }
-
- return $clean;
-}
-
-
-=head3 dir_target
-
- my $make_frag = $mm->dir_target(@directories);
-
-Generates targets to create the specified directories and set its
-permission to PERM_DIR.
-
-Because depending on a directory to just ensure it exists doesn't work
-too well (the modified time changes too often) dir_target() creates a
-.exists file in the created directory. It is this you should depend on.
-For portability purposes you should use the $(DIRFILESEP) macro rather
-than a '/' to seperate the directory from the file.
-
- yourdirectory$(DIRFILESEP).exists
-
-=cut
-
-sub dir_target {
- my($self, @dirs) = @_;
-
- my $make = '';
- foreach my $dir (@dirs) {
- $make .= sprintf <<'MAKE', ($dir) x 7;
-%s$(DFSEP).exists :: Makefile.PL
- $(NOECHO) $(MKPATH) %s
- $(NOECHO) $(CHMOD) $(PERM_DIR) %s
- $(NOECHO) $(TOUCH) %s$(DFSEP).exists
-
-MAKE
-
- }
-
- return $make;
-}
-
-
-=head3 distdir
-
-Defines the scratch directory target that will hold the distribution
-before tar-ing (or shar-ing).
-
-=cut
-
-# For backwards compatibility.
-*dist_dir = *distdir;
-
-sub distdir {
- my($self) = shift;
-
- my $meta_target = $self->{NO_META} ? '' : 'distmeta';
- my $sign_target = !$self->{SIGN} ? '' : 'distsignature';
-
- return sprintf <<'MAKE_FRAG', $meta_target, $sign_target;
-create_distdir :
- $(RM_RF) $(DISTVNAME)
- $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \
- -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
-
-distdir : create_distdir %s %s
- $(NOECHO) $(NOOP)
-
-MAKE_FRAG
-
-}
-
-
-=head3 dist_test
-
-Defines a target that produces the distribution in the
-scratchdirectory, and runs 'perl Makefile.PL; make ;make test' in that
-subdirectory.
-
-=cut
-
-sub dist_test {
- my($self) = shift;
-
- my $mpl_args = join " ", map qq["$_"], @ARGV;
-
- my $test = $self->cd('$(DISTVNAME)',
- '$(ABSPERLRUN) Makefile.PL '.$mpl_args,
- '$(MAKE) $(PASTHRU)',
- '$(MAKE) test $(PASTHRU)'
- );
-
- return sprintf <<'MAKE_FRAG', $test;
-disttest : distdir
- %s
-
-MAKE_FRAG
-
-
-}
-
-
-=head3 dynamic (o)
-
-Defines the dynamic target.
-
-=cut
-
-sub dynamic {
-# --- Dynamic Loading Sections ---
-
- my($self) = shift;
- '
-dynamic :: $(FIRST_MAKEFILE) $(INST_DYNAMIC) $(INST_BOOT)
- $(NOECHO) $(NOOP)
-';
-}
-
-
-=head3 makemakerdflt_target
-
- my $make_frag = $mm->makemakerdflt_target
-
-Returns a make fragment with the makemakerdeflt_target specified.
-This target is the first target in the Makefile, is the default target
-and simply points off to 'all' just in case any make variant gets
-confused or something gets snuck in before the real 'all' target.
-
-=cut
-
-sub makemakerdflt_target {
- return <<'MAKE_FRAG';
-makemakerdflt : all
- $(NOECHO) $(NOOP)
-MAKE_FRAG
-
-}
-
-
-=head3 manifypods_target
-
- my $manifypods_target = $self->manifypods_target;
-
-Generates the manifypods target. This target generates man pages from
-all POD files in MAN1PODS and MAN3PODS.
-
-=cut
-
-sub manifypods_target {
- my($self) = shift;
-
- my $man1pods = '';
- my $man3pods = '';
- my $dependencies = '';
-
- # populate manXpods & dependencies:
- foreach my $name (keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}}) {
- $dependencies .= " \\\n\t$name";
- }
-
- my $manify = <<END;
-manifypods : pure_all $dependencies
-END
-
- my @man_cmds;
- foreach my $section (qw(1 3)) {
- my $pods = $self->{"MAN${section}PODS"};
- push @man_cmds, $self->split_command(<<CMD, %$pods);
- \$(NOECHO) \$(POD2MAN) --section=$section --perm_rw=\$(PERM_RW)
-CMD
- }
-
- $manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds;
- $manify .= join '', map { "$_\n" } @man_cmds;
-
- return $manify;
-}
-
-
-=head3 metafile_target
-
- my $target = $mm->metafile_target;
-
-Generate the metafile target.
-
-Writes the file META.yml YAML encoded meta-data about the module in
-the distdir. The format follows Module::Build's as closely as
-possible.
-
-=cut
-
-sub metafile_target {
- my $self = shift;
-
- return <<'MAKE_FRAG' if $self->{NO_META};
-metafile :
- $(NOECHO) $(NOOP)
-MAKE_FRAG
-
- my @metadata = $self->metafile_data(
- $self->{META_ADD} || {},
- $self->{META_MERGE} || {},
- );
- my $meta = $self->metafile_file(@metadata);
- my @write_meta = $self->echo($meta, 'META_new.yml');
-
- return sprintf <<'MAKE_FRAG', join("\n\t", @write_meta);
-metafile : create_distdir
- $(NOECHO) $(ECHO) Generating META.yml
- %s
- -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml
-MAKE_FRAG
-
-}
-
-
-=begin private
-
-=head3 _sort_pairs
-
- my @pairs = _sort_pairs($sort_sub, \%hash);
-
-Sorts the pairs of a hash based on keys ordered according
-to C<$sort_sub>.
-
-=end private
-
-=cut
-
-sub _sort_pairs {
- my $sort = shift;
- my $pairs = shift;
- return map { $_ => $pairs->{$_} }
- sort $sort
- keys %$pairs;
-}
-
-
-# Taken from Module::Build::Base
-sub _hash_merge {
- my ($self, $h, $k, $v) = @_;
- if (ref $h->{$k} eq 'ARRAY') {
- push @{$h->{$k}}, ref $v ? @$v : $v;
- } elsif (ref $h->{$k} eq 'HASH') {
- $self->_hash_merge($h->{$k}, $_, $v->{$_}) foreach keys %$v;
- } else {
- $h->{$k} = $v;
- }
-}
-
-
-=head3 metafile_data
-
- my @metadata_pairs = $mm->metafile_data(\%meta_add, \%meta_merge);
-
-Returns the data which MakeMaker turns into the META.yml file.
-
-Values of %meta_add will overwrite any existing metadata in those
-keys. %meta_merge will be merged with them.
-
-=cut
-
-sub metafile_data {
- my $self = shift;
- my($meta_add, $meta_merge) = @_;
-
- # The order in which standard meta keys should be written.
- my @meta_order = qw(
- name
- version
- abstract
- author
- license
- distribution_type
-
- configure_requires
- build_requires
- requires
-
- resources
-
- provides
- no_index
-
- generated_by
- meta-spec
- );
-
- # Check the original args so we can tell between the user setting it
- # to an empty hash and it just being initialized.
- my $configure_requires;
- if( $self->{ARGS}{CONFIGURE_REQUIRES} ) {
- $configure_requires = $self->{CONFIGURE_REQUIRES};
- } else {
- $configure_requires = {
- 'ExtUtils::MakeMaker' => 0,
- };
- }
- my $build_requires;
- if( $self->{ARGS}{BUILD_REQUIRES} ) {
- $build_requires = $self->{BUILD_REQUIRES};
- } else {
- $build_requires = {
- 'ExtUtils::MakeMaker' => 0,
- };
- }
-
- my %meta = (
- name => $self->{DISTNAME},
- version => $self->{VERSION},
- abstract => $self->{ABSTRACT},
- license => $self->{LICENSE} || 'unknown',
- distribution_type => $self->{PM} ? 'module' : 'script',
-
- configure_requires => $configure_requires,
-
- build_requires => $build_requires,
-
- no_index => {
- directory => [qw(t inc)]
- },
-
- generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION",
- 'meta-spec' => {
- url => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
- version => 1.4
- },
- );
-
- # The author key is required and it takes a list.
- $meta{author} = defined $self->{AUTHOR} ? [$self->{AUTHOR}] : [];
-
- $meta{requires} = $self->{PREREQ_PM} if defined $self->{PREREQ_PM};
- $meta{requires}{perl} = $self->{MIN_PERL_VERSION} if $self->{MIN_PERL_VERSION};
-
- while( my($key, $val) = each %$meta_add ) {
- $meta{$key} = $val;
- }
-
- while( my($key, $val) = each %$meta_merge ) {
- $self->_hash_merge(\%meta, $key, $val);
- }
-
- my @meta_pairs;
-
- # Put the standard keys first in the proper order.
- for my $key (@meta_order) {
- next unless exists $meta{$key};
-
- push @meta_pairs, $key, delete $meta{$key};
- }
-
- # Then tack everything else onto the end, alpha sorted.
- for my $key (sort {lc $a cmp lc $b} keys %meta) {
- push @meta_pairs, $key, $meta{$key};
- }
-
- return @meta_pairs
-}
-
-=begin private
-
-=head3 _dump_hash
-
- $yaml = _dump_hash(\%options, %hash);
-
-Implements a fake YAML dumper for a hash given
-as a list of pairs. No quoting/escaping is done. Keys
-are supposed to be strings. Values are undef, strings,
-hash refs or array refs of strings.
-
-Supported options are:
-
- delta => STR - indentation delta
- use_header => BOOL - whether to include a YAML header
- indent => STR - a string of spaces
- default: ''
-
- max_key_length => INT - maximum key length used to align
- keys and values of the same hash
- default: 20
- key_sort => CODE - a sort sub
- It may be undef, which means no sorting by keys
- default: sub { lc $a cmp lc $b }
-
- customs => HASH - special options for certain keys
- (whose values are hashes themselves)
- may contain: max_key_length, key_sort, customs
-
-=end private
-
-=cut
-
-sub _dump_hash {
- croak "first argument should be a hash ref" unless ref $_[0] eq 'HASH';
- my $options = shift;
- my %hash = @_;
-
- # Use a list to preserve order.
- my @pairs;
-
- my $k_sort
- = exists $options->{key_sort} ? $options->{key_sort}
- : sub { lc $a cmp lc $b };
- if ($k_sort) {
- croak "'key_sort' should be a coderef" unless ref $k_sort eq 'CODE';
- @pairs = _sort_pairs($k_sort, \%hash);
- } else { # list of pairs, no sorting
- @pairs = @_;
- }
-
- my $yaml = $options->{use_header} ? "--- #YAML:1.0\n" : '';
- my $indent = $options->{indent} || '';
- my $k_length = min(
- ($options->{max_key_length} || 20),
- max(map { length($_) + 1 } grep { !ref $hash{$_} } keys %hash)
- );
- my $customs = $options->{customs} || {};
-
- # printf format for key
- my $k_format = "%-${k_length}s";
-
- while( @pairs ) {
- my($key, $val) = splice @pairs, 0, 2;
- $val = '~' unless defined $val;
- if(ref $val eq 'HASH') {
- if ( keys %$val ) {
- my %k_options = ( # options for recursive call
- delta => $options->{delta},
- use_header => 0,
- indent => $indent . $options->{delta},
- );
- if (exists $customs->{$key}) {
- my %k_custom = %{$customs->{$key}};
- foreach my $k qw(key_sort max_key_length customs) {
- $k_options{$k} = $k_custom{$k} if exists $k_custom{$k};
- }
- }
- $yaml .= $indent . "$key:\n"
- . _dump_hash(\%k_options, %$val);
- }
- else {
- $yaml .= $indent . "$key: {}\n";
- }
- }
- elsif (ref $val eq 'ARRAY') {
- if( @$val ) {
- $yaml .= $indent . "$key:\n";
-
- for (@$val) {
- croak "only nested arrays of non-refs are supported" if ref $_;
- $yaml .= $indent . $options->{delta} . "- $_\n";
- }
- }
- else {
- $yaml .= $indent . "$key: []\n";
- }
- }
- elsif( ref $val and !blessed($val) ) {
- croak "only nested hashes, arrays and objects are supported";
- }
- else { # if it's an object, just stringify it
- $yaml .= $indent . sprintf "$k_format %s\n", "$key:", $val;
- }
- };
-
- return $yaml;
-
-}
-
-sub blessed {
- return eval { $_[0]->isa("UNIVERSAL"); };
-}
-
-sub max {
- return (sort { $b <=> $a } @_)[0];
-}
-
-sub min {
- return (sort { $a <=> $b } @_)[0];
-}
-
-=head3 metafile_file
-
- my $meta_yml = $mm->metafile_file(@metadata_pairs);
-
-Turns the @metadata_pairs into YAML.
-
-This method does not implement a complete YAML dumper, being limited
-to dump a hash with values which are strings, undef's or nested hashes
-and arrays of strings. No quoting/escaping is done.
-
-=cut
-
-sub metafile_file {
- my $self = shift;
-
- my %dump_options = (
- use_header => 1,
- delta => ' ' x 4,
- key_sort => undef,
- );
- return _dump_hash(\%dump_options, @_);
-
-}
-
-
-=head3 distmeta_target
-
- my $make_frag = $mm->distmeta_target;
-
-Generates the distmeta target to add META.yml to the MANIFEST in the
-distdir.
-
-=cut
-
-sub distmeta_target {
- my $self = shift;
-
- my $add_meta = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']);
-eval { maniadd({q{META.yml} => q{Module meta-data (added by MakeMaker)}}) }
- or print "Could not add META.yml to MANIFEST: $${'@'}\n"
-CODE
-
- my $add_meta_to_distdir = $self->cd('$(DISTVNAME)', $add_meta);
-
- return sprintf <<'MAKE', $add_meta_to_distdir;
-distmeta : create_distdir metafile
- $(NOECHO) %s
-
-MAKE
-
-}
-
-
-=head3 realclean (o)
-
-Defines the realclean target.
-
-=cut
-
-sub realclean {
- my($self, %attribs) = @_;
-
- my @dirs = qw($(DISTVNAME));
- my @files = qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD));
-
- # Special exception for the perl core where INST_* is not in blib.
- # This cleans up the files built from the ext/ directory (all XS).
- if( $self->{PERL_CORE} ) {
- push @dirs, qw($(INST_AUTODIR) $(INST_ARCHAUTODIR));
- push @files, values %{$self->{PM}};
- }
-
- if( $self->has_link_code ){
- push @files, qw($(OBJECT));
- }
-
- if( $attribs{FILES} ) {
- if( ref $attribs{FILES} ) {
- push @dirs, @{ $attribs{FILES} };
- }
- else {
- push @dirs, split /\s+/, $attribs{FILES};
- }
- }
-
- # Occasionally files are repeated several times from different sources
- { my(%f) = map { ($_ => 1) } @files; @files = keys %f; }
- { my(%d) = map { ($_ => 1) } @dirs; @dirs = keys %d; }
-
- my $rm_cmd = join "\n\t", map { "$_" }
- $self->split_command('- $(RM_F)', @files);
- my $rmf_cmd = join "\n\t", map { "$_" }
- $self->split_command('- $(RM_RF)', @dirs);
-
- my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd;
-# Delete temporary files (via clean) and also delete dist files
-realclean purge :: clean realclean_subdirs
- %s
- %s
-MAKE
-
- $m .= "\t$attribs{POSTOP}\n" if $attribs{POSTOP};
-
- return $m;
-}
-
-
-=head3 realclean_subdirs_target
-
- my $make_frag = $MM->realclean_subdirs_target;
-
-Returns the realclean_subdirs target. This is used by the realclean
-target to call realclean on any subdirectories which contain Makefiles.
-
-=cut
-
-sub realclean_subdirs_target {
- my $self = shift;
-
- return <<'NOOP_FRAG' unless @{$self->{DIR}};
-realclean_subdirs :
- $(NOECHO) $(NOOP)
-NOOP_FRAG
-
- my $rclean = "realclean_subdirs :\n";
-
- foreach my $dir (@{$self->{DIR}}) {
- foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) {
- my $subrclean .= $self->oneliner(sprintf <<'CODE', $dir, ($makefile) x 2);
-chdir '%s'; system '$(MAKE) $(USEMAKEFILE) %s realclean' if -f '%s';
-CODE
-
- $rclean .= sprintf <<'RCLEAN', $subrclean;
- - %s
-RCLEAN
-
- }
- }
-
- return $rclean;
-}
-
-
-=head3 signature_target
-
- my $target = $mm->signature_target;
-
-Generate the signature target.
-
-Writes the file SIGNATURE with "cpansign -s".
-
-=cut
-
-sub signature_target {
- my $self = shift;
-
- return <<'MAKE_FRAG';
-signature :
- cpansign -s
-MAKE_FRAG
-
-}
-
-
-=head3 distsignature_target
-
- my $make_frag = $mm->distsignature_target;
-
-Generates the distsignature target to add SIGNATURE to the MANIFEST in the
-distdir.
-
-=cut
-
-sub distsignature_target {
- my $self = shift;
-
- my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']);
-eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) }
- or print "Could not add SIGNATURE to MANIFEST: $${'@'}\n"
-CODE
-
- my $sign_dist = $self->cd('$(DISTVNAME)' => 'cpansign -s');
-
- # cpansign -s complains if SIGNATURE is in the MANIFEST yet does not
- # exist
- my $touch_sig = $self->cd('$(DISTVNAME)' => '$(TOUCH) SIGNATURE');
- my $add_sign_to_dist = $self->cd('$(DISTVNAME)' => $add_sign );
-
- return sprintf <<'MAKE', $add_sign_to_dist, $touch_sig, $sign_dist
-distsignature : create_distdir
- $(NOECHO) %s
- $(NOECHO) %s
- %s
-
-MAKE
-
-}
-
-
-=head3 special_targets
-
- my $make_frag = $mm->special_targets
-
-Returns a make fragment containing any targets which have special
-meaning to make. For example, .SUFFIXES and .PHONY.
-
-=cut
-
-sub special_targets {
- my $make_frag = <<'MAKE_FRAG';
-.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT)
-
-.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir
-
-MAKE_FRAG
-
- $make_frag .= <<'MAKE_FRAG' if $ENV{CLEARCASE_ROOT};
-.NO_CONFIG_REC: Makefile
-
-MAKE_FRAG
-
- return $make_frag;
-}
-
-
-
-
-=head2 Init methods
-
-Methods which help initialize the MakeMaker object and macros.
-
-
-=head3 init_ABSTRACT
-
- $mm->init_ABSTRACT
-
-=cut
-
-sub init_ABSTRACT {
- my $self = shift;
-
- if( $self->{ABSTRACT_FROM} and $self->{ABSTRACT} ) {
- warn "Both ABSTRACT_FROM and ABSTRACT are set. ".
- "Ignoring ABSTRACT_FROM.\n";
- return;
- }
-
- if ($self->{ABSTRACT_FROM}){
- $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or
- carp "WARNING: Setting ABSTRACT via file ".
- "'$self->{ABSTRACT_FROM}' failed\n";
- }
-}
-
-=head3 init_INST
-
- $mm->init_INST;
-
-Called by init_main. Sets up all INST_* variables except those related
-to XS code. Those are handled in init_xs.
-
-=cut
-
-sub init_INST {
- my($self) = shift;
-
- $self->{INST_ARCHLIB} ||= $self->catdir($Curdir,"blib","arch");
- $self->{INST_BIN} ||= $self->catdir($Curdir,'blib','bin');
-
- # INST_LIB typically pre-set if building an extension after
- # perl has been built and installed. Setting INST_LIB allows
- # you to build directly into, say $Config{privlibexp}.
- unless ($self->{INST_LIB}){
- if ($self->{PERL_CORE}) {
- if (defined $Cross::platform) {
- $self->{INST_LIB} = $self->{INST_ARCHLIB} =
- $self->catdir($self->{PERL_LIB},"..","xlib",
- $Cross::platform);
- }
- else {
- $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB};
- }
- } else {
- $self->{INST_LIB} = $self->catdir($Curdir,"blib","lib");
- }
- }
-
- my @parentdir = split(/::/, $self->{PARENT_NAME});
- $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)', @parentdir);
- $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)', @parentdir);
- $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)', 'auto',
- '$(FULLEXT)');
- $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)', 'auto',
- '$(FULLEXT)');
-
- $self->{INST_SCRIPT} ||= $self->catdir($Curdir,'blib','script');
-
- $self->{INST_MAN1DIR} ||= $self->catdir($Curdir,'blib','man1');
- $self->{INST_MAN3DIR} ||= $self->catdir($Curdir,'blib','man3');
-
- return 1;
-}
-
-
-=head3 init_INSTALL
-
- $mm->init_INSTALL;
-
-Called by init_main. Sets up all INSTALL_* variables (except
-INSTALLDIRS) and *PREFIX.
-
-=cut
-
-sub init_INSTALL {
- my($self) = shift;
-
- if( $self->{ARGS}{INSTALL_BASE} and $self->{ARGS}{PREFIX} ) {
- die "Only one of PREFIX or INSTALL_BASE can be given. Not both.\n";
- }
-
- if( $self->{ARGS}{INSTALL_BASE} ) {
- $self->init_INSTALL_from_INSTALL_BASE;
- }
- else {
- $self->init_INSTALL_from_PREFIX;
- }
-}
-
-
-=head3 init_INSTALL_from_PREFIX
-
- $mm->init_INSTALL_from_PREFIX;
-
-=cut
-
-sub init_INSTALL_from_PREFIX {
- my $self = shift;
-
- $self->init_lib2arch;
-
- # There are often no Config.pm defaults for these new man variables so
- # we fall back to the old behavior which is to use installman*dir
- foreach my $num (1, 3) {
- my $k = 'installsiteman'.$num.'dir';
-
- $self->{uc $k} ||= uc "\$(installman${num}dir)"
- unless $Config{$k};
- }
-
- foreach my $num (1, 3) {
- my $k = 'installvendorman'.$num.'dir';
-
- unless( $Config{$k} ) {
- $self->{uc $k} ||= $Config{usevendorprefix}
- ? uc "\$(installman${num}dir)"
- : '';
- }
- }
-
- $self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)'
- unless $Config{installsitebin};
- $self->{INSTALLSITESCRIPT} ||= '$(INSTALLSCRIPT)'
- unless $Config{installsitescript};
-
- unless( $Config{installvendorbin} ) {
- $self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix}
- ? $Config{installbin}
- : '';
- }
- unless( $Config{installvendorscript} ) {
- $self->{INSTALLVENDORSCRIPT} ||= $Config{usevendorprefix}
- ? $Config{installscript}
- : '';
- }
-
-
- my $iprefix = $Config{installprefixexp} || $Config{installprefix} ||
- $Config{prefixexp} || $Config{prefix} || '';
- my $vprefix = $Config{usevendorprefix} ? $Config{vendorprefixexp} : '';
- my $sprefix = $Config{siteprefixexp} || '';
-
- # 5.005_03 doesn't have a siteprefix.
- $sprefix = $iprefix unless $sprefix;
-
-
- $self->{PREFIX} ||= '';
-
- if( $self->{PREFIX} ) {
- @{$self}{qw(PERLPREFIX SITEPREFIX VENDORPREFIX)} =
- ('$(PREFIX)') x 3;
- }
- else {
- $self->{PERLPREFIX} ||= $iprefix;
- $self->{SITEPREFIX} ||= $sprefix;
- $self->{VENDORPREFIX} ||= $vprefix;
-
- # Lots of MM extension authors like to use $(PREFIX) so we
- # put something sensible in there no matter what.
- $self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)';
- }
-
- my $arch = $Config{archname};
- my $version = $Config{version};
-
- # default style
- my $libstyle = $Config{installstyle} || 'lib/perl5';
- my $manstyle = '';
-
- if( $self->{LIBSTYLE} ) {
- $libstyle = $self->{LIBSTYLE};
- $manstyle = $self->{LIBSTYLE} eq 'lib/perl5' ? 'lib/perl5' : '';
- }
-
- # Some systems, like VOS, set installman*dir to '' if they can't
- # read man pages.
- for my $num (1, 3) {
- $self->{'INSTALLMAN'.$num.'DIR'} ||= 'none'
- unless $Config{'installman'.$num.'dir'};
- }
-
- my %bin_layouts =
- (
- bin => { s => $iprefix,
- t => 'perl',
- d => 'bin' },
- vendorbin => { s => $vprefix,
- t => 'vendor',
- d => 'bin' },
- sitebin => { s => $sprefix,
- t => 'site',
- d => 'bin' },
- script => { s => $iprefix,
- t => 'perl',
- d => 'bin' },
- vendorscript=> { s => $vprefix,
- t => 'vendor',
- d => 'bin' },
- sitescript => { s => $sprefix,
- t => 'site',
- d => 'bin' },
- );
-
- my %man_layouts =
- (
- man1dir => { s => $iprefix,
- t => 'perl',
- d => 'man/man1',
- style => $manstyle, },
- siteman1dir => { s => $sprefix,
- t => 'site',
- d => 'man/man1',
- style => $manstyle, },
- vendorman1dir => { s => $vprefix,
- t => 'vendor',
- d => 'man/man1',
- style => $manstyle, },
-
- man3dir => { s => $iprefix,
- t => 'perl',
- d => 'man/man3',
- style => $manstyle, },
- siteman3dir => { s => $sprefix,
- t => 'site',
- d => 'man/man3',
- style => $manstyle, },
- vendorman3dir => { s => $vprefix,
- t => 'vendor',
- d => 'man/man3',
- style => $manstyle, },
- );
-
- my %lib_layouts =
- (
- privlib => { s => $iprefix,
- t => 'perl',
- d => '',
- style => $libstyle, },
- vendorlib => { s => $vprefix,
- t => 'vendor',
- d => '',
- style => $libstyle, },
- sitelib => { s => $sprefix,
- t => 'site',
- d => 'site_perl',
- style => $libstyle, },
-
- archlib => { s => $iprefix,
- t => 'perl',
- d => "$version/$arch",
- style => $libstyle },
- vendorarch => { s => $vprefix,
- t => 'vendor',
- d => "$version/$arch",
- style => $libstyle },
- sitearch => { s => $sprefix,
- t => 'site',
- d => "site_perl/$version/$arch",
- style => $libstyle },
- );
-
-
- # Special case for LIB.
- if( $self->{LIB} ) {
- foreach my $var (keys %lib_layouts) {
- my $Installvar = uc "install$var";
-
- if( $var =~ /arch/ ) {
- $self->{$Installvar} ||=
- $self->catdir($self->{LIB}, $Config{archname});
- }
- else {
- $self->{$Installvar} ||= $self->{LIB};
- }
- }
- }
-
- my %type2prefix = ( perl => 'PERLPREFIX',
- site => 'SITEPREFIX',
- vendor => 'VENDORPREFIX'
- );
-
- my %layouts = (%bin_layouts, %man_layouts, %lib_layouts);
- while( my($var, $layout) = each(%layouts) ) {
- my($s, $t, $d, $style) = @{$layout}{qw(s t d style)};
- my $r = '$('.$type2prefix{$t}.')';
-
- print STDERR "Prefixing $var\n" if $Verbose >= 2;
-
- my $installvar = "install$var";
- my $Installvar = uc $installvar;
- next if $self->{$Installvar};
-
- $d = "$style/$d" if $style;
- $self->prefixify($installvar, $s, $r, $d);
-
- print STDERR " $Installvar == $self->{$Installvar}\n"
- if $Verbose >= 2;
- }
-
- # Generate these if they weren't figured out.
- $self->{VENDORARCHEXP} ||= $self->{INSTALLVENDORARCH};
- $self->{VENDORLIBEXP} ||= $self->{INSTALLVENDORLIB};
-
- return 1;
-}
-
-
-=head3 init_from_INSTALL_BASE
-
- $mm->init_from_INSTALL_BASE
-
-=cut
-
-my %map = (
- lib => [qw(lib perl5)],
- arch => [('lib', 'perl5', $Config{archname})],
- bin => [qw(bin)],
- man1dir => [qw(man man1)],
- man3dir => [qw(man man3)]
- );
-$map{script} = $map{bin};
-
-sub init_INSTALL_from_INSTALL_BASE {
- my $self = shift;
-
- @{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} =
- '$(INSTALL_BASE)';
-
- my %install;
- foreach my $thing (keys %map) {
- foreach my $dir (('', 'SITE', 'VENDOR')) {
- my $uc_thing = uc $thing;
- my $key = "INSTALL".$dir.$uc_thing;
-
- $install{$key} ||=
- $self->catdir('$(INSTALL_BASE)', @{$map{$thing}});
- }
- }
-
- # Adjust for variable quirks.
- $install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH};
- $install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB};
-
- foreach my $key (keys %install) {
- $self->{$key} ||= $install{$key};
- }
-
- return 1;
-}
-
-
-=head3 init_VERSION I<Abstract>
-
- $mm->init_VERSION
-
-Initialize macros representing versions of MakeMaker and other tools
-
-MAKEMAKER: path to the MakeMaker module.
-
-MM_VERSION: ExtUtils::MakeMaker Version
-
-MM_REVISION: ExtUtils::MakeMaker version control revision (for backwards
- compat)
-
-VERSION: version of your module
-
-VERSION_MACRO: which macro represents the version (usually 'VERSION')
-
-VERSION_SYM: like version but safe for use as an RCS revision number
-
-DEFINE_VERSION: -D line to set the module version when compiling
-
-XS_VERSION: version in your .xs file. Defaults to $(VERSION)
-
-XS_VERSION_MACRO: which macro represents the XS version.
-
-XS_DEFINE_VERSION: -D line to set the xs version when compiling.
-
-Called by init_main.
-
-=cut
-
-sub init_VERSION {
- my($self) = shift;
-
- $self->{MAKEMAKER} = $ExtUtils::MakeMaker::Filename;
- $self->{MM_VERSION} = $ExtUtils::MakeMaker::VERSION;
- $self->{MM_REVISION}= $ExtUtils::MakeMaker::Revision;
- $self->{VERSION_FROM} ||= '';
-
- if ($self->{VERSION_FROM}){
- $self->{VERSION} = $self->parse_version($self->{VERSION_FROM});
- if( $self->{VERSION} eq 'undef' ) {
- carp("WARNING: Setting VERSION via file ".
- "'$self->{VERSION_FROM}' failed\n");
- }
- }
-
- # strip blanks
- if (defined $self->{VERSION}) {
- $self->{VERSION} =~ s/^\s+//;
- $self->{VERSION} =~ s/\s+$//;
- }
- else {
- $self->{VERSION} = '';
- }
-
-
- $self->{VERSION_MACRO} = 'VERSION';
- ($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g;
- $self->{DEFINE_VERSION} = '-D$(VERSION_MACRO)=\"$(VERSION)\"';
-
-
- # Graham Barr and Paul Marquess had some ideas how to ensure
- # version compatibility between the *.pm file and the
- # corresponding *.xs file. The bottomline was, that we need an
- # XS_VERSION macro that defaults to VERSION:
- $self->{XS_VERSION} ||= $self->{VERSION};
-
- $self->{XS_VERSION_MACRO} = 'XS_VERSION';
- $self->{XS_DEFINE_VERSION} = '-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"';
-
-}
-
-
-=head3 init_others
-
- $MM->init_others();
-
-Initializes the macro definitions used by tools_other() and places them
-in the $MM object.
-
-If there is no description, its the same as the parameter to
-WriteMakefile() documented in ExtUtils::MakeMaker.
-
-Defines at least these macros.
-
- Macro Description
-
- NOOP Do nothing
- NOECHO Tell make not to display the command itself
-
- MAKEFILE
- FIRST_MAKEFILE
- MAKEFILE_OLD
- MAKE_APERL_FILE File used by MAKE_APERL
-
- SHELL Program used to run shell commands
-
- ECHO Print text adding a newline on the end
- RM_F Remove a file
- RM_RF Remove a directory
- TOUCH Update a file's timestamp
- TEST_F Test for a file's existence
- CP Copy a file
- MV Move a file
- CHMOD Change permissions on a file
- FALSE Exit with non-zero
- TRUE Exit with zero
-
- UMASK_NULL Nullify umask
- DEV_NULL Suppress all command output
-
-=cut
-
-sub init_others {
- my $self = shift;
-
- $self->{ECHO} ||= $self->oneliner('print qq{@ARGV}', ['-l']);
- $self->{ECHO_N} ||= $self->oneliner('print qq{@ARGV}');
-
- $self->{TOUCH} ||= $self->oneliner('touch', ["-MExtUtils::Command"]);
- $self->{CHMOD} ||= $self->oneliner('chmod', ["-MExtUtils::Command"]);
- $self->{RM_F} ||= $self->oneliner('rm_f', ["-MExtUtils::Command"]);
- $self->{RM_RF} ||= $self->oneliner('rm_rf', ["-MExtUtils::Command"]);
- $self->{TEST_F} ||= $self->oneliner('test_f', ["-MExtUtils::Command"]);
- $self->{FALSE} ||= $self->oneliner('exit 1');
- $self->{TRUE} ||= $self->oneliner('exit 0');
-
- $self->{MKPATH} ||= $self->oneliner('mkpath', ["-MExtUtils::Command"]);
-
- $self->{CP} ||= $self->oneliner('cp', ["-MExtUtils::Command"]);
- $self->{MV} ||= $self->oneliner('mv', ["-MExtUtils::Command"]);
-
- $self->{MOD_INSTALL} ||=
- $self->oneliner(<<'CODE', ['-MExtUtils::Install']);
-install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
-CODE
- $self->{DOC_INSTALL} ||= $self->oneliner('perllocal_install', ["-MExtUtils::Command::MM"]);
- $self->{UNINSTALL} ||= $self->oneliner('uninstall', ["-MExtUtils::Command::MM"]);
- $self->{WARN_IF_OLD_PACKLIST} ||=
- $self->oneliner('warn_if_old_packlist', ["-MExtUtils::Command::MM"]);
- $self->{FIXIN} ||= $self->oneliner('MY->fixin(shift)', ["-MExtUtils::MY"]);
- $self->{EQUALIZE_TIMESTAMP} ||= $self->oneliner('eqtime', ["-MExtUtils::Command"]);
-
- $self->{UNINST} ||= 0;
- $self->{VERBINST} ||= 0;
-
- $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE} || 'Makefile';
- $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
- $self->{MAKEFILE_OLD} ||= $self->{MAKEFILE}.'.old';
- $self->{MAKE_APERL_FILE} ||= $self->{MAKEFILE}.'.aperl';
-
- # Not everybody uses -f to indicate "use this Makefile instead"
- $self->{USEMAKEFILE} ||= '-f';
-
- # Some makes require a wrapper around macros passed in on the command
- # line.
- $self->{MACROSTART} ||= '';
- $self->{MACROEND} ||= '';
-
- $self->{SHELL} ||= $Config{sh};
-
- # UMASK_NULL is not used by MakeMaker but some CPAN modules
- # make use of it.
- $self->{UMASK_NULL} ||= "umask 0";
-
- # Not the greatest default, but its something.
- $self->{DEV_NULL} ||= "> /dev/null 2>&1";
-
- $self->{NOOP} ||= '$(TRUE)';
- $self->{NOECHO} = '@' unless defined $self->{NOECHO};
-
- $self->{LD_RUN_PATH} = "";
-
- $self->{LIBS} = $self->_fix_libs($self->{LIBS});
-
- # Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS}
- foreach my $libs ( @{$self->{LIBS}} ){
- $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace
- my(@libs) = $self->extliblist($libs);
- if ($libs[0] or $libs[1] or $libs[2]){
- # LD_RUN_PATH now computed by ExtUtils::Liblist
- ($self->{EXTRALIBS}, $self->{BSLOADLIBS},
- $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs;
- last;
- }
- }
-
- if ( $self->{OBJECT} ) {
- $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g;
- } else {
- # init_dirscan should have found out, if we have C files
- $self->{OBJECT} = "";
- $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]};
- }
- $self->{OBJECT} =~ s/\n+/ \\\n\t/g;
-
- $self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : "";
- $self->{PERLMAINCC} ||= '$(CC)';
- $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM};
-
- # Sanity check: don't define LINKTYPE = dynamic if we're skipping
- # the 'dynamic' section of MM. We don't have this problem with
- # 'static', since we either must use it (%Config says we can't
- # use dynamic loading) or the caller asked for it explicitly.
- if (!$self->{LINKTYPE}) {
- $self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'}
- ? 'static'
- : ($Config{usedl} ? 'dynamic' : 'static');
- }
-
- return 1;
-}
-
-
-# Lets look at $self->{LIBS} carefully: It may be an anon array, a string or
-# undefined. In any case we turn it into an anon array
-sub _fix_libs {
- my($self, $libs) = @_;
-
- return !defined $libs ? [''] :
- !ref $libs ? [$libs] :
- !defined $libs->[0] ? [''] :
- $libs ;
-}
-
-
-=head3 tools_other
-
- my $make_frag = $MM->tools_other;
-
-Returns a make fragment containing definitions for the macros init_others()
-initializes.
-
-=cut
-
-sub tools_other {
- my($self) = shift;
- my @m;
-
- # We set PM_FILTER as late as possible so it can see all the earlier
- # on macro-order sensitive makes such as nmake.
- for my $tool (qw{ SHELL CHMOD CP MV NOOP NOECHO RM_F RM_RF TEST_F TOUCH
- UMASK_NULL DEV_NULL MKPATH EQUALIZE_TIMESTAMP
- FALSE TRUE
- ECHO ECHO_N
- UNINST VERBINST
- MOD_INSTALL DOC_INSTALL UNINSTALL
- WARN_IF_OLD_PACKLIST
- MACROSTART MACROEND
- USEMAKEFILE
- PM_FILTER
- FIXIN
- } )
- {
- next unless defined $self->{$tool};
- push @m, "$tool = $self->{$tool}\n";
- }
-
- return join "", @m;
-}
-
-
-=head3 init_DIRFILESEP I<Abstract>
-
- $MM->init_DIRFILESEP;
- my $dirfilesep = $MM->{DIRFILESEP};
-
-Initializes the DIRFILESEP macro which is the seperator between the
-directory and filename in a filepath. ie. / on Unix, \ on Win32 and
-nothing on VMS.
-
-For example:
-
- # instead of $(INST_ARCHAUTODIR)/extralibs.ld
- $(INST_ARCHAUTODIR)$(DIRFILESEP)extralibs.ld
-
-Something of a hack but it prevents a lot of code duplication between
-MM_* variants.
-
-Do not use this as a seperator between directories. Some operating
-systems use different seperators between subdirectories as between
-directories and filenames (for example: VOLUME:[dir1.dir2]file on VMS).
-
-=head3 init_linker I<Abstract>
-
- $mm->init_linker;
-
-Initialize macros which have to do with linking.
-
-PERL_ARCHIVE: path to libperl.a equivalent to be linked to dynamic
-extensions.
-
-PERL_ARCHIVE_AFTER: path to a library which should be put on the
-linker command line I<after> the external libraries to be linked to
-dynamic extensions. This may be needed if the linker is one-pass, and
-Perl includes some overrides for C RTL functions, such as malloc().
-
-EXPORT_LIST: name of a file that is passed to linker to define symbols
-to be exported.
-
-Some OSes do not need these in which case leave it blank.
-
-
-=head3 init_platform
-
- $mm->init_platform
-
-Initialize any macros which are for platform specific use only.
-
-A typical one is the version number of your OS specific mocule.
-(ie. MM_Unix_VERSION or MM_VMS_VERSION).
-
-=cut
-
-sub init_platform {
- return '';
-}
-
-
-=head3 init_MAKE
-
- $mm->init_MAKE
-
-Initialize MAKE from either a MAKE environment variable or $Config{make}.
-
-=cut
-
-sub init_MAKE {
- my $self = shift;
-
- $self->{MAKE} ||= $ENV{MAKE} || $Config{make};
-}
-
-
-=head2 Tools
-
-A grab bag of methods to generate specific macros and commands.
-
-
-
-=head3 manifypods
-
-Defines targets and routines to translate the pods into manpages and
-put them into the INST_* directories.
-
-=cut
-
-sub manifypods {
- my $self = shift;
-
- my $POD2MAN_macro = $self->POD2MAN_macro();
- my $manifypods_target = $self->manifypods_target();
-
- return <<END_OF_TARGET;
-
-$POD2MAN_macro
-
-$manifypods_target
-
-END_OF_TARGET
-
-}
-
-
-=head3 POD2MAN_macro
-
- my $pod2man_macro = $self->POD2MAN_macro
-
-Returns a definition for the POD2MAN macro. This is a program
-which emulates the pod2man utility. You can add more switches to the
-command by simply appending them on the macro.
-
-Typical usage:
-
- $(POD2MAN) --section=3 --perm_rw=$(PERM_RW) podfile1 man_page1 ...
-
-=cut
-
-sub POD2MAN_macro {
- my $self = shift;
-
-# Need the trailing '--' so perl stops gobbling arguments and - happens
-# to be an alternative end of line seperator on VMS so we quote it
- return <<'END_OF_DEF';
-POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--"
-POD2MAN = $(POD2MAN_EXE)
-END_OF_DEF
-}
-
-
-=head3 test_via_harness
-
- my $command = $mm->test_via_harness($perl, $tests);
-
-Returns a $command line which runs the given set of $tests with
-Test::Harness and the given $perl.
-
-Used on the t/*.t files.
-
-=cut
-
-sub test_via_harness {
- my($self, $perl, $tests) = @_;
-
- return qq{\t$perl "-MExtUtils::Command::MM" }.
- qq{"-e" "test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n};
-}
-
-=head3 test_via_script
-
- my $command = $mm->test_via_script($perl, $script);
-
-Returns a $command line which just runs a single test without
-Test::Harness. No checks are done on the results, they're just
-printed.
-
-Used for test.pl, since they don't always follow Test::Harness
-formatting.
-
-=cut
-
-sub test_via_script {
- my($self, $perl, $script) = @_;
- return qq{\t$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)" $script\n};
-}
-
-
-=head3 tool_autosplit
-
-Defines a simple perl call that runs autosplit. May be deprecated by
-pm_to_blib soon.
-
-=cut
-
-sub tool_autosplit {
- my($self, %attribs) = @_;
-
- my $maxlen = $attribs{MAXLEN} ? '$$AutoSplit::Maxlen=$attribs{MAXLEN};'
- : '';
-
- my $asplit = $self->oneliner(sprintf <<'PERL_CODE', $maxlen);
-use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1)
-PERL_CODE
-
- return sprintf <<'MAKE_FRAG', $asplit;
-# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto
-AUTOSPLITFILE = %s
-
-MAKE_FRAG
-
-}
-
-
-=head3 arch_check
-
- my $arch_ok = $mm->arch_check(
- $INC{"Config.pm"},
- File::Spec->catfile($Config{archlibexp}, "Config.pm")
- );
-
-A sanity check that what Perl thinks the architecture is and what
-Config thinks the architecture is are the same. If they're not it
-will return false and show a diagnostic message.
-
-When building Perl it will always return true, as nothing is installed
-yet.
-
-The interface is a bit odd because this is the result of a
-quick refactoring. Don't rely on it.
-
-=cut
-
-sub arch_check {
- my $self = shift;
- my($pconfig, $cconfig) = @_;
-
- return 1 if $self->{PERL_SRC};
-
- my($pvol, $pthinks) = $self->splitpath($pconfig);
- my($cvol, $cthinks) = $self->splitpath($cconfig);
-
- $pthinks = $self->canonpath($pthinks);
- $cthinks = $self->canonpath($cthinks);
-
- my $ret = 1;
- if ($pthinks ne $cthinks) {
- print "Have $pthinks\n";
- print "Want $cthinks\n";
-
- $ret = 0;
-
- my $arch = (grep length, $self->splitdir($pthinks))[-1];
-
- print STDOUT <<END unless $self->{UNINSTALLED_PERL};
-Your perl and your Config.pm seem to have different ideas about the
-architecture they are running on.
-Perl thinks: [$arch]
-Config says: [$Config{archname}]
-This may or may not cause problems. Please check your installation of perl
-if you have problems building this extension.
-END
- }
-
- return $ret;
-}
-
-
-
-=head2 File::Spec wrappers
-
-ExtUtils::MM_Any is a subclass of File::Spec. The methods noted here
-override File::Spec.
-
-
-
-=head3 catfile
-
-File::Spec <= 0.83 has a bug where the file part of catfile is not
-canonicalized. This override fixes that bug.
-
-=cut
-
-sub catfile {
- my $self = shift;
- return $self->canonpath($self->SUPER::catfile(@_));
-}
-
-
-
-=head2 Misc
-
-Methods I can't really figure out where they should go yet.
-
-
-=head3 find_tests
-
- my $test = $mm->find_tests;
-
-Returns a string suitable for feeding to the shell to return all
-tests in t/*.t.
-
-=cut
-
-sub find_tests {
- my($self) = shift;
- return -d 't' ? 't/*.t' : '';
-}
-
-
-=head3 extra_clean_files
-
- my @files_to_clean = $MM->extra_clean_files;
-
-Returns a list of OS specific files to be removed in the clean target in
-addition to the usual set.
-
-=cut
-
-# An empty method here tickled a perl 5.8.1 bug and would return its object.
-sub extra_clean_files {
- return;
-}
-
-
-=head3 installvars
-
- my @installvars = $mm->installvars;
-
-A list of all the INSTALL* variables without the INSTALL prefix. Useful
-for iteration or building related variable sets.
-
-=cut
-
-sub installvars {
- return qw(PRIVLIB SITELIB VENDORLIB
- ARCHLIB SITEARCH VENDORARCH
- BIN SITEBIN VENDORBIN
- SCRIPT SITESCRIPT VENDORSCRIPT
- MAN1DIR SITEMAN1DIR VENDORMAN1DIR
- MAN3DIR SITEMAN3DIR VENDORMAN3DIR
- );
-}
-
-
-=head3 libscan
-
- my $wanted = $self->libscan($path);
-
-Takes a path to a file or dir and returns an empty string if we don't
-want to include this file in the library. Otherwise it returns the
-the $path unchanged.
-
-Mainly used to exclude version control administrative directories from
-installation.
-
-=cut
-
-sub libscan {
- my($self,$path) = @_;
- my($dirs,$file) = ($self->splitpath($path))[1,2];
- return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/,
- $self->splitdir($dirs), $file;
-
- return $path;
-}
-
-
-=head3 platform_constants
-
- my $make_frag = $mm->platform_constants
-
-Returns a make fragment defining all the macros initialized in
-init_platform() rather than put them in constants().
-
-=cut
-
-sub platform_constants {
- return '';
-}
-
-=begin private
-
-=head3 _PREREQ_PRINT
-
- $self->_PREREQ_PRINT;
-
-Implements PREREQ_PRINT.
-
-Refactored out of MakeMaker->new().
-
-=end private
-
-=cut
-
-sub _PREREQ_PRINT {
- my $self = shift;
-
- require Data::Dumper;
- my @what = ('PREREQ_PM');
- push @what, 'MIN_PERL_VERSION' if $self->{MIN_PERL_VERSION};
- push @what, 'BUILD_REQUIRES' if $self->{BUILD_REQUIRES};
- print Data::Dumper->Dump([@{$self}{@what}], \@what);
- exit 0;
-}
-
-
-=begin private
-
-=head3 _PRINT_PREREQ
-
- $mm->_PRINT_PREREQ;
-
-Implements PRINT_PREREQ, a slightly different version of PREREQ_PRINT
-added by Redhat to, I think, support generating RPMs from Perl modules.
-
-Refactored out of MakeMaker->new().
-
-=end private
-
-=cut
-
-sub _PRINT_PREREQ {
- my $self = shift;
-
- my $prereqs= $self->_all_prereqs;
- my @prereq = map { [$_, $prereqs->{$_}] } keys %$prereqs;
-
- if ( $self->{MIN_PERL_VERSION} ) {
- push @prereq, ['perl' => $self->{MIN_PERL_VERSION}];
- }
-
- print join(" ", map { "perl($_->[0])>=$_->[1] " }
- sort { $a->[0] cmp $b->[0] } @prereq), "\n";
- exit 0;
-}
-
-
-=begin private
-
-=head3 _all_prereqs
-
- my $prereqs = $self->_all_prereqs;
-
-Returns a hash ref of both PREREQ_PM and BUILD_REQUIRES.
-
-=end private
-
-=cut
-
-sub _all_prereqs {
- my $self = shift;
-
- return { %{$self->{PREREQ_PM}}, %{$self->{BUILD_REQUIRES}} };
-}
-
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern at pobox.com> and the denizens of
-makemaker at perl.org with code from ExtUtils::MM_Unix and
-ExtUtils::MM_Win32.
-
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_BeOS.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_BeOS.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_BeOS.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,61 +0,0 @@
-package ExtUtils::MM_BeOS;
-
-use strict;
-
-=head1 NAME
-
-ExtUtils::MM_BeOS - methods to override UN*X behaviour in ExtUtils::MakeMaker
-
-=head1 SYNOPSIS
-
- use ExtUtils::MM_BeOS; # Done internally by ExtUtils::MakeMaker if needed
-
-=head1 DESCRIPTION
-
-See ExtUtils::MM_Unix for a documentation of the methods provided
-there. This package overrides the implementation of these methods, not
-the semantics.
-
-=over 4
-
-=cut
-
-use ExtUtils::MakeMaker::Config;
-use File::Spec;
-require ExtUtils::MM_Any;
-require ExtUtils::MM_Unix;
-
-our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '6.55_02';
-
-
-=item os_flavor
-
-BeOS is BeOS.
-
-=cut
-
-sub os_flavor {
- return('BeOS');
-}
-
-=item init_linker
-
-libperl.a equivalent to be linked to dynamic extensions.
-
-=cut
-
-sub init_linker {
- my($self) = shift;
-
- $self->{PERL_ARCHIVE} ||=
- File::Spec->catdir('$(PERL_INC)',$Config{libperl});
- $self->{PERL_ARCHIVE_AFTER} ||= '';
- $self->{EXPORT_LIST} ||= '';
-}
-
-=back
-
-1;
-__END__
-
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_Cygwin.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Cygwin.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Cygwin.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,123 +0,0 @@
-package ExtUtils::MM_Cygwin;
-
-use strict;
-
-use ExtUtils::MakeMaker::Config;
-use File::Spec;
-
-require ExtUtils::MM_Unix;
-require ExtUtils::MM_Win32;
-our @ISA = qw( ExtUtils::MM_Unix );
-
-our $VERSION = '6.55_02';
-
-
-=head1 NAME
-
-ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker
-
-=head1 SYNOPSIS
-
- use ExtUtils::MM_Cygwin; # Done internally by ExtUtils::MakeMaker if needed
-
-=head1 DESCRIPTION
-
-See ExtUtils::MM_Unix for a documentation of the methods provided there.
-
-=over 4
-
-=item os_flavor
-
-We're Unix and Cygwin.
-
-=cut
-
-sub os_flavor {
- return('Unix', 'Cygwin');
-}
-
-=item cflags
-
-if configured for dynamic loading, triggers #define EXT in EXTERN.h
-
-=cut
-
-sub cflags {
- my($self,$libperl)=@_;
- return $self->{CFLAGS} if $self->{CFLAGS};
- return '' unless $self->needs_linking();
-
- my $base = $self->SUPER::cflags($libperl);
- foreach (split /\n/, $base) {
- /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
- };
- $self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true');
-
- return $self->{CFLAGS} = qq{
-CCFLAGS = $self->{CCFLAGS}
-OPTIMIZE = $self->{OPTIMIZE}
-PERLTYPE = $self->{PERLTYPE}
-};
-
-}
-
-
-=item replace_manpage_separator
-
-replaces strings '::' with '.' in MAN*POD man page names
-
-=cut
-
-sub replace_manpage_separator {
- my($self, $man) = @_;
- $man =~ s{/+}{.}g;
- return $man;
-}
-
-=item init_linker
-
-points to libperl.a
-
-=cut
-
-sub init_linker {
- my $self = shift;
-
- if ($Config{useshrplib} eq 'true') {
- my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}";
- if( $] >= 5.006002 ) {
- $libperl =~ s/a$/dll.a/;
- }
- $self->{PERL_ARCHIVE} = $libperl;
- } else {
- $self->{PERL_ARCHIVE} =
- '$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a");
- }
-
- $self->{PERL_ARCHIVE_AFTER} ||= '';
- $self->{EXPORT_LIST} ||= '';
-}
-
-=item maybe_command
-
-If our path begins with F</cygdrive/> then we use C<ExtUtils::MM_Win32>
-to determine if it may be a command. Otherwise we use the tests
-from C<ExtUtils::MM_Unix>.
-
-=cut
-
-sub maybe_command {
- my ($self, $file) = @_;
-
- if ($file =~ m{^/cygdrive/}i) {
- return ExtUtils::MM_Win32->maybe_command($file);
- }
-
- return $self->SUPER::maybe_command($file);
-}
-
-=back
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_DOS.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_DOS.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_DOS.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,65 +0,0 @@
-package ExtUtils::MM_DOS;
-
-use strict;
-
-our $VERSION = 6.55_02;
-
-require ExtUtils::MM_Any;
-require ExtUtils::MM_Unix;
-our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-
-
-=head1 NAME
-
-ExtUtils::MM_DOS - DOS specific subclass of ExtUtils::MM_Unix
-
-=head1 SYNOPSIS
-
- Don't use this module directly.
- Use ExtUtils::MM and let it choose.
-
-=head1 DESCRIPTION
-
-This is a subclass of ExtUtils::MM_Unix which contains functionality
-for DOS.
-
-Unless otherwise stated, it works just like ExtUtils::MM_Unix
-
-=head2 Overridden methods
-
-=over 4
-
-=item os_flavor
-
-=cut
-
-sub os_flavor {
- return('DOS');
-}
-
-=item B<replace_manpage_separator>
-
-Generates Foo__Bar.3 style man page names
-
-=cut
-
-sub replace_manpage_separator {
- my($self, $man) = @_;
-
- $man =~ s,/+,__,g;
- return $man;
-}
-
-=back
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
-
-=head1 SEE ALSO
-
-L<ExtUtils::MM_Unix>, L<ExtUtils::MakeMaker>
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_Darwin.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Darwin.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Darwin.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,47 +0,0 @@
-package ExtUtils::MM_Darwin;
-
-use strict;
-
-BEGIN {
- require ExtUtils::MM_Unix;
- our @ISA = qw( ExtUtils::MM_Unix );
-}
-
-our $VERSION = '6.55_02';
-
-
-=head1 NAME
-
-ExtUtils::MM_Darwin - special behaviors for OS X
-
-=head1 SYNOPSIS
-
- For internal MakeMaker use only
-
-=head1 DESCRIPTION
-
-See L<ExtUtils::MM_Unix> for L<ExtUtils::MM_Any> for documention on the
-methods overridden here.
-
-=head2 Overriden Methods
-
-=head3 init_dist
-
-Turn off Apple tar's tendency to copy resource forks as "._foo" files.
-
-=cut
-
-sub init_dist {
- my $self = shift;
-
- # Thank you, Apple, for breaking tar and then breaking the work around.
- # 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants
- # COPYFILE_DISABLE. I'm not going to push my luck and instead just
- # set both.
- $self->{TAR} ||=
- 'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar';
-
- $self->SUPER::init_dist(@_);
-}
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_MacOS.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_MacOS.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_MacOS.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,40 +0,0 @@
-package ExtUtils::MM_MacOS;
-
-use strict;
-
-our $VERSION = 6.55_02;
-
-sub new {
- die <<'UNSUPPORTED';
-MacOS Classic (MacPerl) is no longer supported by MakeMaker.
-Please use Module::Build instead.
-UNSUPPORTED
-}
-
-=head1 NAME
-
-ExtUtils::MM_MacOS - once produced Makefiles for MacOS Classic
-
-=head1 SYNOPSIS
-
- # MM_MacOS no longer contains any code. This is just a stub.
-
-=head1 DESCRIPTION
-
-Once upon a time, MakeMaker could produce an approximation of a correct
-Makefile on MacOS Classic (MacPerl). Due to a lack of maintainers, this
-fell out of sync with the rest of MakeMaker and hadn't worked in years.
-Since there's little chance of it being repaired, MacOS Classic is fading
-away, and the code was icky to begin with, the code has been deleted to
-make maintenance easier.
-
-Those interested in writing modules for MacPerl should use Module::Build
-which works better than MakeMaker ever did.
-
-Anyone interested in resurrecting this file should pull the old version
-from the MakeMaker CVS repository and contact makemaker at perl.org, but we
-really encourage you to work on Module::Build instead.
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_NW5.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_NW5.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_NW5.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,269 +0,0 @@
-package ExtUtils::MM_NW5;
-
-=head1 NAME
-
-ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker
-
-=head1 SYNOPSIS
-
- use ExtUtils::MM_NW5; # Done internally by ExtUtils::MakeMaker if needed
-
-=head1 DESCRIPTION
-
-See ExtUtils::MM_Unix for a documentation of the methods provided
-there. This package overrides the implementation of these methods, not
-the semantics.
-
-=over
-
-=cut
-
-use strict;
-use ExtUtils::MakeMaker::Config;
-use File::Basename;
-
-our $VERSION = '6.55_02';
-
-require ExtUtils::MM_Win32;
-our @ISA = qw(ExtUtils::MM_Win32);
-
-use ExtUtils::MakeMaker qw( &neatvalue );
-
-$ENV{EMXSHELL} = 'sh'; # to run `commands`
-
-my $BORLAND = $Config{'cc'} =~ /^bcc/i;
-my $GCC = $Config{'cc'} =~ /^gcc/i;
-
-
-=item os_flavor
-
-We're Netware in addition to being Windows.
-
-=cut
-
-sub os_flavor {
- my $self = shift;
- return ($self->SUPER::os_flavor, 'Netware');
-}
-
-=item init_platform
-
-Add Netware macros.
-
-LIBPTH, BASE_IMPORT, NLM_VERSION, MPKTOOL, TOOLPATH, BOOT_SYMBOL,
-NLM_SHORT_NAME, INCLUDE, PATH, MM_NW5_REVISION
-
-
-=item platform_constants
-
-Add Netware macros initialized above to the Makefile.
-
-=cut
-
-sub init_platform {
- my($self) = shift;
-
- # To get Win32's setup.
- $self->SUPER::init_platform;
-
- # incpath is copied to makefile var INCLUDE in constants sub, here just
- # make it empty
- my $libpth = $Config{'libpth'};
- $libpth =~ s( )(;);
- $self->{'LIBPTH'} = $libpth;
-
- $self->{'BASE_IMPORT'} = $Config{'base_import'};
-
- # Additional import file specified from Makefile.pl
- if($self->{'base_import'}) {
- $self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'};
- }
-
- $self->{'NLM_VERSION'} = $Config{'nlm_version'};
- $self->{'MPKTOOL'} = $Config{'mpktool'};
- $self->{'TOOLPATH'} = $Config{'toolpath'};
-
- (my $boot = $self->{'NAME'}) =~ s/:/_/g;
- $self->{'BOOT_SYMBOL'}=$boot;
-
- # If the final binary name is greater than 8 chars,
- # truncate it here.
- if(length($self->{'BASEEXT'}) > 8) {
- $self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8);
- }
-
- # Get the include path and replace the spaces with ;
- # Copy this to makefile as INCLUDE = d:\...;d:\;
- ($self->{INCLUDE} = $Config{'incpath'}) =~ s/([ ]*)-I/;/g;
-
- # Set the path to CodeWarrior binaries which might not have been set in
- # any other place
- $self->{PATH} = '$(PATH);$(TOOLPATH)';
-
- $self->{MM_NW5_VERSION} = $VERSION;
-}
-
-sub platform_constants {
- my($self) = shift;
- my $make_frag = '';
-
- # Setup Win32's constants.
- $make_frag .= $self->SUPER::platform_constants;
-
- foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL
- TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH
- MM_NW5_VERSION
- ))
- {
- next unless defined $self->{$macro};
- $make_frag .= "$macro = $self->{$macro}\n";
- }
-
- return $make_frag;
-}
-
-
-=item const_cccmd
-
-=cut
-
-sub const_cccmd {
- my($self,$libperl)=@_;
- return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
- return '' unless $self->needs_linking();
- return $self->{CONST_CCCMD} = <<'MAKE_FRAG';
-CCCMD = $(CC) $(CCFLAGS) $(INC) $(OPTIMIZE) \
- $(PERLTYPE) $(MPOLLUTE) -o $@ \
- -DVERSION=\"$(VERSION)\" -DXS_VERSION=\"$(XS_VERSION)\"
-MAKE_FRAG
-
-}
-
-
-=item static_lib
-
-=cut
-
-sub static_lib {
- my($self) = @_;
-
- return '' unless $self->has_link_code;
-
- my $m = <<'END';
-$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(RM_RF) $@
-END
-
- # If this extension has it's own library (eg SDBM_File)
- # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
- $m .= <<'END' if $self->{MYEXTLIB};
- $self->{CP} $(MYEXTLIB) $@
-END
-
- my $ar_arg;
- if( $BORLAND ) {
- $ar_arg = '$@ $(OBJECT:^"+")';
- }
- elsif( $GCC ) {
- $ar_arg = '-ru $@ $(OBJECT)';
- }
- else {
- $ar_arg = '-type library -o $@ $(OBJECT)';
- }
-
- $m .= sprintf <<'END', $ar_arg;
- $(AR) %s
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
- $(CHMOD) 755 $@
-END
-
- $m .= <<'END' if $self->{PERL_SRC};
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
-
-
-END
- return $m;
-}
-
-=item dynamic_lib
-
-Defines how to produce the *.so (or equivalent) files.
-
-=cut
-
-sub dynamic_lib {
- my($self, %attribs) = @_;
- return '' unless $self->needs_linking(); #might be because of a subdir
-
- return '' unless $self->has_link_code;
-
- my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
- my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
- my($ldfrom) = '$(LDFROM)';
-
- (my $boot = $self->{NAME}) =~ s/:/_/g;
-
- my $m = <<'MAKE_FRAG';
-# This section creates the dynamically loadable $(INST_DYNAMIC)
-# from $(OBJECT) and possibly $(MYEXTLIB).
-OTHERLDFLAGS = '.$otherldflags.'
-INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
-
-# Create xdc data for an MT safe NLM in case of mpk build
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > $(BASEEXT).def
- $(NOECHO) $(ECHO) $(BASE_IMPORT) >> $(BASEEXT).def
- $(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> $(BASEEXT).def
-MAKE_FRAG
-
-
- if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) {
- $m .= <<'MAKE_FRAG';
- $(MPKTOOL) $(XDCFLAGS) $(BASEEXT).xdc
- $(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> $(BASEEXT).def
-MAKE_FRAG
- }
-
- # Reconstruct the X.Y.Z version.
- my $version = join '.', map { sprintf "%d", $_ }
- $] =~ /(\d)\.(\d{3})(\d{2})/;
- $m .= sprintf ' $(LD) $(LDFLAGS) $(OBJECT:.obj=.obj) -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION)', $version;
-
- # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc
- if($self->{NLM_SHORT_NAME}) {
- # In case of nlms with names exceeding 8 chars, build nlm in the
- # current dir, rename and move to auto\lib.
- $m .= q{ -o $(NLM_SHORT_NAME).$(DLEXT)}
- } else {
- $m .= q{ -o $(INST_AUTODIR)\\$(BASEEXT).$(DLEXT)}
- }
-
- # Add additional lib files if any (SDBM_File)
- $m .= q{ $(MYEXTLIB) } if $self->{MYEXTLIB};
-
- $m .= q{ $(PERL_INC)\Main.lib -commandfile $(BASEEXT).def}."\n";
-
- if($self->{NLM_SHORT_NAME}) {
- $m .= <<'MAKE_FRAG';
- if exist $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT) del $(INST_AUTODIR)\$(NLM_SHORT_NAME).$(DLEXT)
- move $(NLM_SHORT_NAME).$(DLEXT) $(INST_AUTODIR)
-MAKE_FRAG
- }
-
- $m .= <<'MAKE_FRAG';
-
- $(CHMOD) 755 $@
-MAKE_FRAG
-
- return $m;
-}
-
-
-1;
-__END__
-
-=back
-
-=cut
-
-
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_OS2.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_OS2.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_OS2.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,151 +0,0 @@
-package ExtUtils::MM_OS2;
-
-use strict;
-
-use ExtUtils::MakeMaker qw(neatvalue);
-use File::Spec;
-
-our $VERSION = '6.55_02';
-
-require ExtUtils::MM_Any;
-require ExtUtils::MM_Unix;
-our @ISA = qw(ExtUtils::MM_Any ExtUtils::MM_Unix);
-
-=pod
-
-=head1 NAME
-
-ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker
-
-=head1 SYNOPSIS
-
- use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed
-
-=head1 DESCRIPTION
-
-See ExtUtils::MM_Unix for a documentation of the methods provided
-there. This package overrides the implementation of these methods, not
-the semantics.
-
-=head1 METHODS
-
-=over 4
-
-=item init_dist
-
-Define TO_UNIX to convert OS2 linefeeds to Unix style.
-
-=cut
-
-sub init_dist {
- my($self) = @_;
-
- $self->{TO_UNIX} ||= <<'MAKE_TEXT';
-$(NOECHO) $(TEST_F) tmp.zip && $(RM_F) tmp.zip; $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM_F) tmp.zip
-MAKE_TEXT
-
- $self->SUPER::init_dist;
-}
-
-sub dlsyms {
- my($self,%attribs) = @_;
-
- my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
- my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
- my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
- my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
- my(@m);
- (my $boot = $self->{NAME}) =~ s/:/_/g;
-
- if (not $self->{SKIPHASH}{'dynamic'}) {
- push(@m,"
-$self->{BASEEXT}.def: Makefile.PL
-",
- ' $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e \'use ExtUtils::Mksymlists; \\
- Mksymlists("NAME" => "$(NAME)", "DLBASE" => "$(DLBASE)", ',
- '"VERSION" => "$(VERSION)", "DISTNAME" => "$(DISTNAME)", ',
- '"INSTALLDIRS" => "$(INSTALLDIRS)", ',
- '"DL_FUNCS" => ',neatvalue($funcs),
- ', "FUNCLIST" => ',neatvalue($funclist),
- ', "IMPORTS" => ',neatvalue($imports),
- ', "DL_VARS" => ', neatvalue($vars), ');\'
-');
- }
- if ($self->{IMPORTS} && %{$self->{IMPORTS}}) {
- # Make import files (needed for static build)
- -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp";
- open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp";
- while (my($name, $exp) = each %{$self->{IMPORTS}}) {
- my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'";
- print $imp "$name $lib $id ?\n";
- }
- close $imp or die "Can't close tmpimp.imp";
- # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n";
- system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp"
- and die "Cannot make import library: $!, \$?=$?";
- unlink <tmp_imp/*>;
- system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}"
- and die "Cannot extract import objects: $!, \$?=$?";
- }
- join('', at m);
-}
-
-sub static_lib {
- my($self) = @_;
- my $old = $self->ExtUtils::MM_Unix::static_lib();
- return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}};
-
- my @chunks = split /\n{2,}/, $old;
- shift @chunks unless length $chunks[0]; # Empty lines at the start
- $chunks[0] .= <<'EOC';
-
- $(AR) $(AR_STATIC_ARGS) $@ tmp_imp/* && $(RANLIB) $@
-EOC
- return join "\n\n". '', @chunks;
-}
-
-sub replace_manpage_separator {
- my($self,$man) = @_;
- $man =~ s,/+,.,g;
- $man;
-}
-
-sub maybe_command {
- my($self,$file) = @_;
- $file =~ s,[/\\]+,/,g;
- return $file if -x $file && ! -d _;
- return "$file.exe" if -x "$file.exe" && ! -d _;
- return "$file.cmd" if -x "$file.cmd" && ! -d _;
- return;
-}
-
-=item init_linker
-
-=cut
-
-sub init_linker {
- my $self = shift;
-
- $self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)";
-
- $self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout
- ? ''
- : '$(PERL_INC)/libperl_override$(LIB_EXT)';
- $self->{EXPORT_LIST} = '$(BASEEXT).def';
-}
-
-=item os_flavor
-
-OS/2 is OS/2
-
-=cut
-
-sub os_flavor {
- return('OS/2');
-}
-
-=back
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_QNX.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_QNX.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_QNX.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,57 +0,0 @@
-package ExtUtils::MM_QNX;
-
-use strict;
-our $VERSION = '6.55_02';
-
-require ExtUtils::MM_Unix;
-our @ISA = qw(ExtUtils::MM_Unix);
-
-
-=head1 NAME
-
-ExtUtils::MM_QNX - QNX specific subclass of ExtUtils::MM_Unix
-
-=head1 SYNOPSIS
-
- Don't use this module directly.
- Use ExtUtils::MM and let it choose.
-
-=head1 DESCRIPTION
-
-This is a subclass of ExtUtils::MM_Unix which contains functionality for
-QNX.
-
-Unless otherwise stated it works just like ExtUtils::MM_Unix
-
-=head2 Overridden methods
-
-=head3 extra_clean_files
-
-Add .err files corresponding to each .c file.
-
-=cut
-
-sub extra_clean_files {
- my $self = shift;
-
- my @errfiles = @{$self->{C}};
- for ( @errfiles ) {
- s/.c$/.err/;
- }
-
- return( @errfiles, 'perlmain.err' );
-}
-
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
-
-=head1 SEE ALSO
-
-L<ExtUtils::MakeMaker>
-
-=cut
-
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_UWIN.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_UWIN.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_UWIN.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,64 +0,0 @@
-package ExtUtils::MM_UWIN;
-
-use strict;
-our $VERSION = 6.55_02;
-
-require ExtUtils::MM_Unix;
-our @ISA = qw(ExtUtils::MM_Unix);
-
-
-=head1 NAME
-
-ExtUtils::MM_UWIN - U/WIN specific subclass of ExtUtils::MM_Unix
-
-=head1 SYNOPSIS
-
- Don't use this module directly.
- Use ExtUtils::MM and let it choose.
-
-=head1 DESCRIPTION
-
-This is a subclass of ExtUtils::MM_Unix which contains functionality for
-the AT&T U/WIN UNIX on Windows environment.
-
-Unless otherwise stated it works just like ExtUtils::MM_Unix
-
-=head2 Overridden methods
-
-=over 4
-
-=item os_flavor
-
-In addition to being Unix, we're U/WIN.
-
-=cut
-
-sub os_flavor {
- return('Unix', 'U/WIN');
-}
-
-
-=item B<replace_manpage_separator>
-
-=cut
-
-sub replace_manpage_separator {
- my($self, $man) = @_;
-
- $man =~ s,/+,.,g;
- return $man;
-}
-
-=back
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
-
-=head1 SEE ALSO
-
-L<ExtUtils::MM_Win32>, L<ExtUtils::MakeMaker>
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_Unix.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Unix.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Unix.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,3622 +0,0 @@
-package ExtUtils::MM_Unix;
-
-require 5.006;
-
-use strict;
-
-use Carp;
-use ExtUtils::MakeMaker::Config;
-use File::Basename qw(basename dirname);
-use DirHandle;
-
-our %Config_Override;
-
-use ExtUtils::MakeMaker qw($Verbose neatvalue);
-
-# If we make $VERSION an our variable parse_version() breaks
-use vars qw($VERSION);
-$VERSION = '6.55_02';
-
-require ExtUtils::MM_Any;
-our @ISA = qw(ExtUtils::MM_Any);
-
-my %Is;
-BEGIN {
- $Is{OS2} = $^O eq 'os2';
- $Is{Win32} = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare';
- $Is{Dos} = $^O eq 'dos';
- $Is{VMS} = $^O eq 'VMS';
- $Is{OSF} = $^O eq 'dec_osf';
- $Is{IRIX} = $^O eq 'irix';
- $Is{NetBSD} = $^O eq 'netbsd';
- $Is{Interix} = $^O eq 'interix';
- $Is{SunOS4} = $^O eq 'sunos';
- $Is{Solaris} = $^O eq 'solaris';
- $Is{SunOS} = $Is{SunOS4} || $Is{Solaris};
- $Is{BSD} = ($^O =~ /^(?:free|net|open)bsd$/ or
- grep( $^O eq $_, qw(bsdos interix dragonfly) )
- );
-}
-
-BEGIN {
- if( $Is{VMS} ) {
- # For things like vmsify()
- require VMS::Filespec;
- VMS::Filespec->import;
- }
-}
-
-
-=head1 NAME
-
-ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker
-
-=head1 SYNOPSIS
-
-C<require ExtUtils::MM_Unix;>
-
-=head1 DESCRIPTION
-
-The methods provided by this package are designed to be used in
-conjunction with ExtUtils::MakeMaker. When MakeMaker writes a
-Makefile, it creates one or more objects that inherit their methods
-from a package C<MM>. MM itself doesn't provide any methods, but it
-ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating
-specific packages take the responsibility for all the methods provided
-by MM_Unix. We are trying to reduce the number of the necessary
-overrides by defining rather primitive operations within
-ExtUtils::MM_Unix.
-
-If you are going to write a platform specific MM package, please try
-to limit the necessary overrides to primitive methods, and if it is not
-possible to do so, let's work out how to achieve that gain.
-
-If you are overriding any of these methods in your Makefile.PL (in the
-MY class), please report that to the makemaker mailing list. We are
-trying to minimize the necessary method overrides and switch to data
-driven Makefile.PLs wherever possible. In the long run less methods
-will be overridable via the MY class.
-
-=head1 METHODS
-
-The following description of methods is still under
-development. Please refer to the code for not suitably documented
-sections and complain loudly to the makemaker at perl.org mailing list.
-Better yet, provide a patch.
-
-Not all of the methods below are overridable in a
-Makefile.PL. Overridable methods are marked as (o). All methods are
-overridable by a platform specific MM_*.pm file.
-
-Cross-platform methods are being moved into MM_Any. If you can't find
-something that used to be in here, look in MM_Any.
-
-=cut
-
-# So we don't have to keep calling the methods over and over again,
-# we have these globals to cache the values. Faster and shrtr.
-my $Curdir = __PACKAGE__->curdir;
-my $Rootdir = __PACKAGE__->rootdir;
-my $Updir = __PACKAGE__->updir;
-
-
-=head2 Methods
-
-=over 4
-
-=item os_flavor
-
-Simply says that we're Unix.
-
-=cut
-
-sub os_flavor {
- return('Unix');
-}
-
-
-=item c_o (o)
-
-Defines the suffix rules to compile different flavors of C files to
-object files.
-
-=cut
-
-sub c_o {
-# --- Translation Sections ---
-
- my($self) = shift;
- return '' unless $self->needs_linking();
- my(@m);
-
- my $command = '$(CCCMD)';
- my $flags = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)';
-
- if (my $cpp = $Config{cpprun}) {
- my $cpp_cmd = $self->const_cccmd;
- $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/;
- push @m, qq{
-.c.i:
- $cpp_cmd $flags \$*.c > \$*.i
-};
- }
-
- push @m, qq{
-.c.s:
- $command -S $flags \$*.c
-
-.c\$(OBJ_EXT):
- $command $flags \$*.c
-
-.cpp\$(OBJ_EXT):
- $command $flags \$*.cpp
-
-.cxx\$(OBJ_EXT):
- $command $flags \$*.cxx
-
-.cc\$(OBJ_EXT):
- $command $flags \$*.cc
-};
-
- push @m, qq{
-.C\$(OBJ_EXT):
- $command $flags \$*.C
-} if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific
-
- return join "", @m;
-}
-
-=item cflags (o)
-
-Does very much the same as the cflags script in the perl
-distribution. It doesn't return the whole compiler command line, but
-initializes all of its parts. The const_cccmd method then actually
-returns the definition of the CCCMD macro which uses these parts.
-
-=cut
-
-#'
-
-sub cflags {
- my($self,$libperl)=@_;
- return $self->{CFLAGS} if $self->{CFLAGS};
- return '' unless $self->needs_linking();
-
- my($prog, $uc, $perltype, %cflags);
- $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ;
- $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/;
-
- @cflags{qw(cc ccflags optimize shellflags)}
- = @Config{qw(cc ccflags optimize shellflags)};
- my($optdebug) = "";
-
- $cflags{shellflags} ||= '';
-
- my(%map) = (
- D => '-DDEBUGGING',
- E => '-DEMBED',
- DE => '-DDEBUGGING -DEMBED',
- M => '-DEMBED -DMULTIPLICITY',
- DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY',
- );
-
- if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){
- $uc = uc($1);
- } else {
- $uc = ""; # avoid warning
- }
- $perltype = $map{$uc} ? $map{$uc} : "";
-
- if ($uc =~ /^D/) {
- $optdebug = "-g";
- }
-
-
- my($name);
- ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
- if ($prog = $Config{$name}) {
- # Expand hints for this extension via the shell
- print STDOUT "Processing $name hint:\n" if $Verbose;
- my(@o)=`cc=\"$cflags{cc}\"
- ccflags=\"$cflags{ccflags}\"
- optimize=\"$cflags{optimize}\"
- perltype=\"$cflags{perltype}\"
- optdebug=\"$cflags{optdebug}\"
- eval '$prog'
- echo cc=\$cc
- echo ccflags=\$ccflags
- echo optimize=\$optimize
- echo perltype=\$perltype
- echo optdebug=\$optdebug
- `;
- foreach my $line (@o){
- chomp $line;
- if ($line =~ /(.*?)=\s*(.*)\s*$/){
- $cflags{$1} = $2;
- print STDOUT " $1 = $2\n" if $Verbose;
- } else {
- print STDOUT "Unrecognised result from hint: '$line'\n";
- }
- }
- }
-
- if ($optdebug) {
- $cflags{optimize} = $optdebug;
- }
-
- for (qw(ccflags optimize perltype)) {
- $cflags{$_} ||= '';
- $cflags{$_} =~ s/^\s+//;
- $cflags{$_} =~ s/\s+/ /g;
- $cflags{$_} =~ s/\s+$//;
- $self->{uc $_} ||= $cflags{$_};
- }
-
- if ($self->{POLLUTE}) {
- $self->{CCFLAGS} .= ' -DPERL_POLLUTE ';
- }
-
- my $pollute = '';
- if ($Config{usemymalloc} and not $Config{bincompat5005}
- and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/
- and $self->{PERL_MALLOC_OK}) {
- $pollute = '$(PERL_MALLOC_DEF)';
- }
-
- $self->{CCFLAGS} = quote_paren($self->{CCFLAGS});
- $self->{OPTIMIZE} = quote_paren($self->{OPTIMIZE});
-
- return $self->{CFLAGS} = qq{
-CCFLAGS = $self->{CCFLAGS}
-OPTIMIZE = $self->{OPTIMIZE}
-PERLTYPE = $self->{PERLTYPE}
-MPOLLUTE = $pollute
-};
-
-}
-
-
-=item const_cccmd (o)
-
-Returns the full compiler call for C programs and stores the
-definition in CONST_CCCMD.
-
-=cut
-
-sub const_cccmd {
- my($self,$libperl)=@_;
- return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
- return '' unless $self->needs_linking();
- return $self->{CONST_CCCMD} =
- q{CCCMD = $(CC) -c $(PASTHRU_INC) $(INC) \\
- $(CCFLAGS) $(OPTIMIZE) \\
- $(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\
- $(XS_DEFINE_VERSION)};
-}
-
-=item const_config (o)
-
-Defines a couple of constants in the Makefile that are imported from
-%Config.
-
-=cut
-
-sub const_config {
-# --- Constants Sections ---
-
- my($self) = shift;
- my @m = <<"END";
-
-# These definitions are from config.sh (via $INC{'Config.pm'}).
-# They may have been overridden via Makefile.PL or on the command line.
-END
-
- my(%once_only);
- foreach my $key (@{$self->{CONFIG}}){
- # SITE*EXP macros are defined in &constants; avoid duplicates here
- next if $once_only{$key};
- $self->{uc $key} = quote_paren($self->{uc $key});
- push @m, uc($key) , ' = ' , $self->{uc $key}, "\n";
- $once_only{$key} = 1;
- }
- join('', @m);
-}
-
-=item const_loadlibs (o)
-
-Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See
-L<ExtUtils::Liblist> for details.
-
-=cut
-
-sub const_loadlibs {
- my($self) = shift;
- return "" unless $self->needs_linking;
- my @m;
- push @m, qq{
-# $self->{NAME} might depend on some other libraries:
-# See ExtUtils::Liblist for details
-#
-};
- for my $tmp (qw/
- EXTRALIBS LDLOADLIBS BSLOADLIBS
- /) {
- next unless defined $self->{$tmp};
- push @m, "$tmp = $self->{$tmp}\n";
- }
- # don't set LD_RUN_PATH if empty
- for my $tmp (qw/
- LD_RUN_PATH
- /) {
- next unless $self->{$tmp};
- push @m, "$tmp = $self->{$tmp}\n";
- }
- return join "", @m;
-}
-
-=item constants (o)
-
- my $make_frag = $mm->constants;
-
-Prints out macros for lots of constants.
-
-=cut
-
-sub constants {
- my($self) = @_;
- my @m = ();
-
- $self->{DFSEP} = '$(DIRFILESEP)'; # alias for internal use
-
- for my $macro (qw(
-
- AR_STATIC_ARGS DIRFILESEP DFSEP
- NAME NAME_SYM
- VERSION VERSION_MACRO VERSION_SYM DEFINE_VERSION
- XS_VERSION XS_VERSION_MACRO XS_DEFINE_VERSION
- INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB
- INST_MAN1DIR INST_MAN3DIR
- MAN1EXT MAN3EXT
- INSTALLDIRS INSTALL_BASE DESTDIR PREFIX
- PERLPREFIX SITEPREFIX VENDORPREFIX
- ),
- (map { ("INSTALL".$_,
- "DESTINSTALL".$_)
- } $self->installvars),
- qw(
- PERL_LIB
- PERL_ARCHLIB
- LIBPERL_A MYEXTLIB
- FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE
- PERLMAINCC PERL_SRC PERL_INC
- PERL FULLPERL ABSPERL
- PERLRUN FULLPERLRUN ABSPERLRUN
- PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST
- PERL_CORE
- PERM_DIR PERM_RW PERM_RWX
-
- ) )
- {
- next unless defined $self->{$macro};
-
- # pathnames can have sharp signs in them; escape them so
- # make doesn't think it is a comment-start character.
- $self->{$macro} =~ s/#/\\#/g;
- push @m, "$macro = $self->{$macro}\n";
- }
-
- push @m, qq{
-MAKEMAKER = $self->{MAKEMAKER}
-MM_VERSION = $self->{MM_VERSION}
-MM_REVISION = $self->{MM_REVISION}
-};
-
- push @m, q{
-# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle).
-# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle)
-# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar)
-# DLBASE = Basename part of dynamic library. May be just equal BASEEXT.
-};
-
- for my $macro (qw/
- MAKE
- FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
- LDFROM LINKTYPE BOOTDEP
- / )
- {
- next unless defined $self->{$macro};
- push @m, "$macro = $self->{$macro}\n";
- }
-
- push @m, "
-# Handy lists of source code files:
-XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})."
-C_FILES = ".$self->wraplist(@{$self->{C}})."
-O_FILES = ".$self->wraplist(@{$self->{O_FILES}})."
-H_FILES = ".$self->wraplist(@{$self->{H}})."
-MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})."
-MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})."
-";
-
-
- push @m, q{
-# Where is the Config information that we are using/depend on
-CONFIGDEP = $(PERL_ARCHLIB)$(DFSEP)Config.pm $(PERL_INC)$(DFSEP)config.h
-};
-
-
- push @m, qq{
-# Where to build things
-INST_LIBDIR = $self->{INST_LIBDIR}
-INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR}
-
-INST_AUTODIR = $self->{INST_AUTODIR}
-INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
-
-INST_STATIC = $self->{INST_STATIC}
-INST_DYNAMIC = $self->{INST_DYNAMIC}
-INST_BOOT = $self->{INST_BOOT}
-};
-
-
- push @m, qq{
-# Extra linker info
-EXPORT_LIST = $self->{EXPORT_LIST}
-PERL_ARCHIVE = $self->{PERL_ARCHIVE}
-PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER}
-};
-
- push @m, "
-
-TO_INST_PM = ".$self->wraplist(sort keys %{$self->{PM}})."
-
-PM_TO_BLIB = ".$self->wraplist(%{$self->{PM}})."
-";
-
- join('', at m);
-}
-
-
-=item depend (o)
-
-Same as macro for the depend attribute.
-
-=cut
-
-sub depend {
- my($self,%attribs) = @_;
- my(@m,$key,$val);
- while (($key,$val) = each %attribs){
- last unless defined $key;
- push @m, "$key : $val\n";
- }
- join "", @m;
-}
-
-
-=item init_DEST
-
- $mm->init_DEST
-
-Defines the DESTDIR and DEST* variables paralleling the INSTALL*.
-
-=cut
-
-sub init_DEST {
- my $self = shift;
-
- # Initialize DESTDIR
- $self->{DESTDIR} ||= '';
-
- # Make DEST variables.
- foreach my $var ($self->installvars) {
- my $destvar = 'DESTINSTALL'.$var;
- $self->{$destvar} ||= '$(DESTDIR)$(INSTALL'.$var.')';
- }
-}
-
-
-=item init_dist
-
- $mm->init_dist;
-
-Defines a lot of macros for distribution support.
-
- macro description default
-
- TAR tar command to use tar
- TARFLAGS flags to pass to TAR cvf
-
- ZIP zip command to use zip
- ZIPFLAGS flags to pass to ZIP -r
-
- COMPRESS compression command to gzip --best
- use for tarfiles
- SUFFIX suffix to put on .gz
- compressed files
-
- SHAR shar command to use shar
-
- PREOP extra commands to run before
- making the archive
- POSTOP extra commands to run after
- making the archive
-
- TO_UNIX a command to convert linefeeds
- to Unix style in your archive
-
- CI command to checkin your ci -u
- sources to version control
- RCS_LABEL command to label your sources rcs -Nv$(VERSION_SYM): -q
- just after CI is run
-
- DIST_CP $how argument to manicopy() best
- when the distdir is created
-
- DIST_DEFAULT default target to use to tardist
- create a distribution
-
- DISTVNAME name of the resulting archive $(DISTNAME)-$(VERSION)
- (minus suffixes)
-
-=cut
-
-sub init_dist {
- my $self = shift;
-
- $self->{TAR} ||= 'tar';
- $self->{TARFLAGS} ||= 'cvf';
- $self->{ZIP} ||= 'zip';
- $self->{ZIPFLAGS} ||= '-r';
- $self->{COMPRESS} ||= 'gzip --best';
- $self->{SUFFIX} ||= '.gz';
- $self->{SHAR} ||= 'shar';
- $self->{PREOP} ||= '$(NOECHO) $(NOOP)'; # eg update MANIFEST
- $self->{POSTOP} ||= '$(NOECHO) $(NOOP)'; # eg remove the distdir
- $self->{TO_UNIX} ||= '$(NOECHO) $(NOOP)';
-
- $self->{CI} ||= 'ci -u';
- $self->{RCS_LABEL}||= 'rcs -Nv$(VERSION_SYM): -q';
- $self->{DIST_CP} ||= 'best';
- $self->{DIST_DEFAULT} ||= 'tardist';
-
- ($self->{DISTNAME} = $self->{NAME}) =~ s{::}{-}g unless $self->{DISTNAME};
- $self->{DISTVNAME} ||= $self->{DISTNAME}.'-'.$self->{VERSION};
-
-}
-
-=item dist (o)
-
- my $dist_macros = $mm->dist(%overrides);
-
-Generates a make fragment defining all the macros initialized in
-init_dist.
-
-%overrides can be used to override any of the above.
-
-=cut
-
-sub dist {
- my($self, %attribs) = @_;
-
- my $make = '';
- foreach my $key (qw(
- TAR TARFLAGS ZIP ZIPFLAGS COMPRESS SUFFIX SHAR
- PREOP POSTOP TO_UNIX
- CI RCS_LABEL DIST_CP DIST_DEFAULT
- DISTNAME DISTVNAME
- ))
- {
- my $value = $attribs{$key} || $self->{$key};
- $make .= "$key = $value\n";
- }
-
- return $make;
-}
-
-=item dist_basics (o)
-
-Defines the targets distclean, distcheck, skipcheck, manifest, veryclean.
-
-=cut
-
-sub dist_basics {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-distclean :: realclean distcheck
- $(NOECHO) $(NOOP)
-
-distcheck :
- $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck
-
-skipcheck :
- $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck
-
-manifest :
- $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest
-
-veryclean : realclean
- $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old
-
-MAKE_FRAG
-
-}
-
-=item dist_ci (o)
-
-Defines a check in target for RCS.
-
-=cut
-
-sub dist_ci {
- my($self) = shift;
- return q{
-ci :
- $(PERLRUN) "-MExtUtils::Manifest=maniread" \\
- -e "@all = keys %{ maniread() };" \\
- -e "print(qq{Executing $(CI) @all\n}); system(qq{$(CI) @all});" \\
- -e "print(qq{Executing $(RCS_LABEL) ...\n}); system(qq{$(RCS_LABEL) @all});"
-};
-}
-
-=item dist_core (o)
-
- my $dist_make_fragment = $MM->dist_core;
-
-Puts the targets necessary for 'make dist' together into one make
-fragment.
-
-=cut
-
-sub dist_core {
- my($self) = shift;
-
- my $make_frag = '';
- foreach my $target (qw(dist tardist uutardist tarfile zipdist zipfile
- shdist))
- {
- my $method = $target.'_target';
- $make_frag .= "\n";
- $make_frag .= $self->$method();
- }
-
- return $make_frag;
-}
-
-
-=item B<dist_target>
-
- my $make_frag = $MM->dist_target;
-
-Returns the 'dist' target to make an archive for distribution. This
-target simply checks to make sure the Makefile is up-to-date and
-depends on $(DIST_DEFAULT).
-
-=cut
-
-sub dist_target {
- my($self) = shift;
-
- my $date_check = $self->oneliner(<<'CODE', ['-l']);
-print 'Warning: Makefile possibly out of date with $(VERSION_FROM)'
- if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)';
-CODE
-
- return sprintf <<'MAKE_FRAG', $date_check;
-dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE)
- $(NOECHO) %s
-MAKE_FRAG
-}
-
-=item B<tardist_target>
-
- my $make_frag = $MM->tardist_target;
-
-Returns the 'tardist' target which is simply so 'make tardist' works.
-The real work is done by the dynamically named tardistfile_target()
-method, tardist should have that as a dependency.
-
-=cut
-
-sub tardist_target {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-tardist : $(DISTVNAME).tar$(SUFFIX)
- $(NOECHO) $(NOOP)
-MAKE_FRAG
-}
-
-=item B<zipdist_target>
-
- my $make_frag = $MM->zipdist_target;
-
-Returns the 'zipdist' target which is simply so 'make zipdist' works.
-The real work is done by the dynamically named zipdistfile_target()
-method, zipdist should have that as a dependency.
-
-=cut
-
-sub zipdist_target {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-zipdist : $(DISTVNAME).zip
- $(NOECHO) $(NOOP)
-MAKE_FRAG
-}
-
-=item B<tarfile_target>
-
- my $make_frag = $MM->tarfile_target;
-
-The name of this target is the name of the tarball generated by
-tardist. This target does the actual work of turning the distdir into
-a tarball.
-
-=cut
-
-sub tarfile_target {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-$(DISTVNAME).tar$(SUFFIX) : distdir
- $(PREOP)
- $(TO_UNIX)
- $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME)
- $(RM_RF) $(DISTVNAME)
- $(COMPRESS) $(DISTVNAME).tar
- $(POSTOP)
-MAKE_FRAG
-}
-
-=item zipfile_target
-
- my $make_frag = $MM->zipfile_target;
-
-The name of this target is the name of the zip file generated by
-zipdist. This target does the actual work of turning the distdir into
-a zip file.
-
-=cut
-
-sub zipfile_target {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-$(DISTVNAME).zip : distdir
- $(PREOP)
- $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME)
- $(RM_RF) $(DISTVNAME)
- $(POSTOP)
-MAKE_FRAG
-}
-
-=item uutardist_target
-
- my $make_frag = $MM->uutardist_target;
-
-Converts the tarfile into a uuencoded file
-
-=cut
-
-sub uutardist_target {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-uutardist : $(DISTVNAME).tar$(SUFFIX)
- uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu
-MAKE_FRAG
-}
-
-
-=item shdist_target
-
- my $make_frag = $MM->shdist_target;
-
-Converts the distdir into a shell archive.
-
-=cut
-
-sub shdist_target {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-shdist : distdir
- $(PREOP)
- $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar
- $(RM_RF) $(DISTVNAME)
- $(POSTOP)
-MAKE_FRAG
-}
-
-
-=item dlsyms (o)
-
-Used by some OS' to define DL_FUNCS and DL_VARS and write the *.exp files.
-
-Normally just returns an empty string.
-
-=cut
-
-sub dlsyms {
- return '';
-}
-
-
-=item dynamic_bs (o)
-
-Defines targets for bootstrap files.
-
-=cut
-
-sub dynamic_bs {
- my($self, %attribs) = @_;
- return '
-BOOTSTRAP =
-' unless $self->has_link_code();
-
- my $target = $Is{VMS} ? '$(MMS$TARGET)' : '$@';
-
- return sprintf <<'MAKE_FRAG', ($target) x 5;
-BOOTSTRAP = $(BASEEXT).bs
-
-# As Mkbootstrap might not write a file (if none is required)
-# we use touch to prevent make continually trying to remake it.
-# The DynaLoader only reads a non-empty file.
-$(BOOTSTRAP) : $(FIRST_MAKEFILE) $(BOOTDEP) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(NOECHO) $(ECHO) "Running Mkbootstrap for $(NAME) ($(BSLOADLIBS))"
- $(NOECHO) $(PERLRUN) \
- "-MExtUtils::Mkbootstrap" \
- -e "Mkbootstrap('$(BASEEXT)','$(BSLOADLIBS)');"
- $(NOECHO) $(TOUCH) %s
- $(CHMOD) $(PERM_RW) %s
-
-$(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(NOECHO) $(RM_RF) %s
- - $(CP) $(BOOTSTRAP) %s
- $(CHMOD) $(PERM_RW) %s
-MAKE_FRAG
-}
-
-=item dynamic_lib (o)
-
-Defines how to produce the *.so (or equivalent) files.
-
-=cut
-
-sub dynamic_lib {
- my($self, %attribs) = @_;
- return '' unless $self->needs_linking(); #might be because of a subdir
-
- return '' unless $self->has_link_code;
-
- my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
- my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
- my($armaybe) = $attribs{ARMAYBE} || $self->{ARMAYBE} || ":";
- my($ldfrom) = '$(LDFROM)';
- $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':');
- my(@m);
- my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too?
- my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : '';
- push(@m,'
-# This section creates the dynamically loadable $(INST_DYNAMIC)
-# from $(OBJECT) and possibly $(MYEXTLIB).
-ARMAYBE = '.$armaybe.'
-OTHERLDFLAGS = '.$ld_opt.$otherldflags.'
-INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
-INST_DYNAMIC_FIX = '.$ld_fix.'
-
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)
-');
- if ($armaybe ne ':'){
- $ldfrom = 'tmp$(LIB_EXT)';
- push(@m,' $(ARMAYBE) cr '.$ldfrom.' $(OBJECT)'."\n");
- push(@m,' $(RANLIB) '."$ldfrom\n");
- }
- $ldfrom = "-all $ldfrom -none" if $Is{OSF};
-
- # The IRIX linker doesn't use LD_RUN_PATH
- my $ldrun = $Is{IRIX} && $self->{LD_RUN_PATH} ?
- qq{-rpath "$self->{LD_RUN_PATH}"} : '';
-
- # For example in AIX the shared objects/libraries from previous builds
- # linger quite a while in the shared dynalinker cache even when nobody
- # is using them. This is painful if one for instance tries to restart
- # a failed build because the link command will fail unnecessarily 'cos
- # the shared object/library is 'busy'.
- push(@m,' $(RM_F) $@
-');
-
- my $libs = '$(LDLOADLIBS)';
-
- if (($Is{NetBSD} || $Is{Interix}) && $Config{'useshrplib'} eq 'true') {
- # Use nothing on static perl platforms, and to the flags needed
- # to link against the shared libperl library on shared perl
- # platforms. We peek at lddlflags to see if we need -Wl,-R
- # or -R to add paths to the run-time library search path.
- if ($Config{'lddlflags'} =~ /-Wl,-R/) {
- $libs .= ' -L$(PERL_INC) -Wl,-R$(INSTALLARCHLIB)/CORE -Wl,-R$(PERL_ARCHLIB)/CORE -lperl';
- } elsif ($Config{'lddlflags'} =~ /-R/) {
- $libs .= ' -L$(PERL_INC) -R$(INSTALLARCHLIB)/CORE -R$(PERL_ARCHLIB)/CORE -lperl';
- }
- }
-
- my $ld_run_path_shell = "";
- if ($self->{LD_RUN_PATH} ne "") {
- $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" ';
- }
-
- push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $ldfrom, $libs;
- %s$(LD) %s $(LDDLFLAGS) %s $(OTHERLDFLAGS) -o $@ $(MYEXTLIB) \
- $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) $(EXPORT_LIST) \
- $(INST_DYNAMIC_FIX)
-MAKE
-
- push @m, <<'MAKE';
- $(CHMOD) $(PERM_RWX) $@
-MAKE
-
- return join('', at m);
-}
-
-=item exescan
-
-Deprecated method. Use libscan instead.
-
-=cut
-
-sub exescan {
- my($self,$path) = @_;
- $path;
-}
-
-=item extliblist
-
-Called by init_others, and calls ext ExtUtils::Liblist. See
-L<ExtUtils::Liblist> for details.
-
-=cut
-
-sub extliblist {
- my($self,$libs) = @_;
- require ExtUtils::Liblist;
- $self->ext($libs, $Verbose);
-}
-
-=item find_perl
-
-Finds the executables PERL and FULLPERL
-
-=cut
-
-sub find_perl {
- my($self, $ver, $names, $dirs, $trace) = @_;
-
- if ($trace >= 2){
- print "Looking for perl $ver by these names:
-@$names
-in these dirs:
-@$dirs
-";
- }
-
- my $stderr_duped = 0;
- local *STDERR_COPY;
-
- unless ($Is{BSD}) {
- # >& and lexical filehandles together give 5.6.2 indigestion
- if( open(STDERR_COPY, '>&STDERR') ) { ## no critic
- $stderr_duped = 1;
- }
- else {
- warn <<WARNING;
-find_perl() can't dup STDERR: $!
-You might see some garbage while we search for Perl
-WARNING
- }
- }
-
- foreach my $name (@$names){
- foreach my $dir (@$dirs){
- next unless defined $dir; # $self->{PERL_SRC} may be undefined
- my ($abs, $val);
- if ($self->file_name_is_absolute($name)) { # /foo/bar
- $abs = $name;
- } elsif ($self->canonpath($name) eq
- $self->canonpath(basename($name))) { # foo
- $abs = $self->catfile($dir, $name);
- } else { # foo/bar
- $abs = $self->catfile($Curdir, $name);
- }
- print "Checking $abs\n" if ($trace >= 2);
- next unless $self->maybe_command($abs);
- print "Executing $abs\n" if ($trace >= 2);
-
- my $version_check = qq{$abs -le "require $ver; print qq{VER_OK}"};
- $version_check = "$Config{run} $version_check"
- if defined $Config{run} and length $Config{run};
-
- # To avoid using the unportable 2>&1 to suppress STDERR,
- # we close it before running the command.
- # However, thanks to a thread library bug in many BSDs
- # ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 )
- # we cannot use the fancier more portable way in here
- # but instead need to use the traditional 2>&1 construct.
- if ($Is{BSD}) {
- $val = `$version_check 2>&1`;
- } else {
- close STDERR if $stderr_duped;
- $val = `$version_check`;
-
- # 5.6.2's 3-arg open doesn't work with >&
- open STDERR, ">&STDERR_COPY" ## no critic
- if $stderr_duped;
- }
-
- if ($val =~ /^VER_OK/m) {
- print "Using PERL=$abs\n" if $trace;
- return $abs;
- } elsif ($trace >= 2) {
- print "Result: '$val' ".($? >> 8)."\n";
- }
- }
- }
- print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
- 0; # false and not empty
-}
-
-
-=item fixin
-
- $mm->fixin(@files);
-
-Inserts the sharpbang or equivalent magic number to a set of @files.
-
-=cut
-
-sub fixin { # stolen from the pink Camel book, more or less
- my ( $self, @files ) = @_;
-
- my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/;
- for my $file (@files) {
- my $file_new = "$file.new";
- my $file_bak = "$file.bak";
-
- open( my $fixin, '<', $file ) or croak "Can't process '$file': $!";
- local $/ = "\n";
- chomp( my $line = <$fixin> );
- next unless $line =~ s/^\s*\#!\s*//; # Not a shbang file.
- # Now figure out the interpreter name.
- my ( $cmd, $arg ) = split ' ', $line, 2;
- $cmd =~ s!^.*/!!;
-
- # Now look (in reverse) for interpreter in absolute PATH (unless perl).
- my $interpreter;
- if ( $cmd =~ m{^perl(?:\z|[^a-z])} ) {
- if ( $Config{startperl} =~ m,^\#!.*/perl, ) {
- $interpreter = $Config{startperl};
- $interpreter =~ s,^\#!,,;
- }
- else {
- $interpreter = $Config{perlpath};
- }
- }
- else {
- my (@absdirs)
- = reverse grep { $self->file_name_is_absolute($_) } $self->path;
- $interpreter = '';
-
- foreach my $dir (@absdirs) {
- if ( $self->maybe_command($cmd) ) {
- warn "Ignoring $interpreter in $file\n"
- if $Verbose && $interpreter;
- $interpreter = $self->catfile( $dir, $cmd );
- }
- }
- }
-
- # Figure out how to invoke interpreter on this machine.
-
- my ($shb) = "";
- if ($interpreter) {
- print STDOUT "Changing sharpbang in $file to $interpreter"
- if $Verbose;
-
- # this is probably value-free on DOSISH platforms
- if ($does_shbang) {
- $shb .= "$Config{'sharpbang'}$interpreter";
- $shb .= ' ' . $arg if defined $arg;
- $shb .= "\n";
- }
- $shb .= qq{
-eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}'
- if 0; # not running under some shell
-} unless $Is{Win32}; # this won't work on win32, so don't
- }
- else {
- warn "Can't find $cmd in PATH, $file unchanged"
- if $Verbose;
- next;
- }
-
- open( my $fixout, ">", "$file_new" ) or do {
- warn "Can't create new $file: $!\n";
- next;
- };
-
- # Print out the new #! line (or equivalent).
- local $\;
- local $/;
- print $fixout $shb, <$fixin>;
- close $fixin;
- close $fixout;
-
- chmod 0666, $file_bak;
- unlink $file_bak;
- unless ( _rename( $file, $file_bak ) ) {
- warn "Can't rename $file to $file_bak: $!";
- next;
- }
- unless ( _rename( $file_new, $file ) ) {
- warn "Can't rename $file_new to $file: $!";
- unless ( _rename( $file_bak, $file ) ) {
- warn "Can't rename $file_bak back to $file either: $!";
- warn "Leaving $file renamed as $file_bak\n";
- }
- next;
- }
- unlink $file_bak;
- }
- continue {
- system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
- }
-}
-
-
-sub _rename {
- my($old, $new) = @_;
-
- foreach my $file ($old, $new) {
- if( $Is{VMS} and basename($file) !~ /\./ ) {
- # rename() in 5.8.0 on VMS will not rename a file if it
- # does not contain a dot yet it returns success.
- $file = "$file.";
- }
- }
-
- return rename($old, $new);
-}
-
-
-=item force (o)
-
-Writes an empty FORCE: target.
-
-=cut
-
-sub force {
- my($self) = shift;
- '# Phony target to force checking subdirectories.
-FORCE :
- $(NOECHO) $(NOOP)
-';
-}
-
-=item guess_name
-
-Guess the name of this package by examining the working directory's
-name. MakeMaker calls this only if the developer has not supplied a
-NAME attribute.
-
-=cut
-
-# ';
-
-sub guess_name {
- my($self) = @_;
- use Cwd 'cwd';
- my $name = basename(cwd());
- $name =~ s|[\-_][\d\.\-]+\z||; # this is new with MM 5.00, we
- # strip minus or underline
- # followed by a float or some such
- print "Warning: Guessing NAME [$name] from current directory name.\n";
- $name;
-}
-
-=item has_link_code
-
-Returns true if C, XS, MYEXTLIB or similar objects exist within this
-object that need a compiler. Does not descend into subdirectories as
-needs_linking() does.
-
-=cut
-
-sub has_link_code {
- my($self) = shift;
- return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE};
- if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){
- $self->{HAS_LINK_CODE} = 1;
- return 1;
- }
- return $self->{HAS_LINK_CODE} = 0;
-}
-
-
-=item init_dirscan
-
-Scans the directory structure and initializes DIR, XS, XS_FILES,
-C, C_FILES, O_FILES, H, H_FILES, PL_FILES, EXE_FILES.
-
-Called by init_main.
-
-=cut
-
-sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
- my($self) = @_;
- my(%dir, %xs, %c, %h, %pl_files, %pm);
-
- my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t);
-
- # ignore the distdir
- $Is{VMS} ? $ignore{"$self->{DISTVNAME}.dir"} = 1
- : $ignore{$self->{DISTVNAME}} = 1;
-
- @ignore{map lc, keys %ignore} = values %ignore if $Is{VMS};
-
- foreach my $name ($self->lsdir($Curdir)){
- next if $name =~ /\#/;
- next if $name eq $Curdir or $name eq $Updir or $ignore{$name};
- next unless $self->libscan($name);
- if (-d $name){
- next if -l $name; # We do not support symlinks at all
- next if $self->{NORECURS};
- $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
- } elsif ($name =~ /\.xs\z/){
- my($c); ($c = $name) =~ s/\.xs\z/.c/;
- $xs{$name} = $c;
- $c{$c} = 1;
- } elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc
- $c{$name} = 1
- unless $name =~ m/perlmain\.c/; # See MAP_TARGET
- } elsif ($name =~ /\.h\z/i){
- $h{$name} = 1;
- } elsif ($name =~ /\.PL\z/) {
- ($pl_files{$name} = $name) =~ s/\.PL\z// ;
- } elsif (($Is{VMS} || $Is{Dos}) && $name =~ /[._]pl$/i) {
- # case-insensitive filesystem, one dot per name, so foo.h.PL
- # under Unix appears as foo.h_pl under VMS or fooh.pl on Dos
- local($/); open(my $pl, '<', $name); my $txt = <$pl>; close $pl;
- if ($txt =~ /Extracting \S+ \(with variable substitutions/) {
- ($pl_files{$name} = $name) =~ s/[._]pl\z//i ;
- }
- else {
- $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
- }
- } elsif ($name =~ /\.(p[ml]|pod)\z/){
- $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name);
- }
- }
-
- $self->{PL_FILES} ||= \%pl_files;
- $self->{DIR} ||= [sort keys %dir];
- $self->{XS} ||= \%xs;
- $self->{C} ||= [sort keys %c];
- $self->{H} ||= [sort keys %h];
- $self->{PM} ||= \%pm;
-
- my @o_files = @{$self->{C}};
- $self->{O_FILES} = [grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files];
-}
-
-
-=item init_MANPODS
-
-Determines if man pages should be generated and initializes MAN1PODS
-and MAN3PODS as appropriate.
-
-=cut
-
-sub init_MANPODS {
- my $self = shift;
-
- # Set up names of manual pages to generate from pods
- foreach my $man (qw(MAN1 MAN3)) {
- if ( $self->{"${man}PODS"}
- or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/
- ) {
- $self->{"${man}PODS"} ||= {};
- }
- else {
- my $init_method = "init_${man}PODS";
- $self->$init_method();
- }
- }
-}
-
-
-sub _has_pod {
- my($self, $file) = @_;
-
- my($ispod)=0;
- if (open( my $fh, '<', $file )) {
- while (<$fh>) {
- if (/^=(?:head\d+|item|pod)\b/) {
- $ispod=1;
- last;
- }
- }
- close $fh;
- } else {
- # If it doesn't exist yet, we assume, it has pods in it
- $ispod = 1;
- }
-
- return $ispod;
-}
-
-
-=item init_MAN1PODS
-
-Initializes MAN1PODS from the list of EXE_FILES.
-
-=cut
-
-sub init_MAN1PODS {
- my($self) = @_;
-
- if ( exists $self->{EXE_FILES} ) {
- foreach my $name (@{$self->{EXE_FILES}}) {
- next unless $self->_has_pod($name);
-
- $self->{MAN1PODS}->{$name} =
- $self->catfile("\$(INST_MAN1DIR)",
- basename($name).".\$(MAN1EXT)");
- }
- }
-}
-
-
-=item init_MAN3PODS
-
-Initializes MAN3PODS from the list of PM files.
-
-=cut
-
-sub init_MAN3PODS {
- my $self = shift;
-
- my %manifypods = (); # we collect the keys first, i.e. the files
- # we have to convert to pod
-
- foreach my $name (keys %{$self->{PM}}) {
- if ($name =~ /\.pod\z/ ) {
- $manifypods{$name} = $self->{PM}{$name};
- } elsif ($name =~ /\.p[ml]\z/ ) {
- if( $self->_has_pod($name) ) {
- $manifypods{$name} = $self->{PM}{$name};
- }
- }
- }
-
- my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};
-
- # Remove "Configure.pm" and similar, if it's not the only pod listed
- # To force inclusion, just name it "Configure.pod", or override
- # MAN3PODS
- foreach my $name (keys %manifypods) {
- if ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) {
- delete $manifypods{$name};
- next;
- }
- my($manpagename) = $name;
- $manpagename =~ s/\.p(od|m|l)\z//;
- # everything below lib is ok
- unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) {
- $manpagename = $self->catfile(
- split(/::/,$self->{PARENT_NAME}),$manpagename
- );
- }
- $manpagename = $self->replace_manpage_separator($manpagename);
- $self->{MAN3PODS}->{$name} =
- $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)");
- }
-}
-
-
-=item init_PM
-
-Initializes PMLIBDIRS and PM from PMLIBDIRS.
-
-=cut
-
-sub init_PM {
- my $self = shift;
-
- # Some larger extensions often wish to install a number of *.pm/pl
- # files into the library in various locations.
-
- # The attribute PMLIBDIRS holds an array reference which lists
- # subdirectories which we should search for library files to
- # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We
- # recursively search through the named directories (skipping any
- # which don't exist or contain Makefile.PL files).
-
- # For each *.pm or *.pl file found $self->libscan() is called with
- # the default installation path in $_[1]. The return value of
- # libscan defines the actual installation location. The default
- # libscan function simply returns the path. The file is skipped
- # if libscan returns false.
-
- # The default installation location passed to libscan in $_[1] is:
- #
- # ./*.pm => $(INST_LIBDIR)/*.pm
- # ./xyz/... => $(INST_LIBDIR)/xyz/...
- # ./lib/... => $(INST_LIB)/...
- #
- # In this way the 'lib' directory is seen as the root of the actual
- # perl library whereas the others are relative to INST_LIBDIR
- # (which includes PARENT_NAME). This is a subtle distinction but one
- # that's important for nested modules.
-
- unless( $self->{PMLIBDIRS} ) {
- if( $Is{VMS} ) {
- # Avoid logical name vs directory collisions
- $self->{PMLIBDIRS} = ['./lib', "./$self->{BASEEXT}"];
- }
- else {
- $self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}];
- }
- }
-
- #only existing directories that aren't in $dir are allowed
-
- # Avoid $_ wherever possible:
- # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}};
- my (@pmlibdirs) = @{$self->{PMLIBDIRS}};
- @{$self->{PMLIBDIRS}} = ();
- my %dir = map { ($_ => $_) } @{$self->{DIR}};
- foreach my $pmlibdir (@pmlibdirs) {
- -d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir;
- }
-
- unless( $self->{PMLIBPARENTDIRS} ) {
- @{$self->{PMLIBPARENTDIRS}} = ('lib');
- }
-
- return if $self->{PM} and $self->{ARGS}{PM};
-
- if (@{$self->{PMLIBDIRS}}){
- print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n"
- if ($Verbose >= 2);
- require File::Find;
- File::Find::find(sub {
- if (-d $_){
- unless ($self->libscan($_)){
- $File::Find::prune = 1;
- }
- return;
- }
- return if /\#/;
- return if /~$/; # emacs temp files
- return if /,v$/; # RCS files
- return if m{\.swp$}; # vim swap files
-
- my $path = $File::Find::name;
- my $prefix = $self->{INST_LIBDIR};
- my $striplibpath;
-
- my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}};
- $prefix = $self->{INST_LIB}
- if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W}
- {$1}i;
-
- my($inst) = $self->catfile($prefix,$striplibpath);
- local($_) = $inst; # for backwards compatibility
- $inst = $self->libscan($inst);
- print "libscan($path) => '$inst'\n" if ($Verbose >= 2);
- return unless $inst;
- $self->{PM}{$path} = $inst;
- }, @{$self->{PMLIBDIRS}});
- }
-}
-
-
-=item init_DIRFILESEP
-
-Using / for Unix. Called by init_main.
-
-=cut
-
-sub init_DIRFILESEP {
- my($self) = shift;
-
- $self->{DIRFILESEP} = '/';
-}
-
-
-=item init_main
-
-Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE,
-EXE_EXT, FULLEXT, FULLPERL, FULLPERLRUN, FULLPERLRUNINST, INST_*,
-INSTALL*, INSTALLDIRS, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME,
-OBJ_EXT, PARENT_NAME, PERL, PERL_ARCHLIB, PERL_INC, PERL_LIB,
-PERL_SRC, PERLRUN, PERLRUNINST, PREFIX, VERSION,
-VERSION_SYM, XS_VERSION.
-
-=cut
-
-sub init_main {
- my($self) = @_;
-
- # --- Initialize Module Name and Paths
-
- # NAME = Foo::Bar::Oracle
- # FULLEXT = Foo/Bar/Oracle
- # BASEEXT = Oracle
- # PARENT_NAME = Foo::Bar
-### Only UNIX:
-### ($self->{FULLEXT} =
-### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket
- $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME});
-
-
- # Copied from DynaLoader:
-
- my(@modparts) = split(/::/,$self->{NAME});
- my($modfname) = $modparts[-1];
-
- # Some systems have restrictions on files names for DLL's etc.
- # mod2fname returns appropriate file base name (typically truncated)
- # It may also edit @modparts if required.
- if (defined &DynaLoader::mod2fname) {
- $modfname = &DynaLoader::mod2fname(\@modparts);
- }
-
- ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ;
- $self->{PARENT_NAME} ||= '';
-
- if (defined &DynaLoader::mod2fname) {
- # As of 5.001m, dl_os2 appends '_'
- $self->{DLBASE} = $modfname;
- } else {
- $self->{DLBASE} = '$(BASEEXT)';
- }
-
-
- # --- Initialize PERL_LIB, PERL_SRC
-
- # *Real* information: where did we get these two from? ...
- my $inc_config_dir = dirname($INC{'Config.pm'});
- my $inc_carp_dir = dirname($INC{'Carp.pm'});
-
- unless ($self->{PERL_SRC}){
- foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting
- my $dir = $self->catdir(($Updir) x $dir_count);
-
- if (-f $self->catfile($dir,"config_h.SH") &&
- -f $self->catfile($dir,"perl.h") &&
- -f $self->catfile($dir,"lib","strict.pm")
- ) {
- $self->{PERL_SRC}=$dir ;
- last;
- }
- }
- }
-
- warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if
- $self->{PERL_CORE} and !$self->{PERL_SRC};
-
- if ($self->{PERL_SRC}){
- $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib");
-
- if (defined $Cross::platform) {
- $self->{PERL_ARCHLIB} =
- $self->catdir("$self->{PERL_SRC}","xlib",$Cross::platform);
- $self->{PERL_INC} =
- $self->catdir("$self->{PERL_SRC}","xlib",$Cross::platform,
- $Is{Win32}?("CORE"):());
- }
- else {
- $self->{PERL_ARCHLIB} = $self->{PERL_LIB};
- $self->{PERL_INC} = ($Is{Win32}) ?
- $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC};
- }
-
- # catch a situation that has occurred a few times in the past:
- unless (
- -s $self->catfile($self->{PERL_SRC},'cflags')
- or
- $Is{VMS}
- &&
- -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt')
- or
- $Is{Win32}
- ){
- warn qq{
-You cannot build extensions below the perl source tree after executing
-a 'make clean' in the perl source tree.
-
-To rebuild extensions distributed with the perl source you should
-simply Configure (to include those extensions) and then build perl as
-normal. After installing perl the source tree can be deleted. It is
-not needed for building extensions by running 'perl Makefile.PL'
-usually without extra arguments.
-
-It is recommended that you unpack and build additional extensions away
-from the perl source tree.
-};
- }
- } else {
- # we should also consider $ENV{PERL5LIB} here
- my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC};
- $self->{PERL_LIB} ||= $Config{privlibexp};
- $self->{PERL_ARCHLIB} ||= $Config{archlibexp};
- $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now
- my $perl_h;
-
- if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h"))
- and not $old){
- # Maybe somebody tries to build an extension with an
- # uninstalled Perl outside of Perl build tree
- my $lib;
- for my $dir (@INC) {
- $lib = $dir, last if -e $self->catfile($dir, "Config.pm");
- }
- if ($lib) {
- # Win32 puts its header files in /perl/src/lib/CORE.
- # Unix leaves them in /perl/src.
- my $inc = $Is{Win32} ? $self->catdir($lib, "CORE" )
- : dirname $lib;
- if (-e $self->catfile($inc, "perl.h")) {
- $self->{PERL_LIB} = $lib;
- $self->{PERL_ARCHLIB} = $lib;
- $self->{PERL_INC} = $inc;
- $self->{UNINSTALLED_PERL} = 1;
- print STDOUT <<EOP;
-... Detected uninstalled Perl. Trying to continue.
-EOP
- }
- }
- }
- }
-
- # We get SITELIBEXP and SITEARCHEXP directly via
- # Get_from_Config. When we are running standard modules, these
- # won't matter, we will set INSTALLDIRS to "perl". Otherwise we
- # set it to "site". I prefer that INSTALLDIRS be set from outside
- # MakeMaker.
- $self->{INSTALLDIRS} ||= "site";
-
- $self->{MAN1EXT} ||= $Config{man1ext};
- $self->{MAN3EXT} ||= $Config{man3ext};
-
- # Get some stuff out of %Config if we haven't yet done so
- print STDOUT "CONFIG must be an array ref\n"
- if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY');
- $self->{CONFIG} = [] unless (ref $self->{CONFIG});
- push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config);
- push(@{$self->{CONFIG}}, 'shellflags') if $Config{shellflags};
- my(%once_only);
- foreach my $m (@{$self->{CONFIG}}){
- next if $once_only{$m};
- print STDOUT "CONFIG key '$m' does not exist in Config.pm\n"
- unless exists $Config{$m};
- $self->{uc $m} ||= $Config{$m};
- $once_only{$m} = 1;
- }
-
-# This is too dangerous:
-# if ($^O eq "next") {
-# $self->{AR} = "libtool";
-# $self->{AR_STATIC_ARGS} = "-o";
-# }
-# But I leave it as a placeholder
-
- $self->{AR_STATIC_ARGS} ||= "cr";
-
- # These should never be needed
- $self->{OBJ_EXT} ||= '.o';
- $self->{LIB_EXT} ||= '.a';
-
- $self->{MAP_TARGET} ||= "perl";
-
- $self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}";
-
- # make a simple check if we find strict
- warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory
- (strict.pm not found)"
- unless -f $self->catfile("$self->{PERL_LIB}","strict.pm") ||
- $self->{NAME} eq "ExtUtils::MakeMaker";
-}
-
-=item init_others
-
-Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH, LD,
-OBJECT, BOOTDEP, PERLMAINCC, LDFROM, LINKTYPE, SHELL, NOOP,
-FIRST_MAKEFILE, MAKEFILE_OLD, NOECHO, RM_F, RM_RF, TEST_F,
-TOUCH, CP, MV, CHMOD, UMASK_NULL, ECHO, ECHO_N
-
-=cut
-
-sub init_others { # --- Initialize Other Attributes
- my($self) = shift;
-
- $self->{ECHO} ||= 'echo';
- $self->{ECHO_N} ||= 'echo -n';
- $self->{RM_F} ||= "rm -f";
- $self->{RM_RF} ||= "rm -rf";
- $self->{TOUCH} ||= "touch";
- $self->{TEST_F} ||= "test -f";
- $self->{CP} ||= "cp";
- $self->{MV} ||= "mv";
- $self->{CHMOD} ||= "chmod";
- $self->{FALSE} ||= 'false';
- $self->{TRUE} ||= 'true';
-
- $self->{LD} ||= 'ld';
-
- $self->SUPER::init_others(@_);
-
- # After SUPER::init_others so $Config{shell} has a
- # chance to get set.
- $self->{SHELL} ||= '/bin/sh';
-
- return 1;
-}
-
-
-=item init_linker
-
-Unix has no need of special linker flags.
-
-=cut
-
-sub init_linker {
- my($self) = shift;
- $self->{PERL_ARCHIVE} ||= '';
- $self->{PERL_ARCHIVE_AFTER} ||= '';
- $self->{EXPORT_LIST} ||= '';
-}
-
-
-=begin _protected
-
-=item init_lib2arch
-
- $mm->init_lib2arch
-
-=end _protected
-
-=cut
-
-sub init_lib2arch {
- my($self) = shift;
-
- # The user who requests an installation directory explicitly
- # should not have to tell us an architecture installation directory
- # as well. We look if a directory exists that is named after the
- # architecture. If not we take it as a sign that it should be the
- # same as the requested installation directory. Otherwise we take
- # the found one.
- for my $libpair ({l=>"privlib", a=>"archlib"},
- {l=>"sitelib", a=>"sitearch"},
- {l=>"vendorlib", a=>"vendorarch"},
- )
- {
- my $lib = "install$libpair->{l}";
- my $Lib = uc $lib;
- my $Arch = uc "install$libpair->{a}";
- if( $self->{$Lib} && ! $self->{$Arch} ){
- my($ilib) = $Config{$lib};
-
- $self->prefixify($Arch,$ilib,$self->{$Lib});
-
- unless (-d $self->{$Arch}) {
- print STDOUT "Directory $self->{$Arch} not found\n"
- if $Verbose;
- $self->{$Arch} = $self->{$Lib};
- }
- print STDOUT "Defaulting $Arch to $self->{$Arch}\n" if $Verbose;
- }
- }
-}
-
-
-=item init_PERL
-
- $mm->init_PERL;
-
-Called by init_main. Sets up ABSPERL, PERL, FULLPERL and all the
-*PERLRUN* permutations.
-
- PERL is allowed to be miniperl
- FULLPERL must be a complete perl
-
- ABSPERL is PERL converted to an absolute path
-
- *PERLRUN contains everything necessary to run perl, find it's
- libraries, etc...
-
- *PERLRUNINST is *PERLRUN + everything necessary to find the
- modules being built.
-
-=cut
-
-sub init_PERL {
- my($self) = shift;
-
- my @defpath = ();
- foreach my $component ($self->{PERL_SRC}, $self->path(),
- $Config{binexp})
- {
- push @defpath, $component if defined $component;
- }
-
- # Build up a set of file names (not command names).
- my $thisperl = $self->canonpath($^X);
- $thisperl .= $Config{exe_ext} unless
- # VMS might have a file version # at the end
- $Is{VMS} ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i
- : $thisperl =~ m/$Config{exe_ext}$/i;
-
- # We need a relative path to perl when in the core.
- $thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE};
-
- my @perls = ($thisperl);
- push @perls, map { "$_$Config{exe_ext}" }
- ('perl', 'perl5', "perl$Config{version}");
-
- # miniperl has priority over all but the cannonical perl when in the
- # core. Otherwise its a last resort.
- my $miniperl = "miniperl$Config{exe_ext}";
- if( $self->{PERL_CORE} ) {
- splice @perls, 1, 0, $miniperl;
- }
- else {
- push @perls, $miniperl;
- }
-
- $self->{PERL} ||=
- $self->find_perl(5.0, \@perls, \@defpath, $Verbose );
- # don't check if perl is executable, maybe they have decided to
- # supply switches with perl
-
- # When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe.
- my $perl_name = 'perl';
- $perl_name = 'ndbgperl' if $Is{VMS} &&
- defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define';
-
- # XXX This logic is flawed. If "miniperl" is anywhere in the path
- # it will get confused. It should be fixed to work only on the filename.
- # Define 'FULLPERL' to be a non-miniperl (used in test: target)
- ($self->{FULLPERL} = $self->{PERL}) =~ s/miniperl/$perl_name/i
- unless $self->{FULLPERL};
-
- # Little hack to get around VMS's find_perl putting "MCR" in front
- # sometimes.
- $self->{ABSPERL} = $self->{PERL};
- my $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//;
- if( $self->file_name_is_absolute($self->{ABSPERL}) ) {
- $self->{ABSPERL} = '$(PERL)';
- }
- else {
- $self->{ABSPERL} = $self->rel2abs($self->{ABSPERL});
-
- # Quote the perl command if it contains whitespace
- $self->{ABSPERL} = $self->quote_literal($self->{ABSPERL})
- if $self->{ABSPERL} =~ /\s/;
-
- $self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr;
- }
-
- # Are we building the core?
- $self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE};
- $self->{PERL_CORE} = 0 unless defined $self->{PERL_CORE};
-
- # How do we run perl?
- foreach my $perl (qw(PERL FULLPERL ABSPERL)) {
- my $run = $perl.'RUN';
-
- $self->{$run} = "\$($perl)";
-
- # Make sure perl can find itself before it's installed.
- $self->{$run} .= q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"}
- if $self->{UNINSTALLED_PERL} || $self->{PERL_CORE};
-
- $self->{$perl.'RUNINST'} =
- sprintf q{$(%sRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"}, $perl;
- }
-
- return 1;
-}
-
-
-=item init_platform
-
-=item platform_constants
-
-Add MM_Unix_VERSION.
-
-=cut
-
-sub init_platform {
- my($self) = shift;
-
- $self->{MM_Unix_VERSION} = $VERSION;
- $self->{PERL_MALLOC_DEF} = '-DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc '.
- '-Dfree=Perl_mfree -Drealloc=Perl_realloc '.
- '-Dcalloc=Perl_calloc';
-
-}
-
-sub platform_constants {
- my($self) = shift;
- my $make_frag = '';
-
- foreach my $macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF))
- {
- next unless defined $self->{$macro};
- $make_frag .= "$macro = $self->{$macro}\n";
- }
-
- return $make_frag;
-}
-
-
-=item init_PERM
-
- $mm->init_PERM
-
-Called by init_main. Initializes PERL_*
-
-=cut
-
-sub init_PERM {
- my($self) = shift;
-
- $self->{PERM_DIR} = 755 unless defined $self->{PERM_DIR};
- $self->{PERM_RW} = 644 unless defined $self->{PERM_RW};
- $self->{PERM_RWX} = 755 unless defined $self->{PERM_RWX};
-
- return 1;
-}
-
-
-=item init_xs
-
- $mm->init_xs
-
-Sets up macros having to do with XS code. Currently just INST_STATIC,
-INST_DYNAMIC and INST_BOOT.
-
-=cut
-
-sub init_xs {
- my $self = shift;
-
- if ($self->has_link_code()) {
- $self->{INST_STATIC} =
- $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)');
- $self->{INST_DYNAMIC} =
- $self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)');
- $self->{INST_BOOT} =
- $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs');
- } else {
- $self->{INST_STATIC} = '';
- $self->{INST_DYNAMIC} = '';
- $self->{INST_BOOT} = '';
- }
-}
-
-=item install (o)
-
-Defines the install target.
-
-=cut
-
-sub install {
- my($self, %attribs) = @_;
- my(@m);
-
- push @m, q{
-install :: pure_install doc_install
- $(NOECHO) $(NOOP)
-
-install_perl :: pure_perl_install doc_perl_install
- $(NOECHO) $(NOOP)
-
-install_site :: pure_site_install doc_site_install
- $(NOECHO) $(NOOP)
-
-install_vendor :: pure_vendor_install doc_vendor_install
- $(NOECHO) $(NOOP)
-
-pure_install :: pure_$(INSTALLDIRS)_install
- $(NOECHO) $(NOOP)
-
-doc_install :: doc_$(INSTALLDIRS)_install
- $(NOECHO) $(NOOP)
-
-pure__install : pure_site_install
- $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
-
-doc__install : doc_site_install
- $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site
-
-pure_perl_install :: all
- $(NOECHO) $(MOD_INSTALL) \
- read }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
- write }.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{ \
- $(INST_LIB) $(DESTINSTALLPRIVLIB) \
- $(INST_ARCHLIB) $(DESTINSTALLARCHLIB) \
- $(INST_BIN) $(DESTINSTALLBIN) \
- $(INST_SCRIPT) $(DESTINSTALLSCRIPT) \
- $(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) \
- $(INST_MAN3DIR) $(DESTINSTALLMAN3DIR)
- $(NOECHO) $(WARN_IF_OLD_PACKLIST) \
- }.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{
-
-
-pure_site_install :: all
- $(NOECHO) $(MOD_INSTALL) \
- read }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \
- write }.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{ \
- $(INST_LIB) $(DESTINSTALLSITELIB) \
- $(INST_ARCHLIB) $(DESTINSTALLSITEARCH) \
- $(INST_BIN) $(DESTINSTALLSITEBIN) \
- $(INST_SCRIPT) $(DESTINSTALLSITESCRIPT) \
- $(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) \
- $(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR)
- $(NOECHO) $(WARN_IF_OLD_PACKLIST) \
- }.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{
-
-pure_vendor_install :: all
- $(NOECHO) $(MOD_INSTALL) \
- read }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{ \
- write }.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{ \
- $(INST_LIB) $(DESTINSTALLVENDORLIB) \
- $(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) \
- $(INST_BIN) $(DESTINSTALLVENDORBIN) \
- $(INST_SCRIPT) $(DESTINSTALLVENDORSCRIPT) \
- $(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) \
- $(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR)
-
-doc_perl_install :: all
- $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
- -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
- -$(NOECHO) $(DOC_INSTALL) \
- "Module" "$(NAME)" \
- "installed into" "$(INSTALLPRIVLIB)" \
- LINKTYPE "$(LINKTYPE)" \
- VERSION "$(VERSION)" \
- EXE_FILES "$(EXE_FILES)" \
- >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
-
-doc_site_install :: all
- $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
- -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
- -$(NOECHO) $(DOC_INSTALL) \
- "Module" "$(NAME)" \
- "installed into" "$(INSTALLSITELIB)" \
- LINKTYPE "$(LINKTYPE)" \
- VERSION "$(VERSION)" \
- EXE_FILES "$(EXE_FILES)" \
- >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
-
-doc_vendor_install :: all
- $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
- -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
- -$(NOECHO) $(DOC_INSTALL) \
- "Module" "$(NAME)" \
- "installed into" "$(INSTALLVENDORLIB)" \
- LINKTYPE "$(LINKTYPE)" \
- VERSION "$(VERSION)" \
- EXE_FILES "$(EXE_FILES)" \
- >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
-
-};
-
- push @m, q{
-uninstall :: uninstall_from_$(INSTALLDIRS)dirs
- $(NOECHO) $(NOOP)
-
-uninstall_from_perldirs ::
- $(NOECHO) $(UNINSTALL) }.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{
-
-uninstall_from_sitedirs ::
- $(NOECHO) $(UNINSTALL) }.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{
-
-uninstall_from_vendordirs ::
- $(NOECHO) $(UNINSTALL) }.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{
-};
-
- join("", at m);
-}
-
-=item installbin (o)
-
-Defines targets to make and to install EXE_FILES.
-
-=cut
-
-sub installbin {
- my($self) = shift;
-
- return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
- my @exefiles = @{$self->{EXE_FILES}};
- return "" unless @exefiles;
-
- @exefiles = map vmsify($_), @exefiles if $Is{VMS};
-
- my %fromto;
- for my $from (@exefiles) {
- my($path)= $self->catfile('$(INST_SCRIPT)', basename($from));
-
- local($_) = $path; # for backwards compatibility
- my $to = $self->libscan($path);
- print "libscan($from) => '$to'\n" if ($Verbose >=2);
-
- $to = vmsify($to) if $Is{VMS};
- $fromto{$from} = $to;
- }
- my @to = values %fromto;
-
- my @m;
- push(@m, qq{
-EXE_FILES = @exefiles
-
-pure_all :: @to
- \$(NOECHO) \$(NOOP)
-
-realclean ::
-});
-
- # realclean can get rather large.
- push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to);
- push @m, "\n";
-
-
- # A target for each exe file.
- while (my($from,$to) = each %fromto) {
- last unless defined $from;
-
- push @m, sprintf <<'MAKE', $to, $from, $to, $from, $to, $to, $to;
-%s : %s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists
- $(NOECHO) $(RM_F) %s
- $(CP) %s %s
- $(FIXIN) %s
- -$(NOECHO) $(CHMOD) $(PERM_RWX) %s
-
-MAKE
-
- }
-
- join "", @m;
-}
-
-
-=item linkext (o)
-
-Defines the linkext target which in turn defines the LINKTYPE.
-
-=cut
-
-sub linkext {
- my($self, %attribs) = @_;
- # LINKTYPE => static or dynamic or ''
- my($linktype) = defined $attribs{LINKTYPE} ?
- $attribs{LINKTYPE} : '$(LINKTYPE)';
- "
-linkext :: $linktype
- \$(NOECHO) \$(NOOP)
-";
-}
-
-=item lsdir
-
-Takes as arguments a directory name and a regular expression. Returns
-all entries in the directory that match the regular expression.
-
-=cut
-
-sub lsdir {
- my($self) = shift;
- my($dir, $regex) = @_;
- my(@ls);
- my $dh = new DirHandle;
- $dh->open($dir || ".") or return ();
- @ls = $dh->read;
- $dh->close;
- @ls = grep(/$regex/, @ls) if $regex;
- @ls;
-}
-
-=item macro (o)
-
-Simple subroutine to insert the macros defined by the macro attribute
-into the Makefile.
-
-=cut
-
-sub macro {
- my($self,%attribs) = @_;
- my(@m,$key,$val);
- while (($key,$val) = each %attribs){
- last unless defined $key;
- push @m, "$key = $val\n";
- }
- join "", @m;
-}
-
-=item makeaperl (o)
-
-Called by staticmake. Defines how to write the Makefile to produce a
-static new perl.
-
-By default the Makefile produced includes all the static extensions in
-the perl library. (Purified versions of library files, e.g.,
-DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.)
-
-=cut
-
-sub makeaperl {
- my($self, %attribs) = @_;
- my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) =
- @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
- my(@m);
- push @m, "
-# --- MakeMaker makeaperl section ---
-MAP_TARGET = $target
-FULLPERL = $self->{FULLPERL}
-";
- return join '', @m if $self->{PARENT};
-
- my($dir) = join ":", @{$self->{DIR}};
-
- unless ($self->{MAKEAPERL}) {
- push @m, q{
-$(MAP_TARGET) :: static $(MAKE_APERL_FILE)
- $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@
-
-$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) pm_to_blib
- $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET)
- $(NOECHO) $(PERLRUNINST) \
- Makefile.PL DIR=}, $dir, q{ \
- MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
- MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=};
-
- foreach (@ARGV){
- if( /\s/ ){
- s/=(.*)/='$1'/;
- }
- push @m, " \\\n\t\t$_";
- }
-# push @m, map( " \\\n\t\t$_", @ARGV );
- push @m, "\n";
-
- return join '', @m;
- }
-
-
-
- my($cccmd, $linkcmd, $lperl);
-
-
- $cccmd = $self->const_cccmd($libperl);
- $cccmd =~ s/^CCCMD\s*=\s*//;
- $cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /;
- $cccmd .= " $Config{cccdlflags}"
- if ($Config{useshrplib} eq 'true');
- $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/;
-
- # The front matter of the linkcommand...
- $linkcmd = join ' ', "\$(CC)",
- grep($_, @Config{qw(ldflags ccdlflags)});
- $linkcmd =~ s/\s+/ /g;
- $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;
-
- # Which *.a files could we make use of...
- my %static;
- require File::Find;
- File::Find::find(sub {
- return unless m/\Q$self->{LIB_EXT}\E$/;
-
- # Skip perl's libraries.
- return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/;
-
- # Skip purified versions of libraries
- # (e.g., DynaLoader_pure_p1_c0_032.a)
- return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure";
-
- if( exists $self->{INCLUDE_EXT} ){
- my $found = 0;
-
- (my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
- $xx =~ s,/?$_,,;
- $xx =~ s,/,::,g;
-
- # Throw away anything not explicitly marked for inclusion.
- # DynaLoader is implied.
- foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
- if( $xx eq $incl ){
- $found++;
- last;
- }
- }
- return unless $found;
- }
- elsif( exists $self->{EXCLUDE_EXT} ){
- (my $xx = $File::Find::name) =~ s,.*?/auto/,,s;
- $xx =~ s,/?$_,,;
- $xx =~ s,/,::,g;
-
- # Throw away anything explicitly marked for exclusion
- foreach my $excl (@{$self->{EXCLUDE_EXT}}){
- return if( $xx eq $excl );
- }
- }
-
- # don't include the installed version of this extension. I
- # leave this line here, although it is not necessary anymore:
- # I patched minimod.PL instead, so that Miniperl.pm won't
- # enclude duplicates
-
- # Once the patch to minimod.PL is in the distribution, I can
- # drop it
- return if $File::Find::name =~ m:auto/$self->{FULLEXT}/$self->{BASEEXT}$self->{LIB_EXT}\z:;
- use Cwd 'cwd';
- $static{cwd() . "/" . $_}++;
- }, grep( -d $_, @{$searchdirs || []}) );
-
- # We trust that what has been handed in as argument, will be buildable
- $static = [] unless $static;
- @static{@{$static}} = (1) x @{$static};
-
- $extra = [] unless $extra && ref $extra eq 'ARRAY';
- for (sort keys %static) {
- next unless /\Q$self->{LIB_EXT}\E\z/;
- $_ = dirname($_) . "/extralibs.ld";
- push @$extra, $_;
- }
-
- s/^(.*)/"-I$1"/ for @{$perlinc || []};
-
- $target ||= "perl";
- $tmp ||= ".";
-
-# MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we
-# regenerate the Makefiles, MAP_STATIC and the dependencies for
-# extralibs.all are computed correctly
- push @m, "
-MAP_LINKCMD = $linkcmd
-MAP_PERLINC = @{$perlinc || []}
-MAP_STATIC = ",
-join(" \\\n\t", reverse sort keys %static), "
-
-MAP_PRELIBS = $Config{perllibs} $Config{cryptlib}
-";
-
- if (defined $libperl) {
- ($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/;
- }
- unless ($libperl && -f $lperl) { # Ilya's code...
- my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE";
- $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL};
- $libperl ||= "libperl$self->{LIB_EXT}";
- $libperl = "$dir/$libperl";
- $lperl ||= "libperl$self->{LIB_EXT}";
- $lperl = "$dir/$lperl";
-
- if (! -f $libperl and ! -f $lperl) {
- # We did not find a static libperl. Maybe there is a shared one?
- if ($Is{SunOS}) {
- $lperl = $libperl = "$dir/$Config{libperl}";
- # SUNOS ld does not take the full path to a shared library
- $libperl = '' if $Is{SunOS4};
- }
- }
-
- print STDOUT "Warning: $libperl not found
- If you're going to build a static perl binary, make sure perl is installed
- otherwise ignore this warning\n"
- unless (-f $lperl || defined($self->{PERL_SRC}));
- }
-
- # SUNOS ld does not take the full path to a shared library
- my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl';
-
- push @m, "
-MAP_LIBPERL = $libperl
-LLIBPERL = $llibperl
-";
-
- push @m, '
-$(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t", @$extra).'
- $(NOECHO) $(RM_F) $@
- $(NOECHO) $(TOUCH) $@
-';
-
- foreach my $catfile (@$extra){
- push @m, "\tcat $catfile >> \$\@\n";
- }
-
-push @m, "
-\$(MAP_TARGET) :: $tmp/perlmain\$(OBJ_EXT) \$(MAP_LIBPERL) \$(MAP_STATIC) \$(INST_ARCHAUTODIR)/extralibs.all
- \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) \$(LDFROM) \$(MAP_STATIC) \$(LLIBPERL) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
- \$(NOECHO) \$(ECHO) 'To install the new \"\$(MAP_TARGET)\" binary, call'
- \$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename inst_perl MAP_TARGET=\$(MAP_TARGET)'
- \$(NOECHO) \$(ECHO) 'To remove the intermediate files say'
- \$(NOECHO) \$(ECHO) ' \$(MAKE) \$(USEMAKEFILE) $makefilename map_clean'
-
-$tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c
-";
- push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n";
-
- push @m, qq{
-$tmp/perlmain.c: $makefilename}, q{
- $(NOECHO) $(ECHO) Writing $@
- $(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \\
- -e "writemain(grep s#.*/auto/##s, split(q| |, q|$(MAP_STATIC)|))" > $@t && $(MV) $@t $@
-
-};
- push @m, "\t", q{$(NOECHO) $(PERL) $(INSTALLSCRIPT)/fixpmain
-} if (defined (&Dos::UseLFN) && Dos::UseLFN()==0);
-
-
- push @m, q{
-doc_inst_perl :
- $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod
- -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
- -$(NOECHO) $(DOC_INSTALL) \
- "Perl binary" "$(MAP_TARGET)" \
- MAP_STATIC "$(MAP_STATIC)" \
- MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \
- MAP_LIBPERL "$(MAP_LIBPERL)" \
- >> }.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{
-
-};
-
- push @m, q{
-inst_perl : pure_inst_perl doc_inst_perl
-
-pure_inst_perl : $(MAP_TARGET)
- }.$self->{CP}.q{ $(MAP_TARGET) }.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{
-
-clean :: map_clean
-
-map_clean :
- }.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all
-};
-
- join '', @m;
-}
-
-=item makefile (o)
-
-Defines how to rewrite the Makefile.
-
-=cut
-
-sub makefile {
- my($self) = shift;
- my $m;
- # We do not know what target was originally specified so we
- # must force a manual rerun to be sure. But as it should only
- # happen very rarely it is not a significant problem.
- $m = '
-$(OBJECT) : $(FIRST_MAKEFILE)
-
-' if $self->{OBJECT};
-
- my $newer_than_target = $Is{VMS} ? '$(MMS$SOURCE_LIST)' : '$?';
- my $mpl_args = join " ", map qq["$_"], @ARGV;
-
- $m .= sprintf <<'MAKE_FRAG', $newer_than_target, $mpl_args;
-# We take a very conservative approach here, but it's worth it.
-# We move Makefile to Makefile.old here to avoid gnu make looping.
-$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP)
- $(NOECHO) $(ECHO) "Makefile out-of-date with respect to %s"
- $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..."
- -$(NOECHO) $(RM_F) $(MAKEFILE_OLD)
- -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD)
- - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL)
- $(PERLRUN) Makefile.PL %s
- $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <=="
- $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <=="
- $(FALSE)
-
-MAKE_FRAG
-
- return $m;
-}
-
-
-=item maybe_command
-
-Returns true, if the argument is likely to be a command.
-
-=cut
-
-sub maybe_command {
- my($self,$file) = @_;
- return $file if -x $file && ! -d $file;
- return;
-}
-
-
-=item needs_linking (o)
-
-Does this module need linking? Looks into subdirectory objects (see
-also has_link_code())
-
-=cut
-
-sub needs_linking {
- my($self) = shift;
-
- my $caller = (caller(0))[3];
- confess("needs_linking called too early") if
- $caller =~ /^ExtUtils::MakeMaker::/;
- return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING};
- if ($self->has_link_code or $self->{MAKEAPERL}){
- $self->{NEEDS_LINKING} = 1;
- return 1;
- }
- foreach my $child (keys %{$self->{CHILDREN}}) {
- if ($self->{CHILDREN}->{$child}->needs_linking) {
- $self->{NEEDS_LINKING} = 1;
- return 1;
- }
- }
- return $self->{NEEDS_LINKING} = 0;
-}
-
-
-=item parse_abstract
-
-parse a file and return what you think is the ABSTRACT
-
-=cut
-
-sub parse_abstract {
- my($self,$parsefile) = @_;
- my $result;
-
- local $/ = "\n";
- open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
- my $inpod = 0;
- my $package = $self->{DISTNAME};
- $package =~ s/-/::/g;
- while (<$fh>) {
- $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
- next if !$inpod;
- chop;
- next unless /^($package\s-\s)(.*)/;
- $result = $2;
- last;
- }
- close $fh;
-
- return $result;
-}
-
-=item parse_version
-
- my $version = MM->parse_version($file);
-
-Parse a $file and return what $VERSION is set to by the first assignment.
-It will return the string "undef" if it can't figure out what $VERSION
-is. $VERSION should be for all to see, so C<our $VERSION> or plain $VERSION
-are okay, but C<my $VERSION> is not.
-
-parse_version() will try to C<use version> before checking for
-C<$VERSION> so the following will work.
-
- $VERSION = qv(1.2.3);
-
-=cut
-
-sub parse_version {
- my($self,$parsefile) = @_;
- my $result;
-
- local $/ = "\n";
- local $_;
- open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!";
- my $inpod = 0;
- while (<$fh>) {
- $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
- next if $inpod || /^\s*#/;
- chop;
- next if /^\s*(if|unless)/;
- next unless m{(?<!\\) ([\$*]) (([\w\:\']*) \bVERSION)\b .* =}x;
- my $eval = qq{
- package ExtUtils::MakeMaker::_version;
- no strict;
- BEGIN { eval {
- # Ensure any version() routine which might have leaked
- # into this package has been deleted. Interferes with
- # version->import()
- undef *version;
- require version;
- "version"->import;
- } }
-
- local $1$2;
- \$$2=undef;
- do {
- $_
- };
- \$$2;
- };
- local $^W = 0;
- $result = eval($eval); ## no critic
- warn "Could not eval '$eval' in $parsefile: $@" if $@;
- last if defined $result;
- }
- close $fh;
-
- $result = "undef" unless defined $result;
- return $result;
-}
-
-
-=item pasthru (o)
-
-Defines the string that is passed to recursive make calls in
-subdirectories.
-
-=cut
-
-sub pasthru {
- my($self) = shift;
- my(@m);
-
- my(@pasthru);
- my($sep) = $Is{VMS} ? ',' : '';
- $sep .= "\\\n\t";
-
- foreach my $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE
- PREFIX INSTALL_BASE)
- )
- {
- next unless defined $self->{$key};
- push @pasthru, "$key=\"\$($key)\"";
- }
-
- foreach my $key (qw(DEFINE INC)) {
- next unless defined $self->{$key};
- push @pasthru, "PASTHRU_$key=\"\$(PASTHRU_$key)\"";
- }
-
- push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n";
- join "", @m;
-}
-
-=item perl_script
-
-Takes one argument, a file name, and returns the file name, if the
-argument is likely to be a perl script. On MM_Unix this is true for
-any ordinary, readable file.
-
-=cut
-
-sub perl_script {
- my($self,$file) = @_;
- return $file if -r $file && -f _;
- return;
-}
-
-=item perldepend (o)
-
-Defines the dependency from all *.h files that come with the perl
-distribution.
-
-=cut
-
-sub perldepend {
- my($self) = shift;
- my(@m);
-
- my $make_config = $self->cd('$(PERL_SRC)', '$(MAKE) lib/Config.pm');
-
- push @m, sprintf <<'MAKE_FRAG', $make_config if $self->{PERL_SRC};
-# Check for unpropogated config.sh changes. Should never happen.
-# We do NOT just update config.h because that is not sufficient.
-# An out of date config.h is not fatal but complains loudly!
-$(PERL_INC)/config.h: $(PERL_SRC)/config.sh
- -$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE)
-
-$(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh
- $(NOECHO) $(ECHO) "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh"
- %s
-MAKE_FRAG
-
- return join "", @m unless $self->needs_linking;
-
- push @m, q{
-PERL_HDRS = \
- $(PERL_INC)/EXTERN.h \
- $(PERL_INC)/INTERN.h \
- $(PERL_INC)/XSUB.h \
- $(PERL_INC)/av.h \
- $(PERL_INC)/cc_runtime.h \
- $(PERL_INC)/config.h \
- $(PERL_INC)/cop.h \
- $(PERL_INC)/cv.h \
- $(PERL_INC)/dosish.h \
- $(PERL_INC)/embed.h \
- $(PERL_INC)/embedvar.h \
- $(PERL_INC)/fakethr.h \
- $(PERL_INC)/form.h \
- $(PERL_INC)/gv.h \
- $(PERL_INC)/handy.h \
- $(PERL_INC)/hv.h \
- $(PERL_INC)/intrpvar.h \
- $(PERL_INC)/iperlsys.h \
- $(PERL_INC)/keywords.h \
- $(PERL_INC)/mg.h \
- $(PERL_INC)/nostdio.h \
- $(PERL_INC)/op.h \
- $(PERL_INC)/opcode.h \
- $(PERL_INC)/patchlevel.h \
- $(PERL_INC)/perl.h \
- $(PERL_INC)/perlio.h \
- $(PERL_INC)/perlsdio.h \
- $(PERL_INC)/perlsfio.h \
- $(PERL_INC)/perlvars.h \
- $(PERL_INC)/perly.h \
- $(PERL_INC)/pp.h \
- $(PERL_INC)/pp_proto.h \
- $(PERL_INC)/proto.h \
- $(PERL_INC)/regcomp.h \
- $(PERL_INC)/regexp.h \
- $(PERL_INC)/regnodes.h \
- $(PERL_INC)/scope.h \
- $(PERL_INC)/sv.h \
- $(PERL_INC)/thread.h \
- $(PERL_INC)/unixish.h \
- $(PERL_INC)/util.h
-
-$(OBJECT) : $(PERL_HDRS)
-} if $self->{OBJECT};
-
- push @m, join(" ", values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}};
-
- join "\n", @m;
-}
-
-
-=item pm_to_blib
-
-Defines target that copies all files in the hash PM to their
-destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION>
-
-=cut
-
-sub pm_to_blib {
- my $self = shift;
- my($autodir) = $self->catdir('$(INST_LIB)','auto');
- my $r = q{
-pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM)
-};
-
- # VMS will swallow '' and PM_FILTER is often empty. So use q[]
- my $pm_to_blib = $self->oneliner(<<CODE, ['-MExtUtils::Install']);
-pm_to_blib({\@ARGV}, '$autodir', q[\$(PM_FILTER)], '\$(PERM_DIR)')
-CODE
-
- my @cmds = $self->split_command($pm_to_blib, %{$self->{PM}});
-
- $r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds;
- $r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n};
-
- return $r;
-}
-
-=item post_constants (o)
-
-Returns an empty string per default. Dedicated to overrides from
-within Makefile.PL after all constants have been defined.
-
-=cut
-
-sub post_constants{
- "";
-}
-
-=item post_initialize (o)
-
-Returns an empty string per default. Used in Makefile.PLs to add some
-chunk of text to the Makefile after the object is initialized.
-
-=cut
-
-sub post_initialize {
- "";
-}
-
-=item postamble (o)
-
-Returns an empty string. Can be used in Makefile.PLs to write some
-text to the Makefile at the end.
-
-=cut
-
-sub postamble {
- "";
-}
-
-# transform dot-separated version string into comma-separated quadruple
-# examples: '1.2.3.4.5' => '1,2,3,4'
-# '1.2.3' => '1,2,3,0'
-sub _ppd_version {
- my ($self, $string) = @_;
- return join ',', ((split /\./, $string), (0) x 4)[0..3];
-}
-
-=item ppd
-
-Defines target that creates a PPD (Perl Package Description) file
-for a binary distribution.
-
-=cut
-
-sub ppd {
- my($self) = @_;
-
- my $abstract = $self->{ABSTRACT} || '';
- $abstract =~ s/\n/\\n/sg;
- $abstract =~ s/</</g;
- $abstract =~ s/>/>/g;
-
- my $author = $self->{AUTHOR} || '';
- $author =~ s/</</g;
- $author =~ s/>/>/g;
-
- my $ppd_xml = sprintf <<'PPD_HTML', $self->{VERSION}, $abstract, $author;
-<SOFTPKG NAME="$(DISTNAME)" VERSION="%s">
- <ABSTRACT>%s</ABSTRACT>
- <AUTHOR>%s</AUTHOR>
-PPD_HTML
-
- $ppd_xml .= " <IMPLEMENTATION>\n";
- if ( $self->{MIN_PERL_VERSION} ) {
- my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION});
- $ppd_xml .= sprintf <<'PPD_PERLVERS', $min_perl_version;
- <PERLCORE VERSION="%s" />
-PPD_PERLVERS
-
- }
-
- # Don't add "perl" to requires. perl dependencies are
- # handles by ARCHITECTURE.
- my %prereqs = %{$self->{PREREQ_PM}};
- delete $prereqs{perl};
-
- # Build up REQUIRE
- foreach my $prereq (sort keys %prereqs) {
- my $name = $prereq;
- $name .= '::' unless $name =~ /::/;
- my $version = $prereqs{$prereq}+0; # force numification
-
- my %attrs = ( NAME => $name );
- $attrs{VERSION} = $version if $version;
- my $attrs = join " ", map { qq[$_="$attrs{$_}"] } keys %attrs;
- $ppd_xml .= qq( <REQUIRE $attrs />\n);
- }
-
- my $archname = $Config{archname};
- if ($] >= 5.008) {
- # archname did not change from 5.6 to 5.8, but those versions may
- # not be not binary compatible so now we append the part of the
- # version that changes when binary compatibility may change
- $archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}";
- }
- $ppd_xml .= sprintf <<'PPD_OUT', $archname;
- <ARCHITECTURE NAME="%s" />
-PPD_OUT
-
- if ($self->{PPM_INSTALL_SCRIPT}) {
- if ($self->{PPM_INSTALL_EXEC}) {
- $ppd_xml .= sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n},
- $self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT};
- }
- else {
- $ppd_xml .= sprintf qq{ <INSTALL>%s</INSTALL>\n},
- $self->{PPM_INSTALL_SCRIPT};
- }
- }
-
- my ($bin_location) = $self->{BINARY_LOCATION} || '';
- $bin_location =~ s/\\/\\\\/g;
-
- $ppd_xml .= sprintf <<'PPD_XML', $bin_location;
- <CODEBASE HREF="%s" />
- </IMPLEMENTATION>
-</SOFTPKG>
-PPD_XML
-
- my @ppd_cmds = $self->echo($ppd_xml, '$(DISTNAME).ppd');
-
- return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds;
-# Creates a PPD (Perl Package Description) for a binary distribution.
-ppd :
- %s
-PPD_OUT
-
-}
-
-=item prefixify
-
- $MM->prefixify($var, $prefix, $new_prefix, $default);
-
-Using either $MM->{uc $var} || $Config{lc $var}, it will attempt to
-replace it's $prefix with a $new_prefix.
-
-Should the $prefix fail to match I<AND> a PREFIX was given as an
-argument to WriteMakefile() it will set it to the $new_prefix +
-$default. This is for systems whose file layouts don't neatly fit into
-our ideas of prefixes.
-
-This is for heuristics which attempt to create directory structures
-that mirror those of the installed perl.
-
-For example:
-
- $MM->prefixify('installman1dir', '/usr', '/home/foo', 'man/man1');
-
-this will attempt to remove '/usr' from the front of the
-$MM->{INSTALLMAN1DIR} path (initializing it to $Config{installman1dir}
-if necessary) and replace it with '/home/foo'. If this fails it will
-simply use '/home/foo/man/man1'.
-
-=cut
-
-sub prefixify {
- my($self,$var,$sprefix,$rprefix,$default) = @_;
-
- my $path = $self->{uc $var} ||
- $Config_Override{lc $var} || $Config{lc $var} || '';
-
- $rprefix .= '/' if $sprefix =~ m|/$|;
-
- print STDERR " prefixify $var => $path\n" if $Verbose >= 2;
- print STDERR " from $sprefix to $rprefix\n" if $Verbose >= 2;
-
- if( $self->{ARGS}{PREFIX} &&
- $path !~ s{^\Q$sprefix\E\b}{$rprefix}s )
- {
-
- print STDERR " cannot prefix, using default.\n" if $Verbose >= 2;
- print STDERR " no default!\n" if !$default && $Verbose >= 2;
-
- $path = $self->catdir($rprefix, $default) if $default;
- }
-
- print " now $path\n" if $Verbose >= 2;
- return $self->{uc $var} = $path;
-}
-
-
-=item processPL (o)
-
-Defines targets to run *.PL files.
-
-=cut
-
-sub processPL {
- my $self = shift;
- my $pl_files = $self->{PL_FILES};
-
- return "" unless $pl_files;
-
- my $m = '';
- foreach my $plfile (sort keys %$pl_files) {
- my $list = ref($pl_files->{$plfile})
- ? $pl_files->{$plfile}
- : [$pl_files->{$plfile}];
-
- foreach my $target (@$list) {
- if( $Is{VMS} ) {
- $plfile = vmsify($self->eliminate_macros($plfile));
- $target = vmsify($self->eliminate_macros($target));
- }
-
- # Normally a .PL file runs AFTER pm_to_blib so it can have
- # blib in its @INC and load the just built modules. BUT if
- # the generated module is something in $(TO_INST_PM) which
- # pm_to_blib depends on then it can't depend on pm_to_blib
- # else we have a dependency loop.
- my $pm_dep;
- my $perlrun;
- if( defined $self->{PM}{$target} ) {
- $pm_dep = '';
- $perlrun = 'PERLRUN';
- }
- else {
- $pm_dep = 'pm_to_blib';
- $perlrun = 'PERLRUNINST';
- }
-
- $m .= <<MAKE_FRAG;
-
-all :: $target
- \$(NOECHO) \$(NOOP)
-
-$target :: $plfile $pm_dep
- \$($perlrun) $plfile $target
-MAKE_FRAG
-
- }
- }
-
- return $m;
-}
-
-=item quote_paren
-
-Backslashes parentheses C<()> in command line arguments.
-Doesn't handle recursive Makefile C<$(...)> constructs,
-but handles simple ones.
-
-=cut
-
-sub quote_paren {
- my $arg = shift;
- $arg =~ s{\$\((.+?)\)}{\$\\\\($1\\\\)}g; # protect $(...)
- $arg =~ s{(?<!\\)([()])}{\\$1}g; # quote unprotected
- $arg =~ s{\$\\\\\((.+?)\\\\\)}{\$($1)}g; # unprotect $(...)
- return $arg;
-}
-
-=item replace_manpage_separator
-
- my $man_name = $MM->replace_manpage_separator($file_path);
-
-Takes the name of a package, which may be a nested package, in the
-form 'Foo/Bar.pm' and replaces the slash with C<::> or something else
-safe for a man page file name. Returns the replacement.
-
-=cut
-
-sub replace_manpage_separator {
- my($self,$man) = @_;
-
- $man =~ s,/+,::,g;
- return $man;
-}
-
-
-=item cd
-
-=cut
-
-sub cd {
- my($self, $dir, @cmds) = @_;
-
- # No leading tab and no trailing newline makes for easier embedding
- my $make_frag = join "\n\t", map { "cd $dir && $_" } @cmds;
-
- return $make_frag;
-}
-
-=item oneliner
-
-=cut
-
-sub oneliner {
- my($self, $cmd, $switches) = @_;
- $switches = [] unless defined $switches;
-
- # Strip leading and trailing newlines
- $cmd =~ s{^\n+}{};
- $cmd =~ s{\n+$}{};
-
- my @cmds = split /\n/, $cmd;
- $cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds;
- $cmd = $self->escape_newlines($cmd);
-
- $switches = join ' ', @$switches;
-
- return qq{\$(ABSPERLRUN) $switches -e $cmd --};
-}
-
-
-=item quote_literal
-
-=cut
-
-sub quote_literal {
- my($self, $text) = @_;
-
- # I think all we have to quote is single quotes and I think
- # this is a safe way to do it.
- $text =~ s{'}{'\\''}g;
-
- return "'$text'";
-}
-
-
-=item escape_newlines
-
-=cut
-
-sub escape_newlines {
- my($self, $text) = @_;
-
- $text =~ s{\n}{\\\n}g;
-
- return $text;
-}
-
-
-=item max_exec_len
-
-Using POSIX::ARG_MAX. Otherwise falling back to 4096.
-
-=cut
-
-sub max_exec_len {
- my $self = shift;
-
- if (!defined $self->{_MAX_EXEC_LEN}) {
- if (my $arg_max = eval { require POSIX; &POSIX::ARG_MAX }) {
- $self->{_MAX_EXEC_LEN} = $arg_max;
- }
- else { # POSIX minimum exec size
- $self->{_MAX_EXEC_LEN} = 4096;
- }
- }
-
- return $self->{_MAX_EXEC_LEN};
-}
-
-
-=item static (o)
-
-Defines the static target.
-
-=cut
-
-sub static {
-# --- Static Loading Sections ---
-
- my($self) = shift;
- '
-## $(INST_PM) has been moved to the all: target.
-## It remains here for awhile to allow for old usage: "make static"
-static :: $(FIRST_MAKEFILE) $(INST_STATIC)
- $(NOECHO) $(NOOP)
-';
-}
-
-=item static_lib (o)
-
-Defines how to produce the *.a (or equivalent) files.
-
-=cut
-
-sub static_lib {
- my($self) = @_;
- return '' unless $self->has_link_code;
-
- my(@m);
- push(@m, <<'END');
-
-$(INST_STATIC) : $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(RM_RF) $@
-END
-
- # If this extension has its own library (eg SDBM_File)
- # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
- push(@m, <<'MAKE_FRAG') if $self->{MYEXTLIB};
- $(CP) $(MYEXTLIB) $@
-MAKE_FRAG
-
- my $ar;
- if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) {
- # Prefer the absolute pathed ar if available so that PATH
- # doesn't confuse us. Perl itself is built with the full_ar.
- $ar = 'FULL_AR';
- } else {
- $ar = 'AR';
- }
- push @m, sprintf <<'MAKE_FRAG', $ar;
- $(%s) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
- $(CHMOD) $(PERM_RWX) $@
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
-MAKE_FRAG
-
- # Old mechanism - still available:
- push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)/ext.libs
-MAKE_FRAG
-
- join('', @m);
-}
-
-=item staticmake (o)
-
-Calls makeaperl.
-
-=cut
-
-sub staticmake {
- my($self, %attribs) = @_;
- my(@static);
-
- my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB});
-
- # And as it's not yet built, we add the current extension
- # but only if it has some C code (or XS code, which implies C code)
- if (@{$self->{C}}) {
- @static = $self->catfile($self->{INST_ARCHLIB},
- "auto",
- $self->{FULLEXT},
- "$self->{BASEEXT}$self->{LIB_EXT}"
- );
- }
-
- # Either we determine now, which libraries we will produce in the
- # subdirectories or we do it at runtime of the make.
-
- # We could ask all subdir objects, but I cannot imagine, why it
- # would be necessary.
-
- # Instead we determine all libraries for the new perl at
- # runtime.
- my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB});
-
- $self->makeaperl(MAKE => $self->{MAKEFILE},
- DIRS => \@searchdirs,
- STAT => \@static,
- INCL => \@perlinc,
- TARGET => $self->{MAP_TARGET},
- TMP => "",
- LIBPERL => $self->{LIBPERL_A}
- );
-}
-
-=item subdir_x (o)
-
-Helper subroutine for subdirs
-
-=cut
-
-sub subdir_x {
- my($self, $subdir) = @_;
-
- my $subdir_cmd = $self->cd($subdir,
- '$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)'
- );
- return sprintf <<'EOT', $subdir_cmd;
-
-subdirs ::
- $(NOECHO) %s
-EOT
-
-}
-
-=item subdirs (o)
-
-Defines targets to process subdirectories.
-
-=cut
-
-sub subdirs {
-# --- Sub-directory Sections ---
- my($self) = shift;
- my(@m);
- # This method provides a mechanism to automatically deal with
- # subdirectories containing further Makefile.PL scripts.
- # It calls the subdir_x() method for each subdirectory.
- foreach my $dir (@{$self->{DIR}}){
- push(@m, $self->subdir_x($dir));
-#### print "Including $dir subdirectory\n";
- }
- if (@m){
- unshift(@m, "
-# The default clean, realclean and test targets in this Makefile
-# have automatically been given entries for each subdir.
-
-");
- } else {
- push(@m, "\n# none")
- }
- join('', at m);
-}
-
-=item test (o)
-
-Defines the test targets.
-
-=cut
-
-sub test {
-# --- Test and Installation Sections ---
-
- my($self, %attribs) = @_;
- my $tests = $attribs{TESTS} || '';
- if (!$tests && -d 't') {
- $tests = $self->find_tests;
- }
- # note: 'test.pl' name is also hardcoded in init_dirscan()
- my(@m);
- push(@m,"
-TEST_VERBOSE=0
-TEST_TYPE=test_\$(LINKTYPE)
-TEST_FILE = test.pl
-TEST_FILES = $tests
-TESTDB_SW = -d
-
-testdb :: testdb_\$(LINKTYPE)
-
-test :: \$(TEST_TYPE) subdirs-test
-
-subdirs-test ::
- \$(NOECHO) \$(NOOP)
-
-");
-
- foreach my $dir (@{ $self->{DIR} }) {
- my $test = $self->cd($dir, '$(MAKE) test $(PASTHRU)');
-
- push @m, <<END
-subdirs-test ::
- \$(NOECHO) $test
-
-END
- }
-
- push(@m, "\t\$(NOECHO) \$(ECHO) 'No tests defined for \$(NAME) extension.'\n")
- unless $tests or -f "test.pl" or @{$self->{DIR}};
- push(@m, "\n");
-
- push(@m, "test_dynamic :: pure_all\n");
- push(@m, $self->test_via_harness('$(FULLPERLRUN)', '$(TEST_FILES)'))
- if $tests;
- push(@m, $self->test_via_script('$(FULLPERLRUN)', '$(TEST_FILE)'))
- if -f "test.pl";
- push(@m, "\n");
-
- push(@m, "testdb_dynamic :: pure_all\n");
- push(@m, $self->test_via_script('$(FULLPERLRUN) $(TESTDB_SW)',
- '$(TEST_FILE)'));
- push(@m, "\n");
-
- # Occasionally we may face this degenerate target:
- push @m, "test_ : test_dynamic\n\n";
-
- if ($self->needs_linking()) {
- push(@m, "test_static :: pure_all \$(MAP_TARGET)\n");
- push(@m, $self->test_via_harness('./$(MAP_TARGET)', '$(TEST_FILES)')) if $tests;
- push(@m, $self->test_via_script('./$(MAP_TARGET)', '$(TEST_FILE)')) if -f "test.pl";
- push(@m, "\n");
- push(@m, "testdb_static :: pure_all \$(MAP_TARGET)\n");
- push(@m, $self->test_via_script('./$(MAP_TARGET) $(TESTDB_SW)', '$(TEST_FILE)'));
- push(@m, "\n");
- } else {
- push @m, "test_static :: test_dynamic\n";
- push @m, "testdb_static :: testdb_dynamic\n";
- }
- join("", @m);
-}
-
-=item test_via_harness (override)
-
-For some reason which I forget, Unix machines like to have
-PERL_DL_NONLAZY set for tests.
-
-=cut
-
-sub test_via_harness {
- my($self, $perl, $tests) = @_;
- return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests);
-}
-
-=item test_via_script (override)
-
-Again, the PERL_DL_NONLAZY thing.
-
-=cut
-
-sub test_via_script {
- my($self, $perl, $script) = @_;
- return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script);
-}
-
-
-=item tool_xsubpp (o)
-
-Determines typemaps, xsubpp version, prototype behaviour.
-
-=cut
-
-sub tool_xsubpp {
- my($self) = shift;
- return "" unless $self->needs_linking;
-
- my $xsdir;
- my @xsubpp_dirs = @INC;
-
- # Make sure we pick up the new xsubpp if we're building perl.
- unshift @xsubpp_dirs, $self->{PERL_LIB} if $self->{PERL_CORE};
-
- foreach my $dir (@xsubpp_dirs) {
- $xsdir = $self->catdir($dir, 'ExtUtils');
- if( -r $self->catfile($xsdir, "xsubpp") ) {
- last;
- }
- }
-
- my $tmdir = File::Spec->catdir($self->{PERL_LIB},"ExtUtils");
- my(@tmdeps) = $self->catfile($tmdir,'typemap');
- if( $self->{TYPEMAPS} ){
- foreach my $typemap (@{$self->{TYPEMAPS}}){
- if( ! -f $typemap ) {
- warn "Typemap $typemap not found.\n";
- }
- else {
- push(@tmdeps, $typemap);
- }
- }
- }
- push(@tmdeps, "typemap") if -f "typemap";
- my(@tmargs) = map("-typemap $_", @tmdeps);
- if( exists $self->{XSOPT} ){
- unshift( @tmargs, $self->{XSOPT} );
- }
-
- if ($Is{VMS} &&
- $Config{'ldflags'} &&
- $Config{'ldflags'} =~ m!/Debug!i &&
- (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/)
- )
- {
- unshift(@tmargs,'-nolinenumbers');
- }
-
-
- $self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG};
-
- return qq{
-XSUBPPDIR = $xsdir
-XSUBPP = \$(XSUBPPDIR)\$(DFSEP)xsubpp
-XSUBPPRUN = \$(PERLRUN) \$(XSUBPP)
-XSPROTOARG = $self->{XSPROTOARG}
-XSUBPPDEPS = @tmdeps \$(XSUBPP)
-XSUBPPARGS = @tmargs
-XSUBPP_EXTRA_ARGS =
-};
-};
-
-
-=item all_target
-
-Build man pages, too
-
-=cut
-
-sub all_target {
- my $self = shift;
-
- return <<'MAKE_EXT';
-all :: pure_all manifypods
- $(NOECHO) $(NOOP)
-MAKE_EXT
-}
-
-=item top_targets (o)
-
-Defines the targets all, subdirs, config, and O_FILES
-
-=cut
-
-sub top_targets {
-# --- Target Sections ---
-
- my($self) = shift;
- my(@m);
-
- push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'};
-
- push @m, '
-pure_all :: config pm_to_blib subdirs linkext
- $(NOECHO) $(NOOP)
-
-subdirs :: $(MYEXTLIB)
- $(NOECHO) $(NOOP)
-
-config :: $(FIRST_MAKEFILE) blibdirs
- $(NOECHO) $(NOOP)
-';
-
- push @m, '
-$(O_FILES): $(H_FILES)
-' if @{$self->{O_FILES} || []} && @{$self->{H} || []};
-
- push @m, q{
-help :
- perldoc ExtUtils::MakeMaker
-};
-
- join('', at m);
-}
-
-=item writedoc
-
-Obsolete, deprecated method. Not used since Version 5.21.
-
-=cut
-
-sub writedoc {
-# --- perllocal.pod section ---
- my($self,$what,$name, at attribs)=@_;
- my $time = localtime;
- print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n";
- print join "\n\n=item *\n\n", map("C<$_>", at attribs);
- print "\n\n=back\n\n";
-}
-
-=item xs_c (o)
-
-Defines the suffix rules to compile XS files to C.
-
-=cut
-
-sub xs_c {
- my($self) = shift;
- return '' unless $self->needs_linking();
- '
-.xs.c:
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
-';
-}
-
-=item xs_cpp (o)
-
-Defines the suffix rules to compile XS files to C++.
-
-=cut
-
-sub xs_cpp {
- my($self) = shift;
- return '' unless $self->needs_linking();
- '
-.xs.cpp:
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.cpp
-';
-}
-
-=item xs_o (o)
-
-Defines suffix rules to go from XS to object files directly. This is
-only intended for broken make implementations.
-
-=cut
-
-sub xs_o { # many makes are too dumb to use xs_c then c_o
- my($self) = shift;
- return '' unless $self->needs_linking();
- '
-.xs$(OBJ_EXT):
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc && $(MV) $*.xsc $*.c
- $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c
-';
-}
-
-
-1;
-
-=back
-
-=head1 SEE ALSO
-
-L<ExtUtils::MakeMaker>
-
-=cut
-
-__END__
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_VMS.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_VMS.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_VMS.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1994 +0,0 @@
-package ExtUtils::MM_VMS;
-
-use strict;
-
-use ExtUtils::MakeMaker::Config;
-require Exporter;
-
-BEGIN {
- # so we can compile the thing on non-VMS platforms.
- if( $^O eq 'VMS' ) {
- require VMS::Filespec;
- VMS::Filespec->import;
- }
-}
-
-use File::Basename;
-
-our $VERSION = '6.55_02';
-
-require ExtUtils::MM_Any;
-require ExtUtils::MM_Unix;
-our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-
-use ExtUtils::MakeMaker qw($Verbose neatvalue);
-our $Revision = $ExtUtils::MakeMaker::Revision;
-
-
-=head1 NAME
-
-ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker
-
-=head1 SYNOPSIS
-
- Do not use this directly.
- Instead, use ExtUtils::MM and it will figure out which MM_*
- class to use for you.
-
-=head1 DESCRIPTION
-
-See ExtUtils::MM_Unix for a documentation of the methods provided
-there. This package overrides the implementation of these methods, not
-the semantics.
-
-=head2 Methods always loaded
-
-=over 4
-
-=item wraplist
-
-Converts a list into a string wrapped at approximately 80 columns.
-
-=cut
-
-sub wraplist {
- my($self) = shift;
- my($line,$hlen) = ('',0);
-
- foreach my $word (@_) {
- # Perl bug -- seems to occasionally insert extra elements when
- # traversing array (scalar(@array) doesn't show them, but
- # foreach(@array) does) (5.00307)
- next unless $word =~ /\w/;
- $line .= ' ' if length($line);
- if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; }
- $line .= $word;
- $hlen += length($word) + 2;
- }
- $line;
-}
-
-
-# This isn't really an override. It's just here because ExtUtils::MM_VMS
-# appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext()
-# in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just
-# mimic inheritance here and hand off to ExtUtils::Liblist::Kid.
-# XXX This hackery will die soon. --Schwern
-sub ext {
- require ExtUtils::Liblist::Kid;
- goto &ExtUtils::Liblist::Kid::ext;
-}
-
-=back
-
-=head2 Methods
-
-Those methods which override default MM_Unix methods are marked
-"(override)", while methods unique to MM_VMS are marked "(specific)".
-For overridden methods, documentation is limited to an explanation
-of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix
-documentation for more details.
-
-=over 4
-
-=item guess_name (override)
-
-Try to determine name of extension being built. We begin with the name
-of the current directory. Since VMS filenames are case-insensitive,
-however, we look for a F<.pm> file whose name matches that of the current
-directory (presumably the 'main' F<.pm> file for this extension), and try
-to find a C<package> statement from which to obtain the Mixed::Case
-package name.
-
-=cut
-
-sub guess_name {
- my($self) = @_;
- my($defname,$defpm, at pm,%xs);
- local *PM;
-
- $defname = basename(fileify($ENV{'DEFAULT'}));
- $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version
- $defpm = $defname;
- # Fallback in case for some reason a user has copied the files for an
- # extension into a working directory whose name doesn't reflect the
- # extension's name. We'll use the name of a unique .pm file, or the
- # first .pm file with a matching .xs file.
- if (not -e "${defpm}.pm") {
- @pm = glob('*.pm');
- s/.pm$// for @pm;
- if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; }
- elsif (@pm) {
- %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); ## no critic
- if (keys %xs) {
- foreach my $pm (@pm) {
- $defpm = $pm, last if exists $xs{$pm};
- }
- }
- }
- }
- if (open(my $pm, '<', "${defpm}.pm")){
- while (<$pm>) {
- if (/^\s*package\s+([^;]+)/i) {
- $defname = $1;
- last;
- }
- }
- print STDOUT "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t",
- "defaulting package name to $defname\n"
- if eof($pm);
- close $pm;
- }
- else {
- print STDOUT "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t",
- "defaulting package name to $defname\n";
- }
- $defname =~ s#[\d.\-_]+$##;
- $defname;
-}
-
-=item find_perl (override)
-
-Use VMS file specification syntax and CLI commands to find and
-invoke Perl images.
-
-=cut
-
-sub find_perl {
- my($self, $ver, $names, $dirs, $trace) = @_;
- my($vmsfile, at sdirs, at snames, at cand);
- my($rslt);
- my($inabs) = 0;
- local *TCF;
-
- if( $self->{PERL_CORE} ) {
- # Check in relative directories first, so we pick up the current
- # version of Perl if we're running MakeMaker as part of the main build.
- @sdirs = sort { my($absa) = $self->file_name_is_absolute($a);
- my($absb) = $self->file_name_is_absolute($b);
- if ($absa && $absb) { return $a cmp $b }
- else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
- } @$dirs;
- # Check miniperl before perl, and check names likely to contain
- # version numbers before "generic" names, so we pick up an
- # executable that's less likely to be from an old installation.
- @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename
- my($bb) = $b =~ m!([^:>\]/]+)$!;
- my($ahasdir) = (length($a) - length($ba) > 0);
- my($bhasdir) = (length($b) - length($bb) > 0);
- if ($ahasdir and not $bhasdir) { return 1; }
- elsif ($bhasdir and not $ahasdir) { return -1; }
- else { $bb =~ /\d/ <=> $ba =~ /\d/
- or substr($ba,0,1) cmp substr($bb,0,1)
- or length($bb) <=> length($ba) } } @$names;
- }
- else {
- @sdirs = @$dirs;
- @snames = @$names;
- }
-
- # Image names containing Perl version use '_' instead of '.' under VMS
- s/\.(\d+)$/_$1/ for @snames;
- if ($trace >= 2){
- print "Looking for perl $ver by these names:\n";
- print "\t at snames,\n";
- print "in these dirs:\n";
- print "\t at sdirs\n";
- }
- foreach my $dir (@sdirs){
- next unless defined $dir; # $self->{PERL_SRC} may be undefined
- $inabs++ if $self->file_name_is_absolute($dir);
- if ($inabs == 1) {
- # We've covered relative dirs; everything else is an absolute
- # dir (probably an installed location). First, we'll try
- # potential command names, to see whether we can avoid a long
- # MCR expression.
- foreach my $name (@snames) {
- push(@cand,$name) if $name =~ /^[\w\-\$]+$/;
- }
- $inabs++; # Should happen above in next $dir, but just in case...
- }
- foreach my $name (@snames){
- push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name)
- : $self->fixpath($name,0);
- }
- }
- foreach my $name (@cand) {
- print "Checking $name\n" if $trace >= 2;
- # If it looks like a potential command, try it without the MCR
- if ($name =~ /^[\w\-\$]+$/) {
- open(my $tcf, ">", "temp_mmvms.com")
- or die('unable to open temp file');
- print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
- print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n";
- close $tcf;
- $rslt = `\@temp_mmvms.com` ;
- unlink('temp_mmvms.com');
- if ($rslt =~ /VER_OK/) {
- print "Using PERL=$name\n" if $trace;
- return $name;
- }
- }
- next unless $vmsfile = $self->maybe_command($name);
- $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well
- print "Executing $vmsfile\n" if ($trace >= 2);
- open(my $tcf, '>', "temp_mmvms.com")
- or die('unable to open temp file');
- print $tcf "\$ set message/nofacil/nosever/noident/notext\n";
- print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n";
- close $tcf;
- $rslt = `\@temp_mmvms.com`;
- unlink('temp_mmvms.com');
- if ($rslt =~ /VER_OK/) {
- print "Using PERL=MCR $vmsfile\n" if $trace;
- return "MCR $vmsfile";
- }
- }
- print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
- 0; # false and not empty
-}
-
-=item maybe_command (override)
-
-Follows VMS naming conventions for executable files.
-If the name passed in doesn't exactly match an executable file,
-appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
-to check for DCL procedure. If this fails, checks directories in DCL$PATH
-and finally F<Sys$System:> for an executable file having the name specified,
-with or without the F<.Exe>-equivalent suffix.
-
-=cut
-
-sub maybe_command {
- my($self,$file) = @_;
- return $file if -x $file && ! -d _;
- my(@dirs) = ('');
- my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
-
- if ($file !~ m![/:>\]]!) {
- for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
- my $dir = $ENV{"DCL\$PATH;$i"};
- $dir .= ':' unless $dir =~ m%[\]:]$%;
- push(@dirs,$dir);
- }
- push(@dirs,'Sys$System:');
- foreach my $dir (@dirs) {
- my $sysfile = "$dir$file";
- foreach my $ext (@exts) {
- return $file if -x "$sysfile$ext" && ! -d _;
- }
- }
- }
- return 0;
-}
-
-
-=item pasthru (override)
-
-VMS has $(MMSQUALIFIERS) which is a listing of all the original command line
-options. This is used in every invocation of make in the VMS Makefile so
-PASTHRU should not be necessary. Using PASTHRU tends to blow commands past
-the 256 character limit.
-
-=cut
-
-sub pasthru {
- return "PASTHRU=\n";
-}
-
-
-=item pm_to_blib (override)
-
-VMS wants a dot in every file so we can't have one called 'pm_to_blib',
-it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when
-you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'.
-
-So in VMS its pm_to_blib.ts.
-
-=cut
-
-sub pm_to_blib {
- my $self = shift;
-
- my $make = $self->SUPER::pm_to_blib;
-
- $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m;
- $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts};
-
- $make = <<'MAKE' . $make;
-# Dummy target to match Unix target name; we use pm_to_blib.ts as
-# timestamp file to avoid repeated invocations under VMS
-pm_to_blib : pm_to_blib.ts
- $(NOECHO) $(NOOP)
-
-MAKE
-
- return $make;
-}
-
-
-=item perl_script (override)
-
-If name passed in doesn't specify a readable file, appends F<.com> or
-F<.pl> and tries again, since it's customary to have file types on all files
-under VMS.
-
-=cut
-
-sub perl_script {
- my($self,$file) = @_;
- return $file if -r $file && ! -d _;
- return "$file.com" if -r "$file.com";
- return "$file.pl" if -r "$file.pl";
- return '';
-}
-
-
-=item replace_manpage_separator
-
-Use as separator a character which is legal in a VMS-syntax file name.
-
-=cut
-
-sub replace_manpage_separator {
- my($self,$man) = @_;
- $man = unixify($man);
- $man =~ s#/+#__#g;
- $man;
-}
-
-=item init_DEST
-
-(override) Because of the difficulty concatenating VMS filepaths we
-must pre-expand the DEST* variables.
-
-=cut
-
-sub init_DEST {
- my $self = shift;
-
- $self->SUPER::init_DEST;
-
- # Expand DEST variables.
- foreach my $var ($self->installvars) {
- my $destvar = 'DESTINSTALL'.$var;
- $self->{$destvar} = $self->eliminate_macros($self->{$destvar});
- }
-}
-
-
-=item init_DIRFILESEP
-
-No seperator between a directory path and a filename on VMS.
-
-=cut
-
-sub init_DIRFILESEP {
- my($self) = shift;
-
- $self->{DIRFILESEP} = '';
- return 1;
-}
-
-
-=item init_main (override)
-
-
-=cut
-
-sub init_main {
- my($self) = shift;
-
- $self->SUPER::init_main;
-
- $self->{DEFINE} ||= '';
- if ($self->{DEFINE} ne '') {
- my(@terms) = split(/\s+/,$self->{DEFINE});
- my(@defs, at udefs);
- foreach my $def (@terms) {
- next unless $def;
- my $targ = \@defs;
- if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition
- $targ = \@udefs if $1 eq 'U';
- $def =~ s/='(.*)'$/=$1/; # then remove shell-protection ''
- $def =~ s/^'(.*)'$/$1/; # from entire term or argument
- }
- if ($def =~ /=/) {
- $def =~ s/"/""/g; # Protect existing " from DCL
- $def = qq["$def"]; # and quote to prevent parsing of =
- }
- push @$targ, $def;
- }
-
- $self->{DEFINE} = '';
- if (@defs) {
- $self->{DEFINE} = '/Define=(' . join(',', at defs) . ')';
- }
- if (@udefs) {
- $self->{DEFINE} .= '/Undef=(' . join(',', at udefs) . ')';
- }
- }
-}
-
-=item init_others (override)
-
-Provide VMS-specific forms of various utility commands, then hand
-off to the default MM_Unix method.
-
-DEV_NULL should probably be overriden with something.
-
-Also changes EQUALIZE_TIMESTAMP to set revision date of target file to
-one second later than source file, since MMK interprets precisely
-equal revision dates for a source and target file as a sign that the
-target needs to be updated.
-
-=cut
-
-sub init_others {
- my($self) = @_;
-
- $self->{NOOP} = 'Continue';
- $self->{NOECHO} ||= '@ ';
-
- $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS';
- $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE};
- $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS';
- $self->{MAKEFILE_OLD} ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old');
-#
-# If an extension is not specified, then MMS/MMK assumes an
-# an extension of .MMS. If there really is no extension,
-# then a trailing "." needs to be appended to specify a
-# a null extension.
-#
- $self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./;
- $self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./;
- $self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./;
- $self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./;
-
- $self->{MACROSTART} ||= '/Macro=(';
- $self->{MACROEND} ||= ')';
- $self->{USEMAKEFILE} ||= '/Descrip=';
-
- $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"';
-
- $self->{MOD_INSTALL} ||=
- $self->oneliner(<<'CODE', ['-MExtUtils::Install']);
-install([ from_to => {split(' ', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]);
-CODE
-
- $self->SUPER::init_others;
-
- $self->{SHELL} ||= 'Posix';
-
- $self->{UMASK_NULL} = '! ';
-
- # Redirection on VMS goes before the command, not after as on Unix.
- # $(DEV_NULL) is used once and its not worth going nuts over making
- # it work. However, Unix's DEV_NULL is quite wrong for VMS.
- $self->{DEV_NULL} = '';
-
- if ($self->{OBJECT} =~ /\s/) {
- $self->{OBJECT} =~ s/(\\)?\n+\s+/ /g;
- $self->{OBJECT} = $self->wraplist(
- map $self->fixpath($_,0), split /,?\s+/, $self->{OBJECT}
- );
- }
-
- $self->{LDFROM} = $self->wraplist(
- map $self->fixpath($_,0), split /,?\s+/, $self->{LDFROM}
- );
-}
-
-
-=item init_platform (override)
-
-Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION.
-
-MM_VMS_REVISION is for backwards compatibility before MM_VMS had a
-$VERSION.
-
-=cut
-
-sub init_platform {
- my($self) = shift;
-
- $self->{MM_VMS_REVISION} = $Revision;
- $self->{MM_VMS_VERSION} = $VERSION;
- $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS')
- if $self->{PERL_SRC};
-}
-
-
-=item platform_constants
-
-=cut
-
-sub platform_constants {
- my($self) = shift;
- my $make_frag = '';
-
- foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION))
- {
- next unless defined $self->{$macro};
- $make_frag .= "$macro = $self->{$macro}\n";
- }
-
- return $make_frag;
-}
-
-
-=item init_VERSION (override)
-
-Override the *DEFINE_VERSION macros with VMS semantics. Translate the
-MAKEMAKER filepath to VMS style.
-
-=cut
-
-sub init_VERSION {
- my $self = shift;
-
- $self->SUPER::init_VERSION;
-
- $self->{DEFINE_VERSION} = '"$(VERSION_MACRO)=""$(VERSION)"""';
- $self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""';
- $self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'});
-}
-
-
-=item constants (override)
-
-Fixes up numerous file and directory macros to insure VMS syntax
-regardless of input syntax. Also makes lists of files
-comma-separated.
-
-=cut
-
-sub constants {
- my($self) = @_;
-
- # Be kind about case for pollution
- for (@ARGV) { $_ = uc($_) if /POLLUTE/i; }
-
- # Cleanup paths for directories in MMS macros.
- foreach my $macro ( qw [
- INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB
- PERL_LIB PERL_ARCHLIB
- PERL_INC PERL_SRC ],
- (map { 'INSTALL'.$_ } $self->installvars)
- )
- {
- next unless defined $self->{$macro};
- next if $macro =~ /MAN/ && $self->{$macro} eq 'none';
- $self->{$macro} = $self->fixpath($self->{$macro},1);
- }
-
- # Cleanup paths for files in MMS macros.
- foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD
- MAKE_APERL_FILE MYEXTLIB] )
- {
- next unless defined $self->{$macro};
- $self->{$macro} = $self->fixpath($self->{$macro},0);
- }
-
- # Fixup files for MMS macros
- # XXX is this list complete?
- for my $macro (qw/
- FULLEXT VERSION_FROM OBJECT LDFROM
- / ) {
- next unless defined $self->{$macro};
- $self->{$macro} = $self->fixpath($self->{$macro},0);
- }
-
-
- for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) {
- # Where is the space coming from? --jhi
- next unless $self ne " " && defined $self->{$macro};
- my %tmp = ();
- for my $key (keys %{$self->{$macro}}) {
- $tmp{$self->fixpath($key,0)} =
- $self->fixpath($self->{$macro}{$key},0);
- }
- $self->{$macro} = \%tmp;
- }
-
- for my $macro (qw/ C O_FILES H /) {
- next unless defined $self->{$macro};
- my @tmp = ();
- for my $val (@{$self->{$macro}}) {
- push(@tmp,$self->fixpath($val,0));
- }
- $self->{$macro} = \@tmp;
- }
-
- # mms/k does not define a $(MAKE) macro.
- $self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)';
-
- return $self->SUPER::constants;
-}
-
-
-=item special_targets
-
-Clear the default .SUFFIXES and put in our own list.
-
-=cut
-
-sub special_targets {
- my $self = shift;
-
- my $make_frag .= <<'MAKE_FRAG';
-.SUFFIXES :
-.SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs
-
-MAKE_FRAG
-
- return $make_frag;
-}
-
-=item cflags (override)
-
-Bypass shell script and produce qualifiers for CC directly (but warn
-user if a shell script for this extension exists). Fold multiple
-/Defines into one, since some C compilers pay attention to only one
-instance of this qualifier on the command line.
-
-=cut
-
-sub cflags {
- my($self,$libperl) = @_;
- my($quals) = $self->{CCFLAGS} || $Config{'ccflags'};
- my($definestr,$undefstr,$flagoptstr) = ('','','');
- my($incstr) = '/Include=($(PERL_INC)';
- my($name,$sys, at m);
-
- ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ;
- print STDOUT "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}.
- " required to modify CC command for $self->{'BASEEXT'}\n"
- if ($Config{$name});
-
- if ($quals =~ / -[DIUOg]/) {
- while ($quals =~ / -([Og])(\d*)\b/) {
- my($type,$lvl) = ($1,$2);
- $quals =~ s/ -$type$lvl\b\s*//;
- if ($type eq 'g') { $flagoptstr = '/NoOptimize'; }
- else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); }
- }
- while ($quals =~ / -([DIU])(\S+)/) {
- my($type,$def) = ($1,$2);
- $quals =~ s/ -$type$def\s*//;
- $def =~ s/"/""/g;
- if ($type eq 'D') { $definestr .= qq["$def",]; }
- elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); }
- else { $undefstr .= qq["$def",]; }
- }
- }
- if (length $quals and $quals !~ m!/!) {
- warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n";
- $quals = '';
- }
- $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE};
- if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; }
- if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; }
- # Deal with $self->{DEFINE} here since some C compilers pay attention
- # to only one /Define clause on command line, so we have to
- # conflate the ones from $Config{'ccflags'} and $self->{DEFINE}
- # ($self->{DEFINE} has already been VMSified in constants() above)
- if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; }
- for my $type (qw(Def Undef)) {
- my(@terms);
- while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) {
- my $term = $1;
- $term =~ s:^\((.+)\)$:$1:;
- push @terms, $term;
- }
- if ($type eq 'Def') {
- push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ];
- }
- if (@terms) {
- $quals =~ s:/${type}i?n?e?=[^/]+::ig;
- $quals .= "/${type}ine=(" . join(',', at terms) . ')';
- }
- }
-
- $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb";
-
- # Likewise with $self->{INC} and /Include
- if ($self->{'INC'}) {
- my(@includes) = split(/\s+/,$self->{INC});
- foreach (@includes) {
- s/^-I//;
- $incstr .= ','.$self->fixpath($_,1);
- }
- }
- $quals .= "$incstr)";
-# $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g;
- $self->{CCFLAGS} = $quals;
-
- $self->{PERLTYPE} ||= '';
-
- $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'};
- if ($self->{OPTIMIZE} !~ m!/!) {
- if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' }
- elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) {
- $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : '');
- }
- else {
- warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE};
- $self->{OPTIMIZE} = '/Optimize';
- }
- }
-
- return $self->{CFLAGS} = qq{
-CCFLAGS = $self->{CCFLAGS}
-OPTIMIZE = $self->{OPTIMIZE}
-PERLTYPE = $self->{PERLTYPE}
-};
-}
-
-=item const_cccmd (override)
-
-Adds directives to point C preprocessor to the right place when
-handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC
-command line a bit differently than MM_Unix method.
-
-=cut
-
-sub const_cccmd {
- my($self,$libperl) = @_;
- my(@m);
-
- return $self->{CONST_CCCMD} if $self->{CONST_CCCMD};
- return '' unless $self->needs_linking();
- if ($Config{'vms_cc_type'} eq 'gcc') {
- push @m,'
-.FIRST
- ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]';
- }
- elsif ($Config{'vms_cc_type'} eq 'vaxc') {
- push @m,'
-.FIRST
- ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
- ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include';
- }
- else {
- push @m,'
-.FIRST
- ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ',
- ($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),'
- ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include';
- }
-
- push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n");
-
- $self->{CONST_CCCMD} = join('', at m);
-}
-
-
-=item tools_other (override)
-
-Throw in some dubious extra macros for Makefile args.
-
-Also keep around the old $(SAY) macro in case somebody's using it.
-
-=cut
-
-sub tools_other {
- my($self) = @_;
-
- # XXX Are these necessary? Does anyone override them? They're longer
- # than just typing the literal string.
- my $extra_tools = <<'EXTRA_TOOLS';
-
-# Just in case anyone is using the old macro.
-USEMACROS = $(MACROSTART)
-SAY = $(ECHO)
-
-EXTRA_TOOLS
-
- return $self->SUPER::tools_other . $extra_tools;
-}
-
-=item init_dist (override)
-
-VMSish defaults for some values.
-
- macro description default
-
- ZIPFLAGS flags to pass to ZIP -Vu
-
- COMPRESS compression command to gzip
- use for tarfiles
- SUFFIX suffix to put on -gz
- compressed files
-
- SHAR shar command to use vms_share
-
- DIST_DEFAULT default target to use to tardist
- create a distribution
-
- DISTVNAME Use VERSION_SYM instead of $(DISTNAME)-$(VERSION_SYM)
- VERSION for the name
-
-=cut
-
-sub init_dist {
- my($self) = @_;
- $self->{ZIPFLAGS} ||= '-Vu';
- $self->{COMPRESS} ||= 'gzip';
- $self->{SUFFIX} ||= '-gz';
- $self->{SHAR} ||= 'vms_share';
- $self->{DIST_DEFAULT} ||= 'zipdist';
-
- $self->SUPER::init_dist;
-
- $self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}"
- unless $self->{ARGS}{DISTVNAME};
-
- return;
-}
-
-=item c_o (override)
-
-Use VMS syntax on command line. In particular, $(DEFINE) and
-$(PERL_INC) have been pulled into $(CCCMD). Also use MM[SK] macros.
-
-=cut
-
-sub c_o {
- my($self) = @_;
- return '' unless $self->needs_linking();
- '
-.c$(OBJ_EXT) :
- $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
-
-.cpp$(OBJ_EXT) :
- $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp
-
-.cxx$(OBJ_EXT) :
- $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx
-
-';
-}
-
-=item xs_c (override)
-
-Use MM[SK] macros.
-
-=cut
-
-sub xs_c {
- my($self) = @_;
- return '' unless $self->needs_linking();
- '
-.xs.c :
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET)
-';
-}
-
-=item xs_o (override)
-
-Use MM[SK] macros, and VMS command line for C compiler.
-
-=cut
-
-sub xs_o { # many makes are too dumb to use xs_c then c_o
- my($self) = @_;
- return '' unless $self->needs_linking();
- '
-.xs$(OBJ_EXT) :
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).c
- $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c
-';
-}
-
-
-=item dlsyms (override)
-
-Create VMS linker options files specifying universal symbols for this
-extension's shareable image, and listing other shareable images or
-libraries to which it should be linked.
-
-=cut
-
-sub dlsyms {
- my($self,%attribs) = @_;
-
- return '' unless $self->needs_linking();
-
- my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
- my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
- my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
- my(@m);
-
- unless ($self->{SKIPHASH}{'dynamic'}) {
- push(@m,'
-dynamic :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
- $(NOECHO) $(NOOP)
-');
- }
-
- push(@m,'
-static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
- $(NOECHO) $(NOOP)
-') unless $self->{SKIPHASH}{'static'};
-
- push @m,'
-$(INST_ARCHAUTODIR)$(BASEEXT).opt : $(BASEEXT).opt
- $(CP) $(MMS$SOURCE) $(MMS$TARGET)
-
-$(BASEEXT).opt : Makefile.PL
- $(PERLRUN) -e "use ExtUtils::Mksymlists;" -
- ',qq[-e "Mksymlists('NAME' => '$self->{NAME}', 'DL_FUNCS' => ],
- neatvalue($funcs),q[, 'DL_VARS' => ],neatvalue($vars),
- q[, 'FUNCLIST' => ],neatvalue($funclist),qq[)"\n];
-
- push @m, ' $(PERL) -e "print ""$(INST_STATIC)/Include=';
- if ($self->{OBJECT} =~ /\bBASEEXT\b/ or
- $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) {
- push @m, ($Config{d_vms_case_sensitive_symbols}
- ? uc($self->{BASEEXT}) :'$(BASEEXT)');
- }
- else { # We don't have a "main" object file, so pull 'em all in
- # Upcase module names if linker is being case-sensitive
- my($upcase) = $Config{d_vms_case_sensitive_symbols};
- my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT});
- for (@omods) {
- s/\.[^.]*$//; # Trim off file type
- s[\$\(\w+_EXT\)][]; # even as a macro
- s/.*[:>\/\]]//; # Trim off dir spec
- $_ = uc if $upcase;
- };
-
- my(@lines);
- my $tmp = shift @omods;
- foreach my $elt (@omods) {
- $tmp .= ",$elt";
- if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; }
- }
- push @lines, $tmp;
- push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')';
- }
- push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n";
-
- if (length $self->{LDLOADLIBS}) {
- my($line) = '';
- foreach my $lib (split ' ', $self->{LDLOADLIBS}) {
- $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs
- if (length($line) + length($lib) > 160) {
- push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n";
- $line = $lib . '\n';
- }
- else { $line .= $lib . '\n'; }
- }
- push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line;
- }
-
- join('', at m);
-
-}
-
-=item dynamic_lib (override)
-
-Use VMS Link command.
-
-=cut
-
-sub dynamic_lib {
- my($self, %attribs) = @_;
- return '' unless $self->needs_linking(); #might be because of a subdir
-
- return '' unless $self->has_link_code();
-
- my($otherldflags) = $attribs{OTHERLDFLAGS} || "";
- my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
- my $shr = $Config{'dbgprefix'} . 'PerlShr';
- my(@m);
- push @m,"
-
-OTHERLDFLAGS = $otherldflags
-INST_DYNAMIC_DEP = $inst_dynamic_dep
-
-";
- push @m, '
-$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
- If F$TrnLNm("',$shr,'").eqs."" Then Define/NoLog/User ',"$shr Sys\$Share:$shr.$Config{'dlext'}",'
- Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,$(PERL_INC)perlshr_attr.opt/Option
-';
-
- join('', at m);
-}
-
-
-=item static_lib (override)
-
-Use VMS commands to manipulate object library.
-
-=cut
-
-sub static_lib {
- my($self) = @_;
- return '' unless $self->needs_linking();
-
- return '
-$(INST_STATIC) :
- $(NOECHO) $(NOOP)
-' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
-
- my(@m);
- push @m,'
-# Rely on suffix rule for update action
-$(OBJECT) : $(INST_ARCHAUTODIR)$(DFSEP).exists
-
-$(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
-';
- # If this extension has its own library (eg SDBM_File)
- # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
- push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB};
-
- push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n");
-
- # if there was a library to copy, then we can't use MMS$SOURCE_LIST,
- # 'cause it's a library and you can't stick them in other libraries.
- # In that case, we use $OBJECT instead and hope for the best
- if ($self->{MYEXTLIB}) {
- push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n");
- } else {
- push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n");
- }
-
- push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n";
- foreach my $lib (split ' ', $self->{EXTRALIBS}) {
- push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n");
- }
- join('', at m);
-}
-
-
-=item extra_clean_files
-
-Clean up some OS specific files. Plus the temp file used to shorten
-a lot of commands.
-
-=cut
-
-sub extra_clean_files {
- return qw(
- *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso
- .MM_Tmp
- );
-}
-
-
-=item zipfile_target
-
-=item tarfile_target
-
-=item shdist_target
-
-Syntax for invoking shar, tar and zip differs from that for Unix.
-
-=cut
-
-sub zipfile_target {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-$(DISTVNAME).zip : distdir
- $(PREOP)
- $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
- $(RM_RF) $(DISTVNAME)
- $(POSTOP)
-MAKE_FRAG
-}
-
-sub tarfile_target {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-$(DISTVNAME).tar$(SUFFIX) : distdir
- $(PREOP)
- $(TO_UNIX)
- $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
- $(RM_RF) $(DISTVNAME)
- $(COMPRESS) $(DISTVNAME).tar
- $(POSTOP)
-MAKE_FRAG
-}
-
-sub shdist_target {
- my($self) = shift;
-
- return <<'MAKE_FRAG';
-shdist : distdir
- $(PREOP)
- $(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share
- $(RM_RF) $(DISTVNAME)
- $(POSTOP)
-MAKE_FRAG
-}
-
-
-# --- Test and Installation Sections ---
-
-=item install (override)
-
-Work around DCL's 255 character limit several times,and use
-VMS-style command line quoting in a few cases.
-
-=cut
-
-sub install {
- my($self, %attribs) = @_;
- my(@m);
-
- push @m, q[
-install :: all pure_install doc_install
- $(NOECHO) $(NOOP)
-
-install_perl :: all pure_perl_install doc_perl_install
- $(NOECHO) $(NOOP)
-
-install_site :: all pure_site_install doc_site_install
- $(NOECHO) $(NOOP)
-
-pure_install :: pure_$(INSTALLDIRS)_install
- $(NOECHO) $(NOOP)
-
-doc_install :: doc_$(INSTALLDIRS)_install
- $(NOECHO) $(NOOP)
-
-pure__install : pure_site_install
- $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
-
-doc__install : doc_site_install
- $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
-
-# This hack brought to you by DCL's 255-character command line limit
-pure_perl_install ::
- $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
- $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLPRIVLIB) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLARCHLIB) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLBIN) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) " >>.MM_tmp
- $(NOECHO) $(MOD_INSTALL) <.MM_tmp
- $(NOECHO) $(RM_F) .MM_tmp
- $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
-
-# Likewise
-pure_site_install ::
- $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
- $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLSITELIB) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLSITEARCH) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLSITEBIN) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) " >>.MM_tmp
- $(NOECHO) $(MOD_INSTALL) <.MM_tmp
- $(NOECHO) $(RM_F) .MM_tmp
- $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
-
-pure_vendor_install ::
- $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read '.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').' '" >.MM_tmp
- $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write '.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').' '" >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_LIB) $(DESTINSTALLVENDORLIB) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_BIN) $(DESTINSTALLVENDORBIN) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_SCRIPT) $(DESTINSTALLSCRIPT) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) " >>.MM_tmp
- $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) " >>.MM_tmp
- $(NOECHO) $(MOD_INSTALL) <.MM_tmp
- $(NOECHO) $(RM_F) .MM_tmp
-
-# Ditto
-doc_perl_install ::
- $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
- $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
- $(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp
- $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
- $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
- $(NOECHO) $(RM_F) .MM_tmp
-
-# And again
-doc_site_install ::
- $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
- $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
- $(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp
- $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
- $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
- $(NOECHO) $(RM_F) .MM_tmp
-
-doc_vendor_install ::
- $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q["
- $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
- $(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp
- $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp
- $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[
- $(NOECHO) $(RM_F) .MM_tmp
-
-];
-
- push @m, q[
-uninstall :: uninstall_from_$(INSTALLDIRS)dirs
- $(NOECHO) $(NOOP)
-
-uninstall_from_perldirs ::
- $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[
- $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
- $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
- $(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience."
-
-uninstall_from_sitedirs ::
- $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[
- $(NOECHO) $(ECHO) "Uninstall is now deprecated and makes no actual changes."
- $(NOECHO) $(ECHO) "Please check the list above carefully for errors, and manually remove"
- $(NOECHO) $(ECHO) "the appropriate files. Sorry for the inconvenience."
-];
-
- join('', at m);
-}
-
-=item perldepend (override)
-
-Use VMS-style syntax for files; it's cheaper to just do it directly here
-than to have the MM_Unix method call C<catfile> repeatedly. Also, if
-we have to rebuild Config.pm, use MM[SK] to do it.
-
-=cut
-
-sub perldepend {
- my($self) = @_;
- my(@m);
-
- push @m, '
-$(OBJECT) : $(PERL_INC)EXTERN.h, $(PERL_INC)INTERN.h, $(PERL_INC)XSUB.h
-$(OBJECT) : $(PERL_INC)av.h, $(PERL_INC)cc_runtime.h, $(PERL_INC)config.h
-$(OBJECT) : $(PERL_INC)cop.h, $(PERL_INC)cv.h, $(PERL_INC)embed.h
-$(OBJECT) : $(PERL_INC)embedvar.h, $(PERL_INC)form.h
-$(OBJECT) : $(PERL_INC)gv.h, $(PERL_INC)handy.h, $(PERL_INC)hv.h
-$(OBJECT) : $(PERL_INC)intrpvar.h, $(PERL_INC)iperlsys.h, $(PERL_INC)keywords.h
-$(OBJECT) : $(PERL_INC)mg.h, $(PERL_INC)nostdio.h, $(PERL_INC)op.h
-$(OBJECT) : $(PERL_INC)opcode.h, $(PERL_INC)patchlevel.h
-$(OBJECT) : $(PERL_INC)perl.h, $(PERL_INC)perlio.h
-$(OBJECT) : $(PERL_INC)perlsdio.h, $(PERL_INC)perlvars.h
-$(OBJECT) : $(PERL_INC)perly.h, $(PERL_INC)pp.h, $(PERL_INC)pp_proto.h
-$(OBJECT) : $(PERL_INC)proto.h, $(PERL_INC)regcomp.h, $(PERL_INC)regexp.h
-$(OBJECT) : $(PERL_INC)regnodes.h, $(PERL_INC)scope.h, $(PERL_INC)sv.h
-$(OBJECT) : $(PERL_INC)thread.h, $(PERL_INC)util.h, $(PERL_INC)vmsish.h
-
-' if $self->{OBJECT};
-
- if ($self->{PERL_SRC}) {
- my(@macros);
- my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)';
- push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP';
- push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc';
- push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc';
- push(@macros,'SOCKET=1') if $Config{'d_has_sockets'};
- push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!;
- $mmsquals .= '$(USEMACROS)' . join(',', at macros) . '$(MACROEND)' if @macros;
- push(@m,q[
-# Check for unpropagated config.sh changes. Should never happen.
-# We do NOT just update config.h because that is not sufficient.
-# An out of date config.h is not fatal but complains loudly!
-$(PERL_INC)config.h : $(PERL_SRC)config.sh
- $(NOOP)
-
-$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
- $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl"
- olddef = F$Environment("Default")
- Set Default $(PERL_SRC)
- $(MMS)],$mmsquals,);
- if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
- my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0));
- $target =~ s/\Q$prefix/[/;
- push(@m," $target");
- }
- else { push(@m,' $(MMS$TARGET)'); }
- push(@m,q[
- Set Default 'olddef'
-]);
- }
-
- push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n")
- if %{$self->{XS}};
-
- join('', at m);
-}
-
-
-=item makeaperl (override)
-
-Undertake to build a new set of Perl images using VMS commands. Since
-VMS does dynamic loading, it's not necessary to statically link each
-extension into the Perl image, so this isn't the normal build path.
-Consequently, it hasn't really been tested, and may well be incomplete.
-
-=cut
-
-our %olbs; # needs to be localized
-
-sub makeaperl {
- my($self, %attribs) = @_;
- my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) =
- @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)};
- my(@m);
- push @m, "
-# --- MakeMaker makeaperl section ---
-MAP_TARGET = $target
-";
- return join '', @m if $self->{PARENT};
-
- my($dir) = join ":", @{$self->{DIR}};
-
- unless ($self->{MAKEAPERL}) {
- push @m, q{
-$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
- $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
- $(NOECHO) $(PERLRUNINST) \
- Makefile.PL DIR=}, $dir, q{ \
- FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
- MAKEAPERL=1 NORECURS=1 };
-
- push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{
-
-$(MAP_TARGET) :: $(MAKE_APERL_FILE)
- $(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
-};
- push @m, "\n";
-
- return join '', @m;
- }
-
-
- my($linkcmd, at optlibs, at staticpkgs,$extralist,$targdir,$libperldir,%libseen);
- local($_);
-
- # The front matter of the linkcommand...
- $linkcmd = join ' ', $Config{'ld'},
- grep($_, @Config{qw(large split ldflags ccdlflags)});
- $linkcmd =~ s/\s+/ /g;
-
- # Which *.olb files could we make use of...
- local(%olbs); # XXX can this be lexical?
- $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)";
- require File::Find;
- File::Find::find(sub {
- return unless m/\Q$self->{LIB_EXT}\E$/;
- return if m/^libperl/;
-
- if( exists $self->{INCLUDE_EXT} ){
- my $found = 0;
-
- (my $xx = $File::Find::name) =~ s,.*?/auto/,,;
- $xx =~ s,/?$_,,;
- $xx =~ s,/,::,g;
-
- # Throw away anything not explicitly marked for inclusion.
- # DynaLoader is implied.
- foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){
- if( $xx eq $incl ){
- $found++;
- last;
- }
- }
- return unless $found;
- }
- elsif( exists $self->{EXCLUDE_EXT} ){
- (my $xx = $File::Find::name) =~ s,.*?/auto/,,;
- $xx =~ s,/?$_,,;
- $xx =~ s,/,::,g;
-
- # Throw away anything explicitly marked for exclusion
- foreach my $excl (@{$self->{EXCLUDE_EXT}}){
- return if( $xx eq $excl );
- }
- }
-
- $olbs{$ENV{DEFAULT}} = $_;
- }, grep( -d $_, @{$searchdirs || []}));
-
- # We trust that what has been handed in as argument will be buildable
- $static = [] unless $static;
- @olbs{@{$static}} = (1) x @{$static};
-
- $extra = [] unless $extra && ref $extra eq 'ARRAY';
- # Sort the object libraries in inverse order of
- # filespec length to try to insure that dependent extensions
- # will appear before their parents, so the linker will
- # search the parent library to resolve references.
- # (e.g. Intuit::DWIM will precede Intuit, so unresolved
- # references from [.intuit.dwim]dwim.obj can be found
- # in [.intuit]intuit.olb).
- for (sort { length($a) <=> length($b) } keys %olbs) {
- next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/;
- my($dir) = $self->fixpath($_,1);
- my($extralibs) = $dir . "extralibs.ld";
- my($extopt) = $dir . $olbs{$_};
- $extopt =~ s/$self->{LIB_EXT}$/.opt/;
- push @optlibs, "$dir$olbs{$_}";
- # Get external libraries this extension will need
- if (-f $extralibs ) {
- my %seenthis;
- open my $list, "<", $extralibs or warn $!,next;
- while (<$list>) {
- chomp;
- # Include a library in the link only once, unless it's mentioned
- # multiple times within a single extension's options file, in which
- # case we assume the builder needed to search it again later in the
- # link.
- my $skip = exists($libseen{$_}) && !exists($seenthis{$_});
- $libseen{$_}++; $seenthis{$_}++;
- next if $skip;
- push @$extra,$_;
- }
- }
- # Get full name of extension for ExtUtils::Miniperl
- if (-f $extopt) {
- open my $opt, '<', $extopt or die $!;
- while (<$opt>) {
- next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/;
- my $pkg = $1;
- $pkg =~ s#__*#::#g;
- push @staticpkgs,$pkg;
- }
- }
- }
- # Place all of the external libraries after all of the Perl extension
- # libraries in the final link, in order to maximize the opportunity
- # for XS code from multiple extensions to resolve symbols against the
- # same external library while only including that library once.
- push @optlibs, @$extra;
-
- $target = "Perl$Config{'exe_ext'}" unless $target;
- my $shrtarget;
- ($shrtarget,$targdir) = fileparse($target);
- $shrtarget =~ s/^([^.]*)/$1Shr/;
- $shrtarget = $targdir . $shrtarget;
- $target = "Perlshr.$Config{'dlext'}" unless $target;
- $tmpdir = "[]" unless $tmpdir;
- $tmpdir = $self->fixpath($tmpdir,1);
- if (@optlibs) { $extralist = join(' ', at optlibs); }
- else { $extralist = ''; }
- # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr)
- # that's what we're building here).
- push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2];
- if ($libperl) {
- unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) {
- print STDOUT "Warning: $libperl not found\n";
- undef $libperl;
- }
- }
- unless ($libperl) {
- if (defined $self->{PERL_SRC}) {
- $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}");
- } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) {
- } else {
- print STDOUT "Warning: $libperl not found
- If you're going to build a static perl binary, make sure perl is installed
- otherwise ignore this warning\n";
- }
- }
- $libperldir = $self->fixpath((fileparse($libperl))[1],1);
-
- push @m, '
-# Fill in the target you want to produce if it\'s not perl
-MAP_TARGET = ',$self->fixpath($target,0),'
-MAP_SHRTARGET = ',$self->fixpath($shrtarget,0),"
-MAP_LINKCMD = $linkcmd
-MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : '',"
-MAP_EXTRA = $extralist
-MAP_LIBPERL = ",$self->fixpath($libperl,0),'
-';
-
-
- push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n";
- foreach (@optlibs) {
- push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n";
- }
- push @m,"\n${tmpdir}PerlShr.Opt :\n\t";
- push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n";
-
- push @m,'
-$(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",'
- $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",'
-$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",'
- $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
- $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say"
- $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
- $(NOECHO) $(ECHO) "To remove the intermediate files, say
- $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean"
-';
- push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n";
- push @m, "# More from the 255-char line length limit\n";
- foreach (@staticpkgs) {
- push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n];
- }
-
- push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir;
- $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET)
- $(NOECHO) $(RM_F) %sWritemain.tmp
-MAKE_FRAG
-
- push @m, q[
-# Still more from the 255-char line length limit
-doc_inst_perl :
- $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB)
- $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp
- $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp
- $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
- $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp
- $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[
- $(NOECHO) $(RM_F) .MM_tmp
-];
-
- push @m, "
-inst_perl : pure_inst_perl doc_inst_perl
- \$(NOECHO) \$(NOOP)
-
-pure_inst_perl : \$(MAP_TARGET)
- $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
- $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
-
-clean :: map_clean
- \$(NOECHO) \$(NOOP)
-
-map_clean :
- \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE)
- \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET)
-";
-
- join '', @m;
-}
-
-
-# --- Output postprocessing section ---
-
-=item maketext_filter (override)
-
-Insure that colons marking targets are preceded by space, in order
-to distinguish the target delimiter from a colon appearing as
-part of a filespec.
-
-=cut
-
-sub maketext_filter {
- my($self, $text) = @_;
-
- $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg;
- return $text;
-}
-
-=item prefixify (override)
-
-prefixifying on VMS is simple. Each should simply be:
-
- perl_root:[some.dir]
-
-which can just be converted to:
-
- volume:[your.prefix.some.dir]
-
-otherwise you get the default layout.
-
-In effect, your search prefix is ignored and $Config{vms_prefix} is
-used instead.
-
-=cut
-
-sub prefixify {
- my($self, $var, $sprefix, $rprefix, $default) = @_;
-
- # Translate $(PERLPREFIX) to a real path.
- $rprefix = $self->eliminate_macros($rprefix);
- $rprefix = vmspath($rprefix) if $rprefix;
- $sprefix = vmspath($sprefix) if $sprefix;
-
- $default = vmsify($default)
- unless $default =~ /\[.*\]/;
-
- (my $var_no_install = $var) =~ s/^install//;
- my $path = $self->{uc $var} ||
- $ExtUtils::MM_Unix::Config_Override{lc $var} ||
- $Config{lc $var} || $Config{lc $var_no_install};
-
- if( !$path ) {
- print STDERR " no Config found for $var.\n" if $Verbose >= 2;
- $path = $self->_prefixify_default($rprefix, $default);
- }
- elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) {
- # do nothing if there's no prefix or if its relative
- }
- elsif( $sprefix eq $rprefix ) {
- print STDERR " no new prefix.\n" if $Verbose >= 2;
- }
- else {
-
- print STDERR " prefixify $var => $path\n" if $Verbose >= 2;
- print STDERR " from $sprefix to $rprefix\n" if $Verbose >= 2;
-
- my($path_vol, $path_dirs) = $self->splitpath( $path );
- if( $path_vol eq $Config{vms_prefix}.':' ) {
- print STDERR " $Config{vms_prefix}: seen\n" if $Verbose >= 2;
-
- $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
- $path = $self->_catprefix($rprefix, $path_dirs);
- }
- else {
- $path = $self->_prefixify_default($rprefix, $default);
- }
- }
-
- print " now $path\n" if $Verbose >= 2;
- return $self->{uc $var} = $path;
-}
-
-
-sub _prefixify_default {
- my($self, $rprefix, $default) = @_;
-
- print STDERR " cannot prefix, using default.\n" if $Verbose >= 2;
-
- if( !$default ) {
- print STDERR "No default!\n" if $Verbose >= 1;
- return;
- }
- if( !$rprefix ) {
- print STDERR "No replacement prefix!\n" if $Verbose >= 1;
- return '';
- }
-
- return $self->_catprefix($rprefix, $default);
-}
-
-sub _catprefix {
- my($self, $rprefix, $default) = @_;
-
- my($rvol, $rdirs) = $self->splitpath($rprefix);
- if( $rvol ) {
- return $self->catpath($rvol,
- $self->catdir($rdirs, $default),
- ''
- )
- }
- else {
- return $self->catdir($rdirs, $default);
- }
-}
-
-
-=item cd
-
-=cut
-
-sub cd {
- my($self, $dir, @cmds) = @_;
-
- $dir = vmspath($dir);
-
- my $cmd = join "\n\t", map "$_", @cmds;
-
- # No leading tab makes it look right when embedded
- my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd;
-startdir = F$Environment("Default")
- Set Default %s
- %s
- Set Default 'startdir'
-MAKE_FRAG
-
- # No trailing newline makes this easier to embed
- chomp $make_frag;
-
- return $make_frag;
-}
-
-
-=item oneliner
-
-=cut
-
-sub oneliner {
- my($self, $cmd, $switches) = @_;
- $switches = [] unless defined $switches;
-
- # Strip leading and trailing newlines
- $cmd =~ s{^\n+}{};
- $cmd =~ s{\n+$}{};
-
- $cmd = $self->quote_literal($cmd);
- $cmd = $self->escape_newlines($cmd);
-
- # Switches must be quoted else they will be lowercased.
- $switches = join ' ', map { qq{"$_"} } @$switches;
-
- return qq{\$(ABSPERLRUN) $switches -e $cmd "--"};
-}
-
-
-=item B<echo>
-
-perl trips up on "<foo>" thinking it's an input redirect. So we use the
-native Write command instead. Besides, its faster.
-
-=cut
-
-sub echo {
- my($self, $text, $file, $appending) = @_;
- $appending ||= 0;
-
- my $opencmd = $appending ? 'Open/Append' : 'Open/Write';
-
- my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file ");
- push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_) }
- split /\n/, $text;
- push @cmds, '$(NOECHO) Close MMECHOFILE';
- return @cmds;
-}
-
-
-=item quote_literal
-
-=cut
-
-sub quote_literal {
- my($self, $text) = @_;
-
- # I believe this is all we should need.
- $text =~ s{"}{""}g;
-
- return qq{"$text"};
-}
-
-=item escape_newlines
-
-=cut
-
-sub escape_newlines {
- my($self, $text) = @_;
-
- $text =~ s{\n}{-\n}g;
-
- return $text;
-}
-
-=item max_exec_len
-
-256 characters.
-
-=cut
-
-sub max_exec_len {
- my $self = shift;
-
- return $self->{_MAX_EXEC_LEN} ||= 256;
-}
-
-=item init_linker
-
-=cut
-
-sub init_linker {
- my $self = shift;
- $self->{EXPORT_LIST} ||= '$(BASEEXT).opt';
-
- my $shr = $Config{dbgprefix} . 'PERLSHR';
- if ($self->{PERL_SRC}) {
- $self->{PERL_ARCHIVE} ||=
- $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}");
- }
- else {
- $self->{PERL_ARCHIVE} ||=
- $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}";
- }
-
- $self->{PERL_ARCHIVE_AFTER} ||= '';
-}
-
-
-=item catdir (override)
-
-=item catfile (override)
-
-Eliminate the macros in the output to the MMS/MMK file.
-
-(File::Spec::VMS used to do this for us, but it's being removed)
-
-=cut
-
-sub catdir {
- my $self = shift;
-
- # Process the macros on VMS MMS/MMK
- my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_;
-
- my $dir = $self->SUPER::catdir(@args);
-
- # Fix up the directory and force it to VMS format.
- $dir = $self->fixpath($dir, 1);
-
- return $dir;
-}
-
-sub catfile {
- my $self = shift;
-
- # Process the macros on VMS MMS/MMK
- my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_;
-
- my $file = $self->SUPER::catfile(@args);
-
- $file = vmsify($file);
-
- return $file
-}
-
-
-=item eliminate_macros
-
-Expands MM[KS]/Make macros in a text string, using the contents of
-identically named elements of C<%$self>, and returns the result
-as a file specification in Unix syntax.
-
-NOTE: This is the canonical version of the method. The version in
-File::Spec::VMS is deprecated.
-
-=cut
-
-sub eliminate_macros {
- my($self,$path) = @_;
- return '' unless $path;
- $self = {} unless ref $self;
-
- if ($path =~ /\s/) {
- return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path;
- }
-
- my($npath) = unixify($path);
- # sometimes unixify will return a string with an off-by-one trailing null
- $npath =~ s{\0$}{};
-
- my($complex) = 0;
- my($head,$macro,$tail);
-
- # perform m##g in scalar context so it acts as an iterator
- while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) {
- if (defined $self->{$2}) {
- ($head,$macro,$tail) = ($1,$2,$3);
- if (ref $self->{$macro}) {
- if (ref $self->{$macro} eq 'ARRAY') {
- $macro = join ' ', @{$self->{$macro}};
- }
- else {
- print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}),
- "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n";
- $macro = "\cB$macro\cB";
- $complex = 1;
- }
- }
- else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; }
- $npath = "$head$macro$tail";
- }
- }
- if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; }
- $npath;
-}
-
-=item fixpath
-
- my $path = $mm->fixpath($path);
- my $path = $mm->fixpath($path, $is_dir);
-
-Catchall routine to clean up problem MM[SK]/Make macros. Expands macros
-in any directory specification, in order to avoid juxtaposing two
-VMS-syntax directories when MM[SK] is run. Also expands expressions which
-are all macro, so that we can tell how long the expansion is, and avoid
-overrunning DCL's command buffer when MM[KS] is running.
-
-fixpath() checks to see whether the result matches the name of a
-directory in the current default directory and returns a directory or
-file specification accordingly. C<$is_dir> can be set to true to
-force fixpath() to consider the path to be a directory or false to force
-it to be a file.
-
-NOTE: This is the canonical version of the method. The version in
-File::Spec::VMS is deprecated.
-
-=cut
-
-sub fixpath {
- my($self,$path,$force_path) = @_;
- return '' unless $path;
- $self = bless {}, $self unless ref $self;
- my($fixedpath,$prefix,$name);
-
- if ($path =~ /[ \t]/) {
- return join ' ',
- map { $self->fixpath($_,$force_path) }
- split /[ \t]+/, $path;
- }
-
- if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) {
- if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) {
- $fixedpath = vmspath($self->eliminate_macros($path));
- }
- else {
- $fixedpath = vmsify($self->eliminate_macros($path));
- }
- }
- elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) {
- my($vmspre) = $self->eliminate_macros("\$($prefix)");
- # is it a dir or just a name?
- $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : '';
- $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
- $fixedpath = vmspath($fixedpath) if $force_path;
- }
- else {
- $fixedpath = $path;
- $fixedpath = vmspath($fixedpath) if $force_path;
- }
- # No hints, so we try to guess
- if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) {
- $fixedpath = vmspath($fixedpath) if -d $fixedpath;
- }
-
- # Trim off root dirname if it's had other dirs inserted in front of it.
- $fixedpath =~ s/\.000000([\]>])/$1/;
- # Special case for VMS absolute directory specs: these will have had device
- # prepended during trip through Unix syntax in eliminate_macros(), since
- # Unix syntax has no way to express "absolute from the top of this device's
- # directory tree".
- if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; }
-
- return $fixedpath;
-}
-
-
-=item os_flavor
-
-VMS is VMS.
-
-=cut
-
-sub os_flavor {
- return('VMS');
-}
-
-=back
-
-
-=head1 AUTHOR
-
-Original author Charles Bailey F<bailey at newman.upenn.edu>
-
-Maintained by Michael G Schwern F<schwern at pobox.com>
-
-See L<ExtUtils::MakeMaker> for patching and contact information.
-
-
-=cut
-
-1;
-
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_VOS.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_VOS.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_VOS.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,50 +0,0 @@
-package ExtUtils::MM_VOS;
-
-use strict;
-our $VERSION = '6.55_02';
-
-require ExtUtils::MM_Unix;
-our @ISA = qw(ExtUtils::MM_Unix);
-
-
-=head1 NAME
-
-ExtUtils::MM_VOS - VOS specific subclass of ExtUtils::MM_Unix
-
-=head1 SYNOPSIS
-
- Don't use this module directly.
- Use ExtUtils::MM and let it choose.
-
-=head1 DESCRIPTION
-
-This is a subclass of ExtUtils::MM_Unix which contains functionality for
-VOS.
-
-Unless otherwise stated it works just like ExtUtils::MM_Unix
-
-=head2 Overridden methods
-
-=head3 extra_clean_files
-
-Cleanup VOS core files
-
-=cut
-
-sub extra_clean_files {
- return qw(*.kp);
-}
-
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern at pobox.com> with code from ExtUtils::MM_Unix
-
-=head1 SEE ALSO
-
-L<ExtUtils::MakeMaker>
-
-=cut
-
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_Win32.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Win32.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Win32.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,584 +0,0 @@
-package ExtUtils::MM_Win32;
-
-use strict;
-
-
-=head1 NAME
-
-ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker
-
-=head1 SYNOPSIS
-
- use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed
-
-=head1 DESCRIPTION
-
-See ExtUtils::MM_Unix for a documentation of the methods provided
-there. This package overrides the implementation of these methods, not
-the semantics.
-
-=cut
-
-use ExtUtils::MakeMaker::Config;
-use File::Basename;
-use File::Spec;
-use ExtUtils::MakeMaker qw( neatvalue );
-
-require ExtUtils::MM_Any;
-require ExtUtils::MM_Unix;
-our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
-our $VERSION = '6.55_02';
-
-$ENV{EMXSHELL} = 'sh'; # to run `commands`
-
-my $BORLAND = $Config{'cc'} =~ /^bcc/i ? 1 : 0;
-my $GCC = $Config{'cc'} =~ /^gcc/i ? 1 : 0;
-
-
-=head2 Overridden methods
-
-=over 4
-
-=item B<dlsyms>
-
-=cut
-
-sub dlsyms {
- my($self,%attribs) = @_;
-
- my($funcs) = $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {};
- my($vars) = $attribs{DL_VARS} || $self->{DL_VARS} || [];
- my($funclist) = $attribs{FUNCLIST} || $self->{FUNCLIST} || [];
- my($imports) = $attribs{IMPORTS} || $self->{IMPORTS} || {};
- my(@m);
-
- if (not $self->{SKIPHASH}{'dynamic'}) {
- push(@m,"
-$self->{BASEEXT}.def: Makefile.PL
-",
- q! $(PERLRUN) -MExtUtils::Mksymlists \\
- -e "Mksymlists('NAME'=>\"!, $self->{NAME},
- q!\", 'DLBASE' => '!,$self->{DLBASE},
- # The above two lines quoted differently to work around
- # a bug in the 4DOS/4NT command line interpreter. The visible
- # result of the bug was files named q('extension_name',) *with the
- # single quotes and the comma* in the extension build directories.
- q!', 'DL_FUNCS' => !,neatvalue($funcs),
- q!, 'FUNCLIST' => !,neatvalue($funclist),
- q!, 'IMPORTS' => !,neatvalue($imports),
- q!, 'DL_VARS' => !, neatvalue($vars), q!);"
-!);
- }
- join('', at m);
-}
-
-=item replace_manpage_separator
-
-Changes the path separator with .
-
-=cut
-
-sub replace_manpage_separator {
- my($self,$man) = @_;
- $man =~ s,/+,.,g;
- $man;
-}
-
-
-=item B<maybe_command>
-
-Since Windows has nothing as simple as an executable bit, we check the
-file extension.
-
-The PATHEXT env variable will be used to get a list of extensions that
-might indicate a command, otherwise .com, .exe, .bat and .cmd will be
-used by default.
-
-=cut
-
-sub maybe_command {
- my($self,$file) = @_;
- my @e = exists($ENV{'PATHEXT'})
- ? split(/;/, $ENV{PATHEXT})
- : qw(.com .exe .bat .cmd);
- my $e = '';
- for (@e) { $e .= "\Q$_\E|" }
- chop $e;
- # see if file ends in one of the known extensions
- if ($file =~ /($e)$/i) {
- return $file if -e $file;
- }
- else {
- for (@e) {
- return "$file$_" if -e "$file$_";
- }
- }
- return;
-}
-
-
-=item B<init_DIRFILESEP>
-
-Using \ for Windows.
-
-=cut
-
-sub init_DIRFILESEP {
- my($self) = shift;
-
- # The ^ makes sure its not interpreted as an escape in nmake
- $self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' :
- $self->is_make_type('dmake') ? '\\\\'
- : '\\';
-}
-
-=item B<init_others>
-
-Override some of the Unix specific commands with portable
-ExtUtils::Command ones.
-
-Also provide defaults for LD and AR in case the %Config values aren't
-set.
-
-LDLOADLIBS's default is changed to $Config{libs}.
-
-Adjustments are made for Borland's quirks needing -L to come first.
-
-=cut
-
-sub init_others {
- my ($self) = @_;
-
- $self->{NOOP} ||= 'rem';
- $self->{DEV_NULL} ||= '> NUL';
-
- $self->{FIXIN} ||= $self->{PERL_CORE} ?
- "\$(PERLRUN) $self->{PERL_SRC}/win32/bin/pl2bat.pl" :
- 'pl2bat.bat';
-
- $self->{LD} ||= 'link';
- $self->{AR} ||= 'lib';
-
- $self->SUPER::init_others;
-
- # Setting SHELL from $Config{sh} can break dmake. Its ok without it.
- delete $self->{SHELL};
-
- $self->{LDLOADLIBS} ||= $Config{libs};
- # -Lfoo must come first for Borland, so we put it in LDDLFLAGS
- if ($BORLAND) {
- my $libs = $self->{LDLOADLIBS};
- my $libpath = '';
- while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) {
- $libpath .= ' ' if length $libpath;
- $libpath .= $1;
- }
- $self->{LDLOADLIBS} = $libs;
- $self->{LDDLFLAGS} ||= $Config{lddlflags};
- $self->{LDDLFLAGS} .= " $libpath";
- }
-
- return 1;
-}
-
-
-=item init_platform
-
-Add MM_Win32_VERSION.
-
-=item platform_constants
-
-=cut
-
-sub init_platform {
- my($self) = shift;
-
- $self->{MM_Win32_VERSION} = $VERSION;
-}
-
-sub platform_constants {
- my($self) = shift;
- my $make_frag = '';
-
- foreach my $macro (qw(MM_Win32_VERSION))
- {
- next unless defined $self->{$macro};
- $make_frag .= "$macro = $self->{$macro}\n";
- }
-
- return $make_frag;
-}
-
-
-=item special_targets
-
-Add .USESHELL target for dmake.
-
-=cut
-
-sub special_targets {
- my($self) = @_;
-
- my $make_frag = $self->SUPER::special_targets;
-
- $make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake');
-.USESHELL :
-MAKE_FRAG
-
- return $make_frag;
-}
-
-
-=item static_lib
-
-Changes how to run the linker.
-
-The rest is duplicate code from MM_Unix. Should move the linker code
-to its own method.
-
-=cut
-
-sub static_lib {
- my($self) = @_;
- return '' unless $self->has_link_code;
-
- my(@m);
- push(@m, <<'END');
-$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)$(DFSEP).exists
- $(RM_RF) $@
-END
-
- # If this extension has its own library (eg SDBM_File)
- # then copy that to $(INST_STATIC) and add $(OBJECT) into it.
- push @m, <<'MAKE_FRAG' if $self->{MYEXTLIB};
- $(CP) $(MYEXTLIB) $@
-MAKE_FRAG
-
- push @m,
-q{ $(AR) }.($BORLAND ? '$@ $(OBJECT:^"+")'
- : ($GCC ? '-ru $@ $(OBJECT)'
- : '-out:$@ $(OBJECT)')).q{
- $(CHMOD) $(PERM_RWX) $@
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)\extralibs.ld
-};
-
- # Old mechanism - still available:
- push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS};
- $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)\ext.libs
-MAKE_FRAG
-
- join('', @m);
-}
-
-
-=item dynamic_lib
-
-Complicated stuff for Win32 that I don't understand. :(
-
-=cut
-
-sub dynamic_lib {
- my($self, %attribs) = @_;
- return '' unless $self->needs_linking(); #might be because of a subdir
-
- return '' unless $self->has_link_code;
-
- my($otherldflags) = $attribs{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': '');
- my($inst_dynamic_dep) = $attribs{INST_DYNAMIC_DEP} || "";
- my($ldfrom) = '$(LDFROM)';
- my(@m);
-
-# one thing for GCC/Mingw32:
-# we try to overcome non-relocateable-DLL problems by generating
-# a (hopefully unique) image-base from the dll's name
-# -- BKS, 10-19-1999
- if ($GCC) {
- my $dllname = $self->{BASEEXT} . "." . $self->{DLEXT};
- $dllname =~ /(....)(.{0,4})/;
- my $baseaddr = unpack("n", $1 ^ $2);
- $otherldflags .= sprintf("-Wl,--image-base,0x%x0000 ", $baseaddr);
- }
-
- push(@m,'
-# This section creates the dynamically loadable $(INST_DYNAMIC)
-# from $(OBJECT) and possibly $(MYEXTLIB).
-OTHERLDFLAGS = '.$otherldflags.'
-INST_DYNAMIC_DEP = '.$inst_dynamic_dep.'
-
-$(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)$(DFSEP).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
-');
- if ($GCC) {
- push(@m,
- q{ dlltool --def $(EXPORT_LIST) --output-exp dll.exp
- $(LD) -o $@ -Wl,--base-file -Wl,dll.base $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp
- dlltool --def $(EXPORT_LIST) --base-file dll.base --output-exp dll.exp
- $(LD) -o $@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) dll.exp });
- } elsif ($BORLAND) {
- push(@m,
- q{ $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) }.$ldfrom.q{,$@,,}
- .($self->is_make_type('dmake')
- ? q{$(PERL_ARCHIVE:s,/,\,) $(LDLOADLIBS:s,/,\,) }
- .q{$(MYEXTLIB:s,/,\,),$(EXPORT_LIST:s,/,\,)}
- : q{$(subst /,\,$(PERL_ARCHIVE)) $(subst /,\,$(LDLOADLIBS)) }
- .q{$(subst /,\,$(MYEXTLIB)),$(subst /,\,$(EXPORT_LIST))})
- .q{,$(RESFILES)});
- } else { # VC
- push(@m,
- q{ $(LD) -out:$@ $(LDDLFLAGS) }.$ldfrom.q{ $(OTHERLDFLAGS) }
- .q{$(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) -def:$(EXPORT_LIST)});
-
- # Embed the manifest file if it exists
- push(@m, q{
- if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2
- if exist $@.manifest del $@.manifest});
- }
- push @m, '
- $(CHMOD) $(PERM_RWX) $@
-';
-
- join('', at m);
-}
-
-=item extra_clean_files
-
-Clean out some extra dll.{base,exp} files which might be generated by
-gcc. Otherwise, take out all *.pdb files.
-
-=cut
-
-sub extra_clean_files {
- my $self = shift;
-
- return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb');
-}
-
-=item init_linker
-
-=cut
-
-sub init_linker {
- my $self = shift;
-
- $self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}";
- $self->{PERL_ARCHIVE_AFTER} = '';
- $self->{EXPORT_LIST} = '$(BASEEXT).def';
-}
-
-
-=item perl_script
-
-Checks for the perl program under several common perl extensions.
-
-=cut
-
-sub perl_script {
- my($self,$file) = @_;
- return $file if -r $file && -f _;
- return "$file.pl" if -r "$file.pl" && -f _;
- return "$file.plx" if -r "$file.plx" && -f _;
- return "$file.bat" if -r "$file.bat" && -f _;
- return;
-}
-
-
-=item xs_o
-
-This target is stubbed out. Not sure why.
-
-=cut
-
-sub xs_o {
- return ''
-}
-
-
-=item pasthru
-
-All we send is -nologo to nmake to prevent it from printing its damned
-banner.
-
-=cut
-
-sub pasthru {
- my($self) = shift;
- return "PASTHRU = " . ($self->is_make_type('nmake') ? "-nologo" : "");
-}
-
-
-=item arch_check (override)
-
-Normalize all arguments for consistency of comparison.
-
-=cut
-
-sub arch_check {
- my $self = shift;
-
- # Win32 is an XS module, minperl won't have it.
- # arch_check() is not critical, so just fake it.
- return 1 unless $self->can_load_xs;
- return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_);
-}
-
-sub _normalize_path_name {
- my $self = shift;
- my $file = shift;
-
- require Win32;
- my $short = Win32::GetShortPathName($file);
- return defined $short ? lc $short : lc $file;
-}
-
-
-=item oneliner
-
-These are based on what command.com does on Win98. They may be wrong
-for other Windows shells, I don't know.
-
-=cut
-
-sub oneliner {
- my($self, $cmd, $switches) = @_;
- $switches = [] unless defined $switches;
-
- # Strip leading and trailing newlines
- $cmd =~ s{^\n+}{};
- $cmd =~ s{\n+$}{};
-
- $cmd = $self->quote_literal($cmd);
- $cmd = $self->escape_newlines($cmd);
-
- $switches = join ' ', @$switches;
-
- return qq{\$(ABSPERLRUN) $switches -e $cmd --};
-}
-
-
-sub quote_literal {
- my($self, $text) = @_;
-
- # I don't know if this is correct, but it seems to work on
- # Win98's command.com
- $text =~ s{"}{\\"}g;
-
- # dmake eats '{' inside double quotes and leaves alone { outside double
- # quotes; however it transforms {{ into { either inside and outside double
- # quotes. It also translates }} into }. The escaping below is not
- # 100% correct.
- if( $self->is_make_type('dmake') ) {
- $text =~ s/{/{{/g;
- $text =~ s/}}/}}}/g;
- }
-
- return qq{"$text"};
-}
-
-
-sub escape_newlines {
- my($self, $text) = @_;
-
- # Escape newlines
- $text =~ s{\n}{\\\n}g;
-
- return $text;
-}
-
-
-=item cd
-
-dmake can handle Unix style cd'ing but nmake (at least 1.5) cannot. It
-wants:
-
- cd dir1\dir2
- command
- another_command
- cd ..\..
-
-=cut
-
-sub cd {
- my($self, $dir, @cmds) = @_;
-
- return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('nmake');
-
- my $cmd = join "\n\t", map "$_", @cmds;
-
- my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir));
-
- # No leading tab and no trailing newline makes for easier embedding.
- my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs;
-cd %s
- %s
- cd %s
-MAKE_FRAG
-
- chomp $make_frag;
-
- return $make_frag;
-}
-
-
-=item max_exec_len
-
-nmake 1.50 limits command length to 2048 characters.
-
-=cut
-
-sub max_exec_len {
- my $self = shift;
-
- return $self->{_MAX_EXEC_LEN} ||= 2 * 1024;
-}
-
-
-=item os_flavor
-
-Windows is Win32.
-
-=cut
-
-sub os_flavor {
- return('Win32');
-}
-
-
-=item cflags
-
-Defines the PERLDLL symbol if we are configured for static building since all
-code destined for the perl5xx.dll must be compiled with the PERLDLL symbol
-defined.
-
-=cut
-
-sub cflags {
- my($self,$libperl)=@_;
- return $self->{CFLAGS} if $self->{CFLAGS};
- return '' unless $self->needs_linking();
-
- my $base = $self->SUPER::cflags($libperl);
- foreach (split /\n/, $base) {
- /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2;
- };
- $self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static');
-
- return $self->{CFLAGS} = qq{
-CCFLAGS = $self->{CCFLAGS}
-OPTIMIZE = $self->{OPTIMIZE}
-PERLTYPE = $self->{PERLTYPE}
-};
-
-}
-
-sub is_make_type {
- my($self, $type) = @_;
- return !! ($self->make =~ /\b$type(?:\.exe)?$/);
-}
-
-1;
-__END__
-
-=back
-
-=cut
-
-
Deleted: trunk/contrib/perl/lib/ExtUtils/MM_Win95.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MM_Win95.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MM_Win95.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,124 +0,0 @@
-package ExtUtils::MM_Win95;
-
-use strict;
-
-our $VERSION = '6.55_02';
-
-require ExtUtils::MM_Win32;
-our @ISA = qw(ExtUtils::MM_Win32);
-
-use ExtUtils::MakeMaker::Config;
-
-
-=head1 NAME
-
-ExtUtils::MM_Win95 - method to customize MakeMaker for Win9X
-
-=head1 SYNOPSIS
-
- You should not be using this module directly.
-
-=head1 DESCRIPTION
-
-This is a subclass of ExtUtils::MM_Win32 containing changes necessary
-to get MakeMaker playing nice with command.com and other Win9Xisms.
-
-=head2 Overridden methods
-
-Most of these make up for limitations in the Win9x/nmake command shell.
-Mostly its lack of &&.
-
-=over 4
-
-
-=item xs_c
-
-The && problem.
-
-=cut
-
-sub xs_c {
- my($self) = shift;
- return '' unless $self->needs_linking();
- '
-.xs.c:
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
- '
-}
-
-
-=item xs_cpp
-
-The && problem
-
-=cut
-
-sub xs_cpp {
- my($self) = shift;
- return '' unless $self->needs_linking();
- '
-.xs.cpp:
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.cpp
- ';
-}
-
-=item xs_o
-
-The && problem.
-
-=cut
-
-sub xs_o {
- my($self) = shift;
- return '' unless $self->needs_linking();
- '
-.xs$(OBJ_EXT):
- $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.c
- $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
- ';
-}
-
-
-=item max_exec_len
-
-Win98 chokes on things like Encode if we set the max length to nmake's max
-of 2K. So we go for a more conservative value of 1K.
-
-=cut
-
-sub max_exec_len {
- my $self = shift;
-
- return $self->{_MAX_EXEC_LEN} ||= 1024;
-}
-
-
-=item os_flavor
-
-Win95 and Win98 and WinME are collectively Win9x and Win32
-
-=cut
-
-sub os_flavor {
- my $self = shift;
- return ($self->SUPER::os_flavor, 'Win9x');
-}
-
-
-=back
-
-
-=head1 AUTHOR
-
-Code originally inside MM_Win32. Original author unknown.
-
-Currently maintained by Michael G Schwern C<schwern at pobox.com>.
-
-Send patches and ideas to C<makemaker at perl.org>.
-
-See http://www.makemaker.org.
-
-=cut
-
-
-1;
Deleted: trunk/contrib/perl/lib/ExtUtils/MY.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/MY.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/MY.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,40 +0,0 @@
-package ExtUtils::MY;
-
-use strict;
-require ExtUtils::MM;
-
-our $VERSION = 6.55_02;
-our @ISA = qw(ExtUtils::MM);
-
-{
- package MY;
- our @ISA = qw(ExtUtils::MY);
-}
-
-sub DESTROY {}
-
-
-=head1 NAME
-
-ExtUtils::MY - ExtUtils::MakeMaker subclass for customization
-
-=head1 SYNOPSIS
-
- # in your Makefile.PL
- sub MY::whatever {
- ...
- }
-
-=head1 DESCRIPTION
-
-B<FOR INTERNAL USE ONLY>
-
-ExtUtils::MY is a subclass of ExtUtils::MM. Its provided in your
-Makefile.PL for you to add and override MakeMaker functionality.
-
-It also provides a convenient alias via the MY class.
-
-ExtUtils::MY might turn out to be a temporary solution, but MY won't
-go away.
-
-=cut
Deleted: trunk/contrib/perl/lib/ExtUtils/Mkbootstrap.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Mkbootstrap.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/Mkbootstrap.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,109 +0,0 @@
-package ExtUtils::Mkbootstrap;
-
-# There's just too much Dynaloader incest here to turn on strict vars.
-use strict 'refs';
-
-our $VERSION = '6.55_02';
-
-require Exporter;
-our @ISA = ('Exporter');
-our @EXPORT = ('&Mkbootstrap');
-
-use Config;
-
-our $Verbose = 0;
-
-
-sub Mkbootstrap {
- my($baseext, @bsloadlibs)=@_;
- @bsloadlibs = grep($_, @bsloadlibs); # strip empty libs
-
- print STDOUT " bsloadlibs=@bsloadlibs\n" if $Verbose;
-
- # We need DynaLoader here because we and/or the *_BS file may
- # call dl_findfile(). We don't say `use' here because when
- # first building perl extensions the DynaLoader will not have
- # been built when MakeMaker gets first used.
- require DynaLoader;
-
- rename "$baseext.bs", "$baseext.bso"
- if -s "$baseext.bs";
-
- if (-f "${baseext}_BS"){
- $_ = "${baseext}_BS";
- package DynaLoader; # execute code as if in DynaLoader
- local($osname, $dlsrc) = (); # avoid warnings
- ($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)};
- $bscode = "";
- unshift @INC, ".";
- require $_;
- shift @INC;
- }
-
- if ($Config{'dlsrc'} =~ /^dl_dld/){
- package DynaLoader;
- push(@dl_resolve_using, dl_findfile('-lc'));
- }
-
- my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using);
- my($method) = '';
- if (@all){
- open my $bs, ">", "$baseext.bs"
- or die "Unable to open $baseext.bs: $!";
- print STDOUT "Writing $baseext.bs\n";
- print STDOUT " containing: @all" if $Verbose;
- print $bs "# $baseext DynaLoader bootstrap file for $^O architecture.\n";
- print $bs "# Do not edit this file, changes will be lost.\n";
- print $bs "# This file was automatically generated by the\n";
- print $bs "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n";
- print $bs "\@DynaLoader::dl_resolve_using = ";
- # If @all contains names in the form -lxxx or -Lxxx then it's asking for
- # runtime library location so we automatically add a call to dl_findfile()
- if (" @all" =~ m/ -[lLR]/){
- print $bs " dl_findfile(qw(\n @all\n ));\n";
- }else{
- print $bs " qw(@all);\n";
- }
- # write extra code if *_BS says so
- print $bs $DynaLoader::bscode if $DynaLoader::bscode;
- print $bs "\n1;\n";
- close $bs;
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
-
-=head1 SYNOPSIS
-
-C<Mkbootstrap>
-
-=head1 DESCRIPTION
-
-Mkbootstrap typically gets called from an extension Makefile.
-
-There is no C<*.bs> file supplied with the extension. Instead, there may
-be a C<*_BS> file which has code for the special cases, like posix for
-berkeley db on the NeXT.
-
-This file will get parsed, and produce a maybe empty
-C<@DynaLoader::dl_resolve_using> array for the current architecture.
-That will be extended by $BSLOADLIBS, which was computed by
-ExtUtils::Liblist::ext(). If this array still is empty, we do nothing,
-else we write a .bs file with an C<@DynaLoader::dl_resolve_using>
-array.
-
-The C<*_BS> file can put some code into the generated C<*.bs> file by
-placing it in C<$bscode>. This is a handy 'escape' mechanism that may
-prove useful in complex situations.
-
-If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then
-Mkbootstrap will automatically add a dl_findfile() call to the
-generated C<*.bs> file.
-
-=cut
Deleted: trunk/contrib/perl/lib/ExtUtils/Mksymlists.pm
===================================================================
--- trunk/contrib/perl/lib/ExtUtils/Mksymlists.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/ExtUtils/Mksymlists.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,312 +0,0 @@
-package ExtUtils::Mksymlists;
-
-use 5.006;
-use strict qw[ subs refs ];
-# no strict 'vars'; # until filehandles are exempted
-
-use Carp;
-use Exporter;
-use Config;
-
-our @ISA = qw(Exporter);
-our @EXPORT = qw(&Mksymlists);
-our $VERSION = '6.55_02';
-
-sub Mksymlists {
- my(%spec) = @_;
- my($osname) = $^O;
-
- croak("Insufficient information specified to Mksymlists")
- unless ( $spec{NAME} or
- ($spec{FILE} and ($spec{DL_FUNCS} or $spec{FUNCLIST})) );
-
- $spec{DL_VARS} = [] unless $spec{DL_VARS};
- ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE};
- $spec{FUNCLIST} = [] unless $spec{FUNCLIST};
- $spec{DL_FUNCS} = { $spec{NAME} => [] }
- unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or
- @{$spec{FUNCLIST}});
- if (defined $spec{DL_FUNCS}) {
- foreach my $package (keys %{$spec{DL_FUNCS}}) {
- my($packprefix,$bootseen);
- ($packprefix = $package) =~ s/\W/_/g;
- foreach my $sym (@{$spec{DL_FUNCS}->{$package}}) {
- if ($sym =~ /^boot_/) {
- push(@{$spec{FUNCLIST}},$sym);
- $bootseen++;
- }
- else {
- push(@{$spec{FUNCLIST}},"XS_${packprefix}_$sym");
- }
- }
- push(@{$spec{FUNCLIST}},"boot_$packprefix") unless $bootseen;
- }
- }
-
-# We'll need this if we ever add any OS which uses mod2fname
-# not as pseudo-builtin.
-# require DynaLoader;
- if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) {
- $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]);
- }
-
- if ($osname eq 'aix') { _write_aix(\%spec); }
- elsif ($osname eq 'MacOS'){ _write_aix(\%spec) }
- elsif ($osname eq 'VMS') { _write_vms(\%spec) }
- elsif ($osname eq 'os2') { _write_os2(\%spec) }
- elsif ($osname eq 'MSWin32') { _write_win32(\%spec) }
- else {
- croak("Don't know how to create linker option file for $osname\n");
- }
-}
-
-
-sub _write_aix {
- my($data) = @_;
-
- rename "$data->{FILE}.exp", "$data->{FILE}.exp_old";
-
- open( my $exp, ">", "$data->{FILE}.exp")
- or croak("Can't create $data->{FILE}.exp: $!\n");
- print $exp join("\n",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
- print $exp join("\n",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
- close $exp;
-}
-
-
-sub _write_os2 {
- my($data) = @_;
- require Config;
- my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : "");
-
- if (not $data->{DLBASE}) {
- ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
- $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
- }
- my $distname = $data->{DISTNAME} || $data->{NAME};
- $distname = "Distribution $distname";
- my $patchlevel = " pl$Config{perl_patchlevel}" || '';
- my $comment = sprintf "Perl (v%s%s%s) module %s",
- $Config::Config{version}, $threaded, $patchlevel, $data->{NAME};
- chomp $comment;
- if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') {
- $distname = 'perl5-porters at perl.org';
- $comment = "Core $comment";
- }
- $comment = "$comment (Perl-config: $Config{config_args})";
- $comment = substr($comment, 0, 200) . "...)" if length $comment > 203;
- rename "$data->{FILE}.def", "$data->{FILE}_def.old";
-
- open(my $def, ">", "$data->{FILE}.def")
- or croak("Can't create $data->{FILE}.def: $!\n");
- print $def "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n";
- print $def "DESCRIPTION '\@#$distname:$data->{VERSION}#\@ $comment'\n";
- print $def "CODE LOADONCALL\n";
- print $def "DATA LOADONCALL NONSHARED MULTIPLE\n";
- print $def "EXPORTS\n ";
- print $def join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}};
- print $def join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}};
- if (%{$data->{IMPORTS}}) {
- print $def "IMPORTS\n";
- my ($name, $exp);
- while (($name, $exp)= each %{$data->{IMPORTS}}) {
- print $def " $name=$exp\n";
- }
- }
- close $def;
-}
-
-sub _write_win32 {
- my($data) = @_;
-
- require Config;
- if (not $data->{DLBASE}) {
- ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://;
- $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_';
- }
- rename "$data->{FILE}.def", "$data->{FILE}_def.old";
-
- open( my $def, ">", "$data->{FILE}.def" )
- or croak("Can't create $data->{FILE}.def: $!\n");
- # put library name in quotes (it could be a keyword, like 'Alias')
- if ($Config::Config{'cc'} !~ /^gcc/i) {
- print $def "LIBRARY \"$data->{DLBASE}\"\n";
- }
- print $def "EXPORTS\n ";
- my @syms;
- # Export public symbols both with and without underscores to
- # ensure compatibility between DLLs from different compilers
- # NOTE: DynaLoader itself only uses the names without underscores,
- # so this is only to cover the case when the extension DLL may be
- # linked to directly from C. GSAR 97-07-10
- if ($Config::Config{'cc'} =~ /^bcc/i) {
- for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
- push @syms, "_$_", "$_ = _$_";
- }
- }
- else {
- for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}) {
- push @syms, "$_", "_$_ = $_";
- }
- }
- print $def join("\n ", at syms, "\n") if @syms;
- if (%{$data->{IMPORTS}}) {
- print $def "IMPORTS\n";
- my ($name, $exp);
- while (($name, $exp)= each %{$data->{IMPORTS}}) {
- print $def " $name=$exp\n";
- }
- }
- close $def;
-}
-
-
-sub _write_vms {
- my($data) = @_;
-
- require Config; # a reminder for once we do $^O
- require ExtUtils::XSSymSet;
-
- my($isvax) = $Config::Config{'archname'} =~ /VAX/i;
- my($set) = new ExtUtils::XSSymSet;
-
- rename "$data->{FILE}.opt", "$data->{FILE}.opt_old";
-
- open(my $opt,">", "$data->{FILE}.opt")
- or croak("Can't create $data->{FILE}.opt: $!\n");
-
- # Options file declaring universal symbols
- # Used when linking shareable image for dynamic extension,
- # or when linking PerlShr into which we've added this package
- # as a static extension
- # We don't do anything to preserve order, so we won't relax
- # the GSMATCH criteria for a dynamic extension
-
- print $opt "case_sensitive=yes\n"
- if $Config::Config{d_vms_case_sensitive_symbols};
-
- foreach my $sym (@{$data->{FUNCLIST}}) {
- my $safe = $set->addsym($sym);
- if ($isvax) { print $opt "UNIVERSAL=$safe\n" }
- else { print $opt "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; }
- }
-
- foreach my $sym (@{$data->{DL_VARS}}) {
- my $safe = $set->addsym($sym);
- print $opt "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
- if ($isvax) { print $opt "UNIVERSAL=$safe\n" }
- else { print $opt "SYMBOL_VECTOR=($safe=DATA)\n"; }
- }
-
- close $opt;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-ExtUtils::Mksymlists - write linker options files for dynamic extension
-
-=head1 SYNOPSIS
-
- use ExtUtils::Mksymlists;
- Mksymlists({ NAME => $name ,
- DL_VARS => [ $var1, $var2, $var3 ],
- DL_FUNCS => { $pkg1 => [ $func1, $func2 ],
- $pkg2 => [ $func3 ] });
-
-=head1 DESCRIPTION
-
-C<ExtUtils::Mksymlists> produces files used by the linker under some OSs
-during the creation of shared libraries for dynamic extensions. It is
-normally called from a MakeMaker-generated Makefile when the extension
-is built. The linker option file is generated by calling the function
-C<Mksymlists>, which is exported by default from C<ExtUtils::Mksymlists>.
-It takes one argument, a list of key-value pairs, in which the following
-keys are recognized:
-
-=over 4
-
-=item DLBASE
-
-This item specifies the name by which the linker knows the
-extension, which may be different from the name of the
-extension itself (for instance, some linkers add an '_' to the
-name of the extension). If it is not specified, it is derived
-from the NAME attribute. It is presently used only by OS2 and Win32.
-
-=item DL_FUNCS
-
-This is identical to the DL_FUNCS attribute available via MakeMaker,
-from which it is usually taken. Its value is a reference to an
-associative array, in which each key is the name of a package, and
-each value is an a reference to an array of function names which
-should be exported by the extension. For instance, one might say
-C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ],
-Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The
-function names should be identical to those in the XSUB code;
-C<Mksymlists> will alter the names written to the linker option
-file to match the changes made by F<xsubpp>. In addition, if
-none of the functions in a list begin with the string B<boot_>,
-C<Mksymlists> will add a bootstrap function for that package,
-just as xsubpp does. (If a B<boot_E<lt>pkgE<gt>> function is
-present in the list, it is passed through unchanged.) If
-DL_FUNCS is not specified, it defaults to the bootstrap
-function for the extension specified in NAME.
-
-=item DL_VARS
-
-This is identical to the DL_VARS attribute available via MakeMaker,
-and, like DL_FUNCS, it is usually specified via MakeMaker. Its
-value is a reference to an array of variable names which should
-be exported by the extension.
-
-=item FILE
-
-This key can be used to specify the name of the linker option file
-(minus the OS-specific extension), if for some reason you do not
-want to use the default value, which is the last word of the NAME
-attribute (I<e.g.> for C<Tk::Canvas>, FILE defaults to C<Canvas>).
-
-=item FUNCLIST
-
-This provides an alternate means to specify function names to be
-exported from the extension. Its value is a reference to an
-array of function names to be exported by the extension. These
-names are passed through unaltered to the linker options file.
-Specifying a value for the FUNCLIST attribute suppresses automatic
-generation of the bootstrap function for the package. To still create
-the bootstrap name you have to specify the package name in the
-DL_FUNCS hash:
-
- Mksymlists({ NAME => $name ,
- FUNCLIST => [ $func1, $func2 ],
- DL_FUNCS => { $pkg => [] } });
-
-
-=item IMPORTS
-
-This attribute is used to specify names to be imported into the
-extension. It is currently only used by OS/2 and Win32.
-
-=item NAME
-
-This gives the name of the extension (I<e.g.> C<Tk::Canvas>) for which
-the linker option file will be produced.
-
-=back
-
-When calling C<Mksymlists>, one should always specify the NAME
-attribute. In most cases, this is all that's necessary. In
-the case of unusual extensions, however, the other attributes
-can be used to provide additional information to the linker.
-
-=head1 AUTHOR
-
-Charles Bailey I<E<lt>bailey at newman.upenn.eduE<gt>>
-
-=head1 REVISION
-
-Last revised 14-Feb-1996, for Perl 5.002.
Deleted: trunk/contrib/perl/lib/Fatal.pm
===================================================================
--- trunk/contrib/perl/lib/Fatal.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Fatal.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1374 +0,0 @@
-package Fatal;
-
-use 5.008; # 5.8.x needed for autodie
-use Carp;
-use strict;
-use warnings;
-use Tie::RefHash; # To cache subroutine refs
-
-use constant PERL510 => ( $] >= 5.010 );
-
-use constant LEXICAL_TAG => q{:lexical};
-use constant VOID_TAG => q{:void};
-use constant INSIST_TAG => q{!};
-
-use constant ERROR_NOARGS => 'Cannot use lexical %s with no arguments';
-use constant ERROR_VOID_LEX => VOID_TAG.' cannot be used with lexical scope';
-use constant ERROR_LEX_FIRST => LEXICAL_TAG.' must be used as first argument';
-use constant ERROR_NO_LEX => "no %s can only start with ".LEXICAL_TAG;
-use constant ERROR_BADNAME => "Bad subroutine name for %s: %s";
-use constant ERROR_NOTSUB => "%s is not a Perl subroutine";
-use constant ERROR_NOT_BUILT => "%s is neither a builtin, nor a Perl subroutine";
-use constant ERROR_NOHINTS => "No user hints defined for %s";
-
-use constant ERROR_CANT_OVERRIDE => "Cannot make the non-overridable builtin %s fatal";
-
-use constant ERROR_NO_IPC_SYS_SIMPLE => "IPC::System::Simple required for Fatalised/autodying system()";
-
-use constant ERROR_IPC_SYS_SIMPLE_OLD => "IPC::System::Simple version %f required for Fatalised/autodying system(). We only have version %f";
-
-use constant ERROR_AUTODIE_CONFLICT => q{"no autodie '%s'" is not allowed while "use Fatal '%s'" is in effect};
-
-use constant ERROR_FATAL_CONFLICT => q{"use Fatal '%s'" is not allowed while "no autodie '%s'" is in effect};
-
-use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supported under Perl 5.8.x};
-
-# Older versions of IPC::System::Simple don't support all the
-# features we need.
-
-use constant MIN_IPC_SYS_SIMPLE_VER => 0.12;
-
-# All the Fatal/autodie modules share the same version number.
-our $VERSION = '2.06_01';
-
-our $Debug ||= 0;
-
-# EWOULDBLOCK values for systems that don't supply their own.
-# Even though this is defined with our, that's to help our
-# test code. Please don't rely upon this variable existing in
-# the future.
-
-our %_EWOULDBLOCK = (
- MSWin32 => 33,
-);
-
-# We have some tags that can be passed in for use with import.
-# These are all assumed to be CORE::
-
-my %TAGS = (
- ':io' => [qw(:dbm :file :filesys :ipc :socket
- read seek sysread syswrite sysseek )],
- ':dbm' => [qw(dbmopen dbmclose)],
- ':file' => [qw(open close flock sysopen fcntl fileno binmode
- ioctl truncate)],
- ':filesys' => [qw(opendir closedir chdir link unlink rename mkdir
- symlink rmdir readlink umask)],
- ':ipc' => [qw(:msg :semaphore :shm pipe)],
- ':msg' => [qw(msgctl msgget msgrcv msgsnd)],
- ':threads' => [qw(fork)],
- ':semaphore'=>[qw(semctl semget semop)],
- ':shm' => [qw(shmctl shmget shmread)],
- ':system' => [qw(system exec)],
-
- # Can we use qw(getpeername getsockname)? What do they do on failure?
- # TODO - Can socket return false?
- ':socket' => [qw(accept bind connect getsockopt listen recv send
- setsockopt shutdown socketpair)],
-
- # Our defaults don't include system(), because it depends upon
- # an optional module, and it breaks the exotic form.
- #
- # This *may* change in the future. I'd love IPC::System::Simple
- # to be a dependency rather than a recommendation, and hence for
- # system() to be autodying by default.
-
- ':default' => [qw(:io :threads)],
-
- # Version specific tags. These allow someone to specify
- # use autodie qw(:1.994) and know exactly what they'll get.
-
- ':1.994' => [qw(:default)],
- ':1.995' => [qw(:default)],
- ':1.996' => [qw(:default)],
- ':1.997' => [qw(:default)],
- ':1.998' => [qw(:default)],
- ':1.999' => [qw(:default)],
- ':1.999_01' => [qw(:default)],
- ':2.00' => [qw(:default)],
- ':2.01' => [qw(:default)],
- ':2.02' => [qw(:default)],
- ':2.03' => [qw(:default)],
- ':2.04' => [qw(:default)],
- ':2.05' => [qw(:default)],
- ':2.06' => [qw(:default)],
- ':2.06_01' => [qw(:default)],
-);
-
-$TAGS{':all'} = [ keys %TAGS ];
-
-# This hash contains subroutines for which we should
-# subroutine() // die() rather than subroutine() || die()
-
-my %Use_defined_or;
-
-# CORE::open returns undef on failure. It can legitimately return
-# 0 on success, eg: open(my $fh, '-|') || exec(...);
-
- at Use_defined_or{qw(
- CORE::fork
- CORE::recv
- CORE::send
- CORE::open
- CORE::fileno
- CORE::read
- CORE::readlink
- CORE::sysread
- CORE::syswrite
- CORE::sysseek
- CORE::umask
-)} = ();
-
-# Cached_fatalised_sub caches the various versions of our
-# fatalised subs as they're produced. This means we don't
-# have to build our own replacement of CORE::open and friends
-# for every single package that wants to use them.
-
-my %Cached_fatalised_sub = ();
-
-# Every time we're called with package scope, we record the subroutine
-# (including package or CORE::) in %Package_Fatal. This allows us
-# to detect illegal combinations of autodie and Fatal, and makes sure
-# we don't accidently make a Fatal function autodying (which isn't
-# very useful).
-
-my %Package_Fatal = ();
-
-# The first time we're called with a user-sub, we cache it here.
-# In the case of a "no autodie ..." we put back the cached copy.
-
-my %Original_user_sub = ();
-
-# Is_fatalised_sub simply records a big map of fatalised subroutine
-# refs. It means we can avoid repeating work, or fatalising something
-# we've already processed.
-
-my %Is_fatalised_sub = ();
-tie %Is_fatalised_sub, 'Tie::RefHash';
-
-# We use our package in a few hash-keys. Having it in a scalar is
-# convenient. The "guard $PACKAGE" string is used as a key when
-# setting up lexical guards.
-
-my $PACKAGE = __PACKAGE__;
-my $PACKAGE_GUARD = "guard $PACKAGE";
-my $NO_PACKAGE = "no $PACKAGE"; # Used to detect 'no autodie'
-
-# Here's where all the magic happens when someone write 'use Fatal'
-# or 'use autodie'.
-
-sub import {
- my $class = shift(@_);
- my $void = 0;
- my $lexical = 0;
- my $insist_hints = 0;
-
- my ($pkg, $filename) = caller();
-
- @_ or return; # 'use Fatal' is a no-op.
-
- # If we see the :lexical flag, then _all_ arguments are
- # changed lexically
-
- if ($_[0] eq LEXICAL_TAG) {
- $lexical = 1;
- shift @_;
-
- # If we see no arguments and :lexical, we assume they
- # wanted ':default'.
-
- if (@_ == 0) {
- push(@_, ':default');
- }
-
- # Don't allow :lexical with :void, it's needlessly confusing.
- if ( grep { $_ eq VOID_TAG } @_ ) {
- croak(ERROR_VOID_LEX);
- }
- }
-
- if ( grep { $_ eq LEXICAL_TAG } @_ ) {
- # If we see the lexical tag as the non-first argument, complain.
- croak(ERROR_LEX_FIRST);
- }
-
- my @fatalise_these = @_;
-
- # Thiese subs will get unloaded at the end of lexical scope.
- my %unload_later;
-
- # This hash helps us track if we've alredy done work.
- my %done_this;
-
- # NB: we're using while/shift rather than foreach, since
- # we'll be modifying the array as we walk through it.
-
- while (my $func = shift @fatalise_these) {
-
- if ($func eq VOID_TAG) {
-
- # When we see :void, set the void flag.
- $void = 1;
-
- } elsif ($func eq INSIST_TAG) {
-
- $insist_hints = 1;
-
- } elsif (exists $TAGS{$func}) {
-
- # When it's a tag, expand it.
- push(@fatalise_these, @{ $TAGS{$func} });
-
- } else {
-
- # Otherwise, fatalise it.
-
- # Check to see if there's an insist flag at the front.
- # If so, remove it, and insist we have hints for this sub.
- my $insist_this;
-
- if ($func =~ s/^!//) {
- $insist_this = 1;
- }
-
- # TODO: Even if we've already fatalised, we should
- # check we've done it with hints (if $insist_hints).
-
- # If we've already made something fatal this call,
- # then don't do it twice.
-
- next if $done_this{$func};
-
- # We're going to make a subroutine fatalistic.
- # However if we're being invoked with 'use Fatal qw(x)'
- # and we've already been called with 'no autodie qw(x)'
- # in the same scope, we consider this to be an error.
- # Mixing Fatal and autodie effects was considered to be
- # needlessly confusing on p5p.
-
- my $sub = $func;
- $sub = "${pkg}::$sub" unless $sub =~ /::/;
-
- # If we're being called as Fatal, and we've previously
- # had a 'no X' in scope for the subroutine, then complain
- # bitterly.
-
- if (! $lexical and $^H{$NO_PACKAGE}{$sub}) {
- croak(sprintf(ERROR_FATAL_CONFLICT, $func, $func));
- }
-
- # We're not being used in a confusing way, so make
- # the sub fatal. Note that _make_fatal returns the
- # old (original) version of the sub, or undef for
- # built-ins.
-
- my $sub_ref = $class->_make_fatal(
- $func, $pkg, $void, $lexical, $filename,
- ( $insist_this || $insist_hints )
- );
-
- $done_this{$func}++;
-
- $Original_user_sub{$sub} ||= $sub_ref;
-
- # If we're making lexical changes, we need to arrange
- # for them to be cleaned at the end of our scope, so
- # record them here.
-
- $unload_later{$func} = $sub_ref if $lexical;
- }
- }
-
- if ($lexical) {
-
- # Dark magic to have autodie work under 5.8
- # Copied from namespace::clean, that copied it from
- # autobox, that found it on an ancient scroll written
- # in blood.
-
- # This magic bit causes %^H to be lexically scoped.
-
- $^H |= 0x020000;
-
- # Our package guard gets invoked when we leave our lexical
- # scope.
-
- push(@ { $^H{$PACKAGE_GUARD} }, autodie::Scope::Guard->new(sub {
- $class->_install_subs($pkg, \%unload_later);
- }));
-
- }
-
- return;
-
-}
-
-# The code here is originally lifted from namespace::clean,
-# by Robert "phaylon" Sedlacek.
-#
-# It's been redesigned after feedback from ikegami on perlmonks.
-# See http://perlmonks.org/?node_id=693338 . Ikegami rocks.
-#
-# Given a package, and hash of (subname => subref) pairs,
-# we install the given subroutines into the package. If
-# a subref is undef, the subroutine is removed. Otherwise
-# it replaces any existing subs which were already there.
-
-sub _install_subs {
- my ($class, $pkg, $subs_to_reinstate) = @_;
-
- my $pkg_sym = "${pkg}::";
-
- while(my ($sub_name, $sub_ref) = each %$subs_to_reinstate) {
-
- my $full_path = $pkg_sym.$sub_name;
-
- # Copy symbols across to temp area.
-
- no strict 'refs'; ## no critic
-
- local *__tmp = *{ $full_path };
-
- # Nuke the old glob.
- { no strict; delete $pkg_sym->{$sub_name}; } ## no critic
-
- # Copy innocent bystanders back. Note that we lose
- # formats; it seems that Perl versions up to 5.10.0
- # have a bug which causes copying formats to end up in
- # the scalar slot. Thanks to Ben Morrow for spotting this.
-
- foreach my $slot (qw( SCALAR ARRAY HASH IO ) ) {
- next unless defined *__tmp{ $slot };
- *{ $full_path } = *__tmp{ $slot };
- }
-
- # Put back the old sub (if there was one).
-
- if ($sub_ref) {
-
- no strict; ## no critic
- *{ $pkg_sym . $sub_name } = $sub_ref;
- }
- }
-
- return;
-}
-
-sub unimport {
- my $class = shift;
-
- # Calling "no Fatal" must start with ":lexical"
- if ($_[0] ne LEXICAL_TAG) {
- croak(sprintf(ERROR_NO_LEX,$class));
- }
-
- shift @_; # Remove :lexical
-
- my $pkg = (caller)[0];
-
- # If we've been called with arguments, then the developer
- # has explicitly stated 'no autodie qw(blah)',
- # in which case, we disable Fatalistic behaviour for 'blah'.
-
- my @unimport_these = @_ ? @_ : ':all';
-
- while (my $symbol = shift @unimport_these) {
-
- if ($symbol =~ /^:/) {
-
- # Looks like a tag! Expand it!
- push(@unimport_these, @{ $TAGS{$symbol} });
-
- next;
- }
-
- my $sub = $symbol;
- $sub = "${pkg}::$sub" unless $sub =~ /::/;
-
- # If 'blah' was already enabled with Fatal (which has package
- # scope) then, this is considered an error.
-
- if (exists $Package_Fatal{$sub}) {
- croak(sprintf(ERROR_AUTODIE_CONFLICT,$symbol,$symbol));
- }
-
- # Record 'no autodie qw($sub)' as being in effect.
- # This is to catch conflicting semantics elsewhere
- # (eg, mixing Fatal with no autodie)
-
- $^H{$NO_PACKAGE}{$sub} = 1;
-
- if (my $original_sub = $Original_user_sub{$sub}) {
- # Hey, we've got an original one of these, put it back.
- $class->_install_subs($pkg, { $symbol => $original_sub });
- next;
- }
-
- # We don't have an original copy of the sub, on the assumption
- # it's core (or doesn't exist), we'll just nuke it.
-
- $class->_install_subs($pkg,{ $symbol => undef });
-
- }
-
- return;
-
-}
-
-# TODO - This is rather terribly inefficient right now.
-
-# NB: Perl::Critic's dump-autodie-tag-contents depends upon this
-# continuing to work.
-
-{
- my %tag_cache;
-
- sub _expand_tag {
- my ($class, $tag) = @_;
-
- if (my $cached = $tag_cache{$tag}) {
- return $cached;
- }
-
- if (not exists $TAGS{$tag}) {
- croak "Invalid exception class $tag";
- }
-
- my @to_process = @{$TAGS{$tag}};
-
- my @taglist = ();
-
- while (my $item = shift @to_process) {
- if ($item =~ /^:/) {
- push(@to_process, @{$TAGS{$item}} );
- } else {
- push(@taglist, "CORE::$item");
- }
- }
-
- $tag_cache{$tag} = \@taglist;
-
- return \@taglist;
-
- }
-
-}
-
-# This code is from the original Fatal. It scares me.
-# It is 100% compatible with the 5.10.0 Fatal module, right down
-# to the scary 'XXXX' comment. ;)
-
-sub fill_protos {
- my $proto = shift;
- my ($n, $isref, @out, @out1, $seen_semi) = -1;
- while ($proto =~ /\S/) {
- $n++;
- push(@out1,[$n, at out]) if $seen_semi;
- push(@out, $1 . "{\$_[$n]}"), next if $proto =~ s/^\s*\\([\@%\$\&])//;
- push(@out, "\$_[$n]"), next if $proto =~ s/^\s*([_*\$&])//;
- push(@out, "\@_[$n..\$#_]"), last if $proto =~ s/^\s*(;\s*)?\@//;
- $seen_semi = 1, $n--, next if $proto =~ s/^\s*;//; # XXXX ????
- die "Internal error: Unknown prototype letters: \"$proto\"";
- }
- push(@out1,[$n+1, at out]);
- return @out1;
-}
-
-# This is a backwards compatible version of _write_invocation. It's
-# recommended you don't use it.
-
-sub write_invocation {
- my ($core, $call, $name, $void, @args) = @_;
-
- return Fatal->_write_invocation(
- $core, $call, $name, $void,
- 0, # Lexical flag
- undef, # Sub, unused in legacy mode
- undef, # Subref, unused in legacy mode.
- @args
- );
-}
-
-# This version of _write_invocation is used internally. It's not
-# recommended you call it from external code, as the interface WILL
-# change in the future.
-
-sub _write_invocation {
-
- my ($class, $core, $call, $name, $void, $lexical, $sub, $sref, @argvs) = @_;
-
- if (@argvs == 1) { # No optional arguments
-
- my @argv = @{$argvs[0]};
- shift @argv;
-
- return $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
-
- } else {
- my $else = "\t";
- my (@out, @argv, $n);
- while (@argvs) {
- @argv = @{shift @argvs};
- $n = shift @argv;
-
- push @out, "${else}if (\@_ == $n) {\n";
- $else = "\t} els";
-
- push @out, $class->_one_invocation($core,$call,$name,$void,$sub,! $lexical, $sref, @argv);
- }
- push @out, qq[
- }
- die "Internal error: $name(\@_): Do not expect to get ", scalar(\@_), " arguments";
- ];
-
- return join '', @out;
- }
-}
-
-
-# This is a slim interface to ensure backward compatibility with
-# anyone doing very foolish things with old versions of Fatal.
-
-sub one_invocation {
- my ($core, $call, $name, $void, @argv) = @_;
-
- return Fatal->_one_invocation(
- $core, $call, $name, $void,
- undef, # Sub. Unused in back-compat mode.
- 1, # Back-compat flag
- undef, # Subref, unused in back-compat mode.
- @argv
- );
-
-}
-
-# This is the internal interface that generates code.
-# NOTE: This interface WILL change in the future. Please do not
-# call this subroutine directly.
-
-# TODO: Whatever's calling this code has already looked up hints. Pass
-# them in, rather than look them up a second time.
-
-sub _one_invocation {
- my ($class, $core, $call, $name, $void, $sub, $back_compat, $sref, @argv) = @_;
-
-
- # If someone is calling us directly (a child class perhaps?) then
- # they could try to mix void without enabling backwards
- # compatibility. We just don't support this at all, so we gripe
- # about it rather than doing something unwise.
-
- if ($void and not $back_compat) {
- Carp::confess("Internal error: :void mode not supported with $class");
- }
-
- # @argv only contains the results of the in-built prototype
- # function, and is therefore safe to interpolate in the
- # code generators below.
-
- # TODO - The following clobbers context, but that's what the
- # old Fatal did. Do we care?
-
- if ($back_compat) {
-
- # Use Fatal qw(system) will never be supported. It generated
- # a compile-time error with legacy Fatal, and there's no reason
- # to support it when autodie does a better job.
-
- if ($call eq 'CORE::system') {
- return q{
- croak("UNIMPLEMENTED: use Fatal qw(system) not supported.");
- };
- }
-
- local $" = ', ';
-
- if ($void) {
- return qq/return (defined wantarray)?$call(@argv):
- $call(@argv) || croak "Can't $name(\@_)/ .
- ($core ? ': $!' : ', \$! is \"$!\"') . '"'
- } else {
- return qq{return $call(@argv) || croak "Can't $name(\@_)} .
- ($core ? ': $!' : ', \$! is \"$!\"') . '"';
- }
- }
-
- # The name of our original function is:
- # $call if the function is CORE
- # $sub if our function is non-CORE
-
- # The reason for this is that $call is what we're actualling
- # calling. For our core functions, this is always
- # CORE::something. However for user-defined subs, we're about to
- # replace whatever it is that we're calling; as such, we actually
- # calling a subroutine ref.
-
- my $human_sub_name = $core ? $call : $sub;
-
- # Should we be testing to see if our result is defined, or
- # just true?
-
- my $use_defined_or;
-
- my $hints; # All user-sub hints, including list hints.
-
- if ( $core ) {
-
- # Core hints are built into autodie.
-
- $use_defined_or = exists ( $Use_defined_or{$call} );
-
- }
- else {
-
- # User sub hints are looked up using autodie::hints,
- # since users may wish to add their own hints.
-
- require autodie::hints;
-
- $hints = autodie::hints->get_hints_for( $sref );
-
- # We'll look up the sub's fullname. This means we
- # get better reports of where it came from in our
- # error messages, rather than what imported it.
-
- $human_sub_name = autodie::hints->sub_fullname( $sref );
-
- }
-
- # Checks for special core subs.
-
- if ($call eq 'CORE::system') {
-
- # Leverage IPC::System::Simple if we're making an autodying
- # system.
-
- local $" = ", ";
-
- # We need to stash $@ into $E, rather than using
- # local $@ for the whole sub. If we don't then
- # any exceptions from internal errors in autodie/Fatal
- # will mysteriously disappear before propogating
- # upwards.
-
- return qq{
- my \$retval;
- my \$E;
-
-
- {
- local \$@;
-
- eval {
- \$retval = IPC::System::Simple::system(@argv);
- };
-
- \$E = \$@;
- }
-
- if (\$E) {
-
- # TODO - This can't be overridden in child
- # classes!
-
- die autodie::exception::system->new(
- function => q{CORE::system}, args => [ @argv ],
- message => "\$E", errno => \$!,
- );
- }
-
- return \$retval;
- };
-
- }
-
- local $" = ', ';
-
- # If we're going to throw an exception, here's the code to use.
- my $die = qq{
- die $class->throw(
- function => q{$human_sub_name}, args => [ @argv ],
- pragma => q{$class}, errno => \$!,
- context => \$context, return => \$retval,
- eval_error => \$@
- )
- };
-
- if ($call eq 'CORE::flock') {
-
- # flock needs special treatment. When it fails with
- # LOCK_UN and EWOULDBLOCK, then it's not really fatal, it just
- # means we couldn't get the lock right now.
-
- require POSIX; # For POSIX::EWOULDBLOCK
-
- local $@; # Don't blat anyone else's $@.
-
- # Ensure that our vendor supports EWOULDBLOCK. If they
- # don't (eg, Windows), then we use known values for its
- # equivalent on other systems.
-
- my $EWOULDBLOCK = eval { POSIX::EWOULDBLOCK(); }
- || $_EWOULDBLOCK{$^O}
- || _autocroak("Internal error - can't overload flock - EWOULDBLOCK not defined on this system.");
-
- require Fcntl; # For Fcntl::LOCK_NB
-
- return qq{
-
- my \$context = wantarray() ? "list" : "scalar";
-
- # Try to flock. If successful, return it immediately.
-
- my \$retval = $call(@argv);
- return \$retval if \$retval;
-
- # If we failed, but we're using LOCK_NB and
- # returned EWOULDBLOCK, it's not a real error.
-
- if (\$_[1] & Fcntl::LOCK_NB() and \$! == $EWOULDBLOCK ) {
- return \$retval;
- }
-
- # Otherwise, we failed. Die noisily.
-
- $die;
-
- };
- }
-
- # AFAIK everything that can be given an unopned filehandle
- # will fail if it tries to use it, so we don't really need
- # the 'unopened' warning class here. Especially since they
- # then report the wrong line number.
-
- # Other warnings are disabled because they produce excessive
- # complaints from smart-match hints under 5.10.1.
-
- my $code = qq[
- no warnings qw(unopened uninitialized numeric);
-
- if (wantarray) {
- my \@results = $call(@argv);
- my \$retval = \\\@results;
- my \$context = "list";
-
- ];
-
- if ( $hints and ( ref($hints->{list} ) || "" ) eq 'CODE' ) {
-
- # NB: Subroutine hints are passed as a full list.
- # This differs from the 5.10.0 smart-match behaviour,
- # but means that context unaware subroutines can use
- # the same hints in both list and scalar context.
-
- $code .= qq{
- if ( \$hints->{list}->(\@results) ) { $die };
- };
- }
- elsif ( PERL510 and $hints ) {
- $code .= qq{
- if ( \@results ~~ \$hints->{list} ) { $die };
- };
- }
- elsif ( $hints ) {
- croak sprintf(ERROR_58_HINTS, 'list', $sub);
- }
- else {
- $code .= qq{
- # An empty list, or a single undef is failure
- if (! \@results or (\@results == 1 and ! defined \$results[0])) {
- $die;
- }
- }
- }
-
- # Tidy up the end of our wantarray call.
-
- $code .= qq[
- return \@results;
- }
- ];
-
-
- # Otherwise, we're in scalar context.
- # We're never in a void context, since we have to look
- # at the result.
-
- $code .= qq{
- my \$retval = $call(@argv);
- my \$context = "scalar";
- };
-
- if ( $hints and ( ref($hints->{scalar} ) || "" ) eq 'CODE' ) {
-
- # We always call code refs directly, since that always
- # works in 5.8.x, and always works in 5.10.1
-
- return $code .= qq{
- if ( \$hints->{scalar}->(\$retval) ) { $die };
- return \$retval;
- };
-
- }
- elsif (PERL510 and $hints) {
- return $code . qq{
-
- if ( \$retval ~~ \$hints->{scalar} ) { $die };
-
- return \$retval;
- };
- }
- elsif ( $hints ) {
- croak sprintf(ERROR_58_HINTS, 'scalar', $sub);
- }
-
- return $code .
- ( $use_defined_or ? qq{
-
- $die if not defined \$retval;
-
- return \$retval;
-
- } : qq{
-
- return \$retval || $die;
-
- } ) ;
-
-}
-
-# This returns the old copy of the sub, so we can
-# put it back at end of scope.
-
-# TODO : Check to make sure prototypes are restored correctly.
-
-# TODO: Taking a huge list of arguments is awful. Rewriting to
-# take a hash would be lovely.
-
-# TODO - BACKCOMPAT - This is not yet compatible with 5.10.0
-
-sub _make_fatal {
- my($class, $sub, $pkg, $void, $lexical, $filename, $insist) = @_;
- my($name, $code, $sref, $real_proto, $proto, $core, $call, $hints);
- my $ini = $sub;
-
- $sub = "${pkg}::$sub" unless $sub =~ /::/;
-
- # Figure if we're using lexical or package semantics and
- # twiddle the appropriate bits.
-
- if (not $lexical) {
- $Package_Fatal{$sub} = 1;
- }
-
- # TODO - We *should* be able to do skipping, since we know when
- # we've lexicalised / unlexicalised a subroutine.
-
- $name = $sub;
- $name =~ s/.*::// or $name =~ s/^&//;
-
- warn "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
- croak(sprintf(ERROR_BADNAME, $class, $name)) unless $name =~ /^\w+$/;
-
- if (defined(&$sub)) { # user subroutine
-
- # NOTE: Previously we would localise $@ at this point, so
- # the following calls to eval {} wouldn't interfere with anything
- # that's already in $@. Unfortunately, it would also stop
- # any of our croaks from triggering(!), which is even worse.
-
- # This could be something that we've fatalised that
- # was in core.
-
- if ( $Package_Fatal{$sub} and do { local $@; eval { prototype "CORE::$name" } } ) {
-
- # Something we previously made Fatal that was core.
- # This is safe to replace with an autodying to core
- # version.
-
- $core = 1;
- $call = "CORE::$name";
- $proto = prototype $call;
-
- # We return our $sref from this subroutine later
- # on, indicating this subroutine should be placed
- # back when we're finished.
-
- $sref = \&$sub;
-
- } else {
-
- # If this is something we've already fatalised or played with,
- # then look-up the name of the original sub for the rest of
- # our processing.
-
- $sub = $Is_fatalised_sub{\&$sub} || $sub;
-
- # A regular user sub, or a user sub wrapping a
- # core sub.
-
- $sref = \&$sub;
- $proto = prototype $sref;
- $call = '&$sref';
- require autodie::hints;
-
- $hints = autodie::hints->get_hints_for( $sref );
-
- # If we've insisted on hints, but don't have them, then
- # bail out!
-
- if ($insist and not $hints) {
- croak(sprintf(ERROR_NOHINTS, $name));
- }
-
- # Otherwise, use the default hints if we don't have
- # any.
-
- $hints ||= autodie::hints::DEFAULT_HINTS();
-
- }
-
- } elsif ($sub eq $ini && $sub !~ /^CORE::GLOBAL::/) {
- # Stray user subroutine
- croak(sprintf(ERROR_NOTSUB,$sub));
-
- } elsif ($name eq 'system') {
-
- # If we're fatalising system, then we need to load
- # helper code.
-
- # The business with $E is to avoid clobbering our caller's
- # $@, and to avoid $@ being localised when we croak.
-
- my $E;
-
- {
- local $@;
-
- eval {
- require IPC::System::Simple; # Only load it if we need it.
- require autodie::exception::system;
- };
- $E = $@;
- }
-
- if ($E) { croak ERROR_NO_IPC_SYS_SIMPLE; }
-
- # Make sure we're using a recent version of ISS that actually
- # support fatalised system.
- if ($IPC::System::Simple::VERSION < MIN_IPC_SYS_SIMPLE_VER) {
- croak sprintf(
- ERROR_IPC_SYS_SIMPLE_OLD, MIN_IPC_SYS_SIMPLE_VER,
- $IPC::System::Simple::VERSION
- );
- }
-
- $call = 'CORE::system';
- $name = 'system';
- $core = 1;
-
- } elsif ($name eq 'exec') {
- # Exec doesn't have a prototype. We don't care. This
- # breaks the exotic form with lexical scope, and gives
- # the regular form a "do or die" beaviour as expected.
-
- $call = 'CORE::exec';
- $name = 'exec';
- $core = 1;
-
- } else { # CORE subroutine
- my $E;
- {
- local $@;
- $proto = eval { prototype "CORE::$name" };
- $E = $@;
- }
- croak(sprintf(ERROR_NOT_BUILT,$name)) if $E;
- croak(sprintf(ERROR_CANT_OVERRIDE,$name)) if not defined $proto;
- $core = 1;
- $call = "CORE::$name";
- }
-
- if (defined $proto) {
- $real_proto = " ($proto)";
- } else {
- $real_proto = '';
- $proto = '@';
- }
-
- my $true_name = $core ? $call : $sub;
-
- # TODO: This caching works, but I don't like using $void and
- # $lexical as keys. In particular, I suspect our code may end up
- # wrapping already wrapped code when autodie and Fatal are used
- # together.
-
- # NB: We must use '$sub' (the name plus package) and not
- # just '$name' (the short name) here. Failing to do so
- # results code that's in the wrong package, and hence has
- # access to the wrong package filehandles.
-
- if (my $subref = $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical}) {
- $class->_install_subs($pkg, { $name => $subref });
- return $sref;
- }
-
- $code = qq[
- sub$real_proto {
- local(\$", \$!) = (', ', 0); # TODO - Why do we do this?
- ];
-
- # Don't have perl whine if exec fails, since we'll be handling
- # the exception now.
- $code .= "no warnings qw(exec);\n" if $call eq "CORE::exec";
-
- my @protos = fill_protos($proto);
- $code .= $class->_write_invocation($core, $call, $name, $void, $lexical, $sub, $sref, @protos);
- $code .= "}\n";
- warn $code if $Debug;
-
- # I thought that changing package was a monumental waste of
- # time for CORE subs, since they'll always be the same. However
- # that's not the case, since they may refer to package-based
- # filehandles (eg, with open).
- #
- # There is potential to more aggressively cache core subs
- # that we know will never want to interact with package variables
- # and filehandles.
-
- {
- no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ...
-
- my $E;
-
- {
- local $@;
- $code = eval("package $pkg; use Carp; $code"); ## no critic
- $E = $@;
- }
-
- if (not $code) {
- croak("Internal error in autodie/Fatal processing $true_name: $E");
-
- }
- }
-
- # Now we need to wrap our fatalised sub inside an itty bitty
- # closure, which can detect if we've leaked into another file.
- # Luckily, we only need to do this for lexical (autodie)
- # subs. Fatal subs can leak all they want, it's considered
- # a "feature" (or at least backwards compatible).
-
- # TODO: Cache our leak guards!
-
- # TODO: This is pretty hairy code. A lot more tests would
- # be really nice for this.
-
- my $leak_guard;
-
- if ($lexical) {
-
- $leak_guard = qq<
- package $pkg;
-
- sub$real_proto {
-
- # If we're inside a string eval, we can end up with a
- # whacky filename. The following code allows autodie
- # to propagate correctly into string evals.
-
- my \$caller_level = 0;
-
- my \$caller;
-
- while ( (\$caller = (caller \$caller_level)[1]) =~ m{^\\(eval \\d+\\)\$} ) {
-
- # If our filename is actually an eval, and we
- # reach it, then go to our autodying code immediatately.
-
- goto &\$code if (\$caller eq \$filename);
- \$caller_level++;
- }
-
- # We're now out of the eval stack.
-
- # If we're called from the correct file, then use the
- # autodying code.
- goto &\$code if ((caller \$caller_level)[1] eq \$filename);
-
- # Oh bother, we've leaked into another file. Call the
- # original code. Note that \$sref may actually be a
- # reference to a Fatalised version of a core built-in.
- # That's okay, because Fatal *always* leaks between files.
-
- goto &\$sref if \$sref;
- >;
-
-
- # If we're here, it must have been a core subroutine called.
- # Warning: The following code may disturb some viewers.
-
- # TODO: It should be possible to combine this with
- # write_invocation().
-
- foreach my $proto (@protos) {
- local $" = ", "; # So @args is formatted correctly.
- my ($count, @args) = @$proto;
- $leak_guard .= qq<
- if (\@_ == $count) {
- return $call(@args);
- }
- >;
- }
-
- $leak_guard .= qq< croak "Internal error in Fatal/autodie. Leak-guard failure"; } >;
-
- # warn "$leak_guard\n";
-
- my $E;
- {
- local $@;
-
- $leak_guard = eval $leak_guard; ## no critic
-
- $E = $@;
- }
-
- die "Internal error in $class: Leak-guard installation failure: $E" if $E;
- }
-
- my $installed_sub = $leak_guard || $code;
-
- $class->_install_subs($pkg, { $name => $installed_sub });
-
- $Cached_fatalised_sub{$class}{$sub}{$void}{$lexical} = $installed_sub;
-
- # Cache that we've now overriddent this sub. If we get called
- # again, we may need to find that find subroutine again (eg, for hints).
-
- $Is_fatalised_sub{$installed_sub} = $sref;
-
- return $sref;
-
-}
-
-# This subroutine exists primarily so that child classes can override
-# it to point to their own exception class. Doing this is significantly
-# less complex than overriding throw()
-
-sub exception_class { return "autodie::exception" };
-
-{
- my %exception_class_for;
- my %class_loaded;
-
- sub throw {
- my ($class, @args) = @_;
-
- # Find our exception class if we need it.
- my $exception_class =
- $exception_class_for{$class} ||= $class->exception_class;
-
- if (not $class_loaded{$exception_class}) {
- if ($exception_class =~ /[^\w:']/) {
- confess "Bad exception class '$exception_class'.\nThe '$class->exception_class' method wants to use $exception_class\nfor exceptions, but it contains characters which are not word-characters or colons.";
- }
-
- # Alas, Perl does turn barewords into modules unless they're
- # actually barewords. As such, we're left doing a string eval
- # to make sure we load our file correctly.
-
- my $E;
-
- {
- local $@; # We can't clobber $@, it's wrong!
- eval "require $exception_class"; ## no critic
- $E = $@; # Save $E despite ending our local.
- }
-
- # We need quotes around $@ to make sure it's stringified
- # while still in scope. Without them, we run the risk of
- # $@ having been cleared by us exiting the local() block.
-
- confess "Failed to load '$exception_class'.\nThis may be a typo in the '$class->exception_class' method,\nor the '$exception_class' module may not exist.\n\n $E" if $E;
-
- $class_loaded{$exception_class}++;
-
- }
-
- return $exception_class->new(@args);
- }
-}
-
-# For some reason, dying while replacing our subs doesn't
-# kill our calling program. It simply stops the loading of
-# autodie and keeps going with everything else. The _autocroak
-# sub allows us to die with a vegence. It should *only* ever be
-# used for serious internal errors, since the results of it can't
-# be captured.
-
-sub _autocroak {
- warn Carp::longmess(@_);
- exit(255); # Ugh!
-}
-
-package autodie::Scope::Guard;
-
-# This code schedules the cleanup of subroutines at the end of
-# scope. It's directly inspired by chocolateboy's excellent
-# Scope::Guard module.
-
-sub new {
- my ($class, $handler) = @_;
-
- return bless $handler, $class;
-}
-
-sub DESTROY {
- my ($self) = @_;
-
- $self->();
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Fatal - Replace functions with equivalents which succeed or die
-
-=head1 SYNOPSIS
-
- use Fatal qw(open close);
-
- open(my $fh, "<", $filename); # No need to check errors!
-
- use File::Copy qw(move);
- use Fatal qw(move);
-
- move($file1, $file2); # No need to check errors!
-
- sub juggle { . . . }
- Fatal->import('juggle');
-
-=head1 BEST PRACTICE
-
-B<Fatal has been obsoleted by the new L<autodie> pragma.> Please use
-L<autodie> in preference to C<Fatal>. L<autodie> supports lexical scoping,
-throws real exception objects, and provides much nicer error messages.
-
-The use of C<:void> with Fatal is discouraged.
-
-=head1 DESCRIPTION
-
-C<Fatal> provides a way to conveniently replace
-functions which normally return a false value when they fail with
-equivalents which raise exceptions if they are not successful. This
-lets you use these functions without having to test their return
-values explicitly on each call. Exceptions can be caught using
-C<eval{}>. See L<perlfunc> and L<perlvar> for details.
-
-The do-or-die equivalents are set up simply by calling Fatal's
-C<import> routine, passing it the names of the functions to be
-replaced. You may wrap both user-defined functions and overridable
-CORE operators (except C<exec>, C<system>, C<print>, or any other
-built-in that cannot be expressed via prototypes) in this way.
-
-If the symbol C<:void> appears in the import list, then functions
-named later in that import list raise an exception only when
-these are called in void context--that is, when their return
-values are ignored. For example
-
- use Fatal qw/:void open close/;
-
- # properly checked, so no exception raised on error
- if (not open(my $fh, '<', '/bogotic') {
- warn "Can't open /bogotic: $!";
- }
-
- # not checked, so error raises an exception
- close FH;
-
-The use of C<:void> is discouraged, as it can result in exceptions
-not being thrown if you I<accidentally> call a method without
-void context. Use L<autodie> instead if you need to be able to
-disable autodying/Fatal behaviour for a small block of code.
-
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item Bad subroutine name for Fatal: %s
-
-You've called C<Fatal> with an argument that doesn't look like
-a subroutine name, nor a switch that this version of Fatal
-understands.
-
-=item %s is not a Perl subroutine
-
-You've asked C<Fatal> to try and replace a subroutine which does not
-exist, or has not yet been defined.
-
-=item %s is neither a builtin, nor a Perl subroutine
-
-You've asked C<Fatal> to replace a subroutine, but it's not a Perl
-built-in, and C<Fatal> couldn't find it as a regular subroutine.
-It either doesn't exist or has not yet been defined.
-
-=item Cannot make the non-overridable %s fatal
-
-You've tried to use C<Fatal> on a Perl built-in that can't be
-overridden, such as C<print> or C<system>, which means that
-C<Fatal> can't help you, although some other modules might.
-See the L</"SEE ALSO"> section of this documentation.
-
-=item Internal error: %s
-
-You've found a bug in C<Fatal>. Please report it using
-the C<perlbug> command.
-
-=back
-
-=head1 BUGS
-
-C<Fatal> clobbers the context in which a function is called and always
-makes it a scalar context, except when the C<:void> tag is used.
-This problem does not exist in L<autodie>.
-
-"Used only once" warnings can be generated when C<autodie> or C<Fatal>
-is used with package filehandles (eg, C<FILE>). It's strongly recommended
-you use scalar filehandles instead.
-
-=head1 AUTHOR
-
-Original module by Lionel Cons (CERN).
-
-Prototype updates by Ilya Zakharevich <ilya at math.ohio-state.edu>.
-
-L<autodie> support, bugfixes, extended diagnostics, C<system>
-support, and major overhauling by Paul Fenwick <pjf at perltraining.com.au>
-
-=head1 LICENSE
-
-This module is free software, you may distribute it under the
-same terms as Perl itself.
-
-=head1 SEE ALSO
-
-L<autodie> for a nicer way to use lexical Fatal.
-
-L<IPC::System::Simple> for a similar idea for calls to C<system()>
-and backticks.
-
-=cut
Deleted: trunk/contrib/perl/lib/Fatal.t
===================================================================
--- trunk/contrib/perl/lib/Fatal.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Fatal.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,36 +0,0 @@
-#!./perl -w
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- print "1..15\n";
-}
-
-use strict;
-use Fatal qw(open close :void opendir sin);
-
-my $i = 1;
-eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' };
-print "not " unless $@ =~ /^Can't open/;
-print "ok $i\n"; ++$i;
-
-my $foo = 'FOO';
-for ('$foo', "'$foo'", "*$foo", "\\*$foo") {
- eval qq{ open $_, '<$0' };
- print "not " if $@;
- print "ok $i\n"; ++$i;
-
- print "not " if $@ or scalar(<$foo>) !~ m|^#!./perl|;
- print "ok $i\n"; ++$i;
- eval qq{ close FOO };
- print "not " if $@;
- print "ok $i\n"; ++$i;
-}
-
-eval { opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' };
-print "not " unless $@ =~ /^Can't open/;
-print "ok $i\n"; ++$i;
-
-eval { my $a = opendir FOO, 'lkjqweriuapofukndajsdlfjnvcvn' };
-print "not " if $@ =~ /^Can't open/;
-print "ok $i\n"; ++$i;
Deleted: trunk/contrib/perl/lib/File/CheckTree.pm
===================================================================
--- trunk/contrib/perl/lib/File/CheckTree.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/File/CheckTree.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,238 +0,0 @@
-package File::CheckTree;
-
-use 5.006;
-use Cwd;
-use Exporter;
-use File::Spec;
-use warnings;
-use strict;
-
-our $VERSION = '4.4';
-our @ISA = qw(Exporter);
-our @EXPORT = qw(validate);
-
-=head1 NAME
-
-File::CheckTree - run many filetest checks on a tree
-
-=head1 SYNOPSIS
-
- use File::CheckTree;
-
- $num_warnings = validate( q{
- /vmunix -e || die
- /boot -e || die
- /bin cd
- csh -ex
- csh !-ug
- sh -ex
- sh !-ug
- /usr -d || warn "What happened to $file?\n"
- });
-
-=head1 DESCRIPTION
-
-The validate() routine takes a single multiline string consisting of
-directives, each containing a filename plus a file test to try on it.
-(The file test may also be a "cd", causing subsequent relative filenames
-to be interpreted relative to that directory.) After the file test
-you may put C<|| die> to make it a fatal error if the file test fails.
-The default is C<|| warn>. The file test may optionally have a "!' prepended
-to test for the opposite condition. If you do a cd and then list some
-relative filenames, you may want to indent them slightly for readability.
-If you supply your own die() or warn() message, you can use $file to
-interpolate the filename.
-
-Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
-Only the first failed test of the bunch will produce a warning.
-
-The routine returns the number of warnings issued.
-
-=head1 AUTHOR
-
-File::CheckTree was derived from lib/validate.pl which was
-written by Larry Wall.
-Revised by Paul Grassie <F<grassie at perl.com>> in 2002.
-
-=head1 HISTORY
-
-File::CheckTree used to not display fatal error messages.
-It used to count only those warnings produced by a generic C<|| warn>
-(and not those in which the user supplied the message). In addition,
-the validate() routine would leave the user program in whatever
-directory was last entered through the use of "cd" directives.
-These bugs were fixed during the development of perl 5.8.
-The first fixed version of File::CheckTree was 4.2.
-
-=cut
-
-my $Warnings;
-
-sub validate {
- my ($starting_dir, $file, $test, $cwd, $oldwarnings);
-
- $starting_dir = cwd;
-
- $cwd = "";
- $Warnings = 0;
-
- foreach my $check (split /\n/, $_[0]) {
- my ($testlist, @testlist);
-
- # skip blanks/comments
- next if $check =~ /^\s*#/ || $check =~ /^\s*$/;
-
- # Todo:
- # should probably check for invalid directives and die
- # but earlier versions of File::CheckTree did not do this either
-
- # split a line like "/foo -r || die"
- # so that $file is "/foo", $test is "-r || die"
- # (making special allowance for quoted filenames).
- if ($check =~ m/^\s*"([^"]+)"\s+(.*?)\s*$/ or
- $check =~ m/^\s*'([^']+)'\s+(.*?)\s*$/ or
- $check =~ m/^\s*(\S+?)\s+(\S.*?)\s*$/)
- {
- ($file, $test) = ($1,$2);
- }
- else {
- die "Malformed line: '$check'";
- };
-
- # change a $test like "!-ug || die" to "!-Z || die",
- # capturing the bundled tests (e.g. "ug") in $2
- if ($test =~ s/ ^ (!?-) (\w{2,}) \b /$1Z/x) {
- $testlist = $2;
- # split bundled tests, e.g. "ug" to 'u', 'g'
- @testlist = split(//, $testlist);
- }
- else {
- # put in placeholder Z for stand-alone test
- @testlist = ('Z');
- }
-
- # will compare these two later to stop on 1st warning w/in a bundle
- $oldwarnings = $Warnings;
-
- foreach my $one (@testlist) {
- # examples of $test: "!-Z || die" or "-w || warn"
- my $this = $test;
-
- # expand relative $file to full pathname if preceded by cd directive
- $file = File::Spec->catfile($cwd, $file)
- if $cwd && !File::Spec->file_name_is_absolute($file);
-
- # put filename in after the test operator
- $this =~ s/(-\w\b)/$1 "\$file"/g;
-
- # change the "-Z" representing a bundle with the $one test
- $this =~ s/-Z/-$one/;
-
- # if it's a "cd" directive...
- if ($this =~ /^cd\b/) {
- # add "|| die ..."
- $this .= ' || die "cannot cd to $file\n"';
- # expand "cd" directive with directory name
- $this =~ s/\bcd\b/chdir(\$cwd = '$file')/;
- }
- else {
- # add "|| warn" as a default disposition
- $this .= ' || warn' unless $this =~ /\|\|/;
-
- # change a generic ".. || die" or ".. || warn"
- # to call valmess instead of die/warn directly
- # valmess will look up the error message from %Val_Message
- $this =~ s/ ^ ( (\S+) \s+ \S+ ) \s* \|\| \s* (die|warn) \s* $
- /$1 || valmess('$3', '$2', \$file)/x;
- }
-
- {
- # count warnings, either from valmess or '-r || warn "my msg"'
- # also, call any pre-existing signal handler for __WARN__
- my $orig_sigwarn = $SIG{__WARN__};
- local $SIG{__WARN__} = sub {
- ++$Warnings;
- if ( $orig_sigwarn ) {
- $orig_sigwarn->(@_);
- }
- else {
- warn "@_";
- }
- };
-
- # do the test
- eval $this;
-
- # re-raise an exception caused by a "... || die" test
- if (my $err = $@) {
- # in case of any cd directives, return from whence we came
- if ($starting_dir ne cwd) {
- chdir($starting_dir) || die "$starting_dir: $!";
- }
- die $err;
- }
- }
-
- # stop on 1st warning within a bundle of tests
- last if $Warnings > $oldwarnings;
- }
- }
-
- # in case of any cd directives, return from whence we came
- if ($starting_dir ne cwd) {
- chdir($starting_dir) || die "chdir $starting_dir: $!";
- }
-
- return $Warnings;
-}
-
-my %Val_Message = (
- 'r' => "is not readable by uid $>.",
- 'w' => "is not writable by uid $>.",
- 'x' => "is not executable by uid $>.",
- 'o' => "is not owned by uid $>.",
- 'R' => "is not readable by you.",
- 'W' => "is not writable by you.",
- 'X' => "is not executable by you.",
- 'O' => "is not owned by you.",
- 'e' => "does not exist.",
- 'z' => "does not have zero size.",
- 's' => "does not have non-zero size.",
- 'f' => "is not a plain file.",
- 'd' => "is not a directory.",
- 'l' => "is not a symbolic link.",
- 'p' => "is not a named pipe (FIFO).",
- 'S' => "is not a socket.",
- 'b' => "is not a block special file.",
- 'c' => "is not a character special file.",
- 'u' => "does not have the setuid bit set.",
- 'g' => "does not have the setgid bit set.",
- 'k' => "does not have the sticky bit set.",
- 'T' => "is not a text file.",
- 'B' => "is not a binary file."
-);
-
-sub valmess {
- my ($disposition, $test, $file) = @_;
- my $ferror;
-
- if ($test =~ / ^ (!?) -(\w) \s* $ /x) {
- my ($neg, $ftype) = ($1, $2);
-
- $ferror = "$file $Val_Message{$ftype}";
-
- if ($neg eq '!') {
- $ferror =~ s/ is not / should not be / ||
- $ferror =~ s/ does not / should not / ||
- $ferror =~ s/ not / /;
- }
- }
- else {
- $ferror = "Can't do $test $file.\n";
- }
-
- die "$ferror\n" if $disposition eq 'die';
- warn "$ferror\n";
-}
-
-1;
Deleted: trunk/contrib/perl/lib/File/CheckTree.t
===================================================================
--- trunk/contrib/perl/lib/File/CheckTree.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/File/CheckTree.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,241 +0,0 @@
-#!./perl -w
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
-use Test;
-
-BEGIN { plan tests => 8 }
-
-use strict;
-
-BEGIN {
-# Cwd::cwd does an implicit "require Win32", but
-# the ../lib directory in @INC will no longer work once
-# we chdir() out of the "t" directory.
- if ($^O eq 'MSWin32') {
- require Win32;
- Win32->import();
- }
-}
-
-use File::CheckTree;
-use File::Spec; # used to get absolute paths
-
-# We assume that we start from the perl "t" directory.
-# Will move up one level to make it easier to generate
-# reliable pathnames for testing File::CheckTree
-
-chdir(File::Spec->updir) or die "cannot change to parent of t/ directory: $!";
-
-
-#### TEST 1 -- No warnings ####
-# usings both relative and full paths, indented comments
-
-{
- my ($num_warnings, $path_to_README);
- $path_to_README = File::Spec->rel2abs('README');
-
- my @warnings;
- local $SIG{__WARN__} = sub { push @warnings, "@_" };
-
- eval {
- $num_warnings = validate qq{
- lib -d
-# comment, followed "blank" line (w/ whitespace):
-
- # indented comment, followed blank line (w/o whitespace):
-
- README -f
- '$path_to_README' -e || warn
- };
- };
-
- print STDERR $_ for @warnings;
- if ( !$@ && !@warnings && defined($num_warnings) && $num_warnings == 0 ) {
- ok(1);
- }
- else {
- ok(0);
- }
-}
-
-
-#### TEST 2 -- One warning ####
-
-{
- my ($num_warnings, @warnings);
-
- local $SIG{__WARN__} = sub { push @warnings, "@_" };
-
- eval {
- $num_warnings = validate qq{
- lib -f
- README -f
- };
- };
-
- if ( !$@ && @warnings == 1
- && $warnings[0] =~ /lib is not a plain file/
- && defined($num_warnings)
- && $num_warnings == 1 )
- {
- ok(1);
- }
- else {
- ok(0);
- }
-}
-
-
-#### TEST 3 -- Multiple warnings ####
-# including first warning only from a bundle of tests,
-# generic "|| warn", default "|| warn" and "|| warn '...' "
-
-{
- my ($num_warnings, @warnings);
-
- local $SIG{__WARN__} = sub { push @warnings, "@_" };
-
- eval {
- $num_warnings = validate q{
- lib -effd
- README -f || die
- README -d || warn
- lib -f || warn "my warning: $file\n"
- };
- };
-
- if ( !$@ && @warnings == 3
- && $warnings[0] =~ /lib is not a plain file/
- && $warnings[1] =~ /README is not a directory/
- && $warnings[2] =~ /my warning: lib/
- && defined($num_warnings)
- && $num_warnings == 3 )
- {
- ok(1);
- }
- else {
- ok(0);
- }
-}
-
-
-#### TEST 4 -- cd directive ####
-# cd directive followed by relative paths, followed by full paths
-{
- my ($num_warnings, @warnings, $path_to_libFile, $path_to_dist);
- $path_to_libFile = File::Spec->rel2abs(File::Spec->catdir('lib','File'));
- $path_to_dist = File::Spec->rel2abs(File::Spec->curdir);
-
- local $SIG{__WARN__} = sub { push @warnings, "@_" };
-
- eval {
- $num_warnings = validate qq{
- lib -d || die
- '$path_to_libFile' cd
- Spec -e
- Spec -f
- '$path_to_dist' cd
- README -ef
- INSTALL -d || warn
- '$path_to_libFile' -d || die
- };
- };
-
- if ( !$@ && @warnings == 2
- && $warnings[0] =~ /Spec is not a plain file/
- && $warnings[1] =~ /INSTALL is not a directory/
- && defined($num_warnings)
- && $num_warnings == 2 )
- {
- ok(1);
- }
- else {
- ok(0);
- }
-}
-
-
-#### TEST 5 -- Exception ####
-# test with generic "|| die"
-{
- my $num_warnings;
-
- eval {
- $num_warnings = validate q{
- lib -ef || die
- README -d
- };
- };
-
- if ( $@ && $@ =~ /lib is not a plain file/
- && not defined $num_warnings )
- {
- ok(1);
- }
- else {
- ok(0);
- }
-}
-
-
-#### TEST 6 -- Exception ####
-# test with "|| die 'my error message'"
-{
- my $num_warnings;
-
- eval {
- $num_warnings = validate q{
- lib -ef || die "yadda $file yadda...\n"
- README -d
- };
- };
-
- if ( $@ && $@ =~ /yadda lib yadda/
- && not defined $num_warnings )
- {
- ok(1);
- }
- else {
- ok(0);
- }
-}
-
-#### TEST 7 -- Quoted file names ####
-{
- my $num_warnings;
- eval {
- $num_warnings = validate q{
- "a file with whitespace" !-ef
- 'a file with whitespace' !-ef
- };
- };
-
- if ( !$@ ) {
- # No errors mean we compile correctly
- ok(1);
- } else {
- ok(0);
- print STDERR $@;
- };
-}
-
-#### TEST 8 -- Malformed query ####
-{
- my $num_warnings;
- eval {
- $num_warnings = validate q{
- a file with whitespace !-ef
- };
- };
-
- if ( $@ =~ /syntax error/) {
- # We got a syntax error for a malformed file query
- ok(1);
- } else {
- ok(0);
- };
-}
Deleted: trunk/contrib/perl/lib/File/DosGlob.pm
===================================================================
--- trunk/contrib/perl/lib/File/DosGlob.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/File/DosGlob.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,312 +0,0 @@
-#!perl -w
-
-# use strict fails
-#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191.
-
-#
-# Documentation at the __END__
-#
-
-package File::DosGlob;
-
-our $VERSION = '1.04';
-use strict;
-use warnings;
-
-sub doglob {
- my $cond = shift;
- my @retval = ();
- my $fix_drive_relative_paths;
- #print "doglob: ", join('|', @_), "\n";
- OUTER:
- for my $pat (@_) {
- my @matched = ();
- my @globdirs = ();
- my $head = '.';
- my $sepchr = '/';
- my $tail;
- next OUTER unless defined $pat and $pat ne '';
- # if arg is within quotes strip em and do no globbing
- if ($pat =~ /^"(.*)"\z/s) {
- $pat = $1;
- if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
- else { push(@retval, $pat) if -e $pat }
- next OUTER;
- }
- # wildcards with a drive prefix such as h:*.pm must be changed
- # to h:./*.pm to expand correctly
- if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
- substr($pat,0,2) = $1 . "./";
- $fix_drive_relative_paths = 1;
- }
- if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
- ($head, $sepchr, $tail) = ($1,$2,$3);
- #print "div: |$head|$sepchr|$tail|\n";
- push (@retval, $pat), next OUTER if $tail eq '';
- if ($head =~ /[*?]/) {
- @globdirs = doglob('d', $head);
- push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
- next OUTER if @globdirs;
- }
- $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
- $pat = $tail;
- }
- #
- # If file component has no wildcards, we can avoid opendir
- unless ($pat =~ /[*?]/) {
- $head = '' if $head eq '.';
- $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
- $head .= $pat;
- if ($cond eq 'd') { push(@retval,$head) if -d $head }
- else { push(@retval,$head) if -e $head }
- next OUTER;
- }
- opendir(D, $head) or next OUTER;
- my @leaves = readdir D;
- closedir D;
- $head = '' if $head eq '.';
- $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
-
- # escape regex metachars but not glob chars
- $pat =~ s:([].+^\-\${}()[|]):\\$1:g;
- # and convert DOS-style wildcards to regex
- $pat =~ s/\*/.*/g;
- $pat =~ s/\?/.?/g;
-
- #print "regex: '$pat', head: '$head'\n";
- my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
- INNER:
- for my $e (@leaves) {
- next INNER if $e eq '.' or $e eq '..';
- next INNER if $cond eq 'd' and ! -d "$head$e";
- push(@matched, "$head$e"), next INNER if &$matchsub($e);
- #
- # [DOS compatibility special case]
- # Failed, add a trailing dot and try again, but only
- # if name does not have a dot in it *and* pattern
- # has a dot *and* name is shorter than 9 chars.
- #
- if (index($e,'.') == -1 and length($e) < 9
- and index($pat,'\\.') != -1) {
- push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
- }
- }
- push @retval, @matched if @matched;
- }
- if ($fix_drive_relative_paths) {
- s|^([A-Za-z]:)\./|$1| for @retval;
- }
- return @retval;
-}
-
-#
-# this can be used to override CORE::glob in a specific
-# package by saying C<use File::DosGlob 'glob';> in that
-# namespace.
-#
-
-# context (keyed by second cxix arg provided by core)
-my %iter;
-my %entries;
-
-sub glob {
- my($pat,$cxix) = @_;
- my @pat;
-
- # glob without args defaults to $_
- $pat = $_ unless defined $pat;
-
- # extract patterns
- if ($pat =~ /\s/) {
- require Text::ParseWords;
- @pat = Text::ParseWords::parse_line('\s+',0,$pat);
- }
- else {
- push @pat, $pat;
- }
-
- # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
- # abc3 will be the original {3} (and drop the {}).
- # abc1 abc2 will be put in @appendpat.
- # This was just the esiest way, not nearly the best.
- REHASH: {
- my @appendpat = ();
- for (@pat) {
- # There must be a "," I.E. abc{efg} is not what we want.
- while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
- my ($start, $match, $end) = ($1, $2, $3);
- #print "Got: \n\t$start\n\t$match\n\t$end\n";
- my $tmp = "$start$match$end";
- while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
- #print "Striped: $tmp\n";
- # these expansions will be preformed by the original,
- # when we call REHASH.
- }
- push @appendpat, ("$tmp");
- s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
- if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
- $match = $1;
- #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
- $_ = "$start$match$end";
- }
- }
- #print "Sould have "GOT" vs "Got"!\n";
- #FIXME: There should be checking for this.
- # How or what should be done about failure is beond me.
- }
- if ( $#appendpat != -1
- ) {
- #print "LOOP\n";
- #FIXME: Max loop, no way! :")
- for ( @appendpat ) {
- push @pat, $_;
- }
- goto REHASH;
- }
- }
- for ( @pat ) {
- s/\\{/{/g;
- s/\\}/}/g;
- s/\\,/,/g;
- }
- #print join ("\n", @pat). "\n";
-
- # assume global context if not provided one
- $cxix = '_G_' unless defined $cxix;
- $iter{$cxix} = 0 unless exists $iter{$cxix};
-
- # if we're just beginning, do it all first
- if ($iter{$cxix} == 0) {
- $entries{$cxix} = [doglob(1, at pat)];
- }
-
- # chuck it all out, quick or slow
- if (wantarray) {
- delete $iter{$cxix};
- return @{delete $entries{$cxix}};
- }
- else {
- if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
- return shift @{$entries{$cxix}};
- }
- else {
- # return undef for EOL
- delete $iter{$cxix};
- delete $entries{$cxix};
- return undef;
- }
- }
-}
-
-{
- no strict 'refs';
-
- sub import {
- my $pkg = shift;
- return unless @_;
- my $sym = shift;
- my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
- *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
- }
-}
-1;
-
-__END__
-
-=head1 NAME
-
-File::DosGlob - DOS like globbing and then some
-
-=head1 SYNOPSIS
-
- require 5.004;
-
- # override CORE::glob in current package
- use File::DosGlob 'glob';
-
- # override CORE::glob in ALL packages (use with extreme caution!)
- use File::DosGlob 'GLOBAL_glob';
-
- @perlfiles = glob "..\\pe?l/*.p?";
- print <..\\pe?l/*.p?>;
-
- # from the command line (overrides only in main::)
- > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
-
-=head1 DESCRIPTION
-
-A module that implements DOS-like globbing with a few enhancements.
-It is largely compatible with perlglob.exe (the M$ setargv.obj
-version) in all but one respect--it understands wildcards in
-directory components.
-
-For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
-that it will find something like '..\lib\File/DosGlob.pm' alright).
-Note that all path components are case-insensitive, and that
-backslashes and forward slashes are both accepted, and preserved.
-You may have to double the backslashes if you are putting them in
-literally, due to double-quotish parsing of the pattern by perl.
-
-Spaces in the argument delimit distinct patterns, so
-C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
-or C<.dll>. If you want to put in literal spaces in the glob
-pattern, you can escape them with either double quotes, or backslashes.
-e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
-C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using
-C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
-of the quoting rules used.
-
-Extending it to csh patterns is left as an exercise to the reader.
-
-=head1 EXPORTS (by request only)
-
-glob()
-
-=head1 BUGS
-
-Should probably be built into the core, and needs to stop
-pandering to DOS habits. Needs a dose of optimizium too.
-
-=head1 AUTHOR
-
-Gurusamy Sarathy <gsar at activestate.com>
-
-=head1 HISTORY
-
-=over 4
-
-=item *
-
-Support for globally overriding glob() (GSAR 3-JUN-98)
-
-=item *
-
-Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
-
-=item *
-
-A few dir-vs-file optimizations result in glob importation being
-10 times faster than using perlglob.exe, and using perlglob.bat is
-only twice as slow as perlglob.exe (GSAR 28-MAY-97)
-
-=item *
-
-Several cleanups prompted by lack of compatible perlglob.exe
-under Borland (GSAR 27-MAY-97)
-
-=item *
-
-Initial version (GSAR 20-FEB-97)
-
-=back
-
-=head1 SEE ALSO
-
-perl
-
-perlglob.bat
-
-Text::ParseWords
-
-=cut
-
Deleted: trunk/contrib/perl/lib/File/DosGlob.t
===================================================================
--- trunk/contrib/perl/lib/File/DosGlob.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/File/DosGlob.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,132 +0,0 @@
-#!./perl
-
-#
-# test glob() in File::DosGlob
-#
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
-use Test::More tests => 20;
-
-# override it in main::
-use File::DosGlob 'glob';
-
-require Cwd;
-
-my $expected;
-$expected = $_ = "op/a*.t";
-my @r = glob;
-is ($_, $expected, 'test if $_ takes as the default');
-cmp_ok(@r, '>=', 9) or diag("|@r|");
-
- at r = <*/a*.t>;
-# atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t
-cmp_ok(@r, '>=', 9, 'check <*/*>') or diag("|@r|");
-my $r = scalar @r;
-
- at r = ();
-while (defined($_ = <*/a*.t>)) {
- print "# $_\n";
- push @r, $_;
-}
-is(scalar @r, $r, 'check scalar context');
-
- at r = ();
-for (<*/a*.t>) {
- print "# $_\n";
- push @r, $_;
-}
-is(scalar @r, $r, 'check list context');
-
- at r = ();
-while (<*/a*.t>) {
- print "# $_\n";
- push @r, $_;
-}
-is(scalar @r, $r, 'implicit assign to $_ in while()');
-
-my @s = ();
-my $pat = '*/a*.t';
-while (glob ($pat)) {
- print "# $_\n";
- push @s, $_;
-}
-is("@r", "@s", 'explicit glob() gets assign magic too');
-
-package Foo;
-use File::DosGlob 'glob';
-use Test::More;
- at s = ();
-$pat = '*/a*.t';
-while (glob($pat)) {
- print "# $_\n";
- push @s, $_;
-}
-is("@r", "@s", 'in a different package');
-
- at s = ();
-while (<*/a*.t>) {
- my $i = 0;
- print "# $_ <";
- push @s, $_;
- while (<*/b*.t>) {
- print " $_";
- $i++;
- }
- print " >\n";
-}
-is("@r", "@s", 'different glob ops maintain independent contexts');
-
- at s = ();
-eval <<'EOT';
-use File::DosGlob 'GLOBAL_glob';
-package Bar;
-while (<*/a*.t>) {
- my $i = 0;
- print "# $_ <";
- push @s, $_;
- while (glob '*/b*.t') {
- print " $_";
- $i++;
- }
- print " >\n";
-}
-EOT
-is("@r", "@s", 'global override');
-
-# Test that a glob pattern containing ()'s works.
-# NB. The spaces in the glob patterns need to be backslash escaped.
-my $filename_containing_parens = "foo (123) bar";
-SKIP: {
- skip("can't create '$filename_containing_parens': $!", 9)
- unless open my $touch, ">", $filename_containing_parens;
- close $touch;
-
- foreach my $pattern ("foo\\ (*", "*)\\ bar", "foo\\ (1*3)\\ bar") {
- @r = ();
- eval { @r = File::DosGlob::glob($pattern) };
- is($@, "", "eval for glob($pattern)");
- is(scalar @r, 1);
- is($r[0], $filename_containing_parens);
- }
-
- 1 while unlink $filename_containing_parens;
-}
-
-# Test the globbing of a drive relative pattern such as "c:*.pl".
-# NB. previous versions of DosGlob inserted "./ after the drive letter to
-# make the expansion process work correctly. However, while it is harmless,
-# there is no reason for it to be in the result.
-my $cwd = Cwd::cwd();
-if ($cwd =~ /^([a-zA-Z]:)/) {
- my $drive = $1;
- @r = ();
- # This assumes we're in the "t" directory.
- eval { @r = File::DosGlob::glob("${drive}io/*.t") };
- ok(@r and !grep !m|^${drive}io/[^/]*\.t$|, @r);
-} else {
- pass();
-}
Deleted: trunk/contrib/perl/lib/File/Fetch.pm
===================================================================
--- trunk/contrib/perl/lib/File/Fetch.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/File/Fetch.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1382 +0,0 @@
-package File::Fetch;
-
-use strict;
-use FileHandle;
-use File::Temp;
-use File::Copy;
-use File::Spec;
-use File::Spec::Unix;
-use File::Basename qw[dirname];
-
-use Cwd qw[cwd];
-use Carp qw[carp];
-use IPC::Cmd qw[can_run run QUOTE];
-use File::Path qw[mkpath];
-use File::Temp qw[tempdir];
-use Params::Check qw[check];
-use Module::Load::Conditional qw[can_load];
-use Locale::Maketext::Simple Style => 'gettext';
-
-use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
- $BLACKLIST $METHOD_FAIL $VERSION $METHODS
- $FTP_PASSIVE $TIMEOUT $DEBUG $WARN
- ];
-
-$VERSION = '0.20';
-$VERSION = eval $VERSION; # avoid warnings with development releases
-$PREFER_BIN = 0; # XXX TODO implement
-$FROM_EMAIL = 'File-Fetch at example.com';
-$USER_AGENT = "File::Fetch/$VERSION";
-$BLACKLIST = [qw|ftp|];
-$METHOD_FAIL = { };
-$FTP_PASSIVE = 1;
-$TIMEOUT = 0;
-$DEBUG = 0;
-$WARN = 1;
-
-### methods available to fetch the file depending on the scheme
-$METHODS = {
- http => [ qw|lwp wget curl lftp lynx| ],
- ftp => [ qw|lwp netftp wget curl lftp ncftp ftp| ],
- file => [ qw|lwp lftp file| ],
- rsync => [ qw|rsync| ]
-};
-
-### silly warnings ###
-local $Params::Check::VERBOSE = 1;
-local $Params::Check::VERBOSE = 1;
-local $Module::Load::Conditional::VERBOSE = 0;
-local $Module::Load::Conditional::VERBOSE = 0;
-
-### see what OS we are on, important for file:// uris ###
-use constant ON_WIN => ($^O eq 'MSWin32');
-use constant ON_VMS => ($^O eq 'VMS');
-use constant ON_UNIX => (!ON_WIN);
-use constant HAS_VOL => (ON_WIN);
-use constant HAS_SHARE => (ON_WIN);
-
-
-=pod
-
-=head1 NAME
-
-File::Fetch - A generic file fetching mechanism
-
-=head1 SYNOPSIS
-
- use File::Fetch;
-
- ### build a File::Fetch object ###
- my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt');
-
- ### fetch the uri to cwd() ###
- my $where = $ff->fetch() or die $ff->error;
-
- ### fetch the uri to /tmp ###
- my $where = $ff->fetch( to => '/tmp' );
-
- ### parsed bits from the uri ###
- $ff->uri;
- $ff->scheme;
- $ff->host;
- $ff->path;
- $ff->file;
-
-=head1 DESCRIPTION
-
-File::Fetch is a generic file fetching mechanism.
-
-It allows you to fetch any file pointed to by a C<ftp>, C<http>,
-C<file>, or C<rsync> uri by a number of different means.
-
-See the C<HOW IT WORKS> section further down for details.
-
-=head1 ACCESSORS
-
-A C<File::Fetch> object has the following accessors
-
-=over 4
-
-=item $ff->uri
-
-The uri you passed to the constructor
-
-=item $ff->scheme
-
-The scheme from the uri (like 'file', 'http', etc)
-
-=item $ff->host
-
-The hostname in the uri. Will be empty if host was originally
-'localhost' for a 'file://' url.
-
-=item $ff->vol
-
-On operating systems with the concept of a volume the second element
-of a file:// is considered to the be volume specification for the file.
-Thus on Win32 this routine returns the volume, on other operating
-systems this returns nothing.
-
-On Windows this value may be empty if the uri is to a network share, in
-which case the 'share' property will be defined. Additionally, volume
-specifications that use '|' as ':' will be converted on read to use ':'.
-
-On VMS, which has a volume concept, this field will be empty because VMS
-file specifications are converted to absolute UNIX format and the volume
-information is transparently included.
-
-=item $ff->share
-
-On systems with the concept of a network share (currently only Windows) returns
-the sharename from a file://// url. On other operating systems returns empty.
-
-=item $ff->path
-
-The path from the uri, will be at least a single '/'.
-
-=item $ff->file
-
-The name of the remote file. For the local file name, the
-result of $ff->output_file will be used.
-
-=cut
-
-
-##########################
-### Object & Accessors ###
-##########################
-
-{
- ### template for autogenerated accessors ###
- my $Tmpl = {
- scheme => { default => 'http' },
- host => { default => 'localhost' },
- path => { default => '/' },
- file => { required => 1 },
- uri => { required => 1 },
- vol => { default => '' }, # windows for file:// uris
- share => { default => '' }, # windows for file:// uris
- _error_msg => { no_override => 1 },
- _error_msg_long => { no_override => 1 },
- };
-
- for my $method ( keys %$Tmpl ) {
- no strict 'refs';
- *$method = sub {
- my $self = shift;
- $self->{$method} = $_[0] if @_;
- return $self->{$method};
- }
- }
-
- sub _create {
- my $class = shift;
- my %hash = @_;
-
- my $args = check( $Tmpl, \%hash ) or return;
-
- bless $args, $class;
-
- if( lc($args->scheme) ne 'file' and not $args->host ) {
- return File::Fetch->_error(loc(
- "Hostname required when fetching from '%1'",$args->scheme));
- }
-
- for (qw[path file]) {
- unless( $args->$_() ) { # 5.5.x needs the ()
- return File::Fetch->_error(loc("No '%1' specified",$_));
- }
- }
-
- return $args;
- }
-}
-
-=item $ff->output_file
-
-The name of the output file. This is the same as $ff->file,
-but any query parameters are stripped off. For example:
-
- http://example.com/index.html?x=y
-
-would make the output file be C<index.html> rather than
-C<index.html?x=y>.
-
-=back
-
-=cut
-
-sub output_file {
- my $self = shift;
- my $file = $self->file;
-
- $file =~ s/\?.*$//g;
-
- return $file;
-}
-
-### XXX do this or just point to URI::Escape?
-# =head2 $esc_uri = $ff->escaped_uri
-#
-# =cut
-#
-# ### most of this is stolen straight from URI::escape
-# { ### Build a char->hex map
-# my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
-#
-# sub escaped_uri {
-# my $self = shift;
-# my $uri = $self->uri;
-#
-# ### Default unsafe characters. RFC 2732 ^(uric - reserved)
-# $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/
-# $escapes{$1} || $self->_fail_hi($1)/ge;
-#
-# return $uri;
-# }
-#
-# sub _fail_hi {
-# my $self = shift;
-# my $char = shift;
-#
-# $self->_error(loc(
-# "Can't escape '%1', try using the '%2' module instead",
-# sprintf("\\x{%04X}", ord($char)), 'URI::Escape'
-# ));
-# }
-#
-# sub output_file {
-#
-# }
-#
-#
-# }
-
-=head1 METHODS
-
-=head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' );
-
-Parses the uri and creates a corresponding File::Fetch::Item object,
-that is ready to be C<fetch>ed and returns it.
-
-Returns false on failure.
-
-=cut
-
-sub new {
- my $class = shift;
- my %hash = @_;
-
- my ($uri);
- my $tmpl = {
- uri => { required => 1, store => \$uri },
- };
-
- check( $tmpl, \%hash ) or return;
-
- ### parse the uri to usable parts ###
- my $href = __PACKAGE__->_parse_uri( $uri ) or return;
-
- ### make it into a FFI object ###
- my $ff = File::Fetch->_create( %$href ) or return;
-
-
- ### return the object ###
- return $ff;
-}
-
-### parses an uri to a hash structure:
-###
-### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' )
-###
-### becomes:
-###
-### $href = {
-### scheme => 'ftp',
-### host => 'ftp.cpan.org',
-### path => '/pub/mirror',
-### file => 'index.html'
-### };
-###
-### In the case of file:// urls there maybe be additional fields
-###
-### For systems with volume specifications such as Win32 there will be
-### a volume specifier provided in the 'vol' field.
-###
-### 'vol' => 'volumename'
-###
-### For windows file shares there may be a 'share' key specified
-###
-### 'share' => 'sharename'
-###
-### Note that the rules of what a file:// url means vary by the operating system
-### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious
-### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and
-### not '/foo/bar.txt'
-###
-### Similarly if the host interpreting the url is VMS then
-### file:///disk$user/my/notes/note12345.txt' means
-### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as
-### if it is unix where it means /disk$user/my/notes/note12345.txt'.
-### Except for some cases in the File::Spec methods, Perl on VMS will generally
-### handle UNIX format file specifications.
-###
-### This means it is impossible to serve certain file:// urls on certain systems.
-###
-### Thus are the problems with a protocol-less specification. :-(
-###
-
-sub _parse_uri {
- my $self = shift;
- my $uri = shift or return;
-
- my $href = { uri => $uri };
-
- ### find the scheme ###
- $uri =~ s|^(\w+)://||;
- $href->{scheme} = $1;
-
- ### See rfc 1738 section 3.10
- ### http://www.faqs.org/rfcs/rfc1738.html
- ### And wikipedia for more on windows file:// urls
- ### http://en.wikipedia.org/wiki/File://
- if( $href->{scheme} eq 'file' ) {
-
- my @parts = split '/',$uri;
-
- ### file://hostname/...
- ### file://hostname/...
- ### normalize file://localhost with file:///
- $href->{host} = $parts[0] || '';
-
- ### index in @parts where the path components begin;
- my $index = 1;
-
- ### file:////hostname/sharename/blah.txt
- if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) {
-
- $href->{host} = $parts[2] || ''; # avoid warnings
- $href->{share} = $parts[3] || ''; # avoid warnings
-
- $index = 4 # index after the share
-
- ### file:///D|/blah.txt
- ### file:///D:/blah.txt
- } elsif (HAS_VOL) {
-
- ### this code comes from dmq's patch, but:
- ### XXX if volume is empty, wouldn't that be an error? --kane
- ### if so, our file://localhost test needs to be fixed as wel
- $href->{vol} = $parts[1] || '';
-
- ### correct D| style colume descriptors
- $href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN;
-
- $index = 2; # index after the volume
- }
-
- ### rebuild the path from the leftover parts;
- $href->{path} = join '/', '', splice( @parts, $index, $#parts );
-
- } else {
- ### using anything but qw() in hash slices may produce warnings
- ### in older perls :-(
- @{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s;
- }
-
- ### split the path into file + dir ###
- { my @parts = File::Spec::Unix->splitpath( delete $href->{path} );
- $href->{path} = $parts[1];
- $href->{file} = $parts[2];
- }
-
- ### host will be empty if the target was 'localhost' and the
- ### scheme was 'file'
- $href->{host} = '' if ($href->{host} eq 'localhost') and
- ($href->{scheme} eq 'file');
-
- return $href;
-}
-
-=head2 $where = $ff->fetch( [to => /my/output/dir/ | \$scalar] )
-
-Fetches the file you requested and returns the full path to the file.
-
-By default it writes to C<cwd()>, but you can override that by specifying
-the C<to> argument:
-
- ### file fetch to /tmp, full path to the file in $where
- $where = $ff->fetch( to => '/tmp' );
-
- ### file slurped into $scalar, full path to the file in $where
- ### file is downloaded to a temp directory and cleaned up at exit time
- $where = $ff->fetch( to => \$scalar );
-
-Returns the full path to the downloaded file on success, and false
-on failure.
-
-=cut
-
-sub fetch {
- my $self = shift or return;
- my %hash = @_;
-
- my $target;
- my $tmpl = {
- to => { default => cwd(), store => \$target },
- };
-
- check( $tmpl, \%hash ) or return;
-
- my ($to, $fh);
- ### you want us to slurp the contents
- if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
- $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 );
-
- ### plain old fetch
- } else {
- $to = $target;
-
- ### On VMS force to VMS format so File::Spec will work.
- $to = VMS::Filespec::vmspath($to) if ON_VMS;
-
- ### create the path if it doesn't exist yet ###
- unless( -d $to ) {
- eval { mkpath( $to ) };
-
- return $self->_error(loc("Could not create path '%1'",$to)) if $@;
- }
- }
-
- ### set passive ftp if required ###
- local $ENV{FTP_PASSIVE} = $FTP_PASSIVE;
-
- ### we dont use catfile on win32 because if we are using a cygwin tool
- ### under cmd.exe they wont understand windows style separators.
- my $out_to = ON_WIN ? $to.'/'.$self->output_file
- : File::Spec->catfile( $to, $self->output_file );
-
- for my $method ( @{ $METHODS->{$self->scheme} } ) {
- my $sub = '_'.$method.'_fetch';
-
- unless( __PACKAGE__->can($sub) ) {
- $self->_error(loc("Cannot call method for '%1' -- WEIRD!",
- $method));
- next;
- }
-
- ### method is blacklisted ###
- next if grep { lc $_ eq $method } @$BLACKLIST;
-
- ### method is known to fail ###
- next if $METHOD_FAIL->{$method};
-
- ### there's serious issues with IPC::Run and quoting of command
- ### line arguments. using quotes in the wrong place breaks things,
- ### and in the case of say,
- ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document
- ### "index.html" "http://www.cpan.org/index.html?q=1&y=2"
- ### it doesn't matter how you quote, it always fails.
- local $IPC::Cmd::USE_IPC_RUN = 0;
-
- if( my $file = $self->$sub(
- to => $out_to
- )){
-
- unless( -e $file && -s _ ) {
- $self->_error(loc("'%1' said it fetched '%2', ".
- "but it was not created",$method,$file));
-
- ### mark the failure ###
- $METHOD_FAIL->{$method} = 1;
-
- next;
-
- } else {
-
- ### slurp mode?
- if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
-
- ### open the file
- open my $fh, $file or do {
- $self->_error(
- loc("Could not open '%1': %2", $file, $!));
- return;
- };
-
- ### slurp
- $$target = do { local $/; <$fh> };
-
- }
-
- my $abs = File::Spec->rel2abs( $file );
- return $abs;
-
- }
- }
- }
-
-
- ### if we got here, we looped over all methods, but we weren't able
- ### to fetch it.
- return;
-}
-
-########################
-### _*_fetch methods ###
-########################
-
-### LWP fetching ###
-sub _lwp_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- ### modules required to download with lwp ###
- my $use_list = {
- LWP => '0.0',
- 'LWP::UserAgent' => '0.0',
- 'HTTP::Request' => '0.0',
- 'HTTP::Status' => '0.0',
- URI => '0.0',
-
- };
-
- if( can_load(modules => $use_list) ) {
-
- ### setup the uri object
- my $uri = URI->new( File::Spec::Unix->catfile(
- $self->path, $self->file
- ) );
-
- ### special rules apply for file:// uris ###
- $uri->scheme( $self->scheme );
- $uri->host( $self->scheme eq 'file' ? '' : $self->host );
- $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
-
- ### set up the useragent object
- my $ua = LWP::UserAgent->new();
- $ua->timeout( $TIMEOUT ) if $TIMEOUT;
- $ua->agent( $USER_AGENT );
- $ua->from( $FROM_EMAIL );
- $ua->env_proxy;
-
- my $res = $ua->mirror($uri, $to) or return;
-
- ### uptodate or fetched ok ###
- if ( $res->code == 304 or $res->code == 200 ) {
- return $to;
-
- } else {
- return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
- $res->code, HTTP::Status::status_message($res->code),
- $res->status_line));
- }
-
- } else {
- $METHOD_FAIL->{'lwp'} = 1;
- return;
- }
-}
-
-### Net::FTP fetching
-sub _netftp_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- ### required modules ###
- my $use_list = { 'Net::FTP' => 0 };
-
- if( can_load( modules => $use_list ) ) {
-
- ### make connection ###
- my $ftp;
- my @options = ($self->host);
- push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
- unless( $ftp = Net::FTP->new( @options ) ) {
- return $self->_error(loc("Ftp creation failed: %1",$@));
- }
-
- ### login ###
- unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
- return $self->_error(loc("Could not login to '%1'",$self->host));
- }
-
- ### set binary mode, just in case ###
- $ftp->binary;
-
- ### create the remote path
- ### remember remote paths are unix paths! [#11483]
- my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
-
- ### fetch the file ###
- my $target;
- unless( $target = $ftp->get( $remote, $to ) ) {
- return $self->_error(loc("Could not fetch '%1' from '%2'",
- $remote, $self->host));
- }
-
- ### log out ###
- $ftp->quit;
-
- return $target;
-
- } else {
- $METHOD_FAIL->{'netftp'} = 1;
- return;
- }
-}
-
-### /bin/wget fetch ###
-sub _wget_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- ### see if we have a wget binary ###
- if( my $wget = can_run('wget') ) {
-
- ### no verboseness, thanks ###
- my $cmd = [ $wget, '--quiet' ];
-
- ### if a timeout is set, add it ###
- push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
-
- ### run passive if specified ###
- push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
-
- ### set the output document, add the uri ###
- push @$cmd, '--output-document', $to, $self->uri;
-
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
-
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG
- )) {
- ### wget creates the output document always, even if the fetch
- ### fails.. so unlink it in that case
- 1 while unlink $to;
-
- return $self->_error(loc( "Command failed: %1", $captured || '' ));
- }
-
- return $to;
-
- } else {
- $METHOD_FAIL->{'wget'} = 1;
- return;
- }
-}
-
-### /bin/lftp fetch ###
-sub _lftp_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- ### see if we have a wget binary ###
- if( my $lftp = can_run('lftp') ) {
-
- ### no verboseness, thanks ###
- my $cmd = [ $lftp, '-f' ];
-
- my $fh = File::Temp->new;
-
- my $str;
-
- ### if a timeout is set, add it ###
- $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
-
- ### run passive if specified ###
- $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
-
- ### set the output document, add the uri ###
- ### quote the URI, because lftp supports certain shell
- ### expansions, most notably & for backgrounding.
- ### ' quote does nto work, must be "
- $str .= q[get ']. $self->uri .q[' -o ]. $to . $/;
-
- if( $DEBUG ) {
- my $pp_str = join ' ', split $/, $str;
- print "# lftp command: $pp_str\n";
- }
-
- ### write straight to the file.
- $fh->autoflush(1);
- print $fh $str;
-
- ### the command needs to be 1 string to be executed
- push @$cmd, $fh->filename;
-
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
-
-
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG
- )) {
- ### wget creates the output document always, even if the fetch
- ### fails.. so unlink it in that case
- 1 while unlink $to;
-
- return $self->_error(loc( "Command failed: %1", $captured || '' ));
- }
-
- return $to;
-
- } else {
- $METHOD_FAIL->{'lftp'} = 1;
- return;
- }
-}
-
-
-
-### /bin/ftp fetch ###
-sub _ftp_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- ### see if we have a ftp binary ###
- if( my $ftp = can_run('ftp') ) {
-
- my $fh = FileHandle->new;
-
- local $SIG{CHLD} = 'IGNORE';
-
- unless ($fh->open("|$ftp -n")) {
- return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
- }
-
- my @dialog = (
- "lcd " . dirname($to),
- "open " . $self->host,
- "user anonymous $FROM_EMAIL",
- "cd /",
- "cd " . $self->path,
- "binary",
- "get " . $self->file . " " . $self->output_file,
- "quit",
- );
-
- foreach (@dialog) { $fh->print($_, "\n") }
- $fh->close or return;
-
- return $to;
- }
-}
-
-### lynx is stupid - it decompresses any .gz file it finds to be text
-### use /bin/lynx to fetch files
-sub _lynx_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- ### see if we have a lynx binary ###
- if( my $lynx = can_run('lynx') ) {
-
- unless( IPC::Cmd->can_capture_buffer ) {
- $METHOD_FAIL->{'lynx'} = 1;
-
- return $self->_error(loc(
- "Can not capture buffers. Can not use '%1' to fetch files",
- 'lynx' ));
- }
-
- ### check if the HTTP resource exists ###
- if ($self->uri =~ /^https?:\/\//i) {
- my $cmd = [
- $lynx,
- '-head',
- '-source',
- "-auth=anonymous:$FROM_EMAIL",
- ];
-
- push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
-
- push @$cmd, $self->uri;
-
- ### shell out ###
- my $head;
- unless(run( command => $cmd,
- buffer => \$head,
- verbose => $DEBUG )
- ) {
- return $self->_error(loc("Command failed: %1", $head || ''));
- }
-
- unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
- return $self->_error(loc("Command failed: %1", $head || ''));
- }
- }
-
- ### write to the output file ourselves, since lynx ass_u_mes to much
- my $local = FileHandle->new(">$to")
- or return $self->_error(loc(
- "Could not open '%1' for writing: %2",$to,$!));
-
- ### dump to stdout ###
- my $cmd = [
- $lynx,
- '-source',
- "-auth=anonymous:$FROM_EMAIL",
- ];
-
- push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
-
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $self->uri;
-
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? $self->uri
- # : QUOTE. $self->uri .QUOTE;
-
-
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
- return $self->_error(loc("Command failed: %1", $captured || ''));
- }
-
- ### print to local file ###
- ### XXX on a 404 with a special error page, $captured will actually
- ### hold the contents of that page, and make it *appear* like the
- ### request was a success, when really it wasn't :(
- ### there doesn't seem to be an option for lynx to change the exit
- ### code based on a 4XX status or so.
- ### the closest we can come is using --error_file and parsing that,
- ### which is very unreliable ;(
- $local->print( $captured );
- $local->close or return;
-
- return $to;
-
- } else {
- $METHOD_FAIL->{'lynx'} = 1;
- return;
- }
-}
-
-### use /bin/ncftp to fetch files
-sub _ncftp_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- ### we can only set passive mode in interactive sesssions, so bail out
- ### if $FTP_PASSIVE is set
- return if $FTP_PASSIVE;
-
- ### see if we have a ncftp binary ###
- if( my $ncftp = can_run('ncftp') ) {
-
- my $cmd = [
- $ncftp,
- '-V', # do not be verbose
- '-p', $FROM_EMAIL, # email as password
- $self->host, # hostname
- dirname($to), # local dir for the file
- # remote path to the file
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- $IPC::Cmd::USE_IPC_RUN
- ? File::Spec::Unix->catdir( $self->path, $self->file )
- : QUOTE. File::Spec::Unix->catdir(
- $self->path, $self->file ) .QUOTE
-
- ];
-
- ### shell out ###
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
- return $self->_error(loc("Command failed: %1", $captured || ''));
- }
-
- return $to;
-
- } else {
- $METHOD_FAIL->{'ncftp'} = 1;
- return;
- }
-}
-
-### use /bin/curl to fetch files
-sub _curl_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- if (my $curl = can_run('curl')) {
-
- ### these long opts are self explanatory - I like that -jmb
- my $cmd = [ $curl, '-q' ];
-
- push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
-
- push(@$cmd, '--silent') unless $DEBUG;
-
- ### curl does the right thing with passive, regardless ###
- if ($self->scheme eq 'ftp') {
- push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
- }
-
- ### curl doesn't follow 302 (temporarily moved) etc automatically
- ### so we add --location to enable that.
- push @$cmd, '--fail', '--location', '--output', $to, $self->uri;
-
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
-
-
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
-
- return $self->_error(loc("Command failed: %1", $captured || ''));
- }
-
- return $to;
-
- } else {
- $METHOD_FAIL->{'curl'} = 1;
- return;
- }
-}
-
-
-### use File::Copy for fetching file:// urls ###
-###
-### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html)
-### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://)
-###
-
-sub _file_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
-
-
- ### prefix a / on unix systems with a file uri, since it would
- ### look somewhat like this:
- ### file:///home/kane/file
- ### wheras windows file uris for 'c:\some\dir\file' might look like:
- ### file:///C:/some/dir/file
- ### file:///C|/some/dir/file
- ### or for a network share '\\host\share\some\dir\file':
- ### file:////host/share/some/dir/file
- ###
- ### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like:
- ### file://vms.host.edu/disk$user/my/notes/note12345.txt
- ###
-
- my $path = $self->path;
- my $vol = $self->vol;
- my $share = $self->share;
-
- my $remote;
- if (!$share and $self->host) {
- return $self->_error(loc(
- "Currently %1 cannot handle hosts in %2 urls",
- 'File::Fetch', 'file://'
- ));
- }
-
- if( $vol ) {
- $path = File::Spec->catdir( split /\//, $path );
- $remote = File::Spec->catpath( $vol, $path, $self->file);
-
- } elsif( $share ) {
- ### win32 specific, and a share name, so we wont bother with File::Spec
- $path =~ s|/+|\\|g;
- $remote = "\\\\".$self->host."\\$share\\$path";
-
- } else {
- ### File::Spec on VMS can not currently handle UNIX syntax.
- my $file_class = ON_VMS
- ? 'File::Spec::Unix'
- : 'File::Spec';
-
- $remote = $file_class->catfile( $path, $self->file );
- }
-
- ### File::Copy is littered with 'die' statements :( ###
- my $rv = eval { File::Copy::copy( $remote, $to ) };
-
- ### something went wrong ###
- if( !$rv or $@ ) {
- return $self->_error(loc("Could not copy '%1' to '%2': %3 %4",
- $remote, $to, $!, $@));
- }
-
- return $to;
-}
-
-### use /usr/bin/rsync to fetch files
-sub _rsync_fetch {
- my $self = shift;
- my %hash = @_;
-
- my ($to);
- my $tmpl = {
- to => { required => 1, store => \$to }
- };
- check( $tmpl, \%hash ) or return;
-
- if (my $rsync = can_run('rsync')) {
-
- my $cmd = [ $rsync ];
-
- ### XXX: rsync has no I/O timeouts at all, by default
- push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
-
- push(@$cmd, '--quiet') unless $DEBUG;
-
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $self->uri, $to;
-
- ### with IPC::Cmd > 0.41, this is fixed in teh library,
- ### and there's no need for special casing any more.
- ### DO NOT quote things for IPC::Run, it breaks stuff.
- # $IPC::Cmd::USE_IPC_RUN
- # ? ($to, $self->uri)
- # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
-
- my $captured;
- unless(run( command => $cmd,
- buffer => \$captured,
- verbose => $DEBUG )
- ) {
-
- return $self->_error(loc("Command %1 failed: %2",
- "@$cmd" || '', $captured || ''));
- }
-
- return $to;
-
- } else {
- $METHOD_FAIL->{'rsync'} = 1;
- return;
- }
-}
-
-#################################
-#
-# Error code
-#
-#################################
-
-=pod
-
-=head2 $ff->error([BOOL])
-
-Returns the last encountered error as string.
-Pass it a true value to get the C<Carp::longmess()> output instead.
-
-=cut
-
-### error handling the way Archive::Extract does it
-sub _error {
- my $self = shift;
- my $error = shift;
-
- $self->_error_msg( $error );
- $self->_error_msg_long( Carp::longmess($error) );
-
- if( $WARN ) {
- carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
- }
-
- return;
-}
-
-sub error {
- my $self = shift;
- return shift() ? $self->_error_msg_long : $self->_error_msg;
-}
-
-
-1;
-
-=pod
-
-=head1 HOW IT WORKS
-
-File::Fetch is able to fetch a variety of uris, by using several
-external programs and modules.
-
-Below is a mapping of what utilities will be used in what order
-for what schemes, if available:
-
- file => LWP, lftp, file
- http => LWP, wget, curl, lftp, lynx
- ftp => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp
- rsync => rsync
-
-If you'd like to disable the use of one or more of these utilities
-and/or modules, see the C<$BLACKLIST> variable further down.
-
-If a utility or module isn't available, it will be marked in a cache
-(see the C<$METHOD_FAIL> variable further down), so it will not be
-tried again. The C<fetch> method will only fail when all options are
-exhausted, and it was not able to retrieve the file.
-
-A special note about fetching files from an ftp uri:
-
-By default, all ftp connections are done in passive mode. To change
-that, see the C<$FTP_PASSIVE> variable further down.
-
-Furthermore, ftp uris only support anonymous connections, so no
-named user/password pair can be passed along.
-
-C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable
-further down.
-
-=head1 GLOBAL VARIABLES
-
-The behaviour of File::Fetch can be altered by changing the following
-global variables:
-
-=head2 $File::Fetch::FROM_EMAIL
-
-This is the email address that will be sent as your anonymous ftp
-password.
-
-Default is C<File-Fetch at example.com>.
-
-=head2 $File::Fetch::USER_AGENT
-
-This is the useragent as C<LWP> will report it.
-
-Default is C<File::Fetch/$VERSION>.
-
-=head2 $File::Fetch::FTP_PASSIVE
-
-This variable controls whether the environment variable C<FTP_PASSIVE>
-and any passive switches to commandline tools will be set to true.
-
-Default value is 1.
-
-Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch
-files, since passive mode can only be set interactively for this binary
-
-=head2 $File::Fetch::TIMEOUT
-
-When set, controls the network timeout (counted in seconds).
-
-Default value is 0.
-
-=head2 $File::Fetch::WARN
-
-This variable controls whether errors encountered internally by
-C<File::Fetch> should be C<carp>'d or not.
-
-Set to false to silence warnings. Inspect the output of the C<error()>
-method manually to see what went wrong.
-
-Defaults to C<true>.
-
-=head2 $File::Fetch::DEBUG
-
-This enables debugging output when calling commandline utilities to
-fetch files.
-This also enables C<Carp::longmess> errors, instead of the regular
-C<carp> errors.
-
-Good for tracking down why things don't work with your particular
-setup.
-
-Default is 0.
-
-=head2 $File::Fetch::BLACKLIST
-
-This is an array ref holding blacklisted modules/utilities for fetching
-files with.
-
-To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could
-set $File::Fetch::BLACKLIST to:
-
- $File::Fetch::BLACKLIST = [qw|lwp netftp|]
-
-The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable.
-
-See the note on C<MAPPING> below.
-
-=head2 $File::Fetch::METHOD_FAIL
-
-This is a hashref registering what modules/utilities were known to fail
-for fetching files (mostly because they weren't installed).
-
-You can reset this cache by assigning an empty hashref to it, or
-individually remove keys.
-
-See the note on C<MAPPING> below.
-
-=head1 MAPPING
-
-
-Here's a quick mapping for the utilities/modules, and their names for
-the $BLACKLIST, $METHOD_FAIL and other internal functions.
-
- LWP => lwp
- Net::FTP => netftp
- wget => wget
- lynx => lynx
- ncftp => ncftp
- ftp => ftp
- curl => curl
- rsync => rsync
- lftp => lftp
-
-=head1 FREQUENTLY ASKED QUESTIONS
-
-=head2 So how do I use a proxy with File::Fetch?
-
-C<File::Fetch> currently only supports proxies with LWP::UserAgent.
-You will need to set your environment variables accordingly. For
-example, to use an ftp proxy:
-
- $ENV{ftp_proxy} = 'foo.com';
-
-Refer to the LWP::UserAgent manpage for more details.
-
-=head2 I used 'lynx' to fetch a file, but its contents is all wrong!
-
-C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>,
-which we in turn capture. If that content is a 'custom' error file
-(like, say, a C<404 handler>), you will get that contents instead.
-
-Sadly, C<lynx> doesn't support any options to return a different exit
-code on non-C<200 OK> status, giving us no way to tell the difference
-between a 'successfull' fetch and a custom error page.
-
-Therefor, we recommend to only use C<lynx> as a last resort. This is
-why it is at the back of our list of methods to try as well.
-
-=head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
-
-C<File::Fetch> is relatively smart about things. When trying to write
-a file to disk, it removes the C<query parameters> (see the
-C<output_file> method for details) from the file name before creating
-it. In most cases this suffices.
-
-If you have any other characters you need to escape, please install
-the C<URI::Escape> module from CPAN, and pre-encode your URI before
-passing it to C<File::Fetch>. You can read about the details of URIs
-and URI encoding here:
-
- http://www.faqs.org/rfcs/rfc2396.html
-
-=head1 TODO
-
-=over 4
-
-=item Implement $PREFER_BIN
-
-To indicate to rather use commandline tools than modules
-
-=back
-
-=head1 BUG REPORTS
-
-Please report bugs or other issues to E<lt>bug-file-fetch at rt.cpan.org<gt>.
-
-=head1 AUTHOR
-
-This module by Jos Boumans E<lt>kane at cpan.orgE<gt>.
-
-=head1 COPYRIGHT
-
-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:
-
-
-
-
Deleted: trunk/contrib/perl/lib/File/Path.pm
===================================================================
--- trunk/contrib/perl/lib/File/Path.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/File/Path.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,895 +0,0 @@
-package File::Path;
-
-use 5.005_04;
-use strict;
-
-use Cwd 'getcwd';
-use File::Basename ();
-use File::Spec ();
-
-BEGIN {
- if ($] < 5.006) {
- # can't say 'opendir my $dh, $dirname'
- # need to initialise $dh
- eval "use Symbol";
- }
-}
-
-use Exporter ();
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = '2.07_03';
- at ISA = qw(Exporter);
- at EXPORT = qw(mkpath rmtree);
- at EXPORT_OK = qw(make_path remove_tree);
-
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MacOS = $^O eq 'MacOS';
-
-# These OSes complain if you want to remove a file that you have no
-# write permission to:
-my $Force_Writeable = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
-
-# Unix-like systems need to stat each directory in order to detect
-# race condition. MS-Windows is immune to this particular attack.
-my $Need_Stat_Check = !($^O eq 'MSWin32');
-
-sub _carp {
- require Carp;
- goto &Carp::carp;
-}
-
-sub _croak {
- require Carp;
- goto &Carp::croak;
-}
-
-sub _error {
- my $arg = shift;
- my $message = shift;
- my $object = shift;
-
- if ($arg->{error}) {
- $object = '' unless defined $object;
- $message .= ": $!" if $!;
- push @{${$arg->{error}}}, {$object => $message};
- }
- else {
- _carp(defined($object) ? "$message for $object: $!" : "$message: $!");
- }
-}
-
-sub make_path {
- push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH');
- goto &mkpath;
-}
-
-sub mkpath {
- my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
-
- my $arg;
- my $paths;
-
- if ($old_style) {
- my ($verbose, $mode);
- ($paths, $verbose, $mode) = @_;
- $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
- $arg->{verbose} = $verbose;
- $arg->{mode} = defined $mode ? $mode : 0777;
- }
- else {
- $arg = pop @_;
- $arg->{mode} = delete $arg->{mask} if exists $arg->{mask};
- $arg->{mode} = 0777 unless exists $arg->{mode};
- ${$arg->{error}} = [] if exists $arg->{error};
- $paths = [@_];
- }
- return _mkpath($arg, $paths);
-}
-
-sub _mkpath {
- my $arg = shift;
- my $paths = shift;
-
- my(@created,$path);
- foreach $path (@$paths) {
- next unless defined($path) and length($path);
- $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT
- # Logic wants Unix paths, so go with the flow.
- if ($Is_VMS) {
- next if $path eq '/';
- $path = VMS::Filespec::unixify($path);
- }
- next if -d $path;
- my $parent = File::Basename::dirname($path);
- unless (-d $parent or $path eq $parent) {
- push(@created,_mkpath($arg, [$parent]));
- }
- print "mkdir $path\n" if $arg->{verbose};
- if (mkdir($path,$arg->{mode})) {
- push(@created, $path);
- }
- else {
- my $save_bang = $!;
- my ($e, $e1) = ($save_bang, $^E);
- $e .= "; $e1" if $e ne $e1;
- # allow for another process to have created it meanwhile
- if (!-d $path) {
- $! = $save_bang;
- if ($arg->{error}) {
- push @{${$arg->{error}}}, {$path => $e};
- }
- else {
- _croak("mkdir $path: $e");
- }
- }
- }
- }
- return @created;
-}
-
-sub remove_tree {
- push @_, {} unless @_ and UNIVERSAL::isa($_[-1],'HASH');
- goto &rmtree;
-}
-
-sub _is_subdir {
- my($dir, $test) = @_;
-
- my($dv, $dd) = File::Spec->splitpath($dir, 1);
- my($tv, $td) = File::Spec->splitpath($test, 1);
-
- # not on same volume
- return 0 if $dv ne $tv;
-
- my @d = File::Spec->splitdir($dd);
- my @t = File::Spec->splitdir($td);
-
- # @t can't be a subdir if it's shorter than @d
- return 0 if @t < @d;
-
- return join('/', @d) eq join('/', splice @t, 0, + at d);
-}
-
-sub rmtree {
- my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
-
- my $arg;
- my $paths;
-
- if ($old_style) {
- my ($verbose, $safe);
- ($paths, $verbose, $safe) = @_;
- $arg->{verbose} = $verbose;
- $arg->{safe} = defined $safe ? $safe : 0;
-
- if (defined($paths) and length($paths)) {
- $paths = [$paths] unless UNIVERSAL::isa($paths,'ARRAY');
- }
- else {
- _carp ("No root path(s) specified\n");
- return 0;
- }
- }
- else {
- $arg = pop @_;
- ${$arg->{error}} = [] if exists $arg->{error};
- ${$arg->{result}} = [] if exists $arg->{result};
- $paths = [@_];
- }
-
- $arg->{prefix} = '';
- $arg->{depth} = 0;
-
- my @clean_path;
- $arg->{cwd} = getcwd() or do {
- _error($arg, "cannot fetch initial working directory");
- return 0;
- };
- for ($arg->{cwd}) { /\A(.*)\Z/; $_ = $1 } # untaint
-
- for my $p (@$paths) {
- # need to fixup case and map \ to / on Windows
- my $ortho_root = $^O eq 'MSWin32' ? _slash_lc($p) : $p;
- my $ortho_cwd = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd};
- my $ortho_root_length = length($ortho_root);
- $ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']'
- if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) {
- local $! = 0;
- _error($arg, "cannot remove path when cwd is $arg->{cwd}", $p);
- next;
- }
-
- if ($Is_MacOS) {
- $p = ":$p" unless $p =~ /:/;
- $p .= ":" unless $p =~ /:\z/;
- }
- elsif ($^O eq 'MSWin32') {
- $p =~ s{[/\\]\z}{};
- }
- else {
- $p =~ s{/\z}{};
- }
- push @clean_path, $p;
- }
-
- @{$arg}{qw(device inode perm)} = (lstat $arg->{cwd})[0,1] or do {
- _error($arg, "cannot stat initial working directory", $arg->{cwd});
- return 0;
- };
-
- return _rmtree($arg, \@clean_path);
-}
-
-sub _rmtree {
- my $arg = shift;
- my $paths = shift;
-
- my $count = 0;
- my $curdir = File::Spec->curdir();
- my $updir = File::Spec->updir();
-
- my (@files, $root);
- ROOT_DIR:
- foreach $root (@$paths) {
- # since we chdir into each directory, it may not be obvious
- # to figure out where we are if we generate a message about
- # a file name. We therefore construct a semi-canonical
- # filename, anchored from the directory being unlinked (as
- # opposed to being truly canonical, anchored from the root (/).
-
- my $canon = $arg->{prefix}
- ? File::Spec->catfile($arg->{prefix}, $root)
- : $root
- ;
-
- my ($ldev, $lino, $perm) = (lstat $root)[0,1,2] or next ROOT_DIR;
-
- if ( -d _ ) {
- $root = VMS::Filespec::pathify($root) if $Is_VMS;
-
- if (!chdir($root)) {
- # see if we can escalate privileges to get in
- # (e.g. funny protection mask such as -w- instead of rwx)
- $perm &= 07777;
- my $nperm = $perm | 0700;
- if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $root))) {
- _error($arg, "cannot make child directory read-write-exec", $canon);
- next ROOT_DIR;
- }
- elsif (!chdir($root)) {
- _error($arg, "cannot chdir to child", $canon);
- next ROOT_DIR;
- }
- }
-
- my ($cur_dev, $cur_inode, $perm) = (stat $curdir)[0,1,2] or do {
- _error($arg, "cannot stat current working directory", $canon);
- next ROOT_DIR;
- };
-
- if ($Need_Stat_Check) {
- ($ldev eq $cur_dev and $lino eq $cur_inode)
- or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
- }
-
- $perm &= 07777; # don't forget setuid, setgid, sticky bits
- my $nperm = $perm | 0700;
-
- # notabene: 0700 is for making readable in the first place,
- # it's also intended to change it to writable in case we have
- # to recurse in which case we are better than rm -rf for
- # subtrees with strange permissions
-
- if (!($arg->{safe} or $nperm == $perm or chmod($nperm, $curdir))) {
- _error($arg, "cannot make directory read+writeable", $canon);
- $nperm = $perm;
- }
-
- my $d;
- $d = gensym() if $] < 5.006;
- if (!opendir $d, $curdir) {
- _error($arg, "cannot opendir", $canon);
- @files = ();
- }
- else {
- no strict 'refs';
- if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
- # Blindly untaint dir names if taint mode is
- # active, or any perl < 5.006
- @files = map { /\A(.*)\z/s; $1 } readdir $d;
- }
- else {
- @files = readdir $d;
- }
- closedir $d;
- }
-
- if ($Is_VMS) {
- # Deleting large numbers of files from VMS Files-11
- # filesystems is faster if done in reverse ASCIIbetical order.
- # include '.' to '.;' from blead patch #31775
- @files = map {$_ eq '.' ? '.;' : $_} reverse @files;
- ($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//;
- }
-
- @files = grep {$_ ne $updir and $_ ne $curdir} @files;
-
- if (@files) {
- # remove the contained files before the directory itself
- my $narg = {%$arg};
- @{$narg}{qw(device inode cwd prefix depth)}
- = ($cur_dev, $cur_inode, $updir, $canon, $arg->{depth}+1);
- $count += _rmtree($narg, \@files);
- }
-
- # restore directory permissions of required now (in case the rmdir
- # below fails), while we are still in the directory and may do so
- # without a race via '.'
- if ($nperm != $perm and not chmod($perm, $curdir)) {
- _error($arg, "cannot reset chmod", $canon);
- }
-
- # don't leave the client code in an unexpected directory
- chdir($arg->{cwd})
- or _croak("cannot chdir to $arg->{cwd} from $canon: $!, aborting.");
-
- # ensure that a chdir upwards didn't take us somewhere other
- # than we expected (see CVE-2002-0435)
- ($cur_dev, $cur_inode) = (stat $curdir)[0,1]
- or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting.");
-
- if ($Need_Stat_Check) {
- ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode)
- or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
- }
-
- if ($arg->{depth} or !$arg->{keep_root}) {
- if ($arg->{safe} &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
- print "skipped $root\n" if $arg->{verbose};
- next ROOT_DIR;
- }
- if ($Force_Writeable and !chmod $perm | 0700, $root) {
- _error($arg, "cannot make directory writeable", $canon);
- }
- print "rmdir $root\n" if $arg->{verbose};
- if (rmdir $root) {
- push @{${$arg->{result}}}, $root if $arg->{result};
- ++$count;
- }
- else {
- _error($arg, "cannot remove directory", $canon);
- if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- ) {
- _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
- }
- }
- }
- }
- else {
- # not a directory
- $root = VMS::Filespec::vmsify("./$root")
- if $Is_VMS
- && !File::Spec->file_name_is_absolute($root)
- && ($root !~ m/(?<!\^)[\]>]+/); # not already in VMS syntax
-
- if ($arg->{safe} &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root)
- : !(-l $root || -w $root)))
- {
- print "skipped $root\n" if $arg->{verbose};
- next ROOT_DIR;
- }
-
- my $nperm = $perm & 07777 | 0600;
- if ($Force_Writeable and $nperm != $perm and not chmod $nperm, $root) {
- _error($arg, "cannot make file writeable", $canon);
- }
- print "unlink $canon\n" if $arg->{verbose};
- # delete all versions under VMS
- for (;;) {
- if (unlink $root) {
- push @{${$arg->{result}}}, $root if $arg->{result};
- }
- else {
- _error($arg, "cannot unlink file", $canon);
- $Force_Writeable and chmod($perm, $root) or
- _error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
- last;
- }
- ++$count;
- last unless $Is_VMS && lstat $root;
- }
- }
- }
- return $count;
-}
-
-sub _slash_lc {
- # fix up slashes and case on MSWin32 so that we can determine that
- # c:\path\to\dir is underneath C:/Path/To
- my $path = shift;
- $path =~ tr{\\}{/};
- return lc($path);
-}
-
-1;
-__END__
-
-=head1 NAME
-
-File::Path - Create or remove directory trees
-
-=head1 VERSION
-
-This document describes version 2.07 of File::Path, released
-2008-11-09.
-
-=head1 SYNOPSIS
-
- use File::Path qw(make_path remove_tree);
-
- make_path('foo/bar/baz', '/zug/zwang');
- make_path('foo/bar/baz', '/zug/zwang', {
- verbose => 1,
- mode => 0711,
- });
-
- remove_tree('foo/bar/baz', '/zug/zwang');
- remove_tree('foo/bar/baz', '/zug/zwang', {
- verbose => 1,
- error => \my $err_list,
- });
-
- # legacy (interface promoted before v2.00)
- mkpath('/foo/bar/baz');
- mkpath('/foo/bar/baz', 1, 0711);
- mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
- rmtree('foo/bar/baz', 1, 1);
- rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
-
- # legacy (interface promoted before v2.06)
- mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
- rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
-
-=head1 DESCRIPTION
-
-This module provide a convenient way to create directories of
-arbitrary depth and to delete an entire directory subtree from the
-filesystem.
-
-The following functions are provided:
-
-=over
-
-=item make_path( $dir1, $dir2, .... )
-
-=item make_path( $dir1, $dir2, ...., \%opts )
-
-The C<make_path> function creates the given directories if they don't
-exists before, much like the Unix command C<mkdir -p>.
-
-The function accepts a list of directories to be created. Its
-behaviour may be tuned by an optional hashref appearing as the last
-parameter on the call.
-
-The function returns the list of directories actually created during
-the call; in scalar context the number of directories created.
-
-The following keys are recognised in the option hash:
-
-=over
-
-=item mode => $num
-
-The numeric permissions mode to apply to each created directory
-(defaults to 0777), to be modified by the current C<umask>. If the
-directory already exists (and thus does not need to be created),
-the permissions will not be modified.
-
-C<mask> is recognised as an alias for this parameter.
-
-=item verbose => $bool
-
-If present, will cause C<make_path> to print the name of each directory
-as it is created. By default nothing is printed.
-
-=item error => \$err
-
-If present, it should be a reference to a scalar.
-This scalar will be made to reference an array, which will
-be used to store any errors that are encountered. See the L</"ERROR
-HANDLING"> section for more information.
-
-If this parameter is not used, certain error conditions may raise
-a fatal error that will cause the program will halt, unless trapped
-in an C<eval> block.
-
-=back
-
-=item mkpath( $dir )
-
-=item mkpath( $dir, $verbose, $mode )
-
-=item mkpath( [$dir1, $dir2,...], $verbose, $mode )
-
-=item mkpath( $dir1, $dir2,..., \%opt )
-
-The mkpath() function provide the legacy interface of make_path() with
-a different interpretation of the arguments passed. The behaviour and
-return value of the function is otherwise identical to make_path().
-
-=item remove_tree( $dir1, $dir2, .... )
-
-=item remove_tree( $dir1, $dir2, ...., \%opts )
-
-The C<remove_tree> function deletes the given directories and any
-files and subdirectories they might contain, much like the Unix
-command C<rm -r> or C<del /s> on Windows.
-
-The function accepts a list of directories to be
-removed. Its behaviour may be tuned by an optional hashref
-appearing as the last parameter on the call.
-
-The functions returns the number of files successfully deleted.
-
-The following keys are recognised in the option hash:
-
-=over
-
-=item verbose => $bool
-
-If present, will cause C<remove_tree> to print the name of each file as
-it is unlinked. By default nothing is printed.
-
-=item safe => $bool
-
-When set to a true value, will cause C<remove_tree> to skip the files
-for which the process lacks the required privileges needed to delete
-files, such as delete privileges on VMS. In other words, the code
-will make no attempt to alter file permissions. Thus, if the process
-is interrupted, no filesystem object will be left in a more
-permissive mode.
-
-=item keep_root => $bool
-
-When set to a true value, will cause all files and subdirectories
-to be removed, except the initially specified directories. This comes
-in handy when cleaning out an application's scratch directory.
-
- remove_tree( '/tmp', {keep_root => 1} );
-
-=item result => \$res
-
-If present, it should be a reference to a scalar.
-This scalar will be made to reference an array, which will
-be used to store all files and directories unlinked
-during the call. If nothing is unlinked, the array will be empty.
-
- remove_tree( '/tmp', {result => \my $list} );
- print "unlinked $_\n" for @$list;
-
-This is a useful alternative to the C<verbose> key.
-
-=item error => \$err
-
-If present, it should be a reference to a scalar.
-This scalar will be made to reference an array, which will
-be used to store any errors that are encountered. See the L</"ERROR
-HANDLING"> section for more information.
-
-Removing things is a much more dangerous proposition than
-creating things. As such, there are certain conditions that
-C<remove_tree> may encounter that are so dangerous that the only
-sane action left is to kill the program.
-
-Use C<error> to trap all that is reasonable (problems with
-permissions and the like), and let it die if things get out
-of hand. This is the safest course of action.
-
-=back
-
-=item rmtree( $dir )
-
-=item rmtree( $dir, $verbose, $safe )
-
-=item rmtree( [$dir1, $dir2,...], $verbose, $safe )
-
-=item rmtree( $dir1, $dir2,..., \%opt )
-
-The rmtree() function provide the legacy interface of remove_tree()
-with a different interpretation of the arguments passed. The behaviour
-and return value of the function is otherwise identical to
-remove_tree().
-
-=back
-
-=head2 ERROR HANDLING
-
-=over 4
-
-=item B<NOTE:>
-
-The following error handling mechanism is considered
-experimental and is subject to change pending feedback from
-users.
-
-=back
-
-If C<make_path> or C<remove_tree> encounter an error, a diagnostic
-message will be printed to C<STDERR> via C<carp> (for non-fatal
-errors), or via C<croak> (for fatal errors).
-
-If this behaviour is not desirable, the C<error> attribute may be
-used to hold a reference to a variable, which will be used to store
-the diagnostics. The variable is made a reference to an array of hash
-references. Each hash contain a single key/value pair where the key
-is the name of the file, and the value is the error message (including
-the contents of C<$!> when appropriate). If a general error is
-encountered the diagnostic key will be empty.
-
-An example usage looks like:
-
- remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} );
- if (@$err) {
- for my $diag (@$err) {
- my ($file, $message) = %$diag;
- if ($file eq '') {
- print "general error: $message\n";
- }
- else {
- print "problem unlinking $file: $message\n";
- }
- }
- }
- else {
- print "No error encountered\n";
- }
-
-Note that if no errors are encountered, C<$err> will reference an
-empty array. This means that C<$err> will always end up TRUE; so you
-need to test C<@$err> to determine if errors occured.
-
-=head2 NOTES
-
-C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
-current namespace. These days, this is considered bad style, but
-to change it now would break too much code. Nonetheless, you are
-invited to specify what it is you are expecting to use:
-
- use File::Path 'rmtree';
-
-The routines C<make_path> and C<remove_tree> are B<not> exported
-by default. You must specify which ones you want to use.
-
- use File::Path 'remove_tree';
-
-Note that a side-effect of the above is that C<mkpath> and C<rmtree>
-are no longer exported at all. This is due to the way the C<Exporter>
-module works. If you are migrating a codebase to use the new
-interface, you will have to list everything explicitly. But that's
-just good practice anyway.
-
- use File::Path qw(remove_tree rmtree);
-
-=head3 SECURITY CONSIDERATIONS
-
-There were race conditions 1.x implementations of File::Path's
-C<rmtree> function (although sometimes patched depending on the OS
-distribution or platform). The 2.0 version contains code to avoid the
-problem mentioned in CVE-2002-0435.
-
-See the following pages for more information:
-
- http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905
- http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html
- http://www.debian.org/security/2005/dsa-696
-
-Additionally, unless the C<safe> parameter is set (or the
-third parameter in the traditional interface is TRUE), should a
-C<remove_tree> be interrupted, files that were originally in read-only
-mode may now have their permissions set to a read-write (or "delete
-OK") mode.
-
-=head1 DIAGNOSTICS
-
-FATAL errors will cause the program to halt (C<croak>), since the
-problem is so severe that it would be dangerous to continue. (This
-can always be trapped with C<eval>, but it's not a good idea. Under
-the circumstances, dying is the best thing to do).
-
-SEVERE errors may be trapped using the modern interface. If the
-they are not trapped, or the old interface is used, such an error
-will cause the program will halt.
-
-All other errors may be trapped using the modern interface, otherwise
-they will be C<carp>ed about. Program execution will not be halted.
-
-=over 4
-
-=item mkdir [path]: [errmsg] (SEVERE)
-
-C<make_path> was unable to create the path. Probably some sort of
-permissions error at the point of departure, or insufficient resources
-(such as free inodes on Unix).
-
-=item No root path(s) specified
-
-C<make_path> was not given any paths to create. This message is only
-emitted if the routine is called with the traditional interface.
-The modern interface will remain silent if given nothing to do.
-
-=item No such file or directory
-
-On Windows, if C<make_path> gives you this warning, it may mean that
-you have exceeded your filesystem's maximum path length.
-
-=item cannot fetch initial working directory: [errmsg]
-
-C<remove_tree> attempted to determine the initial directory by calling
-C<Cwd::getcwd>, but the call failed for some reason. No attempt
-will be made to delete anything.
-
-=item cannot stat initial working directory: [errmsg]
-
-C<remove_tree> attempted to stat the initial directory (after having
-successfully obtained its name via C<getcwd>), however, the call
-failed for some reason. No attempt will be made to delete anything.
-
-=item cannot chdir to [dir]: [errmsg]
-
-C<remove_tree> attempted to set the working directory in order to
-begin deleting the objects therein, but was unsuccessful. This is
-usually a permissions issue. The routine will continue to delete
-other things, but this directory will be left intact.
-
-=item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
-
-C<remove_tree> recorded the device and inode of a directory, and then
-moved into it. It then performed a C<stat> on the current directory
-and detected that the device and inode were no longer the same. As
-this is at the heart of the race condition problem, the program
-will die at this point.
-
-=item cannot make directory [dir] read+writeable: [errmsg]
-
-C<remove_tree> attempted to change the permissions on the current directory
-to ensure that subsequent unlinkings would not run into problems,
-but was unable to do so. The permissions remain as they were, and
-the program will carry on, doing the best it can.
-
-=item cannot read [dir]: [errmsg]
-
-C<remove_tree> tried to read the contents of the directory in order
-to acquire the names of the directory entries to be unlinked, but
-was unsuccessful. This is usually a permissions issue. The
-program will continue, but the files in this directory will remain
-after the call.
-
-=item cannot reset chmod [dir]: [errmsg]
-
-C<remove_tree>, after having deleted everything in a directory, attempted
-to restore its permissions to the original state but failed. The
-directory may wind up being left behind.
-
-=item cannot remove [dir] when cwd is [dir]
-
-The current working directory of the program is F</some/path/to/here>
-and you are attempting to remove an ancestor, such as F</some/path>.
-The directory tree is left untouched.
-
-The solution is to C<chdir> out of the child directory to a place
-outside the directory tree to be removed.
-
-=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
-
-C<remove_tree>, after having deleted everything and restored the permissions
-of a directory, was unable to chdir back to the parent. The program
-halts to avoid a race condition from occurring.
-
-=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
-
-C<remove_tree> was unable to stat the parent directory after have returned
-from the child. Since there is no way of knowing if we returned to
-where we think we should be (by comparing device and inode) the only
-way out is to C<croak>.
-
-=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
-
-When C<remove_tree> returned from deleting files in a child directory, a
-check revealed that the parent directory it returned to wasn't the one
-it started out from. This is considered a sign of malicious activity.
-
-=item cannot make directory [dir] writeable: [errmsg]
-
-Just before removing a directory (after having successfully removed
-everything it contained), C<remove_tree> attempted to set the permissions
-on the directory to ensure it could be removed and failed. Program
-execution continues, but the directory may possibly not be deleted.
-
-=item cannot remove directory [dir]: [errmsg]
-
-C<remove_tree> attempted to remove a directory, but failed. This may because
-some objects that were unable to be removed remain in the directory, or
-a permissions issue. The directory will be left behind.
-
-=item cannot restore permissions of [dir] to [0nnn]: [errmsg]
-
-After having failed to remove a directory, C<remove_tree> was unable to
-restore its permissions from a permissive state back to a possibly
-more restrictive setting. (Permissions given in octal).
-
-=item cannot make file [file] writeable: [errmsg]
-
-C<remove_tree> attempted to force the permissions of a file to ensure it
-could be deleted, but failed to do so. It will, however, still attempt
-to unlink the file.
-
-=item cannot unlink file [file]: [errmsg]
-
-C<remove_tree> failed to remove a file. Probably a permissions issue.
-
-=item cannot restore permissions of [file] to [0nnn]: [errmsg]
-
-After having failed to remove a file, C<remove_tree> was also unable
-to restore the permissions on the file to a possibly less permissive
-setting. (Permissions given in octal).
-
-=back
-
-=head1 SEE ALSO
-
-=over 4
-
-=item *
-
-L<File::Remove>
-
-Allows files and directories to be moved to the Trashcan/Recycle
-Bin (where they may later be restored if necessary) if the operating
-system supports such functionality. This feature may one day be
-made available directly in C<File::Path>.
-
-=item *
-
-L<File::Find::Rule>
-
-When removing directory trees, if you want to examine each file to
-decide whether to delete it (and possibly leaving large swathes
-alone), F<File::Find::Rule> offers a convenient and flexible approach
-to examining directory trees.
-
-=back
-
-=head1 BUGS
-
-Please report all bugs on the RT queue:
-
-L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
-
-=head1 ACKNOWLEDGEMENTS
-
-Paul Szabo identified the race condition originally, and Brendan
-O'Dea wrote an implementation for Debian that addressed the problem.
-That code was used as a basis for the current code. Their efforts
-are greatly appreciated.
-
-Gisle Aas made a number of improvements to the documentation for
-2.07 and his advice and assistance is also greatly appreciated.
-
-=head1 AUTHORS
-
-Tim Bunce and Charles Bailey. Currently maintained by David Landgren
-<F<david at landgren.net>>.
-
-=head1 COPYRIGHT
-
-This module is copyright (C) Charles Bailey, Tim Bunce and
-David Landgren 1995-2008. All rights reserved.
-
-=head1 LICENSE
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/File/Path.t
===================================================================
--- trunk/contrib/perl/lib/File/Path.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/File/Path.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,588 +0,0 @@
-# Path.t -- tests for module File::Path
-
-use strict;
-
-use Test::More tests => 121;
-use Config;
-
-BEGIN {
- use_ok('Cwd');
- use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
- use_ok('File::Spec::Functions');
-}
-
-eval "use Test::Output";
-my $has_Test_Output = $@ ? 0 : 1;
-
-my $Is_VMS = $^O eq 'VMS';
-
-# first check for stupid permissions second for full, so we clean up
-# behind ourselves
-for my $perm (0111,0777) {
- my $path = catdir(curdir(), "mhx", "bar");
- mkpath($path);
- chmod $perm, "mhx", $path;
-
- my $oct = sprintf('0%o', $perm);
- ok(-d "mhx", "mkdir parent dir $oct");
- ok(-d $path, "mkdir child dir $oct");
-
- rmtree("mhx");
- ok(! -e "mhx", "mhx does not exist $oct");
-}
-
-# find a place to work
-my ($error, $list, $file, $message);
-my $tmp_base = catdir(
- curdir(),
- sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
-);
-
-# invent some names
-my @dir = (
- catdir($tmp_base, qw(a b)),
- catdir($tmp_base, qw(a c)),
- catdir($tmp_base, qw(z b)),
- catdir($tmp_base, qw(z c)),
-);
-
-# create them
-my @created = mkpath([@dir]);
-
-is(scalar(@created), 7, "created list of directories");
-
-# pray for no race conditions blowing them out from under us
- at created = mkpath([$tmp_base]);
-is(scalar(@created), 0, "skipped making existing directory")
- or diag("unexpectedly recreated @created");
-
-# create a file
-my $file_name = catfile( $tmp_base, 'a', 'delete.me' );
-my $file_count = 0;
-if (open OUT, "> $file_name") {
- print OUT "this file may be deleted\n";
- close OUT;
- ++$file_count;
-}
-else {
- diag( "Failed to create file $file_name: $!" );
-}
-
-SKIP: {
- skip "cannot remove a file we failed to create", 1
- unless $file_count == 1;
- my $count = rmtree($file_name);
- is($count, 1, "rmtree'ed a file");
-}
-
- at created = mkpath('');
-is(scalar(@created), 0, "Can't create a directory named ''");
-
-my $dir;
-my $dir2;
-
-sub gisle {
- # background info: @_ = 1; !shift # gives '' not 0
- # Message-Id: <3C820CE6-4400-4E91-AF43-A3D19B356E68 at activestate.com>
- # http://www.nntp.perl.org/group/perl.perl5.porters/2008/05/msg136625.html
- mkpath(shift, !shift, 0755);
-}
-
-sub count {
- opendir D, shift or return -1;
- my $count = () = readdir D;
- closedir D or return -1;
- return $count;
-}
-
-{
- mkdir 'solo', 0755;
- chdir 'solo';
- open my $f, '>', 'foo.dat';
- close $f;
- my $before = count(curdir());
- cmp_ok($before, '>', 0, "baseline $before");
-
- gisle('1st', 1);
- is(count(curdir()), $before + 1, "first after $before");
-
- $before = count(curdir());
- gisle('2nd', 1);
- is(count(curdir()), $before + 1, "second after $before");
-
- chdir updir();
- rmtree 'solo';
-}
-
-{
- mkdir 'solo', 0755;
- chdir 'solo';
- open my $f, '>', 'foo.dat';
- close $f;
- my $before = count(curdir());
- cmp_ok($before, '>', 0, "ARGV $before");
- {
- local @ARGV = (1);
- mkpath('3rd', !shift, 0755);
- }
- is(count(curdir()), $before + 1, "third after $before");
-
- $before = count(curdir());
- {
- local @ARGV = (1);
- mkpath('4th', !shift, 0755);
- }
- is(count(curdir()), $before + 1, "fourth after $before");
-
- chdir updir();
- rmtree 'solo';
-}
-
-SKIP: {
- # tests for rmtree() of ancestor directory
- my $nr_tests = 6;
- my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
- my $dir = catdir($cwd, 'remove');
- my $dir2 = catdir($cwd, 'remove', 'this', 'dir');
-
- skip "failed to mkpath '$dir2': $!", $nr_tests
- unless mkpath($dir2, {verbose => 0});
- skip "failed to chdir dir '$dir2': $!", $nr_tests
- unless chdir($dir2);
-
- rmtree($dir, {error => \$error});
- my $nr_err = @$error;
- is($nr_err, 1, "ancestor error");
-
- if ($nr_err) {
- my ($file, $message) = each %{$error->[0]};
- is($file, $dir, "ancestor named");
- my $ortho_dir = $^O eq 'MSWin32' ? File::Path::_slash_lc($dir2) : $dir2;
- $^O eq 'MSWin32' and $message
- =~ s/\A(cannot remove path when cwd is )(.*)\Z/$1 . File::Path::_slash_lc($2)/e;
- is($message, "cannot remove path when cwd is $ortho_dir", "ancestor reason");
- ok(-d $dir2, "child not removed");
- ok(-d $dir, "ancestor not removed");
- }
- else {
- fail( "ancestor 1");
- fail( "ancestor 2");
- fail( "ancestor 3");
- fail( "ancestor 4");
- }
- chdir $cwd;
- rmtree($dir);
- ok(!(-d $dir), "ancestor now removed");
-};
-
-my $count = rmtree({error => \$error});
-is( $count, 0, 'rmtree of nothing, count of zero' );
-is( scalar(@$error), 0, 'no diagnostic captured' );
-
- at created = mkpath($tmp_base, 0);
-is(scalar(@created), 0, "skipped making existing directories (old style 1)")
- or diag("unexpectedly recreated @created");
-
-$dir = catdir($tmp_base,'C');
-# mkpath returns unix syntax filespecs on VMS
-$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
- at created = make_path($tmp_base, $dir);
-is(scalar(@created), 1, "created directory (new style 1)");
-is($created[0], $dir, "created directory (new style 1) cross-check");
-
- at created = mkpath($tmp_base, 0, 0700);
-is(scalar(@created), 0, "skipped making existing directories (old style 2)")
- or diag("unexpectedly recreated @created");
-
-$dir2 = catdir($tmp_base,'D');
-# mkpath returns unix syntax filespecs on VMS
-$dir2 = VMS::Filespec::unixify($dir2) if $Is_VMS;
- at created = make_path($tmp_base, $dir, $dir2);
-is(scalar(@created), 1, "created directory (new style 2)");
-is($created[0], $dir2, "created directory (new style 2) cross-check");
-
-$count = rmtree($dir, 0);
-is($count, 1, "removed directory unsafe mode");
-
-$count = rmtree($dir2, 0, 1);
-my $removed = $Is_VMS ? 0 : 1;
-is($count, $removed, "removed directory safe mode");
-
-# mkdir foo ./E/../Y
-# Y should exist
-# existence of E is neither here nor there
-$dir = catdir($tmp_base, 'E', updir(), 'Y');
- at created =mkpath($dir);
-cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
-cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
-ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
-
- at created = make_path(catdir(curdir(), $tmp_base));
-is(scalar(@created), 0, "nothing created")
- or diag(@created);
-
-$dir = catdir($tmp_base, 'a');
-$dir2 = catdir($tmp_base, 'z');
-
-rmtree( $dir, $dir2,
- {
- error => \$error,
- result => \$list,
- keep_root => 1,
- }
-);
-
-is(scalar(@$error), 0, "no errors unlinking a and z");
-is(scalar(@$list), 4, "list contains 4 elements")
- or diag("@$list");
-
-ok(-d $dir, "dir a still exists");
-ok(-d $dir2, "dir z still exists");
-
-$dir = catdir($tmp_base,'F');
-# mkpath returns unix syntax filespecs on VMS
-$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
-
- at created = mkpath($dir, undef, 0770);
-is(scalar(@created), 1, "created directory (old style 2 verbose undef)");
-is($created[0], $dir, "created directory (old style 2 verbose undef) cross-check");
-is(rmtree($dir, undef, 0), 1, "removed directory 2 verbose undef");
-
- at created = mkpath($dir, undef);
-is(scalar(@created), 1, "created directory (old style 2a verbose undef)");
-is($created[0], $dir, "created directory (old style 2a verbose undef) cross-check");
-is(rmtree($dir, undef), 1, "removed directory 2a verbose undef");
-
- at created = mkpath($dir, 0, undef);
-is(scalar(@created), 1, "created directory (old style 3 mode undef)");
-is($created[0], $dir, "created directory (old style 3 mode undef) cross-check");
-is(rmtree($dir, 0, undef), 1, "removed directory 3 verbose undef");
-
-$dir = catdir($tmp_base,'G');
-$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
-
- at created = mkpath($dir, undef, 0200);
-is(scalar(@created), 1, "created write-only dir");
-is($created[0], $dir, "created write-only directory cross-check");
-is(rmtree($dir), 1, "removed write-only dir");
-
-# borderline new-style heuristics
-if (chdir $tmp_base) {
- pass("chdir to temp dir");
-}
-else {
- fail("chdir to temp dir: $!");
-}
-
-$dir = catdir('a', 'd1');
-$dir2 = catdir('a', 'd2');
-
- at created = make_path( $dir, 0, $dir2 );
-is(scalar @created, 3, 'new-style 3 dirs created');
-
-$count = remove_tree( $dir, 0, $dir2, );
-is($count, 3, 'new-style 3 dirs removed');
-
- at created = make_path( $dir, $dir2, 1 );
-is(scalar @created, 3, 'new-style 3 dirs created (redux)');
-
-$count = remove_tree( $dir, $dir2, 1 );
-is($count, 3, 'new-style 3 dirs removed (redux)');
-
- at created = make_path( $dir, $dir2 );
-is(scalar @created, 2, 'new-style 2 dirs created');
-
-$count = remove_tree( $dir, $dir2 );
-is($count, 2, 'new-style 2 dirs removed');
-
-if (chdir updir()) {
- pass("chdir parent");
-}
-else {
- fail("chdir parent: $!");
-}
-
-SKIP: {
- skip "This is not a MSWin32 platform", 1
- unless $^O eq 'MSWin32';
-
- my $UNC_path_taint = $ENV{PERL_FILE_PATH_UNC_TESTDIR};
- skip "PERL_FILE_PATH_UNC_TESTDIR environment variable not set", 1
- unless defined($UNC_path_taint);
-
- my ($UNC_path) = ($UNC_path_taint =~ m{^([/\\]{2}\w+[/\\]\w+[/\\]\w+)$});
-
- skip "PERL_FILE_PATH_UNC_TESTDIR environment variable does not point to a directory", 1
- unless -d $UNC_path;
-
- my $removed = rmtree($UNC_path);
- cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path");
-}
-
-SKIP: {
- # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
- skip "Don't need Force_Writeable semantics on $^O", 4
- if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
- skip "Symlinks not available", 4 unless $Config{'d_symlink'};
- $dir = 'bug487319';
- $dir2 = 'bug487319-symlink';
- @created = make_path($dir, {mask => 0700});
- is(scalar @created, 1, 'bug 487319 setup');
- symlink($dir, $dir2);
- ok(-e $dir2, "debian bug 487319 setup symlink") or diag($dir2);
-
- chmod 0500, $dir;
- my $mask_initial = (stat $dir)[2];
- remove_tree($dir2);
-
- my $mask = (stat $dir)[2];
- is( $mask, $mask_initial, 'mask of symlink target dir unchanged (debian bug 487319)');
-
- # now try a file
- my $file = catfile($dir, 'file');
- open my $out, '>', $file;
- close $out;
-
- chmod 0500, $file;
- $mask_initial = (stat $file)[2];
-
- my $file2 = catfile($dir, 'symlink');
- symlink($file, $file2);
- remove_tree($file2);
-
- $mask = (stat $file)[2];
- is( $mask, $mask_initial, 'mask of symlink target file unchanged (debian bug 487319)');
-
- remove_tree($dir);
-}
-
-# see what happens if a file exists where we want a directory
-SKIP: {
- my $entry = catdir($tmp_base, "file");
- skip "Cannot create $entry", 4 unless open OUT, "> $entry";
- print OUT "test file, safe to delete\n", scalar(localtime), "\n";
- close OUT;
- ok(-e $entry, "file exists in place of directory");
-
- mkpath( $entry, {error => \$error} );
- is( scalar(@$error), 1, "caught error condition" );
- ($file, $message) = each %{$error->[0]};
- is( $entry, $file, "and the message is: $message");
-
- eval {@created = mkpath($entry, 0, 0700)};
- $error = $@;
- chomp $error; # just to remove silly # in TAP output
- cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" )
- or diag(@created);
-}
-
-my $extra = catdir(curdir(), qw(EXTRA 1 a));
-
-SKIP: {
- skip "extra scenarios not set up, see eg/setup-extra-tests", 14
- unless -e $extra;
- skip "Symlinks not available", 14 unless $Config{'d_symlink'};
-
- my ($list, $err);
- $dir = catdir( 'EXTRA', '1' );
- rmtree( $dir, {result => \$list, error => \$err} );
- is(scalar(@$list), 2, "extra dir $dir removed");
- is(scalar(@$err), 1, "one error encountered");
-
- $dir = catdir( 'EXTRA', '3', 'N' );
- rmtree( $dir, {result => \$list, error => \$err} );
- is( @$list, 1, q{remove a symlinked dir} );
- is( @$err, 0, q{with no errors} );
-
- $dir = catdir('EXTRA', '3', 'S');
- rmtree($dir, {error => \$error});
- is( scalar(@$error), 1, 'one error for an unreadable dir' );
- eval { ($file, $message) = each %{$error->[0]}};
- is( $file, $dir, 'unreadable dir reported in error' )
- or diag($message);
-
- $dir = catdir('EXTRA', '3', 'T');
- rmtree($dir, {error => \$error});
- is( scalar(@$error), 1, 'one error for an unreadable dir T' );
- eval { ($file, $message) = each %{$error->[0]}};
- is( $file, $dir, 'unreadable dir reported in error T' );
-
- $dir = catdir( 'EXTRA', '4' );
- rmtree($dir, {result => \$list, error => \$err} );
- is( scalar(@$list), 0, q{don't follow a symlinked dir} );
- is( scalar(@$err), 2, q{two errors when removing a symlink in r/o dir} );
- eval { ($file, $message) = each %{$err->[0]} };
- is( $file, $dir, 'symlink reported in error' );
-
- $dir = catdir('EXTRA', '3', 'U');
- $dir2 = catdir('EXTRA', '3', 'V');
- rmtree($dir, $dir2, {verbose => 0, error => \$err, result => \$list});
- is( scalar(@$list), 1, q{deleted 1 out of 2 directories} );
- is( scalar(@$error), 1, q{left behind 1 out of 2 directories} );
- eval { ($file, $message) = each %{$err->[0]} };
- is( $file, $dir, 'first dir reported in error' );
-}
-
-{
- $dir = catdir($tmp_base, 'ZZ');
- @created = mkpath($dir);
- is(scalar(@created), 1, "create a ZZ directory");
-
- local @ARGV = ($dir);
- rmtree( [grep -e $_, @ARGV], 0, 0 );
- ok(!-e $dir, "blow it away via \@ARGV");
-}
-
-SKIP: {
- skip 'Test::Output not available', 14
- unless $has_Test_Output;
-
- SKIP: {
- $dir = catdir('EXTRA', '3');
- skip "extra scenarios not set up, see eg/setup-extra-tests", 3
- unless -e $dir;
-
- $dir = catdir('EXTRA', '3', 'U');
- stderr_like(
- sub {rmtree($dir, {verbose => 0})},
- qr{\Acannot make child directory read-write-exec for [^:]+: .* at \S+ line \d+},
- q(rmtree can't chdir into root dir)
- );
-
- $dir = catdir('EXTRA', '3');
- stderr_like(
- sub {rmtree($dir, {})},
- qr{\Acannot make child directory read-write-exec for [^:]+: .* at (\S+) line (\d+)
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot remove directory for [^:]+: .* at \1 line \2},
- 'rmtree with file owned by root'
- );
-
- stderr_like(
- sub {rmtree('EXTRA', {})},
- qr{\Acannot remove directory for [^:]+: .* at (\S+) line (\d+)
-cannot remove directory for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot remove directory for [^:]+: .* at \1 line \2
-cannot unlink file for [^:]+: .* at \1 line \2
-cannot restore permissions to \d+ for [^:]+: .* at \1 line \2
-cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot remove directory for [^:]+: .* at \1 line \2},
- 'rmtree with insufficient privileges'
- );
- }
-
- my $base = catdir($tmp_base,'output');
- $dir = catdir($base,'A');
- $dir2 = catdir($base,'B');
-
- stderr_like(
- sub { rmtree( undef, 1 ) },
- qr/\ANo root path\(s\) specified\b/,
- "rmtree of nothing carps sensibly"
- );
-
- stderr_like(
- sub { rmtree( '', 1 ) },
- qr/\ANo root path\(s\) specified\b/,
- "rmtree of empty dir carps sensibly"
- );
-
- stderr_is( sub { make_path() }, '', "make_path no args does not carp" );
- stderr_is( sub { remove_tree() }, '', "remove_tree no args does not carp" );
-
- stdout_is(
- sub {@created = mkpath($dir, 1)},
- "mkdir $base\nmkdir $dir\n",
- 'mkpath verbose (old style 1)'
- );
-
- stdout_is(
- sub {@created = mkpath([$dir2], 1)},
- "mkdir $dir2\n",
- 'mkpath verbose (old style 2)'
- );
-
- stdout_is(
- sub {$count = rmtree([$dir, $dir2], 1, 1)},
- "rmdir $dir\nrmdir $dir2\n",
- 'rmtree verbose (old style)'
- );
-
- stdout_is(
- sub {@created = mkpath($dir, {verbose => 1, mask => 0750})},
- "mkdir $dir\n",
- 'mkpath verbose (new style 1)'
- );
-
- stdout_is(
- sub {@created = mkpath($dir2, 1, 0771)},
- "mkdir $dir2\n",
- 'mkpath verbose (new style 2)'
- );
-
- SKIP: {
- $file = catdir($dir2, "file");
- skip "Cannot create $file", 2 unless open OUT, "> $file";
- print OUT "test file, safe to delete\n", scalar(localtime), "\n";
- close OUT;
-
- ok(-e $file, "file created in directory");
-
- stdout_is(
- sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})},
- "rmdir $dir\nunlink $file\nrmdir $dir2\n",
- 'rmtree safe verbose (new style)'
- );
- }
-}
-
-SKIP: {
- skip "extra scenarios not set up, see eg/setup-extra-tests", 11
- unless -d catdir(qw(EXTRA 1));
-
- rmtree 'EXTRA', {safe => 0, error => \$error};
- is( scalar(@$error), 10, 'seven deadly sins' ); # well there used to be 7
-
- rmtree 'EXTRA', {safe => 1, error => \$error};
- is( scalar(@$error), 9, 'safe is better' );
- for (@$error) {
- ($file, $message) = each %$_;
- if ($file =~ /[123]\z/) {
- is(index($message, 'cannot remove directory: '), 0, "failed to remove $file with rmdir")
- or diag($message);
- }
- else {
- like($message, qr(\Acannot (?:restore permissions to \d+|chdir to child|unlink file): ), "failed to remove $file with unlink")
- or diag($message)
- }
- }
-}
-
-SKIP: {
- my $nr_tests = 6;
- my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
- rmtree($tmp_base, {result => \$list} );
- is(ref($list), 'ARRAY', "received a final list of results");
- ok( !(-d $tmp_base), "test base directory gone" );
-
- my $p = getcwd();
- my $x = "x$$";
- my $xx = $x . "x";
-
- # setup
- ok(mkpath($xx));
- ok(chdir($xx));
- END {
- ok(chdir($p));
- ok(rmtree($xx));
- }
-
- # create and delete directory
- my $px = catdir($p, $x);
- ok(mkpath($px));
- ok(rmtree($px), "rmtree"); # fails in File-Path-2.07
-}
Deleted: trunk/contrib/perl/lib/File/Spec.pm
===================================================================
--- trunk/contrib/perl/lib/File/Spec.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/File/Spec.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,336 +0,0 @@
-package File::Spec;
-
-use strict;
-use vars qw(@ISA $VERSION);
-
-$VERSION = '3.30';
-$VERSION = eval $VERSION;
-
-my %module = (MacOS => 'Mac',
- MSWin32 => 'Win32',
- os2 => 'OS2',
- VMS => 'VMS',
- epoc => 'Epoc',
- NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare.
- symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian.
- dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP.
- cygwin => 'Cygwin');
-
-
-my $module = $module{$^O} || 'Unix';
-
-require "File/Spec/$module.pm";
- at ISA = ("File::Spec::$module");
-
-1;
-
-__END__
-
-=head1 NAME
-
-File::Spec - portably perform operations on file names
-
-=head1 SYNOPSIS
-
- use File::Spec;
-
- $x=File::Spec->catfile('a', 'b', 'c');
-
-which returns 'a/b/c' under Unix. Or:
-
- use File::Spec::Functions;
-
- $x = catfile('a', 'b', 'c');
-
-=head1 DESCRIPTION
-
-This module is designed to support operations commonly performed on file
-specifications (usually called "file names", but not to be confused with the
-contents of a file, or Perl's file handles), such as concatenating several
-directory and file names into a single path, or determining whether a path
-is rooted. It is based on code directly taken from MakeMaker 5.17, code
-written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
-Zakharevich, Paul Schinder, and others.
-
-Since these functions are different for most operating systems, each set of
-OS specific routines is available in a separate module, including:
-
- File::Spec::Unix
- File::Spec::Mac
- File::Spec::OS2
- File::Spec::Win32
- File::Spec::VMS
-
-The module appropriate for the current OS is automatically loaded by
-File::Spec. Since some modules (like VMS) make use of facilities available
-only under that OS, it may not be possible to load all modules under all
-operating systems.
-
-Since File::Spec is object oriented, subroutines should not be called directly,
-as in:
-
- File::Spec::catfile('a','b');
-
-but rather as class methods:
-
- File::Spec->catfile('a','b');
-
-For simple uses, L<File::Spec::Functions> provides convenient functional
-forms of these methods.
-
-=head1 METHODS
-
-=over 2
-
-=item canonpath
-X<canonpath>
-
-No physical check on the filesystem, but a logical cleanup of a
-path.
-
- $cpath = File::Spec->canonpath( $path ) ;
-
-Note that this does *not* collapse F<x/../y> sections into F<y>. This
-is by design. If F</foo> on your system is a symlink to F</bar/baz>,
-then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
-F<../>-removal would give you. If you want to do this kind of
-processing, you probably want C<Cwd>'s C<realpath()> function to
-actually traverse the filesystem cleaning up paths like this.
-
-=item catdir
-X<catdir>
-
-Concatenate two or more directory names to form a complete path ending
-with a directory. But remove the trailing slash from the resulting
-string, because it doesn't look good, isn't necessary and confuses
-OS/2. Of course, if this is the root directory, don't cut off the
-trailing slash :-)
-
- $path = File::Spec->catdir( @directories );
-
-=item catfile
-X<catfile>
-
-Concatenate one or more directory names and a filename to form a
-complete path ending with a filename
-
- $path = File::Spec->catfile( @directories, $filename );
-
-=item curdir
-X<curdir>
-
-Returns a string representation of the current directory.
-
- $curdir = File::Spec->curdir();
-
-=item devnull
-X<devnull>
-
-Returns a string representation of the null device.
-
- $devnull = File::Spec->devnull();
-
-=item rootdir
-X<rootdir>
-
-Returns a string representation of the root directory.
-
- $rootdir = File::Spec->rootdir();
-
-=item tmpdir
-X<tmpdir>
-
-Returns a string representation of the first writable directory from a
-list of possible temporary directories. Returns the current directory
-if no writable temporary directories are found. The list of directories
-checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}>
-(unless taint is on) and F</tmp>.
-
- $tmpdir = File::Spec->tmpdir();
-
-=item updir
-X<updir>
-
-Returns a string representation of the parent directory.
-
- $updir = File::Spec->updir();
-
-=item no_upwards
-
-Given a list of file names, strip out those that refer to a parent
-directory. (Does not strip symlinks, only '.', '..', and equivalents.)
-
- @paths = File::Spec->no_upwards( @paths );
-
-=item case_tolerant
-
-Returns a true or false value indicating, respectively, that alphabetic
-case is not or is significant when comparing file specifications.
-
- $is_case_tolerant = File::Spec->case_tolerant();
-
-=item file_name_is_absolute
-
-Takes as its argument a path, and returns true if it is an absolute path.
-
- $is_absolute = File::Spec->file_name_is_absolute( $path );
-
-This does not consult the local filesystem on Unix, Win32, OS/2, or
-Mac OS (Classic). It does consult the working environment for VMS
-(see L<File::Spec::VMS/file_name_is_absolute>).
-
-=item path
-X<path>
-
-Takes no argument. Returns the environment variable C<PATH> (or the local
-platform's equivalent) as a list.
-
- @PATH = File::Spec->path();
-
-=item join
-X<join, path>
-
-join is the same as catfile.
-
-=item splitpath
-X<splitpath> X<split, path>
-
-Splits a path in to volume, directory, and filename portions. On systems
-with no concept of volume, returns '' for volume.
-
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
-
-For systems with no syntax differentiating filenames from directories,
-assumes that the last file is a path unless C<$no_file> is true or a
-trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file>
-true makes this return ( '', $path, '' ).
-
-The directory portion may or may not be returned with a trailing '/'.
-
-The results can be passed to L</catpath()> to get back a path equivalent to
-(usually identical to) the original path.
-
-=item splitdir
-X<splitdir> X<split, dir>
-
-The opposite of L</catdir()>.
-
- @dirs = File::Spec->splitdir( $directories );
-
-C<$directories> must be only the directory portion of the path on systems
-that have the concept of a volume or that have path syntax that differentiates
-files from directories.
-
-Unlike just splitting the directories on the separator, empty
-directory names (C<''>) can be returned, because these are significant
-on some OSes.
-
-=item catpath()
-
-Takes volume, directory and file portions and returns an entire path. Under
-Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is
-inserted if need be. On other OSes, C<$volume> is significant.
-
- $full_path = File::Spec->catpath( $volume, $directory, $file );
-
-=item abs2rel
-X<abs2rel> X<absolute, path> X<relative, path>
-
-Takes a destination path and an optional base path returns a relative path
-from the base path to the destination path:
-
- $rel_path = File::Spec->abs2rel( $path ) ;
- $rel_path = File::Spec->abs2rel( $path, $base ) ;
-
-If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is
-relative, then it is converted to absolute form using
-L</rel2abs()>. This means that it is taken to be relative to
-L<Cwd::cwd()|Cwd>.
-
-On systems with the concept of volume, if C<$path> and C<$base> appear to be
-on two different volumes, we will not attempt to resolve the two
-paths, and we will instead simply return C<$path>. Note that previous
-versions of this module ignored the volume of C<$base>, which resulted in
-garbage results part of the time.
-
-On systems that have a grammar that indicates filenames, this ignores the
-C<$base> filename as well. Otherwise all path components are assumed to be
-directories.
-
-If C<$path> is relative, it is converted to absolute form using L</rel2abs()>.
-This means that it is taken to be relative to L<Cwd::cwd()|Cwd>.
-
-No checks against the filesystem are made. On VMS, there is
-interaction with the working environment, as logicals and
-macros are expanded.
-
-Based on code written by Shigio Yamaguchi.
-
-=item rel2abs()
-X<rel2abs> X<absolute, path> X<relative, path>
-
-Converts a relative path to an absolute path.
-
- $abs_path = File::Spec->rel2abs( $path ) ;
- $abs_path = File::Spec->rel2abs( $path, $base ) ;
-
-If C<$base> is not present or '', then L<Cwd::cwd()|Cwd> is used. If C<$base> is relative,
-then it is converted to absolute form using L</rel2abs()>. This means that it
-is taken to be relative to L<Cwd::cwd()|Cwd>.
-
-On systems with the concept of volume, if C<$path> and C<$base> appear to be
-on two different volumes, we will not attempt to resolve the two
-paths, and we will instead simply return C<$path>. Note that previous
-versions of this module ignored the volume of C<$base>, which resulted in
-garbage results part of the time.
-
-On systems that have a grammar that indicates filenames, this ignores the
-C<$base> filename as well. Otherwise all path components are assumed to be
-directories.
-
-If C<$path> is absolute, it is cleaned up and returned using L</canonpath()>.
-
-No checks against the filesystem are made. On VMS, there is
-interaction with the working environment, as logicals and
-macros are expanded.
-
-Based on code written by Shigio Yamaguchi.
-
-=back
-
-For further information, please see L<File::Spec::Unix>,
-L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or
-L<File::Spec::VMS>.
-
-=head1 SEE ALSO
-
-L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>,
-L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>,
-L<ExtUtils::MakeMaker>
-
-=head1 AUTHOR
-
-Currently maintained by Ken Williams C<< <KWILLIAMS at cpan.org> >>.
-
-The vast majority of the code was written by
-Kenneth Albanowski C<< <kjahds at kjahds.com> >>,
-Andy Dougherty C<< <doughera at lafayette.edu> >>,
-Andreas KE<ouml>nig C<< <A.Koenig at franz.ww.TU-Berlin.DE> >>,
-Tim Bunce C<< <Tim.Bunce at ig.co.uk> >>.
-VMS support by Charles Bailey C<< <bailey at newman.upenn.edu> >>.
-OS/2 support by Ilya Zakharevich C<< <ilya at math.ohio-state.edu> >>.
-Mac support by Paul Schinder C<< <schinder at pobox.com> >>, and
-Thomas Wegner C<< <wegner_thomas at yahoo.com> >>.
-abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio at tamacom.com> >>,
-modified by Barrie Slaymaker C<< <barries at slaysys.com> >>.
-splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/File/Temp.pm
===================================================================
--- trunk/contrib/perl/lib/File/Temp.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/File/Temp.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,2452 +0,0 @@
-package File::Temp;
-
-=head1 NAME
-
-File::Temp - return name and handle of a temporary file safely
-
-=begin __INTERNALS
-
-=head1 PORTABILITY
-
-This section is at the top in order to provide easier access to
-porters. It is not expected to be rendered by a standard pod
-formatting tool. Please skip straight to the SYNOPSIS section if you
-are not trying to port this module to a new platform.
-
-This module is designed to be portable across operating systems and it
-currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS
-(Classic). When porting to a new OS there are generally three main
-issues that have to be solved:
-
-=over 4
-
-=item *
-
-Can the OS unlink an open file? If it can not then the
-C<_can_unlink_opened_file> method should be modified.
-
-=item *
-
-Are the return values from C<stat> reliable? By default all the
-return values from C<stat> are compared when unlinking a temporary
-file using the filename and the handle. Operating systems other than
-unix do not always have valid entries in all fields. If C<unlink0> fails
-then the C<stat> comparison should be modified accordingly.
-
-=item *
-
-Security. Systems that can not support a test for the sticky bit
-on a directory can not use the MEDIUM and HIGH security tests.
-The C<_can_do_level> method should be modified accordingly.
-
-=back
-
-=end __INTERNALS
-
-=head1 SYNOPSIS
-
- use File::Temp qw/ tempfile tempdir /;
-
- $fh = tempfile();
- ($fh, $filename) = tempfile();
-
- ($fh, $filename) = tempfile( $template, DIR => $dir);
- ($fh, $filename) = tempfile( $template, SUFFIX => '.dat');
- ($fh, $filename) = tempfile( $template, TMPDIR => 1 );
-
- binmode( $fh, ":utf8" );
-
- $dir = tempdir( CLEANUP => 1 );
- ($fh, $filename) = tempfile( DIR => $dir );
-
-Object interface:
-
- require File::Temp;
- use File::Temp ();
- use File::Temp qw/ :seekable /;
-
- $fh = File::Temp->new();
- $fname = $fh->filename;
-
- $fh = File::Temp->new(TEMPLATE => $template);
- $fname = $fh->filename;
-
- $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' );
- print $tmp "Some data\n";
- print "Filename is $tmp\n";
- $tmp->seek( 0, SEEK_END );
-
-The following interfaces are provided for compatibility with
-existing APIs. They should not be used in new code.
-
-MkTemp family:
-
- use File::Temp qw/ :mktemp /;
-
- ($fh, $file) = mkstemp( "tmpfileXXXXX" );
- ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix);
-
- $tmpdir = mkdtemp( $template );
-
- $unopened_file = mktemp( $template );
-
-POSIX functions:
-
- use File::Temp qw/ :POSIX /;
-
- $file = tmpnam();
- $fh = tmpfile();
-
- ($fh, $file) = tmpnam();
-
-Compatibility functions:
-
- $unopened_file = File::Temp::tempnam( $dir, $pfx );
-
-=head1 DESCRIPTION
-
-C<File::Temp> can be used to create and open temporary files in a safe
-way. There is both a function interface and an object-oriented
-interface. The File::Temp constructor or the tempfile() function can
-be used to return the name and the open filehandle of a temporary
-file. The tempdir() function can be used to create a temporary
-directory.
-
-The security aspect of temporary file creation is emphasized such that
-a filehandle and filename are returned together. This helps guarantee
-that a race condition can not occur where the temporary file is
-created by another process between checking for the existence of the
-file and its opening. Additional security levels are provided to
-check, for example, that the sticky bit is set on world writable
-directories. See L<"safe_level"> for more information.
-
-For compatibility with popular C library functions, Perl implementations of
-the mkstemp() family of functions are provided. These are, mkstemp(),
-mkstemps(), mkdtemp() and mktemp().
-
-Additionally, implementations of the standard L<POSIX|POSIX>
-tmpnam() and tmpfile() functions are provided if required.
-
-Implementations of mktemp(), tmpnam(), and tempnam() are provided,
-but should be used with caution since they return only a filename
-that was valid when function was called, so cannot guarantee
-that the file will not exist by the time the caller opens the filename.
-
-Filehandles returned by these functions support the seekable methods.
-
-=cut
-
-# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls
-# People would like a version on 5.004 so give them what they want :-)
-use 5.004;
-use strict;
-use Carp;
-use File::Spec 0.8;
-use File::Path qw/ rmtree /;
-use Fcntl 1.03;
-use IO::Seekable; # For SEEK_*
-use Errno;
-require VMS::Stdio if $^O eq 'VMS';
-
-# pre-emptively load Carp::Heavy. If we don't when we run out of file
-# handles and attempt to call croak() we get an error message telling
-# us that Carp::Heavy won't load rather than an error telling us we
-# have run out of file handles. We either preload croak() or we
-# switch the calls to croak from _gettemp() to use die.
-eval { require Carp::Heavy; };
-
-# Need the Symbol package if we are running older perl
-require Symbol if $] < 5.006;
-
-### For the OO interface
-use base qw/ IO::Handle IO::Seekable /;
-use overload '""' => "STRINGIFY", fallback => 1;
-
-# use 'our' on v5.6.0
-use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL);
-
-$DEBUG = 0;
-$KEEP_ALL = 0;
-
-# We are exporting functions
-
-use base qw/Exporter/;
-
-# Export list - to allow fine tuning of export table
-
- at EXPORT_OK = qw{
- tempfile
- tempdir
- tmpnam
- tmpfile
- mktemp
- mkstemp
- mkstemps
- mkdtemp
- unlink0
- cleanup
- SEEK_SET
- SEEK_CUR
- SEEK_END
- };
-
-# Groups of functions for export
-
-%EXPORT_TAGS = (
- 'POSIX' => [qw/ tmpnam tmpfile /],
- 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/],
- 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /],
- );
-
-# add contents of these tags to @EXPORT
-Exporter::export_tags('POSIX','mktemp','seekable');
-
-# Version number
-
-$VERSION = '0.22';
-
-# This is a list of characters that can be used in random filenames
-
-my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
- a b c d e f g h i j k l m n o p q r s t u v w x y z
- 0 1 2 3 4 5 6 7 8 9 _
- /);
-
-# Maximum number of tries to make a temp file before failing
-
-use constant MAX_TRIES => 1000;
-
-# Minimum number of X characters that should be in a template
-use constant MINX => 4;
-
-# Default template when no template supplied
-
-use constant TEMPXXX => 'X' x 10;
-
-# Constants for the security level
-
-use constant STANDARD => 0;
-use constant MEDIUM => 1;
-use constant HIGH => 2;
-
-# OPENFLAGS. If we defined the flag to use with Sysopen here this gives
-# us an optimisation when many temporary files are requested
-
-my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
-my $LOCKFLAG;
-
-unless ($^O eq 'MacOS') {
- for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) {
- my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
- no strict 'refs';
- $OPENFLAGS |= $bit if eval {
- # Make sure that redefined die handlers do not cause problems
- # e.g. CGI::Carp
- local $SIG{__DIE__} = sub {};
- local $SIG{__WARN__} = sub {};
- $bit = &$func();
- 1;
- };
- }
- # Special case O_EXLOCK
- $LOCKFLAG = eval {
- local $SIG{__DIE__} = sub {};
- local $SIG{__WARN__} = sub {};
- &Fcntl::O_EXLOCK();
- };
-}
-
-# On some systems the O_TEMPORARY flag can be used to tell the OS
-# to automatically remove the file when it is closed. This is fine
-# in most cases but not if tempfile is called with UNLINK=>0 and
-# the filename is requested -- in the case where the filename is to
-# be passed to another routine. This happens on windows. We overcome
-# this by using a second open flags variable
-
-my $OPENTEMPFLAGS = $OPENFLAGS;
-unless ($^O eq 'MacOS') {
- for my $oflag (qw/ TEMPORARY /) {
- my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
- local($@);
- no strict 'refs';
- $OPENTEMPFLAGS |= $bit if eval {
- # Make sure that redefined die handlers do not cause problems
- # e.g. CGI::Carp
- local $SIG{__DIE__} = sub {};
- local $SIG{__WARN__} = sub {};
- $bit = &$func();
- 1;
- };
- }
-}
-
-# Private hash tracking which files have been created by each process id via the OO interface
-my %FILES_CREATED_BY_OBJECT;
-
-# INTERNAL ROUTINES - not to be used outside of package
-
-# Generic routine for getting a temporary filename
-# modelled on OpenBSD _gettemp() in mktemp.c
-
-# The template must contain X's that are to be replaced
-# with the random values
-
-# Arguments:
-
-# TEMPLATE - string containing the XXXXX's that is converted
-# to a random filename and opened if required
-
-# Optionally, a hash can also be supplied containing specific options
-# "open" => if true open the temp file, else just return the name
-# default is 0
-# "mkdir"=> if true, we are creating a temp directory rather than tempfile
-# default is 0
-# "suffixlen" => number of characters at end of PATH to be ignored.
-# default is 0.
-# "unlink_on_close" => indicates that, if possible, the OS should remove
-# the file as soon as it is closed. Usually indicates
-# use of the O_TEMPORARY flag to sysopen.
-# Usually irrelevant on unix
-# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true.
-
-# Optionally a reference to a scalar can be passed into the function
-# On error this will be used to store the reason for the error
-# "ErrStr" => \$errstr
-
-# "open" and "mkdir" can not both be true
-# "unlink_on_close" is not used when "mkdir" is true.
-
-# The default options are equivalent to mktemp().
-
-# Returns:
-# filehandle - open file handle (if called with doopen=1, else undef)
-# temp name - name of the temp file or directory
-
-# For example:
-# ($fh, $name) = _gettemp($template, "open" => 1);
-
-# for the current version, failures are associated with
-# stored in an error string and returned to give the reason whilst debugging
-# This routine is not called by any external function
-sub _gettemp {
-
- croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);'
- unless scalar(@_) >= 1;
-
- # the internal error string - expect it to be overridden
- # Need this in case the caller decides not to supply us a value
- # need an anonymous scalar
- my $tempErrStr;
-
- # Default options
- my %options = (
- "open" => 0,
- "mkdir" => 0,
- "suffixlen" => 0,
- "unlink_on_close" => 0,
- "use_exlock" => 1,
- "ErrStr" => \$tempErrStr,
- );
-
- # Read the template
- my $template = shift;
- if (ref($template)) {
- # Use a warning here since we have not yet merged ErrStr
- carp "File::Temp::_gettemp: template must not be a reference";
- return ();
- }
-
- # Check that the number of entries on stack are even
- if (scalar(@_) % 2 != 0) {
- # Use a warning here since we have not yet merged ErrStr
- carp "File::Temp::_gettemp: Must have even number of options";
- return ();
- }
-
- # Read the options and merge with defaults
- %options = (%options, @_) if @_;
-
- # Make sure the error string is set to undef
- ${$options{ErrStr}} = undef;
-
- # Can not open the file and make a directory in a single call
- if ($options{"open"} && $options{"mkdir"}) {
- ${$options{ErrStr}} = "doopen and domkdir can not both be true\n";
- return ();
- }
-
- # Find the start of the end of the Xs (position of last X)
- # Substr starts from 0
- my $start = length($template) - 1 - $options{"suffixlen"};
-
- # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string
- # (taking suffixlen into account). Any fewer is insecure.
-
- # Do it using substr - no reason to use a pattern match since
- # we know where we are looking and what we are looking for
-
- if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) {
- ${$options{ErrStr}} = "The template must end with at least ".
- MINX . " 'X' characters\n";
- return ();
- }
-
- # Replace all the X at the end of the substring with a
- # random character or just all the XX at the end of a full string.
- # Do it as an if, since the suffix adjusts which section to replace
- # and suffixlen=0 returns nothing if used in the substr directly
- # and generate a full path from the template
-
- my $path = _replace_XX($template, $options{"suffixlen"});
-
-
- # Split the path into constituent parts - eventually we need to check
- # whether the directory exists
- # We need to know whether we are making a temp directory
- # or a tempfile
-
- my ($volume, $directories, $file);
- my $parent; # parent directory
- if ($options{"mkdir"}) {
- # There is no filename at the end
- ($volume, $directories, $file) = File::Spec->splitpath( $path, 1);
-
- # The parent is then $directories without the last directory
- # Split the directory and put it back together again
- my @dirs = File::Spec->splitdir($directories);
-
- # If @dirs only has one entry (i.e. the directory template) that means
- # we are in the current directory
- if ($#dirs == 0) {
- $parent = File::Spec->curdir;
- } else {
-
- if ($^O eq 'VMS') { # need volume to avoid relative dir spec
- $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]);
- $parent = 'sys$disk:[]' if $parent eq '';
- } else {
-
- # Put it back together without the last one
- $parent = File::Spec->catdir(@dirs[0..$#dirs-1]);
-
- # ...and attach the volume (no filename)
- $parent = File::Spec->catpath($volume, $parent, '');
- }
-
- }
-
- } else {
-
- # Get rid of the last filename (use File::Basename for this?)
- ($volume, $directories, $file) = File::Spec->splitpath( $path );
-
- # Join up without the file part
- $parent = File::Spec->catpath($volume,$directories,'');
-
- # If $parent is empty replace with curdir
- $parent = File::Spec->curdir
- unless $directories ne '';
-
- }
-
- # Check that the parent directories exist
- # Do this even for the case where we are simply returning a name
- # not a file -- no point returning a name that includes a directory
- # that does not exist or is not writable
-
- unless (-e $parent) {
- ${$options{ErrStr}} = "Parent directory ($parent) does not exist";
- return ();
- }
- unless (-d $parent) {
- ${$options{ErrStr}} = "Parent directory ($parent) is not a directory";
- return ();
- }
-
- # Check the stickiness of the directory and chown giveaway if required
- # If the directory is world writable the sticky bit
- # must be set
-
- if (File::Temp->safe_level == MEDIUM) {
- my $safeerr;
- unless (_is_safe($parent,\$safeerr)) {
- ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
- return ();
- }
- } elsif (File::Temp->safe_level == HIGH) {
- my $safeerr;
- unless (_is_verysafe($parent, \$safeerr)) {
- ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)";
- return ();
- }
- }
-
-
- # Now try MAX_TRIES time to open the file
- for (my $i = 0; $i < MAX_TRIES; $i++) {
-
- # Try to open the file if requested
- if ($options{"open"}) {
- my $fh;
-
- # If we are running before perl5.6.0 we can not auto-vivify
- if ($] < 5.006) {
- $fh = &Symbol::gensym;
- }
-
- # Try to make sure this will be marked close-on-exec
- # XXX: Win32 doesn't respect this, nor the proper fcntl,
- # but may have O_NOINHERIT. This may or may not be in Fcntl.
- local $^F = 2;
-
- # Attempt to open the file
- my $open_success = undef;
- if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) {
- # make it auto delete on close by setting FAB$V_DLT bit
- $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt');
- $open_success = $fh;
- } else {
- my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ?
- $OPENTEMPFLAGS :
- $OPENFLAGS );
- $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock});
- $open_success = sysopen($fh, $path, $flags, 0600);
- }
- if ( $open_success ) {
-
- # in case of odd umask force rw
- chmod(0600, $path);
-
- # Opened successfully - return file handle and name
- return ($fh, $path);
-
- } else {
-
- # Error opening file - abort with error
- # if the reason was anything but EEXIST
- unless ($!{EEXIST}) {
- ${$options{ErrStr}} = "Could not create temp file $path: $!";
- return ();
- }
-
- # Loop round for another try
-
- }
- } elsif ($options{"mkdir"}) {
-
- # Open the temp directory
- if (mkdir( $path, 0700)) {
- # in case of odd umask
- chmod(0700, $path);
-
- return undef, $path;
- } else {
-
- # Abort with error if the reason for failure was anything
- # except EEXIST
- unless ($!{EEXIST}) {
- ${$options{ErrStr}} = "Could not create directory $path: $!";
- return ();
- }
-
- # Loop round for another try
-
- }
-
- } else {
-
- # Return true if the file can not be found
- # Directory has been checked previously
-
- return (undef, $path) unless -e $path;
-
- # Try again until MAX_TRIES
-
- }
-
- # Did not successfully open the tempfile/dir
- # so try again with a different set of random letters
- # No point in trying to increment unless we have only
- # 1 X say and the randomness could come up with the same
- # file MAX_TRIES in a row.
-
- # Store current attempt - in principal this implies that the
- # 3rd time around the open attempt that the first temp file
- # name could be generated again. Probably should store each
- # attempt and make sure that none are repeated
-
- my $original = $path;
- my $counter = 0; # Stop infinite loop
- my $MAX_GUESS = 50;
-
- do {
-
- # Generate new name from original template
- $path = _replace_XX($template, $options{"suffixlen"});
-
- $counter++;
-
- } until ($path ne $original || $counter > $MAX_GUESS);
-
- # Check for out of control looping
- if ($counter > $MAX_GUESS) {
- ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)";
- return ();
- }
-
- }
-
- # If we get here, we have run out of tries
- ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts ("
- . MAX_TRIES . ") to open temp file/dir";
-
- return ();
-
-}
-
-# Internal routine to replace the XXXX... with random characters
-# This has to be done by _gettemp() every time it fails to
-# open a temp file/dir
-
-# Arguments: $template (the template with XXX),
-# $ignore (number of characters at end to ignore)
-
-# Returns: modified template
-
-sub _replace_XX {
-
- croak 'Usage: _replace_XX($template, $ignore)'
- unless scalar(@_) == 2;
-
- my ($path, $ignore) = @_;
-
- # Do it as an if, since the suffix adjusts which section to replace
- # and suffixlen=0 returns nothing if used in the substr directly
- # Alternatively, could simply set $ignore to length($path)-1
- # Don't want to always use substr when not required though.
- my $end = ( $] >= 5.006 ? "\\z" : "\\Z" );
-
- if ($ignore) {
- substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
- } else {
- $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge;
- }
- return $path;
-}
-
-# Internal routine to force a temp file to be writable after
-# it is created so that we can unlink it. Windows seems to occassionally
-# force a file to be readonly when written to certain temp locations
-sub _force_writable {
- my $file = shift;
- chmod 0600, $file;
-}
-
-
-# internal routine to check to see if the directory is safe
-# First checks to see if the directory is not owned by the
-# current user or root. Then checks to see if anyone else
-# can write to the directory and if so, checks to see if
-# it has the sticky bit set
-
-# Will not work on systems that do not support sticky bit
-
-#Args: directory path to check
-# Optionally: reference to scalar to contain error message
-# Returns true if the path is safe and false otherwise.
-# Returns undef if can not even run stat() on the path
-
-# This routine based on version written by Tom Christiansen
-
-# Presumably, by the time we actually attempt to create the
-# file or directory in this directory, it may not be safe
-# anymore... Have to run _is_safe directly after the open.
-
-sub _is_safe {
-
- my $path = shift;
- my $err_ref = shift;
-
- # Stat path
- my @info = stat($path);
- unless (scalar(@info)) {
- $$err_ref = "stat(path) returned no values";
- return 0;
- }
- ;
- return 1 if $^O eq 'VMS'; # owner delete control at file level
-
- # Check to see whether owner is neither superuser (or a system uid) nor me
- # Use the effective uid from the $> variable
- # UID is in [4]
- if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) {
-
- Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'",
- File::Temp->top_system_uid());
-
- $$err_ref = "Directory owned neither by root nor the current user"
- if ref($err_ref);
- return 0;
- }
-
- # check whether group or other can write file
- # use 066 to detect either reading or writing
- # use 022 to check writability
- # Do it with S_IWOTH and S_IWGRP for portability (maybe)
- # mode is in info[2]
- if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable?
- ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable?
- # Must be a directory
- unless (-d $path) {
- $$err_ref = "Path ($path) is not a directory"
- if ref($err_ref);
- return 0;
- }
- # Must have sticky bit set
- unless (-k $path) {
- $$err_ref = "Sticky bit not set on $path when dir is group|world writable"
- if ref($err_ref);
- return 0;
- }
- }
-
- return 1;
-}
-
-# Internal routine to check whether a directory is safe
-# for temp files. Safer than _is_safe since it checks for
-# the possibility of chown giveaway and if that is a possibility
-# checks each directory in the path to see if it is safe (with _is_safe)
-
-# If _PC_CHOWN_RESTRICTED is not set, does the full test of each
-# directory anyway.
-
-# Takes optional second arg as scalar ref to error reason
-
-sub _is_verysafe {
-
- # Need POSIX - but only want to bother if really necessary due to overhead
- require POSIX;
-
- my $path = shift;
- print "_is_verysafe testing $path\n" if $DEBUG;
- return 1 if $^O eq 'VMS'; # owner delete control at file level
-
- my $err_ref = shift;
-
- # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined
- # and If it is not there do the extensive test
- local($@);
- my $chown_restricted;
- $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED()
- if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1};
-
- # If chown_resticted is set to some value we should test it
- if (defined $chown_restricted) {
-
- # Return if the current directory is safe
- return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted );
-
- }
-
- # To reach this point either, the _PC_CHOWN_RESTRICTED symbol
- # was not avialable or the symbol was there but chown giveaway
- # is allowed. Either way, we now have to test the entire tree for
- # safety.
-
- # Convert path to an absolute directory if required
- unless (File::Spec->file_name_is_absolute($path)) {
- $path = File::Spec->rel2abs($path);
- }
-
- # Split directory into components - assume no file
- my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1);
-
- # Slightly less efficient than having a function in File::Spec
- # to chop off the end of a directory or even a function that
- # can handle ../ in a directory tree
- # Sometimes splitdir() returns a blank at the end
- # so we will probably check the bottom directory twice in some cases
- my @dirs = File::Spec->splitdir($directories);
-
- # Concatenate one less directory each time around
- foreach my $pos (0.. $#dirs) {
- # Get a directory name
- my $dir = File::Spec->catpath($volume,
- File::Spec->catdir(@dirs[0.. $#dirs - $pos]),
- ''
- );
-
- print "TESTING DIR $dir\n" if $DEBUG;
-
- # Check the directory
- return 0 unless _is_safe($dir,$err_ref);
-
- }
-
- return 1;
-}
-
-
-
-# internal routine to determine whether unlink works on this
-# platform for files that are currently open.
-# Returns true if we can, false otherwise.
-
-# Currently WinNT, OS/2 and VMS can not unlink an opened file
-# On VMS this is because the O_EXCL flag is used to open the
-# temporary file. Currently I do not know enough about the issues
-# on VMS to decide whether O_EXCL is a requirement.
-
-sub _can_unlink_opened_file {
-
- if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') {
- return 0;
- } else {
- return 1;
- }
-
-}
-
-# internal routine to decide which security levels are allowed
-# see safe_level() for more information on this
-
-# Controls whether the supplied security level is allowed
-
-# $cando = _can_do_level( $level )
-
-sub _can_do_level {
-
- # Get security level
- my $level = shift;
-
- # Always have to be able to do STANDARD
- return 1 if $level == STANDARD;
-
- # Currently, the systems that can do HIGH or MEDIUM are identical
- if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') {
- return 0;
- } else {
- return 1;
- }
-
-}
-
-# This routine sets up a deferred unlinking of a specified
-# filename and filehandle. It is used in the following cases:
-# - Called by unlink0 if an opened file can not be unlinked
-# - Called by tempfile() if files are to be removed on shutdown
-# - Called by tempdir() if directories are to be removed on shutdown
-
-# Arguments:
-# _deferred_unlink( $fh, $fname, $isdir );
-#
-# - filehandle (so that it can be expclicitly closed if open
-# - filename (the thing we want to remove)
-# - isdir (flag to indicate that we are being given a directory)
-# [and hence no filehandle]
-
-# Status is not referred to since all the magic is done with an END block
-
-{
- # Will set up two lexical variables to contain all the files to be
- # removed. One array for files, another for directories They will
- # only exist in this block.
-
- # This means we only have to set up a single END block to remove
- # all files.
-
- # in order to prevent child processes inadvertently deleting the parent
- # temp files we use a hash to store the temp files and directories
- # created by a particular process id.
-
- # %files_to_unlink contains values that are references to an array of
- # array references containing the filehandle and filename associated with
- # the temp file.
- my (%files_to_unlink, %dirs_to_unlink);
-
- # Set up an end block to use these arrays
- END {
- local($., $@, $!, $^E, $?);
- cleanup();
- }
-
- # Cleanup function. Always triggered on END but can be invoked
- # manually.
- sub cleanup {
- if (!$KEEP_ALL) {
- # Files
- my @files = (exists $files_to_unlink{$$} ?
- @{ $files_to_unlink{$$} } : () );
- foreach my $file (@files) {
- # close the filehandle without checking its state
- # in order to make real sure that this is closed
- # if its already closed then I dont care about the answer
- # probably a better way to do this
- close($file->[0]); # file handle is [0]
-
- if (-f $file->[1]) { # file name is [1]
- _force_writable( $file->[1] ); # for windows
- unlink $file->[1] or warn "Error removing ".$file->[1];
- }
- }
- # Dirs
- my @dirs = (exists $dirs_to_unlink{$$} ?
- @{ $dirs_to_unlink{$$} } : () );
- foreach my $dir (@dirs) {
- if (-d $dir) {
- # Some versions of rmtree will abort if you attempt to remove
- # the directory you are sitting in. We protect that and turn it
- # into a warning. We do this because this occurs during
- # cleanup and so can not be caught by the user.
- eval { rmtree($dir, $DEBUG, 0); };
- warn $@ if ($@ && $^W);
- }
- }
-
- # clear the arrays
- @{ $files_to_unlink{$$} } = ()
- if exists $files_to_unlink{$$};
- @{ $dirs_to_unlink{$$} } = ()
- if exists $dirs_to_unlink{$$};
- }
- }
-
-
- # This is the sub called to register a file for deferred unlinking
- # This could simply store the input parameters and defer everything
- # until the END block. For now we do a bit of checking at this
- # point in order to make sure that (1) we have a file/dir to delete
- # and (2) we have been called with the correct arguments.
- sub _deferred_unlink {
-
- croak 'Usage: _deferred_unlink($fh, $fname, $isdir)'
- unless scalar(@_) == 3;
-
- my ($fh, $fname, $isdir) = @_;
-
- warn "Setting up deferred removal of $fname\n"
- if $DEBUG;
-
- # If we have a directory, check that it is a directory
- if ($isdir) {
-
- if (-d $fname) {
-
- # Directory exists so store it
- # first on VMS turn []foo into [.foo] for rmtree
- $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS';
- $dirs_to_unlink{$$} = []
- unless exists $dirs_to_unlink{$$};
- push (@{ $dirs_to_unlink{$$} }, $fname);
-
- } else {
- carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W;
- }
-
- } else {
-
- if (-f $fname) {
-
- # file exists so store handle and name for later removal
- $files_to_unlink{$$} = []
- unless exists $files_to_unlink{$$};
- push(@{ $files_to_unlink{$$} }, [$fh, $fname]);
-
- } else {
- carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W;
- }
-
- }
-
- }
-
-
-}
-
-=head1 OBJECT-ORIENTED INTERFACE
-
-This is the primary interface for interacting with
-C<File::Temp>. Using the OO interface a temporary file can be created
-when the object is constructed and the file can be removed when the
-object is no longer required.
-
-Note that there is no method to obtain the filehandle from the
-C<File::Temp> object. The object itself acts as a filehandle. Also,
-the object is configured such that it stringifies to the name of the
-temporary file, and can be compared to a filename directly. The object
-isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are
-available.
-
-=over 4
-
-=item B<new>
-
-Create a temporary file object.
-
- my $tmp = File::Temp->new();
-
-by default the object is constructed as if C<tempfile>
-was called without options, but with the additional behaviour
-that the temporary file is removed by the object destructor
-if UNLINK is set to true (the default).
-
-Supported arguments are the same as for C<tempfile>: UNLINK
-(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename
-template is specified using the TEMPLATE option. The OPEN option
-is not supported (the file is always opened).
-
- $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX',
- DIR => 'mydir',
- SUFFIX => '.dat');
-
-Arguments are case insensitive.
-
-Can call croak() if an error occurs.
-
-=cut
-
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
-
- # read arguments and convert keys to upper case
- my %args = @_;
- %args = map { uc($_), $args{$_} } keys %args;
-
- # see if they are unlinking (defaulting to yes)
- my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 );
- delete $args{UNLINK};
-
- # template (store it in an array so that it will
- # disappear from the arg list of tempfile)
- my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () );
- delete $args{TEMPLATE};
-
- # Protect OPEN
- delete $args{OPEN};
-
- # Open the file and retain file handle and file name
- my ($fh, $path) = tempfile( @template, %args );
-
- print "Tmp: $fh - $path\n" if $DEBUG;
-
- # Store the filename in the scalar slot
- ${*$fh} = $path;
-
- # Cache the filename by pid so that the destructor can decide whether to remove it
- $FILES_CREATED_BY_OBJECT{$$}{$path} = 1;
-
- # Store unlink information in hash slot (plus other constructor info)
- %{*$fh} = %args;
-
- # create the object
- bless $fh, $class;
-
- # final method-based configuration
- $fh->unlink_on_destroy( $unlink );
-
- return $fh;
-}
-
-=item B<newdir>
-
-Create a temporary directory using an object oriented interface.
-
- $dir = File::Temp->newdir();
-
-By default the directory is deleted when the object goes out of scope.
-
-Supports the same options as the C<tempdir> function. Note that directories
-created with this method default to CLEANUP => 1.
-
- $dir = File::Temp->newdir( $template, %options );
-
-=cut
-
-sub newdir {
- my $self = shift;
-
- # need to handle args as in tempdir because we have to force CLEANUP
- # default without passing CLEANUP to tempdir
- my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
- my %options = @_;
- my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 );
-
- delete $options{CLEANUP};
-
- my $tempdir;
- if (defined $template) {
- $tempdir = tempdir( $template, %options );
- } else {
- $tempdir = tempdir( %options );
- }
- return bless { DIRNAME => $tempdir,
- CLEANUP => $cleanup,
- LAUNCHPID => $$,
- }, "File::Temp::Dir";
-}
-
-=item B<filename>
-
-Return the name of the temporary file associated with this object
-(if the object was created using the "new" constructor).
-
- $filename = $tmp->filename;
-
-This method is called automatically when the object is used as
-a string.
-
-=cut
-
-sub filename {
- my $self = shift;
- return ${*$self};
-}
-
-sub STRINGIFY {
- my $self = shift;
- return $self->filename;
-}
-
-=item B<dirname>
-
-Return the name of the temporary directory associated with this
-object (if the object was created using the "newdir" constructor).
-
- $dirname = $tmpdir->dirname;
-
-This method is called automatically when the object is used in string context.
-
-=item B<unlink_on_destroy>
-
-Control whether the file is unlinked when the object goes out of scope.
-The file is removed if this value is true and $KEEP_ALL is not.
-
- $fh->unlink_on_destroy( 1 );
-
-Default is for the file to be removed.
-
-=cut
-
-sub unlink_on_destroy {
- my $self = shift;
- if (@_) {
- ${*$self}{UNLINK} = shift;
- }
- return ${*$self}{UNLINK};
-}
-
-=item B<DESTROY>
-
-When the object goes out of scope, the destructor is called. This
-destructor will attempt to unlink the file (using C<unlink1>)
-if the constructor was called with UNLINK set to 1 (the default state
-if UNLINK is not specified).
-
-No error is given if the unlink fails.
-
-If the object has been passed to a child process during a fork, the
-file will be deleted when the object goes out of scope in the parent.
-
-For a temporary directory object the directory will be removed
-unless the CLEANUP argument was used in the constructor (and set to
-false) or C<unlink_on_destroy> was modified after creation.
-
-If the global variable $KEEP_ALL is true, the file or directory
-will not be removed.
-
-=cut
-
-sub DESTROY {
- local($., $@, $!, $^E, $?);
- my $self = shift;
-
- # Make sure we always remove the file from the global hash
- # on destruction. This prevents the hash from growing uncontrollably
- # and post-destruction there is no reason to know about the file.
- my $file = $self->filename;
- my $was_created_by_proc;
- if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) {
- $was_created_by_proc = 1;
- delete $FILES_CREATED_BY_OBJECT{$$}{$file};
- }
-
- if (${*$self}{UNLINK} && !$KEEP_ALL) {
- print "# ---------> Unlinking $self\n" if $DEBUG;
-
- # only delete if this process created it
- return unless $was_created_by_proc;
-
- # The unlink1 may fail if the file has been closed
- # by the caller. This leaves us with the decision
- # of whether to refuse to remove the file or simply
- # do an unlink without test. Seems to be silly
- # to do this when we are trying to be careful
- # about security
- _force_writable( $file ); # for windows
- unlink1( $self, $file )
- or unlink($file);
- }
-}
-
-=back
-
-=head1 FUNCTIONS
-
-This section describes the recommended interface for generating
-temporary files and directories.
-
-=over 4
-
-=item B<tempfile>
-
-This is the basic function to generate temporary files.
-The behaviour of the file can be changed using various options:
-
- $fh = tempfile();
- ($fh, $filename) = tempfile();
-
-Create a temporary file in the directory specified for temporary
-files, as specified by the tmpdir() function in L<File::Spec>.
-
- ($fh, $filename) = tempfile($template);
-
-Create a temporary file in the current directory using the supplied
-template. Trailing `X' characters are replaced with random letters to
-generate the filename. At least four `X' characters must be present
-at the end of the template.
-
- ($fh, $filename) = tempfile($template, SUFFIX => $suffix)
-
-Same as previously, except that a suffix is added to the template
-after the `X' translation. Useful for ensuring that a temporary
-filename has a particular extension when needed by other applications.
-But see the WARNING at the end.
-
- ($fh, $filename) = tempfile($template, DIR => $dir);
-
-Translates the template as before except that a directory name
-is specified.
-
- ($fh, $filename) = tempfile($template, TMPDIR => 1);
-
-Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file
-into the same temporary directory as would be used if no template was
-specified at all.
-
- ($fh, $filename) = tempfile($template, UNLINK => 1);
-
-Return the filename and filehandle as before except that the file is
-automatically removed when the program exits (dependent on
-$KEEP_ALL). Default is for the file to be removed if a file handle is
-requested and to be kept if the filename is requested. In a scalar
-context (where no filename is returned) the file is always deleted
-either (depending on the operating system) on exit or when it is
-closed (unless $KEEP_ALL is true when the temp file is created).
-
-Use the object-oriented interface if fine-grained control of when
-a file is removed is required.
-
-If the template is not specified, a template is always
-automatically generated. This temporary file is placed in tmpdir()
-(L<File::Spec>) unless a directory is specified explicitly with the
-DIR option.
-
- $fh = tempfile( DIR => $dir );
-
-If called in scalar context, only the filehandle is returned and the
-file will automatically be deleted when closed on operating systems
-that support this (see the description of tmpfile() elsewhere in this
-document). This is the preferred mode of operation, as if you only
-have a filehandle, you can never create a race condition by fumbling
-with the filename. On systems that can not unlink an open file or can
-not mark a file as temporary when it is opened (for example, Windows
-NT uses the C<O_TEMPORARY> flag) the file is marked for deletion when
-the program ends (equivalent to setting UNLINK to 1). The C<UNLINK>
-flag is ignored if present.
-
- (undef, $filename) = tempfile($template, OPEN => 0);
-
-This will return the filename based on the template but
-will not open this file. Cannot be used in conjunction with
-UNLINK set to true. Default is to always open the file
-to protect from possible race conditions. A warning is issued
-if warnings are turned on. Consider using the tmpnam()
-and mktemp() functions described elsewhere in this document
-if opening the file is not required.
-
-If the operating system supports it (for example BSD derived systems), the
-filehandle will be opened with O_EXLOCK (open with exclusive file lock).
-This can sometimes cause problems if the intention is to pass the filename
-to another system that expects to take an exclusive lock itself (such as
-DBD::SQLite) whilst ensuring that the tempfile is not reused. In this
-situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK
-will be true (this retains compatibility with earlier releases).
-
- ($fh, $filename) = tempfile($template, EXLOCK => 0);
-
-Options can be combined as required.
-
-Will croak() if there is an error.
-
-=cut
-
-sub tempfile {
-
- # Can not check for argument count since we can have any
- # number of args
-
- # Default options
- my %options = (
- "DIR" => undef, # Directory prefix
- "SUFFIX" => '', # Template suffix
- "UNLINK" => 0, # Do not unlink file on exit
- "OPEN" => 1, # Open file
- "TMPDIR" => 0, # Place tempfile in tempdir if template specified
- "EXLOCK" => 1, # Open file with O_EXLOCK
- );
-
- # Check to see whether we have an odd or even number of arguments
- my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef);
-
- # Read the options and merge with defaults
- %options = (%options, @_) if @_;
-
- # First decision is whether or not to open the file
- if (! $options{"OPEN"}) {
-
- warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n"
- if $^W;
-
- }
-
- if ($options{"DIR"} and $^O eq 'VMS') {
-
- # on VMS turn []foo into [.foo] for concatenation
- $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"});
- }
-
- # Construct the template
-
- # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc
- # functions or simply constructing a template and using _gettemp()
- # explicitly. Go for the latter
-
- # First generate a template if not defined and prefix the directory
- # If no template must prefix the temp directory
- if (defined $template) {
- # End up with current directory if neither DIR not TMPDIR are set
- if ($options{"DIR"}) {
-
- $template = File::Spec->catfile($options{"DIR"}, $template);
-
- } elsif ($options{TMPDIR}) {
-
- $template = File::Spec->catfile(File::Spec->tmpdir, $template );
-
- }
-
- } else {
-
- if ($options{"DIR"}) {
-
- $template = File::Spec->catfile($options{"DIR"}, TEMPXXX);
-
- } else {
-
- $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX);
-
- }
-
- }
-
- # Now add a suffix
- $template .= $options{"SUFFIX"};
-
- # Determine whether we should tell _gettemp to unlink the file
- # On unix this is irrelevant and can be worked out after the file is
- # opened (simply by unlinking the open filehandle). On Windows or VMS
- # we have to indicate temporary-ness when we open the file. In general
- # we only want a true temporary file if we are returning just the
- # filehandle - if the user wants the filename they probably do not
- # want the file to disappear as soon as they close it (which may be
- # important if they want a child process to use the file)
- # For this reason, tie unlink_on_close to the return context regardless
- # of OS.
- my $unlink_on_close = ( wantarray ? 0 : 1);
-
- # Create the file
- my ($fh, $path, $errstr);
- croak "Error in tempfile() using $template: $errstr"
- unless (($fh, $path) = _gettemp($template,
- "open" => $options{'OPEN'},
- "mkdir"=> 0 ,
- "unlink_on_close" => $unlink_on_close,
- "suffixlen" => length($options{'SUFFIX'}),
- "ErrStr" => \$errstr,
- "use_exlock" => $options{EXLOCK},
- ) );
-
- # Set up an exit handler that can do whatever is right for the
- # system. This removes files at exit when requested explicitly or when
- # system is asked to unlink_on_close but is unable to do so because
- # of OS limitations.
- # The latter should be achieved by using a tied filehandle.
- # Do not check return status since this is all done with END blocks.
- _deferred_unlink($fh, $path, 0) if $options{"UNLINK"};
-
- # Return
- if (wantarray()) {
-
- if ($options{'OPEN'}) {
- return ($fh, $path);
- } else {
- return (undef, $path);
- }
-
- } else {
-
- # Unlink the file. It is up to unlink0 to decide what to do with
- # this (whether to unlink now or to defer until later)
- unlink0($fh, $path) or croak "Error unlinking file $path using unlink0";
-
- # Return just the filehandle.
- return $fh;
- }
-
-
-}
-
-=item B<tempdir>
-
-This is the recommended interface for creation of temporary
-directories. By default the directory will not be removed on exit
-(that is, it won't be temporary; this behaviour can not be changed
-because of issues with backwards compatibility). To enable removal
-either use the CLEANUP option which will trigger removal on program
-exit, or consider using the "newdir" method in the object interface which
-will allow the directory to be cleaned up when the object goes out of
-scope.
-
-The behaviour of the function depends on the arguments:
-
- $tempdir = tempdir();
-
-Create a directory in tmpdir() (see L<File::Spec|File::Spec>).
-
- $tempdir = tempdir( $template );
-
-Create a directory from the supplied template. This template is
-similar to that described for tempfile(). `X' characters at the end
-of the template are replaced with random letters to construct the
-directory name. At least four `X' characters must be in the template.
-
- $tempdir = tempdir ( DIR => $dir );
-
-Specifies the directory to use for the temporary directory.
-The temporary directory name is derived from an internal template.
-
- $tempdir = tempdir ( $template, DIR => $dir );
-
-Prepend the supplied directory name to the template. The template
-should not include parent directory specifications itself. Any parent
-directory specifications are removed from the template before
-prepending the supplied directory.
-
- $tempdir = tempdir ( $template, TMPDIR => 1 );
-
-Using the supplied template, create the temporary directory in
-a standard location for temporary files. Equivalent to doing
-
- $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir);
-
-but shorter. Parent directory specifications are stripped from the
-template itself. The C<TMPDIR> option is ignored if C<DIR> is set
-explicitly. Additionally, C<TMPDIR> is implied if neither a template
-nor a directory are supplied.
-
- $tempdir = tempdir( $template, CLEANUP => 1);
-
-Create a temporary directory using the supplied template, but
-attempt to remove it (and all files inside it) when the program
-exits. Note that an attempt will be made to remove all files from
-the directory even if they were not created by this module (otherwise
-why ask to clean it up?). The directory removal is made with
-the rmtree() function from the L<File::Path|File::Path> module.
-Of course, if the template is not specified, the temporary directory
-will be created in tmpdir() and will also be removed at program exit.
-
-Will croak() if there is an error.
-
-=cut
-
-# '
-
-sub tempdir {
-
- # Can not check for argument count since we can have any
- # number of args
-
- # Default options
- my %options = (
- "CLEANUP" => 0, # Remove directory on exit
- "DIR" => '', # Root directory
- "TMPDIR" => 0, # Use tempdir with template
- );
-
- # Check to see whether we have an odd or even number of arguments
- my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef );
-
- # Read the options and merge with defaults
- %options = (%options, @_) if @_;
-
- # Modify or generate the template
-
- # Deal with the DIR and TMPDIR options
- if (defined $template) {
-
- # Need to strip directory path if using DIR or TMPDIR
- if ($options{'TMPDIR'} || $options{'DIR'}) {
-
- # Strip parent directory from the filename
- #
- # There is no filename at the end
- $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS';
- my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1);
-
- # Last directory is then our template
- $template = (File::Spec->splitdir($directories))[-1];
-
- # Prepend the supplied directory or temp dir
- if ($options{"DIR"}) {
-
- $template = File::Spec->catdir($options{"DIR"}, $template);
-
- } elsif ($options{TMPDIR}) {
-
- # Prepend tmpdir
- $template = File::Spec->catdir(File::Spec->tmpdir, $template);
-
- }
-
- }
-
- } else {
-
- if ($options{"DIR"}) {
-
- $template = File::Spec->catdir($options{"DIR"}, TEMPXXX);
-
- } else {
-
- $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX);
-
- }
-
- }
-
- # Create the directory
- my $tempdir;
- my $suffixlen = 0;
- if ($^O eq 'VMS') { # dir names can end in delimiters
- $template =~ m/([\.\]:>]+)$/;
- $suffixlen = length($1);
- }
- if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
- # dir name has a trailing ':'
- ++$suffixlen;
- }
-
- my $errstr;
- croak "Error in tempdir() using $template: $errstr"
- unless ((undef, $tempdir) = _gettemp($template,
- "open" => 0,
- "mkdir"=> 1 ,
- "suffixlen" => $suffixlen,
- "ErrStr" => \$errstr,
- ) );
-
- # Install exit handler; must be dynamic to get lexical
- if ( $options{'CLEANUP'} && -d $tempdir) {
- _deferred_unlink(undef, $tempdir, 1);
- }
-
- # Return the dir name
- return $tempdir;
-
-}
-
-=back
-
-=head1 MKTEMP FUNCTIONS
-
-The following functions are Perl implementations of the
-mktemp() family of temp file generation system calls.
-
-=over 4
-
-=item B<mkstemp>
-
-Given a template, returns a filehandle to the temporary file and the name
-of the file.
-
- ($fh, $name) = mkstemp( $template );
-
-In scalar context, just the filehandle is returned.
-
-The template may be any filename with some number of X's appended
-to it, for example F</tmp/temp.XXXX>. The trailing X's are replaced
-with unique alphanumeric combinations.
-
-Will croak() if there is an error.
-
-=cut
-
-
-
-sub mkstemp {
-
- croak "Usage: mkstemp(template)"
- if scalar(@_) != 1;
-
- my $template = shift;
-
- my ($fh, $path, $errstr);
- croak "Error in mkstemp using $template: $errstr"
- unless (($fh, $path) = _gettemp($template,
- "open" => 1,
- "mkdir"=> 0 ,
- "suffixlen" => 0,
- "ErrStr" => \$errstr,
- ) );
-
- if (wantarray()) {
- return ($fh, $path);
- } else {
- return $fh;
- }
-
-}
-
-
-=item B<mkstemps>
-
-Similar to mkstemp(), except that an extra argument can be supplied
-with a suffix to be appended to the template.
-
- ($fh, $name) = mkstemps( $template, $suffix );
-
-For example a template of C<testXXXXXX> and suffix of C<.dat>
-would generate a file similar to F<testhGji_w.dat>.
-
-Returns just the filehandle alone when called in scalar context.
-
-Will croak() if there is an error.
-
-=cut
-
-sub mkstemps {
-
- croak "Usage: mkstemps(template, suffix)"
- if scalar(@_) != 2;
-
-
- my $template = shift;
- my $suffix = shift;
-
- $template .= $suffix;
-
- my ($fh, $path, $errstr);
- croak "Error in mkstemps using $template: $errstr"
- unless (($fh, $path) = _gettemp($template,
- "open" => 1,
- "mkdir"=> 0 ,
- "suffixlen" => length($suffix),
- "ErrStr" => \$errstr,
- ) );
-
- if (wantarray()) {
- return ($fh, $path);
- } else {
- return $fh;
- }
-
-}
-
-=item B<mkdtemp>
-
-Create a directory from a template. The template must end in
-X's that are replaced by the routine.
-
- $tmpdir_name = mkdtemp($template);
-
-Returns the name of the temporary directory created.
-
-Directory must be removed by the caller.
-
-Will croak() if there is an error.
-
-=cut
-
-#' # for emacs
-
-sub mkdtemp {
-
- croak "Usage: mkdtemp(template)"
- if scalar(@_) != 1;
-
- my $template = shift;
- my $suffixlen = 0;
- if ($^O eq 'VMS') { # dir names can end in delimiters
- $template =~ m/([\.\]:>]+)$/;
- $suffixlen = length($1);
- }
- if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) {
- # dir name has a trailing ':'
- ++$suffixlen;
- }
- my ($junk, $tmpdir, $errstr);
- croak "Error creating temp directory from template $template\: $errstr"
- unless (($junk, $tmpdir) = _gettemp($template,
- "open" => 0,
- "mkdir"=> 1 ,
- "suffixlen" => $suffixlen,
- "ErrStr" => \$errstr,
- ) );
-
- return $tmpdir;
-
-}
-
-=item B<mktemp>
-
-Returns a valid temporary filename but does not guarantee
-that the file will not be opened by someone else.
-
- $unopened_file = mktemp($template);
-
-Template is the same as that required by mkstemp().
-
-Will croak() if there is an error.
-
-=cut
-
-sub mktemp {
-
- croak "Usage: mktemp(template)"
- if scalar(@_) != 1;
-
- my $template = shift;
-
- my ($tmpname, $junk, $errstr);
- croak "Error getting name to temp file from template $template: $errstr"
- unless (($junk, $tmpname) = _gettemp($template,
- "open" => 0,
- "mkdir"=> 0 ,
- "suffixlen" => 0,
- "ErrStr" => \$errstr,
- ) );
-
- return $tmpname;
-}
-
-=back
-
-=head1 POSIX FUNCTIONS
-
-This section describes the re-implementation of the tmpnam()
-and tmpfile() functions described in L<POSIX>
-using the mkstemp() from this module.
-
-Unlike the L<POSIX|POSIX> implementations, the directory used
-for the temporary file is not specified in a system include
-file (C<P_tmpdir>) but simply depends on the choice of tmpdir()
-returned by L<File::Spec|File::Spec>. On some implementations this
-location can be set using the C<TMPDIR> environment variable, which
-may not be secure.
-If this is a problem, simply use mkstemp() and specify a template.
-
-=over 4
-
-=item B<tmpnam>
-
-When called in scalar context, returns the full name (including path)
-of a temporary file (uses mktemp()). The only check is that the file does
-not already exist, but there is no guarantee that that condition will
-continue to apply.
-
- $file = tmpnam();
-
-When called in list context, a filehandle to the open file and
-a filename are returned. This is achieved by calling mkstemp()
-after constructing a suitable template.
-
- ($fh, $file) = tmpnam();
-
-If possible, this form should be used to prevent possible
-race conditions.
-
-See L<File::Spec/tmpdir> for information on the choice of temporary
-directory for a particular operating system.
-
-Will croak() if there is an error.
-
-=cut
-
-sub tmpnam {
-
- # Retrieve the temporary directory name
- my $tmpdir = File::Spec->tmpdir;
-
- croak "Error temporary directory is not writable"
- if $tmpdir eq '';
-
- # Use a ten character template and append to tmpdir
- my $template = File::Spec->catfile($tmpdir, TEMPXXX);
-
- if (wantarray() ) {
- return mkstemp($template);
- } else {
- return mktemp($template);
- }
-
-}
-
-=item B<tmpfile>
-
-Returns the filehandle of a temporary file.
-
- $fh = tmpfile();
-
-The file is removed when the filehandle is closed or when the program
-exits. No access to the filename is provided.
-
-If the temporary file can not be created undef is returned.
-Currently this command will probably not work when the temporary
-directory is on an NFS file system.
-
-Will croak() if there is an error.
-
-=cut
-
-sub tmpfile {
-
- # Simply call tmpnam() in a list context
- my ($fh, $file) = tmpnam();
-
- # Make sure file is removed when filehandle is closed
- # This will fail on NFS
- unlink0($fh, $file)
- or return undef;
-
- return $fh;
-
-}
-
-=back
-
-=head1 ADDITIONAL FUNCTIONS
-
-These functions are provided for backwards compatibility
-with common tempfile generation C library functions.
-
-They are not exported and must be addressed using the full package
-name.
-
-=over 4
-
-=item B<tempnam>
-
-Return the name of a temporary file in the specified directory
-using a prefix. The file is guaranteed not to exist at the time
-the function was called, but such guarantees are good for one
-clock tick only. Always use the proper form of C<sysopen>
-with C<O_CREAT | O_EXCL> if you must open such a filename.
-
- $filename = File::Temp::tempnam( $dir, $prefix );
-
-Equivalent to running mktemp() with $dir/$prefixXXXXXXXX
-(using unix file convention as an example)
-
-Because this function uses mktemp(), it can suffer from race conditions.
-
-Will croak() if there is an error.
-
-=cut
-
-sub tempnam {
-
- croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2;
-
- my ($dir, $prefix) = @_;
-
- # Add a string to the prefix
- $prefix .= 'XXXXXXXX';
-
- # Concatenate the directory to the file
- my $template = File::Spec->catfile($dir, $prefix);
-
- return mktemp($template);
-
-}
-
-=back
-
-=head1 UTILITY FUNCTIONS
-
-Useful functions for dealing with the filehandle and filename.
-
-=over 4
-
-=item B<unlink0>
-
-Given an open filehandle and the associated filename, make a safe
-unlink. This is achieved by first checking that the filename and
-filehandle initially point to the same file and that the number of
-links to the file is 1 (all fields returned by stat() are compared).
-Then the filename is unlinked and the filehandle checked once again to
-verify that the number of links on that file is now 0. This is the
-closest you can come to making sure that the filename unlinked was the
-same as the file whose descriptor you hold.
-
- unlink0($fh, $path)
- or die "Error unlinking file $path safely";
-
-Returns false on error but croaks() if there is a security
-anomaly. The filehandle is not closed since on some occasions this is
-not required.
-
-On some platforms, for example Windows NT, it is not possible to
-unlink an open file (the file must be closed first). On those
-platforms, the actual unlinking is deferred until the program ends and
-good status is returned. A check is still performed to make sure that
-the filehandle and filename are pointing to the same thing (but not at
-the time the end block is executed since the deferred removal may not
-have access to the filehandle).
-
-Additionally, on Windows NT not all the fields returned by stat() can
-be compared. For example, the C<dev> and C<rdev> fields seem to be
-different. Also, it seems that the size of the file returned by stat()
-does not always agree, with C<stat(FH)> being more accurate than
-C<stat(filename)>, presumably because of caching issues even when
-using autoflush (this is usually overcome by waiting a while after
-writing to the tempfile before attempting to C<unlink0> it).
-
-Finally, on NFS file systems the link count of the file handle does
-not always go to zero immediately after unlinking. Currently, this
-command is expected to fail on NFS disks.
-
-This function is disabled if the global variable $KEEP_ALL is true
-and an unlink on open file is supported. If the unlink is to be deferred
-to the END block, the file is still registered for removal.
-
-This function should not be called if you are using the object oriented
-interface since the it will interfere with the object destructor deleting
-the file.
-
-=cut
-
-sub unlink0 {
-
- croak 'Usage: unlink0(filehandle, filename)'
- unless scalar(@_) == 2;
-
- # Read args
- my ($fh, $path) = @_;
-
- cmpstat($fh, $path) or return 0;
-
- # attempt remove the file (does not work on some platforms)
- if (_can_unlink_opened_file()) {
-
- # return early (Without unlink) if we have been instructed to retain files.
- return 1 if $KEEP_ALL;
-
- # XXX: do *not* call this on a directory; possible race
- # resulting in recursive removal
- croak "unlink0: $path has become a directory!" if -d $path;
- unlink($path) or return 0;
-
- # Stat the filehandle
- my @fh = stat $fh;
-
- print "Link count = $fh[3] \n" if $DEBUG;
-
- # Make sure that the link count is zero
- # - Cygwin provides deferred unlinking, however,
- # on Win9x the link count remains 1
- # On NFS the link count may still be 1 but we cant know that
- # we are on NFS
- return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0);
-
- } else {
- _deferred_unlink($fh, $path, 0);
- return 1;
- }
-
-}
-
-=item B<cmpstat>
-
-Compare C<stat> of filehandle with C<stat> of provided filename. This
-can be used to check that the filename and filehandle initially point
-to the same file and that the number of links to the file is 1 (all
-fields returned by stat() are compared).
-
- cmpstat($fh, $path)
- or die "Error comparing handle with file";
-
-Returns false if the stat information differs or if the link count is
-greater than 1. Calls croak if there is a security anomaly.
-
-On certain platforms, for example Windows, not all the fields returned by stat()
-can be compared. For example, the C<dev> and C<rdev> fields seem to be
-different in Windows. Also, it seems that the size of the file
-returned by stat() does not always agree, with C<stat(FH)> being more
-accurate than C<stat(filename)>, presumably because of caching issues
-even when using autoflush (this is usually overcome by waiting a while
-after writing to the tempfile before attempting to C<unlink0> it).
-
-Not exported by default.
-
-=cut
-
-sub cmpstat {
-
- croak 'Usage: cmpstat(filehandle, filename)'
- unless scalar(@_) == 2;
-
- # Read args
- my ($fh, $path) = @_;
-
- warn "Comparing stat\n"
- if $DEBUG;
-
- # Stat the filehandle - which may be closed if someone has manually
- # closed the file. Can not turn off warnings without using $^W
- # unless we upgrade to 5.006 minimum requirement
- my @fh;
- {
- local ($^W) = 0;
- @fh = stat $fh;
- }
- return unless @fh;
-
- if ($fh[3] > 1 && $^W) {
- carp "unlink0: fstat found too many links; SB=@fh" if $^W;
- }
-
- # Stat the path
- my @path = stat $path;
-
- unless (@path) {
- carp "unlink0: $path is gone already" if $^W;
- return;
- }
-
- # this is no longer a file, but may be a directory, or worse
- unless (-f $path) {
- confess "panic: $path is no longer a file: SB=@fh";
- }
-
- # Do comparison of each member of the array
- # On WinNT dev and rdev seem to be different
- # depending on whether it is a file or a handle.
- # Cannot simply compare all members of the stat return
- # Select the ones we can use
- my @okstat = (0..$#fh); # Use all by default
- if ($^O eq 'MSWin32') {
- @okstat = (1,2,3,4,5,7,8,9,10);
- } elsif ($^O eq 'os2') {
- @okstat = (0, 2..$#fh);
- } elsif ($^O eq 'VMS') { # device and file ID are sufficient
- @okstat = (0, 1);
- } elsif ($^O eq 'dos') {
- @okstat = (0,2..7,11..$#fh);
- } elsif ($^O eq 'mpeix') {
- @okstat = (0..4,8..10);
- }
-
- # Now compare each entry explicitly by number
- for (@okstat) {
- print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG;
- # Use eq rather than == since rdev, blksize, and blocks (6, 11,
- # and 12) will be '' on platforms that do not support them. This
- # is fine since we are only comparing integers.
- unless ($fh[$_] eq $path[$_]) {
- warn "Did not match $_ element of stat\n" if $DEBUG;
- return 0;
- }
- }
-
- return 1;
-}
-
-=item B<unlink1>
-
-Similar to C<unlink0> except after file comparison using cmpstat, the
-filehandle is closed prior to attempting to unlink the file. This
-allows the file to be removed without using an END block, but does
-mean that the post-unlink comparison of the filehandle state provided
-by C<unlink0> is not available.
-
- unlink1($fh, $path)
- or die "Error closing and unlinking file";
-
-Usually called from the object destructor when using the OO interface.
-
-Not exported by default.
-
-This function is disabled if the global variable $KEEP_ALL is true.
-
-Can call croak() if there is a security anomaly during the stat()
-comparison.
-
-=cut
-
-sub unlink1 {
- croak 'Usage: unlink1(filehandle, filename)'
- unless scalar(@_) == 2;
-
- # Read args
- my ($fh, $path) = @_;
-
- cmpstat($fh, $path) or return 0;
-
- # Close the file
- close( $fh ) or return 0;
-
- # Make sure the file is writable (for windows)
- _force_writable( $path );
-
- # return early (without unlink) if we have been instructed to retain files.
- return 1 if $KEEP_ALL;
-
- # remove the file
- return unlink($path);
-}
-
-=item B<cleanup>
-
-Calling this function will cause any temp files or temp directories
-that are registered for removal to be removed. This happens automatically
-when the process exits but can be triggered manually if the caller is sure
-that none of the temp files are required. This method can be registered as
-an Apache callback.
-
-On OSes where temp files are automatically removed when the temp file
-is closed, calling this function will have no effect other than to remove
-temporary directories (which may include temporary files).
-
- File::Temp::cleanup();
-
-Not exported by default.
-
-=back
-
-=head1 PACKAGE VARIABLES
-
-These functions control the global state of the package.
-
-=over 4
-
-=item B<safe_level>
-
-Controls the lengths to which the module will go to check the safety of the
-temporary file or directory before proceeding.
-Options are:
-
-=over 8
-
-=item STANDARD
-
-Do the basic security measures to ensure the directory exists and is
-writable, that temporary files are opened only if they do not already
-exist, and that possible race conditions are avoided. Finally the
-L<unlink0|"unlink0"> function is used to remove files safely.
-
-=item MEDIUM
-
-In addition to the STANDARD security, the output directory is checked
-to make sure that it is owned either by root or the user running the
-program. If the directory is writable by group or by other, it is then
-checked to make sure that the sticky bit is set.
-
-Will not work on platforms that do not support the C<-k> test
-for sticky bit.
-
-=item HIGH
-
-In addition to the MEDIUM security checks, also check for the
-possibility of ``chown() giveaway'' using the L<POSIX|POSIX>
-sysconf() function. If this is a possibility, each directory in the
-path is checked in turn for safeness, recursively walking back to the
-root directory.
-
-For platforms that do not support the L<POSIX|POSIX>
-C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is
-assumed that ``chown() giveaway'' is possible and the recursive test
-is performed.
-
-=back
-
-The level can be changed as follows:
-
- File::Temp->safe_level( File::Temp::HIGH );
-
-The level constants are not exported by the module.
-
-Currently, you must be running at least perl v5.6.0 in order to
-run with MEDIUM or HIGH security. This is simply because the
-safety tests use functions from L<Fcntl|Fcntl> that are not
-available in older versions of perl. The problem is that the version
-number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though
-they are different versions.
-
-On systems that do not support the HIGH or MEDIUM safety levels
-(for example Win NT or OS/2) any attempt to change the level will
-be ignored. The decision to ignore rather than raise an exception
-allows portable programs to be written with high security in mind
-for the systems that can support this without those programs failing
-on systems where the extra tests are irrelevant.
-
-If you really need to see whether the change has been accepted
-simply examine the return value of C<safe_level>.
-
- $newlevel = File::Temp->safe_level( File::Temp::HIGH );
- die "Could not change to high security"
- if $newlevel != File::Temp::HIGH;
-
-=cut
-
-{
- # protect from using the variable itself
- my $LEVEL = STANDARD;
- sub safe_level {
- my $self = shift;
- if (@_) {
- my $level = shift;
- if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) {
- carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W;
- } else {
- # Dont allow this on perl 5.005 or earlier
- if ($] < 5.006 && $level != STANDARD) {
- # Cant do MEDIUM or HIGH checks
- croak "Currently requires perl 5.006 or newer to do the safe checks";
- }
- # Check that we are allowed to change level
- # Silently ignore if we can not.
- $LEVEL = $level if _can_do_level($level);
- }
- }
- return $LEVEL;
- }
-}
-
-=item TopSystemUID
-
-This is the highest UID on the current system that refers to a root
-UID. This is used to make sure that the temporary directory is
-owned by a system UID (C<root>, C<bin>, C<sys> etc) rather than
-simply by root.
-
-This is required since on many unix systems C</tmp> is not owned
-by root.
-
-Default is to assume that any UID less than or equal to 10 is a root
-UID.
-
- File::Temp->top_system_uid(10);
- my $topid = File::Temp->top_system_uid;
-
-This value can be adjusted to reduce security checking if required.
-The value is only relevant when C<safe_level> is set to MEDIUM or higher.
-
-=cut
-
-{
- my $TopSystemUID = 10;
- $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator"
- sub top_system_uid {
- my $self = shift;
- if (@_) {
- my $newuid = shift;
- croak "top_system_uid: UIDs should be numeric"
- unless $newuid =~ /^\d+$/s;
- $TopSystemUID = $newuid;
- }
- return $TopSystemUID;
- }
-}
-
-=item B<$KEEP_ALL>
-
-Controls whether temporary files and directories should be retained
-regardless of any instructions in the program to remove them
-automatically. This is useful for debugging but should not be used in
-production code.
-
- $File::Temp::KEEP_ALL = 1;
-
-Default is for files to be removed as requested by the caller.
-
-In some cases, files will only be retained if this variable is true
-when the file is created. This means that you can not create a temporary
-file, set this variable and expect the temp file to still be around
-when the program exits.
-
-=item B<$DEBUG>
-
-Controls whether debugging messages should be enabled.
-
- $File::Temp::DEBUG = 1;
-
-Default is for debugging mode to be disabled.
-
-=back
-
-=head1 WARNING
-
-For maximum security, endeavour always to avoid ever looking at,
-touching, or even imputing the existence of the filename. You do not
-know that that filename is connected to the same file as the handle
-you have, and attempts to check this can only trigger more race
-conditions. It's far more secure to use the filehandle alone and
-dispense with the filename altogether.
-
-If you need to pass the handle to something that expects a filename
-then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary
-programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl
-programs. You will have to clear the close-on-exec bit on that file
-descriptor before passing it to another process.
-
- use Fcntl qw/F_SETFD F_GETFD/;
- fcntl($tmpfh, F_SETFD, 0)
- or die "Can't clear close-on-exec flag on temp fh: $!\n";
-
-=head2 Temporary files and NFS
-
-Some problems are associated with using temporary files that reside
-on NFS file systems and it is recommended that a local filesystem
-is used whenever possible. Some of the security tests will most probably
-fail when the temp file is not local. Additionally, be aware that
-the performance of I/O operations over NFS will not be as good as for
-a local disk.
-
-=head2 Forking
-
-In some cases files created by File::Temp are removed from within an
-END block. Since END blocks are triggered when a child process exits
-(unless C<POSIX::_exit()> is used by the child) File::Temp takes care
-to only remove those temp files created by a particular process ID. This
-means that a child will not attempt to remove temp files created by the
-parent process.
-
-If you are forking many processes in parallel that are all creating
-temporary files, you may need to reset the random number seed using
-srand(EXPR) in each child else all the children will attempt to walk
-through the same set of random file names and may well cause
-themselves to give up if they exceed the number of retry attempts.
-
-=head2 Directory removal
-
-Note that if you have chdir'ed into the temporary directory and it is
-subsequently cleaned up (either in the END block or as part of object
-destruction), then you will get a warning from File::Path::rmtree().
-
-=head2 BINMODE
-
-The file returned by File::Temp will have been opened in binary mode
-if such a mode is available. If that is not correct, use the C<binmode()>
-function to change the mode of the filehandle.
-
-Note that you can modify the encoding of a file opened by File::Temp
-also by using C<binmode()>.
-
-=head1 HISTORY
-
-Originally began life in May 1999 as an XS interface to the system
-mkstemp() function. In March 2000, the OpenBSD mkstemp() code was
-translated to Perl for total control of the code's
-security checking, to ensure the presence of the function regardless of
-operating system and to help with portability. The module was shipped
-as a standard part of perl from v5.6.1.
-
-=head1 SEE ALSO
-
-L<POSIX/tmpnam>, L<POSIX/tmpfile>, L<File::Spec>, L<File::Path>
-
-See L<IO::File> and L<File::MkTemp>, L<Apache::TempFile> for
-different implementations of temporary file handling.
-
-See L<File::Tempdir> for an alternative object-oriented wrapper for
-the C<tempdir> function.
-
-=head1 AUTHOR
-
-Tim Jenness E<lt>tjenness at cpan.orgE<gt>
-
-Copyright (C) 2007-2009 Tim Jenness.
-Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and
-Astronomy Research Council. All Rights Reserved. This program is free
-software; you can redistribute it and/or modify it under the same
-terms as Perl itself.
-
-Original Perl implementation loosely based on the OpenBSD C code for
-mkstemp(). Thanks to Tom Christiansen for suggesting that this module
-should be written and providing ideas for code improvements and
-security enhancements.
-
-=cut
-
-package File::Temp::Dir;
-
-use File::Path qw/ rmtree /;
-use strict;
-use overload '""' => "STRINGIFY", fallback => 1;
-
-# private class specifically to support tempdir objects
-# created by File::Temp->newdir
-
-# ostensibly the same method interface as File::Temp but without
-# inheriting all the IO::Seekable methods and other cruft
-
-# Read-only - returns the name of the temp directory
-
-sub dirname {
- my $self = shift;
- return $self->{DIRNAME};
-}
-
-sub STRINGIFY {
- my $self = shift;
- return $self->dirname;
-}
-
-sub unlink_on_destroy {
- my $self = shift;
- if (@_) {
- $self->{CLEANUP} = shift;
- }
- return $self->{CLEANUP};
-}
-
-sub DESTROY {
- my $self = shift;
- local($., $@, $!, $^E, $?);
- if ($self->unlink_on_destroy &&
- $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) {
- if (-d $self->{DIRNAME}) {
- # Some versions of rmtree will abort if you attempt to remove
- # the directory you are sitting in. We protect that and turn it
- # into a warning. We do this because this occurs during object
- # destruction and so can not be caught by the user.
- eval { rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0); };
- warn $@ if ($@ && $^W);
- }
- }
-}
-
-
-1;
Deleted: trunk/contrib/perl/lib/FileCache.pm
===================================================================
--- trunk/contrib/perl/lib/FileCache.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/FileCache.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,188 +0,0 @@
-package FileCache;
-
-our $VERSION = '1.08';
-
-=head1 NAME
-
-FileCache - keep more files open than the system permits
-
-=head1 SYNOPSIS
-
- no strict 'refs';
-
- use FileCache;
- # or
- use FileCache maxopen => 16;
-
- cacheout $mode, $path;
- # or
- cacheout $path;
- print $path @data;
-
- $fh = cacheout $mode, $path;
- # or
- $fh = cacheout $path;
- print $fh @data;
-
-=head1 DESCRIPTION
-
-The C<cacheout> function will make sure that there's a filehandle open
-for reading or writing available as the pathname you give it. It
-automatically closes and re-opens files if you exceed your system's
-maximum number of file descriptors, or the suggested maximum I<maxopen>.
-
-=over
-
-=item cacheout EXPR
-
-The 1-argument form of cacheout will open a file for writing (C<< '>' >>)
-on it's first use, and appending (C<<< '>>' >>>) thereafter.
-
-Returns EXPR on success for convenience. You may neglect the
-return value and manipulate EXPR as the filehandle directly if you prefer.
-
-=item cacheout MODE, EXPR
-
-The 2-argument form of cacheout will use the supplied mode for the initial
-and subsequent openings. Most valid modes for 3-argument C<open> are supported
-namely; C<< '>' >>, C<< '+>' >>, C<< '<' >>, C<< '<+' >>, C<<< '>>' >>>,
-C< '|-' > and C< '-|' >
-
-To pass supplemental arguments to a program opened with C< '|-' > or C< '-|' >
-append them to the command string as you would system EXPR.
-
-Returns EXPR on success for convenience. You may neglect the
-return value and manipulate EXPR as the filehandle directly if you prefer.
-
-=back
-
-=head1 CAVEATS
-
-While it is permissible to C<close> a FileCache managed file,
-do not do so if you are calling C<FileCache::cacheout> from a package other
-than which it was imported, or with another module which overrides C<close>.
-If you must, use C<FileCache::cacheout_close>.
-
-Although FileCache can be used with piped opens ('-|' or '|-') doing so is
-strongly discouraged. If FileCache finds it necessary to close and then reopen
-a pipe, the command at the far end of the pipe will be reexecuted - the results
-of performing IO on FileCache'd pipes is unlikely to be what you expect. The
-ability to use FileCache on pipes may be removed in a future release.
-
-FileCache does not store the current file offset if it finds it necessary to
-close a file. When the file is reopened, the offset will be as specified by the
-original C<open> file mode. This could be construed to be a bug.
-
-The module functionality relies on symbolic references, so things will break
-under 'use strict' unless 'no strict "refs"' is also specified.
-
-=head1 BUGS
-
-F<sys/param.h> lies with its C<NOFILE> define on some systems,
-so you may have to set I<maxopen> yourself.
-
-=cut
-
-require 5.006;
-use Carp;
-use strict;
-no strict 'refs';
-
-# These are not C<my> for legacy reasons.
-# Previous versions requested the user set $cacheout_maxopen by hand.
-# Some authors fiddled with %saw to overcome the clobber on initial open.
-use vars qw(%saw $cacheout_maxopen);
-$cacheout_maxopen = 16;
-
-use base 'Exporter';
-our @EXPORT = qw[cacheout cacheout_close];
-
-
-my %isopen;
-my $cacheout_seq = 0;
-
-sub import {
- my ($pkg,%args) = @_;
-
- # Use Exporter. %args are for us, not Exporter.
- # Make sure to up export_to_level, or we will import into ourselves,
- # rather than our calling package;
-
- __PACKAGE__->export_to_level(1);
- Exporter::import( $pkg );
-
- # Truth is okay here because setting maxopen to 0 would be bad
- return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
-
- # XXX This code is crazy. Why is it a one element foreach loop?
- # Why is it using $param both as a filename and filehandle?
- foreach my $param ( '/usr/include/sys/param.h' ){
- if (open($param, '<', $param)) {
- local ($_, $.);
- while (<$param>) {
- if( /^\s*#\s*define\s+NOFILE\s+(\d+)/ ){
- $cacheout_maxopen = $1 - 4;
- close($param);
- last;
- }
- }
- close $param;
- }
- }
- $cacheout_maxopen ||= 16;
-}
-
-# Open in their package.
-sub cacheout_open {
- return open(*{caller(1) . '::' . $_[1]}, $_[0], $_[1]) && $_[1];
-}
-
-# Close in their package.
-sub cacheout_close {
- # Short-circuit in case the filehandle disappeared
- my $pkg = caller($_[1]||0);
- defined fileno(*{$pkg . '::' . $_[0]}) &&
- CORE::close(*{$pkg . '::' . $_[0]});
- delete $isopen{$_[0]};
-}
-
-# But only this sub name is visible to them.
-sub cacheout {
- my($mode, $file, $class, $ret, $ref, $narg);
- croak "Not enough arguments for cacheout" unless $narg = scalar @_;
- croak "Too many arguments for cacheout" if $narg > 2;
-
- ($mode, $file) = @_;
- ($file, $mode) = ($mode, $file) if $narg == 1;
- croak "Invalid mode for cacheout" if $mode &&
- ( $mode !~ /^\s*(?:>>|\+?>|\+?<|\|\-|)|\-\|\s*$/ );
-
- # Mode changed?
- if( $isopen{$file} && ($mode||'>') ne $isopen{$file}->[1] ){
- &cacheout_close($file, 1);
- }
-
- if( $isopen{$file}) {
- $ret = $file;
- $isopen{$file}->[0]++;
- }
- else{
- if( scalar keys(%isopen) > $cacheout_maxopen -1 ) {
- my @lru = sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } keys(%isopen);
- $cacheout_seq = 0;
- $isopen{$_}->[0] = $cacheout_seq++ for
- splice(@lru, int($cacheout_maxopen / 3)||$cacheout_maxopen);
- &cacheout_close($_, 1) for @lru;
- }
-
- unless( $ref ){
- $mode ||= $saw{$file} ? '>>' : ($saw{$file}=1, '>');
- }
- #XXX should we just return the value from cacheout_open, no croak?
- $ret = cacheout_open($mode, $file) or croak("Can't create $file: $!");
-
- $isopen{$file} = [++$cacheout_seq, $mode];
- }
- return $ret;
-}
-1;
Deleted: trunk/contrib/perl/lib/Getopt/Long.pm
===================================================================
--- trunk/contrib/perl/lib/Getopt/Long.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Getopt/Long.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,2649 +0,0 @@
-# Getopt::Long.pm -- Universal options parsing
-
-package Getopt::Long;
-
-# RCS Status : $Id: Long.pm,v 1.1.1.2 2011-02-17 12:49:39 laffer1 Exp $
-# Author : Johan Vromans
-# Created On : Tue Sep 11 15:00:12 1990
-# Last Modified By: Johan Vromans
-# Last Modified On: Mon Mar 30 22:51:17 2009
-# Update Count : 1601
-# Status : Released
-
-################ Module Preamble ################
-
-use 5.004;
-
-use strict;
-
-use vars qw($VERSION);
-$VERSION = 2.38;
-# For testing versions only.
-#use vars qw($VERSION_STRING);
-#$VERSION_STRING = "2.38";
-
-use Exporter;
-use vars qw(@ISA @EXPORT @EXPORT_OK);
- at ISA = qw(Exporter);
-
-# Exported subroutines.
-sub GetOptions(@); # always
-sub GetOptionsFromArray(@); # on demand
-sub GetOptionsFromString(@); # on demand
-sub Configure(@); # on demand
-sub HelpMessage(@); # on demand
-sub VersionMessage(@); # in demand
-
-BEGIN {
- # Init immediately so their contents can be used in the 'use vars' below.
- @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
- @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure
- &GetOptionsFromArray &GetOptionsFromString);
-}
-
-# User visible variables.
-use vars @EXPORT, @EXPORT_OK;
-use vars qw($error $debug $major_version $minor_version);
-# Deprecated visible variables.
-use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
- $passthrough);
-# Official invisible variables.
-use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix);
-
-# Public subroutines.
-sub config(@); # deprecated name
-
-# Private subroutines.
-sub ConfigDefaults();
-sub ParseOptionSpec($$);
-sub OptCtl($);
-sub FindOption($$$$$);
-sub ValidValue ($$$$$);
-
-################ Local Variables ################
-
-# $requested_version holds the version that was mentioned in the 'use'
-# or 'require', if any. It can be used to enable or disable specific
-# features.
-my $requested_version = 0;
-
-################ Resident subroutines ################
-
-sub ConfigDefaults() {
- # Handle POSIX compliancy.
- if ( defined $ENV{"POSIXLY_CORRECT"} ) {
- $genprefix = "(--|-)";
- $autoabbrev = 0; # no automatic abbrev of options
- $bundling = 0; # no bundling of single letter switches
- $getopt_compat = 0; # disallow '+' to start options
- $order = $REQUIRE_ORDER;
- }
- else {
- $genprefix = "(--|-|\\+)";
- $autoabbrev = 1; # automatic abbrev of options
- $bundling = 0; # bundling off by default
- $getopt_compat = 1; # allow '+' to start options
- $order = $PERMUTE;
- }
- # Other configurable settings.
- $debug = 0; # for debugging
- $error = 0; # error tally
- $ignorecase = 1; # ignore case when matching options
- $passthrough = 0; # leave unrecognized options alone
- $gnu_compat = 0; # require --opt=val if value is optional
- $longprefix = "(--)"; # what does a long prefix look like
-}
-
-# Override import.
-sub import {
- my $pkg = shift; # package
- my @syms = (); # symbols to import
- my @config = (); # configuration
- my $dest = \@syms; # symbols first
- for ( @_ ) {
- if ( $_ eq ':config' ) {
- $dest = \@config; # config next
- next;
- }
- push(@$dest, $_); # push
- }
- # Hide one level and call super.
- local $Exporter::ExportLevel = 1;
- push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions
- $pkg->SUPER::import(@syms);
- # And configure.
- Configure(@config) if @config;
-}
-
-################ Initialization ################
-
-# Values for $order. See GNU getopt.c for details.
-($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
-# Version major/minor numbers.
-($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
-
-ConfigDefaults();
-
-################ OO Interface ################
-
-package Getopt::Long::Parser;
-
-# Store a copy of the default configuration. Since ConfigDefaults has
-# just been called, what we get from Configure is the default.
-my $default_config = do {
- Getopt::Long::Configure ()
-};
-
-sub new {
- my $that = shift;
- my $class = ref($that) || $that;
- my %atts = @_;
-
- # Register the callers package.
- my $self = { caller_pkg => (caller)[0] };
-
- bless ($self, $class);
-
- # Process config attributes.
- if ( defined $atts{config} ) {
- my $save = Getopt::Long::Configure ($default_config, @{$atts{config}});
- $self->{settings} = Getopt::Long::Configure ($save);
- delete ($atts{config});
- }
- # Else use default config.
- else {
- $self->{settings} = $default_config;
- }
-
- if ( %atts ) { # Oops
- die(__PACKAGE__.": unhandled attributes: ".
- join(" ", sort(keys(%atts)))."\n");
- }
-
- $self;
-}
-
-sub configure {
- my ($self) = shift;
-
- # Restore settings, merge new settings in.
- my $save = Getopt::Long::Configure ($self->{settings}, @_);
-
- # Restore orig config and save the new config.
- $self->{settings} = Getopt::Long::Configure ($save);
-}
-
-sub getoptions {
- my ($self) = shift;
-
- # Restore config settings.
- my $save = Getopt::Long::Configure ($self->{settings});
-
- # Call main routine.
- my $ret = 0;
- $Getopt::Long::caller = $self->{caller_pkg};
-
- eval {
- # Locally set exception handler to default, otherwise it will
- # be called implicitly here, and again explicitly when we try
- # to deliver the messages.
- local ($SIG{__DIE__}) = 'DEFAULT';
- $ret = Getopt::Long::GetOptions (@_);
- };
-
- # Restore saved settings.
- Getopt::Long::Configure ($save);
-
- # Handle errors and return value.
- die ($@) if $@;
- return $ret;
-}
-
-package Getopt::Long;
-
-################ Back to Normal ################
-
-# Indices in option control info.
-# Note that ParseOptions uses the fields directly. Search for 'hard-wired'.
-use constant CTL_TYPE => 0;
-#use constant CTL_TYPE_FLAG => '';
-#use constant CTL_TYPE_NEG => '!';
-#use constant CTL_TYPE_INCR => '+';
-#use constant CTL_TYPE_INT => 'i';
-#use constant CTL_TYPE_INTINC => 'I';
-#use constant CTL_TYPE_XINT => 'o';
-#use constant CTL_TYPE_FLOAT => 'f';
-#use constant CTL_TYPE_STRING => 's';
-
-use constant CTL_CNAME => 1;
-
-use constant CTL_DEFAULT => 2;
-
-use constant CTL_DEST => 3;
- use constant CTL_DEST_SCALAR => 0;
- use constant CTL_DEST_ARRAY => 1;
- use constant CTL_DEST_HASH => 2;
- use constant CTL_DEST_CODE => 3;
-
-use constant CTL_AMIN => 4;
-use constant CTL_AMAX => 5;
-
-# FFU.
-#use constant CTL_RANGE => ;
-#use constant CTL_REPEAT => ;
-
-# Rather liberal patterns to match numbers.
-use constant PAT_INT => "[-+]?_*[0-9][0-9_]*";
-use constant PAT_XINT =>
- "(?:".
- "[-+]?_*[1-9][0-9_]*".
- "|".
- "0x_*[0-9a-f][0-9a-f_]*".
- "|".
- "0b_*[01][01_]*".
- "|".
- "0[0-7_]*".
- ")";
-use constant PAT_FLOAT => "[-+]?[0-9._]+(\.[0-9_]+)?([eE][-+]?[0-9_]+)?";
-
-sub GetOptions(@) {
- # Shift in default array.
- unshift(@_, \@ARGV);
- # Try to keep caller() and Carp consitent.
- goto &GetOptionsFromArray;
-}
-
-sub GetOptionsFromString(@) {
- my ($string) = shift;
- require Text::ParseWords;
- my $args = [ Text::ParseWords::shellwords($string) ];
- $caller ||= (caller)[0]; # current context
- my $ret = GetOptionsFromArray($args, @_);
- return ( $ret, $args ) if wantarray;
- if ( @$args ) {
- $ret = 0;
- warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n");
- }
- $ret;
-}
-
-sub GetOptionsFromArray(@) {
-
- my ($argv, @optionlist) = @_; # local copy of the option descriptions
- my $argend = '--'; # option list terminator
- my %opctl = (); # table of option specs
- my $pkg = $caller || (caller)[0]; # current context
- # Needed if linkage is omitted.
- my @ret = (); # accum for non-options
- my %linkage; # linkage
- my $userlinkage; # user supplied HASH
- my $opt; # current option
- my $prefix = $genprefix; # current prefix
-
- $error = '';
-
- if ( $debug ) {
- # Avoid some warnings if debugging.
- local ($^W) = 0;
- print STDERR
- ("Getopt::Long $Getopt::Long::VERSION (",
- '$Revision: 1.1.1.2 $', ") ",
- "called from package \"$pkg\".",
- "\n ",
- "argv: (@$argv)",
- "\n ",
- "autoabbrev=$autoabbrev,".
- "bundling=$bundling,",
- "getopt_compat=$getopt_compat,",
- "gnu_compat=$gnu_compat,",
- "order=$order,",
- "\n ",
- "ignorecase=$ignorecase,",
- "requested_version=$requested_version,",
- "passthrough=$passthrough,",
- "genprefix=\"$genprefix\",",
- "longprefix=\"$longprefix\".",
- "\n");
- }
-
- # Check for ref HASH as first argument.
- # First argument may be an object. It's OK to use this as long
- # as it is really a hash underneath.
- $userlinkage = undef;
- if ( @optionlist && ref($optionlist[0]) and
- UNIVERSAL::isa($optionlist[0],'HASH') ) {
- $userlinkage = shift (@optionlist);
- print STDERR ("=> user linkage: $userlinkage\n") if $debug;
- }
-
- # See if the first element of the optionlist contains option
- # starter characters.
- # Be careful not to interpret '<>' as option starters.
- if ( @optionlist && $optionlist[0] =~ /^\W+$/
- && !($optionlist[0] eq '<>'
- && @optionlist > 0
- && ref($optionlist[1])) ) {
- $prefix = shift (@optionlist);
- # Turn into regexp. Needs to be parenthesized!
- $prefix =~ s/(\W)/\\$1/g;
- $prefix = "([" . $prefix . "])";
- print STDERR ("=> prefix=\"$prefix\"\n") if $debug;
- }
-
- # Verify correctness of optionlist.
- %opctl = ();
- while ( @optionlist ) {
- my $opt = shift (@optionlist);
-
- unless ( defined($opt) ) {
- $error .= "Undefined argument in option spec\n";
- next;
- }
-
- # Strip leading prefix so people can specify "--foo=i" if they like.
- $opt = $+ if $opt =~ /^$prefix+(.*)$/s;
-
- if ( $opt eq '<>' ) {
- if ( (defined $userlinkage)
- && !(@optionlist > 0 && ref($optionlist[0]))
- && (exists $userlinkage->{$opt})
- && ref($userlinkage->{$opt}) ) {
- unshift (@optionlist, $userlinkage->{$opt});
- }
- unless ( @optionlist > 0
- && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
- $error .= "Option spec <> requires a reference to a subroutine\n";
- # Kill the linkage (to avoid another error).
- shift (@optionlist)
- if @optionlist && ref($optionlist[0]);
- next;
- }
- $linkage{'<>'} = shift (@optionlist);
- next;
- }
-
- # Parse option spec.
- my ($name, $orig) = ParseOptionSpec ($opt, \%opctl);
- unless ( defined $name ) {
- # Failed. $orig contains the error message. Sorry for the abuse.
- $error .= $orig;
- # Kill the linkage (to avoid another error).
- shift (@optionlist)
- if @optionlist && ref($optionlist[0]);
- next;
- }
-
- # If no linkage is supplied in the @optionlist, copy it from
- # the userlinkage if available.
- if ( defined $userlinkage ) {
- unless ( @optionlist > 0 && ref($optionlist[0]) ) {
- if ( exists $userlinkage->{$orig} &&
- ref($userlinkage->{$orig}) ) {
- print STDERR ("=> found userlinkage for \"$orig\": ",
- "$userlinkage->{$orig}\n")
- if $debug;
- unshift (@optionlist, $userlinkage->{$orig});
- }
- else {
- # Do nothing. Being undefined will be handled later.
- next;
- }
- }
- }
-
- # Copy the linkage. If omitted, link to global variable.
- if ( @optionlist > 0 && ref($optionlist[0]) ) {
- print STDERR ("=> link \"$orig\" to $optionlist[0]\n")
- if $debug;
- my $rl = ref($linkage{$orig} = shift (@optionlist));
-
- if ( $rl eq "ARRAY" ) {
- $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY;
- }
- elsif ( $rl eq "HASH" ) {
- $opctl{$name}[CTL_DEST] = CTL_DEST_HASH;
- }
- elsif ( $rl eq "SCALAR" || $rl eq "REF" ) {
-# if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
-# my $t = $linkage{$orig};
-# $$t = $linkage{$orig} = [];
-# }
-# elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
-# }
-# else {
- # Ok.
-# }
- }
- elsif ( $rl eq "CODE" ) {
- # Ok.
- }
- else {
- $error .= "Invalid option linkage for \"$opt\"\n";
- }
- }
- else {
- # Link to global $opt_XXX variable.
- # Make sure a valid perl identifier results.
- my $ov = $orig;
- $ov =~ s/\W/_/g;
- if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) {
- print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n")
- if $debug;
- eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;");
- }
- elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) {
- print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n")
- if $debug;
- eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;");
- }
- else {
- print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n")
- if $debug;
- eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;");
- }
- }
-
- if ( $opctl{$name}[CTL_TYPE] eq 'I'
- && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY
- || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH )
- ) {
- $error .= "Invalid option linkage for \"$opt\"\n";
- }
-
- }
-
- # Bail out if errors found.
- die ($error) if $error;
- $error = 0;
-
- # Supply --version and --help support, if needed and allowed.
- if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) {
- if ( !defined($opctl{version}) ) {
- $opctl{version} = ['','version',0,CTL_DEST_CODE,undef];
- $linkage{version} = \&VersionMessage;
- }
- $auto_version = 1;
- }
- if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) {
- if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) {
- $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef];
- $linkage{help} = \&HelpMessage;
- }
- $auto_help = 1;
- }
-
- # Show the options tables if debugging.
- if ( $debug ) {
- my ($arrow, $k, $v);
- $arrow = "=> ";
- while ( ($k,$v) = each(%opctl) ) {
- print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n");
- $arrow = " ";
- }
- }
-
- # Process argument list
- my $goon = 1;
- while ( $goon && @$argv > 0 ) {
-
- # Get next argument.
- $opt = shift (@$argv);
- print STDERR ("=> arg \"", $opt, "\"\n") if $debug;
-
- # Double dash is option list terminator.
- if ( $opt eq $argend ) {
- push (@ret, $argend) if $passthrough;
- last;
- }
-
- # Look it up.
- my $tryopt = $opt;
- my $found; # success status
- my $key; # key (if hash type)
- my $arg; # option argument
- my $ctl; # the opctl entry
-
- ($found, $opt, $ctl, $arg, $key) =
- FindOption ($argv, $prefix, $argend, $opt, \%opctl);
-
- if ( $found ) {
-
- # FindOption undefines $opt in case of errors.
- next unless defined $opt;
-
- my $argcnt = 0;
- while ( defined $arg ) {
-
- # Get the canonical name.
- print STDERR ("=> cname for \"$opt\" is ") if $debug;
- $opt = $ctl->[CTL_CNAME];
- print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug;
-
- if ( defined $linkage{$opt} ) {
- print STDERR ("=> ref(\$L{$opt}) -> ",
- ref($linkage{$opt}), "\n") if $debug;
-
- if ( ref($linkage{$opt}) eq 'SCALAR'
- || ref($linkage{$opt}) eq 'REF' ) {
- if ( $ctl->[CTL_TYPE] eq '+' ) {
- print STDERR ("=> \$\$L{$opt} += \"$arg\"\n")
- if $debug;
- if ( defined ${$linkage{$opt}} ) {
- ${$linkage{$opt}} += $arg;
- }
- else {
- ${$linkage{$opt}} = $arg;
- }
- }
- elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
- print STDERR ("=> ref(\$L{$opt}) auto-vivified",
- " to ARRAY\n")
- if $debug;
- my $t = $linkage{$opt};
- $$t = $linkage{$opt} = [];
- print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
- if $debug;
- push (@{$linkage{$opt}}, $arg);
- }
- elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
- print STDERR ("=> ref(\$L{$opt}) auto-vivified",
- " to HASH\n")
- if $debug;
- my $t = $linkage{$opt};
- $$t = $linkage{$opt} = {};
- print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
- if $debug;
- $linkage{$opt}->{$key} = $arg;
- }
- else {
- print STDERR ("=> \$\$L{$opt} = \"$arg\"\n")
- if $debug;
- ${$linkage{$opt}} = $arg;
- }
- }
- elsif ( ref($linkage{$opt}) eq 'ARRAY' ) {
- print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n")
- if $debug;
- push (@{$linkage{$opt}}, $arg);
- }
- elsif ( ref($linkage{$opt}) eq 'HASH' ) {
- print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n")
- if $debug;
- $linkage{$opt}->{$key} = $arg;
- }
- elsif ( ref($linkage{$opt}) eq 'CODE' ) {
- print STDERR ("=> &L{$opt}(\"$opt\"",
- $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "",
- ", \"$arg\")\n")
- if $debug;
- my $eval_error = do {
- local $@;
- local $SIG{__DIE__} = 'DEFAULT';
- eval {
- &{$linkage{$opt}}
- (Getopt::Long::CallBack->new
- (name => $opt,
- ctl => $ctl,
- opctl => \%opctl,
- linkage => \%linkage,
- prefix => $prefix,
- ),
- $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (),
- $arg);
- };
- $@;
- };
- print STDERR ("=> die($eval_error)\n")
- if $debug && $eval_error ne '';
- if ( $eval_error =~ /^!/ ) {
- if ( $eval_error =~ /^!FINISH\b/ ) {
- $goon = 0;
- }
- }
- elsif ( $eval_error ne '' ) {
- warn ($eval_error);
- $error++;
- }
- }
- else {
- print STDERR ("Invalid REF type \"", ref($linkage{$opt}),
- "\" in linkage\n");
- die("Getopt::Long -- internal error!\n");
- }
- }
- # No entry in linkage means entry in userlinkage.
- elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) {
- if ( defined $userlinkage->{$opt} ) {
- print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n")
- if $debug;
- push (@{$userlinkage->{$opt}}, $arg);
- }
- else {
- print STDERR ("=>\$L{$opt} = [\"$arg\"]\n")
- if $debug;
- $userlinkage->{$opt} = [$arg];
- }
- }
- elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
- if ( defined $userlinkage->{$opt} ) {
- print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n")
- if $debug;
- $userlinkage->{$opt}->{$key} = $arg;
- }
- else {
- print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n")
- if $debug;
- $userlinkage->{$opt} = {$key => $arg};
- }
- }
- else {
- if ( $ctl->[CTL_TYPE] eq '+' ) {
- print STDERR ("=> \$L{$opt} += \"$arg\"\n")
- if $debug;
- if ( defined $userlinkage->{$opt} ) {
- $userlinkage->{$opt} += $arg;
- }
- else {
- $userlinkage->{$opt} = $arg;
- }
- }
- else {
- print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
- $userlinkage->{$opt} = $arg;
- }
- }
-
- $argcnt++;
- last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1;
- undef($arg);
-
- # Need more args?
- if ( $argcnt < $ctl->[CTL_AMIN] ) {
- if ( @$argv ) {
- if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) {
- $arg = shift(@$argv);
- $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
- ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
- if $ctl->[CTL_DEST] == CTL_DEST_HASH;
- next;
- }
- warn("Value \"$$argv[0]\" invalid for option $opt\n");
- $error++;
- }
- else {
- warn("Insufficient arguments for option $opt\n");
- $error++;
- }
- }
-
- # Any more args?
- if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) {
- $arg = shift(@$argv);
- $arg =~ tr/_//d if $ctl->[CTL_TYPE] =~ /^[iIo]$/;
- ($key,$arg) = $arg =~ /^([^=]+)=(.*)/
- if $ctl->[CTL_DEST] == CTL_DEST_HASH;
- next;
- }
- }
- }
-
- # Not an option. Save it if we $PERMUTE and don't have a <>.
- elsif ( $order == $PERMUTE ) {
- # Try non-options call-back.
- my $cb;
- if ( (defined ($cb = $linkage{'<>'})) ) {
- print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n")
- if $debug;
- my $eval_error = do {
- local $@;
- local $SIG{__DIE__} = 'DEFAULT';
- eval {
- &$cb
- (Getopt::Long::CallBack->new
- (name => $tryopt,
- ctl => $ctl,
- opctl => \%opctl,
- linkage => \%linkage,
- prefix => $prefix,
- ));
- };
- $@;
- };
- print STDERR ("=> die($eval_error)\n")
- if $debug && $eval_error ne '';
- if ( $eval_error =~ /^!/ ) {
- if ( $eval_error =~ /^!FINISH\b/ ) {
- $goon = 0;
- }
- }
- elsif ( $eval_error ne '' ) {
- warn ($eval_error);
- $error++;
- }
- }
- else {
- print STDERR ("=> saving \"$tryopt\" ",
- "(not an option, may permute)\n") if $debug;
- push (@ret, $tryopt);
- }
- next;
- }
-
- # ...otherwise, terminate.
- else {
- # Push this one back and exit.
- unshift (@$argv, $tryopt);
- return ($error == 0);
- }
-
- }
-
- # Finish.
- if ( @ret && $order == $PERMUTE ) {
- # Push back accumulated arguments
- print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
- if $debug;
- unshift (@$argv, @ret);
- }
-
- return ($error == 0);
-}
-
-# A readable representation of what's in an optbl.
-sub OptCtl ($) {
- my ($v) = @_;
- my @v = map { defined($_) ? ($_) : ("<undef>") } @$v;
- "[".
- join(",",
- "\"$v[CTL_TYPE]\"",
- "\"$v[CTL_CNAME]\"",
- "\"$v[CTL_DEFAULT]\"",
- ("\$","\@","\%","\&")[$v[CTL_DEST] || 0],
- $v[CTL_AMIN] || '',
- $v[CTL_AMAX] || '',
-# $v[CTL_RANGE] || '',
-# $v[CTL_REPEAT] || '',
- ). "]";
-}
-
-# Parse an option specification and fill the tables.
-sub ParseOptionSpec ($$) {
- my ($opt, $opctl) = @_;
-
- # Match option spec.
- if ( $opt !~ m;^
- (
- # Option name
- (?: \w+[-\w]* )
- # Alias names, or "?"
- (?: \| (?: \? | \w[-\w]* ) )*
- )?
- (
- # Either modifiers ...
- [!+]
- |
- # ... or a value/dest/repeat specification
- [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )?
- |
- # ... or an optional-with-default spec
- : (?: -?\d+ | \+ ) [@%]?
- )?
- $;x ) {
- return (undef, "Error in option spec: \"$opt\"\n");
- }
-
- my ($names, $spec) = ($1, $2);
- $spec = '' unless defined $spec;
-
- # $orig keeps track of the primary name the user specified.
- # This name will be used for the internal or external linkage.
- # In other words, if the user specifies "FoO|BaR", it will
- # match any case combinations of 'foo' and 'bar', but if a global
- # variable needs to be set, it will be $opt_FoO in the exact case
- # as specified.
- my $orig;
-
- my @names;
- if ( defined $names ) {
- @names = split (/\|/, $names);
- $orig = $names[0];
- }
- else {
- @names = ('');
- $orig = '';
- }
-
- # Construct the opctl entries.
- my $entry;
- if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) {
- # Fields are hard-wired here.
- $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0];
- }
- elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) {
- my $def = $1;
- my $dest = $2;
- my $type = $def eq '+' ? 'I' : 'i';
- $dest ||= '$';
- $dest = $dest eq '@' ? CTL_DEST_ARRAY
- : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
- # Fields are hard-wired here.
- $entry = [$type,$orig,$def eq '+' ? undef : $def,
- $dest,0,1];
- }
- else {
- my ($mand, $type, $dest) =
- $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/;
- return (undef, "Cannot repeat while bundling: \"$opt\"\n")
- if $bundling && defined($4);
- my ($mi, $cm, $ma) = ($5, $6, $7);
- return (undef, "{0} is useless in option spec: \"$opt\"\n")
- if defined($mi) && !$mi && !defined($ma) && !defined($cm);
-
- $type = 'i' if $type eq 'n';
- $dest ||= '$';
- $dest = $dest eq '@' ? CTL_DEST_ARRAY
- : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR;
- # Default minargs to 1/0 depending on mand status.
- $mi = $mand eq '=' ? 1 : 0 unless defined $mi;
- # Adjust mand status according to minargs.
- $mand = $mi ? '=' : ':';
- # Adjust maxargs.
- $ma = $mi ? $mi : 1 unless defined $ma || defined $cm;
- return (undef, "Max must be greater than zero in option spec: \"$opt\"\n")
- if defined($ma) && !$ma;
- return (undef, "Max less than min in option spec: \"$opt\"\n")
- if defined($ma) && $ma < $mi;
-
- # Fields are hard-wired here.
- $entry = [$type,$orig,undef,$dest,$mi,$ma||-1];
- }
-
- # Process all names. First is canonical, the rest are aliases.
- my $dups = '';
- foreach ( @names ) {
-
- $_ = lc ($_)
- if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0);
-
- if ( exists $opctl->{$_} ) {
- $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n";
- }
-
- if ( $spec eq '!' ) {
- $opctl->{"no$_"} = $entry;
- $opctl->{"no-$_"} = $entry;
- $opctl->{$_} = [@$entry];
- $opctl->{$_}->[CTL_TYPE] = '';
- }
- else {
- $opctl->{$_} = $entry;
- }
- }
-
- if ( $dups && $^W ) {
- foreach ( split(/\n+/, $dups) ) {
- warn($_."\n");
- }
- }
- ($names[0], $orig);
-}
-
-# Option lookup.
-sub FindOption ($$$$$) {
-
- # returns (1, $opt, $ctl, $arg, $key) if okay,
- # returns (1, undef) if option in error,
- # returns (0) otherwise.
-
- my ($argv, $prefix, $argend, $opt, $opctl) = @_;
-
- print STDERR ("=> find \"$opt\"\n") if $debug;
-
- return (0) unless $opt =~ /^$prefix(.*)$/s;
- return (0) if $opt eq "-" && !defined $opctl->{''};
-
- $opt = $+;
- my $starter = $1;
-
- print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug;
-
- my $optarg; # value supplied with --opt=value
- my $rest; # remainder from unbundling
-
- # If it is a long option, it may include the value.
- # With getopt_compat, only if not bundling.
- if ( ($starter=~/^$longprefix$/
- || ($getopt_compat && ($bundling == 0 || $bundling == 2)))
- && $opt =~ /^([^=]+)=(.*)$/s ) {
- $opt = $1;
- $optarg = $2;
- print STDERR ("=> option \"", $opt,
- "\", optarg = \"$optarg\"\n") if $debug;
- }
-
- #### Look it up ###
-
- my $tryopt = $opt; # option to try
-
- if ( $bundling && $starter eq '-' ) {
-
- # To try overrides, obey case ignore.
- $tryopt = $ignorecase ? lc($opt) : $opt;
-
- # If bundling == 2, long options can override bundles.
- if ( $bundling == 2 && length($tryopt) > 1
- && defined ($opctl->{$tryopt}) ) {
- print STDERR ("=> $starter$tryopt overrides unbundling\n")
- if $debug;
- }
- else {
- $tryopt = $opt;
- # Unbundle single letter option.
- $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : '';
- $tryopt = substr ($tryopt, 0, 1);
- $tryopt = lc ($tryopt) if $ignorecase > 1;
- print STDERR ("=> $starter$tryopt unbundled from ",
- "$starter$tryopt$rest\n") if $debug;
- $rest = undef unless $rest ne '';
- }
- }
-
- # Try auto-abbreviation.
- elsif ( $autoabbrev && $opt ne "" ) {
- # Sort the possible long option names.
- my @names = sort(keys (%$opctl));
- # Downcase if allowed.
- $opt = lc ($opt) if $ignorecase;
- $tryopt = $opt;
- # Turn option name into pattern.
- my $pat = quotemeta ($opt);
- # Look up in option names.
- my @hits = grep (/^$pat/, @names);
- print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
- "out of ", scalar(@names), "\n") if $debug;
-
- # Check for ambiguous results.
- unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
- # See if all matches are for the same option.
- my %hit;
- foreach ( @hits ) {
- my $hit = $_;
- $hit = $opctl->{$hit}->[CTL_CNAME]
- if defined $opctl->{$hit}->[CTL_CNAME];
- $hit{$hit} = 1;
- }
- # Remove auto-supplied options (version, help).
- if ( keys(%hit) == 2 ) {
- if ( $auto_version && exists($hit{version}) ) {
- delete $hit{version};
- }
- elsif ( $auto_help && exists($hit{help}) ) {
- delete $hit{help};
- }
- }
- # Now see if it really is ambiguous.
- unless ( keys(%hit) == 1 ) {
- return (0) if $passthrough;
- warn ("Option ", $opt, " is ambiguous (",
- join(", ", @hits), ")\n");
- $error++;
- return (1, undef);
- }
- @hits = keys(%hit);
- }
-
- # Complete the option name, if appropriate.
- if ( @hits == 1 && $hits[0] ne $opt ) {
- $tryopt = $hits[0];
- $tryopt = lc ($tryopt) if $ignorecase;
- print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
- if $debug;
- }
- }
-
- # Map to all lowercase if ignoring case.
- elsif ( $ignorecase ) {
- $tryopt = lc ($opt);
- }
-
- # Check validity by fetching the info.
- my $ctl = $opctl->{$tryopt};
- unless ( defined $ctl ) {
- return (0) if $passthrough;
- # Pretend one char when bundling.
- if ( $bundling == 1 && length($starter) == 1 ) {
- $opt = substr($opt,0,1);
- unshift (@$argv, $starter.$rest) if defined $rest;
- }
- if ( $opt eq "" ) {
- warn ("Missing option after ", $starter, "\n");
- }
- else {
- warn ("Unknown option: ", $opt, "\n");
- }
- $error++;
- return (1, undef);
- }
- # Apparently valid.
- $opt = $tryopt;
- print STDERR ("=> found ", OptCtl($ctl),
- " for \"", $opt, "\"\n") if $debug;
-
- #### Determine argument status ####
-
- # If it is an option w/o argument, we're almost finished with it.
- my $type = $ctl->[CTL_TYPE];
- my $arg;
-
- if ( $type eq '' || $type eq '!' || $type eq '+' ) {
- if ( defined $optarg ) {
- return (0) if $passthrough;
- warn ("Option ", $opt, " does not take an argument\n");
- $error++;
- undef $opt;
- }
- elsif ( $type eq '' || $type eq '+' ) {
- # Supply explicit value.
- $arg = 1;
- }
- else {
- $opt =~ s/^no-?//i; # strip NO prefix
- $arg = 0; # supply explicit value
- }
- unshift (@$argv, $starter.$rest) if defined $rest;
- return (1, $opt, $ctl, $arg);
- }
-
- # Get mandatory status and type info.
- my $mand = $ctl->[CTL_AMIN];
-
- # Check if there is an option argument available.
- if ( $gnu_compat && defined $optarg && $optarg eq '' ) {
- return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand;
- $optarg = 0 unless $type eq 's';
- }
-
- # Check if there is an option argument available.
- if ( defined $optarg
- ? ($optarg eq '')
- : !(defined $rest || @$argv > 0) ) {
- # Complain if this option needs an argument.
-# if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) {
- if ( $mand ) {
- return (0) if $passthrough;
- warn ("Option ", $opt, " requires an argument\n");
- $error++;
- return (1, undef);
- }
- if ( $type eq 'I' ) {
- # Fake incremental type.
- my @c = @$ctl;
- $c[CTL_TYPE] = '+';
- return (1, $opt, \@c, 1);
- }
- return (1, $opt, $ctl,
- defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
- $type eq 's' ? '' : 0);
- }
-
- # Get (possibly optional) argument.
- $arg = (defined $rest ? $rest
- : (defined $optarg ? $optarg : shift (@$argv)));
-
- # Get key if this is a "name=value" pair for a hash option.
- my $key;
- if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) {
- ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2)
- : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] :
- ($mand ? undef : ($type eq 's' ? "" : 1)));
- if (! defined $arg) {
- warn ("Option $opt, key \"$key\", requires a value\n");
- $error++;
- # Push back.
- unshift (@$argv, $starter.$rest) if defined $rest;
- return (1, undef);
- }
- }
-
- #### Check if the argument is valid for this option ####
-
- my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : "";
-
- if ( $type eq 's' ) { # string
- # A mandatory string takes anything.
- return (1, $opt, $ctl, $arg, $key) if $mand;
-
- # Same for optional string as a hash value
- return (1, $opt, $ctl, $arg, $key)
- if $ctl->[CTL_DEST] == CTL_DEST_HASH;
-
- # An optional string takes almost anything.
- return (1, $opt, $ctl, $arg, $key)
- if defined $optarg || defined $rest;
- return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ??
-
- # Check for option or option list terminator.
- if ($arg eq $argend ||
- $arg =~ /^$prefix.+/) {
- # Push back.
- unshift (@$argv, $arg);
- # Supply empty value.
- $arg = '';
- }
- }
-
- elsif ( $type eq 'i' # numeric/integer
- || $type eq 'I' # numeric/integer w/ incr default
- || $type eq 'o' ) { # dec/oct/hex/bin value
-
- my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
-
- if ( $bundling && defined $rest
- && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) {
- ($key, $arg, $rest) = ($1, $2, $+);
- chop($key) if $key;
- $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
- unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
- }
- elsif ( $arg =~ /^$o_valid$/si ) {
- $arg =~ tr/_//d;
- $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg;
- }
- else {
- if ( defined $optarg || $mand ) {
- if ( $passthrough ) {
- unshift (@$argv, defined $rest ? $starter.$rest : $arg)
- unless defined $optarg;
- return (0);
- }
- warn ("Value \"", $arg, "\" invalid for option ",
- $opt, " (",
- $type eq 'o' ? "extended " : '',
- "number expected)\n");
- $error++;
- # Push back.
- unshift (@$argv, $starter.$rest) if defined $rest;
- return (1, undef);
- }
- else {
- # Push back.
- unshift (@$argv, defined $rest ? $starter.$rest : $arg);
- if ( $type eq 'I' ) {
- # Fake incremental type.
- my @c = @$ctl;
- $c[CTL_TYPE] = '+';
- return (1, $opt, \@c, 1);
- }
- # Supply default value.
- $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0;
- }
- }
- }
-
- elsif ( $type eq 'f' ) { # real number, int is also ok
- # We require at least one digit before a point or 'e',
- # and at least one digit following the point and 'e'.
- # [-]NN[.NN][eNN]
- my $o_valid = PAT_FLOAT;
- if ( $bundling && defined $rest &&
- $rest =~ /^($key_valid)($o_valid)(.*)$/s ) {
- $arg =~ tr/_//d;
- ($key, $arg, $rest) = ($1, $2, $+);
- chop($key) if $key;
- unshift (@$argv, $starter.$rest) if defined $rest && $rest ne '';
- }
- elsif ( $arg =~ /^$o_valid$/ ) {
- $arg =~ tr/_//d;
- }
- else {
- if ( defined $optarg || $mand ) {
- if ( $passthrough ) {
- unshift (@$argv, defined $rest ? $starter.$rest : $arg)
- unless defined $optarg;
- return (0);
- }
- warn ("Value \"", $arg, "\" invalid for option ",
- $opt, " (real number expected)\n");
- $error++;
- # Push back.
- unshift (@$argv, $starter.$rest) if defined $rest;
- return (1, undef);
- }
- else {
- # Push back.
- unshift (@$argv, defined $rest ? $starter.$rest : $arg);
- # Supply default value.
- $arg = 0.0;
- }
- }
- }
- else {
- die("Getopt::Long internal error (Can't happen)\n");
- }
- return (1, $opt, $ctl, $arg, $key);
-}
-
-sub ValidValue ($$$$$) {
- my ($ctl, $arg, $mand, $argend, $prefix) = @_;
-
- if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) {
- return 0 unless $arg =~ /[^=]+=(.*)/;
- $arg = $1;
- }
-
- my $type = $ctl->[CTL_TYPE];
-
- if ( $type eq 's' ) { # string
- # A mandatory string takes anything.
- return (1) if $mand;
-
- return (1) if $arg eq "-";
-
- # Check for option or option list terminator.
- return 0 if $arg eq $argend || $arg =~ /^$prefix.+/;
- return 1;
- }
-
- elsif ( $type eq 'i' # numeric/integer
- || $type eq 'I' # numeric/integer w/ incr default
- || $type eq 'o' ) { # dec/oct/hex/bin value
-
- my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT;
- return $arg =~ /^$o_valid$/si;
- }
-
- elsif ( $type eq 'f' ) { # real number, int is also ok
- # We require at least one digit before a point or 'e',
- # and at least one digit following the point and 'e'.
- # [-]NN[.NN][eNN]
- my $o_valid = PAT_FLOAT;
- return $arg =~ /^$o_valid$/;
- }
- die("ValidValue: Cannot happen\n");
-}
-
-# Getopt::Long Configuration.
-sub Configure (@) {
- my (@options) = @_;
-
- my $prevconfig =
- [ $error, $debug, $major_version, $minor_version,
- $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
- $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
- $longprefix ];
-
- if ( ref($options[0]) eq 'ARRAY' ) {
- ( $error, $debug, $major_version, $minor_version,
- $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order,
- $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help,
- $longprefix ) = @{shift(@options)};
- }
-
- my $opt;
- foreach $opt ( @options ) {
- my $try = lc ($opt);
- my $action = 1;
- if ( $try =~ /^no_?(.*)$/s ) {
- $action = 0;
- $try = $+;
- }
- if ( ($try eq 'default' or $try eq 'defaults') && $action ) {
- ConfigDefaults ();
- }
- elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) {
- local $ENV{POSIXLY_CORRECT};
- $ENV{POSIXLY_CORRECT} = 1 if $action;
- ConfigDefaults ();
- }
- elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) {
- $autoabbrev = $action;
- }
- elsif ( $try eq 'getopt_compat' ) {
- $getopt_compat = $action;
- $genprefix = $action ? "(--|-|\\+)" : "(--|-)";
- }
- elsif ( $try eq 'gnu_getopt' ) {
- if ( $action ) {
- $gnu_compat = 1;
- $bundling = 1;
- $getopt_compat = 0;
- $genprefix = "(--|-)";
- $order = $PERMUTE;
- }
- }
- elsif ( $try eq 'gnu_compat' ) {
- $gnu_compat = $action;
- }
- elsif ( $try =~ /^(auto_?)?version$/ ) {
- $auto_version = $action;
- }
- elsif ( $try =~ /^(auto_?)?help$/ ) {
- $auto_help = $action;
- }
- elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) {
- $ignorecase = $action;
- }
- elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) {
- $ignorecase = $action ? 2 : 0;
- }
- elsif ( $try eq 'bundling' ) {
- $bundling = $action;
- }
- elsif ( $try eq 'bundling_override' ) {
- $bundling = $action ? 2 : 0;
- }
- elsif ( $try eq 'require_order' ) {
- $order = $action ? $REQUIRE_ORDER : $PERMUTE;
- }
- elsif ( $try eq 'permute' ) {
- $order = $action ? $PERMUTE : $REQUIRE_ORDER;
- }
- elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) {
- $passthrough = $action;
- }
- elsif ( $try =~ /^prefix=(.+)$/ && $action ) {
- $genprefix = $1;
- # Turn into regexp. Needs to be parenthesized!
- $genprefix = "(" . quotemeta($genprefix) . ")";
- eval { '' =~ /$genprefix/; };
- die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
- }
- elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) {
- $genprefix = $1;
- # Parenthesize if needed.
- $genprefix = "(" . $genprefix . ")"
- unless $genprefix =~ /^\(.*\)$/;
- eval { '' =~ m"$genprefix"; };
- die("Getopt::Long: invalid pattern \"$genprefix\"") if $@;
- }
- elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) {
- $longprefix = $1;
- # Parenthesize if needed.
- $longprefix = "(" . $longprefix . ")"
- unless $longprefix =~ /^\(.*\)$/;
- eval { '' =~ m"$longprefix"; };
- die("Getopt::Long: invalid long prefix pattern \"$longprefix\"") if $@;
- }
- elsif ( $try eq 'debug' ) {
- $debug = $action;
- }
- else {
- die("Getopt::Long: unknown config parameter \"$opt\"")
- }
- }
- $prevconfig;
-}
-
-# Deprecated name.
-sub config (@) {
- Configure (@_);
-}
-
-# Issue a standard message for --version.
-#
-# The arguments are mostly the same as for Pod::Usage::pod2usage:
-#
-# - a number (exit value)
-# - a string (lead in message)
-# - a hash with options. See Pod::Usage for details.
-#
-sub VersionMessage(@) {
- # Massage args.
- my $pa = setup_pa_args("version", @_);
-
- my $v = $main::VERSION;
- my $fh = $pa->{-output} ||
- ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR;
-
- print $fh (defined($pa->{-message}) ? $pa->{-message} : (),
- $0, defined $v ? " version $v" : (),
- "\n",
- "(", __PACKAGE__, "::", "GetOptions",
- " version ",
- defined($Getopt::Long::VERSION_STRING)
- ? $Getopt::Long::VERSION_STRING : $VERSION, ";",
- " Perl version ",
- $] >= 5.006 ? sprintf("%vd", $^V) : $],
- ")\n");
- exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT";
-}
-
-# Issue a standard message for --help.
-#
-# The arguments are the same as for Pod::Usage::pod2usage:
-#
-# - a number (exit value)
-# - a string (lead in message)
-# - a hash with options. See Pod::Usage for details.
-#
-sub HelpMessage(@) {
- eval {
- require Pod::Usage;
- import Pod::Usage;
- 1;
- } || die("Cannot provide help: cannot load Pod::Usage\n");
-
- # Note that pod2usage will issue a warning if -exitval => NOEXIT.
- pod2usage(setup_pa_args("help", @_));
-
-}
-
-# Helper routine to set up a normalized hash ref to be used as
-# argument to pod2usage.
-sub setup_pa_args($@) {
- my $tag = shift; # who's calling
-
- # If called by direct binding to an option, it will get the option
- # name and value as arguments. Remove these, if so.
- @_ = () if @_ == 2 && $_[0] eq $tag;
-
- my $pa;
- if ( @_ > 1 ) {
- $pa = { @_ };
- }
- else {
- $pa = shift || {};
- }
-
- # At this point, $pa can be a number (exit value), string
- # (message) or hash with options.
-
- if ( UNIVERSAL::isa($pa, 'HASH') ) {
- # Get rid of -msg vs. -message ambiguity.
- $pa->{-message} = $pa->{-msg};
- delete($pa->{-msg});
- }
- elsif ( $pa =~ /^-?\d+$/ ) {
- $pa = { -exitval => $pa };
- }
- else {
- $pa = { -message => $pa };
- }
-
- # These are _our_ defaults.
- $pa->{-verbose} = 0 unless exists($pa->{-verbose});
- $pa->{-exitval} = 0 unless exists($pa->{-exitval});
- $pa;
-}
-
-# Sneak way to know what version the user requested.
-sub VERSION {
- $requested_version = $_[1];
- shift->SUPER::VERSION(@_);
-}
-
-package Getopt::Long::CallBack;
-
-sub new {
- my ($pkg, %atts) = @_;
- bless { %atts }, $pkg;
-}
-
-sub name {
- my $self = shift;
- ''.$self->{name};
-}
-
-use overload
- # Treat this object as an ordinary string for legacy API.
- '""' => \&name,
- fallback => 1;
-
-1;
-
-################ Documentation ################
-
-=head1 NAME
-
-Getopt::Long - Extended processing of command line options
-
-=head1 SYNOPSIS
-
- use Getopt::Long;
- my $data = "file.dat";
- my $length = 24;
- my $verbose;
- $result = GetOptions ("length=i" => \$length, # numeric
- "file=s" => \$data, # string
- "verbose" => \$verbose); # flag
-
-=head1 DESCRIPTION
-
-The Getopt::Long module implements an extended getopt function called
-GetOptions(). This function adheres to the POSIX syntax for command
-line options, with GNU extensions. In general, this means that options
-have long names instead of single letters, and are introduced with a
-double dash "--". Support for bundling of command line options, as was
-the case with the more traditional single-letter approach, is provided
-but not enabled by default.
-
-=head1 Command Line Options, an Introduction
-
-Command line operated programs traditionally take their arguments from
-the command line, for example filenames or other information that the
-program needs to know. Besides arguments, these programs often take
-command line I<options> as well. Options are not necessary for the
-program to work, hence the name 'option', but are used to modify its
-default behaviour. For example, a program could do its job quietly,
-but with a suitable option it could provide verbose information about
-what it did.
-
-Command line options come in several flavours. Historically, they are
-preceded by a single dash C<->, and consist of a single letter.
-
- -l -a -c
-
-Usually, these single-character options can be bundled:
-
- -lac
-
-Options can have values, the value is placed after the option
-character. Sometimes with whitespace in between, sometimes not:
-
- -s 24 -s24
-
-Due to the very cryptic nature of these options, another style was
-developed that used long names. So instead of a cryptic C<-l> one
-could use the more descriptive C<--long>. To distinguish between a
-bundle of single-character options and a long one, two dashes are used
-to precede the option name. Early implementations of long options used
-a plus C<+> instead. Also, option values could be specified either
-like
-
- --size=24
-
-or
-
- --size 24
-
-The C<+> form is now obsolete and strongly deprecated.
-
-=head1 Getting Started with Getopt::Long
-
-Getopt::Long is the Perl5 successor of C<newgetopt.pl>. This was the
-first Perl module that provided support for handling the new style of
-command line options, hence the name Getopt::Long. This module also
-supports single-character options and bundling. Single character
-options may be any alphabetic character, a question mark, and a dash.
-Long options may consist of a series of letters, digits, and dashes.
-Although this is currently not enforced by Getopt::Long, multiple
-consecutive dashes are not allowed, and the option name must not end
-with a dash.
-
-To use Getopt::Long from a Perl program, you must include the
-following line in your Perl program:
-
- use Getopt::Long;
-
-This will load the core of the Getopt::Long module and prepare your
-program for using it. Most of the actual Getopt::Long code is not
-loaded until you really call one of its functions.
-
-In the default configuration, options names may be abbreviated to
-uniqueness, case does not matter, and a single dash is sufficient,
-even for long option names. Also, options may be placed between
-non-option arguments. See L<Configuring Getopt::Long> for more
-details on how to configure Getopt::Long.
-
-=head2 Simple options
-
-The most simple options are the ones that take no values. Their mere
-presence on the command line enables the option. Popular examples are:
-
- --all --verbose --quiet --debug
-
-Handling simple options is straightforward:
-
- my $verbose = ''; # option variable with default value (false)
- my $all = ''; # option variable with default value (false)
- GetOptions ('verbose' => \$verbose, 'all' => \$all);
-
-The call to GetOptions() parses the command line arguments that are
-present in C<@ARGV> and sets the option variable to the value C<1> if
-the option did occur on the command line. Otherwise, the option
-variable is not touched. Setting the option value to true is often
-called I<enabling> the option.
-
-The option name as specified to the GetOptions() function is called
-the option I<specification>. Later we'll see that this specification
-can contain more than just the option name. The reference to the
-variable is called the option I<destination>.
-
-GetOptions() will return a true value if the command line could be
-processed successfully. Otherwise, it will write error messages to
-STDERR, and return a false result.
-
-=head2 A little bit less simple options
-
-Getopt::Long supports two useful variants of simple options:
-I<negatable> options and I<incremental> options.
-
-A negatable option is specified with an exclamation mark C<!> after the
-option name:
-
- my $verbose = ''; # option variable with default value (false)
- GetOptions ('verbose!' => \$verbose);
-
-Now, using C<--verbose> on the command line will enable C<$verbose>,
-as expected. But it is also allowed to use C<--noverbose>, which will
-disable C<$verbose> by setting its value to C<0>. Using a suitable
-default value, the program can find out whether C<$verbose> is false
-by default, or disabled by using C<--noverbose>.
-
-An incremental option is specified with a plus C<+> after the
-option name:
-
- my $verbose = ''; # option variable with default value (false)
- GetOptions ('verbose+' => \$verbose);
-
-Using C<--verbose> on the command line will increment the value of
-C<$verbose>. This way the program can keep track of how many times the
-option occurred on the command line. For example, each occurrence of
-C<--verbose> could increase the verbosity level of the program.
-
-=head2 Mixing command line option with other arguments
-
-Usually programs take command line options as well as other arguments,
-for example, file names. It is good practice to always specify the
-options first, and the other arguments last. Getopt::Long will,
-however, allow the options and arguments to be mixed and 'filter out'
-all the options before passing the rest of the arguments to the
-program. To stop Getopt::Long from processing further arguments,
-insert a double dash C<--> on the command line:
-
- --size 24 -- --all
-
-In this example, C<--all> will I<not> be treated as an option, but
-passed to the program unharmed, in C<@ARGV>.
-
-=head2 Options with values
-
-For options that take values it must be specified whether the option
-value is required or not, and what kind of value the option expects.
-
-Three kinds of values are supported: integer numbers, floating point
-numbers, and strings.
-
-If the option value is required, Getopt::Long will take the
-command line argument that follows the option and assign this to the
-option variable. If, however, the option value is specified as
-optional, this will only be done if that value does not look like a
-valid command line option itself.
-
- my $tag = ''; # option variable with default value
- GetOptions ('tag=s' => \$tag);
-
-In the option specification, the option name is followed by an equals
-sign C<=> and the letter C<s>. The equals sign indicates that this
-option requires a value. The letter C<s> indicates that this value is
-an arbitrary string. Other possible value types are C<i> for integer
-values, and C<f> for floating point values. Using a colon C<:> instead
-of the equals sign indicates that the option value is optional. In
-this case, if no suitable value is supplied, string valued options get
-an empty string C<''> assigned, while numeric options are set to C<0>.
-
-=head2 Options with multiple values
-
-Options sometimes take several values. For example, a program could
-use multiple directories to search for library files:
-
- --library lib/stdlib --library lib/extlib
-
-To accomplish this behaviour, simply specify an array reference as the
-destination for the option:
-
- GetOptions ("library=s" => \@libfiles);
-
-Alternatively, you can specify that the option can have multiple
-values by adding a "@", and pass a scalar reference as the
-destination:
-
- GetOptions ("library=s@" => \$libfiles);
-
-Used with the example above, C<@libfiles> (or C<@$libfiles>) would
-contain two strings upon completion: C<"lib/srdlib"> and
-C<"lib/extlib">, in that order. It is also possible to specify that
-only integer or floating point numbers are acceptable values.
-
-Often it is useful to allow comma-separated lists of values as well as
-multiple occurrences of the options. This is easy using Perl's split()
-and join() operators:
-
- GetOptions ("library=s" => \@libfiles);
- @libfiles = split(/,/,join(',', at libfiles));
-
-Of course, it is important to choose the right separator string for
-each purpose.
-
-Warning: What follows is an experimental feature.
-
-Options can take multiple values at once, for example
-
- --coordinates 52.2 16.4 --rgbcolor 255 255 149
-
-This can be accomplished by adding a repeat specifier to the option
-specification. Repeat specifiers are very similar to the C<{...}>
-repeat specifiers that can be used with regular expression patterns.
-For example, the above command line would be handled as follows:
-
- GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color);
-
-The destination for the option must be an array or array reference.
-
-It is also possible to specify the minimal and maximal number of
-arguments an option takes. C<foo=s{2,4}> indicates an option that
-takes at least two and at most 4 arguments. C<foo=s{,}> indicates one
-or more values; C<foo:s{,}> indicates zero or more option values.
-
-=head2 Options with hash values
-
-If the option destination is a reference to a hash, the option will
-take, as value, strings of the form I<key>C<=>I<value>. The value will
-be stored with the specified key in the hash.
-
- GetOptions ("define=s" => \%defines);
-
-Alternatively you can use:
-
- GetOptions ("define=s%" => \$defines);
-
-When used with command line options:
-
- --define os=linux --define vendor=redhat
-
-the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os">
-with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is
-also possible to specify that only integer or floating point numbers
-are acceptable values. The keys are always taken to be strings.
-
-=head2 User-defined subroutines to handle options
-
-Ultimate control over what should be done when (actually: each time)
-an option is encountered on the command line can be achieved by
-designating a reference to a subroutine (or an anonymous subroutine)
-as the option destination. When GetOptions() encounters the option, it
-will call the subroutine with two or three arguments. The first
-argument is the name of the option. (Actually, it is an object that
-stringifies to the name of the option.) For a scalar or array destination,
-the second argument is the value to be stored. For a hash destination,
-the second arguments is the key to the hash, and the third argument
-the value to be stored. It is up to the subroutine to store the value,
-or do whatever it thinks is appropriate.
-
-A trivial application of this mechanism is to implement options that
-are related to each other. For example:
-
- my $verbose = ''; # option variable with default value (false)
- GetOptions ('verbose' => \$verbose,
- 'quiet' => sub { $verbose = 0 });
-
-Here C<--verbose> and C<--quiet> control the same variable
-C<$verbose>, but with opposite values.
-
-If the subroutine needs to signal an error, it should call die() with
-the desired error message as its argument. GetOptions() will catch the
-die(), issue the error message, and record that an error result must
-be returned upon completion.
-
-If the text of the error message starts with an exclamation mark C<!>
-it is interpreted specially by GetOptions(). There is currently one
-special command implemented: C<die("!FINISH")> will cause GetOptions()
-to stop processing options, as if it encountered a double dash C<-->.
-
-In version 2.37 the first argument to the callback function was
-changed from string to object. This was done to make room for
-extensions and more detailed control. The object stringifies to the
-option name so this change should not introduce compatibility
-problems.
-
-=head2 Options with multiple names
-
-Often it is user friendly to supply alternate mnemonic names for
-options. For example C<--height> could be an alternate name for
-C<--length>. Alternate names can be included in the option
-specification, separated by vertical bar C<|> characters. To implement
-the above example:
-
- GetOptions ('length|height=f' => \$length);
-
-The first name is called the I<primary> name, the other names are
-called I<aliases>. When using a hash to store options, the key will
-always be the primary name.
-
-Multiple alternate names are possible.
-
-=head2 Case and abbreviations
-
-Without additional configuration, GetOptions() will ignore the case of
-option names, and allow the options to be abbreviated to uniqueness.
-
- GetOptions ('length|height=f' => \$length, "head" => \$head);
-
-This call will allow C<--l> and C<--L> for the length option, but
-requires a least C<--hea> and C<--hei> for the head and height options.
-
-=head2 Summary of Option Specifications
-
-Each option specifier consists of two parts: the name specification
-and the argument specification.
-
-The name specification contains the name of the option, optionally
-followed by a list of alternative names separated by vertical bar
-characters.
-
- length option name is "length"
- length|size|l name is "length", aliases are "size" and "l"
-
-The argument specification is optional. If omitted, the option is
-considered boolean, a value of 1 will be assigned when the option is
-used on the command line.
-
-The argument specification can be
-
-=over 4
-
-=item !
-
-The option does not take an argument and may be negated by prefixing
-it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of
-1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of
-0 will be assigned). If the option has aliases, this applies to the
-aliases as well.
-
-Using negation on a single letter option when bundling is in effect is
-pointless and will result in a warning.
-
-=item +
-
-The option does not take an argument and will be incremented by 1
-every time it appears on the command line. E.g. C<"more+">, when used
-with C<--more --more --more>, will increment the value three times,
-resulting in a value of 3 (provided it was 0 or undefined at first).
-
-The C<+> specifier is ignored if the option destination is not a scalar.
-
-=item = I<type> [ I<desttype> ] [ I<repeat> ]
-
-The option requires an argument of the given type. Supported types
-are:
-
-=over 4
-
-=item s
-
-String. An arbitrary sequence of characters. It is valid for the
-argument to start with C<-> or C<-->.
-
-=item i
-
-Integer. An optional leading plus or minus sign, followed by a
-sequence of digits.
-
-=item o
-
-Extended integer, Perl style. This can be either an optional leading
-plus or minus sign, followed by a sequence of digits, or an octal
-string (a zero, optionally followed by '0', '1', .. '7'), or a
-hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case
-insensitive), or a binary string (C<0b> followed by a series of '0'
-and '1').
-
-=item f
-
-Real number. For example C<3.14>, C<-6.23E24> and so on.
-
-=back
-
-The I<desttype> can be C<@> or C<%> to specify that the option is
-list or a hash valued. This is only needed when the destination for
-the option value is not otherwise specified. It should be omitted when
-not needed.
-
-The I<repeat> specifies the number of values this option takes per
-occurrence on the command line. It has the format C<{> [ I<min> ] [ C<,> [ I<max> ] ] C<}>.
-
-I<min> denotes the minimal number of arguments. It defaults to 1 for
-options with C<=> and to 0 for options with C<:>, see below. Note that
-I<min> overrules the C<=> / C<:> semantics.
-
-I<max> denotes the maximum number of arguments. It must be at least
-I<min>. If I<max> is omitted, I<but the comma is not>, there is no
-upper bound to the number of argument values taken.
-
-=item : I<type> [ I<desttype> ]
-
-Like C<=>, but designates the argument as optional.
-If omitted, an empty string will be assigned to string values options,
-and the value zero to numeric options.
-
-Note that if a string argument starts with C<-> or C<-->, it will be
-considered an option on itself.
-
-=item : I<number> [ I<desttype> ]
-
-Like C<:i>, but if the value is omitted, the I<number> will be assigned.
-
-=item : + [ I<desttype> ]
-
-Like C<:i>, but if the value is omitted, the current value for the
-option will be incremented.
-
-=back
-
-=head1 Advanced Possibilities
-
-=head2 Object oriented interface
-
-Getopt::Long can be used in an object oriented way as well:
-
- use Getopt::Long;
- $p = new Getopt::Long::Parser;
- $p->configure(...configuration options...);
- if ($p->getoptions(...options descriptions...)) ...
-
-Configuration options can be passed to the constructor:
-
- $p = new Getopt::Long::Parser
- config => [...configuration options...];
-
-=head2 Thread Safety
-
-Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is
-I<not> thread safe when using the older (experimental and now
-obsolete) threads implementation that was added to Perl 5.005.
-
-=head2 Documentation and help texts
-
-Getopt::Long encourages the use of Pod::Usage to produce help
-messages. For example:
-
- use Getopt::Long;
- use Pod::Usage;
-
- my $man = 0;
- my $help = 0;
-
- GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
- pod2usage(1) if $help;
- pod2usage(-exitstatus => 0, -verbose => 2) if $man;
-
- __END__
-
- =head1 NAME
-
- sample - Using Getopt::Long and Pod::Usage
-
- =head1 SYNOPSIS
-
- sample [options] [file ...]
-
- Options:
- -help brief help message
- -man full documentation
-
- =head1 OPTIONS
-
- =over 8
-
- =item B<-help>
-
- Print a brief help message and exits.
-
- =item B<-man>
-
- Prints the manual page and exits.
-
- =back
-
- =head1 DESCRIPTION
-
- B<This program> will read the given input file(s) and do something
- useful with the contents thereof.
-
- =cut
-
-See L<Pod::Usage> for details.
-
-=head2 Parsing options from an arbitrary array
-
-By default, GetOptions parses the options that are present in the
-global array C<@ARGV>. A special entry C<GetOptionsFromArray> can be
-used to parse options from an arbitrary array.
-
- use Getopt::Long qw(GetOptionsFromArray);
- $ret = GetOptionsFromArray(\@myopts, ...);
-
-When used like this, the global C<@ARGV> is not touched at all.
-
-The following two calls behave identically:
-
- $ret = GetOptions( ... );
- $ret = GetOptionsFromArray(\@ARGV, ... );
-
-=head2 Parsing options from an arbitrary string
-
-A special entry C<GetOptionsFromString> can be used to parse options
-from an arbitrary string.
-
- use Getopt::Long qw(GetOptionsFromString);
- $ret = GetOptionsFromString($string, ...);
-
-The contents of the string are split into arguments using a call to
-C<Text::ParseWords::shellwords>. As with C<GetOptionsFromArray>, the
-global C<@ARGV> is not touched.
-
-It is possible that, upon completion, not all arguments in the string
-have been processed. C<GetOptionsFromString> will, when called in list
-context, return both the return status and an array reference to any
-remaining arguments:
-
- ($ret, $args) = GetOptionsFromString($string, ... );
-
-If any arguments remain, and C<GetOptionsFromString> was not called in
-list context, a message will be given and C<GetOptionsFromString> will
-return failure.
-
-=head2 Storing options values in a hash
-
-Sometimes, for example when there are a lot of options, having a
-separate variable for each of them can be cumbersome. GetOptions()
-supports, as an alternative mechanism, storing options values in a
-hash.
-
-To obtain this, a reference to a hash must be passed I<as the first
-argument> to GetOptions(). For each option that is specified on the
-command line, the option value will be stored in the hash with the
-option name as key. Options that are not actually used on the command
-line will not be put in the hash, on other words,
-C<exists($h{option})> (or defined()) can be used to test if an option
-was used. The drawback is that warnings will be issued if the program
-runs under C<use strict> and uses C<$h{option}> without testing with
-exists() or defined() first.
-
- my %h = ();
- GetOptions (\%h, 'length=i'); # will store in $h{length}
-
-For options that take list or hash values, it is necessary to indicate
-this by appending an C<@> or C<%> sign after the type:
-
- GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}}
-
-To make things more complicated, the hash may contain references to
-the actual destinations, for example:
-
- my $len = 0;
- my %h = ('length' => \$len);
- GetOptions (\%h, 'length=i'); # will store in $len
-
-This example is fully equivalent with:
-
- my $len = 0;
- GetOptions ('length=i' => \$len); # will store in $len
-
-Any mixture is possible. For example, the most frequently used options
-could be stored in variables while all other options get stored in the
-hash:
-
- my $verbose = 0; # frequently referred
- my $debug = 0; # frequently referred
- my %h = ('verbose' => \$verbose, 'debug' => \$debug);
- GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i');
- if ( $verbose ) { ... }
- if ( exists $h{filter} ) { ... option 'filter' was specified ... }
-
-=head2 Bundling
-
-With bundling it is possible to set several single-character options
-at once. For example if C<a>, C<v> and C<x> are all valid options,
-
- -vax
-
-would set all three.
-
-Getopt::Long supports two levels of bundling. To enable bundling, a
-call to Getopt::Long::Configure is required.
-
-The first level of bundling can be enabled with:
-
- Getopt::Long::Configure ("bundling");
-
-Configured this way, single-character options can be bundled but long
-options B<must> always start with a double dash C<--> to avoid
-ambiguity. For example, when C<vax>, C<a>, C<v> and C<x> are all valid
-options,
-
- -vax
-
-would set C<a>, C<v> and C<x>, but
-
- --vax
-
-would set C<vax>.
-
-The second level of bundling lifts this restriction. It can be enabled
-with:
-
- Getopt::Long::Configure ("bundling_override");
-
-Now, C<-vax> would set the option C<vax>.
-
-When any level of bundling is enabled, option values may be inserted
-in the bundle. For example:
-
- -h24w80
-
-is equivalent to
-
- -h 24 -w 80
-
-When configured for bundling, single-character options are matched
-case sensitive while long options are matched case insensitive. To
-have the single-character options matched case insensitive as well,
-use:
-
- Getopt::Long::Configure ("bundling", "ignorecase_always");
-
-It goes without saying that bundling can be quite confusing.
-
-=head2 The lonesome dash
-
-Normally, a lone dash C<-> on the command line will not be considered
-an option. Option processing will terminate (unless "permute" is
-configured) and the dash will be left in C<@ARGV>.
-
-It is possible to get special treatment for a lone dash. This can be
-achieved by adding an option specification with an empty name, for
-example:
-
- GetOptions ('' => \$stdio);
-
-A lone dash on the command line will now be a legal option, and using
-it will set variable C<$stdio>.
-
-=head2 Argument callback
-
-A special option 'name' C<< <> >> can be used to designate a subroutine
-to handle non-option arguments. When GetOptions() encounters an
-argument that does not look like an option, it will immediately call this
-subroutine and passes it one parameter: the argument name. Well, actually
-it is an object that stringifies to the argument name.
-
-For example:
-
- my $width = 80;
- sub process { ... }
- GetOptions ('width=i' => \$width, '<>' => \&process);
-
-When applied to the following command line:
-
- arg1 --width=72 arg2 --width=60 arg3
-
-This will call
-C<process("arg1")> while C<$width> is C<80>,
-C<process("arg2")> while C<$width> is C<72>, and
-C<process("arg3")> while C<$width> is C<60>.
-
-This feature requires configuration option B<permute>, see section
-L<Configuring Getopt::Long>.
-
-=head1 Configuring Getopt::Long
-
-Getopt::Long can be configured by calling subroutine
-Getopt::Long::Configure(). This subroutine takes a list of quoted
-strings, each specifying a configuration option to be enabled, e.g.
-C<ignore_case>, or disabled, e.g. C<no_ignore_case>. Case does not
-matter. Multiple calls to Configure() are possible.
-
-Alternatively, as of version 2.24, the configuration options may be
-passed together with the C<use> statement:
-
- use Getopt::Long qw(:config no_ignore_case bundling);
-
-The following options are available:
-
-=over 12
-
-=item default
-
-This option causes all configuration options to be reset to their
-default values.
-
-=item posix_default
-
-This option causes all configuration options to be reset to their
-default values as if the environment variable POSIXLY_CORRECT had
-been set.
-
-=item auto_abbrev
-
-Allow option names to be abbreviated to uniqueness.
-Default is enabled unless environment variable
-POSIXLY_CORRECT has been set, in which case C<auto_abbrev> is disabled.
-
-=item getopt_compat
-
-Allow C<+> to start options.
-Default is enabled unless environment variable
-POSIXLY_CORRECT has been set, in which case C<getopt_compat> is disabled.
-
-=item gnu_compat
-
-C<gnu_compat> controls whether C<--opt=> is allowed, and what it should
-do. Without C<gnu_compat>, C<--opt=> gives an error. With C<gnu_compat>,
-C<--opt=> will give option C<opt> and empty value.
-This is the way GNU getopt_long() does it.
-
-=item gnu_getopt
-
-This is a short way of setting C<gnu_compat> C<bundling> C<permute>
-C<no_getopt_compat>. With C<gnu_getopt>, command line handling should be
-fully compatible with GNU getopt_long().
-
-=item require_order
-
-Whether command line arguments are allowed to be mixed with options.
-Default is disabled unless environment variable
-POSIXLY_CORRECT has been set, in which case C<require_order> is enabled.
-
-See also C<permute>, which is the opposite of C<require_order>.
-
-=item permute
-
-Whether command line arguments are allowed to be mixed with options.
-Default is enabled unless environment variable
-POSIXLY_CORRECT has been set, in which case C<permute> is disabled.
-Note that C<permute> is the opposite of C<require_order>.
-
-If C<permute> is enabled, this means that
-
- --foo arg1 --bar arg2 arg3
-
-is equivalent to
-
- --foo --bar arg1 arg2 arg3
-
-If an argument callback routine is specified, C<@ARGV> will always be
-empty upon successful return of GetOptions() since all options have been
-processed. The only exception is when C<--> is used:
-
- --foo arg1 --bar arg2 -- arg3
-
-This will call the callback routine for arg1 and arg2, and then
-terminate GetOptions() leaving C<"arg3"> in C<@ARGV>.
-
-If C<require_order> is enabled, options processing
-terminates when the first non-option is encountered.
-
- --foo arg1 --bar arg2 arg3
-
-is equivalent to
-
- --foo -- arg1 --bar arg2 arg3
-
-If C<pass_through> is also enabled, options processing will terminate
-at the first unrecognized option, or non-option, whichever comes
-first.
-
-=item bundling (default: disabled)
-
-Enabling this option will allow single-character options to be
-bundled. To distinguish bundles from long option names, long options
-I<must> be introduced with C<--> and bundles with C<->.
-
-Note that, if you have options C<a>, C<l> and C<all>, and
-auto_abbrev enabled, possible arguments and option settings are:
-
- using argument sets option(s)
- ------------------------------------------
- -a, --a a
- -l, --l l
- -al, -la, -ala, -all,... a, l
- --al, --all all
-
-The surprising part is that C<--a> sets option C<a> (due to auto
-completion), not C<all>.
-
-Note: disabling C<bundling> also disables C<bundling_override>.
-
-=item bundling_override (default: disabled)
-
-If C<bundling_override> is enabled, bundling is enabled as with
-C<bundling> but now long option names override option bundles.
-
-Note: disabling C<bundling_override> also disables C<bundling>.
-
-B<Note:> Using option bundling can easily lead to unexpected results,
-especially when mixing long options and bundles. Caveat emptor.
-
-=item ignore_case (default: enabled)
-
-If enabled, case is ignored when matching long option names. If,
-however, bundling is enabled as well, single character options will be
-treated case-sensitive.
-
-With C<ignore_case>, option specifications for options that only
-differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as
-duplicates.
-
-Note: disabling C<ignore_case> also disables C<ignore_case_always>.
-
-=item ignore_case_always (default: disabled)
-
-When bundling is in effect, case is ignored on single-character
-options also.
-
-Note: disabling C<ignore_case_always> also disables C<ignore_case>.
-
-=item auto_version (default:disabled)
-
-Automatically provide support for the B<--version> option if
-the application did not specify a handler for this option itself.
-
-Getopt::Long will provide a standard version message that includes the
-program name, its version (if $main::VERSION is defined), and the
-versions of Getopt::Long and Perl. The message will be written to
-standard output and processing will terminate.
-
-C<auto_version> will be enabled if the calling program explicitly
-specified a version number higher than 2.32 in the C<use> or
-C<require> statement.
-
-=item auto_help (default:disabled)
-
-Automatically provide support for the B<--help> and B<-?> options if
-the application did not specify a handler for this option itself.
-
-Getopt::Long will provide a help message using module L<Pod::Usage>. The
-message, derived from the SYNOPSIS POD section, will be written to
-standard output and processing will terminate.
-
-C<auto_help> will be enabled if the calling program explicitly
-specified a version number higher than 2.32 in the C<use> or
-C<require> statement.
-
-=item pass_through (default: disabled)
-
-Options that are unknown, ambiguous or supplied with an invalid option
-value are passed through in C<@ARGV> instead of being flagged as
-errors. This makes it possible to write wrapper scripts that process
-only part of the user supplied command line arguments, and pass the
-remaining options to some other program.
-
-If C<require_order> is enabled, options processing will terminate at
-the first unrecognized option, or non-option, whichever comes first.
-However, if C<permute> is enabled instead, results can become confusing.
-
-Note that the options terminator (default C<-->), if present, will
-also be passed through in C<@ARGV>.
-
-=item prefix
-
-The string that starts options. If a constant string is not
-sufficient, see C<prefix_pattern>.
-
-=item prefix_pattern
-
-A Perl pattern that identifies the strings that introduce options.
-Default is C<--|-|\+> unless environment variable
-POSIXLY_CORRECT has been set, in which case it is C<--|->.
-
-=item long_prefix_pattern
-
-A Perl pattern that allows the disambiguation of long and short
-prefixes. Default is C<-->.
-
-Typically you only need to set this if you are using nonstandard
-prefixes and want some or all of them to have the same semantics as
-'--' does under normal circumstances.
-
-For example, setting prefix_pattern to C<--|-|\+|\/> and
-long_prefix_pattern to C<--|\/> would add Win32 style argument
-handling.
-
-=item debug (default: disabled)
-
-Enable debugging output.
-
-=back
-
-=head1 Exportable Methods
-
-=over
-
-=item VersionMessage
-
-This subroutine provides a standard version message. Its argument can be:
-
-=over 4
-
-=item *
-
-A string containing the text of a message to print I<before> printing
-the standard message.
-
-=item *
-
-A numeric value corresponding to the desired exit status.
-
-=item *
-
-A reference to a hash.
-
-=back
-
-If more than one argument is given then the entire argument list is
-assumed to be a hash. If a hash is supplied (either as a reference or
-as a list) it should contain one or more elements with the following
-keys:
-
-=over 4
-
-=item C<-message>
-
-=item C<-msg>
-
-The text of a message to print immediately prior to printing the
-program's usage message.
-
-=item C<-exitval>
-
-The desired exit status to pass to the B<exit()> function.
-This should be an integer, or else the string "NOEXIT" to
-indicate that control should simply be returned without
-terminating the invoking process.
-
-=item C<-output>
-
-A reference to a filehandle, or the pathname of a file to which the
-usage message should be written. The default is C<\*STDERR> unless the
-exit value is less than 2 (in which case the default is C<\*STDOUT>).
-
-=back
-
-You cannot tie this routine directly to an option, e.g.:
-
- GetOptions("version" => \&VersionMessage);
-
-Use this instead:
-
- GetOptions("version" => sub { VersionMessage() });
-
-=item HelpMessage
-
-This subroutine produces a standard help message, derived from the
-program's POD section SYNOPSIS using L<Pod::Usage>. It takes the same
-arguments as VersionMessage(). In particular, you cannot tie it
-directly to an option, e.g.:
-
- GetOptions("help" => \&HelpMessage);
-
-Use this instead:
-
- GetOptions("help" => sub { HelpMessage() });
-
-=back
-
-=head1 Return values and Errors
-
-Configuration errors and errors in the option definitions are
-signalled using die() and will terminate the calling program unless
-the call to Getopt::Long::GetOptions() was embedded in C<eval { ...
-}>, or die() was trapped using C<$SIG{__DIE__}>.
-
-GetOptions returns true to indicate success.
-It returns false when the function detected one or more errors during
-option parsing. These errors are signalled using warn() and can be
-trapped with C<$SIG{__WARN__}>.
-
-=head1 Legacy
-
-The earliest development of C<newgetopt.pl> started in 1990, with Perl
-version 4. As a result, its development, and the development of
-Getopt::Long, has gone through several stages. Since backward
-compatibility has always been extremely important, the current version
-of Getopt::Long still supports a lot of constructs that nowadays are
-no longer necessary or otherwise unwanted. This section describes
-briefly some of these 'features'.
-
-=head2 Default destinations
-
-When no destination is specified for an option, GetOptions will store
-the resultant value in a global variable named C<opt_>I<XXX>, where
-I<XXX> is the primary name of this option. When a progam executes
-under C<use strict> (recommended), these variables must be
-pre-declared with our() or C<use vars>.
-
- our $opt_length = 0;
- GetOptions ('length=i'); # will store in $opt_length
-
-To yield a usable Perl variable, characters that are not part of the
-syntax for variables are translated to underscores. For example,
-C<--fpp-struct-return> will set the variable
-C<$opt_fpp_struct_return>. Note that this variable resides in the
-namespace of the calling program, not necessarily C<main>. For
-example:
-
- GetOptions ("size=i", "sizes=i@");
-
-with command line "-size 10 -sizes 24 -sizes 48" will perform the
-equivalent of the assignments
-
- $opt_size = 10;
- @opt_sizes = (24, 48);
-
-=head2 Alternative option starters
-
-A string of alternative option starter characters may be passed as the
-first argument (or the first argument after a leading hash reference
-argument).
-
- my $len = 0;
- GetOptions ('/', 'length=i' => $len);
-
-Now the command line may look like:
-
- /length 24 -- arg
-
-Note that to terminate options processing still requires a double dash
-C<-->.
-
-GetOptions() will not interpret a leading C<< "<>" >> as option starters
-if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as
-option starters, use C<< "><" >>. Confusing? Well, B<using a starter
-argument is strongly deprecated> anyway.
-
-=head2 Configuration variables
-
-Previous versions of Getopt::Long used variables for the purpose of
-configuring. Although manipulating these variables still work, it is
-strongly encouraged to use the C<Configure> routine that was introduced
-in version 2.17. Besides, it is much easier.
-
-=head1 Tips and Techniques
-
-=head2 Pushing multiple values in a hash option
-
-Sometimes you want to combine the best of hashes and arrays. For
-example, the command line:
-
- --list add=first --list add=second --list add=third
-
-where each successive 'list add' option will push the value of add
-into array ref $list->{'add'}. The result would be like
-
- $list->{add} = [qw(first second third)];
-
-This can be accomplished with a destination routine:
-
- GetOptions('list=s%' =>
- sub { push(@{$list{$_[1]}}, $_[2]) });
-
-=head1 Troubleshooting
-
-=head2 GetOptions does not return a false result when an option is not supplied
-
-That's why they're called 'options'.
-
-=head2 GetOptions does not split the command line correctly
-
-The command line is not split by GetOptions, but by the command line
-interpreter (CLI). On Unix, this is the shell. On Windows, it is
-COMMAND.COM or CMD.EXE. Other operating systems have other CLIs.
-
-It is important to know that these CLIs may behave different when the
-command line contains special characters, in particular quotes or
-backslashes. For example, with Unix shells you can use single quotes
-(C<'>) and double quotes (C<">) to group words together. The following
-alternatives are equivalent on Unix:
-
- "two words"
- 'two words'
- two\ words
-
-In case of doubt, insert the following statement in front of your Perl
-program:
-
- print STDERR (join("|", at ARGV),"\n");
-
-to verify how your CLI passes the arguments to the program.
-
-=head2 Undefined subroutine &main::GetOptions called
-
-Are you running Windows, and did you write
-
- use GetOpt::Long;
-
-(note the capital 'O')?
-
-=head2 How do I put a "-?" option into a Getopt::Long?
-
-You can only obtain this using an alias, and Getopt::Long of at least
-version 2.13.
-
- use Getopt::Long;
- GetOptions ("help|?"); # -help and -? will both set $opt_help
-
-=head1 AUTHOR
-
-Johan Vromans <jvromans at squirrel.nl>
-
-=head1 COPYRIGHT AND DISCLAIMER
-
-This program is Copyright 1990,2009 by Johan Vromans.
-This program is free software; you can redistribute it and/or
-modify it under the terms of the Perl Artistic License or the
-GNU General Public License as published by the Free Software
-Foundation; either version 2 of the License, or (at your option) any
-later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-If you do not have a copy of the GNU General Public License write to
-the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
-MA 02139, USA.
-
-=cut
-
Deleted: trunk/contrib/perl/lib/Memoize.pm
===================================================================
--- trunk/contrib/perl/lib/Memoize.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Memoize.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1047 +0,0 @@
-# -*- mode: perl; perl-indent-level: 2; -*-
-# Memoize.pm
-#
-# Transparent memoization of idempotent functions
-#
-# Copyright 1998, 1999, 2000, 2001 M-J. Dominus.
-# You may copy and distribute this program under the
-# same terms as Perl itself. If in doubt,
-# write to mjd-perl-memoize+ at plover.com for a license.
-#
-# Version 1.01 $Revision: 1.1.1.2 $ $Date: 2011-02-17 12:49:38 $
-
-package Memoize;
-$VERSION = '1.01_03';
-
-# Compile-time constants
-sub SCALAR () { 0 }
-sub LIST () { 1 }
-
-
-#
-# Usage memoize(functionname/ref,
-# { NORMALIZER => coderef, INSTALL => name,
-# LIST_CACHE => descriptor, SCALAR_CACHE => descriptor }
-#
-
-use Carp;
-use Exporter;
-use vars qw($DEBUG);
-use Config; # Dammit.
- at ISA = qw(Exporter);
- at EXPORT = qw(memoize);
- at EXPORT_OK = qw(unmemoize flush_cache);
-use strict;
-
-my %memotable;
-my %revmemotable;
-my @CONTEXT_TAGS = qw(MERGE TIE MEMORY FAULT HASH);
-my %IS_CACHE_TAG = map {($_ => 1)} @CONTEXT_TAGS;
-
-# Raise an error if the user tries to specify one of thesepackage as a
-# tie for LIST_CACHE
-
-my %scalar_only = map {($_ => 1)} qw(DB_File GDBM_File SDBM_File ODBM_File NDBM_File);
-
-sub memoize {
- my $fn = shift;
- my %options = @_;
- my $options = \%options;
-
- unless (defined($fn) &&
- (ref $fn eq 'CODE' || ref $fn eq '')) {
- croak "Usage: memoize 'functionname'|coderef {OPTIONS}";
- }
-
- my $uppack = caller; # TCL me Elmo!
- my $cref; # Code reference to original function
- my $name = (ref $fn ? undef : $fn);
-
- # Convert function names to code references
- $cref = &_make_cref($fn, $uppack);
-
- # Locate function prototype, if any
- my $proto = prototype $cref;
- if (defined $proto) { $proto = "($proto)" }
- else { $proto = "" }
-
- # I would like to get rid of the eval, but there seems not to be any
- # other way to set the prototype properly. The switch here for
- # 'usethreads' works around a bug in threadperl having to do with
- # magic goto. It would be better to fix the bug and use the magic
- # goto version everywhere.
- my $wrapper =
- $Config{usethreads}
- ? eval "sub $proto { &_memoizer(\$cref, \@_); }"
- : eval "sub $proto { unshift \@_, \$cref; goto &_memoizer; }";
-
- my $normalizer = $options{NORMALIZER};
- if (defined $normalizer && ! ref $normalizer) {
- $normalizer = _make_cref($normalizer, $uppack);
- }
-
- my $install_name;
- if (defined $options->{INSTALL}) {
- # INSTALL => name
- $install_name = $options->{INSTALL};
- } elsif (! exists $options->{INSTALL}) {
- # No INSTALL option provided; use original name if possible
- $install_name = $name;
- } else {
- # INSTALL => undef means don't install
- }
-
- if (defined $install_name) {
- $install_name = $uppack . '::' . $install_name
- unless $install_name =~ /::/;
- no strict;
- local($^W) = 0; # ``Subroutine $install_name redefined at ...''
- *{$install_name} = $wrapper; # Install memoized version
- }
-
- $revmemotable{$wrapper} = "" . $cref; # Turn code ref into hash key
-
- # These will be the caches
- my %caches;
- for my $context (qw(SCALAR LIST)) {
- # suppress subsequent 'uninitialized value' warnings
- $options{"${context}_CACHE"} ||= '';
-
- my $cache_opt = $options{"${context}_CACHE"};
- my @cache_opt_args;
- if (ref $cache_opt) {
- @cache_opt_args = @$cache_opt;
- $cache_opt = shift @cache_opt_args;
- }
- if ($cache_opt eq 'FAULT') { # no cache
- $caches{$context} = undef;
- } elsif ($cache_opt eq 'HASH') { # user-supplied hash
- my $cache = $cache_opt_args[0];
- my $package = ref(tied %$cache);
- if ($context eq 'LIST' && $scalar_only{$package}) {
- croak("You can't use $package for LIST_CACHE because it can only store scalars");
- }
- $caches{$context} = $cache;
- } elsif ($cache_opt eq '' || $IS_CACHE_TAG{$cache_opt}) {
- # default is that we make up an in-memory hash
- $caches{$context} = {};
- # (this might get tied later, or MERGEd away)
- } else {
- croak "Unrecognized option to `${context}_CACHE': `$cache_opt' should be one of (@CONTEXT_TAGS); aborting";
- }
- }
-
- # Perhaps I should check here that you didn't supply *both* merge
- # options. But if you did, it does do something reasonable: They
- # both get merged to the same in-memory hash.
- if ($options{SCALAR_CACHE} eq 'MERGE') {
- $caches{SCALAR} = $caches{LIST};
- } elsif ($options{LIST_CACHE} eq 'MERGE') {
- $caches{LIST} = $caches{SCALAR};
- }
-
- # Now deal with the TIE options
- {
- my $context;
- foreach $context (qw(SCALAR LIST)) {
- # If the relevant option wasn't `TIE', this call does nothing.
- _my_tie($context, $caches{$context}, $options); # Croaks on failure
- }
- }
-
- # We should put some more stuff in here eventually.
- # We've been saying that for serveral versions now.
- # And you know what? More stuff keeps going in!
- $memotable{$cref} =
- {
- O => $options, # Short keys here for things we need to access frequently
- N => $normalizer,
- U => $cref,
- MEMOIZED => $wrapper,
- PACKAGE => $uppack,
- NAME => $install_name,
- S => $caches{SCALAR},
- L => $caches{LIST},
- };
-
- $wrapper # Return just memoized version
-}
-
-# This function tries to load a tied hash class and tie the hash to it.
-sub _my_tie {
- my ($context, $hash, $options) = @_;
- my $fullopt = $options->{"${context}_CACHE"};
-
- # We already checked to make sure that this works.
- my $shortopt = (ref $fullopt) ? $fullopt->[0] : $fullopt;
-
- return unless defined $shortopt && $shortopt eq 'TIE';
- carp("TIE option to memoize() is deprecated; use HASH instead")
- if $^W;
-
- my @args = ref $fullopt ? @$fullopt : ();
- shift @args;
- my $module = shift @args;
- if ($context eq 'LIST' && $scalar_only{$module}) {
- croak("You can't use $module for LIST_CACHE because it can only store scalars");
- }
- my $modulefile = $module . '.pm';
- $modulefile =~ s{::}{/}g;
- eval { require $modulefile };
- if ($@) {
- croak "Memoize: Couldn't load hash tie module `$module': $@; aborting";
- }
- my $rc = (tie %$hash => $module, @args);
- unless ($rc) {
- croak "Memoize: Couldn't tie hash to `$module': $!; aborting";
- }
- 1;
-}
-
-sub flush_cache {
- my $func = _make_cref($_[0], scalar caller);
- my $info = $memotable{$revmemotable{$func}};
- die "$func not memoized" unless defined $info;
- for my $context (qw(S L)) {
- my $cache = $info->{$context};
- if (tied %$cache && ! (tied %$cache)->can('CLEAR')) {
- my $funcname = defined($info->{NAME}) ?
- "function $info->{NAME}" : "anonymous function $func";
- my $context = {S => 'scalar', L => 'list'}->{$context};
- croak "Tied cache hash for $context-context $funcname does not support flushing";
- } else {
- %$cache = ();
- }
- }
-}
-
-# This is the function that manages the memo tables.
-sub _memoizer {
- my $orig = shift; # stringized version of ref to original func.
- my $info = $memotable{$orig};
- my $normalizer = $info->{N};
-
- my $argstr;
- my $context = (wantarray() ? LIST : SCALAR);
-
- if (defined $normalizer) {
- no strict;
- if ($context == SCALAR) {
- $argstr = &{$normalizer}(@_);
- } elsif ($context == LIST) {
- ($argstr) = &{$normalizer}(@_);
- } else {
- croak "Internal error \#41; context was neither LIST nor SCALAR\n";
- }
- } else { # Default normalizer
- local $^W = 0;
- $argstr = join chr(28), at _;
- }
-
- if ($context == SCALAR) {
- my $cache = $info->{S};
- _crap_out($info->{NAME}, 'scalar') unless $cache;
- if (exists $cache->{$argstr}) {
- return $cache->{$argstr};
- } else {
- my $val = &{$info->{U}}(@_);
- # Scalars are considered to be lists; store appropriately
- if ($info->{O}{SCALAR_CACHE} eq 'MERGE') {
- $cache->{$argstr} = [$val];
- } else {
- $cache->{$argstr} = $val;
- }
- $val;
- }
- } elsif ($context == LIST) {
- my $cache = $info->{L};
- _crap_out($info->{NAME}, 'list') unless $cache;
- if (exists $cache->{$argstr}) {
- my $val = $cache->{$argstr};
- # If LISTCONTEXT=>MERGE, then the function never returns lists,
- # so we have a scalar value cached, so just return it straightaway:
- return ($val) if $info->{O}{LIST_CACHE} eq 'MERGE';
- # Maybe in a later version we can use a faster test.
-
- # Otherwise, we cached an array containing the returned list:
- return @$val;
- } else {
- my @q = &{$info->{U}}(@_);
- $cache->{$argstr} = $info->{O}{LIST_CACHE} eq 'MERGE' ? $q [0] : \@q;
- @q;
- }
- } else {
- croak "Internal error \#42; context was neither LIST nor SCALAR\n";
- }
-}
-
-sub unmemoize {
- my $f = shift;
- my $uppack = caller;
- my $cref = _make_cref($f, $uppack);
-
- unless (exists $revmemotable{$cref}) {
- croak "Could not unmemoize function `$f', because it was not memoized to begin with";
- }
-
- my $tabent = $memotable{$revmemotable{$cref}};
- unless (defined $tabent) {
- croak "Could not figure out how to unmemoize function `$f'";
- }
- my $name = $tabent->{NAME};
- if (defined $name) {
- no strict;
- local($^W) = 0; # ``Subroutine $install_name redefined at ...''
- *{$name} = $tabent->{U}; # Replace with original function
- }
- undef $memotable{$revmemotable{$cref}};
- undef $revmemotable{$cref};
-
- # This removes the last reference to the (possibly tied) memo tables
- # my ($old_function, $memotabs) = @{$tabent}{'U','S','L'};
- # undef $tabent;
-
-# # Untie the memo tables if they were tied.
-# my $i;
-# for $i (0,1) {
-# if (tied %{$memotabs->[$i]}) {
-# warn "Untying hash #$i\n";
-# untie %{$memotabs->[$i]};
-# }
-# }
-
- $tabent->{U};
-}
-
-sub _make_cref {
- my $fn = shift;
- my $uppack = shift;
- my $cref;
- my $name;
-
- if (ref $fn eq 'CODE') {
- $cref = $fn;
- } elsif (! ref $fn) {
- if ($fn =~ /::/) {
- $name = $fn;
- } else {
- $name = $uppack . '::' . $fn;
- }
- no strict;
- if (defined $name and !defined(&$name)) {
- croak "Cannot operate on nonexistent function `$fn'";
- }
-# $cref = \&$name;
- $cref = *{$name}{CODE};
- } else {
- my $parent = (caller(1))[3]; # Function that called _make_cref
- croak "Usage: argument 1 to `$parent' must be a function name or reference.\n";
- }
- $DEBUG and warn "${name}($fn) => $cref in _make_cref\n";
- $cref;
-}
-
-sub _crap_out {
- my ($funcname, $context) = @_;
- if (defined $funcname) {
- croak "Function `$funcname' called in forbidden $context context; faulting";
- } else {
- croak "Anonymous function called in forbidden $context context; faulting";
- }
-}
-
-1;
-
-
-
-
-
-=head1 NAME
-
-Memoize - Make functions faster by trading space for time
-
-=head1 SYNOPSIS
-
- # This is the documentation for Memoize 1.01
- use Memoize;
- memoize('slow_function');
- slow_function(arguments); # Is faster than it was before
-
-
-This is normally all you need to know. However, many options are available:
-
- memoize(function, options...);
-
-Options include:
-
- NORMALIZER => function
- INSTALL => new_name
-
- SCALAR_CACHE => 'MEMORY'
- SCALAR_CACHE => ['HASH', \%cache_hash ]
- SCALAR_CACHE => 'FAULT'
- SCALAR_CACHE => 'MERGE'
-
- LIST_CACHE => 'MEMORY'
- LIST_CACHE => ['HASH', \%cache_hash ]
- LIST_CACHE => 'FAULT'
- LIST_CACHE => 'MERGE'
-
-=head1 DESCRIPTION
-
-`Memoizing' a function makes it faster by trading space for time. It
-does this by caching the return values of the function in a table.
-If you call the function again with the same arguments, C<memoize>
-jumps in and gives you the value out of the table, instead of letting
-the function compute the value all over again.
-
-Here is an extreme example. Consider the Fibonacci sequence, defined
-by the following function:
-
- # Compute Fibonacci numbers
- sub fib {
- my $n = shift;
- return $n if $n < 2;
- fib($n-1) + fib($n-2);
- }
-
-This function is very slow. Why? To compute fib(14), it first wants
-to compute fib(13) and fib(12), and add the results. But to compute
-fib(13), it first has to compute fib(12) and fib(11), and then it
-comes back and computes fib(12) all over again even though the answer
-is the same. And both of the times that it wants to compute fib(12),
-it has to compute fib(11) from scratch, and then it has to do it
-again each time it wants to compute fib(13). This function does so
-much recomputing of old results that it takes a really long time to
-run---fib(14) makes 1,200 extra recursive calls to itself, to compute
-and recompute things that it already computed.
-
-This function is a good candidate for memoization. If you memoize the
-`fib' function above, it will compute fib(14) exactly once, the first
-time it needs to, and then save the result in a table. Then if you
-ask for fib(14) again, it gives you the result out of the table.
-While computing fib(14), instead of computing fib(12) twice, it does
-it once; the second time it needs the value it gets it from the table.
-It doesn't compute fib(11) four times; it computes it once, getting it
-from the table the next three times. Instead of making 1,200
-recursive calls to `fib', it makes 15. This makes the function about
-150 times faster.
-
-You could do the memoization yourself, by rewriting the function, like
-this:
-
- # Compute Fibonacci numbers, memoized version
- { my @fib;
- sub fib {
- my $n = shift;
- return $fib[$n] if defined $fib[$n];
- return $fib[$n] = $n if $n < 2;
- $fib[$n] = fib($n-1) + fib($n-2);
- }
- }
-
-Or you could use this module, like this:
-
- use Memoize;
- memoize('fib');
-
- # Rest of the fib function just like the original version.
-
-This makes it easy to turn memoizing on and off.
-
-Here's an even simpler example: I wrote a simple ray tracer; the
-program would look in a certain direction, figure out what it was
-looking at, and then convert the `color' value (typically a string
-like `red') of that object to a red, green, and blue pixel value, like
-this:
-
- for ($direction = 0; $direction < 300; $direction++) {
- # Figure out which object is in direction $direction
- $color = $object->{color};
- ($r, $g, $b) = @{&ColorToRGB($color)};
- ...
- }
-
-Since there are relatively few objects in a picture, there are only a
-few colors, which get looked up over and over again. Memoizing
-C<ColorToRGB> sped up the program by several percent.
-
-=head1 DETAILS
-
-This module exports exactly one function, C<memoize>. The rest of the
-functions in this package are None of Your Business.
-
-You should say
-
- memoize(function)
-
-where C<function> is the name of the function you want to memoize, or
-a reference to it. C<memoize> returns a reference to the new,
-memoized version of the function, or C<undef> on a non-fatal error.
-At present, there are no non-fatal errors, but there might be some in
-the future.
-
-If C<function> was the name of a function, then C<memoize> hides the
-old version and installs the new memoized version under the old name,
-so that C<&function(...)> actually invokes the memoized version.
-
-=head1 OPTIONS
-
-There are some optional options you can pass to C<memoize> to change
-the way it behaves a little. To supply options, invoke C<memoize>
-like this:
-
- memoize(function, NORMALIZER => function,
- INSTALL => newname,
- SCALAR_CACHE => option,
- LIST_CACHE => option
- );
-
-Each of these options is optional; you can include some, all, or none
-of them.
-
-=head2 INSTALL
-
-If you supply a function name with C<INSTALL>, memoize will install
-the new, memoized version of the function under the name you give.
-For example,
-
- memoize('fib', INSTALL => 'fastfib')
-
-installs the memoized version of C<fib> as C<fastfib>; without the
-C<INSTALL> option it would have replaced the old C<fib> with the
-memoized version.
-
-To prevent C<memoize> from installing the memoized version anywhere, use
-C<INSTALL =E<gt> undef>.
-
-=head2 NORMALIZER
-
-Suppose your function looks like this:
-
- # Typical call: f('aha!', A => 11, B => 12);
- sub f {
- my $a = shift;
- my %hash = @_;
- $hash{B} ||= 2; # B defaults to 2
- $hash{C} ||= 7; # C defaults to 7
-
- # Do something with $a, %hash
- }
-
-Now, the following calls to your function are all completely equivalent:
-
- f(OUCH);
- f(OUCH, B => 2);
- f(OUCH, C => 7);
- f(OUCH, B => 2, C => 7);
- f(OUCH, C => 7, B => 2);
- (etc.)
-
-However, unless you tell C<Memoize> that these calls are equivalent,
-it will not know that, and it will compute the values for these
-invocations of your function separately, and store them separately.
-
-To prevent this, supply a C<NORMALIZER> function that turns the
-program arguments into a string in a way that equivalent arguments
-turn into the same string. A C<NORMALIZER> function for C<f> above
-might look like this:
-
- sub normalize_f {
- my $a = shift;
- my %hash = @_;
- $hash{B} ||= 2;
- $hash{C} ||= 7;
-
- join(',', $a, map ($_ => $hash{$_}) sort keys %hash);
- }
-
-Each of the argument lists above comes out of the C<normalize_f>
-function looking exactly the same, like this:
-
- OUCH,B,2,C,7
-
-You would tell C<Memoize> to use this normalizer this way:
-
- memoize('f', NORMALIZER => 'normalize_f');
-
-C<memoize> knows that if the normalized version of the arguments is
-the same for two argument lists, then it can safely look up the value
-that it computed for one argument list and return it as the result of
-calling the function with the other argument list, even if the
-argument lists look different.
-
-The default normalizer just concatenates the arguments with character
-28 in between. (In ASCII, this is called FS or control-\.) This
-always works correctly for functions with only one string argument,
-and also when the arguments never contain character 28. However, it
-can confuse certain argument lists:
-
- normalizer("a\034", "b")
- normalizer("a", "\034b")
- normalizer("a\034\034b")
-
-for example.
-
-Since hash keys are strings, the default normalizer will not
-distinguish between C<undef> and the empty string. It also won't work
-when the function's arguments are references. For example, consider a
-function C<g> which gets two arguments: A number, and a reference to
-an array of numbers:
-
- g(13, [1,2,3,4,5,6,7]);
-
-The default normalizer will turn this into something like
-C<"13\034ARRAY(0x436c1f)">. That would be all right, except that a
-subsequent array of numbers might be stored at a different location
-even though it contains the same data. If this happens, C<Memoize>
-will think that the arguments are different, even though they are
-equivalent. In this case, a normalizer like this is appropriate:
-
- sub normalize { join ' ', $_[0], @{$_[1]} }
-
-For the example above, this produces the key "13 1 2 3 4 5 6 7".
-
-Another use for normalizers is when the function depends on data other
-than those in its arguments. Suppose you have a function which
-returns a value which depends on the current hour of the day:
-
- sub on_duty {
- my ($problem_type) = @_;
- my $hour = (localtime)[2];
- open my $fh, "$DIR/$problem_type" or die...;
- my $line;
- while ($hour-- > 0)
- $line = <$fh>;
- }
- return $line;
- }
-
-At 10:23, this function generates the 10th line of a data file; at
-3:45 PM it generates the 15th line instead. By default, C<Memoize>
-will only see the $problem_type argument. To fix this, include the
-current hour in the normalizer:
-
- sub normalize { join ' ', (localtime)[2], @_ }
-
-The calling context of the function (scalar or list context) is
-propagated to the normalizer. This means that if the memoized
-function will treat its arguments differently in list context than it
-would in scalar context, you can have the normalizer function select
-its behavior based on the results of C<wantarray>. Even if called in
-a list context, a normalizer should still return a single string.
-
-=head2 C<SCALAR_CACHE>, C<LIST_CACHE>
-
-Normally, C<Memoize> caches your function's return values into an
-ordinary Perl hash variable. However, you might like to have the
-values cached on the disk, so that they persist from one run of your
-program to the next, or you might like to associate some other
-interesting semantics with the cached values.
-
-There's a slight complication under the hood of C<Memoize>: There are
-actually I<two> caches, one for scalar values and one for list values.
-When your function is called in scalar context, its return value is
-cached in one hash, and when your function is called in list context,
-its value is cached in the other hash. You can control the caching
-behavior of both contexts independently with these options.
-
-The argument to C<LIST_CACHE> or C<SCALAR_CACHE> must either be one of
-the following four strings:
-
- MEMORY
- FAULT
- MERGE
- HASH
-
-or else it must be a reference to a list whose first element is one of
-these four strings, such as C<[HASH, arguments...]>.
-
-=over 4
-
-=item C<MEMORY>
-
-C<MEMORY> means that return values from the function will be cached in
-an ordinary Perl hash variable. The hash variable will not persist
-after the program exits. This is the default.
-
-=item C<HASH>
-
-C<HASH> allows you to specify that a particular hash that you supply
-will be used as the cache. You can tie this hash beforehand to give
-it any behavior you want.
-
-A tied hash can have any semantics at all. It is typically tied to an
-on-disk database, so that cached values are stored in the database and
-retrieved from it again when needed, and the disk file typically
-persists after your program has exited. See C<perltie> for more
-complete details about C<tie>.
-
-A typical example is:
-
- use DB_File;
- tie my %cache => 'DB_File', $filename, O_RDWR|O_CREAT, 0666;
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
-This has the effect of storing the cache in a C<DB_File> database
-whose name is in C<$filename>. The cache will persist after the
-program has exited. Next time the program runs, it will find the
-cache already populated from the previous run of the program. Or you
-can forcibly populate the cache by constructing a batch program that
-runs in the background and populates the cache file. Then when you
-come to run your real program the memoized function will be fast
-because all its results have been precomputed.
-
-=item C<TIE>
-
-This option is no longer supported. It is still documented only to
-aid in the debugging of old programs that use it. Old programs should
-be converted to use the C<HASH> option instead.
-
- memoize ... [TIE, PACKAGE, ARGS...]
-
-is merely a shortcut for
-
- require PACKAGE;
- { my %cache;
- tie %cache, PACKAGE, ARGS...;
- }
- memoize ... [HASH => \%cache];
-
-=item C<FAULT>
-
-C<FAULT> means that you never expect to call the function in scalar
-(or list) context, and that if C<Memoize> detects such a call, it
-should abort the program. The error message is one of
-
- `foo' function called in forbidden list context at line ...
- `foo' function called in forbidden scalar context at line ...
-
-=item C<MERGE>
-
-C<MERGE> normally means the function does not distinguish between list
-and sclar context, and that return values in both contexts should be
-stored together. C<LIST_CACHE =E<gt> MERGE> means that list context
-return values should be stored in the same hash that is used for
-scalar context returns, and C<SCALAR_CACHE =E<gt> MERGE> means the
-same, mutatis mutandis. It is an error to specify C<MERGE> for both,
-but it probably does something useful.
-
-Consider this function:
-
- sub pi { 3; }
-
-Normally, the following code will result in two calls to C<pi>:
-
- $x = pi();
- ($y) = pi();
- $z = pi();
-
-The first call caches the value C<3> in the scalar cache; the second
-caches the list C<(3)> in the list cache. The third call doesn't call
-the real C<pi> function; it gets the value from the scalar cache.
-
-Obviously, the second call to C<pi> is a waste of time, and storing
-its return value is a waste of space. Specifying C<LIST_CACHE =E<gt>
-MERGE> will make C<memoize> use the same cache for scalar and list
-context return values, so that the second call uses the scalar cache
-that was populated by the first call. C<pi> ends up being called only
-once, and both subsequent calls return C<3> from the cache, regardless
-of the calling context.
-
-Another use for C<MERGE> is when you want both kinds of return values
-stored in the same disk file; this saves you from having to deal with
-two disk files instead of one. You can use a normalizer function to
-keep the two sets of return values separate. For example:
-
- tie my %cache => 'MLDBM', 'DB_File', $filename, ...;
-
- memoize 'myfunc',
- NORMALIZER => 'n',
- SCALAR_CACHE => [HASH => \%cache],
- LIST_CACHE => MERGE,
- ;
-
- sub n {
- my $context = wantarray() ? 'L' : 'S';
- # ... now compute the hash key from the arguments ...
- $hashkey = "$context:$hashkey";
- }
-
-This normalizer function will store scalar context return values in
-the disk file under keys that begin with C<S:>, and list context
-return values under keys that begin with C<L:>.
-
-=back
-
-=head1 OTHER FACILITIES
-
-=head2 C<unmemoize>
-
-There's an C<unmemoize> function that you can import if you want to.
-Why would you want to? Here's an example: Suppose you have your cache
-tied to a DBM file, and you want to make sure that the cache is
-written out to disk if someone interrupts the program. If the program
-exits normally, this will happen anyway, but if someone types
-control-C or something then the program will terminate immediately
-without synchronizing the database. So what you can do instead is
-
- $SIG{INT} = sub { unmemoize 'function' };
-
-C<unmemoize> accepts a reference to, or the name of a previously
-memoized function, and undoes whatever it did to provide the memoized
-version in the first place, including making the name refer to the
-unmemoized version if appropriate. It returns a reference to the
-unmemoized version of the function.
-
-If you ask it to unmemoize a function that was never memoized, it
-croaks.
-
-=head2 C<flush_cache>
-
-C<flush_cache(function)> will flush out the caches, discarding I<all>
-the cached data. The argument may be a function name or a reference
-to a function. For finer control over when data is discarded or
-expired, see the documentation for C<Memoize::Expire>, included in
-this package.
-
-Note that if the cache is a tied hash, C<flush_cache> will attempt to
-invoke the C<CLEAR> method on the hash. If there is no C<CLEAR>
-method, this will cause a run-time error.
-
-An alternative approach to cache flushing is to use the C<HASH> option
-(see above) to request that C<Memoize> use a particular hash variable
-as its cache. Then you can examine or modify the hash at any time in
-any way you desire. You may flush the cache by using C<%hash = ()>.
-
-=head1 CAVEATS
-
-Memoization is not a cure-all:
-
-=over 4
-
-=item *
-
-Do not memoize a function whose behavior depends on program
-state other than its own arguments, such as global variables, the time
-of day, or file input. These functions will not produce correct
-results when memoized. For a particularly easy example:
-
- sub f {
- time;
- }
-
-This function takes no arguments, and as far as C<Memoize> is
-concerned, it always returns the same result. C<Memoize> is wrong, of
-course, and the memoized version of this function will call C<time> once
-to get the current time, and it will return that same time
-every time you call it after that.
-
-=item *
-
-Do not memoize a function with side effects.
-
- sub f {
- my ($a, $b) = @_;
- my $s = $a + $b;
- print "$a + $b = $s.\n";
- }
-
-This function accepts two arguments, adds them, and prints their sum.
-Its return value is the numuber of characters it printed, but you
-probably didn't care about that. But C<Memoize> doesn't understand
-that. If you memoize this function, you will get the result you
-expect the first time you ask it to print the sum of 2 and 3, but
-subsequent calls will return 1 (the return value of
-C<print>) without actually printing anything.
-
-=item *
-
-Do not memoize a function that returns a data structure that is
-modified by its caller.
-
-Consider these functions: C<getusers> returns a list of users somehow,
-and then C<main> throws away the first user on the list and prints the
-rest:
-
- sub main {
- my $userlist = getusers();
- shift @$userlist;
- foreach $u (@$userlist) {
- print "User $u\n";
- }
- }
-
- sub getusers {
- my @users;
- # Do something to get a list of users;
- \@users; # Return reference to list.
- }
-
-If you memoize C<getusers> here, it will work right exactly once. The
-reference to the users list will be stored in the memo table. C<main>
-will discard the first element from the referenced list. The next
-time you invoke C<main>, C<Memoize> will not call C<getusers>; it will
-just return the same reference to the same list it got last time. But
-this time the list has already had its head removed; C<main> will
-erroneously remove another element from it. The list will get shorter
-and shorter every time you call C<main>.
-
-Similarly, this:
-
- $u1 = getusers();
- $u2 = getusers();
- pop @$u1;
-
-will modify $u2 as well as $u1, because both variables are references
-to the same array. Had C<getusers> not been memoized, $u1 and $u2
-would have referred to different arrays.
-
-=item *
-
-Do not memoize a very simple function.
-
-Recently someone mentioned to me that the Memoize module made his
-program run slower instead of faster. It turned out that he was
-memoizing the following function:
-
- sub square {
- $_[0] * $_[0];
- }
-
-I pointed out that C<Memoize> uses a hash, and that looking up a
-number in the hash is necessarily going to take a lot longer than a
-single multiplication. There really is no way to speed up the
-C<square> function.
-
-Memoization is not magical.
-
-=back
-
-=head1 PERSISTENT CACHE SUPPORT
-
-You can tie the cache tables to any sort of tied hash that you want
-to, as long as it supports C<TIEHASH>, C<FETCH>, C<STORE>, and
-C<EXISTS>. For example,
-
- tie my %cache => 'GDBM_File', $filename, O_RDWR|O_CREAT, 0666;
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
-works just fine. For some storage methods, you need a little glue.
-
-C<SDBM_File> doesn't supply an C<EXISTS> method, so included in this
-package is a glue module called C<Memoize::SDBM_File> which does
-provide one. Use this instead of plain C<SDBM_File> to store your
-cache table on disk in an C<SDBM_File> database:
-
- tie my %cache => 'Memoize::SDBM_File', $filename, O_RDWR|O_CREAT, 0666;
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
-C<NDBM_File> has the same problem and the same solution. (Use
-C<Memoize::NDBM_File instead of plain NDBM_File.>)
-
-C<Storable> isn't a tied hash class at all. You can use it to store a
-hash to disk and retrieve it again, but you can't modify the hash while
-it's on the disk. So if you want to store your cache table in a
-C<Storable> database, use C<Memoize::Storable>, which puts a hashlike
-front-end onto C<Storable>. The hash table is actually kept in
-memory, and is loaded from your C<Storable> file at the time you
-memoize the function, and stored back at the time you unmemoize the
-function (or when your program exits):
-
- tie my %cache => 'Memoize::Storable', $filename;
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
- tie my %cache => 'Memoize::Storable', $filename, 'nstore';
- memoize 'function', SCALAR_CACHE => [HASH => \%cache];
-
-Include the `nstore' option to have the C<Storable> database written
-in `network order'. (See L<Storable> for more details about this.)
-
-The C<flush_cache()> function will raise a run-time error unless the
-tied package provides a C<CLEAR> method.
-
-=head1 EXPIRATION SUPPORT
-
-See Memoize::Expire, which is a plug-in module that adds expiration
-functionality to Memoize. If you don't like the kinds of policies
-that Memoize::Expire implements, it is easy to write your own plug-in
-module to implement whatever policy you desire. Memoize comes with
-several examples. An expiration manager that implements a LRU policy
-is available on CPAN as Memoize::ExpireLRU.
-
-=head1 BUGS
-
-The test suite is much better, but always needs improvement.
-
-There is some problem with the way C<goto &f> works under threaded
-Perl, perhaps because of the lexical scoping of C<@_>. This is a bug
-in Perl, and until it is resolved, memoized functions will see a
-slightly different C<caller()> and will perform a little more slowly
-on threaded perls than unthreaded perls.
-
-Some versions of C<DB_File> won't let you store data under a key of
-length 0. That means that if you have a function C<f> which you
-memoized and the cache is in a C<DB_File> database, then the value of
-C<f()> (C<f> called with no arguments) will not be memoized. If this
-is a big problem, you can supply a normalizer function that prepends
-C<"x"> to every key.
-
-=head1 MAILING LIST
-
-To join a very low-traffic mailing list for announcements about
-C<Memoize>, send an empty note to C<mjd-perl-memoize-request at plover.com>.
-
-=head1 AUTHOR
-
-Mark-Jason Dominus (C<mjd-perl-memoize+ at plover.com>), Plover Systems co.
-
-See the C<Memoize.pm> Page at http://www.plover.com/~mjd/perl/Memoize/
-for news and upgrades. Near this page, at
-http://www.plover.com/~mjd/perl/MiniMemoize/ there is an article about
-memoization and about the internals of Memoize that appeared in The
-Perl Journal, issue #13. (This article is also included in the
-Memoize distribution as `article.html'.)
-
-The author's book I<Higher Order Perl> (2005, ISBN 1558607013, published
-by Morgan Kaufmann) discusses memoization (and many other fascinating
-topics) in tremendous detail. It will also be available on-line for free.
-For more information, visit http://perl.plover.com/book/ .
-
-To join a mailing list for announcements about C<Memoize>, send an
-empty message to C<mjd-perl-memoize-request at plover.com>. This mailing
-list is for announcements only and has extremely low traffic---about
-two messages per year.
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 1998, 1999, 2000, 2001 by Mark Jason Dominus
-
-This library is free software; you may redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 THANK YOU
-
-Many thanks to Jonathan Roy for bug reports and suggestions, to
-Michael Schwern for other bug reports and patches, to Mike Cariaso for
-helping me to figure out the Right Thing to Do About Expiration, to
-Joshua Gerth, Joshua Chamas, Jonathan Roy (again), Mark D. Anderson,
-and Andrew Johnson for more suggestions about expiration, to Brent
-Powers for the Memoize::ExpireLRU module, to Ariel Scolnicov for
-delightful messages about the Fibonacci function, to Dion Almaer for
-thought-provoking suggestions about the default normalizer, to Walt
-Mankowski and Kurt Starsinic for much help investigating problems
-under threaded Perl, to Alex Dudkevich for reporting the bug in
-prototyped functions and for checking my patch, to Tony Bass for many
-helpful suggestions, to Jonathan Roy (again) for finding a use for
-C<unmemoize()>, to Philippe Verdret for enlightening discussion of
-C<Hook::PrePostCall>, to Nat Torkington for advice I ignored, to Chris
-Nandor for portability advice, to Randal Schwartz for suggesting the
-'C<flush_cache> function, and to Jenda Krynicky for being a light in
-the world.
-
-Special thanks to Jarkko Hietaniemi, the 5.8.0 pumpking, for including
-this module in the core and for his patient and helpful guidance
-during the integration process.
-
-=cut
Deleted: trunk/contrib/perl/lib/NEXT.pm
===================================================================
--- trunk/contrib/perl/lib/NEXT.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/NEXT.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,563 +0,0 @@
-package NEXT;
-$VERSION = '0.64';
-use Carp;
-use strict;
-use overload ();
-
-sub NEXT::ELSEWHERE::ancestors
-{
- my @inlist = shift;
- my @outlist = ();
- while (my $next = shift @inlist) {
- push @outlist, $next;
- no strict 'refs';
- unshift @inlist, @{"$outlist[-1]::ISA"};
- }
- return @outlist;
-}
-
-sub NEXT::ELSEWHERE::ordered_ancestors
-{
- my @inlist = shift;
- my @outlist = ();
- while (my $next = shift @inlist) {
- push @outlist, $next;
- no strict 'refs';
- push @inlist, @{"$outlist[-1]::ISA"};
- }
- return sort { $a->isa($b) ? -1
- : $b->isa($a) ? +1
- : 0 } @outlist;
-}
-
-sub NEXT::ELSEWHERE::buildAUTOLOAD
-{
- my $autoload_name = caller() . '::AUTOLOAD';
-
- no strict 'refs';
- *{$autoload_name} = sub {
- my ($self) = @_;
- my $depth = 1;
- until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
- my $caller = (caller($depth))[3];
- my $wanted = $NEXT::AUTOLOAD || $autoload_name;
- undef $NEXT::AUTOLOAD;
- my ($caller_class, $caller_method) = do { $caller =~ m{(.*)::(.*)}g };
- my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
- croak "Can't call $wanted from $caller"
- unless $caller_method eq $wanted_method;
-
- my $key = ref $self && overload::Overloaded($self)
- ? overload::StrVal($self) : $self;
-
- local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) =
- ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN);
-
- unless ($NEXT::NEXT{$key,$wanted_method}) {
- my @forebears =
- NEXT::ELSEWHERE::ancestors ref $self || $self,
- $wanted_class;
- while (@forebears) {
- last if shift @forebears eq $caller_class
- }
- no strict 'refs';
- @{$NEXT::NEXT{$key,$wanted_method}} =
- map {
- my $stash = \%{"${_}::"};
- ($stash->{$caller_method} && (*{$stash->{$caller_method}}{CODE}))
- ? *{$stash->{$caller_method}}{CODE}
- : () } @forebears
- unless $wanted_method eq 'AUTOLOAD';
- @{$NEXT::NEXT{$key,$wanted_method}} =
- map {
- my $stash = \%{"${_}::"};
- ($stash->{AUTOLOAD} && (*{$stash->{AUTOLOAD}}{CODE}))
- ? "${_}::AUTOLOAD"
- : () } @forebears
- unless @{$NEXT::NEXT{$key,$wanted_method}||[]};
- $NEXT::SEEN->{$key,*{$caller}{CODE}}++;
- }
- my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
- while (do { $wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/ }
- && defined $call_method
- && $NEXT::SEEN->{$key,$call_method}++) {
- $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
- }
- unless (defined $call_method) {
- return unless do { $wanted_class =~ /^NEXT:.*:ACTUAL/ };
- (local $Carp::CarpLevel)++;
- croak qq(Can't locate object method "$wanted_method" ),
- qq(via package "$caller_class");
- };
- return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
- no strict 'refs';
- do { ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*::// }
- if $wanted_method eq 'AUTOLOAD';
- $$call_method = $caller_class."::NEXT::".$wanted_method;
- return $call_method->(@_);
- };
-}
-
-no strict 'vars';
-package NEXT; NEXT::ELSEWHERE::buildAUTOLOAD();
-package NEXT::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
-package NEXT::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
-package NEXT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
-package NEXT::ACTUAL::UNSEEN; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
-package NEXT::ACTUAL::DISTINCT; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
-package NEXT::UNSEEN::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
-package NEXT::DISTINCT::ACTUAL; @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
-
-package EVERY;
-
-sub EVERY::ELSEWHERE::buildAUTOLOAD {
- my $autoload_name = caller() . '::AUTOLOAD';
-
- no strict 'refs';
- *{$autoload_name} = sub {
- my ($self) = @_;
- my $depth = 1;
- until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
- my $caller = (caller($depth))[3];
- my $wanted = $EVERY::AUTOLOAD || $autoload_name;
- undef $EVERY::AUTOLOAD;
- my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
-
- my $key = ref($self) && overload::Overloaded($self)
- ? overload::StrVal($self) : $self;
-
- local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} =
- $NEXT::ALREADY_IN_EVERY{$key,$wanted_method};
-
- return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++;
-
- my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
- $wanted_class;
- @forebears = reverse @forebears if do { $wanted_class =~ /\bLAST\b/ };
- no strict 'refs';
- my %seen;
- my @every = map { my $sub = "${_}::$wanted_method";
- !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
- } @forebears
- unless $wanted_method eq 'AUTOLOAD';
-
- my $want = wantarray;
- if (@every) {
- if ($want) {
- return map {($_, [$self->$_(@_[1..$#_])])} @every;
- }
- elsif (defined $want) {
- return { map {($_, scalar($self->$_(@_[1..$#_])))}
- @every
- };
- }
- else {
- $self->$_(@_[1..$#_]) for @every;
- return;
- }
- }
-
- @every = map { my $sub = "${_}::AUTOLOAD";
- !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
- } @forebears;
- if ($want) {
- return map { $$_ = ref($self)."::EVERY::".$wanted_method;
- ($_, [$self->$_(@_[1..$#_])]);
- } @every;
- }
- elsif (defined $want) {
- return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
- ($_, scalar($self->$_(@_[1..$#_])))
- } @every
- };
- }
- else {
- for (@every) {
- $$_ = ref($self)."::EVERY::".$wanted_method;
- $self->$_(@_[1..$#_]);
- }
- return;
- }
- };
-}
-
-package EVERY::LAST; @ISA = 'EVERY'; EVERY::ELSEWHERE::buildAUTOLOAD();
-package EVERY; @ISA = 'NEXT'; EVERY::ELSEWHERE::buildAUTOLOAD();
-
-1;
-
-__END__
-
-=head1 NAME
-
-NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
-
-
-=head1 SYNOPSIS
-
- use NEXT;
-
- package A;
- sub A::method { print "$_[0]: A method\n"; $_[0]->NEXT::method() }
- sub A::DESTROY { print "$_[0]: A dtor\n"; $_[0]->NEXT::DESTROY() }
-
- package B;
- use base qw( A );
- sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub B::DESTROY { print "$_[0]: B dtor\n"; $_[0]->NEXT::DESTROY() }
-
- package C;
- sub C::method { print "$_[0]: C method\n"; $_[0]->NEXT::method() }
- sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub C::DESTROY { print "$_[0]: C dtor\n"; $_[0]->NEXT::DESTROY() }
-
- package D;
- use base qw( B C );
- sub D::method { print "$_[0]: D method\n"; $_[0]->NEXT::method() }
- sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
- sub D::DESTROY { print "$_[0]: D dtor\n"; $_[0]->NEXT::DESTROY() }
-
- package main;
-
- my $obj = bless {}, "D";
-
- $obj->method(); # Calls D::method, A::method, C::method
- $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
-
- # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
-
-
-
-=head1 DESCRIPTION
-
-NEXT.pm adds a pseudoclass named C<NEXT> to any program
-that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
-C<m> is redispatched as if the calling method had not originally been found.
-
-In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
-left-to-right search of C<$self>'s class hierarchy that resulted in the
-original call to C<m>.
-
-Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
-begins a new dispatch that is restricted to searching the ancestors
-of the current class. C<$self-E<gt>NEXT::m()> can backtrack
-past the current class -- to look for a suitable method in other
-ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
-
-A typical use would be in the destructors of a class hierarchy,
-as illustrated in the synopsis above. Each class in the hierarchy
-has a DESTROY method that performs some class-specific action
-and then redispatches the call up the hierarchy. As a result,
-when an object of class D is destroyed, the destructors of I<all>
-its parent classes are called (in depth-first, left-to-right order).
-
-Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
-If such a method determined that it was not able to handle a
-particular call, it might choose to redispatch that call, in the
-hope that some other C<AUTOLOAD> (above it, or to its left) might
-do better.
-
-By default, if a redispatch attempt fails to find another method
-elsewhere in the objects class hierarchy, it quietly gives up and does
-nothing (but see L<"Enforcing redispatch">). This gracious acquiescence
-is also unlike the (generally annoying) behaviour of C<SUPER>, which
-throws an exception if it cannot redispatch.
-
-Note that it is a fatal error for any method (including C<AUTOLOAD>)
-to attempt to redispatch any method that does not have the
-same name. For example:
-
- sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
-
-
-=head2 Enforcing redispatch
-
-It is possible to make C<NEXT> redispatch more demandingly (i.e. like
-C<SUPER> does), so that the redispatch throws an exception if it cannot
-find a "next" method to call.
-
-To do this, simple invoke the redispatch as:
-
- $self->NEXT::ACTUAL::method();
-
-rather than:
-
- $self->NEXT::method();
-
-The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
-or it should throw an exception.
-
-C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
-decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure
-semantics:
-
- sub AUTOLOAD {
- if ($AUTOLOAD =~ /foo|bar/) {
- # handle here
- }
- else { # try elsewhere
- shift()->NEXT::ACTUAL::AUTOLOAD(@_);
- }
- }
-
-By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
-method call, an exception will be thrown (as usually happens in the absence of
-a suitable C<AUTOLOAD>).
-
-
-=head2 Avoiding repetitions
-
-If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
-
- # A B
- # / \ /
- # C D
- # \ /
- # E
-
- use NEXT;
-
- package A;
- sub foo { print "called A::foo\n"; shift->NEXT::foo() }
-
- package B;
- sub foo { print "called B::foo\n"; shift->NEXT::foo() }
-
- package C; @ISA = qw( A );
- sub foo { print "called C::foo\n"; shift->NEXT::foo() }
-
- package D; @ISA = qw(A B);
- sub foo { print "called D::foo\n"; shift->NEXT::foo() }
-
- package E; @ISA = qw(C D);
- sub foo { print "called E::foo\n"; shift->NEXT::foo() }
-
- E->foo();
-
-then derived classes may (re-)inherit base-class methods through two or
-more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
-through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
-will invoke the multiply inherited method as many times as it is
-inherited. For example, the above code prints:
-
- called E::foo
- called C::foo
- called A::foo
- called D::foo
- called A::foo
- called B::foo
-
-(i.e. C<A::foo> is called twice).
-
-In some cases this I<may> be the desired effect within a diamond hierarchy,
-but in others (e.g. for destructors) it may be more appropriate to
-call each method only once during a sequence of redispatches.
-
-To cover such cases, you can redispatch methods via:
-
- $self->NEXT::DISTINCT::method();
-
-rather than:
-
- $self->NEXT::method();
-
-This causes the redispatcher to only visit each distinct C<method> method
-once. That is, to skip any classes in the hierarchy that it has
-already visited during redispatch. So, for example, if the
-previous example were rewritten:
-
- package A;
- sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
-
- package B;
- sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
-
- package C; @ISA = qw( A );
- sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
-
- package D; @ISA = qw(A B);
- sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
-
- package E; @ISA = qw(C D);
- sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
-
- E->foo();
-
-then it would print:
-
- called E::foo
- called C::foo
- called A::foo
- called D::foo
- called B::foo
-
-and omit the second call to C<A::foo> (since it would not be distinct
-from the first call to C<A::foo>).
-
-Note that you can also use:
-
- $self->NEXT::DISTINCT::ACTUAL::method();
-
-or:
-
- $self->NEXT::ACTUAL::DISTINCT::method();
-
-to get both unique invocation I<and> exception-on-failure.
-
-Note that, for historical compatibility, you can also use
-C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
-
-
-=head2 Invoking all versions of a method with a single call
-
-Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
-Its behaviour is considerably simpler than that of the C<NEXT> family.
-A call to:
-
- $obj->EVERY::foo();
-
-calls I<every> method named C<foo> that the object in C<$obj> has inherited.
-That is:
-
- use NEXT;
-
- package A; @ISA = qw(B D X);
- sub foo { print "A::foo " }
-
- package B; @ISA = qw(D X);
- sub foo { print "B::foo " }
-
- package X; @ISA = qw(D);
- sub foo { print "X::foo " }
-
- package D;
- sub foo { print "D::foo " }
-
- package main;
-
- my $obj = bless {}, 'A';
- $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
-
-Prefixing a method call with C<EVERY::> causes every method in the
-object's hierarchy with that name to be invoked. As the above example
-illustrates, they are not called in Perl's usual "left-most-depth-first"
-order. Instead, they are called "breadth-first-dependency-wise".
-
-That means that the inheritance tree of the object is traversed breadth-first
-and the resulting order of classes is used as the sequence in which methods
-are called. However, that sequence is modified by imposing a rule that the
-appropriate method of a derived class must be called before the same method of
-any ancestral class. That's why, in the above example, C<X::foo> is called
-before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
-
-In general, there's no need to worry about the order of calls. They will be
-left-to-right, breadth-first, most-derived-first. This works perfectly for
-most inherited methods (including destructors), but is inappropriate for
-some kinds of methods (such as constructors, cloners, debuggers, and
-initializers) where it's more appropriate that the least-derived methods be
-called first (as more-derived methods may rely on the behaviour of their
-"ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
-
- $obj->EVERY::foo(); # prints" A::foo B::foo X::foo D::foo
-
-you can use the C<EVERY::LAST> pseudo-class:
-
- $obj->EVERY::LAST::foo(); # prints" D::foo X::foo B::foo A::foo
-
-which reverses the order of method call.
-
-Whichever version is used, the actual methods are called in the same
-context (list, scalar, or void) as the original call via C<EVERY>, and return:
-
-=over
-
-=item *
-
-A hash of array references in list context. Each entry of the hash has the
-fully qualified method name as its key and a reference to an array containing
-the method's list-context return values as its value.
-
-=item *
-
-A reference to a hash of scalar values in scalar context. Each entry of the hash has the
-fully qualified method name as its key and the method's scalar-context return values as its value.
-
-=item *
-
-Nothing in void context (obviously).
-
-=back
-
-=head2 Using C<EVERY> methods
-
-The typical way to use an C<EVERY> call is to wrap it in another base
-method, that all classes inherit. For example, to ensure that every
-destructor an object inherits is actually called (as opposed to just the
-left-most-depth-first-est one):
-
- package Base;
- sub DESTROY { $_[0]->EVERY::Destroy }
-
- package Derived1;
- use base 'Base';
- sub Destroy {...}
-
- package Derived2;
- use base 'Base', 'Derived1';
- sub Destroy {...}
-
-et cetera. Every derived class than needs its own clean-up
-behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
-which the call to C<EVERY::LAST::Destroy> in the inherited destructor
-then correctly picks up.
-
-Likewise, to create a class hierarchy in which every initializer inherited by
-a new object is invoked:
-
- package Base;
- sub new {
- my ($class, %args) = @_;
- my $obj = bless {}, $class;
- $obj->EVERY::LAST::Init(\%args);
- }
-
- package Derived1;
- use base 'Base';
- sub Init {
- my ($argsref) = @_;
- ...
- }
-
- package Derived2;
- use base 'Base', 'Derived1';
- sub Init {
- my ($argsref) = @_;
- ...
- }
-
-et cetera. Every derived class than needs some additional initialization
-behaviour simply adds its own C<Init> method (I<not> a C<new> method),
-which the call to C<EVERY::LAST::Init> in the inherited constructor
-then correctly picks up.
-
-
-=head1 AUTHOR
-
-Damian Conway (damian at conway.org)
-
-=head1 BUGS AND IRRITATIONS
-
-Because it's a module, not an integral part of the interpreter, NEXT.pm
-has to guess where the surrounding call was found in the method
-look-up sequence. In the presence of diamond inheritance patterns
-it occasionally guesses wrong.
-
-It's also too slow (despite caching).
-
-Comment, suggestions, and patches welcome.
-
-=head1 COPYRIGHT
-
- Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
- This module is free software. It may be used, redistributed
- and/or modified under the same terms as Perl itself.
Deleted: trunk/contrib/perl/lib/Net/Cmd.pm
===================================================================
--- trunk/contrib/perl/lib/Net/Cmd.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/Cmd.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,783 +0,0 @@
-# Net::Cmd.pm
-#
-# Copyright (c) 1995-2006 Graham Barr <gbarr at pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Cmd;
-
-require 5.001;
-require Exporter;
-
-use strict;
-use vars qw(@ISA @EXPORT $VERSION);
-use Carp;
-use Symbol 'gensym';
-
-BEGIN {
- if ($^O eq 'os390') {
- require Convert::EBCDIC;
-
- # Convert::EBCDIC->import;
- }
-}
-
-BEGIN {
- if (!eval { require utf8 }) {
- *is_utf8 = sub { 0 };
- }
- elsif (eval { utf8::is_utf8(undef); 1 }) {
- *is_utf8 = \&utf8::is_utf8;
- }
- elsif (eval { require Encode; Encode::is_utf8(undef); 1 }) {
- *is_utf8 = \&Encode::is_utf8;
- }
- else {
- *is_utf8 = sub { $_[0] =~ /[^\x00-\xff]/ };
- }
-}
-
-$VERSION = "2.29";
- at ISA = qw(Exporter);
- at EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);
-
-
-sub CMD_INFO {1}
-sub CMD_OK {2}
-sub CMD_MORE {3}
-sub CMD_REJECT {4}
-sub CMD_ERROR {5}
-sub CMD_PENDING {0}
-
-my %debug = ();
-
-my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef;
-
-
-sub toebcdic {
- my $cmd = shift;
-
- unless (exists ${*$cmd}{'net_cmd_asciipeer'}) {
- my $string = $_[0];
- my $ebcdicstr = $tr->toebcdic($string);
- ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/;
- }
-
- ${*$cmd}{'net_cmd_asciipeer'}
- ? $tr->toebcdic($_[0])
- : $_[0];
-}
-
-
-sub toascii {
- my $cmd = shift;
- ${*$cmd}{'net_cmd_asciipeer'}
- ? $tr->toascii($_[0])
- : $_[0];
-}
-
-
-sub _print_isa {
- no strict qw(refs);
-
- my $pkg = shift;
- my $cmd = $pkg;
-
- $debug{$pkg} ||= 0;
-
- my %done = ();
- my @do = ($pkg);
- my %spc = ($pkg, "");
-
- while ($pkg = shift @do) {
- next if defined $done{$pkg};
-
- $done{$pkg} = 1;
-
- my $v =
- defined ${"${pkg}::VERSION"}
- ? "(" . ${"${pkg}::VERSION"} . ")"
- : "";
-
- my $spc = $spc{$pkg};
- $cmd->debug_print(1, "${spc}${pkg}${v}\n");
-
- if (@{"${pkg}::ISA"}) {
- @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"};
- unshift(@do, @{"${pkg}::ISA"});
- }
- }
-}
-
-
-sub debug {
- @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';
-
- my ($cmd, $level) = @_;
- my $pkg = ref($cmd) || $cmd;
- my $oldval = 0;
-
- if (ref($cmd)) {
- $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
- }
- else {
- $oldval = $debug{$pkg} || 0;
- }
-
- return $oldval
- unless @_ == 2;
-
- $level = $debug{$pkg} || 0
- unless defined $level;
-
- _print_isa($pkg)
- if ($level && !exists $debug{$pkg});
-
- if (ref($cmd)) {
- ${*$cmd}{'net_cmd_debug'} = $level;
- }
- else {
- $debug{$pkg} = $level;
- }
-
- $oldval;
-}
-
-
-sub message {
- @_ == 1 or croak 'usage: $obj->message()';
-
- my $cmd = shift;
-
- wantarray
- ? @{${*$cmd}{'net_cmd_resp'}}
- : join("", @{${*$cmd}{'net_cmd_resp'}});
-}
-
-
-sub debug_text { $_[2] }
-
-
-sub debug_print {
- my ($cmd, $out, $text) = @_;
- print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text);
-}
-
-
-sub code {
- @_ == 1 or croak 'usage: $obj->code()';
-
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_code'} = "000"
- unless exists ${*$cmd}{'net_cmd_code'};
-
- ${*$cmd}{'net_cmd_code'};
-}
-
-
-sub status {
- @_ == 1 or croak 'usage: $obj->status()';
-
- my $cmd = shift;
-
- substr(${*$cmd}{'net_cmd_code'}, 0, 1);
-}
-
-
-sub set_status {
- @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';
-
- my $cmd = shift;
- my ($code, $resp) = @_;
-
- $resp = [$resp]
- unless ref($resp);
-
- (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp);
-
- 1;
-}
-
-
-sub command {
- my $cmd = shift;
-
- unless (defined fileno($cmd)) {
- $cmd->set_status("599", "Connection closed");
- return $cmd;
- }
-
-
- $cmd->dataend()
- if (exists ${*$cmd}{'net_cmd_last_ch'});
-
- if (scalar(@_)) {
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- my $str = join(
- " ",
- map {
- /\n/
- ? do { my $n = $_; $n =~ tr/\n/ /; $n }
- : $_;
- } @_
- );
- $str = $cmd->toascii($str) if $tr;
- $str .= "\015\012";
-
- my $len = length $str;
- my $swlen;
-
- $cmd->close
- unless (defined($swlen = syswrite($cmd, $str, $len)) && $swlen == $len);
-
- $cmd->debug_print(1, $str)
- if ($cmd->debug);
-
- ${*$cmd}{'net_cmd_resp'} = []; # the response
- ${*$cmd}{'net_cmd_code'} = "000"; # Made this one up :-)
- }
-
- $cmd;
-}
-
-
-sub ok {
- @_ == 1 or croak 'usage: $obj->ok()';
-
- my $code = $_[0]->code;
- 0 < $code && $code < 400;
-}
-
-
-sub unsupported {
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_resp'} = ['Unsupported command'];
- ${*$cmd}{'net_cmd_code'} = 580;
- 0;
-}
-
-
-sub getline {
- my $cmd = shift;
-
- ${*$cmd}{'net_cmd_lines'} ||= [];
-
- return shift @{${*$cmd}{'net_cmd_lines'}}
- if scalar(@{${*$cmd}{'net_cmd_lines'}});
-
- my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : "";
- my $fd = fileno($cmd);
-
- return undef
- unless defined $fd;
-
- my $rin = "";
- vec($rin, $fd, 1) = 1;
-
- my $buf;
-
- until (scalar(@{${*$cmd}{'net_cmd_lines'}})) {
- my $timeout = $cmd->timeout || undef;
- my $rout;
-
- my $select_ret = select($rout = $rin, undef, undef, $timeout);
- if ($select_ret > 0) {
- unless (sysread($cmd, $buf = "", 1024)) {
- carp(ref($cmd) . ": Unexpected EOF on command channel")
- if $cmd->debug;
- $cmd->close;
- return undef;
- }
-
- substr($buf, 0, 0) = $partial; ## prepend from last sysread
-
- my @buf = split(/\015?\012/, $buf, -1); ## break into lines
-
- $partial = pop @buf;
-
- push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf);
-
- }
- else {
- my $msg = $select_ret ? "Error or Interrupted: $!" : "Timeout";
- carp("$cmd: $msg") if ($cmd->debug);
- return undef;
- }
- }
-
- ${*$cmd}{'net_cmd_partial'} = $partial;
-
- if ($tr) {
- foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) {
- $ln = $cmd->toebcdic($ln);
- }
- }
-
- shift @{${*$cmd}{'net_cmd_lines'}};
-}
-
-
-sub ungetline {
- my ($cmd, $str) = @_;
-
- ${*$cmd}{'net_cmd_lines'} ||= [];
- unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
-}
-
-
-sub parse_response {
- return ()
- unless $_[1] =~ s/^(\d\d\d)(.?)//o;
- ($1, $2 eq "-");
-}
-
-
-sub response {
- my $cmd = shift;
- my ($code, $more) = (undef) x 2;
-
- ${*$cmd}{'net_cmd_resp'} ||= [];
-
- while (1) {
- my $str = $cmd->getline();
-
- return CMD_ERROR
- unless defined($str);
-
- $cmd->debug_print(0, $str)
- if ($cmd->debug);
-
- ($code, $more) = $cmd->parse_response($str);
- unless (defined $code) {
- $cmd->ungetline($str);
- last;
- }
-
- ${*$cmd}{'net_cmd_code'} = $code;
-
- push(@{${*$cmd}{'net_cmd_resp'}}, $str);
-
- last unless ($more);
- }
-
- substr($code, 0, 1);
-}
-
-
-sub read_until_dot {
- my $cmd = shift;
- my $fh = shift;
- my $arr = [];
-
- while (1) {
- my $str = $cmd->getline() or return undef;
-
- $cmd->debug_print(0, $str)
- if ($cmd->debug & 4);
-
- last if ($str =~ /^\.\r?\n/o);
-
- $str =~ s/^\.\././o;
-
- if (defined $fh) {
- print $fh $str;
- }
- else {
- push(@$arr, $str);
- }
- }
-
- $arr;
-}
-
-
-sub datasend {
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("", @$arr);
-
- # encode to individual utf8 bytes if
- # $line is a string (in internal UTF-8)
- utf8::encode($line) if is_utf8($line);
-
- return 0 unless defined(fileno($cmd));
-
- my $last_ch = ${*$cmd}{'net_cmd_last_ch'};
- $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch;
-
- return 1 unless length $line;
-
- if ($cmd->debug) {
- foreach my $b (split(/\n/, $line)) {
- $cmd->debug_print(1, "$b\n");
- }
- }
-
- $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015";
-
- my $first_ch = '';
-
- if ($last_ch eq "\015") {
- $first_ch = "\012" if $line =~ s/^\012//;
- }
- elsif ($last_ch eq "\012") {
- $first_ch = "." if $line =~ /^\./;
- }
-
- $line =~ s/\015?\012(\.?)/\015\012$1$1/sg;
-
- substr($line, 0, 0) = $first_ch;
-
- ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1);
-
- my $len = length($line);
- my $offset = 0;
- my $win = "";
- vec($win, fileno($cmd), 1) = 1;
- my $timeout = $cmd->timeout || undef;
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- while ($len) {
- my $wout;
- my $s = select(undef, $wout = $win, undef, $timeout);
- if ((defined $s and $s > 0) or -f $cmd) # -f for testing on win32
- {
- my $w = syswrite($cmd, $line, $len, $offset);
- unless (defined($w)) {
- carp("$cmd: $!") if $cmd->debug;
- return undef;
- }
- $len -= $w;
- $offset += $w;
- }
- else {
- carp("$cmd: Timeout") if ($cmd->debug);
- return undef;
- }
- }
-
- 1;
-}
-
-
-sub rawdatasend {
- my $cmd = shift;
- my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
- my $line = join("", @$arr);
-
- return 0 unless defined(fileno($cmd));
-
- return 1
- unless length($line);
-
- if ($cmd->debug) {
- my $b = "$cmd>>> ";
- print STDERR $b, join("\n$b", split(/\n/, $line)), "\n";
- }
-
- my $len = length($line);
- my $offset = 0;
- my $win = "";
- vec($win, fileno($cmd), 1) = 1;
- my $timeout = $cmd->timeout || undef;
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
- while ($len) {
- my $wout;
- if (select(undef, $wout = $win, undef, $timeout) > 0) {
- my $w = syswrite($cmd, $line, $len, $offset);
- unless (defined($w)) {
- carp("$cmd: $!") if $cmd->debug;
- return undef;
- }
- $len -= $w;
- $offset += $w;
- }
- else {
- carp("$cmd: Timeout") if ($cmd->debug);
- return undef;
- }
- }
-
- 1;
-}
-
-
-sub dataend {
- my $cmd = shift;
-
- return 0 unless defined(fileno($cmd));
-
- my $ch = ${*$cmd}{'net_cmd_last_ch'};
- my $tosend;
-
- if (!defined $ch) {
- return 1;
- }
- elsif ($ch ne "\012") {
- $tosend = "\015\012";
- }
-
- $tosend .= ".\015\012";
-
- local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS';
-
- $cmd->debug_print(1, ".\n")
- if ($cmd->debug);
-
- syswrite($cmd, $tosend, length $tosend);
-
- delete ${*$cmd}{'net_cmd_last_ch'};
-
- $cmd->response() == CMD_OK;
-}
-
-# read and write to tied filehandle
-sub tied_fh {
- my $cmd = shift;
- ${*$cmd}{'net_cmd_readbuf'} = '';
- my $fh = gensym();
- tie *$fh, ref($cmd), $cmd;
- return $fh;
-}
-
-# tie to myself
-sub TIEHANDLE {
- my $class = shift;
- my $cmd = shift;
- return $cmd;
-}
-
-# Tied filehandle read. Reads requested data length, returning
-# end-of-file when the dot is encountered.
-sub READ {
- my $cmd = shift;
- my ($len, $offset) = @_[1, 2];
- return unless exists ${*$cmd}{'net_cmd_readbuf'};
- my $done = 0;
- while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) {
- ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return;
- $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m;
- }
-
- $_[0] = '';
- substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len);
- substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = '';
- delete ${*$cmd}{'net_cmd_readbuf'} if $done;
-
- return length $_[0];
-}
-
-
-sub READLINE {
- my $cmd = shift;
-
- # in this context, we use the presence of readbuf to
- # indicate that we have not yet reached the eof
- return unless exists ${*$cmd}{'net_cmd_readbuf'};
- my $line = $cmd->getline;
- return if $line =~ /^\.\r?\n/;
- $line;
-}
-
-
-sub PRINT {
- my $cmd = shift;
- my ($buf, $len, $offset) = @_;
- $len ||= length($buf);
- $offset += 0;
- return unless $cmd->datasend(substr($buf, $offset, $len));
- ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend()
- return $len;
-}
-
-
-sub CLOSE {
- my $cmd = shift;
- my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1;
- delete ${*$cmd}{'net_cmd_readbuf'};
- delete ${*$cmd}{'net_cmd_sending'};
- $r;
-}
-
-1;
-
-__END__
-
-
-=head1 NAME
-
-Net::Cmd - Network Command class (as used by FTP, SMTP etc)
-
-=head1 SYNOPSIS
-
- use Net::Cmd;
-
- @ISA = qw(Net::Cmd);
-
-=head1 DESCRIPTION
-
-C<Net::Cmd> is a collection of methods that can be inherited by a sub class
-of C<IO::Handle>. These methods implement the functionality required for a
-command based protocol, for example FTP and SMTP.
-
-=head1 USER METHODS
-
-These methods provide a user interface to the C<Net::Cmd> object.
-
-=over 4
-
-=item debug ( VALUE )
-
-Set the level of debug information for this object. If C<VALUE> is not given
-then the current state is returned. Otherwise the state is changed to
-C<VALUE> and the previous state returned.
-
-Different packages
-may implement different levels of debug but a non-zero value results in
-copies of all commands and responses also being sent to STDERR.
-
-If C<VALUE> is C<undef> then the debug level will be set to the default
-debug level for the class.
-
-This method can also be called as a I<static> method to set/get the default
-debug level for a given class.
-
-=item message ()
-
-Returns the text message returned from the last command
-
-=item code ()
-
-Returns the 3-digit code from the last command. If a command is pending
-then the value 0 is returned
-
-=item ok ()
-
-Returns non-zero if the last code value was greater than zero and
-less than 400. This holds true for most command servers. Servers
-where this does not hold may override this method.
-
-=item status ()
-
-Returns the most significant digit of the current status code. If a command
-is pending then C<CMD_PENDING> is returned.
-
-=item datasend ( DATA )
-
-Send data to the remote server, converting LF to CRLF. Any line starting
-with a '.' will be prefixed with another '.'.
-C<DATA> may be an array or a reference to an array.
-
-=item dataend ()
-
-End the sending of data to the remote server. This is done by ensuring that
-the data already sent ends with CRLF then sending '.CRLF' to end the
-transmission. Once this data has been sent C<dataend> calls C<response> and
-returns true if C<response> returns CMD_OK.
-
-=back
-
-=head1 CLASS METHODS
-
-These methods are not intended to be called by the user, but used or
-over-ridden by a sub-class of C<Net::Cmd>
-
-=over 4
-
-=item debug_print ( DIR, TEXT )
-
-Print debugging information. C<DIR> denotes the direction I<true> being
-data being sent to the server. Calls C<debug_text> before printing to
-STDERR.
-
-=item debug_text ( TEXT )
-
-This method is called to print debugging information. TEXT is
-the text being sent. The method should return the text to be printed
-
-This is primarily meant for the use of modules such as FTP where passwords
-are sent, but we do not want to display them in the debugging information.
-
-=item command ( CMD [, ARGS, ... ])
-
-Send a command to the command server. All arguments a first joined with
-a space character and CRLF is appended, this string is then sent to the
-command server.
-
-Returns undef upon failure
-
-=item unsupported ()
-
-Sets the status code to 580 and the response text to 'Unsupported command'.
-Returns zero.
-
-=item response ()
-
-Obtain a response from the server. Upon success the most significant digit
-of the status code is returned. Upon failure, timeout etc., I<undef> is
-returned.
-
-=item parse_response ( TEXT )
-
-This method is called by C<response> as a method with one argument. It should
-return an array of 2 values, the 3-digit status code and a flag which is true
-when this is part of a multi-line response and this line is not the list.
-
-=item getline ()
-
-Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
-upon failure.
-
-B<NOTE>: If you do use this method for any reason, please remember to add
-some C<debug_print> calls into your method.
-
-=item ungetline ( TEXT )
-
-Unget a line of text from the server.
-
-=item rawdatasend ( DATA )
-
-Send data to the remote server without performing any conversions. C<DATA>
-is a scalar.
-
-=item read_until_dot ()
-
-Read data from the remote server until a line consisting of a single '.'.
-Any lines starting with '..' will have one of the '.'s removed.
-
-Returns a reference to a list containing the lines, or I<undef> upon failure.
-
-=item tied_fh ()
-
-Returns a filehandle tied to the Net::Cmd object. After issuing a
-command, you may read from this filehandle using read() or <>. The
-filehandle will return EOF when the final dot is encountered.
-Similarly, you may write to the filehandle in order to send data to
-the server after issuing a command that expects data to be written.
-
-See the Net::POP3 and Net::SMTP modules for examples of this.
-
-=back
-
-=head1 EXPORTS
-
-C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
-C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR>, correspond to possible results
-of C<response> and C<status>. The sixth is C<CMD_PENDING>.
-
-=head1 AUTHOR
-
-Graham Barr <gbarr at pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2006 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/Config.eg
===================================================================
--- trunk/contrib/perl/lib/Net/Config.eg 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/Config.eg 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,49 +0,0 @@
-package Net::Config;
-
-require Exporter;
-use vars qw(@ISA @EXPORT %NetConfig);
-use strict;
-
- at EXPORT = qw(%NetConfig);
- at ISA = qw(Exporter);
-
-# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
-# WARNING WARNING WARNING WARNING WARNING WARNING WARNING
-#
-# Below this line is auto-generated, *ANY* changes will be lost
-
-%NetConfig = (
- # the followinf parameters are all lists of hosts for the
- # respective protocols.
- nntp_hosts => [],
- snpp_hosts => [],
- pop3_hosts => [],
- smtp_hosts => [],
- ph_hosts => [],
- daytime_hosts => [],
- time_hosts => [],
-
- # your internet domain
- inet_domain => undef,
-
- # If you have an ftp proxy firewall (not an http firewall)
- # then set this to the name of the firewall
- ftp_firewall => undef,
-
- # set if all connections done via the firewall should use
- # passive data connections
- ftp_ext_passive => 0,
-
- # set if all connections not done via the firewall should use
- # passive data connections
- ftp_int_passive => 0,
-
- # If set the make test will attempt to connect to the hosts above
- test_hosts => 0,
-
- # Used during Configure (which you are not using) to do
- # DNS lookups to ensure hosts exist
- test_exist => 0,
-
-);
-1;
Deleted: trunk/contrib/perl/lib/Net/Config.pm
===================================================================
--- trunk/contrib/perl/lib/Net/Config.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/Config.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,312 +0,0 @@
-# Net::Config.pm
-#
-# Copyright (c) 2000 Graham Barr <gbarr at pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Config;
-
-require Exporter;
-use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG);
-use Socket qw(inet_aton inet_ntoa);
-use strict;
-
- at EXPORT = qw(%NetConfig);
- at ISA = qw(Net::LocalCfg Exporter);
-$VERSION = "1.11";
-
-eval { local $SIG{__DIE__}; require Net::LocalCfg };
-
-%NetConfig = (
- nntp_hosts => [],
- snpp_hosts => [],
- pop3_hosts => [],
- smtp_hosts => [],
- ph_hosts => [],
- daytime_hosts => [],
- time_hosts => [],
- inet_domain => undef,
- ftp_firewall => undef,
- ftp_ext_passive => 1,
- ftp_int_passive => 1,
- test_hosts => 1,
- test_exist => 1,
-);
-
-#
-# Try to get as much configuration info as possible from InternetConfig
-#
-$^O eq 'MacOS' and eval <<TRY_INTERNET_CONFIG;
-use Mac::InternetConfig;
-
-{
-my %nc = (
- nntp_hosts => [ \$InternetConfig{ kICNNTPHost() } ],
- pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ],
- smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ],
- ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef,
- ph_hosts => [ \$InternetConfig{ kICPhHost() } ],
- ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
- ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0,
- socks_hosts =>
- \$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [],
- ftp_firewall =>
- \$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [],
-);
-\@NetConfig{keys %nc} = values %nc;
-}
-TRY_INTERNET_CONFIG
-
-my $file = __FILE__;
-my $ref;
-$file =~ s/Config.pm/libnet.cfg/;
-if (-f $file) {
- $ref = eval { local $SIG{__DIE__}; do $file };
- if (ref($ref) eq 'HASH') {
- %NetConfig = (%NetConfig, %{$ref});
- $LIBNET_CFG = $file;
- }
-}
-if ($< == $> and !$CONFIGURE) {
- my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
- if (defined $home) {
- $file = $home . "/.libnetrc";
- $ref = eval { local $SIG{__DIE__}; do $file } if -f $file;
- %NetConfig = (%NetConfig, %{$ref})
- if ref($ref) eq 'HASH';
- }
-}
-my ($k, $v);
-while (($k, $v) = each %NetConfig) {
- $NetConfig{$k} = [$v]
- if ($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v));
-}
-
-# Take a hostname and determine if it is inside the firewall
-
-
-sub requires_firewall {
- shift; # ignore package
- my $host = shift;
-
- return 0 unless defined $NetConfig{'ftp_firewall'};
-
- $host = inet_aton($host) or return -1;
- $host = inet_ntoa($host);
-
- if (exists $NetConfig{'local_netmask'}) {
- my $quad = unpack("N", pack("C*", split(/\./, $host)));
- my $list = $NetConfig{'local_netmask'};
- $list = [$list] unless ref($list);
- foreach (@$list) {
- my ($net, $bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
- my $mask = ~0 << (32 - $bits);
- my $addr = unpack("N", pack("C*", split(/\./, $net)));
-
- return 0 if (($addr & $mask) == ($quad & $mask));
- }
- return 1;
- }
-
- return 0;
-}
-
-use vars qw(*is_external);
-*is_external = \&requires_firewall;
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Config - Local configuration data for libnet
-
-=head1 SYNOPSYS
-
- use Net::Config qw(%NetConfig);
-
-=head1 DESCRIPTION
-
-C<Net::Config> holds configuration data for the modules in the libnet
-distribution. During installation you will be asked for these values.
-
-The configuration data is held globally in a file in the perl installation
-tree, but a user may override any of these values by providing their own. This
-can be done by having a C<.libnetrc> file in their home directory. This file
-should return a reference to a HASH containing the keys described below.
-For example
-
- # .libnetrc
- {
- nntp_hosts => [ "my_preferred_host" ],
- ph_hosts => [ "my_ph_server" ],
- }
- __END__
-
-=head1 METHODS
-
-C<Net::Config> defines the following methods. They are methods as they are
-invoked as class methods. This is because C<Net::Config> inherits from
-C<Net::LocalCfg> so you can override these methods if you want.
-
-=over 4
-
-=item requires_firewall HOST
-
-Attempts to determine if a given host is outside your firewall. Possible
-return values are.
-
- -1 Cannot lookup hostname
- 0 Host is inside firewall (or there is no ftp_firewall entry)
- 1 Host is outside the firewall
-
-This is done by using hostname lookup and the C<local_netmask> entry in
-the configuration data.
-
-=back
-
-=head1 NetConfig VALUES
-
-=over 4
-
-=item nntp_hosts
-
-=item snpp_hosts
-
-=item pop3_hosts
-
-=item smtp_hosts
-
-=item ph_hosts
-
-=item daytime_hosts
-
-=item time_hosts
-
-Each is a reference to an array of hostnames (in order of preference),
-which should be used for the given protocol
-
-=item inet_domain
-
-Your internet domain name
-
-=item ftp_firewall
-
-If you have an FTP proxy firewall (B<NOT> an HTTP or SOCKS firewall)
-then this value should be set to the firewall hostname. If your firewall
-does not listen to port 21, then this value should be set to
-C<"hostname:port"> (eg C<"hostname:99">)
-
-=item ftp_firewall_type
-
-There are many different ftp firewall products available. But unfortunately
-there is no standard for how to traverse a firewall. The list below shows the
-sequence of commands that Net::FTP will use
-
- user Username for remote host
- pass Password for remote host
- fwuser Username for firewall
- fwpass Password for firewall
- remote.host The hostname of the remote ftp server
-
-=over 4
-
-=item 0
-
-There is no firewall
-
-=item 1
-
- USER user at remote.host
- PASS pass
-
-=item 2
-
- USER fwuser
- PASS fwpass
- USER user at remote.host
- PASS pass
-
-=item 3
-
- USER fwuser
- PASS fwpass
- SITE remote.site
- USER user
- PASS pass
-
-=item 4
-
- USER fwuser
- PASS fwpass
- OPEN remote.site
- USER user
- PASS pass
-
-=item 5
-
- USER user at fwuser@remote.site
- PASS pass at fwpass
-
-=item 6
-
- USER fwuser at remote.site
- PASS fwpass
- USER user
- PASS pass
-
-=item 7
-
- USER user at remote.host
- PASS pass
- AUTH fwuser
- RESP fwpass
-
-=back
-
-=item ftp_ext_passive
-
-=item ftp_int_passive
-
-FTP servers can work in passive or active mode. Active mode is when
-you want to transfer data you have to tell the server the address and
-port to connect to. Passive mode is when the server provide the
-address and port and you establish the connection.
-
-With some firewalls active mode does not work as the server cannot
-connect to your machine (because you are behind a firewall) and the firewall
-does not re-write the command. In this case you should set C<ftp_ext_passive>
-to a I<true> value.
-
-Some servers are configured to only work in passive mode. If you have
-one of these you can force C<Net::FTP> to always transfer in passive
-mode; when not going via a firewall, by setting C<ftp_int_passive> to
-a I<true> value.
-
-=item local_netmask
-
-A reference to a list of netmask strings in the form C<"134.99.4.0/24">.
-These are used by the C<requires_firewall> function to determine if a given
-host is inside or outside your firewall.
-
-=back
-
-The following entries are used during installation & testing on the
-libnet package
-
-=over 4
-
-=item test_hosts
-
-If true then C<make test> may attempt to connect to hosts given in the
-configuration.
-
-=item test_exists
-
-If true then C<Configure> will check each hostname given that it exists
-
-=back
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/Domain.pm
===================================================================
--- trunk/contrib/perl/lib/Net/Domain.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/Domain.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,347 +0,0 @@
-# Net::Domain.pm
-#
-# Copyright (c) 1995-1998 Graham Barr <gbarr at pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Domain;
-
-require Exporter;
-
-use Carp;
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK);
-use Net::Config;
-
- at ISA = qw(Exporter);
- at EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);
-
-$VERSION = "2.20";
-
-my ($host, $domain, $fqdn) = (undef, undef, undef);
-
-# Try every conceivable way to get hostname.
-
-
-sub _hostname {
-
- # we already know it
- return $host
- if (defined $host);
-
- if ($^O eq 'MSWin32') {
- require Socket;
- my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost');
- while (@addr) {
- my $a = shift(@addr);
- $host = gethostbyaddr($a, Socket::AF_INET());
- last if defined $host;
- }
- if (defined($host) && index($host, '.') > 0) {
- $fqdn = $host;
- ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
- }
- elsif ($^O eq 'MacOS') {
- chomp($host = `hostname`);
- }
- elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard
- $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
- $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
- if (index($host, '.') > 0) {
- $fqdn = $host;
- ($host, $domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
- }
- return $host;
- }
- else {
- local $SIG{'__DIE__'};
-
- # syscall is preferred since it avoids tainting problems
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- defined(&main::SYS_gethostname);
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- defined(&main::SYS_gethostname);
- }
- and $host =
- (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- }
-
- # POSIX
- || eval {
- require POSIX;
- $host = (POSIX::uname())[1];
- }
-
- # trusty old hostname command
- || eval {
- chop($host = `(hostname) 2>/dev/null`); # BSD'ish
- }
-
- # sysV/POSIX uname command (may truncate)
- || eval {
- chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
- }
-
- # Apollo pre-SR10
- || eval { $host = (split(/[:\. ]/, `/com/host`, 6))[0]; }
-
- || eval { $host = ""; };
- }
-
- # remove garbage
- $host =~ s/[\0\r\n]+//go;
- $host =~ s/(\A\.+|\.+\Z)//go;
- $host =~ s/\.\.+/\./go;
-
- $host;
-}
-
-
-sub _hostdomain {
-
- # we already know it
- return $domain
- if (defined $domain);
-
- local $SIG{'__DIE__'};
-
- return $domain = $NetConfig{'inet_domain'}
- if defined $NetConfig{'inet_domain'};
-
- # try looking in /etc/resolv.conf
- # putting this here and assuming that it is correct, eliminates
- # calls to gethostbyname, and therefore DNS lookups. This helps
- # those on dialup systems.
-
- local *RES;
- local ($_);
-
- if (open(RES, "/etc/resolv.conf")) {
- while (<RES>) {
- $domain = $1
- if (/\A\s*(?:domain|search)\s+(\S+)/);
- }
- close(RES);
-
- return $domain
- if (defined $domain);
- }
-
- # just try hostname and system calls
-
- my $host = _hostname();
- my (@hosts);
-
- @hosts = ($host, "localhost");
-
- unless (defined($host) && $host =~ /\./) {
- my $dom = undef;
- eval {
- my $tmp = "\0" x 256; ## preload scalar
- eval {
- package main;
- require "syscall.ph";
- }
- || eval {
- package main;
- require "sys/syscall.ph";
- }
- and $dom =
- (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
- ? $tmp
- : undef;
- };
-
- if ($^O eq 'VMS') {
- $dom ||= $ENV{'TCPIP$INET_DOMAIN'}
- || $ENV{'UCX$INET_DOMAIN'};
- }
-
- chop($dom = `domainname 2>/dev/null`)
- unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32)/);
-
- if (defined $dom) {
- my @h = ();
- $dom =~ s/^\.+//;
- while (length($dom)) {
- push(@h, "$host.$dom");
- $dom =~ s/^[^.]+.+// or last;
- }
- unshift(@hosts, @h);
- }
- }
-
- # Attempt to locate FQDN
-
- foreach (grep { defined $_ } @hosts) {
- my @info = gethostbyname($_);
-
- next unless @info;
-
- # look at real name & aliases
- my $site;
- foreach $site ($info[0], split(/ /, $info[1])) {
- if (rindex($site, ".") > 0) {
-
- # Extract domain from FQDN
-
- ($domain = $site) =~ s/\A[^\.]+\.//;
- return $domain;
- }
- }
- }
-
- # Look for environment variable
-
- $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN};
-
- if (defined $domain) {
- $domain =~ s/[\r\n\0]+//g;
- $domain =~ s/(\A\.+|\.+\Z)//g;
- $domain =~ s/\.\.+/\./g;
- }
-
- $domain;
-}
-
-
-sub domainname {
-
- return $fqdn
- if (defined $fqdn);
-
- _hostname();
- _hostdomain();
-
- # Assumption: If the host name does not contain a period
- # and the domain name does, then assume that they are correct
- # this helps to eliminate calls to gethostbyname, and therefore
- # eleminate DNS lookups
-
- return $fqdn = $host . "." . $domain
- if (defined $host
- and defined $domain
- and $host !~ /\./
- and $domain =~ /\./);
-
- # For hosts that have no name, just an IP address
- return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/;
-
- my @host = defined $host ? split(/\./, $host) : ('localhost');
- my @domain = defined $domain ? split(/\./, $domain) : ();
- my @fqdn = ();
-
- # Determine from @host & @domain the FQDN
-
- my @d = @domain;
-
-LOOP:
- while (1) {
- my @h = @host;
- while (@h) {
- my $tmp = join(".", @h, @d);
- if ((gethostbyname($tmp))[0]) {
- @fqdn = (@h, @d);
- $fqdn = $tmp;
- last LOOP;
- }
- pop @h;
- }
- last unless shift @d;
- }
-
- if (@fqdn) {
- $host = shift @fqdn;
- until ((gethostbyname($host))[0]) {
- $host .= "." . shift @fqdn;
- }
- $domain = join(".", @fqdn);
- }
- else {
- undef $host;
- undef $domain;
- undef $fqdn;
- }
-
- $fqdn;
-}
-
-
-sub hostfqdn { domainname() }
-
-
-sub hostname {
- domainname()
- unless (defined $host);
- return $host;
-}
-
-
-sub hostdomain {
- domainname()
- unless (defined $domain);
- return $domain;
-}
-
-1; # Keep require happy
-
-__END__
-
-=head1 NAME
-
-Net::Domain - Attempt to evaluate the current host's internet name and domain
-
-=head1 SYNOPSIS
-
- use Net::Domain qw(hostname hostfqdn hostdomain domainname);
-
-=head1 DESCRIPTION
-
-Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
-of the current host. From this determine the host-name and the host-domain.
-
-Each of the functions will return I<undef> if the FQDN cannot be determined.
-
-=over 4
-
-=item hostfqdn ()
-
-Identify and return the FQDN of the current host.
-
-=item domainname ()
-
-An alias for hostfqdn ().
-
-=item hostname ()
-
-Returns the smallest part of the FQDN which can be used to identify the host.
-
-=item hostdomain ()
-
-Returns the remainder of the FQDN after the I<hostname> has been removed.
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr at pobox.com>.
-Adapted from Sys::Hostname by David Sundstrom <sunds at asictest.sc.ti.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/FTP.pm
===================================================================
--- trunk/contrib/perl/lib/Net/FTP.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/FTP.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1829 +0,0 @@
-# Net::FTP.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-#
-# Documentation (at end) improved 1996 by Nathan Torkington <gnat at frii.com>.
-
-package Net::FTP;
-
-require 5.001;
-
-use strict;
-use vars qw(@ISA $VERSION);
-use Carp;
-
-use Socket 1.3;
-use IO::Socket;
-use Time::Local;
-use Net::Cmd;
-use Net::Config;
-use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC);
-
-$VERSION = '2.77';
- at ISA = qw(Exporter Net::Cmd IO::Socket::INET);
-
-# Someday I will "use constant", when I am not bothered to much about
-# compatability with older releases of perl
-
-use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
-($TELNET_IAC, $TELNET_IP, $TELNET_DM) = (255, 244, 242);
-
-
-BEGIN {
-
- # make a constant so code is fast'ish
- my $is_os390 = $^O eq 'os390';
- *trEBCDIC = sub () {$is_os390}
-}
-
-
-sub new {
- my $pkg = shift;
- my ($peer, %arg);
- if (@_ % 2) {
- $peer = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $peer = delete $arg{Host};
- }
-
- my $host = $peer;
- my $fire = undef;
- my $fire_type = undef;
-
- if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) {
- $fire = $arg{Firewall}
- || $ENV{FTP_FIREWALL}
- || $NetConfig{ftp_firewall}
- || undef;
-
- if (defined $fire) {
- $peer = $fire;
- delete $arg{Port};
- $fire_type = $arg{FirewallType}
- || $ENV{FTP_FIREWALL_TYPE}
- || $NetConfig{firewall_type}
- || undef;
- }
- }
-
- my $ftp = $pkg->SUPER::new(
- PeerAddr => $peer,
- PeerPort => $arg{Port} || 'ftp(21)',
- LocalAddr => $arg{'LocalAddr'},
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- or return undef;
-
- ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname
- ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode
- ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240);
-
- ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'};
-
- ${*$ftp}{'net_ftp_firewall'} = $fire
- if (defined $fire);
- ${*$ftp}{'net_ftp_firewall_type'} = $fire_type
- if (defined $fire_type);
-
- ${*$ftp}{'net_ftp_passive'} =
- int exists $arg{Passive} ? $arg{Passive}
- : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE}
- : defined $fire ? $NetConfig{ftp_ext_passive}
- : $NetConfig{ftp_int_passive}; # Whew! :-)
-
- $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);
-
- $ftp->autoflush(1);
-
- $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($ftp->response() == CMD_OK) {
- $ftp->close();
- $@ = $ftp->message;
- undef $ftp;
- }
-
- $ftp;
-}
-
-##
-## User interface methods
-##
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_ftp_host'};
-}
-
-
-sub hash {
- my $ftp = shift; # self
-
- my ($h, $b) = @_;
- unless ($h) {
- delete ${*$ftp}{'net_ftp_hash'};
- return [\*STDERR, 0];
- }
- ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024);
- select((select($h), $| = 1)[0]);
- $b = 512 if $b < 512;
- ${*$ftp}{'net_ftp_hash'} = [$h, $b];
-}
-
-
-sub quit {
- my $ftp = shift;
-
- $ftp->_QUIT;
- $ftp->close;
-}
-
-
-sub DESTROY { }
-
-
-sub ascii { shift->type('A', @_); }
-sub binary { shift->type('I', @_); }
-
-
-sub ebcdic {
- carp "TYPE E is unsupported, shall default to I";
- shift->type('E', @_);
-}
-
-
-sub byte {
- carp "TYPE L is unsupported, shall default to I";
- shift->type('L', @_);
-}
-
-# Allow the user to send a command directly, BE CAREFUL !!
-
-
-sub quot {
- my $ftp = shift;
- my $cmd = shift;
-
- $ftp->command(uc $cmd, @_);
- $ftp->response();
-}
-
-
-sub site {
- my $ftp = shift;
-
- $ftp->command("SITE", @_);
- $ftp->response();
-}
-
-
-sub mdtm {
- my $ftp = shift;
- my $file = shift;
-
- # Server Y2K bug workaround
- #
- # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of
- # ("%d",tm.tm_year+1900). This results in an extra digit in the
- # string returned. To account for this we allow an optional extra
- # digit in the year. Then if the first two digits are 19 we use the
- # remainder, otherwise we subtract 1900 from the whole year.
-
- $ftp->_MDTM($file)
- && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900))
- : undef;
-}
-
-
-sub size {
- my $ftp = shift;
- my $file = shift;
- my $io;
- if ($ftp->supported("SIZE")) {
- return $ftp->_SIZE($file)
- ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0]
- : undef;
- }
- elsif ($ftp->supported("STAT")) {
- my @msg;
- return undef
- unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
- my $line;
- foreach $line (@msg) {
- return (split(/\s+/, $line))[4]
- if $line =~ /^[-rwxSsTt]{10}/;
- }
- }
- else {
- my @files = $ftp->dir($file);
- if (@files) {
- return (split(/\s+/, $1))[4]
- if $files[0] =~ /^([-rwxSsTt]{10}.*)$/;
- }
- }
- undef;
-}
-
-
-sub login {
- my ($ftp, $user, $pass, $acct) = @_;
- my ($ok, $ruser, $fwtype);
-
- unless (defined $user) {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});
-
- ($user, $pass, $acct) = $rc->lpa()
- if ($rc);
- }
-
- $user ||= "anonymous";
- $ruser = $user;
-
- $fwtype = ${*$ftp}{'net_ftp_firewall_type'}
- || $NetConfig{'ftp_firewall_type'}
- || 0;
-
- if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
- if ($fwtype == 1 || $fwtype == 7) {
- $user .= '@' . ${*$ftp}{'net_ftp_host'};
- }
- else {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
-
- my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : ();
-
- if ($fwtype == 5) {
- $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'});
- $pass = $pass . '@' . $fwpass;
- }
- else {
- if ($fwtype == 2) {
- $user .= '@' . ${*$ftp}{'net_ftp_host'};
- }
- elsif ($fwtype == 6) {
- $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
- }
-
- $ok = $ftp->_USER($fwuser);
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
-
- $ok = $ftp->_PASS($fwpass || "");
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
-
- $ok = $ftp->_ACCT($fwacct)
- if defined($fwacct);
-
- if ($fwtype == 3) {
- $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response;
- }
- elsif ($fwtype == 4) {
- $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response;
- }
-
- return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
- }
- }
- }
-
- $ok = $ftp->_USER($user);
-
- # Some dumb firewalls don't prefix the connection messages
- $ok = $ftp->response()
- if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);
-
- if ($ok == CMD_MORE) {
- unless (defined $pass) {
- require Net::Netrc;
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);
-
- ($ruser, $pass, $acct) = $rc->lpa()
- if ($rc);
-
- $pass = '-anonymous@'
- if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
- }
-
- $ok = $ftp->_PASS($pass || "");
- }
-
- $ok = $ftp->_ACCT($acct)
- if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));
-
- if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
- my ($f, $auth, $resp) = _auth_id($ftp);
- $ftp->authorize($auth, $resp) if defined($resp);
- }
-
- $ok == CMD_OK;
-}
-
-
-sub account {
- @_ == 2 or croak 'usage: $ftp->account( ACCT )';
- my $ftp = shift;
- my $acct = shift;
- $ftp->_ACCT($acct) == CMD_OK;
-}
-
-
-sub _auth_id {
- my ($ftp, $auth, $resp) = @_;
-
- unless (defined $resp) {
- require Net::Netrc;
-
- $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};
-
- my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
- || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});
-
- ($auth, $resp) = $rc->lpa()
- if ($rc);
- }
- ($ftp, $auth, $resp);
-}
-
-
-sub authorize {
- @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';
-
- my ($ftp, $auth, $resp) = &_auth_id;
-
- my $ok = $ftp->_AUTH($auth || "");
-
- $ok = $ftp->_RESP($resp || "")
- if ($ok == CMD_MORE);
-
- $ok == CMD_OK;
-}
-
-
-sub rename {
- @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';
-
- my ($ftp, $from, $to) = @_;
-
- $ftp->_RNFR($from)
- && $ftp->_RNTO($to);
-}
-
-
-sub type {
- my $ftp = shift;
- my $type = shift;
- my $oldval = ${*$ftp}{'net_ftp_type'};
-
- return $oldval
- unless (defined $type);
-
- return undef
- unless ($ftp->_TYPE($type, @_));
-
- ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_);
-
- $oldval;
-}
-
-
-sub alloc {
- my $ftp = shift;
- my $size = shift;
- my $oldval = ${*$ftp}{'net_ftp_allo'};
-
- return $oldval
- unless (defined $size);
-
- return undef
- unless ($ftp->_ALLO($size, @_));
-
- ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_);
-
- $oldval;
-}
-
-
-sub abort {
- my $ftp = shift;
-
- send($ftp, pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC), MSG_OOB);
-
- $ftp->command(pack("C", $TELNET_DM) . "ABOR");
-
- ${*$ftp}{'net_ftp_dataconn'}->close()
- if defined ${*$ftp}{'net_ftp_dataconn'};
-
- $ftp->response();
-
- $ftp->status == CMD_OK;
-}
-
-
-sub get {
- my ($ftp, $remote, $local, $where) = @_;
-
- my ($loc, $len, $buf, $resp, $data);
- local *FD;
-
- my $localfd = ref($local) || ref(\$local) eq "GLOB";
-
- ($local = $remote) =~ s#^.*/##
- unless (defined $local);
-
- croak("Bad remote filename '$remote'\n")
- if $remote =~ /[\r\n]/s;
-
- ${*$ftp}{'net_ftp_rest'} = $where if defined $where;
- my $rest = ${*$ftp}{'net_ftp_rest'};
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- $data = $ftp->retr($remote)
- or return undef;
-
- if ($localfd) {
- $loc = $local;
- }
- else {
- $loc = \*FD;
-
- unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) {
- carp "Cannot open Local file $local: $!\n";
- $data->abort;
- return undef;
- }
- }
-
- if ($ftp->type eq 'I' && !binmode($loc)) {
- carp "Cannot binmode Local file $local: $!\n";
- $data->abort;
- close($loc) unless $localfd;
- return undef;
- }
-
- $buf = '';
- my ($count, $hashh, $hashb, $ref) = (0);
-
- ($hashh, $hashb) = @$ref
- if ($ref = ${*$ftp}{'net_ftp_hash'});
-
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
- local $\; # Just in case
-
- while (1) {
- last unless $len = $data->read($buf, $blksize);
-
- if (trEBCDIC && $ftp->type ne 'I') {
- $buf = $ftp->toebcdic($buf);
- $len = length($buf);
- }
-
- if ($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
- unless (print $loc $buf) {
- carp "Cannot write to Local file $local: $!\n";
- $data->abort;
- close($loc)
- unless $localfd;
- return undef;
- }
- }
-
- print $hashh "\n" if $hashh;
-
- unless ($localfd) {
- unless (close($loc)) {
- carp "Cannot close file $local (perhaps disk space) $!\n";
- return undef;
- }
- }
-
- unless ($data->close()) # implied $ftp->response
- {
- carp "Unable to close datastream";
- return undef;
- }
-
- return $local;
-}
-
-
-sub cwd {
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';
-
- my ($ftp, $dir) = @_;
-
- $dir = "/" unless defined($dir) && $dir =~ /\S/;
-
- $dir eq ".."
- ? $ftp->_CDUP()
- : $ftp->_CWD($dir);
-}
-
-
-sub cdup {
- @_ == 1 or croak 'usage: $ftp->cdup()';
- $_[0]->_CDUP;
-}
-
-
-sub pwd {
- @_ == 1 || croak 'usage: $ftp->pwd()';
- my $ftp = shift;
-
- $ftp->_PWD();
- $ftp->_extract_path;
-}
-
-# rmdir( $ftp, $dir, [ $recurse ] )
-#
-# Removes $dir on remote host via FTP.
-# $ftp is handle for remote host
-#
-# If $recurse is TRUE, the directory and deleted recursively.
-# This means all of its contents and subdirectories.
-#
-# Initial version contributed by Dinkum Software
-#
-sub rmdir {
- @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');
-
- # Pick off the args
- my ($ftp, $dir, $recurse) = @_;
- my $ok;
-
- return $ok
- if $ok = $ftp->_RMD($dir)
- or !$recurse;
-
- # Try to delete the contents
- # Get a list of all the files in the directory
- my @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir);
-
- return undef
- unless @filelist; # failed, it is probably not a directory
-
- # Go thru and delete each file or the directory
- my $file;
- foreach $file (map { m,/, ? $_ : "$dir/$_" } @filelist) {
- next # successfully deleted the file
- if $ftp->delete($file);
-
- # Failed to delete it, assume its a directory
- # Recurse and ignore errors, the final rmdir() will
- # fail on any errors here
- return $ok
- unless $ok = $ftp->rmdir($file, 1);
- }
-
- # Directory should be empty
- # Try to remove the directory again
- # Pass results directly to caller
- # If any of the prior deletes failed, this
- # rmdir() will fail because directory is not empty
- return $ftp->_RMD($dir);
-}
-
-
-sub restart {
- @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )';
-
- my ($ftp, $where) = @_;
-
- ${*$ftp}{'net_ftp_rest'} = $where;
-
- return undef;
-}
-
-
-sub mkdir {
- @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';
-
- my ($ftp, $dir, $recurse) = @_;
-
- $ftp->_MKD($dir) || $recurse
- or return undef;
-
- my $path = $dir;
-
- unless ($ftp->ok) {
- my @path = split(m#(?=/+)#, $dir);
-
- $path = "";
-
- while (@path) {
- $path .= shift @path;
-
- $ftp->_MKD($path);
-
- $path = $ftp->_extract_path($path);
- }
-
- # If the creation of the last element was not successful, see if we
- # can cd to it, if so then return path
-
- unless ($ftp->ok) {
- my ($status, $message) = ($ftp->status, $ftp->message);
- my $pwd = $ftp->pwd;
-
- if ($pwd && $ftp->cwd($dir)) {
- $path = $dir;
- $ftp->cwd($pwd);
- }
- else {
- undef $path;
- }
- $ftp->set_status($status, $message);
- }
- }
-
- $path;
-}
-
-
-sub delete {
- @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';
-
- $_[0]->_DELE($_[1]);
-}
-
-
-sub put { shift->_store_cmd("stor", @_) }
-sub put_unique { shift->_store_cmd("stou", @_) }
-sub append { shift->_store_cmd("appe", @_) }
-
-
-sub nlst { shift->_data_cmd("NLST", @_) }
-sub list { shift->_data_cmd("LIST", @_) }
-sub retr { shift->_data_cmd("RETR", @_) }
-sub stor { shift->_data_cmd("STOR", @_) }
-sub stou { shift->_data_cmd("STOU", @_) }
-sub appe { shift->_data_cmd("APPE", @_) }
-
-
-sub _store_cmd {
- my ($ftp, $cmd, $local, $remote) = @_;
- my ($loc, $sock, $len, $buf);
- local *FD;
-
- my $localfd = ref($local) || ref(\$local) eq "GLOB";
-
- unless (defined $remote) {
- croak 'Must specify remote filename with stream input'
- if $localfd;
-
- require File::Basename;
- $remote = File::Basename::basename($local);
- }
- if (defined ${*$ftp}{'net_ftp_allo'}) {
- delete ${*$ftp}{'net_ftp_allo'};
- }
- else {
-
- # if the user hasn't already invoked the alloc method since the last
- # _store_cmd call, figure out if the local file is a regular file(not
- # a pipe, or device) and if so get the file size from stat, and send
- # an ALLO command before sending the STOR, STOU, or APPE command.
- my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe
- $ftp->_ALLO($size) if $size;
- }
- croak("Bad remote filename '$remote'\n")
- if $remote =~ /[\r\n]/s;
-
- if ($localfd) {
- $loc = $local;
- }
- else {
- $loc = \*FD;
-
- unless (sysopen($loc, $local, O_RDONLY)) {
- carp "Cannot open Local file $local: $!\n";
- return undef;
- }
- }
-
- if ($ftp->type eq 'I' && !binmode($loc)) {
- carp "Cannot binmode Local file $local: $!\n";
- return undef;
- }
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- $sock = $ftp->_data_cmd($cmd, $remote)
- or return undef;
-
- $remote = ($ftp->message =~ /FILE:\s*(.*)/)[0]
- if 'STOU' eq uc $cmd;
-
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
-
- my ($count, $hashh, $hashb, $ref) = (0);
-
- ($hashh, $hashb) = @$ref
- if ($ref = ${*$ftp}{'net_ftp_hash'});
-
- while (1) {
- last unless $len = read($loc, $buf = "", $blksize);
-
- if (trEBCDIC && $ftp->type ne 'I') {
- $buf = $ftp->toascii($buf);
- $len = length($buf);
- }
-
- if ($hashh) {
- $count += $len;
- print $hashh "#" x (int($count / $hashb));
- $count %= $hashb;
- }
-
- my $wlen;
- unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) {
- $sock->abort;
- close($loc)
- unless $localfd;
- print $hashh "\n" if $hashh;
- return undef;
- }
- }
-
- print $hashh "\n" if $hashh;
-
- close($loc)
- unless $localfd;
-
- $sock->close()
- or return undef;
-
- if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) {
- require File::Basename;
- $remote = File::Basename::basename($+);
- }
-
- return $remote;
-}
-
-
-sub port {
- @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';
-
- my ($ftp, $port) = @_;
- my $ok;
-
- delete ${*$ftp}{'net_ftp_intern_port'};
-
- unless (defined $port) {
-
- # create a Listen socket at same address as the command socket
-
- ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(
- Listen => 5,
- Proto => 'tcp',
- Timeout => $ftp->timeout,
- LocalAddr => $ftp->sockhost,
- );
-
- my $listen = ${*$ftp}{'net_ftp_listen'};
-
- my ($myport, @myaddr) = ($listen->sockport, split(/\./, $listen->sockhost));
-
- $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
-
- ${*$ftp}{'net_ftp_intern_port'} = 1;
- }
-
- $ok = $ftp->_PORT($port);
-
- ${*$ftp}{'net_ftp_port'} = $port;
-
- $ok;
-}
-
-
-sub ls { shift->_list_cmd("NLST", @_); }
-sub dir { shift->_list_cmd("LIST", @_); }
-
-
-sub pasv {
- @_ == 1 or croak 'usage: $ftp->pasv()';
-
- my $ftp = shift;
-
- delete ${*$ftp}{'net_ftp_intern_port'};
-
- $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
- ? ${*$ftp}{'net_ftp_pasv'} = $1
- : undef;
-}
-
-
-sub unique_name {
- my $ftp = shift;
- ${*$ftp}{'net_ftp_unique'} || undef;
-}
-
-
-sub supported {
- @_ == 2 or croak 'usage: $ftp->supported( CMD )';
- my $ftp = shift;
- my $cmd = uc shift;
- my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};
-
- return $hash->{$cmd}
- if exists $hash->{$cmd};
-
- return $hash->{$cmd} = 0
- unless $ftp->_HELP($cmd);
-
- my $text = $ftp->message;
- if ($text =~ /following\s+commands/i) {
- $text =~ s/^.*\n//;
- while ($text =~ /(\*?)(\w+)(\*?)/sg) {
- $hash->{"\U$2"} = !length("$1$3");
- }
- }
- else {
- $hash->{$cmd} = $text !~ /unimplemented/i;
- }
-
- $hash->{$cmd} ||= 0;
-}
-
-##
-## Deprecated methods
-##
-
-
-sub lsl {
- carp "Use of Net::FTP::lsl deprecated, use 'dir'"
- if $^W;
- goto &dir;
-}
-
-
-sub authorise {
- carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
- if $^W;
- goto &authorize;
-}
-
-
-##
-## Private methods
-##
-
-
-sub _extract_path {
- my ($ftp, $path) = @_;
-
- # This tries to work both with and without the quote doubling
- # convention (RFC 959 requires it, but the first 3 servers I checked
- # didn't implement it). It will fail on a server which uses a quote in
- # the message which isn't a part of or surrounding the path.
- $ftp->ok
- && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/
- && ($path = $1) =~ s/\"\"/\"/g;
-
- $path;
-}
-
-##
-## Communication methods
-##
-
-
-sub _dataconn {
- my $ftp = shift;
- my $data = undef;
- my $pkg = "Net::FTP::" . $ftp->type;
-
- eval "require " . $pkg;
-
- $pkg =~ s/ /_/g;
-
- delete ${*$ftp}{'net_ftp_dataconn'};
-
- if (defined ${*$ftp}{'net_ftp_pasv'}) {
- my @port = map { 0 + $_ } split(/,/, ${*$ftp}{'net_ftp_pasv'});
-
- $data = $pkg->new(
- PeerAddr => join(".", @port[0 .. 3]),
- PeerPort => $port[4] * 256 + $port[5],
- LocalAddr => ${*$ftp}{'net_ftp_localaddr'},
- Proto => 'tcp'
- );
- }
- elsif (defined ${*$ftp}{'net_ftp_listen'}) {
- $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
- close(delete ${*$ftp}{'net_ftp_listen'});
- }
-
- if ($data) {
- ${*$data} = "";
- $data->timeout($ftp->timeout);
- ${*$ftp}{'net_ftp_dataconn'} = $data;
- ${*$data}{'net_ftp_cmd'} = $ftp;
- ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
- }
-
- $data;
-}
-
-
-sub _list_cmd {
- my $ftp = shift;
- my $cmd = uc shift;
-
- delete ${*$ftp}{'net_ftp_port'};
- delete ${*$ftp}{'net_ftp_pasv'};
-
- my $data = $ftp->_data_cmd($cmd, @_);
-
- return
- unless (defined $data);
-
- require Net::FTP::A;
- bless $data, "Net::FTP::A"; # Force ASCII mode
-
- my $databuf = '';
- my $buf = '';
- my $blksize = ${*$ftp}{'net_ftp_blksize'};
-
- while ($data->read($databuf, $blksize)) {
- $buf .= $databuf;
- }
-
- my $list = [split(/\n/, $buf)];
-
- $data->close();
-
- if (trEBCDIC) {
- for (@$list) { $_ = $ftp->toebcdic($_) }
- }
-
- wantarray
- ? @{$list}
- : $list;
-}
-
-
-sub _data_cmd {
- my $ftp = shift;
- my $cmd = uc shift;
- my $ok = 1;
- my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
- my $arg;
-
- for $arg (@_) {
- croak("Bad argument '$arg'\n")
- if $arg =~ /[\r\n]/s;
- }
-
- if ( ${*$ftp}{'net_ftp_passive'}
- && !defined ${*$ftp}{'net_ftp_pasv'}
- && !defined ${*$ftp}{'net_ftp_port'})
- {
- my $data = undef;
-
- $ok = defined $ftp->pasv;
- $ok = $ftp->_REST($where)
- if $ok && $where;
-
- if ($ok) {
- $ftp->command($cmd, @_);
- $data = $ftp->_dataconn();
- $ok = CMD_INFO == $ftp->response();
- if ($ok) {
- $data->reading
- if $data && $cmd =~ /RETR|LIST|NLST/;
- return $data;
- }
- $data->_close
- if $data;
- }
- return undef;
- }
-
- $ok = $ftp->port
- unless (defined ${*$ftp}{'net_ftp_port'}
- || defined ${*$ftp}{'net_ftp_pasv'});
-
- $ok = $ftp->_REST($where)
- if $ok && $where;
-
- return undef
- unless $ok;
-
- $ftp->command($cmd, @_);
-
- return 1
- if (defined ${*$ftp}{'net_ftp_pasv'});
-
- $ok = CMD_INFO == $ftp->response();
-
- return $ok
- unless exists ${*$ftp}{'net_ftp_intern_port'};
-
- if ($ok) {
- my $data = $ftp->_dataconn();
-
- $data->reading
- if $data && $cmd =~ /RETR|LIST|NLST/;
-
- return $data;
- }
-
-
- close(delete ${*$ftp}{'net_ftp_listen'});
-
- return undef;
-}
-
-##
-## Over-ride methods (Net::Cmd)
-##
-
-
-sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }
-
-
-sub command {
- my $ftp = shift;
-
- delete ${*$ftp}{'net_ftp_port'};
- $ftp->SUPER::command(@_);
-}
-
-
-sub response {
- my $ftp = shift;
- my $code = $ftp->SUPER::response();
-
- delete ${*$ftp}{'net_ftp_pasv'}
- if ($code != CMD_MORE && $code != CMD_INFO);
-
- $code;
-}
-
-
-sub parse_response {
- return ($1, $2 eq "-")
- if $_[1] =~ s/^(\d\d\d)([- ]?)//o;
-
- my $ftp = shift;
-
- # Darn MS FTP server is a load of CRAP !!!!
- return ()
- unless ${*$ftp}{'net_cmd_code'} + 0;
-
- (${*$ftp}{'net_cmd_code'}, 1);
-}
-
-##
-## Allow 2 servers to talk directly
-##
-
-
-sub pasv_xfer_unique {
- my ($sftp, $sfile, $dftp, $dfile) = @_;
- $sftp->pasv_xfer($sfile, $dftp, $dfile, 1);
-}
-
-
-sub pasv_xfer {
- my ($sftp, $sfile, $dftp, $dfile, $unique) = @_;
-
- ($dfile = $sfile) =~ s#.*/##
- unless (defined $dfile);
-
- my $port = $sftp->pasv
- or return undef;
-
- $dftp->port($port)
- or return undef;
-
- return undef
- unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));
-
- unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
- $sftp->retr($sfile);
- $dftp->abort;
- $dftp->response();
- return undef;
- }
-
- $dftp->pasv_wait($sftp);
-}
-
-
-sub pasv_wait {
- @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';
-
- my ($ftp, $non_pasv) = @_;
- my ($file, $rin, $rout);
-
- vec($rin = '', fileno($ftp), 1) = 1;
- select($rout = $rin, undef, undef, undef);
-
- $ftp->response();
- $non_pasv->response();
-
- return undef
- unless $ftp->ok() && $non_pasv->ok();
-
- return $1
- if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;
-
- return $1
- if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
-
- return 1;
-}
-
-
-sub feature {
- @_ == 2 or croak 'usage: $ftp->feature( NAME )';
- my ($ftp, $feat) = @_;
-
- my $feature = ${*$ftp}{net_ftp_feature} ||= do {
- my @feat;
-
- # Example response
- # 211-Features:
- # MDTM
- # REST STREAM
- # SIZE
- # 211 End
-
- @feat = map { /^\s+(.*\S)/ } $ftp->message
- if $ftp->_FEAT;
-
- \@feat;
- };
-
- return grep { /^\Q$feat\E\b/i } @$feature;
-}
-
-
-sub cmd { shift->command(@_)->response() }
-
-########################################
-#
-# RFC959 commands
-#
-
-
-sub _ABOR { shift->command("ABOR")->response() == CMD_OK }
-sub _ALLO { shift->command("ALLO", @_)->response() == CMD_OK }
-sub _CDUP { shift->command("CDUP")->response() == CMD_OK }
-sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
-sub _PASV { shift->command("PASV")->response() == CMD_OK }
-sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
-sub _DELE { shift->command("DELE", @_)->response() == CMD_OK }
-sub _CWD { shift->command("CWD", @_)->response() == CMD_OK }
-sub _PORT { shift->command("PORT", @_)->response() == CMD_OK }
-sub _RMD { shift->command("RMD", @_)->response() == CMD_OK }
-sub _MKD { shift->command("MKD", @_)->response() == CMD_OK }
-sub _PWD { shift->command("PWD", @_)->response() == CMD_OK }
-sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK }
-sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK }
-sub _RESP { shift->command("RESP", @_)->response() == CMD_OK }
-sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK }
-sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
-sub _STAT { shift->command("STAT", @_)->response() == CMD_OK }
-sub _FEAT { shift->command("FEAT", @_)->response() == CMD_OK }
-sub _APPE { shift->command("APPE", @_)->response() == CMD_INFO }
-sub _LIST { shift->command("LIST", @_)->response() == CMD_INFO }
-sub _NLST { shift->command("NLST", @_)->response() == CMD_INFO }
-sub _RETR { shift->command("RETR", @_)->response() == CMD_INFO }
-sub _STOR { shift->command("STOR", @_)->response() == CMD_INFO }
-sub _STOU { shift->command("STOU", @_)->response() == CMD_INFO }
-sub _RNFR { shift->command("RNFR", @_)->response() == CMD_MORE }
-sub _REST { shift->command("REST", @_)->response() == CMD_MORE }
-sub _PASS { shift->command("PASS", @_)->response() }
-sub _ACCT { shift->command("ACCT", @_)->response() }
-sub _AUTH { shift->command("AUTH", @_)->response() }
-
-
-sub _USER {
- my $ftp = shift;
- my $ok = $ftp->command("USER", @_)->response();
-
- # A certain brain dead firewall :-)
- $ok = $ftp->command("user", @_)->response()
- unless $ok == CMD_MORE or $ok == CMD_OK;
-
- $ok;
-}
-
-
-sub _SMNT { shift->unsupported(@_) }
-sub _MODE { shift->unsupported(@_) }
-sub _SYST { shift->unsupported(@_) }
-sub _STRU { shift->unsupported(@_) }
-sub _REIN { shift->unsupported(@_) }
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::FTP - FTP Client class
-
-=head1 SYNOPSIS
-
- use Net::FTP;
-
- $ftp = Net::FTP->new("some.host.name", Debug => 0)
- or die "Cannot connect to some.host.name: $@";
-
- $ftp->login("anonymous",'-anonymous@')
- or die "Cannot login ", $ftp->message;
-
- $ftp->cwd("/pub")
- or die "Cannot change working directory ", $ftp->message;
-
- $ftp->get("that.file")
- or die "get failed ", $ftp->message;
-
- $ftp->quit;
-
-=head1 DESCRIPTION
-
-C<Net::FTP> is a class implementing a simple FTP client in Perl as
-described in RFC959. It provides wrappers for a subset of the RFC959
-commands.
-
-=head1 OVERVIEW
-
-FTP stands for File Transfer Protocol. It is a way of transferring
-files between networked machines. The protocol defines a client
-(whose commands are provided by this module) and a server (not
-implemented in this module). Communication is always initiated by the
-client, and the server responds with a message and a status code (and
-sometimes with data).
-
-The FTP protocol allows files to be sent to or fetched from the
-server. Each transfer involves a B<local file> (on the client) and a
-B<remote file> (on the server). In this module, the same file name
-will be used for both local and remote if only one is specified. This
-means that transferring remote file C</path/to/file> will try to put
-that file in C</path/to/file> locally, unless you specify a local file
-name.
-
-The protocol also defines several standard B<translations> which the
-file can undergo during transfer. These are ASCII, EBCDIC, binary,
-and byte. ASCII is the default type, and indicates that the sender of
-files will translate the ends of lines to a standard representation
-which the receiver will then translate back into their local
-representation. EBCDIC indicates the file being transferred is in
-EBCDIC format. Binary (also known as image) format sends the data as
-a contiguous bit stream. Byte format transfers the data as bytes, the
-values of which remain the same regardless of differences in byte size
-between the two machines (in theory - in practice you should only use
-this if you really know what you're doing).
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ([ HOST ] [, OPTIONS ])
-
-This is the constructor for a new Net::FTP object. C<HOST> is the
-name of the remote host to which an FTP connection is required.
-
-C<HOST> is optional. If C<HOST> is not given then it may instead be
-passed as the C<Host> option described below.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Host> - FTP host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-
-B<Firewall> - The name of a machine which acts as an FTP firewall. This can be
-overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
-given host cannot be directly connected to, then the
-connection is made to the firewall machine and the string C<@hostname> is
-appended to the login identifier. This kind of setup is also referred to
-as an ftp proxy.
-
-B<FirewallType> - The type of firewall running on the machine indicated by
-B<Firewall>. This can be overridden by an environment variable
-C<FTP_FIREWALL_TYPE>. For a list of permissible types, see the description of
-ftp_firewall_type in L<Net::Config>.
-
-B<BlockSize> - This is the block size that Net::FTP will use when doing
-transfers. (defaults to 10240)
-
-B<Port> - The port number to connect to on the remote machine for the
-FTP connection
-
-B<Timeout> - Set a timeout value (defaults to 120)
-
-B<Debug> - debug level (see the debug method in L<Net::Cmd>)
-
-B<Passive> - If set to a non-zero value then all data transfers will
-be done using passive mode. If set to zero then data transfers will be
-done using active mode. If the machine is connected to the Internet
-directly, both passive and active mode should work equally well.
-Behind most firewall and NAT configurations passive mode has a better
-chance of working. However, in some rare firewall configurations,
-active mode actually works when passive mode doesn't. Some really old
-FTP servers might not implement passive transfers. If not specified,
-then the transfer mode is set by the environment variable
-C<FTP_PASSIVE> or if that one is not set by the settings done by the
-F<libnetcfg> utility. If none of these apply then passive mode is
-used.
-
-B<Hash> - If given a reference to a file handle (e.g., C<\*STDERR>),
-print hash marks (#) on that filehandle every 1024 bytes. This
-simply invokes the C<hash()> method for you, so that hash marks
-are displayed for all transfers. You can, of course, call C<hash()>
-explicitly whenever you'd like.
-
-B<LocalAddr> - Local address to use for all socket connections, this
-argument will be passed to L<IO::Socket::INET>
-
-If the constructor fails undef will be returned and an error message will
-be in $@
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])
-
-Log into the remote FTP server with the given login information. If
-no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
-package to lookup the login information for the connected host.
-If no information is found then a login of I<anonymous> is used.
-If no password is given and the login is I<anonymous> then I<anonymous@>
-will be used for password.
-
-If the connection is via a firewall then the C<authorize> method will
-be called with no arguments.
-
-=item authorize ( [AUTH [, RESP]])
-
-This is a protocol used by some firewall ftp proxies. It is used
-to authorise the user to send data out. If both arguments are not specified
-then C<authorize> uses C<Net::Netrc> to do a lookup.
-
-=item site (ARGS)
-
-Send a SITE command to the remote server and wait for a response.
-
-Returns most significant digit of the response code.
-
-=item ascii
-
-Transfer file in ASCII. CRLF translation will be done if required
-
-=item binary
-
-Transfer file in binary mode. No transformation will be done.
-
-B<Hint>: If both server and client machines use the same line ending for
-text files, then it will be faster to transfer all files in binary mode.
-
-=item rename ( OLDNAME, NEWNAME )
-
-Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
-is done by sending the RNFR and RNTO commands.
-
-=item delete ( FILENAME )
-
-Send a request to the server to delete C<FILENAME>.
-
-=item cwd ( [ DIR ] )
-
-Attempt to change directory to the directory given in C<$dir>. If
-C<$dir> is C<"..">, the FTP C<CDUP> command is used to attempt to
-move up one directory. If no directory is given then an attempt is made
-to change the directory to the root directory.
-
-=item cdup ()
-
-Change directory to the parent of the current directory.
-
-=item pwd ()
-
-Returns the full pathname of the current directory.
-
-=item restart ( WHERE )
-
-Set the byte offset at which to begin the next data transfer. Net::FTP simply
-records this value and uses it when during the next data transfer. For this
-reason this method will not return an error, but setting it may cause
-a subsequent data transfer to fail.
-
-=item rmdir ( DIR [, RECURSE ])
-
-Remove the directory with the name C<DIR>. If C<RECURSE> is I<true> then
-C<rmdir> will attempt to delete everything inside the directory.
-
-=item mkdir ( DIR [, RECURSE ])
-
-Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
-C<mkdir> will attempt to create all the directories in the given path.
-
-Returns the full pathname to the new directory.
-
-=item alloc ( SIZE [, RECORD_SIZE] )
-
-The alloc command allows you to give the ftp server a hint about the size
-of the file about to be transferred using the ALLO ftp command. Some storage
-systems use this to make intelligent decisions about how to store the file.
-The C<SIZE> argument represents the size of the file in bytes. The
-C<RECORD_SIZE> argument indicates a maximum record or page size for files
-sent with a record or page structure.
-
-The size of the file will be determined, and sent to the server
-automatically for normal files so that this method need only be called if
-you are transferring data from a socket, named pipe, or other stream not
-associated with a normal file.
-
-=item ls ( [ DIR ] )
-
-Get a directory listing of C<DIR>, or the current directory.
-
-In an array context, returns a list of lines returned from the server. In
-a scalar context, returns a reference to a list.
-
-=item dir ( [ DIR ] )
-
-Get a directory listing of C<DIR>, or the current directory in long format.
-
-In an array context, returns a list of lines returned from the server. In
-a scalar context, returns a reference to a list.
-
-=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] )
-
-Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
-a filename or a filehandle. If not specified, the file will be stored in
-the current directory with the same leafname as the remote file.
-
-If C<WHERE> is given then the first C<WHERE> bytes of the file will
-not be transferred, and the remaining bytes will be appended to
-the local file if it already exists.
-
-Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
-is not given. If an error was encountered undef is returned.
-
-=item put ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
-If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
-C<REMOTE_FILE> is not specified then the file will be stored in the current
-directory with the same leafname as C<LOCAL_FILE>.
-
-Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
-is not given.
-
-B<NOTE>: If for some reason the transfer does not complete and an error is
-returned then the contents that had been transferred will not be remove
-automatically.
-
-=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Same as put but uses the C<STOU> command.
-
-Returns the name of the file on the server.
-
-=item append ( LOCAL_FILE [, REMOTE_FILE ] )
-
-Same as put but appends to the file on the remote server.
-
-Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
-is not given.
-
-=item unique_name ()
-
-Returns the name of the last file stored on the server using the
-C<STOU> command.
-
-=item mdtm ( FILE )
-
-Returns the I<modification time> of the given file
-
-=item size ( FILE )
-
-Returns the size in bytes for the given file as stored on the remote server.
-
-B<NOTE>: The size reported is the size of the stored file on the remote server.
-If the file is subsequently transferred from the server in ASCII mode
-and the remote server and local machine have different ideas about
-"End Of Line" then the size of file on the local machine after transfer
-may be different.
-
-=item supported ( CMD )
-
-Returns TRUE if the remote server supports the given command.
-
-=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] )
-
-Called without parameters, or with the first argument false, hash marks
-are suppressed. If the first argument is true but not a reference to a
-file handle glob, then \*STDERR is used. The second argument is the number
-of bytes per hash mark printed, and defaults to 1024. In all cases the
-return value is a reference to an array of two: the filehandle glob reference
-and the bytes per hash mark.
-
-=item feature ( NAME )
-
-Determine if the server supports the specified feature. The return
-value is a list of lines the server responded with to describe the
-options that it supports for the given feature. If the feature is
-unsupported then the empty list is returned.
-
- if ($ftp->feature( 'MDTM' )) {
- # Do something
- }
-
- if (grep { /\bTLS\b/ } $ftp->feature('AUTH')) {
- # Server supports TLS
- }
-
-=back
-
-The following methods can return different results depending on
-how they are called. If the user explicitly calls either
-of the C<pasv> or C<port> methods then these methods will
-return a I<true> or I<false> value. If the user does not
-call either of these methods then the result will be a
-reference to a C<Net::FTP::dataconn> based object.
-
-=over 4
-
-=item nlst ( [ DIR ] )
-
-Send an C<NLST> command to the server, with an optional parameter.
-
-=item list ( [ DIR ] )
-
-Same as C<nlst> but using the C<LIST> command
-
-=item retr ( FILE )
-
-Begin the retrieval of a file called C<FILE> from the remote server.
-
-=item stor ( FILE )
-
-Tell the server that you wish to store a file. C<FILE> is the
-name of the new file that should be created.
-
-=item stou ( FILE )
-
-Same as C<stor> but using the C<STOU> command. The name of the unique
-file which was created on the server will be available via the C<unique_name>
-method after the data connection has been closed.
-
-=item appe ( FILE )
-
-Tell the server that we want to append some data to the end of a file
-called C<FILE>. If this file does not exist then create it.
-
-=back
-
-If for some reason you want to have complete control over the data connection,
-this includes generating it and calling the C<response> method when required,
-then the user can use these methods to do so.
-
-However calling these methods only affects the use of the methods above that
-can return a data connection. They have no effect on methods C<get>, C<put>,
-C<put_unique> and those that do not require data connections.
-
-=over 4
-
-=item port ( [ PORT ] )
-
-Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
-to the server. If not, then a listen socket is created and the correct information
-sent to the server.
-
-=item pasv ()
-
-Tell the server to go into passive mode. Returns the text that represents the
-port on which the server is listening, this text is in a suitable form to
-sent to another ftp server using the C<port> method.
-
-=back
-
-The following methods can be used to transfer files between two remote
-servers, providing that these two servers can connect directly to each other.
-
-=over 4
-
-=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
-
-This method will do a file transfer between two remote ftp servers. If
-C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.
-
-=item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )
-
-Like C<pasv_xfer> but the file is stored on the remote server using
-the STOU command.
-
-=item pasv_wait ( NON_PASV_SERVER )
-
-This method can be used to wait for a transfer to complete between a passive
-server and a non-passive server. The method should be called on the passive
-server with the C<Net::FTP> object for the non-passive server passed as an
-argument.
-
-=item abort ()
-
-Abort the current data transfer.
-
-=item quit ()
-
-Send the QUIT command to the remote FTP server and close the socket connection.
-
-=back
-
-=head2 Methods for the adventurous
-
-C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
-be used to send commands to the remote FTP server.
-
-=over 4
-
-=item quot (CMD [,ARGS])
-
-Send a command, that Net::FTP does not directly support, to the remote
-server and wait for a response.
-
-Returns most significant digit of the response code.
-
-B<WARNING> This call should only be used on commands that do not require
-data connections. Misuse of this method can hang the connection.
-
-=back
-
-=head1 THE dataconn CLASS
-
-Some of the methods defined in C<Net::FTP> return an object which will
-be derived from this class.The dataconn class itself is derived from
-the C<IO::Socket::INET> class, so any normal IO operations can be performed.
-However the following methods are defined in the dataconn class and IO should
-be performed using these.
-
-=over 4
-
-=item read ( BUFFER, SIZE [, TIMEOUT ] )
-
-Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
-performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given, the timeout value from the command connection will be used.
-
-Returns the number of bytes read before any <CRLF> translation.
-
-=item write ( BUFFER, SIZE [, TIMEOUT ] )
-
-Write C<SIZE> bytes of data from C<BUFFER> to the server, also
-performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
-given, the timeout value from the command connection will be used.
-
-Returns the number of bytes written before any <CRLF> translation.
-
-=item bytes_read ()
-
-Returns the number of bytes read so far.
-
-=item abort ()
-
-Abort the current data transfer.
-
-=item close ()
-
-Close the data connection and get a response from the FTP server. Returns
-I<true> if the connection was closed successfully and the first digit of
-the response from the server was a '2'.
-
-=back
-
-=head1 UNIMPLEMENTED
-
-The following RFC959 commands have not been implemented:
-
-=over 4
-
-=item B<SMNT>
-
-Mount a different file system structure without changing login or
-accounting information.
-
-=item B<HELP>
-
-Ask the server for "helpful information" (that's what the RFC says) on
-the commands it accepts.
-
-=item B<MODE>
-
-Specifies transfer mode (stream, block or compressed) for file to be
-transferred.
-
-=item B<SYST>
-
-Request remote server system identification.
-
-=item B<STAT>
-
-Request remote server status.
-
-=item B<STRU>
-
-Specifies file structure for file to be transferred.
-
-=item B<REIN>
-
-Reinitialize the connection, flushing all I/O and account information.
-
-=back
-
-=head1 REPORTING BUGS
-
-When reporting bugs/problems please include as much information as possible.
-It may be difficult for me to reproduce the problem as almost every setup
-is different.
-
-A small script which yields the problem will probably be of help. It would
-also be useful if this script was run with the extra options C<Debug => 1>
-passed to the constructor, and the output sent with the bug report. If you
-cannot include a small script then please include a Debug trace from a
-run of your program which does yield the problem.
-
-=head1 AUTHOR
-
-Graham Barr <gbarr at pobox.com>
-
-=head1 SEE ALSO
-
-L<Net::Netrc>
-L<Net::Cmd>
-
-ftp(1), ftpd(8), RFC 959
-http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
-
-=head1 USE EXAMPLES
-
-For an example of the use of Net::FTP see
-
-=over 4
-
-=item http://www.csh.rit.edu/~adam/Progs/
-
-C<autoftp> is a program that can retrieve, send, or list files via
-the FTP protocol in a non-interactive manner.
-
-=back
-
-=head1 CREDITS
-
-Henry Gabryjelski <henryg at WPI.EDU> - for the suggestion of creating directories
-recursively.
-
-Nathan Torkington <gnat at frii.com> - for some input on the documentation.
-
-Roderick Schertler <roderick at gate.net> - for various inputs
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2004 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/Hostname.pm.eg
===================================================================
--- trunk/contrib/perl/lib/Net/Hostname.pm.eg 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/Hostname.pm.eg 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,14 +0,0 @@
-#
-
-package Sys::Hostname;
-
-use Net::Domain qw(hostname);
-use Carp;
-
-require Exporter;
- at ISA = qw(Exporter);
- at EXPORT = qw(hostname);
-
-carp "deprecated package 'Sys::Hostname', use Net::Domain" if $^W;
-
-1;
Deleted: trunk/contrib/perl/lib/Net/NNTP.pm
===================================================================
--- trunk/contrib/perl/lib/Net/NNTP.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/NNTP.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1140 +0,0 @@
-# Net::NNTP.pm
-#
-# Copyright (c) 1995-1997 Graham Barr <gbarr at pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::NNTP;
-
-use strict;
-use vars qw(@ISA $VERSION $debug);
-use IO::Socket;
-use Net::Cmd;
-use Carp;
-use Time::Local;
-use Net::Config;
-
-$VERSION = "2.24";
- at ISA = qw(Net::Cmd IO::Socket::INET);
-
-
-sub new {
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host, %arg);
- if (@_ % 2) {
- $host = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $host = delete $arg{Host};
- }
- my $obj;
-
- $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};
-
- my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts};
-
- @{$hosts} = qw(news)
- unless @{$hosts};
-
- my $h;
- foreach $h (@{$hosts}) {
- $obj = $type->SUPER::new(
- PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'nntp(119)',
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- and last;
- }
-
- return undef
- unless defined $obj;
-
- ${*$obj}{'net_nntp_host'} = $host;
-
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK) {
- $obj->close;
- return undef;
- }
-
- my $c = $obj->code;
- my @m = $obj->message;
-
- unless (exists $arg{Reader} && $arg{Reader} == 0) {
-
- # if server is INN and we have transfer rights the we are currently
- # talking to innd not nnrpd
- if ($obj->reader) {
-
- # If reader suceeds the we need to consider this code to determine postok
- $c = $obj->code;
- }
- else {
-
- # I want to ignore this failure, so restore the previous status.
- $obj->set_status($c, \@m);
- }
- }
-
- ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;
-
- $obj;
-}
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_nntp_host'};
-}
-
-
-sub debug_text {
- my $nntp = shift;
- my $inout = shift;
- my $text = shift;
-
- if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/)
- || ($text =~ /^(authinfo\s+pass)/io))
- {
- $text = "$1 ....\n";
- }
-
- $text;
-}
-
-
-sub postok {
- @_ == 1 or croak 'usage: $nntp->postok()';
- my $nntp = shift;
- ${*$nntp}{'net_nntp_post'} || 0;
-}
-
-
-sub article {
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB'));
-
- $nntp->_ARTICLE(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-
-sub articlefh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )';
- my $nntp = shift;
-
- return unless $nntp->_ARTICLE(@_);
- return $nntp->tied_fh;
-}
-
-
-sub authinfo {
- @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
- my ($nntp, $user, $pass) = @_;
-
- $nntp->_AUTHINFO("USER", $user) == CMD_MORE
- && $nntp->_AUTHINFO("PASS", $pass) == CMD_OK;
-}
-
-
-sub authinfo_simple {
- @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
- my ($nntp, $user, $pass) = @_;
-
- $nntp->_AUTHINFO('SIMPLE') == CMD_MORE
- && $nntp->command($user, $pass)->response == CMD_OK;
-}
-
-
-sub body {
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
-
- $nntp->_BODY(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-
-sub bodyfh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )';
- my $nntp = shift;
- return unless $nntp->_BODY(@_);
- return $nntp->tied_fh;
-}
-
-
-sub head {
- @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
- my $nntp = shift;
- my @fh;
-
- @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');
-
- $nntp->_HEAD(@_)
- ? $nntp->read_until_dot(@fh)
- : undef;
-}
-
-
-sub headfh {
- @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )';
- my $nntp = shift;
- return unless $nntp->_HEAD(@_);
- return $nntp->tied_fh;
-}
-
-
-sub nntpstat {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
- my $nntp = shift;
-
- $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub group {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
- my $nntp = shift;
- my $grp = ${*$nntp}{'net_nntp_group'} || undef;
-
- return $grp
- unless (@_ || wantarray);
-
- my $newgrp = shift;
-
- return wantarray ? () : undef
- unless $nntp->_GROUP($newgrp || $grp || "")
- && $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;
-
- my ($count, $first, $last, $group) = ($1, $2, $3, $4);
-
- # group may be replied as '(current group)'
- $group = ${*$nntp}{'net_nntp_group'}
- if $group =~ /\(/;
-
- ${*$nntp}{'net_nntp_group'} = $group;
-
- wantarray
- ? ($count, $first, $last, $group)
- : $group;
-}
-
-
-sub help {
- @_ == 1 or croak 'usage: $nntp->help()';
- my $nntp = shift;
-
- $nntp->_HELP
- ? $nntp->read_until_dot
- : undef;
-}
-
-
-sub ihave {
- @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])';
- my $nntp = shift;
- my $mid = shift;
-
- $nntp->_IHAVE($mid) && $nntp->datasend(@_)
- ? @_ == 0 || $nntp->dataend
- : undef;
-}
-
-
-sub last {
- @_ == 1 or croak 'usage: $nntp->last()';
- my $nntp = shift;
-
- $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub list {
- @_ == 1 or croak 'usage: $nntp->list()';
- my $nntp = shift;
-
- $nntp->_LIST
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub newgroups {
- @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])';
- my $nntp = shift;
- my $time = _timestr(shift);
- my $dist = shift || "";
-
- $dist = join(",", @{$dist})
- if ref($dist);
-
- $nntp->_NEWGROUPS($time, $dist)
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub newnews {
- @_ >= 2 && @_ <= 4
- or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
- my $nntp = shift;
- my $time = _timestr(shift);
- my $grp = @_ ? shift: $nntp->group;
- my $dist = shift || "";
-
- $grp ||= "*";
- $grp = join(",", @{$grp})
- if ref($grp);
-
- $dist = join(",", @{$dist})
- if ref($dist);
-
- $nntp->_NEWNEWS($grp, $time, $dist)
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub next {
- @_ == 1 or croak 'usage: $nntp->next()';
- my $nntp = shift;
-
- $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
- ? $1
- : undef;
-}
-
-
-sub post {
- @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
- my $nntp = shift;
-
- $nntp->_POST() && $nntp->datasend(@_)
- ? @_ == 0 || $nntp->dataend
- : undef;
-}
-
-
-sub postfh {
- my $nntp = shift;
- return unless $nntp->_POST();
- return $nntp->tied_fh;
-}
-
-
-sub quit {
- @_ == 1 or croak 'usage: $nntp->quit()';
- my $nntp = shift;
-
- $nntp->_QUIT;
- $nntp->close;
-}
-
-
-sub slave {
- @_ == 1 or croak 'usage: $nntp->slave()';
- my $nntp = shift;
-
- $nntp->_SLAVE;
-}
-
-##
-## The following methods are not implemented by all servers
-##
-
-
-sub active {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_LIST('ACTIVE', @_)
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub active_times {
- @_ == 1 or croak 'usage: $nntp->active_times()';
- my $nntp = shift;
-
- $nntp->_LIST('ACTIVE.TIMES')
- ? $nntp->_grouplist
- : undef;
-}
-
-
-sub distributions {
- @_ == 1 or croak 'usage: $nntp->distributions()';
- my $nntp = shift;
-
- $nntp->_LIST('DISTRIBUTIONS')
- ? $nntp->_description
- : undef;
-}
-
-
-sub distribution_patterns {
- @_ == 1 or croak 'usage: $nntp->distributions()';
- my $nntp = shift;
-
- my $arr;
- local $_;
-
- $nntp->_LIST('DISTRIB.PATS')
- && ($arr = $nntp->read_until_dot)
- ? [grep { /^\d/ && (chomp, $_ = [split /:/]) } @$arr]
- : undef;
-}
-
-
-sub newsgroups {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_LIST('NEWSGROUPS', @_)
- ? $nntp->_description
- : undef;
-}
-
-
-sub overview_fmt {
- @_ == 1 or croak 'usage: $nntp->overview_fmt()';
- my $nntp = shift;
-
- $nntp->_LIST('OVERVIEW.FMT')
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub subscriptions {
- @_ == 1 or croak 'usage: $nntp->subscriptions()';
- my $nntp = shift;
-
- $nntp->_LIST('SUBSCRIPTIONS')
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub listgroup {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )';
- my $nntp = shift;
-
- $nntp->_LISTGROUP(@_)
- ? $nntp->_articlelist
- : undef;
-}
-
-
-sub reader {
- @_ == 1 or croak 'usage: $nntp->reader()';
- my $nntp = shift;
-
- $nntp->_MODE('READER');
-}
-
-
-sub xgtitle {
- @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
- my $nntp = shift;
-
- $nntp->_XGTITLE(@_)
- ? $nntp->_description
- : undef;
-}
-
-
-sub xhdr {
- @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
- my $nntp = shift;
- my $hdr = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XHDR($hdr, $arg)
- ? $nntp->_description
- : undef;
-}
-
-
-sub xover {
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XOVER($arg)
- ? $nntp->_fieldlist
- : undef;
-}
-
-
-sub xpat {
- @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
- my $nntp = shift;
- my $hdr = shift;
- my $pat = shift;
- my $arg = _msg_arg(@_);
-
- $pat = join(" ", @$pat)
- if ref($pat);
-
- $nntp->_XPAT($hdr, $arg, $pat)
- ? $nntp->_description
- : undef;
-}
-
-
-sub xpath {
- @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )';
- my ($nntp, $mid) = @_;
-
- return undef
- unless $nntp->_XPATH($mid);
-
- my $m;
- ($m = $nntp->message) =~ s/^\d+\s+//o;
- my @p = split /\s+/, $m;
-
- wantarray ? @p : $p[0];
-}
-
-
-sub xrover {
- @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
- my $nntp = shift;
- my $arg = _msg_arg(@_);
-
- $nntp->_XROVER($arg)
- ? $nntp->_description
- : undef;
-}
-
-
-sub date {
- @_ == 1 or croak 'usage: $nntp->date()';
- my $nntp = shift;
-
- $nntp->_DATE
- && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
- ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900)
- : undef;
-}
-
-
-##
-## Private subroutines
-##
-
-
-sub _msg_arg {
- my $spec = shift;
- my $arg = "";
-
- if (@_) {
- carp "Depriciated passing of two message numbers, " . "pass a reference"
- if $^W;
- $spec = [$spec, $_[0]];
- }
-
- if (defined $spec) {
- if (ref($spec)) {
- $arg = $spec->[0];
- if (defined $spec->[1]) {
- $arg .= "-"
- if $spec->[1] != $spec->[0];
- $arg .= $spec->[1]
- if $spec->[1] > $spec->[0];
- }
- }
- else {
- $arg = $spec;
- }
- }
-
- $arg;
-}
-
-
-sub _timestr {
- my $time = shift;
- my @g = reverse((gmtime($time))[0 .. 5]);
- $g[1] += 1;
- $g[0] %= 100;
- sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
-}
-
-
-sub _grouplist {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot
- or return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr) {
- my @a = split(/[\s\n]+/, $ln);
- $hash->{$a[0]} = [@a[1, 2, 3]];
- }
-
- $hash;
-}
-
-
-sub _fieldlist {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot
- or return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr) {
- my @a = split(/[\t\n]/, $ln);
- my $m = shift @a;
- $hash->{$m} = [@a];
- }
-
- $hash;
-}
-
-
-sub _articlelist {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot;
-
- chomp(@$arr)
- if $arr;
-
- $arr;
-}
-
-
-sub _description {
- my $nntp = shift;
- my $arr = $nntp->read_until_dot
- or return undef;
-
- my $hash = {};
- my $ln;
-
- foreach $ln (@$arr) {
- chomp($ln);
-
- $hash->{$1} = $ln
- if $ln =~ s/^\s*(\S+)\s*//o;
- }
-
- $hash;
-
-}
-
-##
-## The commands
-##
-
-
-sub _ARTICLE { shift->command('ARTICLE', @_)->response == CMD_OK }
-sub _AUTHINFO { shift->command('AUTHINFO', @_)->response }
-sub _BODY { shift->command('BODY', @_)->response == CMD_OK }
-sub _DATE { shift->command('DATE')->response == CMD_INFO }
-sub _GROUP { shift->command('GROUP', @_)->response == CMD_OK }
-sub _HEAD { shift->command('HEAD', @_)->response == CMD_OK }
-sub _HELP { shift->command('HELP', @_)->response == CMD_INFO }
-sub _IHAVE { shift->command('IHAVE', @_)->response == CMD_MORE }
-sub _LAST { shift->command('LAST')->response == CMD_OK }
-sub _LIST { shift->command('LIST', @_)->response == CMD_OK }
-sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK }
-sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK }
-sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK }
-sub _NEXT { shift->command('NEXT')->response == CMD_OK }
-sub _POST { shift->command('POST', @_)->response == CMD_MORE }
-sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK }
-sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK }
-sub _STAT { shift->command('STAT', @_)->response == CMD_OK }
-sub _MODE { shift->command('MODE', @_)->response == CMD_OK }
-sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK }
-sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK }
-sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK }
-sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK }
-sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK }
-sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK }
-sub _XTHREAD { shift->unsupported }
-sub _XSEARCH { shift->unsupported }
-sub _XINDEX { shift->unsupported }
-
-##
-## IO/perl methods
-##
-
-
-sub DESTROY {
- my $nntp = shift;
- defined(fileno($nntp)) && $nntp->quit;
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::NNTP - NNTP Client class
-
-=head1 SYNOPSIS
-
- use Net::NNTP;
-
- $nntp = Net::NNTP->new("some.host.name");
- $nntp->quit;
-
-=head1 DESCRIPTION
-
-C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
-in RFC977. C<Net::NNTP> inherits its communication methods from C<Net::Cmd>
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ])
-
-This is the constructor for a new Net::NNTP object. C<HOST> is the
-name of the remote host to which a NNTP connection is required. If not
-given then it may be passed as the C<Host> option described below. If no host is passed
-then two environment variables are checked, first C<NNTPSERVER> then
-C<NEWSHOST>, then C<Net::Config> is checked, and if a host is not found
-then C<news> is used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Host> - NNTP host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-NNTP server, a value of zero will cause all IO operations to block.
-(default: 120)
-
-B<Debug> - Enable the printing of debugging information to STDERR
-
-B<Reader> - If the remote server is INN then initially the connection
-will be to nnrpd, by default C<Net::NNTP> will issue a C<MODE READER> command
-so that the remote server becomes innd. If the C<Reader> option is given
-with a value of zero, then this command will not be sent and the
-connection will be left talking to nnrpd.
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item article ( [ MSGID|MSGNUM ], [FH] )
-
-Retrieve the header, a blank line, then the body (text) of the
-specified article.
-
-If C<FH> is specified then it is expected to be a valid filehandle
-and the result will be printed to it, on success a true value will be
-returned. If C<FH> is not specified then the return value, on success,
-will be a reference to an array containing the article requested, each
-entry in the array will contain one line of the article.
-
-If no arguments are passed then the current article in the currently
-selected newsgroup is fetched.
-
-C<MSGNUM> is a numeric id of an article in the current newsgroup, and
-will change the current article pointer. C<MSGID> is the message id of
-an article as shown in that article's header. It is anticipated that the
-client will obtain the C<MSGID> from a list provided by the C<newnews>
-command, from references contained within another article, or from the
-message-id provided in the response to some other commands.
-
-If there is an error then C<undef> will be returned.
-
-=item body ( [ MSGID|MSGNUM ], [FH] )
-
-Like C<article> but only fetches the body of the article.
-
-=item head ( [ MSGID|MSGNUM ], [FH] )
-
-Like C<article> but only fetches the headers for the article.
-
-=item articlefh ( [ MSGID|MSGNUM ] )
-
-=item bodyfh ( [ MSGID|MSGNUM ] )
-
-=item headfh ( [ MSGID|MSGNUM ] )
-
-These are similar to article(), body() and head(), but rather than
-returning the requested data directly, they return a tied filehandle
-from which to read the article.
-
-=item nntpstat ( [ MSGID|MSGNUM ] )
-
-The C<nntpstat> command is similar to the C<article> command except that no
-text is returned. When selecting by message number within a group,
-the C<nntpstat> command serves to set the "current article pointer" without
-sending text.
-
-Using the C<nntpstat> command to
-select by message-id is valid but of questionable value, since a
-selection by message-id does B<not> alter the "current article pointer".
-
-Returns the message-id of the "current article".
-
-=item group ( [ GROUP ] )
-
-Set and/or get the current group. If C<GROUP> is not given then information
-is returned on the current group.
-
-In a scalar context it returns the group name.
-
-In an array context the return value is a list containing, the number
-of articles in the group, the number of the first article, the number
-of the last article and the group name.
-
-=item ihave ( MSGID [, MESSAGE ])
-
-The C<ihave> command informs the server that the client has an article
-whose id is C<MSGID>. If the server desires a copy of that
-article, and C<MESSAGE> has been given the it will be sent.
-
-Returns I<true> if the server desires the article and C<MESSAGE> was
-successfully sent,if specified.
-
-If C<MESSAGE> is not specified then the message must be sent using the
-C<datasend> and C<dataend> methods from L<Net::Cmd>
-
-C<MESSAGE> can be either an array of lines or a reference to an array.
-
-=item last ()
-
-Set the "current article pointer" to the previous article in the current
-newsgroup.
-
-Returns the message-id of the article.
-
-=item date ()
-
-Returns the date on the remote server. This date will be in a UNIX time
-format (seconds since 1970)
-
-=item postok ()
-
-C<postok> will return I<true> if the servers initial response indicated
-that it will allow posting.
-
-=item authinfo ( USER, PASS )
-
-Authenticates to the server (using AUTHINFO USER / AUTHINFO PASS)
-using the supplied username and password. Please note that the
-password is sent in clear text to the server. This command should not
-be used with valuable passwords unless the connection to the server is
-somehow protected.
-
-=item list ()
-
-Obtain information about all the active newsgroups. The results is a reference
-to a hash where the key is a group name and each value is a reference to an
-array. The elements in this array are:- the last article number in the group,
-the first article number in the group and any information flags about the group.
-
-=item newgroups ( SINCE [, DISTRIBUTIONS ])
-
-C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution
-pattern or a reference to a list of distribution patterns.
-The result is the same as C<list>, but the
-groups return will be limited to those created after C<SINCE> and, if
-specified, in one of the distribution areas in C<DISTRIBUTIONS>.
-
-=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]])
-
-C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference
-to a list of group patterns. C<DISTRIBUTIONS> is either a distribution
-pattern or a reference to a list of distribution patterns.
-
-Returns a reference to a list which contains the message-ids of all news posted
-after C<SINCE>, that are in a groups which matched C<GROUPS> and a
-distribution which matches C<DISTRIBUTIONS>.
-
-=item next ()
-
-Set the "current article pointer" to the next article in the current
-newsgroup.
-
-Returns the message-id of the article.
-
-=item post ( [ MESSAGE ] )
-
-Post a new article to the news server. If C<MESSAGE> is specified and posting
-is allowed then the message will be sent.
-
-If C<MESSAGE> is not specified then the message must be sent using the
-C<datasend> and C<dataend> methods from L<Net::Cmd>
-
-C<MESSAGE> can be either an array of lines or a reference to an array.
-
-The message, either sent via C<datasend> or as the C<MESSAGE>
-parameter, must be in the format as described by RFC822 and must
-contain From:, Newsgroups: and Subject: headers.
-
-=item postfh ()
-
-Post a new article to the news server using a tied filehandle. If
-posting is allowed, this method will return a tied filehandle that you
-can print() the contents of the article to be posted. You must
-explicitly close() the filehandle when you are finished posting the
-article, and the return value from the close() call will indicate
-whether the message was successfully posted.
-
-=item slave ()
-
-Tell the remote server that I am not a user client, but probably another
-news server.
-
-=item quit ()
-
-Quit the remote server and close the socket connection.
-
-=back
-
-=head2 Extension methods
-
-These methods use commands that are not part of the RFC977 documentation. Some
-servers may not support all of them.
-
-=over 4
-
-=item newsgroups ( [ PATTERN ] )
-
-Returns a reference to a hash where the keys are all the group names which
-match C<PATTERN>, or all of the groups if no pattern is specified, and
-each value contains the description text for the group.
-
-=item distributions ()
-
-Returns a reference to a hash where the keys are all the possible
-distribution names and the values are the distribution descriptions.
-
-=item subscriptions ()
-
-Returns a reference to a list which contains a list of groups which
-are recommended for a new user to subscribe to.
-
-=item overview_fmt ()
-
-Returns a reference to an array which contain the names of the fields returned
-by C<xover>.
-
-=item active_times ()
-
-Returns a reference to a hash where the keys are the group names and each
-value is a reference to an array containing the time the groups was created
-and an identifier, possibly an Email address, of the creator.
-
-=item active ( [ PATTERN ] )
-
-Similar to C<list> but only active groups that match the pattern are returned.
-C<PATTERN> can be a group pattern.
-
-=item xgtitle ( PATTERN )
-
-Returns a reference to a hash where the keys are all the group names which
-match C<PATTERN> and each value is the description text for the group.
-
-=item xhdr ( HEADER, MESSAGE-SPEC )
-
-Obtain the header field C<HEADER> for all the messages specified.
-
-The return value will be a reference
-to a hash where the keys are the message numbers and each value contains
-the text of the requested header for that message.
-
-=item xover ( MESSAGE-SPEC )
-
-The return value will be a reference
-to a hash where the keys are the message numbers and each value contains
-a reference to an array which contains the overview fields for that
-message.
-
-The names of the fields can be obtained by calling C<overview_fmt>.
-
-=item xpath ( MESSAGE-ID )
-
-Returns the path name to the file on the server which contains the specified
-message.
-
-=item xpat ( HEADER, PATTERN, MESSAGE-SPEC)
-
-The result is the same as C<xhdr> except the is will be restricted to
-headers where the text of the header matches C<PATTERN>
-
-=item xrover
-
-The XROVER command returns reference information for the article(s)
-specified.
-
-Returns a reference to a HASH where the keys are the message numbers and the
-values are the References: lines from the articles
-
-=item listgroup ( [ GROUP ] )
-
-Returns a reference to a list of all the active messages in C<GROUP>, or
-the current group if C<GROUP> is not specified.
-
-=item reader
-
-Tell the server that you are a reader and not another server.
-
-This is required by some servers. For example if you are connecting to
-an INN server and you have transfer permission your connection will
-be connected to the transfer daemon, not the NNTP daemon. Issuing
-this command will cause the transfer daemon to hand over control
-to the NNTP daemon.
-
-Some servers do not understand this command, but issuing it and ignoring
-the response is harmless.
-
-=back
-
-=head1 UNSUPPORTED
-
-The following NNTP command are unsupported by the package, and there are
-no plans to do so.
-
- AUTHINFO GENERIC
- XTHREAD
- XSEARCH
- XINDEX
-
-=head1 DEFINITIONS
-
-=over 4
-
-=item MESSAGE-SPEC
-
-C<MESSAGE-SPEC> is either a single message-id, a single message number, or
-a reference to a list of two message numbers.
-
-If C<MESSAGE-SPEC> is a reference to a list of two message numbers and the
-second number in a range is less than or equal to the first then the range
-represents all messages in the group after the first message number.
-
-B<NOTE> For compatibility reasons only with earlier versions of Net::NNTP
-a message spec can be passed as a list of two numbers, this is deprecated
-and a reference to the list should now be passed
-
-=item PATTERN
-
-The C<NNTP> protocol uses the C<WILDMAT> format for patterns.
-The WILDMAT format was first developed by Rich Salz based on
-the format used in the UNIX "find" command to articulate
-file names. It was developed to provide a uniform mechanism
-for matching patterns in the same manner that the UNIX shell
-matches filenames.
-
-Patterns are implicitly anchored at the
-beginning and end of each string when testing for a match.
-
-There are five pattern matching operations other than a strict
-one-to-one match between the pattern and the source to be
-checked for a match.
-
-The first is an asterisk C<*> to match any sequence of zero or more
-characters.
-
-The second is a question mark C<?> to match any single character. The
-third specifies a specific set of characters.
-
-The set is specified as a list of characters, or as a range of characters
-where the beginning and end of the range are separated by a minus (or dash)
-character, or as any combination of lists and ranges. The dash can
-also be included in the set as a character it if is the beginning
-or end of the set. This set is enclosed in square brackets. The
-close square bracket C<]> may be used in a set if it is the first
-character in the set.
-
-The fourth operation is the same as the
-logical not of the third operation and is specified the same
-way as the third with the addition of a caret character C<^> at
-the beginning of the test string just inside the open square
-bracket.
-
-The final operation uses the backslash character to
-invalidate the special meaning of an open square bracket C<[>,
-the asterisk, backslash or the question mark. Two backslashes in
-sequence will result in the evaluation of the backslash as a
-character with no special meaning.
-
-=over 4
-
-=item Examples
-
-=item C<[^]-]>
-
-matches any single character other than a close square
-bracket or a minus sign/dash.
-
-=item C<*bdc>
-
-matches any string that ends with the string "bdc"
-including the string "bdc" (without quotes).
-
-=item C<[0-9a-zA-Z]>
-
-matches any single printable alphanumeric ASCII character.
-
-=item C<a??d>
-
-matches any four character string which begins
-with a and ends with d.
-
-=back
-
-=back
-
-=head1 SEE ALSO
-
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr at pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1997 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/Netrc.pm
===================================================================
--- trunk/contrib/perl/lib/Net/Netrc.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/Netrc.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,325 +0,0 @@
-# Net::Netrc.pm
-#
-# Copyright (c) 1995-1998 Graham Barr <gbarr at pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Netrc;
-
-use Carp;
-use strict;
-use FileHandle;
-use vars qw($VERSION);
-
-$VERSION = "2.12";
-
-my %netrc = ();
-
-
-sub _readrc {
- my $host = shift;
- my ($home, $file);
-
- if ($^O eq "MacOS") {
- $home = $ENV{HOME} || `pwd`;
- chomp($home);
- $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
- }
- else {
-
- # Some OS's don't have `getpwuid', so we default to $ENV{HOME}
- $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
- $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE};
- $file = $home . "/.netrc";
- }
-
- my ($login, $pass, $acct) = (undef, undef, undef);
- my $fh;
- local $_;
-
- $netrc{default} = undef;
-
- # OS/2 and Win32 do not handle stat in a way compatable with this check :-(
- unless ($^O eq 'os2'
- || $^O eq 'MSWin32'
- || $^O eq 'MacOS'
- || $^O =~ /^cygwin/)
- {
- my @stat = stat($file);
-
- if (@stat) {
- if ($stat[2] & 077) {
- carp "Bad permissions: $file";
- return;
- }
- if ($stat[4] != $<) {
- carp "Not owner: $file";
- return;
- }
- }
- }
-
- if ($fh = FileHandle->new($file, "r")) {
- my ($mach, $macdef, $tok, @tok) = (0, 0);
-
- while (<$fh>) {
- undef $macdef if /\A\n\Z/;
-
- if ($macdef) {
- push(@$macdef, $_);
- next;
- }
-
- s/^\s*//;
- chomp;
-
- while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) {
- (my $tok = $+) =~ s/\\(.)/$1/g;
- push(@tok, $tok);
- }
-
- TOKEN:
- while (@tok) {
- if ($tok[0] eq "default") {
- shift(@tok);
- $mach = bless {};
- $netrc{default} = [$mach];
-
- next TOKEN;
- }
-
- last TOKEN
- unless @tok > 1;
-
- $tok = shift(@tok);
-
- if ($tok eq "machine") {
- my $host = shift @tok;
- $mach = bless {machine => $host};
-
- $netrc{$host} = []
- unless exists($netrc{$host});
- push(@{$netrc{$host}}, $mach);
- }
- elsif ($tok =~ /^(login|password|account)$/) {
- next TOKEN unless $mach;
- my $value = shift @tok;
-
- # Following line added by rmerrell to remove '/' escape char in .netrc
- $value =~ s/\/\\/\\/g;
- $mach->{$1} = $value;
- }
- elsif ($tok eq "macdef") {
- next TOKEN unless $mach;
- my $value = shift @tok;
- $mach->{macdef} = {}
- unless exists $mach->{macdef};
- $macdef = $mach->{machdef}{$value} = [];
- }
- }
- }
- $fh->close();
- }
-}
-
-
-sub lookup {
- my ($pkg, $mach, $login) = @_;
-
- _readrc()
- unless exists $netrc{default};
-
- $mach ||= 'default';
- undef $login
- if $mach eq 'default';
-
- if (exists $netrc{$mach}) {
- if (defined $login) {
- my $m;
- foreach $m (@{$netrc{$mach}}) {
- return $m
- if (exists $m->{login} && $m->{login} eq $login);
- }
- return undef;
- }
- return $netrc{$mach}->[0];
- }
-
- return $netrc{default}->[0]
- if defined $netrc{default};
-
- return undef;
-}
-
-
-sub login {
- my $me = shift;
-
- exists $me->{login}
- ? $me->{login}
- : undef;
-}
-
-
-sub account {
- my $me = shift;
-
- exists $me->{account}
- ? $me->{account}
- : undef;
-}
-
-
-sub password {
- my $me = shift;
-
- exists $me->{password}
- ? $me->{password}
- : undef;
-}
-
-
-sub lpa {
- my $me = shift;
- ($me->login, $me->password, $me->account);
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Netrc - OO interface to users netrc file
-
-=head1 SYNOPSIS
-
- use Net::Netrc;
-
- $mach = Net::Netrc->lookup('some.machine');
- $login = $mach->login;
- ($login, $password, $account) = $mach->lpa;
-
-=head1 DESCRIPTION
-
-C<Net::Netrc> is a class implementing a simple interface to the .netrc file
-used as by the ftp program.
-
-C<Net::Netrc> also implements security checks just like the ftp program,
-these checks are, first that the .netrc file must be owned by the user and
-second the ownership permissions should be such that only the owner has
-read and write access. If these conditions are not met then a warning is
-output and the .netrc file is not read.
-
-=head1 THE .netrc FILE
-
-The .netrc file contains login and initialization information used by the
-auto-login process. It resides in the user's home directory. The following
-tokens are recognized; they may be separated by spaces, tabs, or new-lines:
-
-=over 4
-
-=item machine name
-
-Identify a remote machine name. The auto-login process searches
-the .netrc file for a machine token that matches the remote machine
-specified. Once a match is made, the subsequent .netrc tokens
-are processed, stopping when the end of file is reached or an-
-other machine or a default token is encountered.
-
-=item default
-
-This is the same as machine name except that default matches
-any name. There can be only one default token, and it must be
-after all machine tokens. This is normally used as:
-
- default login anonymous password user at site
-
-thereby giving the user automatic anonymous login to machines
-not specified in .netrc.
-
-=item login name
-
-Identify a user on the remote machine. If this token is present,
-the auto-login process will initiate a login using the
-specified name.
-
-=item password string
-
-Supply a password. If this token is present, the auto-login
-process will supply the specified string if the remote server
-requires a password as part of the login process.
-
-=item account string
-
-Supply an additional account password. If this token is present,
-the auto-login process will supply the specified string
-if the remote server requires an additional account password.
-
-=item macdef name
-
-Define a macro. C<Net::Netrc> only parses this field to be compatible
-with I<ftp>.
-
-=back
-
-=head1 CONSTRUCTOR
-
-The constructor for a C<Net::Netrc> object is not called new as it does not
-really create a new object. But instead is called C<lookup> as this is
-essentially what it does.
-
-=over 4
-
-=item lookup ( MACHINE [, LOGIN ])
-
-Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
-then the entry returned will have the given login. If C<LOGIN> is not given then
-the first entry in the .netrc file for C<MACHINE> will be returned.
-
-If a matching entry cannot be found, and a default entry exists, then a
-reference to the default entry is returned.
-
-If there is no matching entry found and there is no default defined, or
-no .netrc file is found, then C<undef> is returned.
-
-=back
-
-=head1 METHODS
-
-=over 4
-
-=item login ()
-
-Return the login id for the netrc entry
-
-=item password ()
-
-Return the password for the netrc entry
-
-=item account ()
-
-Return the account information for the netrc entry
-
-=item lpa ()
-
-Return a list of login, password and account information fir the netrc entry
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr at pobox.com>
-
-=head1 SEE ALSO
-
-L<Net::Netrc>
-L<Net::Cmd>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-1998 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/POP3.pm
===================================================================
--- trunk/contrib/perl/lib/Net/POP3.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/POP3.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,742 +0,0 @@
-# Net::POP3.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::POP3;
-
-use strict;
-use IO::Socket;
-use vars qw(@ISA $VERSION $debug);
-use Net::Cmd;
-use Carp;
-use Net::Config;
-
-$VERSION = "2.29";
-
- at ISA = qw(Net::Cmd IO::Socket::INET);
-
-
-sub new {
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host, %arg);
- if (@_ % 2) {
- $host = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $host = delete $arg{Host};
- }
- my $hosts = defined $host ? [$host] : $NetConfig{pop3_hosts};
- my $obj;
- my @localport = exists $arg{ResvPort} ? (LocalPort => $arg{ResvPort}) : ();
-
- my $h;
- foreach $h (@{$hosts}) {
- $obj = $type->SUPER::new(
- PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'pop3(110)',
- Proto => 'tcp',
- @localport,
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- and last;
- }
-
- return undef
- unless defined $obj;
-
- ${*$obj}{'net_pop3_host'} = $host;
-
- $obj->autoflush(1);
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK) {
- $obj->close();
- return undef;
- }
-
- ${*$obj}{'net_pop3_banner'} = $obj->message;
-
- $obj;
-}
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_pop3_host'};
-}
-
-##
-## We don't want people sending me their passwords when they report problems
-## now do we :-)
-##
-
-
-sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }
-
-
-sub login {
- @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
- my ($me, $user, $pass) = @_;
-
- if (@_ <= 2) {
- ($user, $pass) = $me->_lookup_credentials($user);
- }
-
- $me->user($user)
- and $me->pass($pass);
-}
-
-
-sub apop {
- @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
- my ($me, $user, $pass) = @_;
- my $banner;
- my $md;
-
- if (eval { local $SIG{__DIE__}; require Digest::MD5 }) {
- $md = Digest::MD5->new();
- }
- elsif (eval { local $SIG{__DIE__}; require MD5 }) {
- $md = MD5->new();
- }
- else {
- carp "You need to install Digest::MD5 or MD5 to use the APOP command";
- return undef;
- }
-
- return undef
- unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]);
-
- if (@_ <= 2) {
- ($user, $pass) = $me->_lookup_credentials($user);
- }
-
- $md->add($banner, $pass);
-
- return undef
- unless ($me->_APOP($user, $md->hexdigest));
-
- $me->_get_mailbox_count();
-}
-
-
-sub user {
- @_ == 2 or croak 'usage: $pop3->user( USER )';
- $_[0]->_USER($_[1]) ? 1 : undef;
-}
-
-
-sub pass {
- @_ == 2 or croak 'usage: $pop3->pass( PASS )';
-
- my ($me, $pass) = @_;
-
- return undef
- unless ($me->_PASS($pass));
-
- $me->_get_mailbox_count();
-}
-
-
-sub reset {
- @_ == 1 or croak 'usage: $obj->reset()';
-
- my $me = shift;
-
- return 0
- unless ($me->_RSET);
-
- if (defined ${*$me}{'net_pop3_mail'}) {
- local $_;
- foreach (@{${*$me}{'net_pop3_mail'}}) {
- delete $_->{'net_pop3_deleted'};
- }
- }
-}
-
-
-sub last {
- @_ == 1 or croak 'usage: $obj->last()';
-
- return undef
- unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;
-
- return $1;
-}
-
-
-sub top {
- @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
- my $me = shift;
-
- return undef
- unless $me->_TOP($_[0], $_[1] || 0);
-
- $me->read_until_dot;
-}
-
-
-sub popstat {
- @_ == 1 or croak 'usage: $pop3->popstat()';
- my $me = shift;
-
- return ()
- unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;
-
- ($1 || 0, $2 || 0);
-}
-
-
-sub list {
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
- my $me = shift;
-
- return undef
- unless $me->_LIST(@_);
-
- if (@_) {
- $me->message =~ /\d+\D+(\d+)/;
- return $1 || undef;
- }
-
- my $info = $me->read_until_dot
- or return undef;
-
- my %hash = map { (/(\d+)\D+(\d+)/) } @$info;
-
- return \%hash;
-}
-
-
-sub get {
- @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
- my $me = shift;
-
- return undef
- unless $me->_RETR(shift);
-
- $me->read_until_dot(@_);
-}
-
-
-sub getfh {
- @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )';
- my $me = shift;
-
- return unless $me->_RETR(shift);
- return $me->tied_fh;
-}
-
-
-sub delete {
- @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
- my $me = shift;
- return 0 unless $me->_DELE(@_);
- ${*$me}{'net_pop3_deleted'} = 1;
-}
-
-
-sub uidl {
- @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
- my $me = shift;
- my $uidl;
-
- $me->_UIDL(@_)
- or return undef;
- if (@_) {
- $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
- }
- else {
- my $ref = $me->read_until_dot
- or return undef;
- my $ln;
- $uidl = {};
- foreach $ln (@$ref) {
- my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
- $uidl->{$msg} = $uid;
- }
- }
- return $uidl;
-}
-
-
-sub ping {
- @_ == 2 or croak 'usage: $pop3->ping( USER )';
- my $me = shift;
-
- return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;
-
- ($1 || 0, $2 || 0);
-}
-
-
-sub _lookup_credentials {
- my ($me, $user) = @_;
-
- require Net::Netrc;
-
- $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] }
- || $ENV{NAME}
- || $ENV{USER}
- || $ENV{LOGNAME};
-
- my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user);
- $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});
-
- my $pass = $m
- ? $m->password || ""
- : "";
-
- ($user, $pass);
-}
-
-
-sub _get_mailbox_count {
- my ($me) = @_;
- my $ret = ${*$me}{'net_pop3_count'} =
- ($me->message =~ /(\d+)\s+message/io) ? $1 : ($me->popstat)[0];
-
- $ret ? $ret : "0E0";
-}
-
-
-sub _STAT { shift->command('STAT')->response() == CMD_OK }
-sub _LIST { shift->command('LIST', @_)->response() == CMD_OK }
-sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK }
-sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK }
-sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
-sub _RSET { shift->command('RSET')->response() == CMD_OK }
-sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
-sub _TOP { shift->command('TOP', @_)->response() == CMD_OK }
-sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK }
-sub _USER { shift->command('USER', $_[0])->response() == CMD_OK }
-sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK }
-sub _APOP { shift->command('APOP', @_)->response() == CMD_OK }
-sub _PING { shift->command('PING', $_[0])->response() == CMD_OK }
-
-
-sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK }
-sub _LAST { shift->command('LAST')->response() == CMD_OK }
-
-
-sub _CAPA { shift->command('CAPA')->response() == CMD_OK }
-
-
-sub quit {
- my $me = shift;
-
- $me->_QUIT;
- $me->close;
-}
-
-
-sub DESTROY {
- my $me = shift;
-
- if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) {
- $me->reset;
- $me->quit;
- }
-}
-
-##
-## POP3 has weird responses, so we emulate them to look the same :-)
-##
-
-
-sub response {
- my $cmd = shift;
- my $str = $cmd->getline() or return undef;
- my $code = "500";
-
- $cmd->debug_print(0, $str)
- if ($cmd->debug);
-
- if ($str =~ s/^\+OK\s*//io) {
- $code = "200";
- }
- elsif ($str =~ s/^\+\s*//io) {
- $code = "300";
- }
- else {
- $str =~ s/^-ERR\s*//io;
- }
-
- ${*$cmd}{'net_cmd_resp'} = [$str];
- ${*$cmd}{'net_cmd_code'} = $code;
-
- substr($code, 0, 1);
-}
-
-
-sub capa {
- my $this = shift;
- my ($capa, %capabilities);
-
- # Fake a capability here
- $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/);
-
- if ($this->_CAPA()) {
- $capabilities{CAPA} = 1;
- $capa = $this->read_until_dot();
- %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa);
- }
- else {
-
- # Check AUTH for SASL capabilities
- if ($this->command('AUTH')->response() == CMD_OK) {
- my $mechanism = $this->read_until_dot();
- $capabilities{SASL} = join " ", map {m/([A-Z0-9_-]+)/} @{$mechanism};
- }
- }
-
- return ${*$this}{'net_pop3e_capabilities'} = \%capabilities;
-}
-
-
-sub capabilities {
- my $this = shift;
-
- ${*$this}{'net_pop3e_capabilities'} || $this->capa;
-}
-
-
-sub auth {
- my ($self, $username, $password) = @_;
-
- eval {
- require MIME::Base64;
- require Authen::SASL;
- } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
-
- my $capa = $self->capa;
- my $mechanisms = $capa->{SASL} || 'CRAM-MD5';
-
- my $sasl;
-
- if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
- $sasl = $username;
- my $user_mech = $sasl->mechanism || '';
- my @user_mech = split(/\s+/, $user_mech);
- my %user_mech;
- @user_mech{@user_mech} = ();
-
- my @server_mech = split(/\s+/, $mechanisms);
- my @mech = @user_mech
- ? grep { exists $user_mech{$_} } @server_mech
- : @server_mech;
- unless (@mech) {
- $self->set_status(
- 500,
- [ 'Client SASL mechanisms (',
- join(', ', @user_mech),
- ') do not match the SASL mechnism the server announces (',
- join(', ', @server_mech), ')',
- ]
- );
- return 0;
- }
-
- $sasl->mechanism(join(" ", @mech));
- }
- else {
- die "auth(username, password)" if not length $username;
- $sasl = Authen::SASL->new(
- mechanism => $mechanisms,
- callback => {
- user => $username,
- pass => $password,
- authname => $username,
- }
- );
- }
-
- # We should probably allow the user to pass the host, but I don't
- # currently know and SASL mechanisms that are used by smtp that need it
- my ($hostname) = split /:/, ${*$self}{'net_pop3_host'};
- my $client = eval { $sasl->client_new('pop', $hostname, 0) };
-
- unless ($client) {
- my $mech = $sasl->mechanism;
- $self->set_status(
- 500,
- [ " Authen::SASL failure: $@",
- '(please check if your local Authen::SASL installation',
- "supports mechanism '$mech'"
- ]
- );
- return 0;
- }
-
- my ($token) = $client->client_start
- or do {
- my $mech = $client->mechanism;
- $self->set_status(
- 500,
- [ ' Authen::SASL failure: $client->client_start ',
- "mechanism '$mech' hostname #$hostname#",
- $client->error
- ]
- );
- return 0;
- };
-
- # We dont support sasl mechanisms that encrypt the socket traffic.
- # todo that we would really need to change the ISA hierarchy
- # so we dont inherit from IO::Socket, but instead hold it in an attribute
-
- my @cmd = ("AUTH", $client->mechanism);
- my $code;
-
- push @cmd, MIME::Base64::encode_base64($token, '')
- if defined $token and length $token;
-
- while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
-
- my ($token) = $client->client_step(MIME::Base64::decode_base64(($self->message)[0])) or do {
- $self->set_status(
- 500,
- [ ' Authen::SASL failure: $client->client_step ',
- "mechanism '", $client->mechanism, " hostname #$hostname#, ",
- $client->error
- ]
- );
- return 0;
- };
-
- @cmd = (MIME::Base64::encode_base64(defined $token ? $token : '', ''));
- }
-
- $code == CMD_OK;
-}
-
-
-sub banner {
- my $this = shift;
-
- return ${*$this}{'net_pop3_banner'};
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::POP3 - Post Office Protocol 3 Client class (RFC1939)
-
-=head1 SYNOPSIS
-
- use Net::POP3;
-
- # Constructors
- $pop = Net::POP3->new('pop3host');
- $pop = Net::POP3->new('pop3host', Timeout => 60);
-
- if ($pop->login($username, $password) > 0) {
- my $msgnums = $pop->list; # hashref of msgnum => size
- foreach my $msgnum (keys %$msgnums) {
- my $msg = $pop->get($msgnum);
- print @$msg;
- $pop->delete($msgnum);
- }
- }
-
- $pop->quit;
-
-=head1 DESCRIPTION
-
-This module implements a client interface to the POP3 protocol, enabling
-a perl5 application to talk to POP3 servers. This documentation assumes
-that you are familiar with the POP3 protocol described in RFC1939.
-
-A new Net::POP3 object must be created with the I<new> method. Once
-this has been done, all POP3 commands are accessed via method calls
-on the object.
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ] 0
-
-This is the constructor for a new Net::POP3 object. C<HOST> is the
-name of the remote host to which an POP3 connection is required.
-
-C<HOST> is optional. If C<HOST> is not given then it may instead be
-passed as the C<Host> option described below. If neither is given then
-the C<POP3_Hosts> specified in C<Net::Config> will be used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Host> - POP3 host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-B<ResvPort> - If given then the socket for the C<Net::POP3> object
-will be bound to the local port given using C<bind> when the socket is
-created.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-POP3 server (default: 120)
-
-B<Debug> - Enable debugging information
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item auth ( USERNAME, PASSWORD )
-
-Attempt SASL authentication.
-
-=item user ( USER )
-
-Send the USER command.
-
-=item pass ( PASS )
-
-Send the PASS command. Returns the number of messages in the mailbox.
-
-=item login ( [ USER [, PASS ]] )
-
-Send both the USER and PASS commands. If C<PASS> is not given the
-C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
-and username. If the username is not specified then the current user name
-will be used.
-
-Returns the number of messages in the mailbox. However if there are no
-messages on the server the string C<"0E0"> will be returned. This is
-will give a true value in a boolean context, but zero in a numeric context.
-
-If there was an error authenticating the user then I<undef> will be returned.
-
-=item apop ( [ USER [, PASS ]] )
-
-Authenticate with the server identifying as C<USER> with password C<PASS>.
-Similar to L</login>, but the password is not sent in clear text.
-
-To use this method you must have the Digest::MD5 or the MD5 module installed,
-otherwise this method will return I<undef>.
-
-=item banner ()
-
-Return the sever's connection banner
-
-=item capa ()
-
-Return a reference to a hash of the capabilities of the server. APOP
-is added as a pseudo capability. Note that I've been unable to
-find a list of the standard capability values, and some appear to
-be multi-word and some are not. We make an attempt at intelligently
-parsing them, but it may not be correct.
-
-=item capabilities ()
-
-Just like capa, but only uses a cache from the last time we asked
-the server, so as to avoid asking more than once.
-
-=item top ( MSGNUM [, NUMLINES ] )
-
-Get the header and the first C<NUMLINES> of the body for the message
-C<MSGNUM>. Returns a reference to an array which contains the lines of text
-read from the server.
-
-=item list ( [ MSGNUM ] )
-
-If called with an argument the C<list> returns the size of the message
-in octets.
-
-If called without arguments a reference to a hash is returned. The
-keys will be the C<MSGNUM>'s of all undeleted messages and the values will
-be their size in octets.
-
-=item get ( MSGNUM [, FH ] )
-
-Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
-then get returns a reference to an array which contains the lines of
-text read from the server. If C<FH> is given then the lines returned
-from the server are printed to the filehandle C<FH>.
-
-=item getfh ( MSGNUM )
-
-As per get(), but returns a tied filehandle. Reading from this
-filehandle returns the requested message. The filehandle will return
-EOF at the end of the message and should not be reused.
-
-=item last ()
-
-Returns the highest C<MSGNUM> of all the messages accessed.
-
-=item popstat ()
-
-Returns a list of two elements. These are the number of undeleted
-elements and the size of the mbox in octets.
-
-=item ping ( USER )
-
-Returns a list of two elements. These are the number of new messages
-and the total number of messages for C<USER>.
-
-=item uidl ( [ MSGNUM ] )
-
-Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
-given C<uidl> returns a reference to a hash where the keys are the
-message numbers and the values are the unique identifiers.
-
-=item delete ( MSGNUM )
-
-Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
-that are marked to be deleted will be removed from the remote mailbox
-when the server connection closed.
-
-=item reset ()
-
-Reset the status of the remote POP3 server. This includes resetting the
-status of all messages to not be deleted.
-
-=item quit ()
-
-Quit and close the connection to the remote POP3 server. Any messages marked
-as deleted will be deleted from the remote mailbox.
-
-=back
-
-=head1 NOTES
-
-If a C<Net::POP3> object goes out of scope before C<quit> method is called
-then the C<reset> method will called before the connection is closed. This
-means that any messages marked to be deleted will not be.
-
-=head1 SEE ALSO
-
-L<Net::Netrc>,
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr at pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2003 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/Ping.pm
===================================================================
--- trunk/contrib/perl/lib/Net/Ping.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/Ping.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1777 +0,0 @@
-package Net::Ping;
-
-require 5.002;
-require Exporter;
-
-use strict;
-use vars qw(@ISA @EXPORT $VERSION
- $def_timeout $def_proto $def_factor
- $max_datasize $pingstring $hires $source_verify $syn_forking);
-use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK );
-use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW PF_INET SOL_SOCKET SO_ERROR
- inet_aton inet_ntoa sockaddr_in );
-use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG );
-use FileHandle;
-use Carp;
-
- at ISA = qw(Exporter);
- at EXPORT = qw(pingecho);
-$VERSION = "2.36";
-
-sub SOL_IP { 0; };
-sub IP_TOS { 1; };
-
-# Constants
-
-$def_timeout = 5; # Default timeout to wait for a reply
-$def_proto = "tcp"; # Default protocol to use for pinging
-$def_factor = 1.2; # Default exponential backoff rate.
-$max_datasize = 1024; # Maximum data bytes in a packet
-# The data we exchange with the server for the stream protocol
-$pingstring = "pingschwingping!\n";
-$source_verify = 1; # Default is to verify source endpoint
-$syn_forking = 0;
-
-if ($^O =~ /Win32/i) {
- # Hack to avoid this Win32 spewage:
- # Your vendor has not defined POSIX macro ECONNREFUSED
- my @pairs = (ECONNREFUSED => 10061, # "Unknown Error" Special Win32 Response?
- ENOTCONN => 10057,
- ECONNRESET => 10054,
- EINPROGRESS => 10036,
- EWOULDBLOCK => 10035,
- );
- while (my $name = shift @pairs) {
- my $value = shift @pairs;
- # When defined, these all are non-zero
- unless (eval $name) {
- no strict 'refs';
- *{$name} = defined prototype \&{$name} ? sub () {$value} : sub {$value};
- }
- }
-# $syn_forking = 1; # XXX possibly useful in < Win2K ?
-};
-
-# h2ph "asm/socket.h"
-# require "asm/socket.ph";
-sub SO_BINDTODEVICE {25;}
-
-# Description: The pingecho() subroutine is provided for backward
-# compatibility with the original Net::Ping. It accepts a host
-# name/IP and an optional timeout in seconds. Create a tcp ping
-# object and try pinging the host. The result of the ping is returned.
-
-sub pingecho
-{
- my ($host, # Name or IP number of host to ping
- $timeout # Optional timeout in seconds
- ) = @_;
- my ($p); # A ping object
-
- $p = Net::Ping->new("tcp", $timeout);
- $p->ping($host); # Going out of scope closes the connection
-}
-
-# Description: The new() method creates a new ping object. Optional
-# parameters may be specified for the protocol to use, the timeout in
-# seconds and the size in bytes of additional data which should be
-# included in the packet.
-# After the optional parameters are checked, the data is constructed
-# and a socket is opened if appropriate. The object is returned.
-
-sub new
-{
- my ($this,
- $proto, # Optional protocol to use for pinging
- $timeout, # Optional timeout in seconds
- $data_size, # Optional additional bytes of data
- $device, # Optional device to use
- $tos, # Optional ToS to set
- ) = @_;
- my $class = ref($this) || $this;
- my $self = {};
- my ($cnt, # Count through data bytes
- $min_datasize # Minimum data bytes required
- );
-
- bless($self, $class);
-
- $proto = $def_proto unless $proto; # Determine the protocol
- croak('Protocol for ping must be "icmp", "udp", "tcp", "syn", "stream", or "external"')
- unless $proto =~ m/^(icmp|udp|tcp|syn|stream|external)$/;
- $self->{"proto"} = $proto;
-
- $timeout = $def_timeout unless $timeout; # Determine the timeout
- croak("Default timeout for ping must be greater than 0 seconds")
- if $timeout <= 0;
- $self->{"timeout"} = $timeout;
-
- $self->{"device"} = $device;
-
- $self->{"tos"} = $tos;
-
- $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
- $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
- croak("Data for ping must be from $min_datasize to $max_datasize bytes")
- if ($data_size < $min_datasize) || ($data_size > $max_datasize);
- $data_size-- if $self->{"proto"} eq "udp"; # We provide the first byte
- $self->{"data_size"} = $data_size;
-
- $self->{"data"} = ""; # Construct data bytes
- for ($cnt = 0; $cnt < $self->{"data_size"}; $cnt++)
- {
- $self->{"data"} .= chr($cnt % 256);
- }
-
- $self->{"local_addr"} = undef; # Don't bind by default
- $self->{"retrans"} = $def_factor; # Default exponential backoff rate
- $self->{"econnrefused"} = undef; # Default Connection refused behavior
-
- $self->{"seq"} = 0; # For counting packets
- if ($self->{"proto"} eq "udp") # Open a socket
- {
- $self->{"proto_num"} = (getprotobyname('udp'))[2] ||
- croak("Can't udp protocol by name");
- $self->{"port_num"} = (getservbyname('echo', 'udp'))[2] ||
- croak("Can't get udp echo port by name");
- $self->{"fh"} = FileHandle->new();
- socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
- $self->{"proto_num"}) ||
- croak("udp socket error - $!");
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak "error binding to device $self->{'device'} $!";
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
- }
- elsif ($self->{"proto"} eq "icmp")
- {
- croak("icmp ping requires root privilege") if ($> and $^O ne 'VMS' and $^O ne 'cygwin');
- $self->{"proto_num"} = (getprotobyname('icmp'))[2] ||
- croak("Can't get icmp protocol by name");
- $self->{"pid"} = $$ & 0xffff; # Save lower 16 bits of pid
- $self->{"fh"} = FileHandle->new();
- socket($self->{"fh"}, PF_INET, SOCK_RAW, $self->{"proto_num"}) ||
- croak("icmp socket error - $!");
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak "error binding to device $self->{'device'} $!";
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
- }
- elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
- {
- $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
- croak("Can't get tcp protocol by name");
- $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
- croak("Can't get tcp echo port by name");
- $self->{"fh"} = FileHandle->new();
- }
- elsif ($self->{"proto"} eq "syn")
- {
- $self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
- croak("Can't get tcp protocol by name");
- $self->{"port_num"} = (getservbyname('echo', 'tcp'))[2] ||
- croak("Can't get tcp echo port by name");
- if ($syn_forking) {
- $self->{"fork_rd"} = FileHandle->new();
- $self->{"fork_wr"} = FileHandle->new();
- pipe($self->{"fork_rd"}, $self->{"fork_wr"});
- $self->{"fh"} = FileHandle->new();
- $self->{"good"} = {};
- $self->{"bad"} = {};
- } else {
- $self->{"wbits"} = "";
- $self->{"bad"} = {};
- }
- $self->{"syn"} = {};
- $self->{"stop_time"} = 0;
- }
- elsif ($self->{"proto"} eq "external")
- {
- # No preliminary work needs to be done.
- }
-
- return($self);
-}
-
-# Description: Set the local IP address from which pings will be sent.
-# For ICMP and UDP pings, this calls bind() on the already-opened socket;
-# for TCP pings, just saves the address to be used when the socket is
-# opened. Returns non-zero if successful; croaks on error.
-sub bind
-{
- my ($self,
- $local_addr # Name or IP number of local interface
- ) = @_;
- my ($ip # Packed IP number of $local_addr
- );
-
- croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2;
- croak("already bound") if defined($self->{"local_addr"}) &&
- ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp");
-
- $ip = inet_aton($local_addr);
- croak("nonexistent local address $local_addr") unless defined($ip);
- $self->{"local_addr"} = $ip; # Only used if proto is tcp
-
- if ($self->{"proto"} eq "udp" || $self->{"proto"} eq "icmp")
- {
- CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
- croak("$self->{'proto'} bind error - $!");
- }
- elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
- {
- croak("Unknown protocol \"$self->{proto}\" in bind()");
- }
-
- return 1;
-}
-
-# Description: A select() wrapper that compensates for platform
-# peculiarities.
-sub mselect
-{
- if ($_[3] > 0 and $^O eq 'MSWin32') {
- # On windows, select() doesn't process the message loop,
- # but sleep() will, allowing alarm() to interrupt the latter.
- # So we chop up the timeout into smaller pieces and interleave
- # select() and sleep() calls.
- my $t = $_[3];
- my $gran = 0.5; # polling granularity in seconds
- my @args = @_;
- while (1) {
- $gran = $t if $gran > $t;
- my $nfound = select($_[0], $_[1], $_[2], $gran);
- undef $nfound if $nfound == -1;
- $t -= $gran;
- return $nfound if $nfound or !defined($nfound) or $t <= 0;
-
- sleep(0);
- ($_[0], $_[1], $_[2]) = @args;
- }
- }
- else {
- my $nfound = select($_[0], $_[1], $_[2], $_[3]);
- undef $nfound if $nfound == -1;
- return $nfound;
- }
-}
-
-# Description: Allow UDP source endpoint comparison to be
-# skipped for those remote interfaces that do
-# not response from the same endpoint.
-
-sub source_verify
-{
- my $self = shift;
- $source_verify = 1 unless defined
- ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self);
-}
-
-# Description: Set whether or not the connect
-# behavior should enforce remote service
-# availability as well as reachability.
-
-sub service_check
-{
- my $self = shift;
- $self->{"econnrefused"} = 1 unless defined
- ($self->{"econnrefused"} = shift());
-}
-
-sub tcp_service_check
-{
- service_check(@_);
-}
-
-# Description: Set exponential backoff for retransmission.
-# Should be > 1 to retain exponential properties.
-# If set to 0, retransmissions are disabled.
-
-sub retrans
-{
- my $self = shift;
- $self->{"retrans"} = shift;
-}
-
-# Description: allows the module to use milliseconds as returned by
-# the Time::HiRes module
-
-$hires = 0;
-sub hires
-{
- my $self = shift;
- $hires = 1 unless defined
- ($hires = ((defined $self) && (ref $self)) ? shift() : $self);
- require Time::HiRes if $hires;
-}
-
-sub time
-{
- return $hires ? Time::HiRes::time() : CORE::time();
-}
-
-# Description: Sets or clears the O_NONBLOCK flag on a file handle.
-sub socket_blocking_mode
-{
- my ($self,
- $fh, # the file handle whose flags are to be modified
- $block) = @_; # if true then set the blocking
- # mode (clear O_NONBLOCK), otherwise
- # set the non-blocking mode (set O_NONBLOCK)
-
- my $flags;
- if ($^O eq 'MSWin32' || $^O eq 'VMS') {
- # FIONBIO enables non-blocking sockets on windows and vms.
- # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h
- my $f = 0x8004667e;
- my $v = pack("L", $block ? 0 : 1);
- ioctl($fh, $f, $v) or croak("ioctl failed: $!");
- return;
- }
- if ($flags = fcntl($fh, F_GETFL, 0)) {
- $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK);
- if (!fcntl($fh, F_SETFL, $flags)) {
- croak("fcntl F_SETFL: $!");
- }
- } else {
- croak("fcntl F_GETFL: $!");
- }
-}
-
-# Description: Ping a host name or IP number with an optional timeout.
-# First lookup the host, and return undef if it is not found. Otherwise
-# perform the specific ping method based on the protocol. Return the
-# result of the ping.
-
-sub ping
-{
- my ($self,
- $host, # Name or IP number of host to ping
- $timeout, # Seconds after which ping times out
- ) = @_;
- my ($ip, # Packed IP number of $host
- $ret, # The return value
- $ping_time, # When ping began
- );
-
- croak("Usage: \$p->ping(\$host [, \$timeout])") unless @_ == 2 || @_ == 3;
- $timeout = $self->{"timeout"} unless $timeout;
- croak("Timeout must be greater than 0 seconds") if $timeout <= 0;
-
- $ip = inet_aton($host);
- return () unless defined($ip); # Does host exist?
-
- # Dispatch to the appropriate routine.
- $ping_time = &time();
- if ($self->{"proto"} eq "external") {
- $ret = $self->ping_external($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "udp") {
- $ret = $self->ping_udp($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "icmp") {
- $ret = $self->ping_icmp($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "tcp") {
- $ret = $self->ping_tcp($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "stream") {
- $ret = $self->ping_stream($ip, $timeout);
- }
- elsif ($self->{"proto"} eq "syn") {
- $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout);
- } else {
- croak("Unknown protocol \"$self->{proto}\" in ping()");
- }
-
- return wantarray ? ($ret, &time() - $ping_time, inet_ntoa($ip)) : $ret;
-}
-
-# Uses Net::Ping::External to do an external ping.
-sub ping_external {
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
-
- eval { require Net::Ping::External; }
- or croak('Protocol "external" not supported on your system: Net::Ping::External not found');
- return Net::Ping::External::ping(ip => $ip, timeout => $timeout);
-}
-
-use constant ICMP_ECHOREPLY => 0; # ICMP packet types
-use constant ICMP_UNREACHABLE => 3; # ICMP packet types
-use constant ICMP_ECHO => 8;
-use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet
-use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY
-use constant ICMP_FLAGS => 0; # No special flags for send or recv
-use constant ICMP_PORT => 0; # No port with ICMP
-
-sub ping_icmp
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
-
- my ($saddr, # sockaddr_in with port and ip
- $checksum, # Checksum of ICMP packet
- $msg, # ICMP packet to send
- $len_msg, # Length of $msg
- $rbits, # Read bits, filehandles for reading
- $nfound, # Number of ready filehandles found
- $finish_time, # Time ping should be finished
- $done, # set to 1 when we are done
- $ret, # Return value
- $recv_msg, # Received message including IP header
- $from_saddr, # sockaddr_in of sender
- $from_port, # Port packet was sent from
- $from_ip, # Packed IP of sender
- $from_type, # ICMP type
- $from_subcode, # ICMP subcode
- $from_chk, # ICMP packet checksum
- $from_pid, # ICMP packet id
- $from_seq, # ICMP packet sequence
- $from_msg # ICMP message
- );
-
- $self->{"seq"} = ($self->{"seq"} + 1) % 65536; # Increment sequence
- $checksum = 0; # No checksum for starters
- $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
- $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
- $checksum = Net::Ping->checksum($msg);
- $msg = pack(ICMP_STRUCT . $self->{"data_size"}, ICMP_ECHO, SUBCODE,
- $checksum, $self->{"pid"}, $self->{"seq"}, $self->{"data"});
- $len_msg = length($msg);
- $saddr = sockaddr_in(ICMP_PORT, $ip);
- $self->{"from_ip"} = undef;
- $self->{"from_type"} = undef;
- $self->{"from_subcode"} = undef;
- send($self->{"fh"}, $msg, ICMP_FLAGS, $saddr); # Send the message
-
- $rbits = "";
- vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
- $ret = 0;
- $done = 0;
- $finish_time = &time() + $timeout; # Must be done by this time
- while (!$done && $timeout > 0) # Keep trying if we have time
- {
- $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet
- $timeout = $finish_time - &time(); # Get remaining time
- if (!defined($nfound)) # Hmm, a strange error
- {
- $ret = undef;
- $done = 1;
- }
- elsif ($nfound) # Got a packet from somewhere
- {
- $recv_msg = "";
- $from_pid = -1;
- $from_seq = -1;
- $from_saddr = recv($self->{"fh"}, $recv_msg, 1500, ICMP_FLAGS);
- ($from_port, $from_ip) = sockaddr_in($from_saddr);
- ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2));
- if ($from_type == ICMP_ECHOREPLY) {
- ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4))
- if length $recv_msg >= 28;
- } else {
- ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4))
- if length $recv_msg >= 56;
- }
- $self->{"from_ip"} = $from_ip;
- $self->{"from_type"} = $from_type;
- $self->{"from_subcode"} = $from_subcode;
- if (($from_pid == $self->{"pid"}) && # Does the packet check out?
- (! $source_verify || (inet_ntoa($from_ip) eq inet_ntoa($ip))) &&
- ($from_seq == $self->{"seq"})) {
- if ($from_type == ICMP_ECHOREPLY) {
- $ret = 1;
- $done = 1;
- } elsif ($from_type == ICMP_UNREACHABLE) {
- $done = 1;
- }
- }
- } else { # Oops, timed out
- $done = 1;
- }
- }
- return $ret;
-}
-
-sub icmp_result {
- my ($self) = @_;
- my $ip = $self->{"from_ip"} || "";
- $ip = "\0\0\0\0" unless 4 == length $ip;
- return (inet_ntoa($ip),($self->{"from_type"} || 0), ($self->{"from_subcode"} || 0));
-}
-
-# Description: Do a checksum on the message. Basically sum all of
-# the short words and fold the high order bits into the low order bits.
-
-sub checksum
-{
- my ($class,
- $msg # The message to checksum
- ) = @_;
- my ($len_msg, # Length of the message
- $num_short, # The number of short words in the message
- $short, # One short word
- $chk # The checksum
- );
-
- $len_msg = length($msg);
- $num_short = int($len_msg / 2);
- $chk = 0;
- foreach $short (unpack("n$num_short", $msg))
- {
- $chk += $short;
- } # Add the odd byte in
- $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2;
- $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low
- return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
-}
-
-
-# Description: Perform a tcp echo ping. Since a tcp connection is
-# host specific, we have to open and close each connection here. We
-# can't just leave a socket open. Because of the robust nature of
-# tcp, it will take a while before it gives up trying to establish a
-# connection. Therefore, we use select() on a non-blocking socket to
-# check against our timeout. No data bytes are actually
-# sent since the successful establishment of a connection is proof
-# enough of the reachability of the remote host. Also, tcp is
-# expensive and doesn't need our help to add to the overhead.
-
-sub ping_tcp
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
- my ($ret # The return value
- );
-
- $! = 0;
- $ret = $self -> tcp_connect( $ip, $timeout);
- if (!$self->{"econnrefused"} &&
- $! == ECONNREFUSED) {
- $ret = 1; # "Connection refused" means reachable
- }
- $self->{"fh"}->close();
- return $ret;
-}
-
-sub tcp_connect
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which connect times out
- ) = @_;
- my ($saddr); # Packed IP and Port
-
- $saddr = sockaddr_in($self->{"port_num"}, $ip);
-
- my $ret = 0; # Default to unreachable
-
- my $do_socket = sub {
- socket($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"}) ||
- croak("tcp socket error - $!");
- if (defined $self->{"local_addr"} &&
- !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
- croak("tcp bind error - $!");
- }
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak("error binding to device $self->{'device'} $!");
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
- };
- my $do_connect = sub {
- $self->{"ip"} = $ip;
- # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?,
- # we'll get (10061 & 255) = 77, so we cannot check it in the parent process.
- return ($ret = connect($self->{"fh"}, $saddr) || ($! == ECONNREFUSED && !$self->{"econnrefused"}));
- };
- my $do_connect_nb = sub {
- # Set O_NONBLOCK property on filehandle
- $self->socket_blocking_mode($self->{"fh"}, 0);
-
- # start the connection attempt
- if (!connect($self->{"fh"}, $saddr)) {
- if ($! == ECONNREFUSED) {
- $ret = 1 unless $self->{"econnrefused"};
- } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) {
- # EINPROGRESS is the expected error code after a connect()
- # on a non-blocking socket. But if the kernel immediately
- # determined that this connect() will never work,
- # Simply respond with "unreachable" status.
- # (This can occur on some platforms with errno
- # EHOSTUNREACH or ENETUNREACH.)
- return 0;
- } else {
- # Got the expected EINPROGRESS.
- # Just wait for connection completion...
- my ($wbits, $wout, $wexc);
- $wout = $wexc = $wbits = "";
- vec($wbits, $self->{"fh"}->fileno, 1) = 1;
-
- my $nfound = mselect(undef,
- ($wout = $wbits),
- ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef),
- $timeout);
- warn("select: $!") unless defined $nfound;
-
- if ($nfound && vec($wout, $self->{"fh"}->fileno, 1)) {
- # the socket is ready for writing so the connection
- # attempt completed. test whether the connection
- # attempt was successful or not
-
- if (getpeername($self->{"fh"})) {
- # Connection established to remote host
- $ret = 1;
- } else {
- # TCP ACK will never come from this host
- # because there was an error connecting.
-
- # This should set $! to the correct error.
- my $char;
- sysread($self->{"fh"},$char,1);
- $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i);
-
- $ret = 1 if (!$self->{"econnrefused"}
- && $! == ECONNREFUSED);
- }
- } else {
- # the connection attempt timed out (or there were connect
- # errors on Windows)
- if ($^O =~ 'MSWin32') {
- # If the connect will fail on a non-blocking socket,
- # winsock reports ECONNREFUSED as an exception, and we
- # need to fetch the socket-level error code via getsockopt()
- # instead of using the thread-level error code that is in $!.
- if ($nfound && vec($wexc, $self->{"fh"}->fileno, 1)) {
- $! = unpack("i", getsockopt($self->{"fh"}, SOL_SOCKET,
- SO_ERROR));
- }
- }
- }
- }
- } else {
- # Connection established to remote host
- $ret = 1;
- }
-
- # Unset O_NONBLOCK property on filehandle
- $self->socket_blocking_mode($self->{"fh"}, 1);
- $self->{"ip"} = $ip;
- return $ret;
- };
-
- if ($syn_forking) {
- # Buggy Winsock API doesn't allow nonblocking connect.
- # Hence, if our OS is Windows, we need to create a separate
- # process to do the blocking connect attempt.
- # XXX Above comments are not true at least for Win2K, where
- # nonblocking connect works.
-
- $| = 1; # Clear buffer prior to fork to prevent duplicate flushing.
- $self->{'tcp_chld'} = fork;
- if (!$self->{'tcp_chld'}) {
- if (!defined $self->{'tcp_chld'}) {
- # Fork did not work
- warn "Fork error: $!";
- return 0;
- }
- &{ $do_socket }();
-
- # Try a slow blocking connect() call
- # and report the status to the parent.
- if ( &{ $do_connect }() ) {
- $self->{"fh"}->close();
- # No error
- exit 0;
- } else {
- # Pass the error status to the parent
- # Make sure that $! <= 255
- exit($! <= 255 ? $! : 255);
- }
- }
-
- &{ $do_socket }();
-
- my $patience = &time() + $timeout;
-
- my ($child, $child_errno);
- $? = 0; $child_errno = 0;
- # Wait up to the timeout
- # And clean off the zombie
- do {
- $child = waitpid($self->{'tcp_chld'}, &WNOHANG());
- $child_errno = $? >> 8;
- select(undef, undef, undef, 0.1);
- } while &time() < $patience && $child != $self->{'tcp_chld'};
-
- if ($child == $self->{'tcp_chld'}) {
- if ($self->{"proto"} eq "stream") {
- # We need the socket connected here, in parent
- # Should be safe to connect because the child finished
- # within the timeout
- &{ $do_connect }();
- }
- # $ret cannot be set by the child process
- $ret = !$child_errno;
- } else {
- # Time must have run out.
- # Put that choking client out of its misery
- kill "KILL", $self->{'tcp_chld'};
- # Clean off the zombie
- waitpid($self->{'tcp_chld'}, 0);
- $ret = 0;
- }
- delete $self->{'tcp_chld'};
- $! = $child_errno;
- } else {
- # Otherwise don't waste the resources to fork
-
- &{ $do_socket }();
-
- &{ $do_connect_nb }();
- }
-
- return $ret;
-}
-
-sub DESTROY {
- my $self = shift;
- if ($self->{'proto'} eq 'tcp' &&
- $self->{'tcp_chld'}) {
- # Put that choking client out of its misery
- kill "KILL", $self->{'tcp_chld'};
- # Clean off the zombie
- waitpid($self->{'tcp_chld'}, 0);
- }
-}
-
-# This writes the given string to the socket and then reads it
-# back. It returns 1 on success, 0 on failure.
-sub tcp_echo
-{
- my $self = shift;
- my $timeout = shift;
- my $pingstring = shift;
-
- my $ret = undef;
- my $time = &time();
- my $wrstr = $pingstring;
- my $rdstr = "";
-
- eval <<'EOM';
- do {
- my $rin = "";
- vec($rin, $self->{"fh"}->fileno(), 1) = 1;
-
- my $rout = undef;
- if($wrstr) {
- $rout = "";
- vec($rout, $self->{"fh"}->fileno(), 1) = 1;
- }
-
- if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) {
-
- if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
- my $num = syswrite($self->{"fh"}, $wrstr, length $wrstr);
- if($num) {
- # If it was a partial write, update and try again.
- $wrstr = substr($wrstr,$num);
- } else {
- # There was an error.
- $ret = 0;
- }
- }
-
- if(vec($rin,$self->{"fh"}->fileno(),1)) {
- my $reply;
- if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
- $rdstr .= $reply;
- $ret = 1 if $rdstr eq $pingstring;
- } else {
- # There was an error.
- $ret = 0;
- }
- }
-
- }
- } until &time() > ($time + $timeout) || defined($ret);
-EOM
-
- return $ret;
-}
-
-
-
-
-# Description: Perform a stream ping. If the tcp connection isn't
-# already open, it opens it. It then sends some data and waits for
-# a reply. It leaves the stream open on exit.
-
-sub ping_stream
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
-
- # Open the stream if it's not already open
- if(!defined $self->{"fh"}->fileno()) {
- $self->tcp_connect($ip, $timeout) or return 0;
- }
-
- croak "tried to switch servers while stream pinging"
- if $self->{"ip"} ne $ip;
-
- return $self->tcp_echo($timeout, $pingstring);
-}
-
-# Description: opens the stream. You would do this if you want to
-# separate the overhead of opening the stream from the first ping.
-
-sub open
-{
- my ($self,
- $host, # Host or IP address
- $timeout # Seconds after which open times out
- ) = @_;
-
- my ($ip); # Packed IP number of the host
- $ip = inet_aton($host);
- $timeout = $self->{"timeout"} unless $timeout;
-
- if($self->{"proto"} eq "stream") {
- if(defined($self->{"fh"}->fileno())) {
- croak("socket is already open");
- } else {
- $self->tcp_connect($ip, $timeout);
- }
- }
-}
-
-
-# Description: Perform a udp echo ping. Construct a message of
-# at least the one-byte sequence number and any additional data bytes.
-# Send the message out and wait for a message to come back. If we
-# get a message, make sure all of its parts match. If they do, we are
-# done. Otherwise go back and wait for the message until we run out
-# of time. Return the result of our efforts.
-
-use constant UDP_FLAGS => 0; # Nothing special on send or recv
-sub ping_udp
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
-
- my ($saddr, # sockaddr_in with port and ip
- $ret, # The return value
- $msg, # Message to be echoed
- $finish_time, # Time ping should be finished
- $flush, # Whether socket needs to be disconnected
- $connect, # Whether socket needs to be connected
- $done, # Set to 1 when we are done pinging
- $rbits, # Read bits, filehandles for reading
- $nfound, # Number of ready filehandles found
- $from_saddr, # sockaddr_in of sender
- $from_msg, # Characters echoed by $host
- $from_port, # Port message was echoed from
- $from_ip # Packed IP number of sender
- );
-
- $saddr = sockaddr_in($self->{"port_num"}, $ip);
- $self->{"seq"} = ($self->{"seq"} + 1) % 256; # Increment sequence
- $msg = chr($self->{"seq"}) . $self->{"data"}; # Add data if any
-
- if ($self->{"connected"}) {
- if ($self->{"connected"} ne $saddr) {
- # Still connected to wrong destination.
- # Need to flush out the old one.
- $flush = 1;
- }
- } else {
- # Not connected yet.
- # Need to connect() before send()
- $connect = 1;
- }
-
- # Have to connect() and send() instead of sendto()
- # in order to pick up on the ECONNREFUSED setting
- # from recv() or double send() errno as utilized in
- # the concept by rdw @ perlmonks. See:
- # http://perlmonks.thepen.com/42898.html
- if ($flush) {
- # Need to socket() again to flush the descriptor
- # This will disconnect from the old saddr.
- socket($self->{"fh"}, PF_INET, SOCK_DGRAM,
- $self->{"proto_num"});
- }
- # Connect the socket if it isn't already connected
- # to the right destination.
- if ($flush || $connect) {
- connect($self->{"fh"}, $saddr); # Tie destination to socket
- $self->{"connected"} = $saddr;
- }
- send($self->{"fh"}, $msg, UDP_FLAGS); # Send it
-
- $rbits = "";
- vec($rbits, $self->{"fh"}->fileno(), 1) = 1;
- $ret = 0; # Default to unreachable
- $done = 0;
- my $retrans = 0.01;
- my $factor = $self->{"retrans"};
- $finish_time = &time() + $timeout; # Ping needs to be done by then
- while (!$done && $timeout > 0)
- {
- if ($factor > 1)
- {
- $timeout = $retrans if $timeout > $retrans;
- $retrans*= $factor; # Exponential backoff
- }
- $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response
- my $why = $!;
- $timeout = $finish_time - &time(); # Get remaining time
-
- if (!defined($nfound)) # Hmm, a strange error
- {
- $ret = undef;
- $done = 1;
- }
- elsif ($nfound) # A packet is waiting
- {
- $from_msg = "";
- $from_saddr = recv($self->{"fh"}, $from_msg, 1500, UDP_FLAGS);
- if (!$from_saddr) {
- # For example an unreachable host will make recv() fail.
- if (!$self->{"econnrefused"} &&
- ($! == ECONNREFUSED ||
- $! == ECONNRESET)) {
- # "Connection refused" means reachable
- # Good, continue
- $ret = 1;
- }
- $done = 1;
- } else {
- ($from_port, $from_ip) = sockaddr_in($from_saddr);
- if (!$source_verify ||
- (($from_ip eq $ip) && # Does the packet check out?
- ($from_port == $self->{"port_num"}) &&
- ($from_msg eq $msg)))
- {
- $ret = 1; # It's a winner
- $done = 1;
- }
- }
- }
- elsif ($timeout <= 0) # Oops, timed out
- {
- $done = 1;
- }
- else
- {
- # Send another in case the last one dropped
- if (send($self->{"fh"}, $msg, UDP_FLAGS)) {
- # Another send worked? The previous udp packet
- # must have gotten lost or is still in transit.
- # Hopefully this new packet will arrive safely.
- } else {
- if (!$self->{"econnrefused"} &&
- $! == ECONNREFUSED) {
- # "Connection refused" means reachable
- # Good, continue
- $ret = 1;
- }
- $done = 1;
- }
- }
- }
- return $ret;
-}
-
-# Description: Send a TCP SYN packet to host specified.
-sub ping_syn
-{
- my $self = shift;
- my $host = shift;
- my $ip = shift;
- my $start_time = shift;
- my $stop_time = shift;
-
- if ($syn_forking) {
- return $self->ping_syn_fork($host, $ip, $start_time, $stop_time);
- }
-
- my $fh = FileHandle->new();
- my $saddr = sockaddr_in($self->{"port_num"}, $ip);
-
- # Create TCP socket
- if (!socket ($fh, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
- croak("tcp socket error - $!");
- }
-
- if (defined $self->{"local_addr"} &&
- !CORE::bind($fh, sockaddr_in(0, $self->{"local_addr"}))) {
- croak("tcp bind error - $!");
- }
-
- if ($self->{'device'}) {
- setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak("error binding to device $self->{'device'} $!");
- }
- if ($self->{'tos'}) {
- setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
- # Set O_NONBLOCK property on filehandle
- $self->socket_blocking_mode($fh, 0);
-
- # Attempt the non-blocking connect
- # by just sending the TCP SYN packet
- if (connect($fh, $saddr)) {
- # Non-blocking, yet still connected?
- # Must have connected very quickly,
- # or else it wasn't very non-blocking.
- #warn "WARNING: Nonblocking connect connected anyway? ($^O)";
- } else {
- # Error occurred connecting.
- if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) {
- # The connection is just still in progress.
- # This is the expected condition.
- } else {
- # Just save the error and continue on.
- # The ack() can check the status later.
- $self->{"bad"}->{$host} = $!;
- }
- }
-
- my $entry = [ $host, $ip, $fh, $start_time, $stop_time ];
- $self->{"syn"}->{$fh->fileno} = $entry;
- if ($self->{"stop_time"} < $stop_time) {
- $self->{"stop_time"} = $stop_time;
- }
- vec($self->{"wbits"}, $fh->fileno, 1) = 1;
-
- return 1;
-}
-
-sub ping_syn_fork {
- my ($self, $host, $ip, $start_time, $stop_time) = @_;
-
- # Buggy Winsock API doesn't allow nonblocking connect.
- # Hence, if our OS is Windows, we need to create a separate
- # process to do the blocking connect attempt.
- my $pid = fork();
- if (defined $pid) {
- if ($pid) {
- # Parent process
- my $entry = [ $host, $ip, $pid, $start_time, $stop_time ];
- $self->{"syn"}->{$pid} = $entry;
- if ($self->{"stop_time"} < $stop_time) {
- $self->{"stop_time"} = $stop_time;
- }
- } else {
- # Child process
- my $saddr = sockaddr_in($self->{"port_num"}, $ip);
-
- # Create TCP socket
- if (!socket ($self->{"fh"}, PF_INET, SOCK_STREAM, $self->{"proto_num"})) {
- croak("tcp socket error - $!");
- }
-
- if (defined $self->{"local_addr"} &&
- !CORE::bind($self->{"fh"}, sockaddr_in(0, $self->{"local_addr"}))) {
- croak("tcp bind error - $!");
- }
-
- if ($self->{'device'}) {
- setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
- or croak("error binding to device $self->{'device'} $!");
- }
- if ($self->{'tos'}) {
- setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
- or croak "error configuring tos to $self->{'tos'} $!";
- }
-
- $!=0;
- # Try to connect (could take a long time)
- connect($self->{"fh"}, $saddr);
- # Notify parent of connect error status
- my $err = $!+0;
- my $wrstr = "$$ $err";
- # Force to 16 chars including \n
- $wrstr .= " "x(15 - length $wrstr). "\n";
- syswrite($self->{"fork_wr"}, $wrstr, length $wrstr);
- exit;
- }
- } else {
- # fork() failed?
- die "fork: $!";
- }
- return 1;
-}
-
-# Description: Wait for TCP ACK from host specified
-# from ping_syn above. If no host is specified, wait
-# for TCP ACK from any of the hosts in the SYN queue.
-sub ack
-{
- my $self = shift;
-
- if ($self->{"proto"} eq "syn") {
- if ($syn_forking) {
- my @answer = $self->ack_unfork(shift);
- return wantarray ? @answer : $answer[0];
- }
- my $wbits = "";
- my $stop_time = 0;
- if (my $host = shift) {
- # Host passed as arg
- if (exists $self->{"bad"}->{$host}) {
- if (!$self->{"econnrefused"} &&
- $self->{"bad"}->{ $host } &&
- (($! = ECONNREFUSED)>0) &&
- $self->{"bad"}->{ $host } eq "$!") {
- # "Connection refused" means reachable
- # Good, continue
- } else {
- # ECONNREFUSED means no good
- return ();
- }
- }
- my $host_fd = undef;
- foreach my $fd (keys %{ $self->{"syn"} }) {
- my $entry = $self->{"syn"}->{$fd};
- if ($entry->[0] eq $host) {
- $host_fd = $fd;
- $stop_time = $entry->[4]
- || croak("Corrupted SYN entry for [$host]");
- last;
- }
- }
- croak("ack called on [$host] without calling ping first!")
- unless defined $host_fd;
- vec($wbits, $host_fd, 1) = 1;
- } else {
- # No $host passed so scan all hosts
- # Use the latest stop_time
- $stop_time = $self->{"stop_time"};
- # Use all the bits
- $wbits = $self->{"wbits"};
- }
-
- while ($wbits !~ /^\0*\z/) {
- my $timeout = $stop_time - &time();
- # Force a minimum of 10 ms timeout.
- $timeout = 0.01 if $timeout <= 0.01;
-
- my $winner_fd = undef;
- my $wout = $wbits;
- my $fd = 0;
- # Do "bad" fds from $wbits first
- while ($wout !~ /^\0*\z/) {
- if (vec($wout, $fd, 1)) {
- # Wipe it from future scanning.
- vec($wout, $fd, 1) = 0;
- if (my $entry = $self->{"syn"}->{$fd}) {
- if ($self->{"bad"}->{ $entry->[0] }) {
- $winner_fd = $fd;
- last;
- }
- }
- }
- $fd++;
- }
-
- if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) {
- if (defined $winner_fd) {
- $fd = $winner_fd;
- } else {
- # Done waiting for one of the ACKs
- $fd = 0;
- # Determine which one
- while ($wout !~ /^\0*\z/ &&
- !vec($wout, $fd, 1)) {
- $fd++;
- }
- }
- if (my $entry = $self->{"syn"}->{$fd}) {
- # Wipe it from future scanning.
- delete $self->{"syn"}->{$fd};
- vec($self->{"wbits"}, $fd, 1) = 0;
- vec($wbits, $fd, 1) = 0;
- if (!$self->{"econnrefused"} &&
- $self->{"bad"}->{ $entry->[0] } &&
- (($! = ECONNREFUSED)>0) &&
- $self->{"bad"}->{ $entry->[0] } eq "$!") {
- # "Connection refused" means reachable
- # Good, continue
- } elsif (getpeername($entry->[2])) {
- # Connection established to remote host
- # Good, continue
- } else {
- # TCP ACK will never come from this host
- # because there was an error connecting.
-
- # This should set $! to the correct error.
- my $char;
- sysread($entry->[2],$char,1);
- # Store the excuse why the connection failed.
- $self->{"bad"}->{$entry->[0]} = $!;
- if (!$self->{"econnrefused"} &&
- (($! == ECONNREFUSED) ||
- ($! == EAGAIN && $^O =~ /cygwin/i))) {
- # "Connection refused" means reachable
- # Good, continue
- } else {
- # No good, try the next socket...
- next;
- }
- }
- # Everything passed okay, return the answer
- return wantarray ?
- ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]))
- : $entry->[0];
- } else {
- warn "Corrupted SYN entry: unknown fd [$fd] ready!";
- vec($wbits, $fd, 1) = 0;
- vec($self->{"wbits"}, $fd, 1) = 0;
- }
- } elsif (defined $nfound) {
- # Timed out waiting for ACK
- foreach my $fd (keys %{ $self->{"syn"} }) {
- if (vec($wbits, $fd, 1)) {
- my $entry = $self->{"syn"}->{$fd};
- $self->{"bad"}->{$entry->[0]} = "Timed out";
- vec($wbits, $fd, 1) = 0;
- vec($self->{"wbits"}, $fd, 1) = 0;
- delete $self->{"syn"}->{$fd};
- }
- }
- } else {
- # Weird error occurred with select()
- warn("select: $!");
- $self->{"syn"} = {};
- $wbits = "";
- }
- }
- }
- return ();
-}
-
-sub ack_unfork {
- my ($self,$host) = @_;
- my $stop_time = $self->{"stop_time"};
- if ($host) {
- # Host passed as arg
- if (my $entry = $self->{"good"}->{$host}) {
- delete $self->{"good"}->{$host};
- return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
- }
- }
-
- my $rbits = "";
- my $timeout;
-
- if (keys %{ $self->{"syn"} }) {
- # Scan all hosts that are left
- vec($rbits, fileno($self->{"fork_rd"}), 1) = 1;
- $timeout = $stop_time - &time();
- # Force a minimum of 10 ms timeout.
- $timeout = 0.01 if $timeout < 0.01;
- } else {
- # No hosts left to wait for
- $timeout = 0;
- }
-
- if ($timeout > 0) {
- my $nfound;
- while ( keys %{ $self->{"syn"} } and
- $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) {
- # Done waiting for one of the ACKs
- if (!sysread($self->{"fork_rd"}, $_, 16)) {
- # Socket closed, which means all children are done.
- return ();
- }
- my ($pid, $how) = split;
- if ($pid) {
- # Flush the zombie
- waitpid($pid, 0);
- if (my $entry = $self->{"syn"}->{$pid}) {
- # Connection attempt to remote host is done
- delete $self->{"syn"}->{$pid};
- if (!$how || # If there was no error connecting
- (!$self->{"econnrefused"} &&
- $how == ECONNREFUSED)) { # "Connection refused" means reachable
- if ($host && $entry->[0] ne $host) {
- # A good connection, but not the host we need.
- # Move it from the "syn" hash to the "good" hash.
- $self->{"good"}->{$entry->[0]} = $entry;
- # And wait for the next winner
- next;
- }
- return ($entry->[0], &time() - $entry->[3], inet_ntoa($entry->[1]));
- }
- } else {
- # Should never happen
- die "Unknown ping from pid [$pid]";
- }
- } else {
- die "Empty response from status socket?";
- }
- }
- if (defined $nfound) {
- # Timed out waiting for ACK status
- } else {
- # Weird error occurred with select()
- warn("select: $!");
- }
- }
- if (my @synners = keys %{ $self->{"syn"} }) {
- # Kill all the synners
- kill 9, @synners;
- foreach my $pid (@synners) {
- # Wait for the deaths to finish
- # Then flush off the zombie
- waitpid($pid, 0);
- }
- }
- $self->{"syn"} = {};
- return ();
-}
-
-# Description: Tell why the ack() failed
-sub nack {
- my $self = shift;
- my $host = shift || croak('Usage> nack($failed_ack_host)');
- return $self->{"bad"}->{$host} || undef;
-}
-
-# Description: Close the connection.
-
-sub close
-{
- my ($self) = @_;
-
- if ($self->{"proto"} eq "syn") {
- delete $self->{"syn"};
- } elsif ($self->{"proto"} eq "tcp") {
- # The connection will already be closed
- } else {
- $self->{"fh"}->close();
- }
-}
-
-sub port_number {
- my $self = shift;
- if(@_) {
- $self->{port_num} = shift @_;
- $self->service_check(1);
- }
- return $self->{port_num};
-}
-
-
-1;
-__END__
-
-=head1 NAME
-
-Net::Ping - check a remote host for reachability
-
-=head1 SYNOPSIS
-
- use Net::Ping;
-
- $p = Net::Ping->new();
- print "$host is alive.\n" if $p->ping($host);
- $p->close();
-
- $p = Net::Ping->new("icmp");
- $p->bind($my_addr); # Specify source interface of pings
- foreach $host (@host_array)
- {
- print "$host is ";
- print "NOT " unless $p->ping($host, 2);
- print "reachable.\n";
- sleep(1);
- }
- $p->close();
-
- $p = Net::Ping->new("tcp", 2);
- # Try connecting to the www port instead of the echo port
- $p->port_number(getservbyname("http", "tcp"));
- while ($stop_time > time())
- {
- print "$host not reachable ", scalar(localtime()), "\n"
- unless $p->ping($host);
- sleep(300);
- }
- undef($p);
-
- # Like tcp protocol, but with many hosts
- $p = Net::Ping->new("syn");
- $p->port_number(getservbyname("http", "tcp"));
- foreach $host (@host_array) {
- $p->ping($host);
- }
- while (($host,$rtt,$ip) = $p->ack) {
- print "HOST: $host [$ip] ACKed in $rtt seconds.\n";
- }
-
- # High precision syntax (requires Time::HiRes)
- $p = Net::Ping->new();
- $p->hires();
- ($ret, $duration, $ip) = $p->ping($host, 5.5);
- printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration)
- if $ret;
- $p->close();
-
- # For backward compatibility
- print "$host is alive.\n" if pingecho($host);
-
-=head1 DESCRIPTION
-
-This module contains methods to test the reachability of remote
-hosts on a network. A ping object is first created with optional
-parameters, a variable number of hosts may be pinged multiple
-times and then the connection is closed.
-
-You may choose one of six different protocols to use for the
-ping. The "tcp" protocol is the default. Note that a live remote host
-may still fail to be pingable by one or more of these protocols. For
-example, www.microsoft.com is generally alive but not "icmp" pingable.
-
-With the "tcp" protocol the ping() method attempts to establish a
-connection to the remote host's echo port. If the connection is
-successfully established, the remote host is considered reachable. No
-data is actually echoed. This protocol does not require any special
-privileges but has higher overhead than the "udp" and "icmp" protocols.
-
-Specifying the "udp" protocol causes the ping() method to send a udp
-packet to the remote host's echo port. If the echoed packet is
-received from the remote host and the received packet contains the
-same data as the packet that was sent, the remote host is considered
-reachable. This protocol does not require any special privileges.
-It should be borne in mind that, for a udp ping, a host
-will be reported as unreachable if it is not running the
-appropriate echo service. For Unix-like systems see L<inetd(8)>
-for more information.
-
-If the "icmp" protocol is specified, the ping() method sends an icmp
-echo message to the remote host, which is what the UNIX ping program
-does. If the echoed message is received from the remote host and
-the echoed information is correct, the remote host is considered
-reachable. Specifying the "icmp" protocol requires that the program
-be run as root or that the program be setuid to root.
-
-If the "external" protocol is specified, the ping() method attempts to
-use the C<Net::Ping::External> module to ping the remote host.
-C<Net::Ping::External> interfaces with your system's default C<ping>
-utility to perform the ping, and generally produces relatively
-accurate results. If C<Net::Ping::External> if not installed on your
-system, specifying the "external" protocol will result in an error.
-
-If the "syn" protocol is specified, the ping() method will only
-send a TCP SYN packet to the remote host then immediately return.
-If the syn packet was sent successfully, it will return a true value,
-otherwise it will return false. NOTE: Unlike the other protocols,
-the return value does NOT determine if the remote host is alive or
-not since the full TCP three-way handshake may not have completed
-yet. The remote host is only considered reachable if it receives
-a TCP ACK within the timeout specified. To begin waiting for the
-ACK packets, use the ack() method as explained below. Use the
-"syn" protocol instead the "tcp" protocol to determine reachability
-of multiple destinations simultaneously by sending parallel TCP
-SYN packets. It will not block while testing each remote host.
-demo/fping is provided in this distribution to demonstrate the
-"syn" protocol as an example.
-This protocol does not require any special privileges.
-
-=head2 Functions
-
-=over 4
-
-=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]);
-
-Create a new ping object. All of the parameters are optional. $proto
-specifies the protocol to use when doing a ping. The current choices
-are "tcp", "udp", "icmp", "stream", "syn", or "external".
-The default is "tcp".
-
-If a default timeout ($def_timeout) in seconds is provided, it is used
-when a timeout is not given to the ping() method (below). The timeout
-must be greater than 0 and the default, if not specified, is 5 seconds.
-
-If the number of data bytes ($bytes) is given, that many data bytes
-are included in the ping packet sent to the remote host. The number of
-data bytes is ignored if the protocol is "tcp". The minimum (and
-default) number of data bytes is 1 if the protocol is "udp" and 0
-otherwise. The maximum number of data bytes that can be specified is
-1024.
-
-If $device is given, this device is used to bind the source endpoint
-before sending the ping packet. I believe this only works with
-superuser privileges and with udp and icmp protocols at this time.
-
-If $tos is given, this ToS is configured into the socket.
-
-=item $p->ping($host [, $timeout]);
-
-Ping the remote host and wait for a response. $host can be either the
-hostname or the IP number of the remote host. The optional timeout
-must be greater than 0 seconds and defaults to whatever was specified
-when the ping object was created. Returns a success flag. If the
-hostname cannot be found or there is a problem with the IP number, the
-success flag returned will be undef. Otherwise, the success flag will
-be 1 if the host is reachable and 0 if it is not. For most practical
-purposes, undef and 0 and can be treated as the same case. In array
-context, the elapsed time as well as the string form of the ip the
-host resolved to are also returned. The elapsed time value will
-be a float, as retuned by the Time::HiRes::time() function, if hires()
-has been previously called, otherwise it is returned as an integer.
-
-=item $p->source_verify( { 0 | 1 } );
-
-Allows source endpoint verification to be enabled or disabled.
-This is useful for those remote destinations with multiples
-interfaces where the response may not originate from the same
-endpoint that the original destination endpoint was sent to.
-This only affects udp and icmp protocol pings.
-
-This is enabled by default.
-
-=item $p->service_check( { 0 | 1 } );
-
-Set whether or not the connect behavior should enforce
-remote service availability as well as reachability. Normally,
-if the remote server reported ECONNREFUSED, it must have been
-reachable because of the status packet that it reported.
-With this option enabled, the full three-way tcp handshake
-must have been established successfully before it will
-claim it is reachable. NOTE: It still does nothing more
-than connect and disconnect. It does not speak any protocol
-(i.e., HTTP or FTP) to ensure the remote server is sane in
-any way. The remote server CPU could be grinding to a halt
-and unresponsive to any clients connecting, but if the kernel
-throws the ACK packet, it is considered alive anyway. To
-really determine if the server is responding well would be
-application specific and is beyond the scope of Net::Ping.
-For udp protocol, enabling this option demands that the
-remote server replies with the same udp data that it was sent
-as defined by the udp echo service.
-
-This affects the "udp", "tcp", and "syn" protocols.
-
-This is disabled by default.
-
-=item $p->tcp_service_check( { 0 | 1 } );
-
-Deprecated method, but does the same as service_check() method.
-
-=item $p->hires( { 0 | 1 } );
-
-Causes this module to use Time::HiRes module, allowing milliseconds
-to be returned by subsequent calls to ping().
-
-This is disabled by default.
-
-=item $p->bind($local_addr);
-
-Sets the source address from which pings will be sent. This must be
-the address of one of the interfaces on the local host. $local_addr
-may be specified as a hostname or as a text IP address such as
-"192.168.1.1".
-
-If the protocol is set to "tcp", this method may be called any
-number of times, and each call to the ping() method (below) will use
-the most recent $local_addr. If the protocol is "icmp" or "udp",
-then bind() must be called at most once per object, and (if it is
-called at all) must be called before the first call to ping() for that
-object.
-
-=item $p->open($host);
-
-When you are using the "stream" protocol, this call pre-opens the
-tcp socket. It's only necessary to do this if you want to
-provide a different timeout when creating the connection, or
-remove the overhead of establishing the connection from the
-first ping. If you don't call C<open()>, the connection is
-automatically opened the first time C<ping()> is called.
-This call simply does nothing if you are using any protocol other
-than stream.
-
-=item $p->ack( [ $host ] );
-
-When using the "syn" protocol, use this method to determine
-the reachability of the remote host. This method is meant
-to be called up to as many times as ping() was called. Each
-call returns the host (as passed to ping()) that came back
-with the TCP ACK. The order in which the hosts are returned
-may not necessarily be the same order in which they were
-SYN queued using the ping() method. If the timeout is
-reached before the TCP ACK is received, or if the remote
-host is not listening on the port attempted, then the TCP
-connection will not be established and ack() will return
-undef. In list context, the host, the ack time, and the
-dotted ip string will be returned instead of just the host.
-If the optional $host argument is specified, the return
-value will be pertaining to that host only.
-This call simply does nothing if you are using any protocol
-other than syn.
-
-=item $p->nack( $failed_ack_host );
-
-The reason that host $failed_ack_host did not receive a
-valid ACK. Useful to find out why when ack( $fail_ack_host )
-returns a false value.
-
-=item $p->close();
-
-Close the network connection for this ping object. The network
-connection is also closed by "undef $p". The network connection is
-automatically closed if the ping object goes out of scope (e.g. $p is
-local to a subroutine and you leave the subroutine).
-
-=item $p->port_number([$port_number])
-
-When called with a port number, the port number used to ping is set to
-$port_number rather than using the echo port. It also has the effect
-of calling C<$p-E<gt>service_check(1)> causing a ping to return a successful
-response only if that specific port is accessible. This function returns
-the value of the port that C<ping()> will connect to.
-
-=item pingecho($host [, $timeout]);
-
-To provide backward compatibility with the previous version of
-Net::Ping, a pingecho() subroutine is available with the same
-functionality as before. pingecho() uses the tcp protocol. The
-return values and parameters are the same as described for the ping()
-method. This subroutine is obsolete and may be removed in a future
-version of Net::Ping.
-
-=back
-
-=head1 NOTES
-
-There will be less network overhead (and some efficiency in your
-program) if you specify either the udp or the icmp protocol. The tcp
-protocol will generate 2.5 times or more traffic for each ping than
-either udp or icmp. If many hosts are pinged frequently, you may wish
-to implement a small wait (e.g. 25ms or more) between each ping to
-avoid flooding your network with packets.
-
-The icmp protocol requires that the program be run as root or that it
-be setuid to root. The other protocols do not require special
-privileges, but not all network devices implement tcp or udp echo.
-
-Local hosts should normally respond to pings within milliseconds.
-However, on a very congested network it may take up to 3 seconds or
-longer to receive an echo packet from the remote host. If the timeout
-is set too low under these conditions, it will appear that the remote
-host is not reachable (which is almost the truth).
-
-Reachability doesn't necessarily mean that the remote host is actually
-functioning beyond its ability to echo packets. tcp is slightly better
-at indicating the health of a system than icmp because it uses more
-of the networking stack to respond.
-
-Because of a lack of anything better, this module uses its own
-routines to pack and unpack ICMP packets. It would be better for a
-separate module to be written which understands all of the different
-kinds of ICMP packets.
-
-=head1 INSTALL
-
-The latest source tree is available via cvs:
-
- cvs -z3 -q -d :pserver:anonymous at cvs.roobik.com.:/usr/local/cvsroot/freeware checkout Net-Ping
- cd Net-Ping
-
-The tarball can be created as follows:
-
- perl Makefile.PL ; make ; make dist
-
-The latest Net::Ping release can be found at CPAN:
-
- $CPAN/modules/by-module/Net/
-
-1) Extract the tarball
-
- gtar -zxvf Net-Ping-xxxx.tar.gz
- cd Net-Ping-xxxx
-
-2) Build:
-
- make realclean
- perl Makefile.PL
- make
- make test
-
-3) Install
-
- make install
-
-Or install it RPM Style:
-
- rpm -ta SOURCES/Net-Ping-xxxx.tar.gz
-
- rpm -ih RPMS/noarch/perl-Net-Ping-xxxx.rpm
-
-=head1 BUGS
-
-For a list of known issues, visit:
-
-https://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-Ping
-
-To report a new bug, visit:
-
-https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-Ping
-
-=head1 AUTHORS
-
- Current maintainer:
- bbb at cpan.org (Rob Brown)
-
- External protocol:
- colinm at cpan.org (Colin McMillen)
-
- Stream protocol:
- bronson at trestle.com (Scott Bronson)
-
- Original pingecho():
- karrer at bernina.ethz.ch (Andreas Karrer)
- pmarquess at bfsec.bt.co.uk (Paul Marquess)
-
- Original Net::Ping author:
- mose at ns.ccsn.edu (Russell Mosemann)
-
-=head1 COPYRIGHT
-
-Copyright (c) 2002-2003, Rob Brown. All rights reserved.
-
-Copyright (c) 2001, Colin McMillen. All rights reserved.
-
-This program is free software; you may redistribute it and/or
-modify it under the same terms as Perl itself.
-
-$Id: Ping.pm,v 1.1.1.2 2011-02-17 12:49:38 laffer1 Exp $
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/README
===================================================================
--- trunk/contrib/perl/lib/Net/README 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/README 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,109 +0,0 @@
-libnet is a collection of Perl modules which provides a simple
-and consistent programming interface (API) to the client side
-of various protocols used in the internet community.
-
-For details of each protocol please refer to the RFC. RFC's
-can be found a various places on the WEB, for a starting
-point look at:
-
- http://www.yahoo.com/Computers_and_Internet/Standards/RFCs/
-
-The RFC implemented in this distribution are
-
-Net::FTP RFC959 File Transfer Protocol
-Net::SMTP RFC821 Simple Mail Transfer Protocol
-Net::Time RFC867 Daytime Protocol
-Net::Time RFC868 Time Protocol
-Net::NNTP RFC977 Network News Transfer Protocol
-Net::POP3 RFC1939 Post Office Protocol 3
-
-AVAILABILITY
-
-The latest version of libnet is available from the Comprehensive Perl
-Archive Network (CPAN). To find a CPAN site near you see:
-
- http://search.cpan.org/~gbarr/libnet/
-
-The subversion source repository can be browsed at
-
- http://svn.goingon.net/viewvc/libnet/
-
-If you have a subversion client, then you can checkout the latest code with
-
- svn co http://svn.goingon.net/repos/libnet/trunk libnet
-
-INSTALLATION
-
-In order to use this package you will need Perl version 5.002 or
-better. You install libnet, as you would install any perl module
-library, by running these commands:
-
- perl Makefile.PL
- make
- make test
- make install
-
-If you want to install a private copy of libnet in your home
-directory, then you should try to produce the initial Makefile with
-something like this command:
-
- perl Makefile.PL PREFIX=~/perl
-
-
-The Makefile.PL program will start out by checking your perl
-installation for a few packages that are recommended to be installed
-together with libnet. These packages should be available on CPAN
-(described above).
-
-CONFIGURE
-
-Normally when perl Makefile.PL is run it will run Configure which will
-ask some questions about your system. The results of these questions
-will be stored in a file called libnet.cfg which will be installed
-alongside the other perl modules in this distribution. The Makefile.PL
-will run Configure in an interactive mode unless these exists a file
-called libnet.cfg in the build directory.
-
-If you are on a system which cannot run this script you can create an
-empty file to make Makefile.PL skip running Configure. If you want to
-keep your existing settings and not run interactivly the simple run
-
- Configure -d
-
-before running the Makefile.PL.
-
-DOCUMENTATION
-
-See ChangeLog for recent changes. POD style documentation is included
-in all modules and scripts. These are normally converted to manual
-pages and installed as part of the "make install" process. You should
-also be able to use the 'perldoc' utility to extract documentation from
-the module files directly.
-
-DEMOS
-
-The demos directory does contain a few demo scripts. These should be
-run from the top directory like
-
- demos/smtp.self -user my-email-address -debug
-
-However I do not guarantee these scripts to work.
-
-SUPPORT
-
-Questions about how to use this library should be directed to the
-comp.lang.perl.modules USENET Newsgroup. Bug reports and suggestions
-for improvements can be sent to me at <gbarr at pobox.com>.
-
-Most of the modules in this library have an option to output a debug
-transcript to STDERR. When reporting bugs/problems please, if possible,
-include a transcript of a run.
-
-COPYRIGHT
-
- (C) 1996-2007 Graham Barr. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-Share and Enjoy!
Deleted: trunk/contrib/perl/lib/Net/SMTP.pm
===================================================================
--- trunk/contrib/perl/lib/Net/SMTP.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/SMTP.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,867 +0,0 @@
-# Net::SMTP.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::SMTP;
-
-require 5.001;
-
-use strict;
-use vars qw($VERSION @ISA);
-use Socket 1.3;
-use Carp;
-use IO::Socket;
-use Net::Cmd;
-use Net::Config;
-
-$VERSION = "2.31";
-
- at ISA = qw(Net::Cmd IO::Socket::INET);
-
-
-sub new {
- my $self = shift;
- my $type = ref($self) || $self;
- my ($host, %arg);
- if (@_ % 2) {
- $host = shift;
- %arg = @_;
- }
- else {
- %arg = @_;
- $host = delete $arg{Host};
- }
- my $hosts = defined $host ? $host : $NetConfig{smtp_hosts};
- my $obj;
-
- my $h;
- foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) {
- $obj = $type->SUPER::new(
- PeerAddr => ($host = $h),
- PeerPort => $arg{Port} || 'smtp(25)',
- LocalAddr => $arg{LocalAddr},
- LocalPort => $arg{LocalPort},
- Proto => 'tcp',
- Timeout => defined $arg{Timeout}
- ? $arg{Timeout}
- : 120
- )
- and last;
- }
-
- return undef
- unless defined $obj;
-
- $obj->autoflush(1);
-
- $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);
-
- unless ($obj->response() == CMD_OK) {
- $obj->close();
- return undef;
- }
-
- ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses};
- ${*$obj}{'net_smtp_host'} = $host;
-
- (${*$obj}{'net_smtp_banner'}) = $obj->message;
- (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;
-
- unless ($obj->hello($arg{Hello} || "")) {
- $obj->close();
- return undef;
- }
-
- $obj;
-}
-
-
-sub host {
- my $me = shift;
- ${*$me}{'net_smtp_host'};
-}
-
-##
-## User interface methods
-##
-
-
-sub banner {
- my $me = shift;
-
- return ${*$me}{'net_smtp_banner'} || undef;
-}
-
-
-sub domain {
- my $me = shift;
-
- return ${*$me}{'net_smtp_domain'} || undef;
-}
-
-
-sub etrn {
- my $self = shift;
- defined($self->supports('ETRN', 500, ["Command unknown: 'ETRN'"]))
- && $self->_ETRN(@_);
-}
-
-
-sub auth {
- my ($self, $username, $password) = @_;
-
- eval {
- require MIME::Base64;
- require Authen::SASL;
- } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0;
-
- my $mechanisms = $self->supports('AUTH', 500, ["Command unknown: 'AUTH'"]);
- return unless defined $mechanisms;
-
- my $sasl;
-
- if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) {
- $sasl = $username;
- $sasl->mechanism($mechanisms);
- }
- else {
- die "auth(username, password)" if not length $username;
- $sasl = Authen::SASL->new(
- mechanism => $mechanisms,
- callback => {
- user => $username,
- pass => $password,
- authname => $username,
- }
- );
- }
-
- # We should probably allow the user to pass the host, but I don't
- # currently know and SASL mechanisms that are used by smtp that need it
- my $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0);
- my $str = $client->client_start;
-
- # We dont support sasl mechanisms that encrypt the socket traffic.
- # todo that we would really need to change the ISA hierarchy
- # so we dont inherit from IO::Socket, but instead hold it in an attribute
-
- my @cmd = ("AUTH", $client->mechanism);
- my $code;
-
- push @cmd, MIME::Base64::encode_base64($str, '')
- if defined $str and length $str;
-
- while (($code = $self->command(@cmd)->response()) == CMD_MORE) {
- @cmd = (
- MIME::Base64::encode_base64(
- $client->client_step(MIME::Base64::decode_base64(($self->message)[0])), ''
- )
- );
- }
-
- $code == CMD_OK;
-}
-
-
-sub hello {
- my $me = shift;
- my $domain = shift || "localhost.localdomain";
- my $ok = $me->_EHLO($domain);
- my @msg = $me->message;
-
- if ($ok) {
- my $h = ${*$me}{'net_smtp_esmtp'} = {};
- my $ln;
- foreach $ln (@msg) {
- $h->{uc $1} = $2
- if $ln =~ /(\w+)\b[= \t]*([^\n]*)/;
- }
- }
- elsif ($me->status == CMD_ERROR) {
- @msg = $me->message
- if $ok = $me->_HELO($domain);
- }
-
- return undef unless $ok;
-
- $msg[0] =~ /\A\s*(\S+)/;
- return ($1 || " ");
-}
-
-
-sub supports {
- my $self = shift;
- my $cmd = uc shift;
- return ${*$self}{'net_smtp_esmtp'}->{$cmd}
- if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
- $self->set_status(@_)
- if @_;
- return;
-}
-
-
-sub _addr {
- my $self = shift;
- my $addr = shift;
- $addr = "" unless defined $addr;
-
- if (${*$self}{'net_smtp_exact_addr'}) {
- return $1 if $addr =~ /^\s*(<.*>)\s*$/s;
- }
- else {
- return $1 if $addr =~ /(<[^>]*>)/;
- $addr =~ s/^\s+|\s+$//sg;
- }
-
- "<$addr>";
-}
-
-
-sub mail {
- my $me = shift;
- my $addr = _addr($me, shift);
- my $opts = "";
-
- if (@_) {
- my %opt = @_;
- my ($k, $v);
-
- if (exists ${*$me}{'net_smtp_esmtp'}) {
- my $esmtp = ${*$me}{'net_smtp_esmtp'};
-
- if (defined($v = delete $opt{Size})) {
- if (exists $esmtp->{SIZE}) {
- $opts .= sprintf " SIZE=%d", $v + 0;
- }
- else {
- carp 'Net::SMTP::mail: SIZE option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Return})) {
- if (exists $esmtp->{DSN}) {
- $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS");
- }
- else {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Bits})) {
- if ($v eq "8") {
- if (exists $esmtp->{'8BITMIME'}) {
- $opts .= " BODY=8BITMIME";
- }
- else {
- carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
- }
- }
- elsif ($v eq "binary") {
- if (exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'}) {
- $opts .= " BODY=BINARYMIME";
- ${*$me}{'net_smtp_chunking'} = 1;
- }
- else {
- carp 'Net::SMTP::mail: BINARYMIME option not supported by host';
- }
- }
- elsif (exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) {
- $opts .= " BODY=7BIT";
- }
- else {
- carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Transaction})) {
- if (exists $esmtp->{CHECKPOINT}) {
- $opts .= " TRANSID=" . _addr($me, $v);
- }
- else {
- carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{Envelope})) {
- if (exists $esmtp->{DSN}) {
- $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
- $opts .= " ENVID=$v";
- }
- else {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{ENVID})) {
-
- # expected to be in a format as required by RFC 3461, xtext-encoded
- if (exists $esmtp->{DSN}) {
- $opts .= " ENVID=$v";
- }
- else {
- carp 'Net::SMTP::mail: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{AUTH})) {
-
- # expected to be in a format as required by RFC 2554,
- # rfc2821-quoted and xtext-encoded, or <>
- if (exists $esmtp->{AUTH}) {
- $v = '<>' if !defined($v) || $v eq '';
- $opts .= " AUTH=$v";
- }
- else {
- carp 'Net::SMTP::mail: AUTH option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{XVERP})) {
- if (exists $esmtp->{'XVERP'}) {
- $opts .= " XVERP";
- }
- else {
- carp 'Net::SMTP::mail: XVERP option not supported by host';
- }
- }
-
- carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
- if scalar keys %opt;
- }
- else {
- carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
- }
- }
-
- $me->_MAIL("FROM:" . $addr . $opts);
-}
-
-
-sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) }
-sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) }
-sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) }
-
-
-sub reset {
- my $me = shift;
-
- $me->dataend()
- if (exists ${*$me}{'net_smtp_lastch'});
-
- $me->_RSET();
-}
-
-
-sub recipient {
- my $smtp = shift;
- my $opts = "";
- my $skip_bad = 0;
-
- if (@_ && ref($_[-1])) {
- my %opt = %{pop(@_)};
- my $v;
-
- $skip_bad = delete $opt{'SkipBad'};
-
- if (exists ${*$smtp}{'net_smtp_esmtp'}) {
- my $esmtp = ${*$smtp}{'net_smtp_esmtp'};
-
- if (defined($v = delete $opt{Notify})) {
- if (exists $esmtp->{DSN}) {
- $opts .= " NOTIFY=" . join(",", map { uc $_ } @$v);
- }
- else {
- carp 'Net::SMTP::recipient: DSN option not supported by host';
- }
- }
-
- if (defined($v = delete $opt{ORcpt})) {
- if (exists $esmtp->{DSN}) {
- $opts .= " ORCPT=" . $v;
- }
- else {
- carp 'Net::SMTP::recipient: DSN option not supported by host';
- }
- }
-
- carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored'
- if scalar keys %opt;
- }
- elsif (%opt) {
- carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
- }
- }
-
- my @ok;
- my $addr;
- foreach $addr (@_) {
- if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) {
- push(@ok, $addr) if $skip_bad;
- }
- elsif (!$skip_bad) {
- return 0;
- }
- }
-
- return $skip_bad ? @ok : 1;
-}
-
-BEGIN {
- *to = \&recipient;
- *cc = \&recipient;
- *bcc = \&recipient;
-}
-
-
-sub data {
- my $me = shift;
-
- if (exists ${*$me}{'net_smtp_chunking'}) {
- carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead';
- }
- else {
- my $ok = $me->_DATA() && $me->datasend(@_);
-
- $ok && @_
- ? $me->dataend
- : $ok;
- }
-}
-
-
-sub bdat {
- my $me = shift;
-
- if (exists ${*$me}{'net_smtp_chunking'}) {
- my $data = shift;
-
- $me->_BDAT(length $data)
- && $me->rawdatasend($data)
- && $me->response() == CMD_OK;
- }
- else {
- carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
- }
-}
-
-
-sub bdatlast {
- my $me = shift;
-
- if (exists ${*$me}{'net_smtp_chunking'}) {
- my $data = shift;
-
- $me->_BDAT(length $data, "LAST")
- && $me->rawdatasend($data)
- && $me->response() == CMD_OK;
- }
- else {
- carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead';
- }
-}
-
-
-sub datafh {
- my $me = shift;
- return unless $me->_DATA();
- return $me->tied_fh;
-}
-
-
-sub expand {
- my $me = shift;
-
- $me->_EXPN(@_)
- ? ($me->message)
- : ();
-}
-
-
-sub verify { shift->_VRFY(@_) }
-
-
-sub help {
- my $me = shift;
-
- $me->_HELP(@_)
- ? scalar $me->message
- : undef;
-}
-
-
-sub quit {
- my $me = shift;
-
- $me->_QUIT;
- $me->close;
-}
-
-
-sub DESTROY {
-
- # ignore
-}
-
-##
-## RFC821 commands
-##
-
-
-sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK }
-sub _HELO { shift->command("HELO", @_)->response() == CMD_OK }
-sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK }
-sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK }
-sub _SEND { shift->command("SEND", @_)->response() == CMD_OK }
-sub _SAML { shift->command("SAML", @_)->response() == CMD_OK }
-sub _SOML { shift->command("SOML", @_)->response() == CMD_OK }
-sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK }
-sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK }
-sub _HELP { shift->command("HELP", @_)->response() == CMD_OK }
-sub _RSET { shift->command("RSET")->response() == CMD_OK }
-sub _NOOP { shift->command("NOOP")->response() == CMD_OK }
-sub _QUIT { shift->command("QUIT")->response() == CMD_OK }
-sub _DATA { shift->command("DATA")->response() == CMD_MORE }
-sub _BDAT { shift->command("BDAT", @_) }
-sub _TURN { shift->unsupported(@_); }
-sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK }
-sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK }
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::SMTP - Simple Mail Transfer Protocol Client
-
-=head1 SYNOPSIS
-
- use Net::SMTP;
-
- # Constructors
- $smtp = Net::SMTP->new('mailhost');
- $smtp = Net::SMTP->new('mailhost', Timeout => 60);
-
-=head1 DESCRIPTION
-
-This module implements a client interface to the SMTP and ESMTP
-protocol, enabling a perl5 application to talk to SMTP servers. This
-documentation assumes that you are familiar with the concepts of the
-SMTP protocol described in RFC821.
-
-A new Net::SMTP object must be created with the I<new> method. Once
-this has been done, all SMTP commands are accessed through this object.
-
-The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.
-
-=head1 EXAMPLES
-
-This example prints the mail domain name of the SMTP server known as mailhost:
-
- #!/usr/local/bin/perl -w
-
- use Net::SMTP;
-
- $smtp = Net::SMTP->new('mailhost');
- print $smtp->domain,"\n";
- $smtp->quit;
-
-This example sends a small message to the postmaster at the SMTP server
-known as mailhost:
-
- #!/usr/local/bin/perl -w
-
- use Net::SMTP;
-
- $smtp = Net::SMTP->new('mailhost');
-
- $smtp->mail($ENV{USER});
- $smtp->to('postmaster');
-
- $smtp->data();
- $smtp->datasend("To: postmaster\n");
- $smtp->datasend("\n");
- $smtp->datasend("A simple test message\n");
- $smtp->dataend();
-
- $smtp->quit;
-
-=head1 CONSTRUCTOR
-
-=over 4
-
-=item new ( [ HOST ] [, OPTIONS ] )
-
-This is the constructor for a new Net::SMTP object. C<HOST> is the
-name of the remote host to which an SMTP connection is required.
-
-C<HOST> is optional. If C<HOST> is not given then it may instead be
-passed as the C<Host> option described below. If neither is given then
-the C<SMTP_Hosts> specified in C<Net::Config> will be used.
-
-C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
-Possible options are:
-
-B<Hello> - SMTP requires that you identify yourself. This option
-specifies a string to pass as your mail domain. If not given localhost.localdomain
-will be used.
-
-B<Host> - SMTP host to connect to. It may be a single scalar, as defined for
-the C<PeerAddr> option in L<IO::Socket::INET>, or a reference to
-an array with hosts to try in turn. The L</host> method will return the value
-which was used to connect to the host.
-
-B<LocalAddr> and B<LocalPort> - These parameters are passed directly
-to IO::Socket to allow binding the socket to a local port.
-
-B<Timeout> - Maximum time, in seconds, to wait for a response from the
-SMTP server (default: 120)
-
-B<ExactAddresses> - If true the all ADDRESS arguments must be as
-defined by C<addr-spec> in RFC2822. If not given, or false, then
-Net::SMTP will attempt to extract the address from the value passed.
-
-B<Debug> - Enable debugging information
-
-
-Example:
-
-
- $smtp = Net::SMTP->new('mailhost',
- Hello => 'my.mail.domain',
- Timeout => 30,
- Debug => 1,
- );
-
- # the same
- $smtp = Net::SMTP->new(
- Host => 'mailhost',
- Hello => 'my.mail.domain',
- Timeout => 30,
- Debug => 1,
- );
-
- # Connect to the default server from Net::config
- $smtp = Net::SMTP->new(
- Hello => 'my.mail.domain',
- Timeout => 30,
- );
-
-=back
-
-=head1 METHODS
-
-Unless otherwise stated all methods return either a I<true> or I<false>
-value, with I<true> meaning that the operation was a success. When a method
-states that it returns a value, failure will be returned as I<undef> or an
-empty list.
-
-=over 4
-
-=item banner ()
-
-Returns the banner message which the server replied with when the
-initial connection was made.
-
-=item domain ()
-
-Returns the domain that the remote SMTP server identified itself as during
-connection.
-
-=item hello ( DOMAIN )
-
-Tell the remote server the mail domain which you are in using the EHLO
-command (or HELO if EHLO fails). Since this method is invoked
-automatically when the Net::SMTP object is constructed the user should
-normally not have to call it manually.
-
-=item host ()
-
-Returns the value used by the constructor, and passed to IO::Socket::INET,
-to connect to the host.
-
-=item etrn ( DOMAIN )
-
-Request a queue run for the DOMAIN given.
-
-=item auth ( USERNAME, PASSWORD )
-
-Attempt SASL authentication.
-
-=item mail ( ADDRESS [, OPTIONS] )
-
-=item send ( ADDRESS )
-
-=item send_or_mail ( ADDRESS )
-
-=item send_and_mail ( ADDRESS )
-
-Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
-is the address of the sender. This initiates the sending of a message. The
-method C<recipient> should be called for each address that the message is to
-be sent to.
-
-The C<mail> method can some additional ESMTP OPTIONS which is passed
-in hash like fashion, using key and value pairs. Possible options are:
-
- Size => <bytes>
- Return => "FULL" | "HDRS"
- Bits => "7" | "8" | "binary"
- Transaction => <ADDRESS>
- Envelope => <ENVID> # xtext-encodes its argument
- ENVID => <ENVID> # similar to Envelope, but expects argument encoded
- XVERP => 1
- AUTH => <submitter> # encoded address according to RFC 2554
-
-The C<Return> and C<Envelope> parameters are used for DSN (Delivery
-Status Notification).
-
-The submitter address in C<AUTH> option is expected to be in a format as
-required by RFC 2554, in an RFC2821-quoted form and xtext-encoded, or <> .
-
-=item reset ()
-
-Reset the status of the server. This may be called after a message has been
-initiated, but before any data has been sent, to cancel the sending of the
-message.
-
-=item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] )
-
-Notify the server that the current message should be sent to all of the
-addresses given. Each address is sent as a separate command to the server.
-Should the sending of any address result in a failure then the process is
-aborted and a I<false> value is returned. It is up to the user to call
-C<reset> if they so desire.
-
-The C<recipient> method can also pass additional case-sensitive OPTIONS as an
-anonymous hash using key and value pairs. Possible options are:
-
- Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below)
- ORcpt => <ORCPT>
- SkipBad => 1 (to ignore bad addresses)
-
-If C<SkipBad> is true the C<recipient> will not return an error when a bad
-address is encountered and it will return an array of addresses that did
-succeed.
-
- $smtp->recipient($recipient1,$recipient2); # Good
- $smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good
- $smtp->recipient($recipient1,$recipient2, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
- @goodrecips=$smtp->recipient(@recipients, { Notify => ['FAILURE'], SkipBad => 1 }); # Good
- $smtp->recipient("$recipient,$recipient2"); # BAD
-
-Notify is used to request Delivery Status Notifications (DSNs), but your
-SMTP/ESMTP service may not respect this request depending upon its version and
-your site's SMTP configuration.
-
-Leaving out the Notify option usually defaults an SMTP service to its default
-behavior equivalent to ['FAILURE'] notifications only, but again this may be
-dependent upon your site's SMTP configuration.
-
-The NEVER keyword must appear by itself if used within the Notify option and "requests
-that a DSN not be returned to the sender under any conditions."
-
- {Notify => ['NEVER']}
-
- $smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good
-
-You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in
-the anonymous array reference as defined by RFC3461 (see http://rfc.net/rfc3461.html
-for more information. Note: quotations in this topic from same.).
-
-A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on
-successful delivery or delivery failure, respectively."
-
-A Notify parameter of 'DELAY' "indicates the sender's willingness to receive
-delayed DSNs. Delayed DSNs may be issued if delivery of a message has been
-delayed for an unusual amount of time (as determined by the Message Transfer
-Agent (MTA) at which the message is delayed), but the final delivery status
-(whether successful or failure) cannot be determined. The absence of the DELAY
-keyword in a NOTIFY parameter requests that a "delayed" DSN NOT be issued under
-any conditions."
-
- {Notify => ['SUCCESS','FAILURE','DELAY']}
-
- $smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good
-
-ORcpt is also part of the SMTP DSN extension according to RFC3461.
-It is used to pass along the original recipient that the mail was first
-sent to. The machine that generates a DSN will use this address to inform
-the sender, because he can't know if recipients get rewritten by mail servers.
-It is expected to be in a format as required by RFC3461, xtext-encoded.
-
-=item to ( ADDRESS [, ADDRESS [...]] )
-
-=item cc ( ADDRESS [, ADDRESS [...]] )
-
-=item bcc ( ADDRESS [, ADDRESS [...]] )
-
-Synonyms for C<recipient>.
-
-=item data ( [ DATA ] )
-
-Initiate the sending of the data from the current message.
-
-C<DATA> may be a reference to a list or a list. If specified the contents
-of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
-result will be true if the data was accepted.
-
-If C<DATA> is not specified then the result will indicate that the server
-wishes the data to be sent. The data must then be sent using the C<datasend>
-and C<dataend> methods described in L<Net::Cmd>.
-
-=item expand ( ADDRESS )
-
-Request the server to expand the given address Returns an array
-which contains the text read from the server.
-
-=item verify ( ADDRESS )
-
-Verify that C<ADDRESS> is a legitimate mailing address.
-
-Most sites usually disable this feature in their SMTP service configuration.
-Use "Debug => 1" option under new() to see if disabled.
-
-=item help ( [ $subject ] )
-
-Request help text from the server. Returns the text or undef upon failure
-
-=item quit ()
-
-Send the QUIT command to the remote SMTP server and close the socket connection.
-
-=back
-
-=head1 ADDRESSES
-
-Net::SMTP attempts to DWIM with addresses that are passed. For
-example an application might extract The From: line from an email
-and pass that to mail(). While this may work, it is not recommended.
-The application should really use a module like L<Mail::Address>
-to extract the mail address and pass that.
-
-If C<ExactAddresses> is passed to the constructor, then addresses
-should be a valid rfc2821-quoted address, although Net::SMTP will
-accept accept the address surrounded by angle brackets.
-
- funny user at domain WRONG
- "funny user"@domain RIGHT, recommended
- <"funny user"@domain> OK
-
-=head1 SEE ALSO
-
-L<Net::Cmd>
-
-=head1 AUTHOR
-
-Graham Barr <gbarr at pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2004 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/Time.pm
===================================================================
--- trunk/contrib/perl/lib/Net/Time.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/Time.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,151 +0,0 @@
-# Net::Time.pm
-#
-# Copyright (c) 1995-2004 Graham Barr <gbarr at pobox.com>. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Net::Time;
-
-use strict;
-use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
-use Carp;
-use IO::Socket;
-require Exporter;
-use Net::Config;
-use IO::Select;
-
- at ISA = qw(Exporter);
- at EXPORT_OK = qw(inet_time inet_daytime);
-
-$VERSION = "2.10";
-
-$TIMEOUT = 120;
-
-
-sub _socket {
- my ($pname, $pnum, $host, $proto, $timeout) = @_;
-
- $proto ||= 'udp';
-
- my $port = (getservbyname($pname, $proto))[2] || $pnum;
-
- my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'};
-
- my $me;
-
- foreach $host (@$hosts) {
- $me = IO::Socket::INET->new(
- PeerAddr => $host,
- PeerPort => $port,
- Proto => $proto
- )
- and last;
- }
-
- return unless $me;
-
- $me->send("\n")
- if $proto eq 'udp';
-
- $timeout = $TIMEOUT
- unless defined $timeout;
-
- IO::Select->new($me)->can_read($timeout)
- ? $me
- : undef;
-}
-
-
-sub inet_time {
- my $s = _socket('time', 37, @_) || return undef;
- my $buf = '';
- my $offset = 0 | 0;
-
- return undef
- unless defined $s->recv($buf, length(pack("N", 0)));
-
- # unpack, we | 0 to ensure we have an unsigned
- my $time = (unpack("N", $buf))[0] | 0;
-
- # the time protocol return time in seconds since 1900, convert
- # it to a the required format
-
- if ($^O eq "MacOS") {
-
- # MacOS return seconds since 1904, 1900 was not a leap year.
- $offset = (4 * 31536000) | 0;
- }
- else {
-
- # otherwise return seconds since 1972, there were 17 leap years between
- # 1900 and 1972
- $offset = (70 * 31536000 + 17 * 86400) | 0;
- }
-
- $time - $offset;
-}
-
-
-sub inet_daytime {
- my $s = _socket('daytime', 13, @_) || return undef;
- my $buf = '';
-
- defined($s->recv($buf, 1024))
- ? $buf
- : undef;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Net::Time - time and daytime network client interface
-
-=head1 SYNOPSIS
-
- use Net::Time qw(inet_time inet_daytime);
-
- print inet_time(); # use default host from Net::Config
- print inet_time('localhost');
- print inet_time('localhost', 'tcp');
-
- print inet_daytime(); # use default host from Net::Config
- print inet_daytime('localhost');
- print inet_daytime('localhost', 'tcp');
-
-=head1 DESCRIPTION
-
-C<Net::Time> provides subroutines that obtain the time on a remote machine.
-
-=over 4
-
-=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])
-
-Obtain the time on C<HOST>, or some default host if C<HOST> is not given
-or not defined, using the protocol as defined in RFC868. The optional
-argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
-C<udp>. The result will be a time value in the same units as returned
-by time() or I<undef> upon failure.
-
-=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])
-
-Obtain the time on C<HOST>, or some default host if C<HOST> is not given
-or not defined, using the protocol as defined in RFC867. The optional
-argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
-C<udp>. The result will be an ASCII string or I<undef> upon failure.
-
-=back
-
-=head1 AUTHOR
-
-Graham Barr <gbarr at pobox.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 1995-2004 Graham Barr. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Net/libnetFAQ.pod
===================================================================
--- trunk/contrib/perl/lib/Net/libnetFAQ.pod 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Net/libnetFAQ.pod 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,303 +0,0 @@
-=head1 NAME
-
-libnetFAQ - libnet Frequently Asked Questions
-
-=head1 DESCRIPTION
-
-=head2 Where to get this document
-
-This document is distributed with the libnet distribution, and is also
-available on the libnet web page at
-
- http://search.cpan.org/~gbarr/libnet/
-
-=head2 How to contribute to this document
-
-You may mail corrections, additions, and suggestions to me
-gbarr at pobox.com.
-
-=head1 Author and Copyright Information
-
-Copyright (c) 1997-1998 Graham Barr. All rights reserved.
-This document is free; you can redistribute it and/or modify it
-under the terms of the Artistic License.
-
-=head2 Disclaimer
-
-This information is offered in good faith and in the hope that it may
-be of use, but is not guaranteed to be correct, up to date, or suitable
-for any particular purpose whatsoever. The authors accept no liability
-in respect of this information or its use.
-
-
-=head1 Obtaining and installing libnet
-
-=head2 What is libnet ?
-
-libnet is a collection of perl5 modules which all related to network
-programming. The majority of the modules available provided the
-client side of popular server-client protocols that are used in
-the internet community.
-
-=head2 Which version of perl do I need ?
-
-libnet has been know to work with versions of perl from 5.002 onwards. However
-if your release of perl is prior to perl5.004 then you will need to
-obtain and install the IO distribution from CPAN. If you have perl5.004
-or later then you will have the IO modules in your installation already,
-but CPAN may contain updates.
-
-=head2 What other modules do I need ?
-
-The only modules you will need installed are the modules from the IO
-distribution. If you have perl5.004 or later you will already have
-these modules.
-
-=head2 What machines support libnet ?
-
-libnet itself is an entirely perl-code distribution so it should work
-on any machine that perl runs on. However IO may not work
-with some machines and earlier releases of perl. But this
-should not be the case with perl version 5.004 or later.
-
-=head2 Where can I get the latest libnet release
-
-The latest libnet release is always on CPAN, you will find it
-in
-
- http://www.cpan.org/modules/by-module/Net/
-
-The latest release and information is also available on the libnet web page
-at
-
- http://search.cpan.org/~gbarr/libnet/
-
-=head1 Using Net::FTP
-
-=head2 How do I download files from an FTP server ?
-
-An example taken from an article posted to comp.lang.perl.misc
-
- #!/your/path/to/perl
-
- # a module making life easier
-
- use Net::FTP;
-
- # for debugging: $ftp = Net::FTP->new('site','Debug',10);
- # open a connection and log in!
-
- $ftp = Net::FTP->new('target_site.somewhere.xxx');
- $ftp->login('username','password');
-
- # set transfer mode to binary
-
- $ftp->binary();
-
- # change the directory on the ftp site
-
- $ftp->cwd('/some/path/to/somewhere/');
-
- foreach $name ('file1', 'file2', 'file3') {
-
- # get's arguments are in the following order:
- # ftp server's filename
- # filename to save the transfer to on the local machine
- # can be simply used as get($name) if you want the same name
-
- $ftp->get($name,$name);
- }
-
- # ftp done!
-
- $ftp->quit;
-
-=head2 How do I transfer files in binary mode ?
-
-To transfer files without <LF><CR> translation Net::FTP provides
-the C<binary> method
-
- $ftp->binary;
-
-=head2 How can I get the size of a file on a remote FTP server ?
-
-=head2 How can I get the modification time of a file on a remote FTP server ?
-
-=head2 How can I change the permissions of a file on a remote server ?
-
-The FTP protocol does not have a command for changing the permissions
-of a file on the remote server. But some ftp servers may allow a chmod
-command to be issued via a SITE command, eg
-
- $ftp->quot('site chmod 0777',$filename);
-
-But this is not guaranteed to work.
-
-=head2 Can I do a reget operation like the ftp command ?
-
-=head2 How do I get a directory listing from an FTP server ?
-
-=head2 Changing directory to "" does not fail ?
-
-Passing an argument of "" to ->cwd() has the same affect of calling ->cwd()
-without any arguments. Turn on Debug (I<See below>) and you will see what is
-happening
-
- $ftp = Net::FTP->new($host, Debug => 1);
- $ftp->login;
- $ftp->cwd("");
-
-gives
-
- Net::FTP=GLOB(0x82196d8)>>> CWD /
- Net::FTP=GLOB(0x82196d8)<<< 250 CWD command successful.
-
-=head2 I am behind a SOCKS firewall, but the Firewall option does not work ?
-
-The Firewall option is only for support of one type of firewall. The type
-supported is an ftp proxy.
-
-To use Net::FTP, or any other module in the libnet distribution,
-through a SOCKS firewall you must create a socks-ified perl executable
-by compiling perl with the socks library.
-
-=head2 I am behind an FTP proxy firewall, but cannot access machines outside ?
-
-Net::FTP implements the most popular ftp proxy firewall approach. The scheme
-implemented is that where you log in to the firewall with C<user at hostname>
-
-I have heard of one other type of firewall which requires a login to the
-firewall with an account, then a second login with C<user at hostname>. You can
-still use Net::FTP to traverse these firewalls, but a more manual approach
-must be taken, eg
-
- $ftp = Net::FTP->new($firewall) or die $@;
- $ftp->login($firewall_user, $firewall_passwd) or die $ftp->message;
- $ftp->login($ext_user . '@' . $ext_host, $ext_passwd) or die $ftp->message.
-
-=head2 My ftp proxy firewall does not listen on port 21
-
-FTP servers usually listen on the same port number, port 21, as any other
-FTP server. But there is no reason why this has to be the case.
-
-If you pass a port number to Net::FTP then it assumes this is the port
-number of the final destination. By default Net::FTP will always try
-to connect to the firewall on port 21.
-
-Net::FTP uses IO::Socket to open the connection and IO::Socket allows
-the port number to be specified as part of the hostname. So this problem
-can be resolved by either passing a Firewall option like C<"hostname:1234">
-or by setting the C<ftp_firewall> option in Net::Config to be a string
-in in the same form.
-
-=head2 Is it possible to change the file permissions of a file on an FTP server ?
-
-The answer to this is "maybe". The FTP protocol does not specify a command to change
-file permissions on a remote host. However many servers do allow you to run the
-chmod command via the C<SITE> command. This can be done with
-
- $ftp->site('chmod','0775',$file);
-
-=head2 I have seen scripts call a method message, but cannot find it documented ?
-
-Net::FTP, like several other packages in libnet, inherits from Net::Cmd, so
-all the methods described in Net::Cmd are also available on Net::FTP
-objects.
-
-=head2 Why does Net::FTP not implement mput and mget methods
-
-The quick answer is because they are easy to implement yourself. The long
-answer is that to write these in such a way that multiple platforms are
-supported correctly would just require too much code. Below are
-some examples how you can implement these yourself.
-
-sub mput {
- my($ftp,$pattern) = @_;
- foreach my $file (glob($pattern)) {
- $ftp->put($file) or warn $ftp->message;
- }
-}
-
-sub mget {
- my($ftp,$pattern) = @_;
- foreach my $file ($ftp->ls($pattern)) {
- $ftp->get($file) or warn $ftp->message;
- }
-}
-
-
-=head1 Using Net::SMTP
-
-=head2 Why can't the part of an Email address after the @ be used as the hostname ?
-
-The part of an Email address which follows the @ is not necessarily a hostname,
-it is a mail domain. To find the name of a host to connect for a mail domain
-you need to do a DNS MX lookup
-
-=head2 Why does Net::SMTP not do DNS MX lookups ?
-
-Net::SMTP implements the SMTP protocol. The DNS MX lookup is not part
-of this protocol.
-
-=head2 The verify method always returns true ?
-
-Well it may seem that way, but it does not. The verify method returns true
-if the command succeeded. If you pass verify an address which the
-server would normally have to forward to another machine, the command
-will succeed with something like
-
- 252 Couldn't verify <someone at there> but will attempt delivery anyway
-
-This command will fail only if you pass it an address in a domain
-the server directly delivers for, and that address does not exist.
-
-=head1 Debugging scripts
-
-=head2 How can I debug my scripts that use Net::* modules ?
-
-Most of the libnet client classes allow options to be passed to the
-constructor, in most cases one option is called C<Debug>. Passing
-this option with a non-zero value will turn on a protocol trace, which
-will be sent to STDERR. This trace can be useful to see what commands
-are being sent to the remote server and what responses are being
-received back.
-
- #!/your/path/to/perl
-
- use Net::FTP;
-
- my $ftp = new Net::FTP($host, Debug => 1);
- $ftp->login('gbarr','password');
- $ftp->quit;
-
-this script would output something like
-
- Net::FTP: Net::FTP(2.22)
- Net::FTP: Exporter
- Net::FTP: Net::Cmd(2.0801)
- Net::FTP: IO::Socket::INET
- Net::FTP: IO::Socket(1.1603)
- Net::FTP: IO::Handle(1.1504)
-
- Net::FTP=GLOB(0x8152974)<<< 220 imagine FTP server (Version wu-2.4(5) Tue Jul 29 11:17:18 CDT 1997) ready.
- Net::FTP=GLOB(0x8152974)>>> user gbarr
- Net::FTP=GLOB(0x8152974)<<< 331 Password required for gbarr.
- Net::FTP=GLOB(0x8152974)>>> PASS ....
- Net::FTP=GLOB(0x8152974)<<< 230 User gbarr logged in. Access restrictions apply.
- Net::FTP=GLOB(0x8152974)>>> QUIT
- Net::FTP=GLOB(0x8152974)<<< 221 Goodbye.
-
-The first few lines tell you the modules that Net::FTP uses and their versions,
-this is useful data to me when a user reports a bug. The last seven lines
-show the communication with the server. Each line has three parts. The first
-part is the object itself, this is useful for separating the output
-if you are using multiple objects. The second part is either C<<<<<> to
-show data coming from the server or C<>>>>> to show data
-going to the server. The remainder of the line is the command
-being sent or response being received.
-
-=head1 AUTHOR AND COPYRIGHT
-
-Copyright (c) 1997 Graham Barr.
-All rights reserved.
-
Deleted: trunk/contrib/perl/lib/Pod/Checker.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Checker.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Checker.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1268 +0,0 @@
-#############################################################################
-# Pod/Checker.pm -- check pod documents for syntax errors
-#
-# Copyright (C) 1994-2000 by Bradford Appleton. All rights reserved.
-# This file is part of "PodParser". PodParser is free software;
-# you can redistribute it and/or modify it under the same terms
-# as Perl itself.
-#############################################################################
-
-package Pod::Checker;
-use strict;
-
-use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES);
-$VERSION = '1.45'; ## Current version of this package
-require 5.005; ## requires this Perl version or later
-
-use Pod::ParseUtils; ## for hyperlinks and lists
-
-=head1 NAME
-
-Pod::Checker, podchecker() - check pod documents for syntax errors
-
-=head1 SYNOPSIS
-
- use Pod::Checker;
-
- $syntax_okay = podchecker($filepath, $outputpath, %options);
-
- my $checker = new Pod::Checker %options;
- $checker->parse_from_file($filepath, \*STDERR);
-
-=head1 OPTIONS/ARGUMENTS
-
-C<$filepath> is the input POD to read and C<$outputpath> is
-where to write POD syntax error messages. Either argument may be a scalar
-indicating a file-path, or else a reference to an open filehandle.
-If unspecified, the input-file it defaults to C<\*STDIN>, and
-the output-file defaults to C<\*STDERR>.
-
-=head2 podchecker()
-
-This function can take a hash of options:
-
-=over 4
-
-=item B<-warnings> =E<gt> I<val>
-
-Turn warnings on/off. I<val> is usually 1 for on, but higher values
-trigger additional warnings. See L<"Warnings">.
-
-=back
-
-=head1 DESCRIPTION
-
-B<podchecker> will perform syntax checking of Perl5 POD format documentation.
-
-Curious/ambitious users are welcome to propose additional features they wish
-to see in B<Pod::Checker> and B<podchecker> and verify that the checks are
-consistent with L<perlpod>.
-
-The following checks are currently performed:
-
-=over 4
-
-=item *
-
-Unknown '=xxxx' commands, unknown 'XE<lt>...E<gt>' interior-sequences,
-and unterminated interior sequences.
-
-=item *
-
-Check for proper balancing of C<=begin> and C<=end>. The contents of such
-a block are generally ignored, i.e. no syntax checks are performed.
-
-=item *
-
-Check for proper nesting and balancing of C<=over>, C<=item> and C<=back>.
-
-=item *
-
-Check for same nested interior-sequences (e.g.
-C<LE<lt>...LE<lt>...E<gt>...E<gt>>).
-
-=item *
-
-Check for malformed or non-existing entities C<EE<lt>...E<gt>>.
-
-=item *
-
-Check for correct syntax of hyperlinks C<LE<lt>...E<gt>>. See L<perlpod>
-for details.
-
-=item *
-
-Check for unresolved document-internal links. This check may also reveal
-misspelled links that seem to be internal links but should be links
-to something else.
-
-=back
-
-=head1 DIAGNOSTICS
-
-=head2 Errors
-
-=over 4
-
-=item * empty =headn
-
-A heading (C<=head1> or C<=head2>) without any text? That ain't no
-heading!
-
-=item * =over on line I<N> without closing =back
-
-The C<=over> command does not have a corresponding C<=back> before the
-next heading (C<=head1> or C<=head2>) or the end of the file.
-
-=item * =item without previous =over
-
-=item * =back without previous =over
-
-An C<=item> or C<=back> command has been found outside a
-C<=over>/C<=back> block.
-
-=item * No argument for =begin
-
-A C<=begin> command was found that is not followed by the formatter
-specification.
-
-=item * =end without =begin
-
-A standalone C<=end> command was found.
-
-=item * Nested =begin's
-
-There were at least two consecutive C<=begin> commands without
-the corresponding C<=end>. Only one C<=begin> may be active at
-a time.
-
-=item * =for without formatter specification
-
-There is no specification of the formatter after the C<=for> command.
-
-=item * unresolved internal link I<NAME>
-
-The given link to I<NAME> does not have a matching node in the current
-POD. This also happened when a single word node name is not enclosed in
-C<"">.
-
-=item * Unknown command "I<CMD>"
-
-An invalid POD command has been found. Valid are C<=head1>, C<=head2>,
-C<=head3>, C<=head4>, C<=over>, C<=item>, C<=back>, C<=begin>, C<=end>,
-C<=for>, C<=pod>, C<=cut>
-
-=item * Unknown interior-sequence "I<SEQ>"
-
-An invalid markup command has been encountered. Valid are:
-C<BE<lt>E<gt>>, C<CE<lt>E<gt>>, C<EE<lt>E<gt>>, C<FE<lt>E<gt>>,
-C<IE<lt>E<gt>>, C<LE<lt>E<gt>>, C<SE<lt>E<gt>>, C<XE<lt>E<gt>>,
-C<ZE<lt>E<gt>>
-
-=item * nested commands I<CMD>E<lt>...I<CMD>E<lt>...E<gt>...E<gt>
-
-Two nested identical markup commands have been found. Generally this
-does not make sense.
-
-=item * garbled entity I<STRING>
-
-The I<STRING> found cannot be interpreted as a character entity.
-
-=item * Entity number out of range
-
-An entity specified by number (dec, hex, oct) is out of range (1-255).
-
-=item * malformed link LE<lt>E<gt>
-
-The link found cannot be parsed because it does not conform to the
-syntax described in L<perlpod>.
-
-=item * nonempty ZE<lt>E<gt>
-
-The C<ZE<lt>E<gt>> sequence is supposed to be empty.
-
-=item * empty XE<lt>E<gt>
-
-The index entry specified contains nothing but whitespace.
-
-=item * Spurious text after =pod / =cut
-
-The commands C<=pod> and C<=cut> do not take any arguments.
-
-=item * Spurious character(s) after =back
-
-The C<=back> command does not take any arguments.
-
-=back
-
-=head2 Warnings
-
-These may not necessarily cause trouble, but indicate mediocre style.
-
-=over 4
-
-=item * multiple occurrence of link target I<name>
-
-The POD file has some C<=item> and/or C<=head> commands that have
-the same text. Potential hyperlinks to such a text cannot be unique then.
-This warning is printed only with warning level greater than one.
-
-=item * line containing nothing but whitespace in paragraph
-
-There is some whitespace on a seemingly empty line. POD is very sensitive
-to such things, so this is flagged. B<vi> users switch on the B<list>
-option to avoid this problem.
-
-=begin _disabled_
-
-=item * file does not start with =head
-
-The file starts with a different POD directive than head.
-This is most probably something you do not want.
-
-=end _disabled_
-
-=item * previous =item has no contents
-
-There is a list C<=item> right above the flagged line that has no
-text contents. You probably want to delete empty items.
-
-=item * preceding non-item paragraph(s)
-
-A list introduced by C<=over> starts with a text or verbatim paragraph,
-but continues with C<=item>s. Move the non-item paragraph out of the
-C<=over>/C<=back> block.
-
-=item * =item type mismatch (I<one> vs. I<two>)
-
-A list started with e.g. a bullet-like C<=item> and continued with a
-numbered one. This is obviously inconsistent. For most translators the
-type of the I<first> C<=item> determines the type of the list.
-
-=item * I<N> unescaped C<E<lt>E<gt>> in paragraph
-
-Angle brackets not written as C<E<lt>ltE<gt>> and C<E<lt>gtE<gt>>
-can potentially cause errors as they could be misinterpreted as
-markup commands. This is only printed when the -warnings level is
-greater than 1.
-
-=item * Unknown entity
-
-A character entity was found that does not belong to the standard
-ISO set or the POD specials C<verbar> and C<sol>.
-
-=item * No items in =over
-
-The list opened with C<=over> does not contain any items.
-
-=item * No argument for =item
-
-C<=item> without any parameters is deprecated. It should either be followed
-by C<*> to indicate an unordered list, by a number (optionally followed
-by a dot) to indicate an ordered (numbered) list or simple text for a
-definition list.
-
-=item * empty section in previous paragraph
-
-The previous section (introduced by a C<=head> command) does not contain
-any text. This usually indicates that something is missing. Note: A
-C<=head1> followed immediately by C<=head2> does not trigger this warning.
-
-=item * Verbatim paragraph in NAME section
-
-The NAME section (C<=head1 NAME>) should consist of a single paragraph
-with the script/module name, followed by a dash `-' and a very short
-description of what the thing is good for.
-
-=item * =headI<n> without preceding higher level
-
-For example if there is a C<=head2> in the POD file prior to a
-C<=head1>.
-
-=back
-
-=head2 Hyperlinks
-
-There are some warnings with respect to malformed hyperlinks:
-
-=over 4
-
-=item * ignoring leading/trailing whitespace in link
-
-There is whitespace at the beginning or the end of the contents of
-LE<lt>...E<gt>.
-
-=item * (section) in '$page' deprecated
-
-There is a section detected in the page name of LE<lt>...E<gt>, e.g.
-C<LE<lt>passwd(2)E<gt>>. POD hyperlinks may point to POD documents only.
-Please write C<CE<lt>passwd(2)E<gt>> instead. Some formatters are able
-to expand this to appropriate code. For links to (builtin) functions,
-please say C<LE<lt>perlfunc/mkdirE<gt>>, without ().
-
-=item * alternative text/node '%s' contains non-escaped | or /
-
-The characters C<|> and C</> are special in the LE<lt>...E<gt> context.
-Although the hyperlink parser does its best to determine which "/" is
-text and which is a delimiter in case of doubt, one ought to escape
-these literal characters like this:
-
- / E<sol>
- | E<verbar>
-
-=back
-
-=head1 RETURN VALUE
-
-B<podchecker> returns the number of POD syntax errors found or -1 if
-there were no POD commands at all found in the file.
-
-=head1 EXAMPLES
-
-See L</SYNOPSIS>
-
-=head1 INTERFACE
-
-While checking, this module collects document properties, e.g. the nodes
-for hyperlinks (C<=headX>, C<=item>) and index entries (C<XE<lt>E<gt>>).
-POD translators can use this feature to syntax-check and get the nodes in
-a first pass before actually starting to convert. This is expensive in terms
-of execution time, but allows for very robust conversions.
-
-Since PodParser-1.24 the B<Pod::Checker> module uses only the B<poderror>
-method to print errors and warnings. The summary output (e.g.
-"Pod syntax OK") has been dropped from the module and has been included in
-B<podchecker> (the script). This allows users of B<Pod::Checker> to
-control completely the output behavior. Users of B<podchecker> (the script)
-get the well-known behavior.
-
-=cut
-
-#############################################################################
-
-#use diagnostics;
-use Carp qw(croak);
-use Exporter;
-use Pod::Parser;
-
- at ISA = qw(Pod::Parser);
- at EXPORT = qw(&podchecker);
-
-my %VALID_COMMANDS = (
- 'pod' => 1,
- 'cut' => 1,
- 'head1' => 1,
- 'head2' => 1,
- 'head3' => 1,
- 'head4' => 1,
- 'over' => 1,
- 'back' => 1,
- 'item' => 1,
- 'for' => 1,
- 'begin' => 1,
- 'end' => 1,
- 'encoding' => 1,
-);
-
-my %VALID_SEQUENCES = (
- 'I' => 1,
- 'B' => 1,
- 'S' => 1,
- 'C' => 1,
- 'L' => 1,
- 'F' => 1,
- 'X' => 1,
- 'Z' => 1,
- 'E' => 1,
-);
-
-# stolen from HTML::Entities
-my %ENTITIES = (
- # Some normal chars that have special meaning in SGML context
- amp => '&', # ampersand
-'gt' => '>', # greater than
-'lt' => '<', # less than
- quot => '"', # double quote
-
- # PUBLIC ISO 8879-1986//ENTITIES Added Latin 1//EN//HTML
- AElig => '\xC6', # capital AE diphthong (ligature)
- Aacute => '\xC1', # capital A, acute accent
- Acirc => '\xC2', # capital A, circumflex accent
- Agrave => '\xC0', # capital A, grave accent
- Aring => '\xC5', # capital A, ring
- Atilde => '\xC3', # capital A, tilde
- Auml => '\xC4', # capital A, dieresis or umlaut mark
- Ccedil => '\xC7', # capital C, cedilla
- ETH => '\xD0', # capital Eth, Icelandic
- Eacute => '\xC9', # capital E, acute accent
- Ecirc => '\xCA', # capital E, circumflex accent
- Egrave => '\xC8', # capital E, grave accent
- Euml => '\xCB', # capital E, dieresis or umlaut mark
- Iacute => '\xCD', # capital I, acute accent
- Icirc => '\xCE', # capital I, circumflex accent
- Igrave => '\xCC', # capital I, grave accent
- Iuml => '\xCF', # capital I, dieresis or umlaut mark
- Ntilde => '\xD1', # capital N, tilde
- Oacute => '\xD3', # capital O, acute accent
- Ocirc => '\xD4', # capital O, circumflex accent
- Ograve => '\xD2', # capital O, grave accent
- Oslash => '\xD8', # capital O, slash
- Otilde => '\xD5', # capital O, tilde
- Ouml => '\xD6', # capital O, dieresis or umlaut mark
- THORN => '\xDE', # capital THORN, Icelandic
- Uacute => '\xDA', # capital U, acute accent
- Ucirc => '\xDB', # capital U, circumflex accent
- Ugrave => '\xD9', # capital U, grave accent
- Uuml => '\xDC', # capital U, dieresis or umlaut mark
- Yacute => '\xDD', # capital Y, acute accent
- aacute => '\xE1', # small a, acute accent
- acirc => '\xE2', # small a, circumflex accent
- aelig => '\xE6', # small ae diphthong (ligature)
- agrave => '\xE0', # small a, grave accent
- aring => '\xE5', # small a, ring
- atilde => '\xE3', # small a, tilde
- auml => '\xE4', # small a, dieresis or umlaut mark
- ccedil => '\xE7', # small c, cedilla
- eacute => '\xE9', # small e, acute accent
- ecirc => '\xEA', # small e, circumflex accent
- egrave => '\xE8', # small e, grave accent
- eth => '\xF0', # small eth, Icelandic
- euml => '\xEB', # small e, dieresis or umlaut mark
- iacute => '\xED', # small i, acute accent
- icirc => '\xEE', # small i, circumflex accent
- igrave => '\xEC', # small i, grave accent
- iuml => '\xEF', # small i, dieresis or umlaut mark
- ntilde => '\xF1', # small n, tilde
- oacute => '\xF3', # small o, acute accent
- ocirc => '\xF4', # small o, circumflex accent
- ograve => '\xF2', # small o, grave accent
- oslash => '\xF8', # small o, slash
- otilde => '\xF5', # small o, tilde
- ouml => '\xF6', # small o, dieresis or umlaut mark
- szlig => '\xDF', # small sharp s, German (sz ligature)
- thorn => '\xFE', # small thorn, Icelandic
- uacute => '\xFA', # small u, acute accent
- ucirc => '\xFB', # small u, circumflex accent
- ugrave => '\xF9', # small u, grave accent
- uuml => '\xFC', # small u, dieresis or umlaut mark
- yacute => '\xFD', # small y, acute accent
- yuml => '\xFF', # small y, dieresis or umlaut mark
-
- # Some extra Latin 1 chars that are listed in the HTML3.2 draft (21-May-96)
- copy => '\xA9', # copyright sign
- reg => '\xAE', # registered sign
- nbsp => "\240", # non breaking space
-
- # Additional ISO-8859/1 entities listed in rfc1866 (section 14)
- iexcl => '\xA1',
- cent => '\xA2',
- pound => '\xA3',
- curren => '\xA4',
- yen => '\xA5',
- brvbar => '\xA6',
- sect => '\xA7',
- uml => '\xA8',
- ordf => '\xAA',
- laquo => '\xAB',
-'not' => '\xAC', # not is a keyword in perl
- shy => '\xAD',
- macr => '\xAF',
- deg => '\xB0',
- plusmn => '\xB1',
- sup1 => '\xB9',
- sup2 => '\xB2',
- sup3 => '\xB3',
- acute => '\xB4',
- micro => '\xB5',
- para => '\xB6',
- middot => '\xB7',
- cedil => '\xB8',
- ordm => '\xBA',
- raquo => '\xBB',
- frac14 => '\xBC',
- frac12 => '\xBD',
- frac34 => '\xBE',
- iquest => '\xBF',
-'times' => '\xD7', # times is a keyword in perl
- divide => '\xF7',
-
-# some POD special entities
- verbar => '|',
- sol => '/'
-);
-
-##---------------------------------------------------------------------------
-
-##---------------------------------
-## Function definitions begin here
-##---------------------------------
-
-sub podchecker {
- my ($infile, $outfile, %options) = @_;
- local $_;
-
- ## Set defaults
- $infile ||= \*STDIN;
- $outfile ||= \*STDERR;
-
- ## Now create a pod checker
- my $checker = new Pod::Checker(%options);
-
- ## Now check the pod document for errors
- $checker->parse_from_file($infile, $outfile);
-
- ## Return the number of errors found
- return $checker->num_errors();
-}
-
-##---------------------------------------------------------------------------
-
-##-------------------------------
-## Method definitions begin here
-##-------------------------------
-
-##################################
-
-=over 4
-
-=item C<Pod::Checker-E<gt>new( %options )>
-
-Return a reference to a new Pod::Checker object that inherits from
-Pod::Parser and is used for calling the required methods later. The
-following options are recognized:
-
-C<-warnings =E<gt> num>
- Print warnings if C<num> is true. The higher the value of C<num>,
-the more warnings are printed. Currently there are only levels 1 and 2.
-
-C<-quiet =E<gt> num>
- If C<num> is true, do not print any errors/warnings. This is useful
-when Pod::Checker is used to munge POD code into plain text from within
-POD formatters.
-
-=cut
-
-## sub new {
-## my $this = shift;
-## my $class = ref($this) || $this;
-## my %params = @_;
-## my $self = {%params};
-## bless $self, $class;
-## $self->initialize();
-## return $self;
-## }
-
-sub initialize {
- my $self = shift;
- ## Initialize number of errors, and setup an error function to
- ## increment this number and then print to the designated output.
- $self->{_NUM_ERRORS} = 0;
- $self->{_NUM_WARNINGS} = 0;
- $self->{-quiet} ||= 0;
- # set the error handling subroutine
- $self->errorsub($self->{-quiet} ? sub { 1; } : 'poderror');
- $self->{_commands} = 0; # total number of POD commands encountered
- $self->{_list_stack} = []; # stack for nested lists
- $self->{_have_begin} = ''; # stores =begin
- $self->{_links} = []; # stack for internal hyperlinks
- $self->{_nodes} = []; # stack for =head/=item nodes
- $self->{_index} = []; # text in X<>
- # print warnings?
- $self->{-warnings} = 1 unless(defined $self->{-warnings});
- $self->{_current_head1} = ''; # the current =head1 block
- $self->parseopts(-process_cut_cmd => 1, -warnings => $self->{-warnings});
-}
-
-##################################
-
-=item C<$checker-E<gt>poderror( @args )>
-
-=item C<$checker-E<gt>poderror( {%opts}, @args )>
-
-Internal method for printing errors and warnings. If no options are
-given, simply prints "@_". The following options are recognized and used
-to form the output:
-
- -msg
-
-A message to print prior to C<@args>.
-
- -line
-
-The line number the error occurred in.
-
- -file
-
-The file (name) the error occurred in.
-
- -severity
-
-The error level, should be 'WARNING' or 'ERROR'.
-
-=cut
-
-# Invoked as $self->poderror( @args ), or $self->poderror( {%opts}, @args )
-sub poderror {
- my $self = shift;
- my %opts = (ref $_[0]) ? %{shift()} : ();
-
- ## Retrieve options
- chomp( my $msg = ($opts{-msg} || '')."@_" );
- my $line = (exists $opts{-line}) ? " at line $opts{-line}" : '';
- my $file = (exists $opts{-file}) ? " in file $opts{-file}" : '';
- unless (exists $opts{-severity}) {
- ## See if can find severity in message prefix
- $opts{-severity} = $1 if ( $msg =~ s/^\**\s*([A-Z]{3,}):\s+// );
- }
- my $severity = (exists $opts{-severity}) ? "*** $opts{-severity}: " : '';
-
- ## Increment error count and print message "
- ++($self->{_NUM_ERRORS})
- if(!%opts || ($opts{-severity} && $opts{-severity} eq 'ERROR'));
- ++($self->{_NUM_WARNINGS})
- if(!%opts || ($opts{-severity} && $opts{-severity} eq 'WARNING'));
- unless($self->{-quiet}) {
- my $out_fh = $self->output_handle() || \*STDERR;
- print $out_fh ($severity, $msg, $line, $file, "\n")
- if($self->{-warnings} || !%opts || $opts{-severity} ne 'WARNING');
- }
-}
-
-##################################
-
-=item C<$checker-E<gt>num_errors()>
-
-Set (if argument specified) and retrieve the number of errors found.
-
-=cut
-
-sub num_errors {
- return (@_ > 1) ? ($_[0]->{_NUM_ERRORS} = $_[1]) : $_[0]->{_NUM_ERRORS};
-}
-
-##################################
-
-=item C<$checker-E<gt>num_warnings()>
-
-Set (if argument specified) and retrieve the number of warnings found.
-
-=cut
-
-sub num_warnings {
- return (@_ > 1) ? ($_[0]->{_NUM_WARNINGS} = $_[1]) : $_[0]->{_NUM_WARNINGS};
-}
-
-##################################
-
-=item C<$checker-E<gt>name()>
-
-Set (if argument specified) and retrieve the canonical name of POD as
-found in the C<=head1 NAME> section.
-
-=cut
-
-sub name {
- return (@_ > 1 && $_[1]) ?
- ($_[0]->{-name} = $_[1]) : $_[0]->{-name};
-}
-
-##################################
-
-=item C<$checker-E<gt>node()>
-
-Add (if argument specified) and retrieve the nodes (as defined by C<=headX>
-and C<=item>) of the current POD. The nodes are returned in the order of
-their occurrence. They consist of plain text, each piece of whitespace is
-collapsed to a single blank.
-
-=cut
-
-sub node {
- my ($self,$text) = @_;
- if(defined $text) {
- $text =~ s/\s+$//s; # strip trailing whitespace
- $text =~ s/\s+/ /gs; # collapse whitespace
- # add node, order important!
- push(@{$self->{_nodes}}, $text);
- # keep also a uniqueness counter
- $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
- return $text;
- }
- @{$self->{_nodes}};
-}
-
-##################################
-
-=item C<$checker-E<gt>idx()>
-
-Add (if argument specified) and retrieve the index entries (as defined by
-C<XE<lt>E<gt>>) of the current POD. They consist of plain text, each piece
-of whitespace is collapsed to a single blank.
-
-=cut
-
-# set/return index entries of current POD
-sub idx {
- my ($self,$text) = @_;
- if(defined $text) {
- $text =~ s/\s+$//s; # strip trailing whitespace
- $text =~ s/\s+/ /gs; # collapse whitespace
- # add node, order important!
- push(@{$self->{_index}}, $text);
- # keep also a uniqueness counter
- $self->{_unique_nodes}->{$text}++ if($text !~ /^\s*$/s);
- return $text;
- }
- @{$self->{_index}};
-}
-
-##################################
-
-=item C<$checker-E<gt>hyperlink()>
-
-Add (if argument specified) and retrieve the hyperlinks (as defined by
-C<LE<lt>E<gt>>) of the current POD. They consist of a 2-item array: line
-number and C<Pod::Hyperlink> object.
-
-=back
-
-=cut
-
-# set/return hyperlinks of the current POD
-sub hyperlink {
- my $self = shift;
- if($_[0]) {
- push(@{$self->{_links}}, $_[0]);
- return $_[0];
- }
- @{$self->{_links}};
-}
-
-## overrides for Pod::Parser
-
-sub end_pod {
- ## Do some final checks and
- ## print the number of errors found
- my $self = shift;
- my $infile = $self->input_file();
-
- if(@{$self->{_list_stack}}) {
- my $list;
- while(($list = $self->_close_list('EOF',$infile)) &&
- $list->indent() ne 'auto') {
- $self->poderror({ -line => 'EOF', -file => $infile,
- -severity => 'ERROR', -msg => '=over on line ' .
- $list->start() . ' without closing =back' });
- }
- }
-
- # check validity of document internal hyperlinks
- # first build the node names from the paragraph text
- my %nodes;
- foreach($self->node()) {
- $nodes{$_} = 1;
- if(/^(\S+)\s+\S/) {
- # we have more than one word. Use the first as a node, too.
- # This is used heavily in perlfunc.pod
- $nodes{$1} ||= 2; # derived node
- }
- }
- foreach($self->idx()) {
- $nodes{$_} = 3; # index node
- }
- foreach($self->hyperlink()) {
- my ($line,$link) = @$_;
- # _TODO_ what if there is a link to the page itself by the name,
- # e.g. in Tk::Pod : L<Tk::Pod/"DESCRIPTION">
- if($link->node() && !$link->page() && $link->type() ne 'hyperlink') {
- my $node = $self->_check_ptree($self->parse_text($link->node(),
- $line), $line, $infile, 'L');
- if($node && !$nodes{$node}) {
- $self->poderror({ -line => $line || '', -file => $infile,
- -severity => 'ERROR',
- -msg => "unresolved internal link '$node'"});
- }
- }
- }
-
- # check the internal nodes for uniqueness. This pertains to
- # =headX, =item and X<...>
- if($self->{-warnings} && $self->{-warnings}>1) {
- foreach(grep($self->{_unique_nodes}->{$_} > 1,
- keys %{$self->{_unique_nodes}})) {
- $self->poderror({ -line => '-', -file => $infile,
- -severity => 'WARNING',
- -msg => "multiple occurrence of link target '$_'"});
- }
- }
-
- # no POD found here
- $self->num_errors(-1) if($self->{_commands} == 0);
-}
-
-# check a POD command directive
-sub command {
- my ($self, $cmd, $paragraph, $line_num, $pod_para) = @_;
- my ($file, $line) = $pod_para->file_line;
- ## Check the command syntax
- my $arg; # this will hold the command argument
- if (! $VALID_COMMANDS{$cmd}) {
- $self->poderror({ -line => $line, -file => $file, -severity => 'ERROR',
- -msg => "Unknown command '$cmd'" });
- }
- else { # found a valid command
- $self->{_commands}++; # delete this line if below is enabled again
-
- ##### following check disabled due to strong request
- #if(!$self->{_commands}++ && $cmd !~ /^head/) {
- # $self->poderror({ -line => $line, -file => $file,
- # -severity => 'WARNING',
- # -msg => "file does not start with =head" });
- #}
-
- # check syntax of particular command
- if($cmd eq 'over') {
- # check for argument
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- my $indent = 4; # default
- if($arg && $arg =~ /^\s*(\d+)\s*$/) {
- $indent = $1;
- }
- # start a new list
- $self->_open_list($indent,$line,$file);
- }
- elsif($cmd eq 'item') {
- # are we in a list?
- unless(@{$self->{_list_stack}}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=item without previous =over' });
- # auto-open in case we encounter many more
- $self->_open_list('auto',$line,$file);
- }
- my $list = $self->{_list_stack}->[0];
- # check whether the previous item had some contents
- if(defined $self->{_list_item_contents} &&
- $self->{_list_item_contents} == 0) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'previous =item has no contents' });
- }
- if($list->{_has_par}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'preceding non-item paragraph(s)' });
- delete $list->{_has_par};
- }
- # check for argument
- $arg = $self->interpolate_and_check($paragraph, $line, $file);
- if($arg && $arg =~ /(\S+)/) {
- $arg =~ s/[\s\n]+$//;
- my $type;
- if($arg =~ /^[*]\s*(\S*.*)/) {
- $type = 'bullet';
- $self->{_list_item_contents} = $1 ? 1 : 0;
- $arg = $1;
- }
- elsif($arg =~ /^\d+\.?\s+(\S*)/) {
- $type = 'number';
- $self->{_list_item_contents} = $1 ? 1 : 0;
- $arg = $1;
- }
- else {
- $type = 'definition';
- $self->{_list_item_contents} = 1;
- }
- my $first = $list->type();
- if($first && $first ne $type) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => "=item type mismatch ('$first' vs. '$type')"});
- }
- else { # first item
- $list->type($type);
- }
- }
- else {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'No argument for =item' });
- $arg = ' '; # empty
- $self->{_list_item_contents} = 0;
- }
- # add this item
- $list->item($arg);
- # remember this node
- $self->node($arg);
- }
- elsif($cmd eq 'back') {
- # check if we have an open list
- unless(@{$self->{_list_stack}}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=back without previous =over' });
- }
- else {
- # check for spurious characters
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- if($arg && $arg =~ /\S/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'Spurious character(s) after =back' });
- }
- # close list
- my $list = $self->_close_list($line,$file);
- # check for empty lists
- if(!$list->item() && $self->{-warnings}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'No items in =over (at line ' .
- $list->start() . ') / =back list'});
- }
- }
- }
- elsif($cmd =~ /^head(\d+)/) {
- my $hnum = $1;
- $self->{"_have_head_$hnum"}++; # count head types
- if($hnum > 1 && !$self->{'_have_head_'.($hnum -1)}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => "=head$hnum without preceding higher level"});
- }
- # check whether the previous =head section had some contents
- if(defined $self->{_commands_in_head} &&
- $self->{_commands_in_head} == 0 &&
- defined $self->{_last_head} &&
- $self->{_last_head} >= $hnum) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'empty section in previous paragraph'});
- }
- $self->{_commands_in_head} = -1;
- $self->{_last_head} = $hnum;
- # check if there is an open list
- if(@{$self->{_list_stack}}) {
- my $list;
- while(($list = $self->_close_list($line,$file)) &&
- $list->indent() ne 'auto') {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=over on line '. $list->start() .
- " without closing =back (at $cmd)" });
- }
- }
- # remember this node
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- $arg =~ s/[\s\n]+$//s;
- $self->node($arg);
- unless(length($arg)) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => "empty =$cmd"});
- }
- if($cmd eq 'head1') {
- $self->{_current_head1} = $arg;
- } else {
- $self->{_current_head1} = '';
- }
- }
- elsif($cmd eq 'begin') {
- if($self->{_have_begin}) {
- # already have a begin
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => q{Nested =begin's (first at line } .
- $self->{_have_begin} . ')'});
- }
- else {
- # check for argument
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- unless($arg && $arg =~ /(\S+)/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'No argument for =begin'});
- }
- # remember the =begin
- $self->{_have_begin} = "$line:$1";
- }
- }
- elsif($cmd eq 'end') {
- if($self->{_have_begin}) {
- # close the existing =begin
- $self->{_have_begin} = '';
- # check for spurious characters
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- # the closing argument is optional
- #if($arg && $arg =~ /\S/) {
- # $self->poderror({ -line => $line, -file => $file,
- # -severity => 'WARNING',
- # -msg => "Spurious character(s) after =end" });
- #}
- }
- else {
- # don't have a matching =begin
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=end without =begin' });
- }
- }
- elsif($cmd eq 'for') {
- unless($paragraph =~ /\s*(\S+)\s*/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => '=for without formatter specification' });
- }
- $arg = ''; # do not expand paragraph below
- }
- elsif($cmd =~ /^(pod|cut)$/) {
- # check for argument
- $arg = $self->interpolate_and_check($paragraph, $line,$file);
- if($arg && $arg =~ /(\S+)/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => "Spurious text after =$cmd"});
- }
- }
- $self->{_commands_in_head}++;
- ## Check the interior sequences in the command-text
- $self->interpolate_and_check($paragraph, $line,$file)
- unless(defined $arg);
- }
-}
-
-sub _open_list
-{
- my ($self,$indent,$line,$file) = @_;
- my $list = Pod::List->new(
- -indent => $indent,
- -start => $line,
- -file => $file);
- unshift(@{$self->{_list_stack}}, $list);
- undef $self->{_list_item_contents};
- $list;
-}
-
-sub _close_list
-{
- my ($self,$line,$file) = @_;
- my $list = shift(@{$self->{_list_stack}});
- if(defined $self->{_list_item_contents} &&
- $self->{_list_item_contents} == 0) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'previous =item has no contents' });
- }
- undef $self->{_list_item_contents};
- $list;
-}
-
-# process a block of some text
-sub interpolate_and_check {
- my ($self, $paragraph, $line, $file) = @_;
- ## Check the interior sequences in the command-text
- # and return the text
- $self->_check_ptree(
- $self->parse_text($paragraph,$line), $line, $file, '');
-}
-
-sub _check_ptree {
- my ($self,$ptree,$line,$file,$nestlist) = @_;
- local($_);
- my $text = '';
- # process each node in the parse tree
- foreach(@$ptree) {
- # regular text chunk
- unless(ref) {
- # count the unescaped angle brackets
- # complain only when warning level is greater than 1
- if($self->{-warnings} && $self->{-warnings}>1) {
- my $count;
- if($count = tr/<>/<>/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => "$count unescaped <> in paragraph" });
- }
- }
- $text .= $_;
- next;
- }
- # have an interior sequence
- my $cmd = $_->cmd_name();
- my $contents = $_->parse_tree();
- ($file,$line) = $_->file_line();
- # check for valid tag
- if (! $VALID_SEQUENCES{$cmd}) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => qq(Unknown interior-sequence '$cmd')});
- # expand it anyway
- $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
- next;
- }
- if($nestlist =~ /$cmd/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => "nested commands $cmd<...$cmd<...>...>"});
- # _TODO_ should we add the contents anyway?
- # expand it anyway, see below
- }
- if($cmd eq 'E') {
- # preserve entities
- if(@$contents > 1 || ref $$contents[0] || $$contents[0] !~ /^\w+$/) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'garbled entity ' . $_->raw_text()});
- next;
- }
- my $ent = $$contents[0];
- my $val;
- if($ent =~ /^0x[0-9a-f]+$/i) {
- # hexadec entity
- $val = hex($ent);
- }
- elsif($ent =~ /^0\d+$/) {
- # octal
- $val = oct($ent);
- }
- elsif($ent =~ /^\d+$/) {
- # numeric entity
- $val = $ent;
- }
- if(defined $val) {
- if($val>0 && $val<256) {
- $text .= chr($val);
- }
- else {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'Entity number out of range ' . $_->raw_text()});
- }
- }
- elsif($ENTITIES{$ent}) {
- # known ISO entity
- $text .= $ENTITIES{$ent};
- }
- else {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'Unknown entity ' . $_->raw_text()});
- $text .= "E<$ent>";
- }
- }
- elsif($cmd eq 'L') {
- # try to parse the hyperlink
- my $link = Pod::Hyperlink->new($contents->raw_text());
- unless(defined $link) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'malformed link ' . $_->raw_text() ." : $@"});
- next;
- }
- $link->line($line); # remember line
- if($self->{-warnings}) {
- foreach my $w ($link->warning()) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => $w });
- }
- }
- # check the link text
- $text .= $self->_check_ptree($self->parse_text($link->text(),
- $line), $line, $file, "$nestlist$cmd");
- # remember link
- $self->hyperlink([$line,$link]);
- }
- elsif($cmd =~ /[BCFIS]/) {
- # add the guts
- $text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
- }
- elsif($cmd eq 'Z') {
- if(length($contents->raw_text())) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'Nonempty Z<>'});
- }
- }
- elsif($cmd eq 'X') {
- my $idx = $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
- if($idx =~ /^\s*$/s) {
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'ERROR',
- -msg => 'Empty X<>'});
- }
- else {
- # remember this node
- $self->idx($idx);
- }
- }
- else {
- # not reached
- croak 'internal error';
- }
- }
- $text;
-}
-
-# process a block of verbatim text
-sub verbatim {
- ## Nothing particular to check
- my ($self, $paragraph, $line_num, $pod_para) = @_;
-
- $self->_preproc_par($paragraph);
-
- if($self->{_current_head1} eq 'NAME') {
- my ($file, $line) = $pod_para->file_line;
- $self->poderror({ -line => $line, -file => $file,
- -severity => 'WARNING',
- -msg => 'Verbatim paragraph in NAME section' });
- }
-}
-
-# process a block of regular text
-sub textblock {
- my ($self, $paragraph, $line_num, $pod_para) = @_;
- my ($file, $line) = $pod_para->file_line;
-
- $self->_preproc_par($paragraph);
-
- # skip this paragraph if in a =begin block
- unless($self->{_have_begin}) {
- my $block = $self->interpolate_and_check($paragraph, $line,$file);
- if($self->{_current_head1} eq 'NAME') {
- if($block =~ /^\s*(\S+?)\s*[,-]/) {
- # this is the canonical name
- $self->{-name} = $1 unless(defined $self->{-name});
- }
- }
- }
-}
-
-sub _preproc_par
-{
- my $self = shift;
- $_[0] =~ s/[\s\n]+$//;
- if($_[0]) {
- $self->{_commands_in_head}++;
- $self->{_list_item_contents}++ if(defined $self->{_list_item_contents});
- if(@{$self->{_list_stack}} && !$self->{_list_stack}->[0]->item()) {
- $self->{_list_stack}->[0]->{_has_par} = 1;
- }
- }
-}
-
-1;
-
-__END__
-
-=head1 AUTHOR
-
-Please report bugs using L<http://rt.cpan.org>.
-
-Brad Appleton E<lt>bradapp at enteract.comE<gt> (initial version),
-Marek Rouchal E<lt>marekr at cpan.orgE<gt>
-
-Based on code for B<Pod::Text::pod2text()> written by
-Tom Christiansen E<lt>tchrist at mox.perl.comE<gt>
-
-=cut
-
Deleted: trunk/contrib/perl/lib/Pod/Escapes.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Escapes.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Escapes.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,721 +0,0 @@
-
-require 5;
-# The documentation is at the end.
-# Time-stamp: "2004-05-07 15:31:25 ADT"
-package Pod::Escapes;
-require Exporter;
- at ISA = ('Exporter');
-$VERSION = '1.04';
- at EXPORT_OK = qw(
- %Code2USASCII
- %Name2character
- %Name2character_number
- %Latin1Code_to_fallback
- %Latin1Char_to_fallback
- e2char
- e2charnum
-);
-%EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
-
-#==========================================================================
-
-use strict;
-use vars qw(
- %Code2USASCII
- %Name2character
- %Name2character_number
- %Latin1Code_to_fallback
- %Latin1Char_to_fallback
- $FAR_CHAR
- $FAR_CHAR_NUMBER
- $NOT_ASCII
-);
-
-$FAR_CHAR = "?" unless defined $FAR_CHAR;
-$FAR_CHAR_NUMBER = ord($FAR_CHAR) unless defined $FAR_CHAR_NUMBER;
-
-$NOT_ASCII = 'A' ne chr(65) unless defined $NOT_ASCII;
-
-#--------------------------------------------------------------------------
-sub e2char {
- my $in = $_[0];
- return undef unless defined $in and length $in;
-
- # Convert to decimal:
- if($in =~ m/^(0[0-7]*)$/s ) {
- $in = oct $in;
- } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
- $in = hex $1;
- } # else it's decimal, or named
-
- if($NOT_ASCII) {
- # We're in bizarro world of not-ASCII!
- # Cope with US-ASCII codes, use fallbacks for Latin-1, or use FAR_CHAR.
- unless($in =~ m/^\d+$/s) {
- # It's a named character reference. Get its numeric Unicode value.
- $in = $Name2character{$in};
- return undef unless defined $in; # (if there's no such name)
- $in = ord $in; # (All ents must be one character long.)
- # ...So $in holds the char's US-ASCII numeric value, which we'll
- # now go get the local equivalent for.
- }
-
- # It's numeric, whether by origin or by mutation from a known name
- return $Code2USASCII{$in} # so "65" => "A" everywhere
- || $Latin1Code_to_fallback{$in} # Fallback.
- || $FAR_CHAR; # Fall further back
- }
-
- # Normal handling:
- if($in =~ m/^\d+$/s) {
- if($] < 5.007 and $in > 255) { # can't be trusted with Unicode
- return $FAR_CHAR;
- } else {
- return chr($in);
- }
- } else {
- return $Name2character{$in}; # returns undef if unknown
- }
-}
-
-#--------------------------------------------------------------------------
-sub e2charnum {
- my $in = $_[0];
- return undef unless defined $in and length $in;
-
- # Convert to decimal:
- if($in =~ m/^(0[0-7]*)$/s ) {
- $in = oct $in;
- } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
- $in = hex $1;
- } # else it's decimal, or named
-
- if($in =~ m/^\d+$/s) {
- return 0 + $in;
- } else {
- return $Name2character_number{$in}; # returns undef if unknown
- }
-}
-
-#--------------------------------------------------------------------------
-
-%Name2character_number = (
- # General XML/XHTML:
- 'lt' => 60,
- 'gt' => 62,
- 'quot' => 34,
- 'amp' => 38,
- 'apos' => 39,
-
- # POD-specific:
- 'sol' => 47,
- 'verbar' => 124,
-
- 'lchevron' => 171, # legacy for laquo
- 'rchevron' => 187, # legacy for raquo
-
- # Remember, grave looks like \ (as in virtu\)
- # acute looks like / (as in re/sume/)
- # circumflex looks like ^ (as in papier ma^che/)
- # umlaut/dieresis looks like " (as in nai"ve, Chloe")
-
- # From the XHTML 1 .ent files:
- 'nbsp' , 160,
- 'iexcl' , 161,
- 'cent' , 162,
- 'pound' , 163,
- 'curren' , 164,
- 'yen' , 165,
- 'brvbar' , 166,
- 'sect' , 167,
- 'uml' , 168,
- 'copy' , 169,
- 'ordf' , 170,
- 'laquo' , 171,
- 'not' , 172,
- 'shy' , 173,
- 'reg' , 174,
- 'macr' , 175,
- 'deg' , 176,
- 'plusmn' , 177,
- 'sup2' , 178,
- 'sup3' , 179,
- 'acute' , 180,
- 'micro' , 181,
- 'para' , 182,
- 'middot' , 183,
- 'cedil' , 184,
- 'sup1' , 185,
- 'ordm' , 186,
- 'raquo' , 187,
- 'frac14' , 188,
- 'frac12' , 189,
- 'frac34' , 190,
- 'iquest' , 191,
- 'Agrave' , 192,
- 'Aacute' , 193,
- 'Acirc' , 194,
- 'Atilde' , 195,
- 'Auml' , 196,
- 'Aring' , 197,
- 'AElig' , 198,
- 'Ccedil' , 199,
- 'Egrave' , 200,
- 'Eacute' , 201,
- 'Ecirc' , 202,
- 'Euml' , 203,
- 'Igrave' , 204,
- 'Iacute' , 205,
- 'Icirc' , 206,
- 'Iuml' , 207,
- 'ETH' , 208,
- 'Ntilde' , 209,
- 'Ograve' , 210,
- 'Oacute' , 211,
- 'Ocirc' , 212,
- 'Otilde' , 213,
- 'Ouml' , 214,
- 'times' , 215,
- 'Oslash' , 216,
- 'Ugrave' , 217,
- 'Uacute' , 218,
- 'Ucirc' , 219,
- 'Uuml' , 220,
- 'Yacute' , 221,
- 'THORN' , 222,
- 'szlig' , 223,
- 'agrave' , 224,
- 'aacute' , 225,
- 'acirc' , 226,
- 'atilde' , 227,
- 'auml' , 228,
- 'aring' , 229,
- 'aelig' , 230,
- 'ccedil' , 231,
- 'egrave' , 232,
- 'eacute' , 233,
- 'ecirc' , 234,
- 'euml' , 235,
- 'igrave' , 236,
- 'iacute' , 237,
- 'icirc' , 238,
- 'iuml' , 239,
- 'eth' , 240,
- 'ntilde' , 241,
- 'ograve' , 242,
- 'oacute' , 243,
- 'ocirc' , 244,
- 'otilde' , 245,
- 'ouml' , 246,
- 'divide' , 247,
- 'oslash' , 248,
- 'ugrave' , 249,
- 'uacute' , 250,
- 'ucirc' , 251,
- 'uuml' , 252,
- 'yacute' , 253,
- 'thorn' , 254,
- 'yuml' , 255,
-
- 'fnof' , 402,
- 'Alpha' , 913,
- 'Beta' , 914,
- 'Gamma' , 915,
- 'Delta' , 916,
- 'Epsilon' , 917,
- 'Zeta' , 918,
- 'Eta' , 919,
- 'Theta' , 920,
- 'Iota' , 921,
- 'Kappa' , 922,
- 'Lambda' , 923,
- 'Mu' , 924,
- 'Nu' , 925,
- 'Xi' , 926,
- 'Omicron' , 927,
- 'Pi' , 928,
- 'Rho' , 929,
- 'Sigma' , 931,
- 'Tau' , 932,
- 'Upsilon' , 933,
- 'Phi' , 934,
- 'Chi' , 935,
- 'Psi' , 936,
- 'Omega' , 937,
- 'alpha' , 945,
- 'beta' , 946,
- 'gamma' , 947,
- 'delta' , 948,
- 'epsilon' , 949,
- 'zeta' , 950,
- 'eta' , 951,
- 'theta' , 952,
- 'iota' , 953,
- 'kappa' , 954,
- 'lambda' , 955,
- 'mu' , 956,
- 'nu' , 957,
- 'xi' , 958,
- 'omicron' , 959,
- 'pi' , 960,
- 'rho' , 961,
- 'sigmaf' , 962,
- 'sigma' , 963,
- 'tau' , 964,
- 'upsilon' , 965,
- 'phi' , 966,
- 'chi' , 967,
- 'psi' , 968,
- 'omega' , 969,
- 'thetasym' , 977,
- 'upsih' , 978,
- 'piv' , 982,
- 'bull' , 8226,
- 'hellip' , 8230,
- 'prime' , 8242,
- 'Prime' , 8243,
- 'oline' , 8254,
- 'frasl' , 8260,
- 'weierp' , 8472,
- 'image' , 8465,
- 'real' , 8476,
- 'trade' , 8482,
- 'alefsym' , 8501,
- 'larr' , 8592,
- 'uarr' , 8593,
- 'rarr' , 8594,
- 'darr' , 8595,
- 'harr' , 8596,
- 'crarr' , 8629,
- 'lArr' , 8656,
- 'uArr' , 8657,
- 'rArr' , 8658,
- 'dArr' , 8659,
- 'hArr' , 8660,
- 'forall' , 8704,
- 'part' , 8706,
- 'exist' , 8707,
- 'empty' , 8709,
- 'nabla' , 8711,
- 'isin' , 8712,
- 'notin' , 8713,
- 'ni' , 8715,
- 'prod' , 8719,
- 'sum' , 8721,
- 'minus' , 8722,
- 'lowast' , 8727,
- 'radic' , 8730,
- 'prop' , 8733,
- 'infin' , 8734,
- 'ang' , 8736,
- 'and' , 8743,
- 'or' , 8744,
- 'cap' , 8745,
- 'cup' , 8746,
- 'int' , 8747,
- 'there4' , 8756,
- 'sim' , 8764,
- 'cong' , 8773,
- 'asymp' , 8776,
- 'ne' , 8800,
- 'equiv' , 8801,
- 'le' , 8804,
- 'ge' , 8805,
- 'sub' , 8834,
- 'sup' , 8835,
- 'nsub' , 8836,
- 'sube' , 8838,
- 'supe' , 8839,
- 'oplus' , 8853,
- 'otimes' , 8855,
- 'perp' , 8869,
- 'sdot' , 8901,
- 'lceil' , 8968,
- 'rceil' , 8969,
- 'lfloor' , 8970,
- 'rfloor' , 8971,
- 'lang' , 9001,
- 'rang' , 9002,
- 'loz' , 9674,
- 'spades' , 9824,
- 'clubs' , 9827,
- 'hearts' , 9829,
- 'diams' , 9830,
- 'OElig' , 338,
- 'oelig' , 339,
- 'Scaron' , 352,
- 'scaron' , 353,
- 'Yuml' , 376,
- 'circ' , 710,
- 'tilde' , 732,
- 'ensp' , 8194,
- 'emsp' , 8195,
- 'thinsp' , 8201,
- 'zwnj' , 8204,
- 'zwj' , 8205,
- 'lrm' , 8206,
- 'rlm' , 8207,
- 'ndash' , 8211,
- 'mdash' , 8212,
- 'lsquo' , 8216,
- 'rsquo' , 8217,
- 'sbquo' , 8218,
- 'ldquo' , 8220,
- 'rdquo' , 8221,
- 'bdquo' , 8222,
- 'dagger' , 8224,
- 'Dagger' , 8225,
- 'permil' , 8240,
- 'lsaquo' , 8249,
- 'rsaquo' , 8250,
- 'euro' , 8364,
-);
-
-
-# Fill out %Name2character...
-{
- %Name2character = ();
- my($name, $number);
- while( ($name, $number) = each %Name2character_number) {
- if($] < 5.007 and $number > 255) {
- $Name2character{$name} = $FAR_CHAR;
- # substitute for Unicode characters, for perls
- # that can't reliable handle them
- } else {
- $Name2character{$name} = chr $number;
- # normal case
- }
- }
- # So they resolve 'right' even in EBCDIC-land
- $Name2character{'lt' } = '<';
- $Name2character{'gt' } = '>';
- $Name2character{'quot'} = '"';
- $Name2character{'amp' } = '&';
- $Name2character{'apos'} = "'";
- $Name2character{'sol' } = '/';
- $Name2character{'verbar'} = '|';
-}
-
-#--------------------------------------------------------------------------
-
-%Code2USASCII = (
-# mostly generated by
-# perl -e "printf qq{ \x25 3s, '\x25s',\n}, $_, chr($_) foreach (32 .. 126)"
- 32, ' ',
- 33, '!',
- 34, '"',
- 35, '#',
- 36, '$',
- 37, '%',
- 38, '&',
- 39, "'", #!
- 40, '(',
- 41, ')',
- 42, '*',
- 43, '+',
- 44, ',',
- 45, '-',
- 46, '.',
- 47, '/',
- 48, '0',
- 49, '1',
- 50, '2',
- 51, '3',
- 52, '4',
- 53, '5',
- 54, '6',
- 55, '7',
- 56, '8',
- 57, '9',
- 58, ':',
- 59, ';',
- 60, '<',
- 61, '=',
- 62, '>',
- 63, '?',
- 64, '@',
- 65, 'A',
- 66, 'B',
- 67, 'C',
- 68, 'D',
- 69, 'E',
- 70, 'F',
- 71, 'G',
- 72, 'H',
- 73, 'I',
- 74, 'J',
- 75, 'K',
- 76, 'L',
- 77, 'M',
- 78, 'N',
- 79, 'O',
- 80, 'P',
- 81, 'Q',
- 82, 'R',
- 83, 'S',
- 84, 'T',
- 85, 'U',
- 86, 'V',
- 87, 'W',
- 88, 'X',
- 89, 'Y',
- 90, 'Z',
- 91, '[',
- 92, "\\", #!
- 93, ']',
- 94, '^',
- 95, '_',
- 96, '`',
- 97, 'a',
- 98, 'b',
- 99, 'c',
- 100, 'd',
- 101, 'e',
- 102, 'f',
- 103, 'g',
- 104, 'h',
- 105, 'i',
- 106, 'j',
- 107, 'k',
- 108, 'l',
- 109, 'm',
- 110, 'n',
- 111, 'o',
- 112, 'p',
- 113, 'q',
- 114, 'r',
- 115, 's',
- 116, 't',
- 117, 'u',
- 118, 'v',
- 119, 'w',
- 120, 'x',
- 121, 'y',
- 122, 'z',
- 123, '{',
- 124, '|',
- 125, '}',
- 126, '~',
-);
-
-#--------------------------------------------------------------------------
-
-%Latin1Code_to_fallback = ();
- at Latin1Code_to_fallback{0xA0 .. 0xFF} = (
-# Copied from Text/Unidecode/x00.pm:
-
-' ', qq{!}, qq{C/}, 'PS', qq{\$?}, qq{Y=}, qq{|}, 'SS', qq{"}, qq{(c)}, 'a', qq{<<}, qq{!}, "", qq{(r)}, qq{-},
-'deg', qq{+-}, '2', '3', qq{'}, 'u', 'P', qq{*}, qq{,}, '1', 'o', qq{>>}, qq{1/4}, qq{1/2}, qq{3/4}, qq{?},
-'A', 'A', 'A', 'A', 'A', 'A', 'AE', 'C', 'E', 'E', 'E', 'E', 'I', 'I', 'I', 'I',
-'D', 'N', 'O', 'O', 'O', 'O', 'O', 'x', 'O', 'U', 'U', 'U', 'U', 'U', 'Th', 'ss',
-'a', 'a', 'a', 'a', 'a', 'a', 'ae', 'c', 'e', 'e', 'e', 'e', 'i', 'i', 'i', 'i',
-'d', 'n', 'o', 'o', 'o', 'o', 'o', qq{/}, 'o', 'u', 'u', 'u', 'u', 'y', 'th', 'y',
-
-);
-
-{
- # Now stuff %Latin1Char_to_fallback:
- %Latin1Char_to_fallback = ();
- my($k,$v);
- while( ($k,$v) = each %Latin1Code_to_fallback) {
- $Latin1Char_to_fallback{chr $k} = $v;
- #print chr($k), ' => ', $v, "\n";
- }
-}
-
-#--------------------------------------------------------------------------
-1;
-__END__
-
-=head1 NAME
-
-Pod::Escapes -- for resolving Pod EE<lt>...E<gt> sequences
-
-=head1 SYNOPSIS
-
- use Pod::Escapes qw(e2char);
- ...la la la, parsing POD, la la la...
- $text = e2char($e_node->label);
- unless(defined $text) {
- print "Unknown E sequence \"", $e_node->label, "\"!";
- }
- ...else print/interpolate $text...
-
-=head1 DESCRIPTION
-
-This module provides things that are useful in decoding
-Pod EE<lt>...E<gt> sequences. Presumably, it should be used
-only by Pod parsers and/or formatters.
-
-By default, Pod::Escapes exports none of its symbols. But
-you can request any of them to be exported.
-Either request them individually, as with
-C<use Pod::Escapes qw(symbolname symbolname2...);>,
-or you can do C<use Pod::Escapes qw(:ALL);> to get all
-exportable symbols.
-
-=head1 GOODIES
-
-=over
-
-=item e2char($e_content)
-
-Given a name or number that could appear in a
-C<EE<lt>name_or_numE<gt>> sequence, this returns the string that
-it stands for. For example, C<e2char('sol')>, C<e2char('47')>,
-C<e2char('0x2F')>, and C<e2char('057')> all return "/",
-because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
-and C<EE<lt>057E<gt>>, all mean "/". If
-the name has no known value (as with a name of "qacute") or is
-syntactally invalid (as with a name of "1/4"), this returns undef.
-
-=item e2charnum($e_content)
-
-Given a name or number that could appear in a
-C<EE<lt>name_or_numE<gt>> sequence, this returns the number of
-the Unicode character that this stands for. For example,
-C<e2char('sol')>, C<e2char('47')>,
-C<e2char('0x2F')>, and C<e2char('057')> all return 47,
-because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
-and C<EE<lt>057E<gt>>, all mean "/", whose Unicode number is 47. If
-the name has no known value (as with a name of "qacute") or is
-syntactally invalid (as with a name of "1/4"), this returns undef.
-
-=item $Name2character{I<name>}
-
-Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
-to the string that each stands for. Note that this does not
-include numerics (like "64" or "x981c"). Under old Perl versions
-(before 5.7) you get a "?" in place of characters whose Unicode
-value is over 255.
-
-=item $Name2character_number{I<name>}
-
-Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
-to the Unicode value that each stands for. For example,
-C<$Name2character_number{'eacute'}> is 201, and
-C<$Name2character_number{'eacute'}> is 8364. You get the correct
-Unicode value, regardless of the version of Perl you're using --
-which differs from C<%Name2character>'s behavior under pre-5.7 Perls.
-
-Note that this hash does not
-include numerics (like "64" or "x981c").
-
-=item $Latin1Code_to_fallback{I<integer>}
-
-For numbers in the range 160 (0x00A0) to 255 (0x00FF), this maps
-from the character code for a Latin-1 character (like 233 for
-lowercase e-acute) to the US-ASCII character that best aproximates
-it (like "e"). You may find this useful if you are rendering
-POD in a format that you think deals well only with US-ASCII
-characters.
-
-=item $Latin1Char_to_fallback{I<character>}
-
-Just as above, but maps from characters (like "\xE9",
-lowercase e-acute) to characters (like "e").
-
-=item $Code2USASCII{I<integer>}
-
-This maps from US-ASCII codes (like 32) to the corresponding
-character (like space, for 32). Only characters 32 to 126 are
-defined. This is meant for use by C<e2char($x)> when it senses
-that it's running on a non-ASCII platform (where chr(32) doesn't
-get you a space -- but $Code2USASCII{32} will). It's
-documented here just in case you might find it useful.
-
-=back
-
-=head1 CAVEATS
-
-On Perl versions before 5.7, Unicode characters with a value
-over 255 (like lambda or emdash) can't be conveyed. This
-module does work under such early Perl versions, but in the
-place of each such character, you get a "?". Latin-1
-characters (characters 160-255) are unaffected.
-
-Under EBCDIC platforms, C<e2char($n)> may not always be the
-same as C<chr(e2charnum($n))>, and ditto for
-C<$Name2character{$name}> and
-C<chr($Name2character_number{$name})>.
-
-=head1 SEE ALSO
-
-L<perlpod|perlpod>
-
-L<perlpodspec|perlpodspec>
-
-L<Text::Unidecode|Text::Unidecode>
-
-=head1 COPYRIGHT AND DISCLAIMERS
-
-Copyright (c) 2001-2004 Sean M. Burke. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-This program is distributed in the hope that it will be useful, but
-without any warranty; without even the implied warranty of
-merchantability or fitness for a particular purpose.
-
-Portions of the data tables in this module are derived from the
-entity declarations in the W3C XHTML specification.
-
-Currently (October 2001), that's these three:
-
- http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent
- http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent
- http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent
-
-=head1 AUTHOR
-
-Sean M. Burke C<sburke at cpan.org>
-
-=cut
-
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-# What I used for reading the XHTML .ent files:
-
-use strict;
-my(@norms, @good, @bad);
-my $dir = 'c:/sgml/docbook/';
-my %escapes;
-foreach my $file (qw(
- xhtml-symbol.ent
- xhtml-lat1.ent
- xhtml-special.ent
-)) {
- open(IN, "<$dir$file") or die "can't read-open $dir$file: $!";
- print "Reading $file...\n";
- while(<IN>) {
- if(m/<!ENTITY\s+(\S+)\s+"&#([^;]+);">/) {
- my($name, $value) = ($1,$2);
- next if $name eq 'quot' or $name eq 'apos' or $name eq 'gt';
-
- $value = hex $1 if $value =~ m/^x([a-fA-F0-9]+)$/s;
- print "ILLEGAL VALUE $value" unless $value =~ m/^\d+$/s;
- if($value > 255) {
- push @good , sprintf " %-10s , chr(%s),\n", "'$name'", $value;
- push @bad , sprintf " %-10s , \$bad,\n", "'$name'", $value;
- } else {
- push @norms, sprintf " %-10s , chr(%s),\n", "'$name'", $value;
- }
- } elsif(m/<!ENT/) {
- print "# Skipping $_";
- }
-
- }
- close(IN);
-}
-
-print @norms;
-print "\n ( \$] .= 5.006001 ? (\n";
-print @good;
-print " ) : (\n";
-print @bad;
-print " )\n);\n";
-
-__END__
-#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-
Deleted: trunk/contrib/perl/lib/Pod/Find.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Find.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Find.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,535 +0,0 @@
-#############################################################################
-# Pod/Find.pm -- finds files containing POD documentation
-#
-# Author: Marek Rouchal <marekr at cpan.org>
-#
-# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code
-# from Nick Ing-Simmon's PodToHtml). All rights reserved.
-# This file is part of "PodParser". Pod::Find is free software;
-# you can redistribute it and/or modify it under the same terms
-# as Perl itself.
-#############################################################################
-
-package Pod::Find;
-use strict;
-
-use vars qw($VERSION);
-$VERSION = '1.35'; ## Current version of this package
-require 5.005; ## requires this Perl version or later
-use Carp;
-
-BEGIN {
- if ($] < 5.006) {
- require Symbol;
- import Symbol;
- }
-}
-
-#############################################################################
-
-=head1 NAME
-
-Pod::Find - find POD documents in directory trees
-
-=head1 SYNOPSIS
-
- use Pod::Find qw(pod_find simplify_name);
- my %pods = pod_find({ -verbose => 1, -inc => 1 });
- foreach(keys %pods) {
- print "found library POD `$pods{$_}' in $_\n";
- }
-
- print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n";
-
- $location = pod_where( { -inc => 1 }, "Pod::Find" );
-
-=head1 DESCRIPTION
-
-B<Pod::Find> provides a set of functions to locate POD files. Note that
-no function is exported by default to avoid pollution of your namespace,
-so be sure to specify them in the B<use> statement if you need them:
-
- use Pod::Find qw(pod_find);
-
-From this version on the typical SCM (software configuration management)
-files/directories like RCS, CVS, SCCS, .svn are ignored.
-
-=cut
-
-#use diagnostics;
-use Exporter;
-use File::Spec;
-use File::Find;
-use Cwd;
-
-use vars qw(@ISA @EXPORT_OK $VERSION);
- at ISA = qw(Exporter);
- at EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod);
-
-# package global variables
-my $SIMPLIFY_RX;
-
-=head2 C<pod_find( { %opts } , @directories )>
-
-The function B<pod_find> searches for POD documents in a given set of
-files and/or directories. It returns a hash with the file names as keys
-and the POD name as value. The POD name is derived from the file name
-and its position in the directory tree.
-
-E.g. when searching in F<$HOME/perl5lib>, the file
-F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
-whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
-I<Myclass::Subclass>. The name information can be used for POD
-translators.
-
-Only text files containing at least one valid POD command are found.
-
-A warning is printed if more than one POD file with the same POD name
-is found, e.g. F<CPAN.pm> in different directories. This usually
-indicates duplicate occurrences of modules in the I<@INC> search path.
-
-B<OPTIONS> The first argument for B<pod_find> may be a hash reference
-with options. The rest are either directories that are searched
-recursively or files. The POD names of files are the plain basenames
-with any Perl-like extension (.pm, .pl, .pod) stripped.
-
-=over 4
-
-=item C<-verbose =E<gt> 1>
-
-Print progress information while scanning.
-
-=item C<-perl =E<gt> 1>
-
-Apply Perl-specific heuristics to find the correct PODs. This includes
-stripping Perl-like extensions, omitting subdirectories that are numeric
-but do I<not> match the current Perl interpreter's version id, suppressing
-F<site_perl> as a module hierarchy name etc.
-
-=item C<-script =E<gt> 1>
-
-Search for PODs in the current Perl interpreter's installation
-B<scriptdir>. This is taken from the local L<Config|Config> module.
-
-=item C<-inc =E<gt> 1>
-
-Search for PODs in the current Perl interpreter's I<@INC> paths. This
-automatically considers paths specified in the C<PERL5LIB> environment
-as this is included in I<@INC> by the Perl interpreter itself.
-
-=back
-
-=cut
-
-# return a hash of the POD files found
-# first argument may be a hashref (options),
-# rest is a list of directories to search recursively
-sub pod_find
-{
- my %opts;
- if(ref $_[0]) {
- %opts = %{shift()};
- }
-
- $opts{-verbose} ||= 0;
- $opts{-perl} ||= 0;
-
- my (@search) = @_;
-
- if($opts{-script}) {
- require Config;
- push(@search, $Config::Config{scriptdir})
- if -d $Config::Config{scriptdir};
- $opts{-perl} = 1;
- }
-
- if($opts{-inc}) {
- if ($^O eq 'MacOS') {
- # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
- my @new_INC = @INC;
- for (@new_INC) {
- if ( $_ eq '.' ) {
- $_ = ':';
- } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
- $_ = ':'. $_;
- } else {
- $_ =~ s{^\./}{:};
- }
- }
- push(@search, grep($_ ne File::Spec->curdir, @new_INC));
- } else {
- push(@search, grep($_ ne File::Spec->curdir, @INC));
- }
-
- $opts{-perl} = 1;
- }
-
- if($opts{-perl}) {
- require Config;
- # this code simplifies the POD name for Perl modules:
- # * remove "site_perl"
- # * remove e.g. "i586-linux" (from 'archname')
- # * remove e.g. 5.00503
- # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod)
-
- # Mac OS:
- # * remove ":?site_perl:"
- # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod)
-
- if ($^O eq 'MacOS') {
- $SIMPLIFY_RX =
- qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!;
- } else {
- $SIMPLIFY_RX =
- qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!;
- }
- }
-
- my %dirs_visited;
- my %pods;
- my %names;
- my $pwd = cwd();
-
- foreach my $try (@search) {
- unless(File::Spec->file_name_is_absolute($try)) {
- # make path absolute
- $try = File::Spec->catfile($pwd,$try);
- }
- # simplify path
- # on VMS canonpath will vmsify:[the.path], but File::Find::find
- # wants /unixy/paths
- $try = File::Spec->canonpath($try) if ($^O ne 'VMS');
- $try = VMS::Filespec::unixify($try) if ($^O eq 'VMS');
- my $name;
- if(-f $try) {
- if($name = _check_and_extract_name($try, $opts{-verbose})) {
- _check_for_duplicates($try, $name, \%names, \%pods);
- }
- next;
- }
- my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!;
- File::Find::find( sub {
- my $item = $File::Find::name;
- if(-d) {
- if($item =~ m{/(?:RCS|CVS|SCCS|\.svn)$}) {
- $File::Find::prune = 1;
- return;
- }
- elsif($dirs_visited{$item}) {
- warn "Directory '$item' already seen, skipping.\n"
- if($opts{-verbose});
- $File::Find::prune = 1;
- return;
- }
- else {
- $dirs_visited{$item} = 1;
- }
- if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) {
- $File::Find::prune = 1;
- warn "Perl $] version mismatch on $_, skipping.\n"
- if($opts{-verbose});
- }
- return;
- }
- if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) {
- _check_for_duplicates($item, $name, \%names, \%pods);
- }
- }, $try); # end of File::Find::find
- }
- chdir $pwd;
- return %pods;
-}
-
-sub _check_for_duplicates {
- my ($file, $name, $names_ref, $pods_ref) = @_;
- if($$names_ref{$name}) {
- warn "Duplicate POD found (shadowing?): $name ($file)\n";
- warn ' Already seen in ',
- join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n";
- }
- else {
- $$names_ref{$name} = 1;
- }
- return $$pods_ref{$file} = $name;
-}
-
-sub _check_and_extract_name {
- my ($file, $verbose, $root_rx) = @_;
-
- # check extension or executable flag
- # this involves testing the .bat extension on Win32!
- unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) {
- return;
- }
-
- return unless contains_pod($file,$verbose);
-
- # strip non-significant path components
- # TODO what happens on e.g. Win32?
- my $name = $file;
- if(defined $root_rx) {
- $name =~ s/$root_rx//s;
- $name =~ s/$SIMPLIFY_RX//s if(defined $SIMPLIFY_RX);
- }
- else {
- if ($^O eq 'MacOS') {
- $name =~ s/^.*://s;
- } else {
- $name =~ s{^.*/}{}s;
- }
- }
- _simplify($name);
- $name =~ s{/+}{::}g;
- if ($^O eq 'MacOS') {
- $name =~ s{:+}{::}g; # : -> ::
- } else {
- $name =~ s{/+}{::}g; # / -> ::
- }
- return $name;
-}
-
-=head2 C<simplify_name( $str )>
-
-The function B<simplify_name> is equivalent to B<basename>, but also
-strips Perl-like extensions (.pm, .pl, .pod) and extensions like
-F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
-
-=cut
-
-# basic simplification of the POD name:
-# basename & strip extension
-sub simplify_name {
- my ($str) = @_;
- # remove all path components
- if ($^O eq 'MacOS') {
- $str =~ s/^.*://s;
- } else {
- $str =~ s{^.*/}{}s;
- }
- _simplify($str);
- return $str;
-}
-
-# internal sub only
-sub _simplify {
- # strip Perl's own extensions
- $_[0] =~ s/\.(pod|pm|plx?)\z//i;
- # strip meaningless extensions on Win32 and OS/2
- $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i);
- # strip meaningless extensions on VMS
- $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS');
-}
-
-# contribution from Tim Jenness <t.jenness at jach.hawaii.edu>
-
-=head2 C<pod_where( { %opts }, $pod )>
-
-Returns the location of a pod document given a search directory
-and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name.
-
-Options:
-
-=over 4
-
-=item C<-inc =E<gt> 1>
-
-Search @INC for the pod and also the C<scriptdir> defined in the
-L<Config|Config> module.
-
-=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]>
-
-Reference to an array of search directories. These are searched in order
-before looking in C<@INC> (if B<-inc>). Current directory is used if
-none are specified.
-
-=item C<-verbose =E<gt> 1>
-
-List directories as they are searched
-
-=back
-
-Returns the full path of the first occurrence to the file.
-Package names (eg 'A::B') are automatically converted to directory
-names in the selected directory. (eg on unix 'A::B' is converted to
-'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the
-search automatically if required.
-
-A subdirectory F<pod/> is also checked if it exists in any of the given
-search directories. This ensures that e.g. L<perlfunc|perlfunc> is
-found.
-
-It is assumed that if a module name is supplied, that that name
-matches the file name. Pods are not opened to check for the 'NAME'
-entry.
-
-A check is made to make sure that the file that is found does
-contain some pod documentation.
-
-=cut
-
-sub pod_where {
-
- # default options
- my %options = (
- '-inc' => 0,
- '-verbose' => 0,
- '-dirs' => [ File::Spec->curdir ],
- );
-
- # Check for an options hash as first argument
- if (defined $_[0] && ref($_[0]) eq 'HASH') {
- my $opt = shift;
-
- # Merge default options with supplied options
- %options = (%options, %$opt);
- }
-
- # Check usage
- carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_));
-
- # Read argument
- my $pod = shift;
-
- # Split on :: and then join the name together using File::Spec
- my @parts = split (/::/, $pod);
-
- # Get full directory list
- my @search_dirs = @{ $options{'-dirs'} };
-
- if ($options{'-inc'}) {
-
- require Config;
-
- # Add @INC
- if ($^O eq 'MacOS' && $options{'-inc'}) {
- # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
- my @new_INC = @INC;
- for (@new_INC) {
- if ( $_ eq '.' ) {
- $_ = ':';
- } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) {
- $_ = ':'. $_;
- } else {
- $_ =~ s{^\./}{:};
- }
- }
- push (@search_dirs, @new_INC);
- } elsif ($options{'-inc'}) {
- push (@search_dirs, @INC);
- }
-
- # Add location of pod documentation for perl man pages (eg perlfunc)
- # This is a pod directory in the private install tree
- #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
- # 'pod');
- #push (@search_dirs, $perlpoddir)
- # if -d $perlpoddir;
-
- # Add location of binaries such as pod2text
- push (@search_dirs, $Config::Config{'scriptdir'})
- if -d $Config::Config{'scriptdir'};
- }
-
- warn 'Search path is: '.join(' ', @search_dirs)."\n"
- if $options{'-verbose'};
-
- # Loop over directories
- Dir: foreach my $dir ( @search_dirs ) {
-
- # Don't bother if can't find the directory
- if (-d $dir) {
- warn "Looking in directory $dir\n"
- if $options{'-verbose'};
-
- # Now concatenate this directory with the pod we are searching for
- my $fullname = File::Spec->catfile($dir, @parts);
- warn "Filename is now $fullname\n"
- if $options{'-verbose'};
-
- # Loop over possible extensions
- foreach my $ext ('', '.pod', '.pm', '.pl') {
- my $fullext = $fullname . $ext;
- if (-f $fullext &&
- contains_pod($fullext, $options{'-verbose'}) ) {
- warn "FOUND: $fullext\n" if $options{'-verbose'};
- return $fullext;
- }
- }
- } else {
- warn "Directory $dir does not exist\n"
- if $options{'-verbose'};
- next Dir;
- }
- # for some strange reason the path on MacOS/darwin/cygwin is
- # 'pods' not 'pod'
- # this could be the case also for other systems that
- # have a case-tolerant file system, but File::Spec
- # does not recognize 'darwin' yet. And cygwin also has "pods",
- # but is not case tolerant. Oh well...
- if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i)
- && -d File::Spec->catdir($dir,'pods')) {
- $dir = File::Spec->catdir($dir,'pods');
- redo Dir;
- }
- if(-d File::Spec->catdir($dir,'pod')) {
- $dir = File::Spec->catdir($dir,'pod');
- redo Dir;
- }
- }
- # No match;
- return;
-}
-
-=head2 C<contains_pod( $file , $verbose )>
-
-Returns true if the supplied filename (not POD module) contains some pod
-information.
-
-=cut
-
-sub contains_pod {
- my $file = shift;
- my $verbose = 0;
- $verbose = shift if @_;
-
- # check for one line of POD
- my $podfh;
- if ($] < 5.006) {
- $podfh = gensym();
- }
-
- unless(open($podfh,"<$file")) {
- warn "Error: $file is unreadable: $!\n";
- return;
- }
-
- local $/ = undef;
- my $pod = <$podfh>;
- close($podfh) || die "Error closing $file: $!\n";
- unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) {
- warn "No POD in $file, skipping.\n"
- if($verbose);
- return 0;
- }
-
- return 1;
-}
-
-=head1 AUTHOR
-
-Please report bugs using L<http://rt.cpan.org>.
-
-Marek Rouchal E<lt>marekr at cpan.orgE<gt>,
-heavily borrowing code from Nick Ing-Simmons' PodToHtml.
-
-Tim Jenness E<lt>t.jenness at jach.hawaii.eduE<gt> provided
-C<pod_where> and C<contains_pod>.
-
-=head1 SEE ALSO
-
-L<Pod::Parser>, L<Pod::Checker>, L<perldoc>
-
-=cut
-
-1;
-
Deleted: trunk/contrib/perl/lib/Pod/Functions.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Functions.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Functions.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,376 +0,0 @@
-package Pod::Functions;
-use strict;
-
-=head1 NAME
-
-Pod::Functions - Group Perl's functions a la perlfunc.pod
-
-=head1 SYNOPSIS
-
- use Pod::Functions;
-
- my @misc_ops = @{ $Kinds{ 'Misc' } };
- my $misc_dsc = $Type_Description{ 'Misc' };
-
-or
-
- perl /path/to/lib/Pod/Functions.pm
-
-This will print a grouped list of Perl's functions, like the
-L<perlfunc/"Perl Functions by Category"> section.
-
-=head1 DESCRIPTION
-
-It exports the following variables:
-
-=over 4
-
-=item %Kinds
-
-This holds a hash-of-lists. Each list contains the functions in the category
-the key denotes.
-
-=item %Type
-
-In this hash each key represents a function and the value is the category.
-The category can be a comma separated list.
-
-=item %Flavor
-
-In this hash each key represents a function and the value is a short
-description of that function.
-
-=item %Type_Description
-
-In this hash each key represents a category of functions and the value is
-a short description of that category.
-
-=item @Type_Order
-
-This list of categories is used to produce the same order as the
-L<perlfunc/"Perl Functions by Category"> section.
-
-=back
-
-=head1 CHANGES
-
-1.02 20020813 <abe at ztreet.demon.nl>
- de-typo in the SYNOPSIS section (thanks Mike Castle for noticing)
-
-1.01 20011229 <abe at ztreet.demon.nl>
- fixed some bugs that slipped in after 5.6.1
- added the pod
- finished making it strict safe
-
-1.00 ??
- first numbered version
-
-=cut
-
-our $VERSION = '1.04';
-
-require Exporter;
-
-our @ISA = qw(Exporter);
-our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
-
-our(%Kinds, %Type, %Flavor);
-
-our %Type_Description = (
- 'ARRAY' => 'Functions for real @ARRAYs',
- 'Binary' => 'Functions for fixed length data or records',
- 'File' => 'Functions for filehandles, files, or directories',
- 'Flow' => 'Keywords related to control flow of your perl program',
- 'HASH' => 'Functions for real %HASHes',
- 'I/O' => 'Input and output functions',
- 'LIST' => 'Functions for list data',
- 'Math' => 'Numeric functions',
- 'Misc' => 'Miscellaneous functions',
- 'Modules' => 'Keywords related to perl modules',
- 'Network' => 'Fetching network info',
- 'Objects' => 'Keywords related to classes and object-orientedness',
- 'Process' => 'Functions for processes and process groups',
- 'Regexp' => 'Regular expressions and pattern matching',
- 'Socket' => 'Low-level socket functions',
- 'String' => 'Functions for SCALARs or strings',
- 'SysV' => 'System V interprocess communication functions',
- 'Time' => 'Time-related functions',
- 'User' => 'Fetching user and group info',
- 'Namespace' => 'Keywords altering or affecting scoping of identifiers',
-);
-
-our @Type_Order = qw{
- String
- Regexp
- Math
- ARRAY
- LIST
- HASH
- I/O
- Binary
- File
- Flow
- Namespace
- Misc
- Process
- Modules
- Objects
- Socket
- SysV
- User
- Network
- Time
-};
-
-while (<DATA>) {
- chomp;
- s/#.*//;
- next unless $_;
- my($name, $type, $text) = split " ", $_, 3;
- $Type{$name} = $type;
- $Flavor{$name} = $text;
- for my $t ( split /[,\s]+/, $type ) {
- push @{$Kinds{$t}}, $name;
- }
-}
-
-close DATA;
-
-my( $typedesc, $list );
-unless (caller) {
- foreach my $type ( @Type_Order ) {
- $list = join(", ", sort @{$Kinds{$type}});
- $typedesc = $Type_Description{$type} . ":";
- write;
- }
-}
-
-format =
-
-^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- $typedesc
-~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- $typedesc
- ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
- $list
-.
-
-1;
-
-__DATA__
--X File a file test (-r, -x, etc)
-abs Math absolute value function
-accept Socket accept an incoming socket connect
-alarm Process schedule a SIGALRM
-atan2 Math arctangent of Y/X in the range -PI to PI
-bind Socket binds an address to a socket
-binmode I/O prepare binary files for I/O
-bless Objects create an object
-caller Flow,Namespace get context of the current subroutine call
-chdir File change your current working directory
-chmod File changes the permissions on a list of files
-chomp String remove a trailing record separator from a string
-chop String remove the last character from a string
-chown File change the ownership on a list of files
-chr String get character this number represents
-chroot File make directory new root for path lookups
-close I/O close file (or pipe or socket) handle
-closedir I/O close directory handle
-connect Socket connect to a remote socket
-continue Flow optional trailing block in a while or foreach
-cos Math cosine function
-crypt String one-way passwd-style encryption
-dbmclose Objects,I/O breaks binding on a tied dbm file
-dbmopen Objects,I/O create binding on a tied dbm file
-defined Misc test whether a value, variable, or function is defined
-delete HASH deletes a value from a hash
-die I/O,Flow raise an exception or bail out
-do Flow,Modules turn a BLOCK into a TERM
-dump Misc,Flow create an immediate core dump
-each HASH retrieve the next key/value pair from a hash
-endgrent User be done using group file
-endhostent User be done using hosts file
-endnetent User be done using networks file
-endprotoent Network be done using protocols file
-endpwent User be done using passwd file
-endservent Network be done using services file
-eof I/O test a filehandle for its end
-eval Flow,Misc catch exceptions or compile and run code
-exec Process abandon this program to run another
-exists HASH test whether a hash key is present
-exit Flow terminate this program
-exp Math raise I<e> to a power
-fcntl File file control system call
-fileno I/O return file descriptor from filehandle
-flock I/O lock an entire file with an advisory lock
-fork Process create a new process just like this one
-format I/O declare a picture format with use by the write() function
-formline Misc internal function used for formats
-getc I/O get the next character from the filehandle
-getgrent User get next group record
-getgrgid User get group record given group user ID
-getgrnam User get group record given group name
-gethostbyaddr Network get host record given its address
-gethostbyname Network get host record given name
-gethostent Network get next hosts record
-getlogin User return who logged in at this tty
-getnetbyaddr Network get network record given its address
-getnetbyname Network get networks record given name
-getnetent Network get next networks record
-getpeername Socket find the other end of a socket connection
-getpgrp Process get process group
-getppid Process get parent process ID
-getpriority Process get current nice value
-getprotobyname Network get protocol record given name
-getprotobynumber Network get protocol record numeric protocol
-getprotoent Network get next protocols record
-getpwent User get next passwd record
-getpwnam User get passwd record given user login name
-getpwuid User get passwd record given user ID
-getservbyname Network get services record given its name
-getservbyport Network get services record given numeric port
-getservent Network get next services record
-getsockname Socket retrieve the sockaddr for a given socket
-getsockopt Socket get socket options on a given socket
-glob File expand filenames using wildcards
-gmtime Time convert UNIX time into record or string using Greenwich time
-goto Flow create spaghetti code
-grep LIST locate elements in a list test true against a given criterion
-hex Math,String convert a string to a hexadecimal number
-import Modules,Namespace patch a module's namespace into your own
-index String find a substring within a string
-int Math get the integer portion of a number
-ioctl File system-dependent device control system call
-join LIST join a list into a string using a separator
-keys HASH retrieve list of indices from a hash
-kill Process send a signal to a process or process group
-last Flow exit a block prematurely
-lc String return lower-case version of a string
-lcfirst String return a string with just the next letter in lower case
-length String return the number of bytes in a string
-link File create a hard link in the filesystem
-listen Socket register your socket as a server
-local Misc,Namespace create a temporary value for a global variable (dynamic scoping)
-localtime Time convert UNIX time into record or string using local time
-lock Threads get a thread lock on a variable, subroutine, or method
-log Math retrieve the natural logarithm for a number
-lstat File stat a symbolic link
-m// Regexp match a string with a regular expression pattern
-map LIST apply a change to a list to get back a new list with the changes
-mkdir File create a directory
-msgctl SysV SysV IPC message control operations
-msgget SysV get SysV IPC message queue
-msgrcv SysV receive a SysV IPC message from a message queue
-msgsnd SysV send a SysV IPC message to a message queue
-my Misc,Namespace declare and assign a local variable (lexical scoping)
-next Flow iterate a block prematurely
-no Modules unimport some module symbols or semantics at compile time
-package Modules,Objects,Namespace declare a separate global namespace
-prototype Flow,Misc get the prototype (if any) of a subroutine
-oct String,Math convert a string to an octal number
-open File open a file, pipe, or descriptor
-opendir File open a directory
-ord String find a character's numeric representation
-our Misc,Namespace declare and assign a package variable (lexical scoping)
-pack Binary,String convert a list into a binary representation
-pipe Process open a pair of connected filehandles
-pop ARRAY remove the last element from an array and return it
-pos Regexp find or set the offset for the last/next m//g search
-print I/O output a list to a filehandle
-printf I/O output a formatted list to a filehandle
-push ARRAY append one or more elements to an array
-q/STRING/ String singly quote a string
-qq/STRING/ String doubly quote a string
-quotemeta Regexp quote regular expression magic characters
-qw/STRING/ LIST quote a list of words
-qx/STRING/ Process backquote quote a string
-qr/STRING/ Regexp Compile pattern
-rand Math retrieve the next pseudorandom number
-read I/O,Binary fixed-length buffered input from a filehandle
-readdir I/O get a directory from a directory handle
-readline I/O fetch a record from a file
-readlink File determine where a symbolic link is pointing
-readpipe Process execute a system command and collect standard output
-recv Socket receive a message over a Socket
-redo Flow start this loop iteration over again
-ref Objects find out the type of thing being referenced
-rename File change a filename
-require Modules load in external functions from a library at runtime
-reset Misc clear all variables of a given name
-return Flow get out of a function early
-reverse String,LIST flip a string or a list
-rewinddir I/O reset directory handle
-rindex String right-to-left substring search
-rmdir File remove a directory
-s/// Regexp replace a pattern with a string
-scalar Misc force a scalar context
-seek I/O reposition file pointer for random-access I/O
-seekdir I/O reposition directory pointer
-select I/O reset default output or do I/O multiplexing
-semctl SysV SysV semaphore control operations
-semget SysV get set of SysV semaphores
-semop SysV SysV semaphore operations
-send Socket send a message over a socket
-setgrent User prepare group file for use
-sethostent Network prepare hosts file for use
-setnetent Network prepare networks file for use
-setpgrp Process set the process group of a process
-setpriority Process set a process's nice value
-setprotoent Network prepare protocols file for use
-setpwent User prepare passwd file for use
-setservent Network prepare services file for use
-setsockopt Socket set some socket options
-shift ARRAY remove the first element of an array, and return it
-shmctl SysV SysV shared memory operations
-shmget SysV get SysV shared memory segment identifier
-shmread SysV read SysV shared memory
-shmwrite SysV write SysV shared memory
-shutdown Socket close down just half of a socket connection
-sin Math return the sine of a number
-sleep Process block for some number of seconds
-socket Socket create a socket
-socketpair Socket create a pair of sockets
-sort LIST sort a list of values
-splice ARRAY add or remove elements anywhere in an array
-split Regexp split up a string using a regexp delimiter
-sprintf String formatted print into a string
-sqrt Math square root function
-srand Math seed the random number generator
-stat File get a file's status information
-study Regexp optimize input data for repeated searches
-sub Flow declare a subroutine, possibly anonymously
-substr String get or alter a portion of a string
-symlink File create a symbolic link to a file
-syscall I/O,Binary execute an arbitrary system call
-sysopen File open a file, pipe, or descriptor
-sysread I/O,Binary fixed-length unbuffered input from a filehandle
-sysseek I/O,Binary position I/O pointer on handle used with sysread and syswrite
-system Process run a separate program
-syswrite I/O,Binary fixed-length unbuffered output to a filehandle
-tell I/O get current seekpointer on a filehandle
-telldir I/O get current seekpointer on a directory handle
-tie Objects bind a variable to an object class
-tied Objects get a reference to the object underlying a tied variable
-time Time return number of seconds since 1970
-times Process,Time return elapsed time for self and child processes
-tr/// String transliterate a string
-truncate I/O shorten a file
-uc String return upper-case version of a string
-ucfirst String return a string with just the next letter in upper case
-umask File set file creation mode mask
-undef Misc remove a variable or function definition
-unlink File remove one link to a file
-unpack Binary,LIST convert binary structure into normal perl variables
-unshift ARRAY prepend more elements to the beginning of a list
-untie Objects break a tie binding to a variable
-use Modules,Namespace load a module and import its namespace
-use Objects load in a module at compile time
-utime File set a file's last access and modify times
-values HASH return a list of the values in a hash
-vec Binary test or set particular bits in a string
-wait Process wait for any child process to die
-waitpid Process wait for a particular child process to die
-wantarray Misc,Flow get void vs scalar vs list context of current subroutine call
-warn I/O print debugging info
-write I/O print a picture record
-y/// String transliterate a string
Deleted: trunk/contrib/perl/lib/Pod/Html.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Html.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Html.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,2233 +0,0 @@
-package Pod::Html;
-use strict;
-require Exporter;
-
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = 1.09;
- at ISA = qw(Exporter);
- at EXPORT = qw(pod2html htmlify);
- at EXPORT_OK = qw(anchorify);
-
-use Carp;
-use Config;
-use Cwd;
-use File::Spec;
-use File::Spec::Unix;
-use Getopt::Long;
-
-use locale; # make \w work right in non-ASCII lands
-
-=head1 NAME
-
-Pod::Html - module to convert pod files to HTML
-
-=head1 SYNOPSIS
-
- use Pod::Html;
- pod2html([options]);
-
-=head1 DESCRIPTION
-
-Converts files from pod format (see L<perlpod>) to HTML format. It
-can automatically generate indexes and cross-references, and it keeps
-a cache of things it knows how to cross-reference.
-
-=head1 FUNCTIONS
-
-=head2 pod2html
-
- pod2html("pod2html",
- "--podpath=lib:ext:pod:vms",
- "--podroot=/usr/src/perl",
- "--htmlroot=/perl/nmanual",
- "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
- "--recurse",
- "--infile=foo.pod",
- "--outfile=/perl/nmanual/foo.html");
-
-pod2html takes the following arguments:
-
-=over 4
-
-=item backlink
-
- --backlink="Back to Top"
-
-Adds "Back to Top" links in front of every C<head1> heading (except for
-the first). By default, no backlinks are generated.
-
-=item cachedir
-
- --cachedir=name
-
-Creates the item and directory caches in the given directory.
-
-=item css
-
- --css=stylesheet
-
-Specify the URL of a cascading style sheet. Also disables all HTML/CSS
-C<style> attributes that are output by default (to avoid conflicts).
-
-=item flush
-
- --flush
-
-Flushes the item and directory caches.
-
-=item header
-
- --header
- --noheader
-
-Creates header and footer blocks containing the text of the C<NAME>
-section. By default, no headers are generated.
-
-=item help
-
- --help
-
-Displays the usage message.
-
-=item hiddendirs
-
- --hiddendirs
- --nohiddendirs
-
-Include hidden directories in the search for POD's in podpath if recurse
-is set.
-The default is not to traverse any directory whose name begins with C<.>.
-See L</"podpath"> and L</"recurse">.
-
-[This option is for backward compatibility only.
-It's hard to imagine that one would usefully create a module with a
-name component beginning with C<.>.]
-
-=item htmldir
-
- --htmldir=name
-
-Sets the directory in which the resulting HTML file is placed. This
-is used to generate relative links to other files. Not passing this
-causes all links to be absolute, since this is the value that tells
-Pod::Html the root of the documentation tree.
-
-=item htmlroot
-
- --htmlroot=name
-
-Sets the base URL for the HTML files. When cross-references are made,
-the HTML root is prepended to the URL.
-
-=item index
-
- --index
- --noindex
-
-Generate an index at the top of the HTML file. This is the default
-behaviour.
-
-=item infile
-
- --infile=name
-
-Specify the pod file to convert. Input is taken from STDIN if no
-infile is specified.
-
-=item libpods
-
- --libpods=name:...:name
-
-List of page names (eg, "perlfunc") which contain linkable C<=item>s.
-
-=item netscape
-
- --netscape
- --nonetscape
-
-B<Deprecated>, has no effect. For backwards compatibility only.
-
-=item outfile
-
- --outfile=name
-
-Specify the HTML file to create. Output goes to STDOUT if no outfile
-is specified.
-
-=item podpath
-
- --podpath=name:...:name
-
-Specify which subdirectories of the podroot contain pod files whose
-HTML converted forms can be linked to in cross references.
-
-=item podroot
-
- --podroot=name
-
-Specify the base directory for finding library pods.
-
-=item quiet
-
- --quiet
- --noquiet
-
-Don't display I<mostly harmless> warning messages. These messages
-will be displayed by default. But this is not the same as C<verbose>
-mode.
-
-=item recurse
-
- --recurse
- --norecurse
-
-Recurse into subdirectories specified in podpath (default behaviour).
-
-=item title
-
- --title=title
-
-Specify the title of the resulting HTML file.
-
-=item verbose
-
- --verbose
- --noverbose
-
-Display progress messages. By default, they won't be displayed.
-
-=back
-
-=head2 htmlify
-
- htmlify($heading);
-
-Converts a pod section specification to a suitable section specification
-for HTML. Note that we keep spaces and special characters except
-C<", ?> (Netscape problem) and the hyphen (writer's problem...).
-
-=head2 anchorify
-
- anchorify(@heading);
-
-Similar to C<htmlify()>, but turns non-alphanumerics into underscores. Note
-that C<anchorify()> is not exported by default.
-
-=head1 ENVIRONMENT
-
-Uses C<$Config{pod2html}> to setup default options.
-
-=head1 AUTHOR
-
-Tom Christiansen, E<lt>tchrist at perl.comE<gt>.
-
-=head1 SEE ALSO
-
-L<perlpod>
-
-=head1 COPYRIGHT
-
-This program is distributed under the Artistic License.
-
-=cut
-
-my($Cachedir);
-my($Dircache, $Itemcache);
-my @Begin_Stack;
-my @Libpods;
-my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl);
-my($Podfile, @Podpath, $Podroot);
-my $Css;
-
-my $Recurse;
-my $Quiet;
-my $HiddenDirs;
-my $Verbose;
-my $Doindex;
-
-my $Backlink;
-my($Listlevel, @Listtype);
-my $ListNewTerm;
-use vars qw($Ignore); # need to localize it later.
-
-my(%Items_Named, @Items_Seen);
-my($Title, $Header);
-
-my $Top;
-my $Paragraph;
-
-my %Sections;
-
-# Caches
-my %Pages = (); # associative array used to find the location
- # of pages referenced by L<> links.
-my %Items = (); # associative array used to find the location
- # of =item directives referenced by C<> links
-
-my %Local_Items;
-my $Is83;
-
-my $Curdir = File::Spec->curdir;
-
-init_globals();
-
-sub init_globals {
- $Cachedir = "."; # The directory to which item and directory
- # caches will be written.
-
- $Dircache = "pod2htmd.tmp";
- $Itemcache = "pod2htmi.tmp";
-
- @Begin_Stack = (); # begin/end stack
-
- @Libpods = (); # files to search for links from C<> directives
- $Htmlroot = "/"; # http-server base directory from which all
- # relative paths in $podpath stem.
- $Htmldir = ""; # The directory to which the html pages
- # will (eventually) be written.
- $Htmlfile = ""; # write to stdout by default
- $Htmlfileurl = ""; # The url that other files would use to
- # refer to this file. This is only used
- # to make relative urls that point to
- # other files.
-
- $Podfile = ""; # read from stdin by default
- @Podpath = (); # list of directories containing library pods.
- $Podroot = $Curdir; # filesystem base directory from which all
- # relative paths in $podpath stem.
- $Css = ''; # Cascading style sheet
- $Recurse = 1; # recurse on subdirectories in $podpath.
- $Quiet = 0; # not quiet by default
- $Verbose = 0; # not verbose by default
- $Doindex = 1; # non-zero if we should generate an index
- $Backlink = ''; # text for "back to top" links
- $Listlevel = 0; # current list depth
- @Listtype = (); # list types for open lists
- $ListNewTerm = 0; # indicates new term in definition list; used
- # to correctly open/close <dd> tags
- $Ignore = 1; # whether or not to format text. we don't
- # format text until we hit our first pod
- # directive.
-
- @Items_Seen = (); # for multiples of the same item in perlfunc
- %Items_Named = ();
- $Header = 0; # produce block header/footer
- $Title = ''; # title to give the pod(s)
- $Top = 1; # true if we are at the top of the doc. used
- # to prevent the first <hr /> directive.
- $Paragraph = ''; # which paragraph we're processing (used
- # for error messages)
- %Sections = (); # sections within this page
-
- %Local_Items = ();
- $Is83 = $^O eq 'dos'; # Is it an 8.3 filesystem?
-}
-
-#
-# clean_data: global clean-up of pod data
-#
-sub clean_data($){
- my( $dataref ) = @_;
- for my $i ( 0..$#{$dataref} ) {
- ${$dataref}[$i] =~ s/\s+\Z//;
-
- # have a look for all-space lines
- if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){
- my @chunks = split( /^\s+$/m, ${$dataref}[$i] );
- splice( @$dataref, $i, 1, @chunks );
- }
- }
-}
-
-
-sub pod2html {
- local(@ARGV) = @_;
- local($/);
- local $_;
-
- init_globals();
-
- $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
-
- # cache of %Pages and %Items from last time we ran pod2html
-
- #undef $opt_help if defined $opt_help;
-
- # parse the command-line parameters
- parse_command_line();
-
- # escape the backlink argument (same goes for title but is done later...)
- $Backlink = html_escape($Backlink) if defined $Backlink;
-
- # set some variables to their default values if necessary
- local *POD;
- unless (@ARGV && $ARGV[0]) {
- $Podfile = "-" unless $Podfile; # stdin
- open(POD, "<$Podfile")
- || die "$0: cannot open $Podfile file for input: $!\n";
- } else {
- $Podfile = $ARGV[0]; # XXX: might be more filenames
- *POD = *ARGV;
- }
- $Htmlfile = "-" unless $Htmlfile; # stdout
- $Htmlroot = "" if $Htmlroot eq "/"; # so we don't get a //
- $Htmldir =~ s#/\z## ; # so we don't get a //
- if ( $Htmlroot eq ''
- && defined( $Htmldir )
- && $Htmldir ne ''
- && substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir
- )
- {
- # Set the 'base' url for this file, so that we can use it
- # as the location from which to calculate relative links
- # to other files. If this is '', then absolute links will
- # be used throughout.
- $Htmlfileurl= "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1);
- }
-
- # read the pod a paragraph at a time
- warn "Scanning for sections in input file(s)\n" if $Verbose;
- $/ = "";
- my @poddata = <POD>;
- close(POD);
-
- # be eol agnostic
- for (@poddata) {
- if (/\r/) {
- if (/\r\n/) {
- @poddata = map { s/\r\n/\n/g;
- /\n\n/ ?
- map { "$_\n\n" } split /\n\n/ :
- $_ } @poddata;
- } else {
- @poddata = map { s/\r/\n/g;
- /\n\n/ ?
- map { "$_\n\n" } split /\n\n/ :
- $_ } @poddata;
- }
- last;
- }
- }
-
- clean_data( \@poddata );
-
- # scan the pod for =head[1-6] directives and build an index
- my $index = scan_headings(\%Sections, @poddata);
-
- unless($index) {
- warn "No headings in $Podfile\n" if $Verbose;
- }
-
- # open the output file
- open(HTML, ">$Htmlfile")
- || die "$0: cannot open $Htmlfile file for output: $!\n";
-
- # put a title in the HTML file if one wasn't specified
- if ($Title eq '') {
- TITLE_SEARCH: {
- for (my $i = 0; $i < @poddata; $i++) {
- if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
- for my $para ( @poddata[$i, $i+1] ) {
- last TITLE_SEARCH
- if ($Title) = $para =~ /(\S+\s+-+.*\S)/s;
- }
- }
-
- }
- }
- }
- if (!$Title and $Podfile =~ /\.pod\z/) {
- # probably a split pod so take first =head[12] as title
- for (my $i = 0; $i < @poddata; $i++) {
- last if ($Title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
- }
- warn "adopted '$Title' as title for $Podfile\n"
- if $Verbose and $Title;
- }
- if ($Title) {
- $Title =~ s/\s*\(.*\)//;
- } else {
- warn "$0: no title for $Podfile.\n" unless $Quiet;
- $Podfile =~ /^(.*)(\.[^.\/]+)?\z/s;
- $Title = ($Podfile eq "-" ? 'No Title' : $1);
- warn "using $Title" if $Verbose;
- }
- $Title = html_escape($Title);
-
- my $csslink = '';
- my $bodystyle = ' style="background-color: white"';
- my $tdstyle = ' style="background-color: #cccccc"';
-
- if ($Css) {
- $csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />);
- $csslink =~ s,\\,/,g;
- $csslink =~ s,(/.):,$1|,;
- $bodystyle = '';
- $tdstyle = '';
- }
-
- my $block = $Header ? <<END_OF_BLOCK : '';
-<table border="0" width="100%" cellspacing="0" cellpadding="3">
-<tr><td class="block"$tdstyle valign="middle">
-<big><strong><span class="block"> $Title</span></strong></big>
-</td></tr>
-</table>
-END_OF_BLOCK
-
- print HTML <<END_OF_HEAD;
-<?xml version="1.0" ?>
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
-<title>$Title</title>$csslink
-<meta http-equiv="content-type" content="text/html; charset=utf-8" />
-<link rev="made" href="mailto:$Config{perladmin}" />
-</head>
-
-<body$bodystyle>
-$block
-END_OF_HEAD
-
- # load/reload/validate/cache %Pages and %Items
- get_cache($Dircache, $Itemcache, \@Podpath, $Podroot, $Recurse);
-
- # scan the pod for =item directives
- scan_items( \%Local_Items, "", @poddata);
-
- # put an index at the top of the file. note, if $Doindex is 0 we
- # still generate an index, but surround it with an html comment.
- # that way some other program can extract it if desired.
- $index =~ s/--+/-/g;
-
- my $hr = ($Doindex and $index) ? qq(<hr name="index" />) : "";
-
- unless ($Doindex)
- {
- $index = qq(<!--\n$index\n-->\n);
- }
-
- print HTML << "END_OF_INDEX";
-
-<!-- INDEX BEGIN -->
-<div name="index">
-<p><a name=\"__index__\"></a></p>
-$index
-$hr
-</div>
-<!-- INDEX END -->
-
-END_OF_INDEX
-
- # now convert this file
- my $after_item; # set to true after an =item
- warn "Converting input file $Podfile\n" if $Verbose;
- foreach my $i (0..$#poddata){
- $_ = $poddata[$i];
- $Paragraph = $i+1;
- if (/^(=.*)/s) { # is it a pod directive?
- $Ignore = 0;
- $after_item = 0;
- $_ = $1;
- if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
- process_begin($1, $2);
- } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
- process_end($1, $2);
- } elsif (/^=cut/) { # =cut
- process_cut();
- } elsif (/^=pod/) { # =pod
- process_pod();
- } else {
- next if @Begin_Stack && $Begin_Stack[-1] ne 'html';
-
- if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading
- process_head( $1, $2, $Doindex && $index );
- } elsif (/^=item\s*(.*\S)?/sm) { # =item text
- process_item( $1 );
- $after_item = 1;
- } elsif (/^=over\s*(.*)/) { # =over N
- process_over();
- } elsif (/^=back/) { # =back
- process_back();
- } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for
- process_for($1,$2);
- } else {
- /^=(\S*)\s*/;
- warn "$0: $Podfile: unknown pod directive '$1' in "
- . "paragraph $Paragraph. ignoring.\n" unless $Quiet;
- }
- }
- $Top = 0;
- }
- else {
- next if $Ignore;
- next if @Begin_Stack && $Begin_Stack[-1] ne 'html';
- print HTML and next if @Begin_Stack && $Begin_Stack[-1] eq 'html';
- my $text = $_;
-
- # Open tag for definition list as we have something to put in it
- if( $ListNewTerm ){
- print HTML "<dd>\n";
- $ListNewTerm = 0;
- }
-
- if( $text =~ /\A\s+/ ){
- process_pre( \$text );
- print HTML "<pre>\n$text</pre>\n";
-
- } else {
- process_text( \$text );
-
- # experimental: check for a paragraph where all lines
- # have some ...\t...\t...\n pattern
- if( $text =~ /\t/ ){
- my @lines = split( "\n", $text );
- if( @lines > 1 ){
- my $all = 2;
- foreach my $line ( @lines ){
- if( $line =~ /\S/ && $line !~ /\t/ ){
- $all--;
- last if $all == 0;
- }
- }
- if( $all > 0 ){
- $text =~ s/\t+/<td>/g;
- $text =~ s/^/<tr><td>/gm;
- $text = '<table cellspacing="0" cellpadding="0">' .
- $text . '</table>';
- }
- }
- }
- ## end of experimental
-
- print HTML "<p>$text</p>\n";
- }
- $after_item = 0;
- }
- }
-
- # finish off any pending directives
- finish_list();
-
- # link to page index
- print HTML "<p><a href=\"#__index__\"><small>$Backlink</small></a></p>\n"
- if $Doindex and $index and $Backlink;
-
- print HTML <<END_OF_TAIL;
-$block
-</body>
-
-</html>
-END_OF_TAIL
-
- # close the html file
- close(HTML);
-
- warn "Finished\n" if $Verbose;
-}
-
-##############################################################################
-
-sub usage {
- my $podfile = shift;
- warn "$0: $podfile: @_\n" if @_;
- die <<END_OF_USAGE;
-Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
- --podpath=<name>:...:<name> --podroot=<name>
- --libpods=<name>:...:<name> --recurse --verbose --index
- --netscape --norecurse --noindex --cachedir=<name>
-
- --backlink - set text for "back to top" links (default: none).
- --cachedir - directory for the item and directory cache files.
- --css - stylesheet URL
- --flush - flushes the item and directory caches.
- --[no]header - produce block header/footer (default is no headers).
- --help - prints this message.
- --hiddendirs - search hidden directories in podpath
- --htmldir - directory for resulting HTML files.
- --htmlroot - http-server base directory from which all relative paths
- in podpath stem (default is /).
- --[no]index - generate an index at the top of the resulting html
- (default behaviour).
- --infile - filename for the pod to convert (input taken from stdin
- by default).
- --libpods - colon-separated list of pages to search for =item pod
- directives in as targets of C<> and implicit links (empty
- by default). note, these are not filenames, but rather
- page names like those that appear in L<> links.
- --outfile - filename for the resulting html file (output sent to
- stdout by default).
- --podpath - colon-separated list of directories containing library
- pods (empty by default).
- --podroot - filesystem base directory from which all relative paths
- in podpath stem (default is .).
- --[no]quiet - suppress some benign warning messages (default is off).
- --[no]recurse - recurse on those subdirectories listed in podpath
- (default behaviour).
- --title - title that will appear in resulting html file.
- --[no]verbose - self-explanatory (off by default).
- --[no]netscape - deprecated, has no effect. for backwards compatibility only.
-
-END_OF_USAGE
-
-}
-
-sub parse_command_line {
- my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help,
- $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,
- $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,
- $opt_recurse,$opt_title,$opt_verbose,$opt_hiddendirs);
-
- unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
- my $result = GetOptions(
- 'backlink=s' => \$opt_backlink,
- 'cachedir=s' => \$opt_cachedir,
- 'css=s' => \$opt_css,
- 'flush' => \$opt_flush,
- 'header!' => \$opt_header,
- 'help' => \$opt_help,
- 'hiddendirs!'=> \$opt_hiddendirs,
- 'htmldir=s' => \$opt_htmldir,
- 'htmlroot=s' => \$opt_htmlroot,
- 'index!' => \$opt_index,
- 'infile=s' => \$opt_infile,
- 'libpods=s' => \$opt_libpods,
- 'netscape!' => \$opt_netscape,
- 'outfile=s' => \$opt_outfile,
- 'podpath=s' => \$opt_podpath,
- 'podroot=s' => \$opt_podroot,
- 'quiet!' => \$opt_quiet,
- 'recurse!' => \$opt_recurse,
- 'title=s' => \$opt_title,
- 'verbose!' => \$opt_verbose,
- );
- usage("-", "invalid parameters") if not $result;
-
- usage("-") if defined $opt_help; # see if the user asked for help
- $opt_help = ""; # just to make -w shut-up.
-
- @Podpath = split(":", $opt_podpath) if defined $opt_podpath;
- @Libpods = split(":", $opt_libpods) if defined $opt_libpods;
-
- $Backlink = $opt_backlink if defined $opt_backlink;
- $Cachedir = $opt_cachedir if defined $opt_cachedir;
- $Css = $opt_css if defined $opt_css;
- $Header = $opt_header if defined $opt_header;
- $Htmldir = $opt_htmldir if defined $opt_htmldir;
- $Htmlroot = $opt_htmlroot if defined $opt_htmlroot;
- $Doindex = $opt_index if defined $opt_index;
- $Podfile = $opt_infile if defined $opt_infile;
- $HiddenDirs = $opt_hiddendirs if defined $opt_hiddendirs;
- $Htmlfile = $opt_outfile if defined $opt_outfile;
- $Podroot = $opt_podroot if defined $opt_podroot;
- $Quiet = $opt_quiet if defined $opt_quiet;
- $Recurse = $opt_recurse if defined $opt_recurse;
- $Title = $opt_title if defined $opt_title;
- $Verbose = $opt_verbose if defined $opt_verbose;
-
- warn "Flushing item and directory caches\n"
- if $opt_verbose && defined $opt_flush;
- $Dircache = "$Cachedir/pod2htmd.tmp";
- $Itemcache = "$Cachedir/pod2htmi.tmp";
- if (defined $opt_flush) {
- 1 while unlink($Dircache, $Itemcache);
- }
-}
-
-
-my $Saved_Cache_Key;
-
-sub get_cache {
- my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
- my @cache_key_args = @_;
-
- # A first-level cache:
- # Don't bother reading the cache files if they still apply
- # and haven't changed since we last read them.
-
- my $this_cache_key = cache_key(@cache_key_args);
-
- return if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key;
-
- # load the cache of %Pages and %Items if possible. $tests will be
- # non-zero if successful.
- my $tests = 0;
- if (-f $dircache && -f $itemcache) {
- warn "scanning for item cache\n" if $Verbose;
- $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
- }
-
- # if we didn't succeed in loading the cache then we must (re)build
- # %Pages and %Items.
- if (!$tests) {
- warn "scanning directories in pod-path\n" if $Verbose;
- scan_podpath($podroot, $recurse, 0);
- }
- $Saved_Cache_Key = cache_key(@cache_key_args);
-}
-
-sub cache_key {
- my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
- return join('!', $dircache, $itemcache, $recurse,
- @$podpath, $podroot, stat($dircache), stat($itemcache));
-}
-
-#
-# load_cache - tries to find if the caches stored in $dircache and $itemcache
-# are valid caches of %Pages and %Items. if they are valid then it loads
-# them and returns a non-zero value.
-#
-sub load_cache {
- my($dircache, $itemcache, $podpath, $podroot) = @_;
- my($tests);
- local $_;
-
- $tests = 0;
-
- open(CACHE, "<$itemcache") ||
- die "$0: error opening $itemcache for reading: $!\n";
- $/ = "\n";
-
- # is it the same podpath?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if (join(":", @$podpath) eq $_);
-
- # is it the same podroot?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if ($podroot eq $_);
-
- # load the cache if its good
- if ($tests != 2) {
- close(CACHE);
- return 0;
- }
-
- warn "loading item cache\n" if $Verbose;
- while (<CACHE>) {
- /(.*?) (.*)$/;
- $Items{$1} = $2;
- }
- close(CACHE);
-
- warn "scanning for directory cache\n" if $Verbose;
- open(CACHE, "<$dircache") ||
- die "$0: error opening $dircache for reading: $!\n";
- $/ = "\n";
- $tests = 0;
-
- # is it the same podpath?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if (join(":", @$podpath) eq $_);
-
- # is it the same podroot?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if ($podroot eq $_);
-
- # load the cache if its good
- if ($tests != 2) {
- close(CACHE);
- return 0;
- }
-
- warn "loading directory cache\n" if $Verbose;
- while (<CACHE>) {
- /(.*?) (.*)$/;
- $Pages{$1} = $2;
- }
-
- close(CACHE);
-
- return 1;
-}
-
-#
-# scan_podpath - scans the directories specified in @podpath for directories,
-# .pod files, and .pm files. it also scans the pod files specified in
-# @Libpods for =item directives.
-#
-sub scan_podpath {
- my($podroot, $recurse, $append) = @_;
- my($pwd, $dir);
- my($libpod, $dirname, $pod, @files, @poddata);
-
- unless($append) {
- %Items = ();
- %Pages = ();
- }
-
- # scan each directory listed in @Podpath
- $pwd = getcwd();
- chdir($podroot)
- || die "$0: error changing to directory $podroot: $!\n";
- foreach $dir (@Podpath) {
- scan_dir($dir, $recurse);
- }
-
- # scan the pods listed in @Libpods for =item directives
- foreach $libpod (@Libpods) {
- # if the page isn't defined then we won't know where to find it
- # on the system.
- next unless defined $Pages{$libpod} && $Pages{$libpod};
-
- # if there is a directory then use the .pod and .pm files within it.
- # NOTE: Only finds the first so-named directory in the tree.
-# if ($Pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
- if ($Pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
- # find all the .pod and .pm files within the directory
- $dirname = $1;
- opendir(DIR, $dirname) ||
- die "$0: error opening directory $dirname: $!\n";
- @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR));
- closedir(DIR);
-
- # scan each .pod and .pm file for =item directives
- foreach $pod (@files) {
- open(POD, "<$dirname/$pod") ||
- die "$0: error opening $dirname/$pod for input: $!\n";
- @poddata = <POD>;
- close(POD);
- clean_data( \@poddata );
-
- scan_items( \%Items, "$dirname/$pod", @poddata);
- }
-
- # use the names of files as =item directives too.
-### Don't think this should be done this way - confuses issues.(WL)
-### foreach $pod (@files) {
-### $pod =~ /^(.*)(\.pod|\.pm)$/;
-### $Items{$1} = "$dirname/$1.html" if $1;
-### }
- } elsif ($Pages{$libpod} =~ /([^:]*\.pod):/ ||
- $Pages{$libpod} =~ /([^:]*\.pm):/) {
- # scan the .pod or .pm file for =item directives
- $pod = $1;
- open(POD, "<$pod") ||
- die "$0: error opening $pod for input: $!\n";
- @poddata = <POD>;
- close(POD);
- clean_data( \@poddata );
-
- scan_items( \%Items, "$pod", @poddata);
- } else {
- warn "$0: shouldn't be here (line ".__LINE__."\n" unless $Quiet;
- }
- }
- @poddata = (); # clean-up a bit
-
- chdir($pwd)
- || die "$0: error changing to directory $pwd: $!\n";
-
- # cache the item list for later use
- warn "caching items for later use\n" if $Verbose;
- open(CACHE, ">$Itemcache") ||
- die "$0: error open $Itemcache for writing: $!\n";
-
- print CACHE join(":", @Podpath) . "\n$podroot\n";
- foreach my $key (keys %Items) {
- print CACHE "$key $Items{$key}\n";
- }
-
- close(CACHE);
-
- # cache the directory list for later use
- warn "caching directories for later use\n" if $Verbose;
- open(CACHE, ">$Dircache") ||
- die "$0: error open $Dircache for writing: $!\n";
-
- print CACHE join(":", @Podpath) . "\n$podroot\n";
- foreach my $key (keys %Pages) {
- print CACHE "$key $Pages{$key}\n";
- }
-
- close(CACHE);
-}
-
-#
-# scan_dir - scans the directory specified in $dir for subdirectories, .pod
-# files, and .pm files. notes those that it finds. this information will
-# be used later in order to figure out where the pages specified in L<>
-# links are on the filesystem.
-#
-sub scan_dir {
- my($dir, $recurse) = @_;
- my($t, @subdirs, @pods, $pod, $dirname, @dirs);
- local $_;
-
- @subdirs = ();
- @pods = ();
-
- opendir(DIR, $dir) ||
- die "$0: error opening directory $dir: $!\n";
- while (defined($_ = readdir(DIR))) {
- if (-d "$dir/$_" && $_ ne "." && $_ ne ".."
- && ($HiddenDirs || !/^\./)
- ) { # directory
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_:";
- push(@subdirs, $_);
- } elsif (/\.pod\z/) { # .pod
- s/\.pod\z//;
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pod:";
- push(@pods, "$dir/$_.pod");
- } elsif (/\.html\z/) { # .html
- s/\.html\z//;
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pod:";
- } elsif (/\.pm\z/) { # .pm
- s/\.pm\z//;
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pm:";
- push(@pods, "$dir/$_.pm");
- } elsif (-T "$dir/$_") { # script(?)
- local *F;
- if (open(F, "$dir/$_")) {
- my $line;
- while (defined($line = <F>)) {
- if ($line =~ /^=(?:pod|head1)/) {
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pod:";
- last;
- }
- }
- close(F);
- }
- }
- }
- closedir(DIR);
-
- # recurse on the subdirectories if necessary
- if ($recurse) {
- foreach my $subdir (@subdirs) {
- scan_dir("$dir/$subdir", $recurse);
- }
- }
-}
-
-#
-# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
-# build an index.
-#
-sub scan_headings {
- my($sections, @data) = @_;
- my($tag, $which_head, $otitle, $listdepth, $index);
-
- local $Ignore = 0;
-
- $listdepth = 0;
- $index = "";
-
- # scan for =head directives, note their name, and build an index
- # pointing to each of them.
- foreach my $line (@data) {
- if ($line =~ /^=(head)([1-6])\s+(.*)/) {
- ($tag, $which_head, $otitle) = ($1,$2,$3);
-
- my $title = depod( $otitle );
- my $name = anchorify( $title );
- $$sections{$name} = 1;
- $title = process_text( \$otitle );
-
- while ($which_head != $listdepth) {
- if ($which_head > $listdepth) {
- $index .= "\n" . ("\t" x $listdepth) . "<ul>\n";
- $listdepth++;
- } elsif ($which_head < $listdepth) {
- $listdepth--;
- $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
- }
- }
-
- $index .= "\n" . ("\t" x $listdepth) . "<li>" .
- "<a href=\"#" . $name . "\">" .
- $title . "</a></li>";
- }
- }
-
- # finish off the lists
- while ($listdepth--) {
- $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
- }
-
- # get rid of bogus lists
- $index =~ s,\t*<ul>\s*</ul>\n,,g;
-
- return $index;
-}
-
-#
-# scan_items - scans the pod specified by $pod for =item directives. we
-# will use this information later on in resolving C<> links.
-#
-sub scan_items {
- my( $itemref, $pod, @poddata ) = @_;
- my($i, $item);
- local $_;
-
- $pod =~ s/\.pod\z//;
- $pod .= ".html" if $pod;
-
- foreach $i (0..$#poddata) {
- my $txt = depod( $poddata[$i] );
-
- # figure out what kind of item it is.
- # Build string for referencing this item.
- if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bulleted list
- next unless $1;
- $item = $1;
- } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list
- $item = $1;
- } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # definition list
- $item = $1;
- } else {
- next;
- }
- my $fid = fragment_id( $item );
- $$itemref{$fid} = "$pod" if $fid;
- }
-}
-
-#
-# process_head - convert a pod head[1-6] tag and convert it to HTML format.
-#
-sub process_head {
- my($tag, $heading, $hasindex) = @_;
-
- # figure out the level of the =head
- $tag =~ /head([1-6])/;
- my $level = $1;
-
- finish_list();
-
- print HTML "<p>\n";
- if( $level == 1 && ! $Top ){
- print HTML "<a href=\"#__index__\"><small>$Backlink</small></a>\n"
- if $hasindex and $Backlink;
- print HTML "</p>\n<hr />\n"
- } else {
- print HTML "</p>\n";
- }
-
- my $name = anchorify( depod( $heading ) );
- my $convert = process_text( \$heading );
- print HTML "<h$level><a name=\"$name\">$convert</a></h$level>\n";
-}
-
-
-#
-# emit_item_tag - print an =item's text
-# Note: The global $EmittedItem is used for inhibiting self-references.
-#
-my $EmittedItem;
-
-sub emit_item_tag($$$){
- my( $otext, $text, $compact ) = @_;
- my $item = fragment_id( depod($text) , -generate);
- Carp::confess("Undefined fragment '$text' (".depod($text).") from fragment_id() in emit_item_tag() in $Podfile")
- if !defined $item;
- $EmittedItem = $item;
- ### print STDERR "emit_item_tag=$item ($text)\n";
-
- print HTML '<strong>';
- if ($Items_Named{$item}++) {
- print HTML process_text( \$otext );
- } else {
- my $name = $item;
- $name = anchorify($name);
- print HTML qq{<a name="$name" class="item">}, process_text( \$otext ), '</a>';
- }
- print HTML "</strong>";
- undef( $EmittedItem );
-}
-
-sub new_listitem {
- my( $tag ) = @_;
- # Open tag for definition list as we have something to put in it
- if( ($tag ne 'dl') && ($ListNewTerm) ){
- print HTML "<dd>\n";
- $ListNewTerm = 0;
- }
-
- if( $Items_Seen[$Listlevel]++ == 0 ){
- # start of new list
- push( @Listtype, "$tag" );
- print HTML "<$tag>\n";
- } else {
- # if this is not the first item, close the previous one
- if ( $tag eq 'dl' ){
- print HTML "</dd>\n" unless $ListNewTerm;
- } else {
- print HTML "</li>\n";
- }
- }
- my $opentag = $tag eq 'dl' ? 'dt' : 'li';
- print HTML "<$opentag>";
-}
-
-#
-# process_item - convert a pod item tag and convert it to HTML format.
-#
-sub process_item {
- my( $otext ) = @_;
-
- # lots of documents start a list without doing an =over. this is
- # bad! but, the proper thing to do seems to be to just assume
- # they did do an =over. so warn them once and then continue.
- if( $Listlevel == 0 ){
- warn "$0: $Podfile: unexpected =item directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- process_over();
- }
-
- # remove formatting instructions from the text
- my $text = depod( $otext );
-
- # all the list variants:
- if( $text =~ /\A\*/ ){ # bullet
- new_listitem( 'ul' );
- if ($text =~ /\A\*\s+(\S.*)\Z/s ) { # with additional text
- my $tag = $1;
- $otext =~ s/\A\*\s+//;
- emit_item_tag( $otext, $tag, 1 );
- print HTML "\n";
- }
-
- } elsif( $text =~ /\A\d+/ ){ # numbered list
- new_listitem( 'ol' );
- if ($text =~ /\A(?>\d+\.?)\s*(\S.*)\Z/s ) { # with additional text
- my $tag = $1;
- $otext =~ s/\A\d+\.?\s*//;
- emit_item_tag( $otext, $tag, 1 );
- print HTML "\n";
- }
-
- } else { # definition list
- # new_listitem takes care of opening the <dt> tag
- new_listitem( 'dl' );
- if ($text =~ /\A(.+)\Z/s ){ # should have text
- emit_item_tag( $otext, $text, 1 );
- # write the definition term and close <dt> tag
- print HTML "</dt>\n";
- }
- # trigger opening a <dd> tag for the actual definition; will not
- # happen if next paragraph is also a definition term (=item)
- $ListNewTerm = 1;
- }
- print HTML "\n";
-}
-
-#
-# process_over - process a pod over tag and start a corresponding HTML list.
-#
-sub process_over {
- # start a new list
- $Listlevel++;
- push( @Items_Seen, 0 );
-}
-
-#
-# process_back - process a pod back tag and convert it to HTML format.
-#
-sub process_back {
- if( $Listlevel == 0 ){
- warn "$0: $Podfile: unexpected =back directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- return;
- }
-
- # close off the list. note, I check to see if $Listtype[$Listlevel] is
- # defined because an =item directive may have never appeared and thus
- # $Listtype[$Listlevel] may have never been initialized.
- $Listlevel--;
- if( defined $Listtype[$Listlevel] ){
- if ( $Listtype[$Listlevel] eq 'dl' ){
- print HTML "</dd>\n" unless $ListNewTerm;
- } else {
- print HTML "</li>\n";
- }
- print HTML "</$Listtype[$Listlevel]>\n";
- pop( @Listtype );
- $ListNewTerm = 0;
- }
-
- # clean up item count
- pop( @Items_Seen );
-}
-
-#
-# process_cut - process a pod cut tag, thus start ignoring pod directives.
-#
-sub process_cut {
- $Ignore = 1;
-}
-
-#
-# process_pod - process a pod tag, thus stop ignoring pod directives
-# until we see a corresponding cut.
-#
-sub process_pod {
- # no need to set $Ignore to 0 cause the main loop did it
-}
-
-#
-# process_for - process a =for pod tag. if it's for html, spit
-# it out verbatim, if illustration, center it, otherwise ignore it.
-#
-sub process_for {
- my($whom, $text) = @_;
- if ( $whom =~ /^(pod2)?html$/i) {
- print HTML $text;
- } elsif ($whom =~ /^illustration$/i) {
- 1 while chomp $text;
- for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
- $text .= $ext, last if -r "$text$ext";
- }
- print HTML qq{<p align="center"><img src="$text" alt="$text illustration" /></p>};
- }
-}
-
-#
-# process_begin - process a =begin pod tag. this pushes
-# whom we're beginning on the begin stack. if there's a
-# begin stack, we only print if it us.
-#
-sub process_begin {
- my($whom, $text) = @_;
- $whom = lc($whom);
- push (@Begin_Stack, $whom);
- if ( $whom =~ /^(pod2)?html$/) {
- print HTML $text if $text;
- }
-}
-
-#
-# process_end - process a =end pod tag. pop the
-# begin stack. die if we're mismatched.
-#
-sub process_end {
- my($whom, $text) = @_;
- $whom = lc($whom);
- if (!defined $Begin_Stack[-1] or $Begin_Stack[-1] ne $whom ) {
- Carp::confess("Unmatched begin/end at chunk $Paragraph in pod $Podfile\n")
- }
- pop( @Begin_Stack );
-}
-
-#
-# process_pre - indented paragraph, made into <pre></pre>
-#
-sub process_pre {
- my( $text ) = @_;
- my( $rest );
- return if $Ignore;
-
- $rest = $$text;
-
- # insert spaces in place of tabs
- $rest =~ s#(.+)#
- my $line = $1;
- 1 while $line =~ s/(\t+)/' ' x ((length($1) * 8) - $-[0] % 8)/e;
- $line;
- #eg;
-
- # convert some special chars to HTML escapes
- $rest = html_escape($rest);
-
- # try and create links for all occurrences of perl.* within
- # the preformatted text.
- $rest =~ s{
- (\s*)(perl\w+)
- }{
- if ( defined $Pages{$2} ){ # is a link
- qq($1<a href="$Htmlroot/$Pages{$2}">$2</a>);
- } elsif (defined $Pages{dosify($2)}) { # is a link
- qq($1<a href="$Htmlroot/$Pages{dosify($2)}">$2</a>);
- } else {
- "$1$2";
- }
- }xeg;
- $rest =~ s{
- (<a\ href="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
- }{
- my $url ;
- if ( $Htmlfileurl ne '' ){
- # Here, we take advantage of the knowledge
- # that $Htmlfileurl ne '' implies $Htmlroot eq ''.
- # Since $Htmlroot eq '', we need to prepend $Htmldir
- # on the fron of the link to get the absolute path
- # of the link's target. We check for a leading '/'
- # to avoid corrupting links that are #, file:, etc.
- my $old_url = $3 ;
- $old_url = "$Htmldir$old_url" if $old_url =~ m{^\/};
- $url = relativize_url( "$old_url.html", $Htmlfileurl );
- } else {
- $url = "$3.html" ;
- }
- "$1$url" ;
- }xeg;
-
- # Look for embedded URLs and make them into links. We don't
- # relativize them since they are best left as the author intended.
-
- my $urls = '(' . join ('|', qw{
- http
- telnet
- mailto
- news
- gopher
- file
- wais
- ftp
- } )
- . ')';
-
- my $ltrs = '\w';
- my $gunk = '/#~:.?+=&%@!\-';
- my $punc = '.:!?\-;';
- my $any = "${ltrs}${gunk}${punc}";
-
- $rest =~ s{
- \b # start at word boundary
- ( # begin $1 {
- $urls : # need resource and a colon
- (?!:) # Ignore File::, among others.
- [$any] +? # followed by one or more of any valid
- # character, but be conservative and
- # take only what you need to....
- ) # end $1 }
- (?=
- " > # maybe pre-quoted '<a href="...">'
- | # or:
- [$punc]* # 0 or more punctuation
- (?: # followed
- [^$any] # by a non-url char
- | # or
- $ # end of the string
- ) #
- | # or else
- $ # then end of the string
- )
- }{<a href="$1">$1</a>}igox;
-
- # text should be as it is (verbatim)
- $$text = $rest;
-}
-
-
-#
-# pure text processing
-#
-# pure_text/inIS_text: differ with respect to automatic C<> recognition.
-# we don't want this to happen within IS
-#
-sub pure_text($){
- my $text = shift();
- process_puretext( $text, 1 );
-}
-
-sub inIS_text($){
- my $text = shift();
- process_puretext( $text, 0 );
-}
-
-#
-# process_puretext - process pure text (without pod-escapes) converting
-# double-quotes and handling implicit C<> links.
-#
-sub process_puretext {
- my($text, $notinIS) = @_;
-
- ## Guessing at func() or [\$\@%&]*var references in plain text is destined
- ## to produce some strange looking ref's. uncomment to disable:
- ## $notinIS = 0;
-
- my(@words, $lead, $trail);
-
- # keep track of leading and trailing white-space
- $lead = ($text =~ s/\A(\s+)//s ? $1 : "");
- $trail = ($text =~ s/(\s+)\Z//s ? $1 : "");
-
- # split at space/non-space boundaries
- @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text );
-
- # process each word individually
- foreach my $word (@words) {
- # skip space runs
- next if $word =~ /^\s*$/;
- # see if we can infer a link or a function call
- #
- # NOTE: This is a word based search, it won't automatically
- # mark "substr($var, 1, 2)" because the 1st word would be "substr($var"
- # User has to enclose those with proper C<>
-
- if( $notinIS && $word =~
- m/
- ^([a-z_]{2,}) # The function name
- \(
- ([0-9][a-z]* # Manual page(1) or page(1M)
- |[^)]*[\$\@\%][^)]+ # ($foo), (1, @foo), (%hash)
- | # ()
- )
- \)
- ([.,;]?)$ # a possible punctuation follows
- /xi
- ) {
- # has parenthesis so should have been a C<> ref
- ## try for a pagename (perlXXX(1))?
- my( $func, $args, $rest ) = ( $1, $2, $3 || '' );
- if( $args =~ /^\d+$/ ){
- my $url = page_sect( $word, '' );
- if( defined $url ){
- $word = qq(<a href="$url" class="man">the $word manpage</a>$rest);
- next;
- }
- }
- ## try function name for a link, append tt'ed argument list
- $word = emit_C( $func, '', "($args)") . $rest;
-
-#### disabled. either all (including $\W, $\w+{.*} etc.) or nothing.
-## } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) {
-## # perl variables, should be a C<> ref
-## $word = emit_C( $word );
-
- } elsif ($word =~ m,^\w+://\w,) {
- # looks like a URL
- # Don't relativize it: leave it as the author intended
- $word = qq(<a href="$word">$word</a>);
- } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
- # looks like an e-mail address
- my ($w1, $w2, $w3) = ("", $word, "");
- ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
- ($w1, $w2, $w3) = ("<", $1, ">$2") if $word =~ /^<(.*?)>(,?)/;
- $word = qq($w1<a href="mailto:$w2">$w2</a>$w3);
- } else {
- $word = html_escape($word) if $word =~ /["&<>]/;
- }
- }
-
- # put everything back together
- return $lead . join( '', @words ) . $trail;
-}
-
-
-#
-# process_text - handles plaintext that appears in the input pod file.
-# there may be pod commands embedded within the text so those must be
-# converted to html commands.
-#
-
-sub process_text1($$;$$);
-sub pattern ($) { $_[0] ? '\s+'.('>' x ($_[0] + 1)) : '>' }
-sub closing ($) { local($_) = shift; (defined && s/\s+\z//) ? length : 0 }
-
-sub process_text {
- return if $Ignore;
- my( $tref ) = @_;
- my $res = process_text1( 0, $tref );
- $res =~ s/\s+$//s;
- $$tref = $res;
-}
-
-sub process_text_rfc_links {
- my $text = shift;
-
- # For every "RFCnnnn" or "RFC nnn", link it to the authoritative
- # ource. Do not use the /i modifier here. Require "RFC" to be written in
- # in capital letters.
-
- $text =~ s{
- (?<=[^<>[:alpha:]]) # Make sure this is not an URL already
- (RFC\s*([0-9]{1,5}))(?![0-9]) # max 5 digits
- }
- {<a href="http://www.ietf.org/rfc/rfc$2.txt" class="rfc">$1</a>}gx;
-
- $text;
-}
-
-sub process_text1($$;$$){
- my( $lev, $rstr, $func, $closing ) = @_;
- my $res = '';
-
- unless (defined $func) {
- $func = '';
- $lev++;
- }
-
- if( $func eq 'B' ){
- # B<text> - boldface
- $res = '<strong>' . process_text1( $lev, $rstr ) . '</strong>';
-
- } elsif( $func eq 'C' ){
- # C<code> - can be a ref or <code></code>
- # need to extract text
- my $par = go_ahead( $rstr, 'C', $closing );
-
- ## clean-up of the link target
- my $text = depod( $par );
-
- ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ;
- ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n";
-
- $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
-
- } elsif( $func eq 'E' ){
- # E<x> - convert to character
- $$rstr =~ s/^([^>]*)>//;
- my $escape = $1;
- $escape =~ s/^(\d+|X[\dA-F]+)$/#$1/i;
- $res = "&$escape;";
-
- } elsif( $func eq 'F' ){
- # F<filename> - italicize
- $res = '<em class="file">' . process_text1( $lev, $rstr ) . '</em>';
-
- } elsif( $func eq 'I' ){
- # I<text> - italicize
- $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
-
- } elsif( $func eq 'L' ){
- # L<link> - link
- ## L<text|cross-ref> => produce text, use cross-ref for linking
- ## L<cross-ref> => make text from cross-ref
- ## need to extract text
- my $par = go_ahead( $rstr, 'L', $closing );
-
- # some L<>'s that shouldn't be:
- # a) full-blown URL's are emitted as-is
- if( $par =~ m{^\w+://}s ){
- return make_URL_href( $par );
- }
- # b) C<...> is stripped and treated as C<>
- if( $par =~ /^C<(.*)>$/ ){
- my $text = depod( $1 );
- return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
- }
-
- # analyze the contents
- $par =~ s/\n/ /g; # undo word-wrapped tags
- my $opar = $par;
- my $linktext;
- if( $par =~ s{^([^|]+)\|}{} ){
- $linktext = $1;
- }
-
- # make sure sections start with a /
- $par =~ s{^"}{/"};
-
- my( $page, $section, $ident );
-
- # check for link patterns
- if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){ # name/ident
- # we've got a name/ident (no quotes)
- if (length $2) {
- ( $page, $ident ) = ( $1, $2 );
- } else {
- ( $page, $section ) = ( $1, $2 );
- }
- ### print STDERR "--> L<$par> to page $page, ident $ident\n";
-
- } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section"
- # even though this should be a "section", we go for ident first
- ( $page, $ident ) = ( $1, $2 );
- ### print STDERR "--> L<$par> to page $page, section $section\n";
-
- } elsif( $par =~ /\s/ ){ # this must be a section with missing quotes
- ( $page, $section ) = ( '', $par );
- ### print STDERR "--> L<$par> to void page, section $section\n";
-
- } else {
- ( $page, $section ) = ( $par, '' );
- ### print STDERR "--> L<$par> to page $par, void section\n";
- }
-
- # now, either $section or $ident is defined. the convoluted logic
- # below tries to resolve L<> according to what the user specified.
- # failing this, we try to find the next best thing...
- my( $url, $ltext, $fid );
-
- RESOLVE: {
- if( defined $ident ){
- ## try to resolve $ident as an item
- ( $url, $fid ) = coderef( $page, $ident );
- if( $url ){
- if( ! defined( $linktext ) ){
- $linktext = $ident;
- $linktext .= " in " if $ident && $page;
- $linktext .= "the $page manpage" if $page;
- }
- ### print STDERR "got coderef url=$url\n";
- last RESOLVE;
- }
- ## no luck: go for a section (auto-quoting!)
- $section = $ident;
- }
- ## now go for a section
- my $htmlsection = htmlify( $section );
- $url = page_sect( $page, $htmlsection );
- if( $url ){
- if( ! defined( $linktext ) ){
- $linktext = $section;
- $linktext .= " in " if $section && $page;
- $linktext .= "the $page manpage" if $page;
- }
- ### print STDERR "got page/section url=$url\n";
- last RESOLVE;
- }
- ## no luck: go for an ident
- if( $section ){
- $ident = $section;
- } else {
- $ident = $page;
- $page = undef();
- }
- ( $url, $fid ) = coderef( $page, $ident );
- if( $url ){
- if( ! defined( $linktext ) ){
- $linktext = $ident;
- $linktext .= " in " if $ident && $page;
- $linktext .= "the $page manpage" if $page;
- }
- ### print STDERR "got section=>coderef url=$url\n";
- last RESOLVE;
- }
-
- # warning; show some text.
- $linktext = $opar unless defined $linktext;
- warn "$0: $Podfile: cannot resolve L<$opar> in paragraph $Paragraph.\n" unless $Quiet;
- }
-
- # now we have a URL or just plain code
- $$rstr = $linktext . '>' . $$rstr;
- if( defined( $url ) ){
- $res = "<a href=\"$url\">" . process_text1( $lev, $rstr ) . '</a>';
- } else {
- $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
- }
-
- } elsif( $func eq 'S' ){
- # S<text> - non-breaking spaces
- $res = process_text1( $lev, $rstr );
- $res =~ s/ / /g;
-
- } elsif( $func eq 'X' ){
- # X<> - ignore
- warn "$0: $Podfile: invalid X<> in paragraph $Paragraph.\n"
- unless $$rstr =~ s/^[^>]*>// or $Quiet;
- } elsif( $func eq 'Z' ){
- # Z<> - empty
- warn "$0: $Podfile: invalid Z<> in paragraph $Paragraph.\n"
- unless $$rstr =~ s/^>// or $Quiet;
-
- } else {
- my $term = pattern $closing;
- while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
- # all others: either recurse into new function or
- # terminate at closing angle bracket(s)
- my $pt = $1;
- $pt .= $2 if !$3 && $lev == 1;
- $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt );
- return $res if !$3 && $lev > 1;
- if( $3 ){
- $res .= process_text1( $lev, $rstr, $3, closing $4 );
- }
- }
- if( $lev == 1 ){
- $res .= pure_text( $$rstr );
- } elsif( ! $Quiet ) {
- my $snippet = substr($$rstr,0,60);
- warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph: '$snippet'.\n"
-
- }
- $res = process_text_rfc_links($res);
- }
- return $res;
-}
-
-#
-# go_ahead: extract text of an IS (can be nested)
-#
-sub go_ahead($$$){
- my( $rstr, $func, $closing ) = @_;
- my $res = '';
- my @closing = ($closing);
- while( $$rstr =~
- s/\A(.*?)(([BCEFILSXZ])<(<+\s+)?|@{[pattern $closing[0]]})//s ){
- $res .= $1;
- unless( $3 ){
- shift @closing;
- return $res unless @closing;
- } else {
- unshift @closing, closing $4;
- }
- $res .= $2;
- }
- unless ($Quiet) {
- my $snippet = substr($$rstr,0,60);
- warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph (go_ahead): '$snippet'.\n"
- }
- return $res;
-}
-
-#
-# emit_C - output result of C<text>
-# $text is the depod-ed text
-#
-sub emit_C($;$$){
- my( $text, $nocode, $args ) = @_;
- $args = '' unless defined $args;
- my $res;
- my( $url, $fid ) = coderef( undef(), $text );
-
- # need HTML-safe text
- my $linktext = html_escape( "$text$args" );
-
- if( defined( $url ) &&
- (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){
- $res = "<a href=\"$url\"><code>$linktext</code></a>";
- } elsif( 0 && $nocode ){
- $res = $linktext;
- } else {
- $res = "<code>$linktext</code>";
- }
- return $res;
-}
-
-#
-# html_escape: make text safe for HTML
-#
-sub html_escape {
- my $rest = $_[0];
- $rest =~ s/&/&/g;
- $rest =~ s/</</g;
- $rest =~ s/>/>/g;
- $rest =~ s/"/"/g;
- # ' is only in XHTML, not HTML4. Be conservative
- #$rest =~ s/'/'/g;
- return $rest;
-}
-
-
-#
-# dosify - convert filenames to 8.3
-#
-sub dosify {
- my($str) = @_;
- return lc($str) if $^O eq 'VMS'; # VMS just needs casing
- if ($Is83) {
- $str = lc $str;
- $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
- $str =~ s/(\w+)/substr ($1,0,8)/ge;
- }
- return $str;
-}
-
-#
-# page_sect - make a URL from the text of a L<>
-#
-sub page_sect($$) {
- my( $page, $section ) = @_;
- my( $linktext, $page83, $link); # work strings
-
- # check if we know that this is a section in this page
- if (!defined $Pages{$page} && defined $Sections{$page}) {
- $section = $page;
- $page = "";
- ### print STDERR "reset page='', section=$section\n";
- }
-
- $page83=dosify($page);
- $page=$page83 if (defined $Pages{$page83});
- if ($page eq "") {
- $link = "#" . anchorify( $section );
- } elsif ( $page =~ /::/ ) {
- $page =~ s,::,/,g;
- # Search page cache for an entry keyed under the html page name,
- # then look to see what directory that page might be in. NOTE:
- # this will only find one page. A better solution might be to produce
- # an intermediate page that is an index to all such pages.
- my $page_name = $page ;
- $page_name =~ s,^.*/,,s ;
- if ( defined( $Pages{ $page_name } ) &&
- $Pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/
- ) {
- $page = $1 ;
- }
- else {
- # NOTE: This branch assumes that all A::B pages are located in
- # $Htmlroot/A/B.html . This is often incorrect, since they are
- # often in $Htmlroot/lib/A/B.html or such like. Perhaps we could
- # analyze the contents of %Pages and figure out where any
- # cousins of A::B are, then assume that. So, if A::B isn't found,
- # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
- # lib/A/B.pm. This is also limited, but it's an improvement.
- # Maybe a hints file so that the links point to the correct places
- # nonetheless?
-
- }
- $link = "$Htmlroot/$page.html";
- $link .= "#" . anchorify( $section ) if ($section);
- } elsif (!defined $Pages{$page}) {
- $link = "";
- } else {
- $section = anchorify( $section ) if $section ne "";
- ### print STDERR "...section=$section\n";
-
- # if there is a directory by the name of the page, then assume that an
- # appropriate section will exist in the subdirectory
-# if ($section ne "" && $Pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
- if ($section ne "" && $Pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
- $link = "$Htmlroot/$1/$section.html";
- ### print STDERR "...link=$link\n";
-
- # since there is no directory by the name of the page, the section will
- # have to exist within a .html of the same name. thus, make sure there
- # is a .pod or .pm that might become that .html
- } else {
- $section = "#$section" if $section;
- ### print STDERR "...section=$section\n";
-
- # check if there is a .pod with the page name.
- # for L<Foo>, Foo.(pod|pm) is preferred to A/Foo.(pod|pm)
- if ($Pages{$page} =~ /([^:]*)\.(?:pod|pm):/) {
- $link = "$Htmlroot/$1.html$section";
- } else {
- $link = "";
- }
- }
- }
-
- if ($link) {
- # Here, we take advantage of the knowledge that $Htmlfileurl ne ''
- # implies $Htmlroot eq ''. This means that the link in question
- # needs a prefix of $Htmldir if it begins with '/'. The test for
- # the initial '/' is done to avoid '#'-only links, and to allow
- # for other kinds of links, like file:, ftp:, etc.
- my $url ;
- if ( $Htmlfileurl ne '' ) {
- $link = "$Htmldir$link" if $link =~ m{^/}s;
- $url = relativize_url( $link, $Htmlfileurl );
-# print( " b: [$link,$Htmlfileurl,$url]\n" );
- }
- else {
- $url = $link ;
- }
- return $url;
-
- } else {
- return undef();
- }
-}
-
-#
-# relativize_url - convert an absolute URL to one relative to a base URL.
-# Assumes both end in a filename.
-#
-sub relativize_url {
- my ($dest,$source) = @_ ;
-
- my ($dest_volume,$dest_directory,$dest_file) =
- File::Spec::Unix->splitpath( $dest ) ;
- $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
-
- my ($source_volume,$source_directory,$source_file) =
- File::Spec::Unix->splitpath( $source ) ;
- $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
-
- my $rel_path = '' ;
- if ( $dest ne '' ) {
- $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
- }
-
- if ( $rel_path ne '' &&
- substr( $rel_path, -1 ) ne '/' &&
- substr( $dest_file, 0, 1 ) ne '#'
- ) {
- $rel_path .= "/$dest_file" ;
- }
- else {
- $rel_path .= "$dest_file" ;
- }
-
- return $rel_path ;
-}
-
-
-#
-# coderef - make URL from the text of a C<>
-#
-sub coderef($$){
- my( $page, $item ) = @_;
- my( $url );
-
- my $fid = fragment_id( $item );
-
- if( defined( $page ) && $page ne "" ){
- # we have been given a $page...
- $page =~ s{::}{/}g;
-
- Carp::confess("Undefined fragment '$item' from fragment_id() in coderef() in $Podfile")
- if !defined $fid;
- # Do we take it? Item could be a section!
- my $base = $Items{$fid} || "";
- $base =~ s{[^/]*/}{};
- if( $base ne "$page.html" ){
- ### print STDERR "coderef( $page, $item ): items{$fid} = $Items{$fid} = $base => discard page!\n";
- $page = undef();
- }
-
- } else {
- # no page - local items precede cached items
- if( defined( $fid ) ){
- if( exists $Local_Items{$fid} ){
- $page = $Local_Items{$fid};
- } else {
- $page = $Items{$fid};
- }
- }
- }
-
- # if there was a pod file that we found earlier with an appropriate
- # =item directive, then create a link to that page.
- if( defined $page ){
- if( $page ){
- if( exists $Pages{$page} and $Pages{$page} =~ /([^:.]*)\.[^:]*:/){
- $page = $1 . '.html';
- }
- my $link = "$Htmlroot/$page#" . anchorify($fid);
-
- # Here, we take advantage of the knowledge that $Htmlfileurl
- # ne '' implies $Htmlroot eq ''.
- if ( $Htmlfileurl ne '' ) {
- $link = "$Htmldir$link" ;
- $url = relativize_url( $link, $Htmlfileurl ) ;
- } else {
- $url = $link ;
- }
- } else {
- $url = "#" . anchorify($fid);
- }
-
- confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/;
- }
- return( $url, $fid );
-}
-
-
-
-#
-# Adapted from Nick Ing-Simmons' PodToHtml package.
-sub relative_url {
- my $source_file = shift ;
- my $destination_file = shift;
-
- my $source = URI::file->new_abs($source_file);
- my $uo = URI::file->new($destination_file,$source)->abs;
- return $uo->rel->as_string;
-}
-
-
-#
-# finish_list - finish off any pending HTML lists. this should be called
-# after the entire pod file has been read and converted.
-#
-sub finish_list {
- if( $Listlevel ){
- warn "$0: $Podfile: unterminated list(s) at =head in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- while( $Listlevel ){
- process_back();
- }
- }
-}
-
-#
-# htmlify - converts a pod section specification to a suitable section
-# specification for HTML. Note that we keep spaces and special characters
-# except ", ? (Netscape problem) and the hyphen (writer's problem...).
-#
-sub htmlify {
- my( $heading) = @_;
- $heading =~ s/(\s+)/ /g;
- $heading =~ s/\s+\Z//;
- $heading =~ s/\A\s+//;
- # The hyphen is a disgrace to the English language.
- # $heading =~ s/[-"?]//g;
- $heading =~ s/["?]//g;
- $heading = lc( $heading );
- return $heading;
-}
-
-#
-# similar to htmlify, but turns non-alphanumerics into underscores
-#
-sub anchorify {
- my ($anchor) = @_;
- $anchor = htmlify($anchor);
- $anchor =~ s/\W/_/g;
- return $anchor;
-}
-
-#
-# depod - convert text by eliminating all interior sequences
-# Note: can be called with copy or modify semantics
-#
-my %E2c;
-$E2c{lt} = '<';
-$E2c{gt} = '>';
-$E2c{sol} = '/';
-$E2c{verbar} = '|';
-$E2c{amp} = '&'; # in Tk's pods
-
-sub depod1($;$$);
-
-sub depod($){
- my $string;
- if( ref( $_[0] ) ){
- $string = ${$_[0]};
- ${$_[0]} = depod1( \$string );
- } else {
- $string = $_[0];
- depod1( \$string );
- }
-}
-
-sub depod1($;$$){
- my( $rstr, $func, $closing ) = @_;
- my $res = '';
- return $res unless defined $$rstr;
- if( ! defined( $func ) ){
- # skip to next begin of an interior sequence
- while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?//s ){
- # recurse into its text
- $res .= $1 . depod1( $rstr, $2, closing $3);
- }
- $res .= $$rstr;
- } elsif( $func eq 'E' ){
- # E<x> - convert to character
- $$rstr =~ s/^([^>]*)>//;
- $res .= $E2c{$1} || "";
- } elsif( $func eq 'X' ){
- # X<> - ignore
- $$rstr =~ s/^[^>]*>//;
- } elsif( $func eq 'Z' ){
- # Z<> - empty
- $$rstr =~ s/^>//;
- } else {
- # all others: either recurse into new function or
- # terminate at closing angle bracket
- my $term = pattern $closing;
- while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
- $res .= $1;
- last unless $3;
- $res .= depod1( $rstr, $3, closing $4 );
- }
- ## If we're here and $2 ne '>': undelimited interior sequence.
- ## Ignored, as this is called without proper indication of where we are.
- ## Rely on process_text to produce diagnostics.
- }
- return $res;
-}
-
-{
- my %seen; # static fragment record hash
-
-sub fragment_id_readable {
- my $text = shift;
- my $generate = shift; # optional flag
-
- my $orig = $text;
-
- # leave the words for the fragment identifier,
- # change everything else to underbars.
- $text =~ s/[^A-Za-z0-9_]+/_/g; # do not use \W to avoid locale dependency.
- $text =~ s/_{2,}/_/g;
- $text =~ s/\A_//;
- $text =~ s/_\Z//;
-
- unless ($text)
- {
- # Nothing left after removing punctuation, so leave it as is
- # E.g. if option is named: "=item -#"
-
- $text = $orig;
- }
-
- if ($generate) {
- if ( exists $seen{$text} ) {
- # This already exists, make it unique
- $seen{$text}++;
- $text = $text . $seen{$text};
- } else {
- $seen{$text} = 1; # first time seen this fragment
- }
- }
-
- $text;
-}}
-
-my @HC;
-sub fragment_id_obfuscated { # This was the old "_2d_2d__"
- my $text = shift;
- my $generate = shift; # optional flag
-
- # text? Normalize by obfuscating the fragment id to make it unique
- $text =~ s/\s+/_/sg;
-
- $text =~ s{(\W)}{
- defined( $HC[ord($1)] ) ? $HC[ord($1)]
- : ( $HC[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe;
- $text = substr( $text, 0, 50 );
-
- $text;
-}
-
-#
-# fragment_id - construct a fragment identifier from:
-# a) =item text
-# b) contents of C<...>
-#
-
-sub fragment_id {
- my $text = shift;
- my $generate = shift; # optional flag
-
- $text =~ s/\s+\Z//s;
- if( $text ){
- # a method or function?
- return $1 if $text =~ /(\w+)\s*\(/;
- return $1 if $text =~ /->\s*(\w+)\s*\(?/;
-
- # a variable name?
- return $1 if $text =~ /^([\$\@%*]\S+)/;
-
- # some pattern matching operator?
- return $1 if $text =~ m|^(\w+/).*/\w*$|;
-
- # fancy stuff... like "do { }"
- return $1 if $text =~ m|^(\w+)\s*{.*}$|;
-
- # honour the perlfunc manpage: func [PAR[,[ ]PAR]...]
- # and some funnies with ... Module ...
- return $1 if $text =~ m{^([a-z\d_]+)(\s+[A-Z,/& ][A-Z\d,/& ]*)?$};
- return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$};
-
- return fragment_id_readable($text, $generate);
- } else {
- return;
- }
-}
-
-#
-# make_URL_href - generate HTML href from URL
-# Special treatment for CGI queries.
-#
-sub make_URL_href($){
- my( $url ) = @_;
- if( $url !~
- s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<a href="$1$2">$1</a>}i ){
- $url = "<a href=\"$url\">$url</a>";
- }
- return $url;
-}
-
-1;
Deleted: trunk/contrib/perl/lib/Pod/InputObjects.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/InputObjects.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/InputObjects.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,936 +0,0 @@
-#############################################################################
-# Pod/InputObjects.pm -- package which defines objects for input streams
-# and paragraphs and commands when parsing 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.
-#############################################################################
-
-package Pod::InputObjects;
-use strict;
-
-use vars qw($VERSION);
-$VERSION = '1.31'; ## Current version of this package
-require 5.005; ## requires this Perl version or later
-
-#############################################################################
-
-=head1 NAME
-
-Pod::InputObjects - objects representing POD input paragraphs, commands, etc.
-
-=head1 SYNOPSIS
-
- use Pod::InputObjects;
-
-=head1 REQUIRES
-
-perl5.004, Carp
-
-=head1 EXPORTS
-
-Nothing.
-
-=head1 DESCRIPTION
-
-This module defines some basic input objects used by B<Pod::Parser> when
-reading and parsing POD text from an input source. The following objects
-are defined:
-
-=over 4
-
-=begin __PRIVATE__
-
-=item package B<Pod::InputSource>
-
-An object corresponding to a source of POD input text. It is mostly a
-wrapper around a filehandle or C<IO::Handle>-type object (or anything
-that implements the C<getline()> method) which keeps track of some
-additional information relevant to the parsing of PODs.
-
-=end __PRIVATE__
-
-=item package B<Pod::Paragraph>
-
-An object corresponding to a paragraph of POD input text. It may be a
-plain paragraph, a verbatim paragraph, or a command paragraph (see
-L<perlpod>).
-
-=item package B<Pod::InteriorSequence>
-
-An object corresponding to an interior sequence command from the POD
-input text (see L<perlpod>).
-
-=item package B<Pod::ParseTree>
-
-An object corresponding to a tree of parsed POD text. Each "node" in
-a parse-tree (or I<ptree>) is either a text-string or a reference to
-a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree
-in the order in which they were parsed from left-to-right.
-
-=back
-
-Each of these input objects are described in further detail in the
-sections which follow.
-
-=cut
-
-#############################################################################
-
-package Pod::InputSource;
-
-##---------------------------------------------------------------------------
-
-=begin __PRIVATE__
-
-=head1 B<Pod::InputSource>
-
-This object corresponds to an input source or stream of POD
-documentation. When parsing PODs, it is necessary to associate and store
-certain context information with each input source. All of this
-information is kept together with the stream itself in one of these
-C<Pod::InputSource> objects. Each such object is merely a wrapper around
-an C<IO::Handle> object of some kind (or at least something that
-implements the C<getline()> method). They have the following
-methods/attributes:
-
-=end __PRIVATE__
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=begin __PRIVATE__
-
-=head2 B<new()>
-
- my $pod_input1 = Pod::InputSource->new(-handle => $filehandle);
- my $pod_input2 = new Pod::InputSource(-handle => $filehandle,
- -name => $name);
- my $pod_input3 = new Pod::InputSource(-handle => \*STDIN);
- my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN,
- -name => "(STDIN)");
-
-This is a class method that constructs a C<Pod::InputSource> object and
-returns a reference to the new input source object. It takes one or more
-keyword arguments in the form of a hash. The keyword C<-handle> is
-required and designates the corresponding input handle. The keyword
-C<-name> is optional and specifies the name associated with the input
-handle (typically a file name).
-
-=end __PRIVATE__
-
-=cut
-
-sub new {
- ## Determine if we were called via an object-ref or a classname
- my $this = shift;
- my $class = ref($this) || $this;
-
- ## Any remaining arguments are treated as initial values for the
- ## hash that is used to represent this object. Note that we default
- ## certain values by specifying them *before* the arguments passed.
- ## If they are in the argument list, they will override the defaults.
- my $self = { -name => '(unknown)',
- -handle => undef,
- -was_cutting => 0,
- @_ };
-
- ## Bless ourselves into the desired class and perform any initialization
- bless $self, $class;
- return $self;
-}
-
-##---------------------------------------------------------------------------
-
-=begin __PRIVATE__
-
-=head2 B<name()>
-
- my $filename = $pod_input->name();
- $pod_input->name($new_filename_to_use);
-
-This method gets/sets the name of the input source (usually a filename).
-If no argument is given, it returns a string containing the name of
-the input source; otherwise it sets the name of the input source to the
-contents of the given argument.
-
-=end __PRIVATE__
-
-=cut
-
-sub name {
- (@_ > 1) and $_[0]->{'-name'} = $_[1];
- return $_[0]->{'-name'};
-}
-
-## allow 'filename' as an alias for 'name'
-*filename = \&name;
-
-##---------------------------------------------------------------------------
-
-=begin __PRIVATE__
-
-=head2 B<handle()>
-
- my $handle = $pod_input->handle();
-
-Returns a reference to the handle object from which input is read (the
-one used to contructed this input source object).
-
-=end __PRIVATE__
-
-=cut
-
-sub handle {
- return $_[0]->{'-handle'};
-}
-
-##---------------------------------------------------------------------------
-
-=begin __PRIVATE__
-
-=head2 B<was_cutting()>
-
- print "Yes.\n" if ($pod_input->was_cutting());
-
-The value of the C<cutting> state (that the B<cutting()> method would
-have returned) immediately before any input was read from this input
-stream. After all input from this stream has been read, the C<cutting>
-state is restored to this value.
-
-=end __PRIVATE__
-
-=cut
-
-sub was_cutting {
- (@_ > 1) and $_[0]->{-was_cutting} = $_[1];
- return $_[0]->{-was_cutting};
-}
-
-##---------------------------------------------------------------------------
-
-#############################################################################
-
-package Pod::Paragraph;
-
-##---------------------------------------------------------------------------
-
-=head1 B<Pod::Paragraph>
-
-An object representing a paragraph of POD input text.
-It has the following methods/attributes:
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=head2 Pod::Paragraph-E<gt>B<new()>
-
- my $pod_para1 = Pod::Paragraph->new(-text => $text);
- my $pod_para2 = Pod::Paragraph->new(-name => $cmd,
- -text => $text);
- my $pod_para3 = new Pod::Paragraph(-text => $text);
- my $pod_para4 = new Pod::Paragraph(-name => $cmd,
- -text => $text);
- my $pod_para5 = Pod::Paragraph->new(-name => $cmd,
- -text => $text,
- -file => $filename,
- -line => $line_number);
-
-This is a class method that constructs a C<Pod::Paragraph> object and
-returns a reference to the new paragraph object. It may be given one or
-two keyword arguments. The C<-text> keyword indicates the corresponding
-text of the POD paragraph. The C<-name> keyword indicates the name of
-the corresponding POD command, such as C<head1> or C<item> (it should
-I<not> contain the C<=> prefix); this is needed only if the POD
-paragraph corresponds to a command paragraph. The C<-file> and C<-line>
-keywords indicate the filename and line number corresponding to the
-beginning of the paragraph
-
-=cut
-
-sub new {
- ## Determine if we were called via an object-ref or a classname
- my $this = shift;
- my $class = ref($this) || $this;
-
- ## Any remaining arguments are treated as initial values for the
- ## hash that is used to represent this object. Note that we default
- ## certain values by specifying them *before* the arguments passed.
- ## If they are in the argument list, they will override the defaults.
- my $self = {
- -name => undef,
- -text => (@_ == 1) ? shift : undef,
- -file => '<unknown-file>',
- -line => 0,
- -prefix => '=',
- -separator => ' ',
- -ptree => [],
- @_
- };
-
- ## Bless ourselves into the desired class and perform any initialization
- bless $self, $class;
- return $self;
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_para-E<gt>B<cmd_name()>
-
- my $para_cmd = $pod_para->cmd_name();
-
-If this paragraph is a command paragraph, then this method will return
-the name of the command (I<without> any leading C<=> prefix).
-
-=cut
-
-sub cmd_name {
- (@_ > 1) and $_[0]->{'-name'} = $_[1];
- return $_[0]->{'-name'};
-}
-
-## let name() be an alias for cmd_name()
-*name = \&cmd_name;
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_para-E<gt>B<text()>
-
- my $para_text = $pod_para->text();
-
-This method will return the corresponding text of the paragraph.
-
-=cut
-
-sub text {
- (@_ > 1) and $_[0]->{'-text'} = $_[1];
- return $_[0]->{'-text'};
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_para-E<gt>B<raw_text()>
-
- my $raw_pod_para = $pod_para->raw_text();
-
-This method will return the I<raw> text of the POD paragraph, exactly
-as it appeared in the input.
-
-=cut
-
-sub raw_text {
- return $_[0]->{'-text'} unless (defined $_[0]->{'-name'});
- return $_[0]->{'-prefix'} . $_[0]->{'-name'} .
- $_[0]->{'-separator'} . $_[0]->{'-text'};
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_para-E<gt>B<cmd_prefix()>
-
- my $prefix = $pod_para->cmd_prefix();
-
-If this paragraph is a command paragraph, then this method will return
-the prefix used to denote the command (which should be the string "="
-or "==").
-
-=cut
-
-sub cmd_prefix {
- return $_[0]->{'-prefix'};
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_para-E<gt>B<cmd_separator()>
-
- my $separator = $pod_para->cmd_separator();
-
-If this paragraph is a command paragraph, then this method will return
-the text used to separate the command name from the rest of the
-paragraph (if any).
-
-=cut
-
-sub cmd_separator {
- return $_[0]->{'-separator'};
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_para-E<gt>B<parse_tree()>
-
- my $ptree = $pod_parser->parse_text( $pod_para->text() );
- $pod_para->parse_tree( $ptree );
- $ptree = $pod_para->parse_tree();
-
-This method will get/set the corresponding parse-tree of the paragraph's text.
-
-=cut
-
-sub parse_tree {
- (@_ > 1) and $_[0]->{'-ptree'} = $_[1];
- return $_[0]->{'-ptree'};
-}
-
-## let ptree() be an alias for parse_tree()
-*ptree = \&parse_tree;
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_para-E<gt>B<file_line()>
-
- my ($filename, $line_number) = $pod_para->file_line();
- my $position = $pod_para->file_line();
-
-Returns the current filename and line number for the paragraph
-object. If called in a list context, it returns a list of two
-elements: first the filename, then the line number. If called in
-a scalar context, it returns a string containing the filename, followed
-by a colon (':'), followed by the line number.
-
-=cut
-
-sub file_line {
- my @loc = ($_[0]->{'-file'} || '<unknown-file>',
- $_[0]->{'-line'} || 0);
- return (wantarray) ? @loc : join(':', @loc);
-}
-
-##---------------------------------------------------------------------------
-
-#############################################################################
-
-package Pod::InteriorSequence;
-
-##---------------------------------------------------------------------------
-
-=head1 B<Pod::InteriorSequence>
-
-An object representing a POD interior sequence command.
-It has the following methods/attributes:
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=head2 Pod::InteriorSequence-E<gt>B<new()>
-
- my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd
- -ldelim => $delimiter);
- my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd,
- -ldelim => $delimiter);
- my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd,
- -ldelim => $delimiter,
- -file => $filename,
- -line => $line_number);
-
- my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree);
- my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree);
-
-This is a class method that constructs a C<Pod::InteriorSequence> object
-and returns a reference to the new interior sequence object. It should
-be given two keyword arguments. The C<-ldelim> keyword indicates the
-corresponding left-delimiter of the interior sequence (e.g. 'E<lt>').
-The C<-name> keyword indicates the name of the corresponding interior
-sequence command, such as C<I> or C<B> or C<C>. The C<-file> and
-C<-line> keywords indicate the filename and line number corresponding
-to the beginning of the interior sequence. If the C<$ptree> argument is
-given, it must be the last argument, and it must be either string, or
-else an array-ref suitable for passing to B<Pod::ParseTree::new> (or
-it may be a reference to a Pod::ParseTree object).
-
-=cut
-
-sub new {
- ## Determine if we were called via an object-ref or a classname
- my $this = shift;
- my $class = ref($this) || $this;
-
- ## See if first argument has no keyword
- if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) {
- ## Yup - need an implicit '-name' before first parameter
- unshift @_, '-name';
- }
-
- ## See if odd number of args
- if ((@_ % 2) != 0) {
- ## Yup - need an implicit '-ptree' before the last parameter
- splice @_, $#_, 0, '-ptree';
- }
-
- ## Any remaining arguments are treated as initial values for the
- ## hash that is used to represent this object. Note that we default
- ## certain values by specifying them *before* the arguments passed.
- ## If they are in the argument list, they will override the defaults.
- my $self = {
- -name => (@_ == 1) ? $_[0] : undef,
- -file => '<unknown-file>',
- -line => 0,
- -ldelim => '<',
- -rdelim => '>',
- @_
- };
-
- ## Initialize contents if they havent been already
- my $ptree = $self->{'-ptree'} || new Pod::ParseTree();
- if ( ref $ptree =~ /^(ARRAY)?$/ ) {
- ## We have an array-ref, or a normal scalar. Pass it as an
- ## an argument to the ptree-constructor
- $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree);
- }
- $self->{'-ptree'} = $ptree;
-
- ## Bless ourselves into the desired class and perform any initialization
- bless $self, $class;
- return $self;
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_seq-E<gt>B<cmd_name()>
-
- my $seq_cmd = $pod_seq->cmd_name();
-
-The name of the interior sequence command.
-
-=cut
-
-sub cmd_name {
- (@_ > 1) and $_[0]->{'-name'} = $_[1];
- return $_[0]->{'-name'};
-}
-
-## let name() be an alias for cmd_name()
-*name = \&cmd_name;
-
-##---------------------------------------------------------------------------
-
-## Private subroutine to set the parent pointer of all the given
-## children that are interior-sequences to be $self
-
-sub _set_child2parent_links {
- my ($self, @children) = @_;
- ## Make sure any sequences know who their parent is
- for (@children) {
- next unless (length and ref and ref ne 'SCALAR');
- if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or
- UNIVERSAL::can($_, 'nested'))
- {
- $_->nested($self);
- }
- }
-}
-
-## Private subroutine to unset child->parent links
-
-sub _unset_child2parent_links {
- my $self = shift;
- $self->{'-parent_sequence'} = undef;
- my $ptree = $self->{'-ptree'};
- for (@$ptree) {
- next unless (length and ref and ref ne 'SCALAR');
- $_->_unset_child2parent_links()
- if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
- }
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_seq-E<gt>B<prepend()>
-
- $pod_seq->prepend($text);
- $pod_seq1->prepend($pod_seq2);
-
-Prepends the given string or parse-tree or sequence object to the parse-tree
-of this interior sequence.
-
-=cut
-
-sub prepend {
- my $self = shift;
- $self->{'-ptree'}->prepend(@_);
- _set_child2parent_links($self, @_);
- return $self;
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_seq-E<gt>B<append()>
-
- $pod_seq->append($text);
- $pod_seq1->append($pod_seq2);
-
-Appends the given string or parse-tree or sequence object to the parse-tree
-of this interior sequence.
-
-=cut
-
-sub append {
- my $self = shift;
- $self->{'-ptree'}->append(@_);
- _set_child2parent_links($self, @_);
- return $self;
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_seq-E<gt>B<nested()>
-
- $outer_seq = $pod_seq->nested || print "not nested";
-
-If this interior sequence is nested inside of another interior
-sequence, then the outer/parent sequence that contains it is
-returned. Otherwise C<undef> is returned.
-
-=cut
-
-sub nested {
- my $self = shift;
- (@_ == 1) and $self->{'-parent_sequence'} = shift;
- return $self->{'-parent_sequence'} || undef;
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_seq-E<gt>B<raw_text()>
-
- my $seq_raw_text = $pod_seq->raw_text();
-
-This method will return the I<raw> text of the POD interior sequence,
-exactly as it appeared in the input.
-
-=cut
-
-sub raw_text {
- my $self = shift;
- my $text = $self->{'-name'} . $self->{'-ldelim'};
- for ( $self->{'-ptree'}->children ) {
- $text .= (ref $_) ? $_->raw_text : $_;
- }
- $text .= $self->{'-rdelim'};
- return $text;
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_seq-E<gt>B<left_delimiter()>
-
- my $ldelim = $pod_seq->left_delimiter();
-
-The leftmost delimiter beginning the argument text to the interior
-sequence (should be "<").
-
-=cut
-
-sub left_delimiter {
- (@_ > 1) and $_[0]->{'-ldelim'} = $_[1];
- return $_[0]->{'-ldelim'};
-}
-
-## let ldelim() be an alias for left_delimiter()
-*ldelim = \&left_delimiter;
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_seq-E<gt>B<right_delimiter()>
-
-The rightmost delimiter beginning the argument text to the interior
-sequence (should be ">").
-
-=cut
-
-sub right_delimiter {
- (@_ > 1) and $_[0]->{'-rdelim'} = $_[1];
- return $_[0]->{'-rdelim'};
-}
-
-## let rdelim() be an alias for right_delimiter()
-*rdelim = \&right_delimiter;
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_seq-E<gt>B<parse_tree()>
-
- my $ptree = $pod_parser->parse_text($paragraph_text);
- $pod_seq->parse_tree( $ptree );
- $ptree = $pod_seq->parse_tree();
-
-This method will get/set the corresponding parse-tree of the interior
-sequence's text.
-
-=cut
-
-sub parse_tree {
- (@_ > 1) and $_[0]->{'-ptree'} = $_[1];
- return $_[0]->{'-ptree'};
-}
-
-## let ptree() be an alias for parse_tree()
-*ptree = \&parse_tree;
-
-##---------------------------------------------------------------------------
-
-=head2 $pod_seq-E<gt>B<file_line()>
-
- my ($filename, $line_number) = $pod_seq->file_line();
- my $position = $pod_seq->file_line();
-
-Returns the current filename and line number for the interior sequence
-object. If called in a list context, it returns a list of two
-elements: first the filename, then the line number. If called in
-a scalar context, it returns a string containing the filename, followed
-by a colon (':'), followed by the line number.
-
-=cut
-
-sub file_line {
- my @loc = ($_[0]->{'-file'} || '<unknown-file>',
- $_[0]->{'-line'} || 0);
- return (wantarray) ? @loc : join(':', @loc);
-}
-
-##---------------------------------------------------------------------------
-
-=head2 Pod::InteriorSequence::B<DESTROY()>
-
-This method performs any necessary cleanup for the interior-sequence.
-If you override this method then it is B<imperative> that you invoke
-the parent method from within your own method, otherwise
-I<interior-sequence storage will not be reclaimed upon destruction!>
-
-=cut
-
-sub DESTROY {
- ## We need to get rid of all child->parent pointers throughout the
- ## tree so their reference counts will go to zero and they can be
- ## garbage-collected
- _unset_child2parent_links(@_);
-}
-
-##---------------------------------------------------------------------------
-
-#############################################################################
-
-package Pod::ParseTree;
-
-##---------------------------------------------------------------------------
-
-=head1 B<Pod::ParseTree>
-
-This object corresponds to a tree of parsed POD text. As POD text is
-scanned from left to right, it is parsed into an ordered list of
-text-strings and B<Pod::InteriorSequence> objects (in order of
-appearance). A B<Pod::ParseTree> object corresponds to this list of
-strings and sequences. Each interior sequence in the parse-tree may
-itself contain a parse-tree (since interior sequences may be nested).
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=head2 Pod::ParseTree-E<gt>B<new()>
-
- my $ptree1 = Pod::ParseTree->new;
- my $ptree2 = new Pod::ParseTree;
- my $ptree4 = Pod::ParseTree->new($array_ref);
- my $ptree3 = new Pod::ParseTree($array_ref);
-
-This is a class method that constructs a C<Pod::Parse_tree> object and
-returns a reference to the new parse-tree. If a single-argument is given,
-it must be a reference to an array, and is used to initialize the root
-(top) of the parse tree.
-
-=cut
-
-sub new {
- ## Determine if we were called via an object-ref or a classname
- my $this = shift;
- my $class = ref($this) || $this;
-
- my $self = (@_ == 1 and ref $_[0]) ? $_[0] : [];
-
- ## Bless ourselves into the desired class and perform any initialization
- bless $self, $class;
- return $self;
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $ptree-E<gt>B<top()>
-
- my $top_node = $ptree->top();
- $ptree->top( $top_node );
- $ptree->top( @children );
-
-This method gets/sets the top node of the parse-tree. If no arguments are
-given, it returns the topmost node in the tree (the root), which is also
-a B<Pod::ParseTree>. If it is given a single argument that is a reference,
-then the reference is assumed to a parse-tree and becomes the new top node.
-Otherwise, if arguments are given, they are treated as the new list of
-children for the top node.
-
-=cut
-
-sub top {
- my $self = shift;
- if (@_ > 0) {
- @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
- }
- return $self;
-}
-
-## let parse_tree() & ptree() be aliases for the 'top' method
-*parse_tree = *ptree = \⊤
-
-##---------------------------------------------------------------------------
-
-=head2 $ptree-E<gt>B<children()>
-
-This method gets/sets the children of the top node in the parse-tree.
-If no arguments are given, it returns the list (array) of children
-(each of which should be either a string or a B<Pod::InteriorSequence>.
-Otherwise, if arguments are given, they are treated as the new list of
-children for the top node.
-
-=cut
-
-sub children {
- my $self = shift;
- if (@_ > 0) {
- @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_;
- }
- return @{ $self };
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $ptree-E<gt>B<prepend()>
-
-This method prepends the given text or parse-tree to the current parse-tree.
-If the first item on the parse-tree is text and the argument is also text,
-then the text is prepended to the first item (not added as a separate string).
-Otherwise the argument is added as a new string or parse-tree I<before>
-the current one.
-
-=cut
-
-use vars qw(@ptree); ## an alias used for performance reasons
-
-sub prepend {
- my $self = shift;
- local *ptree = $self;
- for (@_) {
- next unless length;
- if (@ptree && !(ref $ptree[0]) && !(ref $_)) {
- $ptree[0] = $_ . $ptree[0];
- }
- else {
- unshift @ptree, $_;
- }
- }
-}
-
-##---------------------------------------------------------------------------
-
-=head2 $ptree-E<gt>B<append()>
-
-This method appends the given text or parse-tree to the current parse-tree.
-If the last item on the parse-tree is text and the argument is also text,
-then the text is appended to the last item (not added as a separate string).
-Otherwise the argument is added as a new string or parse-tree I<after>
-the current one.
-
-=cut
-
-sub append {
- my $self = shift;
- local *ptree = $self;
- my $can_append = @ptree && !(ref $ptree[-1]);
- for (@_) {
- if (ref) {
- push @ptree, $_;
- }
- elsif(!length) {
- next;
- }
- elsif ($can_append) {
- $ptree[-1] .= $_;
- }
- else {
- push @ptree, $_;
- }
- }
-}
-
-=head2 $ptree-E<gt>B<raw_text()>
-
- my $ptree_raw_text = $ptree->raw_text();
-
-This method will return the I<raw> text of the POD parse-tree
-exactly as it appeared in the input.
-
-=cut
-
-sub raw_text {
- my $self = shift;
- my $text = '';
- for ( @$self ) {
- $text .= (ref $_) ? $_->raw_text : $_;
- }
- return $text;
-}
-
-##---------------------------------------------------------------------------
-
-## Private routines to set/unset child->parent links
-
-sub _unset_child2parent_links {
- my $self = shift;
- local *ptree = $self;
- for (@ptree) {
- next unless (defined and length and ref and ref ne 'SCALAR');
- $_->_unset_child2parent_links()
- if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
- }
-}
-
-sub _set_child2parent_links {
- ## nothing to do, Pod::ParseTrees cant have parent pointers
-}
-
-=head2 Pod::ParseTree::B<DESTROY()>
-
-This method performs any necessary cleanup for the parse-tree.
-If you override this method then it is B<imperative>
-that you invoke the parent method from within your own method,
-otherwise I<parse-tree storage will not be reclaimed upon destruction!>
-
-=cut
-
-sub DESTROY {
- ## We need to get rid of all child->parent pointers throughout the
- ## tree so their reference counts will go to zero and they can be
- ## garbage-collected
- _unset_child2parent_links(@_);
-}
-
-#############################################################################
-
-=head1 SEE ALSO
-
-See L<Pod::Parser>, L<Pod::Select>
-
-=head1 AUTHOR
-
-Please report bugs using L<http://rt.cpan.org>.
-
-Brad Appleton E<lt>bradapp at enteract.comE<gt>
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/Pod/LaTeX.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/LaTeX.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/LaTeX.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1876 +0,0 @@
-package Pod::LaTeX;
-
-=head1 NAME
-
-Pod::LaTeX - Convert Pod data to formatted Latex
-
-=head1 SYNOPSIS
-
- use Pod::LaTeX;
- my $parser = Pod::LaTeX->new ( );
-
- $parser->parse_from_filehandle;
-
- $parser->parse_from_file ('file.pod', 'file.tex');
-
-=head1 DESCRIPTION
-
-C<Pod::LaTeX> is a module to convert documentation in the Pod format
-into Latex. The L<B<pod2latex>|pod2latex> X<pod2latex> command uses
-this module for translation.
-
-C<Pod::LaTeX> is a derived class from L<Pod::Select|Pod::Select>.
-
-=cut
-
-
-use strict;
-require Pod::ParseUtils;
-use base qw/ Pod::Select /;
-
-# use Data::Dumper; # for debugging
-use Carp;
-
-use vars qw/ $VERSION %HTML_Escapes @LatexSections /;
-
-$VERSION = '0.58';
-
-# Definitions of =headN -> latex mapping
- at LatexSections = (qw/
- chapter
- section
- subsection
- subsubsection
- paragraph
- subparagraph
- /);
-
-# Standard escape sequences converted to Latex.
-# The Unicode name of each character is given in the comments.
-# Complete LaTeX set added by Peter Acklam.
-
-%HTML_Escapes = (
- 'sol' => '\textfractionsolidus{}', # xxx - or should it be just '/'
- 'verbar' => '|',
-
- # The stuff below is based on the information available at
- # http://www.w3.org/TR/html401/sgml/entities.html
-
- # All characters in the range 0xA0-0xFF of the ISO 8859-1 character set.
- # Several of these characters require the `textcomp' LaTeX package.
- 'nbsp' => q|~|, # 0xA0 - no-break space = non-breaking space
- 'iexcl' => q|\textexclamdown{}|, # 0xA1 - inverted exclamation mark
- 'cent' => q|\textcent{}|, # 0xA2 - cent sign
- 'pound' => q|\textsterling{}|, # 0xA3 - pound sign
- 'curren' => q|\textcurrency{}|, # 0xA4 - currency sign
- 'yen' => q|\textyen{}|, # 0xA5 - yen sign = yuan sign
- 'brvbar' => q|\textbrokenbar{}|, # 0xA6 - broken bar = broken vertical bar
- 'sect' => q|\textsection{}|, # 0xA7 - section sign
- 'uml' => q|\textasciidieresis{}|, # 0xA8 - diaeresis = spacing diaeresis
- 'copy' => q|\textcopyright{}|, # 0xA9 - copyright sign
- 'ordf' => q|\textordfeminine{}|, # 0xAA - feminine ordinal indicator
- 'laquo' => q|\guillemotleft{}|, # 0xAB - left-pointing double angle quotation mark = left pointing guillemet
- 'not' => q|\textlnot{}|, # 0xAC - not sign
- 'shy' => q|\-|, # 0xAD - soft hyphen = discretionary hyphen
- 'reg' => q|\textregistered{}|, # 0xAE - registered sign = registered trade mark sign
- 'macr' => q|\textasciimacron{}|, # 0xAF - macron = spacing macron = overline = APL overbar
- 'deg' => q|\textdegree{}|, # 0xB0 - degree sign
- 'plusmn' => q|\textpm{}|, # 0xB1 - plus-minus sign = plus-or-minus sign
- 'sup2' => q|\texttwosuperior{}|, # 0xB2 - superscript two = superscript digit two = squared
- 'sup3' => q|\textthreesuperior{}|, # 0xB3 - superscript three = superscript digit three = cubed
- 'acute' => q|\textasciiacute{}|, # 0xB4 - acute accent = spacing acute
- 'micro' => q|\textmu{}|, # 0xB5 - micro sign
- 'para' => q|\textparagraph{}|, # 0xB6 - pilcrow sign = paragraph sign
- 'middot' => q|\textperiodcentered{}|, # 0xB7 - middle dot = Georgian comma = Greek middle dot
- 'cedil' => q|\c{}|, # 0xB8 - cedilla = spacing cedilla
- 'sup1' => q|\textonesuperior{}|, # 0xB9 - superscript one = superscript digit one
- 'ordm' => q|\textordmasculine{}|, # 0xBA - masculine ordinal indicator
- 'raquo' => q|\guillemotright{}|, # 0xBB - right-pointing double angle quotation mark = right pointing guillemet
- 'frac14' => q|\textonequarter{}|, # 0xBC - vulgar fraction one quarter = fraction one quarter
- 'frac12' => q|\textonehalf{}|, # 0xBD - vulgar fraction one half = fraction one half
- 'frac34' => q|\textthreequarters{}|, # 0xBE - vulgar fraction three quarters = fraction three quarters
- 'iquest' => q|\textquestiondown{}|, # 0xBF - inverted question mark = turned question mark
- 'Agrave' => q|\`A|, # 0xC0 - latin capital letter A with grave = latin capital letter A grave
- 'Aacute' => q|\'A|, # 0xC1 - latin capital letter A with acute
- 'Acirc' => q|\^A|, # 0xC2 - latin capital letter A with circumflex
- 'Atilde' => q|\~A|, # 0xC3 - latin capital letter A with tilde
- 'Auml' => q|\"A|, # 0xC4 - latin capital letter A with diaeresis
- 'Aring' => q|\AA{}|, # 0xC5 - latin capital letter A with ring above = latin capital letter A ring
- 'AElig' => q|\AE{}|, # 0xC6 - latin capital letter AE = latin capital ligature AE
- 'Ccedil' => q|\c{C}|, # 0xC7 - latin capital letter C with cedilla
- 'Egrave' => q|\`E|, # 0xC8 - latin capital letter E with grave
- 'Eacute' => q|\'E|, # 0xC9 - latin capital letter E with acute
- 'Ecirc' => q|\^E|, # 0xCA - latin capital letter E with circumflex
- 'Euml' => q|\"E|, # 0xCB - latin capital letter E with diaeresis
- 'Igrave' => q|\`I|, # 0xCC - latin capital letter I with grave
- 'Iacute' => q|\'I|, # 0xCD - latin capital letter I with acute
- 'Icirc' => q|\^I|, # 0xCE - latin capital letter I with circumflex
- 'Iuml' => q|\"I|, # 0xCF - latin capital letter I with diaeresis
- 'ETH' => q|\DH{}|, # 0xD0 - latin capital letter ETH
- 'Ntilde' => q|\~N|, # 0xD1 - latin capital letter N with tilde
- 'Ograve' => q|\`O|, # 0xD2 - latin capital letter O with grave
- 'Oacute' => q|\'O|, # 0xD3 - latin capital letter O with acute
- 'Ocirc' => q|\^O|, # 0xD4 - latin capital letter O with circumflex
- 'Otilde' => q|\~O|, # 0xD5 - latin capital letter O with tilde
- 'Ouml' => q|\"O|, # 0xD6 - latin capital letter O with diaeresis
- 'times' => q|\texttimes{}|, # 0xD7 - multiplication sign
- 'Oslash' => q|\O{}|, # 0xD8 - latin capital letter O with stroke = latin capital letter O slash
- 'Ugrave' => q|\`U|, # 0xD9 - latin capital letter U with grave
- 'Uacute' => q|\'U|, # 0xDA - latin capital letter U with acute
- 'Ucirc' => q|\^U|, # 0xDB - latin capital letter U with circumflex
- 'Uuml' => q|\"U|, # 0xDC - latin capital letter U with diaeresis
- 'Yacute' => q|\'Y|, # 0xDD - latin capital letter Y with acute
- 'THORN' => q|\TH{}|, # 0xDE - latin capital letter THORN
- 'szlig' => q|\ss{}|, # 0xDF - latin small letter sharp s = ess-zed
- 'agrave' => q|\`a|, # 0xE0 - latin small letter a with grave = latin small letter a grave
- 'aacute' => q|\'a|, # 0xE1 - latin small letter a with acute
- 'acirc' => q|\^a|, # 0xE2 - latin small letter a with circumflex
- 'atilde' => q|\~a|, # 0xE3 - latin small letter a with tilde
- 'auml' => q|\"a|, # 0xE4 - latin small letter a with diaeresis
- 'aring' => q|\aa{}|, # 0xE5 - latin small letter a with ring above = latin small letter a ring
- 'aelig' => q|\ae{}|, # 0xE6 - latin small letter ae = latin small ligature ae
- 'ccedil' => q|\c{c}|, # 0xE7 - latin small letter c with cedilla
- 'egrave' => q|\`e|, # 0xE8 - latin small letter e with grave
- 'eacute' => q|\'e|, # 0xE9 - latin small letter e with acute
- 'ecirc' => q|\^e|, # 0xEA - latin small letter e with circumflex
- 'euml' => q|\"e|, # 0xEB - latin small letter e with diaeresis
- 'igrave' => q|\`i|, # 0xEC - latin small letter i with grave
- 'iacute' => q|\'i|, # 0xED - latin small letter i with acute
- 'icirc' => q|\^i|, # 0xEE - latin small letter i with circumflex
- 'iuml' => q|\"i|, # 0xEF - latin small letter i with diaeresis
- 'eth' => q|\dh{}|, # 0xF0 - latin small letter eth
- 'ntilde' => q|\~n|, # 0xF1 - latin small letter n with tilde
- 'ograve' => q|\`o|, # 0xF2 - latin small letter o with grave
- 'oacute' => q|\'o|, # 0xF3 - latin small letter o with acute
- 'ocirc' => q|\^o|, # 0xF4 - latin small letter o with circumflex
- 'otilde' => q|\~o|, # 0xF5 - latin small letter o with tilde
- 'ouml' => q|\"o|, # 0xF6 - latin small letter o with diaeresis
- 'divide' => q|\textdiv{}|, # 0xF7 - division sign
- 'oslash' => q|\o{}|, # 0xF8 - latin small letter o with stroke, = latin small letter o slash
- 'ugrave' => q|\`u|, # 0xF9 - latin small letter u with grave
- 'uacute' => q|\'u|, # 0xFA - latin small letter u with acute
- 'ucirc' => q|\^u|, # 0xFB - latin small letter u with circumflex
- 'uuml' => q|\"u|, # 0xFC - latin small letter u with diaeresis
- 'yacute' => q|\'y|, # 0xFD - latin small letter y with acute
- 'thorn' => q|\th{}|, # 0xFE - latin small letter thorn
- 'yuml' => q|\"y|, # 0xFF - latin small letter y with diaeresis
-
- # Latin Extended-B
- 'fnof' => q|\textflorin{}|, # latin small f with hook = function = florin
-
- # Greek
- 'Alpha' => q|$\mathrm{A}$|, # greek capital letter alpha
- 'Beta' => q|$\mathrm{B}$|, # greek capital letter beta
- 'Gamma' => q|$\Gamma$|, # greek capital letter gamma
- 'Delta' => q|$\Delta$|, # greek capital letter delta
- 'Epsilon' => q|$\mathrm{E}$|, # greek capital letter epsilon
- 'Zeta' => q|$\mathrm{Z}$|, # greek capital letter zeta
- 'Eta' => q|$\mathrm{H}$|, # greek capital letter eta
- 'Theta' => q|$\Theta$|, # greek capital letter theta
- 'Iota' => q|$\mathrm{I}$|, # greek capital letter iota
- 'Kappa' => q|$\mathrm{K}$|, # greek capital letter kappa
- 'Lambda' => q|$\Lambda$|, # greek capital letter lambda
- 'Mu' => q|$\mathrm{M}$|, # greek capital letter mu
- 'Nu' => q|$\mathrm{N}$|, # greek capital letter nu
- 'Xi' => q|$\Xi$|, # greek capital letter xi
- 'Omicron' => q|$\mathrm{O}$|, # greek capital letter omicron
- 'Pi' => q|$\Pi$|, # greek capital letter pi
- 'Rho' => q|$\mathrm{R}$|, # greek capital letter rho
- 'Sigma' => q|$\Sigma$|, # greek capital letter sigma
- 'Tau' => q|$\mathrm{T}$|, # greek capital letter tau
- 'Upsilon' => q|$\Upsilon$|, # greek capital letter upsilon
- 'Phi' => q|$\Phi$|, # greek capital letter phi
- 'Chi' => q|$\mathrm{X}$|, # greek capital letter chi
- 'Psi' => q|$\Psi$|, # greek capital letter psi
- 'Omega' => q|$\Omega$|, # greek capital letter omega
-
- 'alpha' => q|$\alpha$|, # greek small letter alpha
- 'beta' => q|$\beta$|, # greek small letter beta
- 'gamma' => q|$\gamma$|, # greek small letter gamma
- 'delta' => q|$\delta$|, # greek small letter delta
- 'epsilon' => q|$\epsilon$|, # greek small letter epsilon
- 'zeta' => q|$\zeta$|, # greek small letter zeta
- 'eta' => q|$\eta$|, # greek small letter eta
- 'theta' => q|$\theta$|, # greek small letter theta
- 'iota' => q|$\iota$|, # greek small letter iota
- 'kappa' => q|$\kappa$|, # greek small letter kappa
- 'lambda' => q|$\lambda$|, # greek small letter lambda
- 'mu' => q|$\mu$|, # greek small letter mu
- 'nu' => q|$\nu$|, # greek small letter nu
- 'xi' => q|$\xi$|, # greek small letter xi
- 'omicron' => q|$o$|, # greek small letter omicron
- 'pi' => q|$\pi$|, # greek small letter pi
- 'rho' => q|$\rho$|, # greek small letter rho
-# 'sigmaf' => q||, # greek small letter final sigma
- 'sigma' => q|$\sigma$|, # greek small letter sigma
- 'tau' => q|$\tau$|, # greek small letter tau
- 'upsilon' => q|$\upsilon$|, # greek small letter upsilon
- 'phi' => q|$\phi$|, # greek small letter phi
- 'chi' => q|$\chi$|, # greek small letter chi
- 'psi' => q|$\psi$|, # greek small letter psi
- 'omega' => q|$\omega$|, # greek small letter omega
-# 'thetasym' => q||, # greek small letter theta symbol
-# 'upsih' => q||, # greek upsilon with hook symbol
-# 'piv' => q||, # greek pi symbol
-
- # General Punctuation
- 'bull' => q|\textbullet{}|, # bullet = black small circle
- # bullet is NOT the same as bullet operator
- 'hellip' => q|\textellipsis{}|, # horizontal ellipsis = three dot leader
- 'prime' => q|\textquotesingle{}|, # prime = minutes = feet
- 'Prime' => q|\textquotedbl{}|, # double prime = seconds = inches
- 'oline' => q|\textasciimacron{}|, # overline = spacing overscore
- 'frasl' => q|\textfractionsolidus{}|, # fraction slash
-
- # Letterlike Symbols
- 'weierp' => q|$\wp$|, # script capital P = power set = Weierstrass p
- 'image' => q|$\Re$|, # blackletter capital I = imaginary part
- 'real' => q|$\Im$|, # blackletter capital R = real part symbol
- 'trade' => q|\texttrademark{}|, # trade mark sign
-# 'alefsym' => q||, # alef symbol = first transfinite cardinal
- # alef symbol is NOT the same as hebrew letter alef, although the same
- # glyph could be used to depict both characters
-
- # Arrows
- 'larr' => q|\textleftarrow{}|, # leftwards arrow
- 'uarr' => q|\textuparrow{}|, # upwards arrow
- 'rarr' => q|\textrightarrow{}|, # rightwards arrow
- 'darr' => q|\textdownarrow{}|, # downwards arrow
- 'harr' => q|$\leftrightarrow$|, # left right arrow
-# 'crarr' => q||, # downwards arrow with corner leftwards = carriage return
- 'lArr' => q|$\Leftarrow$|, # leftwards double arrow
- # ISO 10646 does not say that lArr is the same as the 'is implied by'
- # arrow but also does not have any other character for that function. So
- # lArr can be used for 'is implied by' as ISOtech suggests
- 'uArr' => q|$\Uparrow$|, # upwards double arrow
- 'rArr' => q|$\Rightarrow$|, # rightwards double arrow
- # ISO 10646 does not say this is the 'implies' character but does not
- # have another character with this function so ? rArr can be used for
- # 'implies' as ISOtech suggests
- 'dArr' => q|$\Downarrow$|, # downwards double arrow
- 'hArr' => q|$\Leftrightarrow$|, # left right double arrow
-
- # Mathematical Operators.
- # Some of these require the `amssymb' package.
- 'forall' => q|$\forall$|, # for all
- 'part' => q|$\partial$|, # partial differential
- 'exist' => q|$\exists$|, # there exists
- 'empty' => q|$\emptyset$|, # empty set = null set = diameter
- 'nabla' => q|$\nabla$|, # nabla = backward difference
- 'isin' => q|$\in$|, # element of
- 'notin' => q|$\notin$|, # not an element of
- 'ni' => q|$\ni$|, # contains as member
- 'prod' => q|$\prod$|, # n-ary product = product sign
- # prod is NOT the same character as 'greek capital letter pi' though the
- # same glyph might be used for both
- 'sum' => q|$\sum$|, # n-ary sumation
- # sum is NOT the same character as 'greek capital letter sigma' though
- # the same glyph might be used for both
- 'minus' => q|$-$|, # minus sign
- 'lowast' => q|$\ast$|, # asterisk operator
- 'radic' => q|$\surd$|, # square root = radical sign
- 'prop' => q|$\propto$|, # proportional to
- 'infin' => q|$\infty$|, # infinity
- 'ang' => q|$\angle$|, # angle
- 'and' => q|$\wedge$|, # logical and = wedge
- 'or' => q|$\vee$|, # logical or = vee
- 'cap' => q|$\cap$|, # intersection = cap
- 'cup' => q|$\cup$|, # union = cup
- 'int' => q|$\int$|, # integral
- 'there4' => q|$\therefore$|, # therefore
- 'sim' => q|$\sim$|, # tilde operator = varies with = similar to
- # tilde operator is NOT the same character as the tilde
- 'cong' => q|$\cong$|, # approximately equal to
- 'asymp' => q|$\asymp$|, # almost equal to = asymptotic to
- 'ne' => q|$\neq$|, # not equal to
- 'equiv' => q|$\equiv$|, # identical to
- 'le' => q|$\leq$|, # less-than or equal to
- 'ge' => q|$\geq$|, # greater-than or equal to
- 'sub' => q|$\subset$|, # subset of
- 'sup' => q|$\supset$|, # superset of
- # note that nsup, 'not a superset of' is not covered by the Symbol font
- # encoding and is not included.
- 'nsub' => q|$\not\subset$|, # not a subset of
- 'sube' => q|$\subseteq$|, # subset of or equal to
- 'supe' => q|$\supseteq$|, # superset of or equal to
- 'oplus' => q|$\oplus$|, # circled plus = direct sum
- 'otimes' => q|$\otimes$|, # circled times = vector product
- 'perp' => q|$\perp$|, # up tack = orthogonal to = perpendicular
- 'sdot' => q|$\cdot$|, # dot operator
- # dot operator is NOT the same character as middle dot
-
- # Miscellaneous Technical
- 'lceil' => q|$\lceil$|, # left ceiling = apl upstile
- 'rceil' => q|$\rceil$|, # right ceiling
- 'lfloor' => q|$\lfloor$|, # left floor = apl downstile
- 'rfloor' => q|$\rfloor$|, # right floor
- 'lang' => q|$\langle$|, # left-pointing angle bracket = bra
- # lang is NOT the same character as 'less than' or 'single left-pointing
- # angle quotation mark'
- 'rang' => q|$\rangle$|, # right-pointing angle bracket = ket
- # rang is NOT the same character as 'greater than' or 'single
- # right-pointing angle quotation mark'
-
- # Geometric Shapes
- 'loz' => q|$\lozenge$|, # lozenge
-
- # Miscellaneous Symbols
- 'spades' => q|$\spadesuit$|, # black spade suit
- 'clubs' => q|$\clubsuit$|, # black club suit = shamrock
- 'hearts' => q|$\heartsuit$|, # black heart suit = valentine
- 'diams' => q|$\diamondsuit$|, # black diamond suit
-
- # C0 Controls and Basic Latin
- 'quot' => q|"|, # quotation mark = APL quote ["]
- 'amp' => q|\&|, # ampersand
- 'lt' => q|<|, # less-than sign
- 'gt' => q|>|, # greater-than sign
- 'OElig' => q|\OE{}|, # latin capital ligature OE
- 'oelig' => q|\oe{}|, # latin small ligature oe
- 'Scaron' => q|\v{S}|, # latin capital letter S with caron
- 'scaron' => q|\v{s}|, # latin small letter s with caron
- 'Yuml' => q|\"Y|, # latin capital letter Y with diaeresis
- 'circ' => q|\textasciicircum{}|, # modifier letter circumflex accent
- 'tilde' => q|\textasciitilde{}|, # small tilde
- 'ensp' => q|\phantom{n}|, # en space
- 'emsp' => q|\hspace{1em}|, # em space
- 'thinsp' => q|\,|, # thin space
- 'zwnj' => q|{}|, # zero width non-joiner
-# 'zwj' => q||, # zero width joiner
-# 'lrm' => q||, # left-to-right mark
-# 'rlm' => q||, # right-to-left mark
- 'ndash' => q|--|, # en dash
- 'mdash' => q|---|, # em dash
- 'lsquo' => q|\textquoteleft{}|, # left single quotation mark
- 'rsquo' => q|\textquoteright{}|, # right single quotation mark
- 'sbquo' => q|\quotesinglbase{}|, # single low-9 quotation mark
- 'ldquo' => q|\textquotedblleft{}|, # left double quotation mark
- 'rdquo' => q|\textquotedblright{}|, # right double quotation mark
- 'bdquo' => q|\quotedblbase{}|, # double low-9 quotation mark
- 'dagger' => q|\textdagger{}|, # dagger
- 'Dagger' => q|\textdaggerdbl{}|, # double dagger
- 'permil' => q|\textperthousand{}|, # per mille sign
- 'lsaquo' => q|\guilsinglleft{}|, # single left-pointing angle quotation mark
- 'rsaquo' => q|\guilsinglright{}|, # single right-pointing angle quotation mark
- 'euro' => q|\texteuro{}|, # euro sign
-);
-
-=head1 OBJECT METHODS
-
-The following methods are provided in this module. Methods inherited
-from C<Pod::Select> are not described in the public interface.
-
-=over 4
-
-=begin __PRIVATE__
-
-=item C<initialize>
-
-Initialise the object. This method is subclassed from C<Pod::Parser>.
-The base class method is invoked. This method defines the default
-behaviour of the object unless overridden by supplying arguments to
-the constructor.
-
-Internal settings are defaulted as well as the public instance data.
-Internal hash values are accessed directly (rather than through
-a method) and start with an underscore.
-
-This method should not be invoked by the user directly.
-
-=end __PRIVATE__
-
-=cut
-
-
-
-# - An array for nested lists
-
-# Arguments have already been read by this point
-
-sub initialize {
- my $self = shift;
-
- # print Dumper($self);
-
- # Internals
- $self->{_Lists} = []; # For nested lists
- $self->{_suppress_all_para} = 0; # For =begin blocks
- $self->{_dont_modify_any_para}=0; # For =begin blocks
- $self->{_CURRENT_HEAD1} = ''; # Name of current HEAD1 section
-
- # Options - only initialise if not already set
-
- # Cause the '=head1 NAME' field to be treated specially
- # The contents of the NAME paragraph will be converted
- # to a section title. All subsequent =head1 will be converted
- # to =head2 and down. Will not affect =head1's prior to NAME
- # Assumes: 'Module - purpose' format
- # Also creates a purpose field
- # The name is used for Labeling of the subsequent subsections
- $self->{ReplaceNAMEwithSection} = 0
- unless exists $self->{ReplaceNAMEwithSection};
- $self->{AddPreamble} = 1 # make full latex document
- unless exists $self->{AddPreamble};
- $self->{StartWithNewPage} = 0 # Start new page for pod section
- unless exists $self->{StartWithNewPage};
- $self->{TableOfContents} = 0 # Add table of contents
- unless exists $self->{TableOfContents}; # only relevent if AddPreamble=1
- $self->{AddPostamble} = 1 # Add closing latex code at end
- unless exists $self->{AddPostamble}; # effectively end{document} and index
- $self->{MakeIndex} = 1 # Add index (only relevant AddPostamble
- unless exists $self->{MakeIndex}; # and AddPreamble)
-
- $self->{UniqueLabels} = 1 # Use label unique for each pod
- unless exists $self->{UniqueLabels}; # either based on the filename
- # or supplied
-
- # Control the level of =head1. default is \section
- #
- $self->{Head1Level} = 1 # Offset in latex sections
- unless exists $self->{Head1Level}; # 0 is chapter, 2 is subsection
-
- # Control at which level numbering of sections is turned off
- # ie subsection becomes subsection*
- # The numbering is relative to the latex sectioning commands
- # and is independent of Pod heading level
- # default is to number \section but not \subsection
- $self->{LevelNoNum} = 2
- unless exists $self->{LevelNoNum};
-
- # Label to be used as prefix to all internal section names
- # If not defined will attempt to derive it from the filename
- # This can not happen when running parse_from_filehandle though
- # hence the ability to set the label externally
- # The label could then be Pod::Parser_DESCRIPTION or somesuch
-
- $self->{Label} = undef # label to be used as prefix
- unless exists $self->{Label}; # to all internal section names
-
- # These allow the caller to add arbritrary latex code to
- # start and end of document. AddPreamble and AddPostamble are ignored
- # if these are set.
- # Also MakeIndex and TableOfContents are also ignored.
- $self->{UserPreamble} = undef # User supplied start (AddPreamble =1)
- unless exists $self->{Label};
- $self->{UserPostamble} = undef # Use supplied end (AddPostamble=1)
- unless exists $self->{Label};
-
- # Run base initialize
- $self->SUPER::initialize;
-
-}
-
-=back
-
-=head2 Data Accessors
-
-The following methods are provided for accessing instance data. These
-methods should be used for accessing configuration parameters rather
-than assuming the object is a hash.
-
-Default values can be supplied by using these names as keys to a hash
-of arguments when using the C<new()> constructor.
-
-=over 4
-
-=item B<AddPreamble>
-
-Logical to control whether a C<latex> preamble is to be written.
-If true, a valid C<latex> preamble is written before the pod data is written.
-This is similar to:
-
- \documentclass{article}
- \usepackage[T1]{fontenc}
- \usepackage{textcomp}
- \begin{document}
-
-but will be more complicated if table of contents and indexing are required.
-Can be used to set or retrieve the current value.
-
- $add = $parser->AddPreamble();
- $parser->AddPreamble(1);
-
-If used in conjunction with C<AddPostamble> a full latex document will
-be written that could be immediately processed by C<latex>.
-
-For some pod escapes it may be necessary to include the amsmath
-package. This is not yet added to the preamble automaatically.
-
-=cut
-
-sub AddPreamble {
- my $self = shift;
- if (@_) {
- $self->{AddPreamble} = shift;
- }
- return $self->{AddPreamble};
-}
-
-=item B<AddPostamble>
-
-Logical to control whether a standard C<latex> ending is written to the output
-file after the document has been processed.
-In its simplest form this is simply:
-
- \end{document}
-
-but can be more complicated if a index is required.
-Can be used to set or retrieve the current value.
-
- $add = $parser->AddPostamble();
- $parser->AddPostamble(1);
-
-If used in conjunction with C<AddPreaamble> a full latex document will
-be written that could be immediately processed by C<latex>.
-
-=cut
-
-sub AddPostamble {
- my $self = shift;
- if (@_) {
- $self->{AddPostamble} = shift;
- }
- return $self->{AddPostamble};
-}
-
-=item B<Head1Level>
-
-The C<latex> sectioning level that should be used to correspond to
-a pod C<=head1> directive. This can be used, for example, to turn
-a C<=head1> into a C<latex> C<subsection>. This should hold a number
-corresponding to the required position in an array containing the
-following elements:
-
- [0] chapter
- [1] section
- [2] subsection
- [3] subsubsection
- [4] paragraph
- [5] subparagraph
-
-Can be used to set or retrieve the current value:
-
- $parser->Head1Level(2);
- $sect = $parser->Head1Level;
-
-Setting this number too high can result in sections that may not be reproducible
-in the expected way. For example, setting this to 4 would imply that C<=head3>
-do not have a corresponding C<latex> section (C<=head1> would correspond to
-a C<paragraph>).
-
-A check is made to ensure that the supplied value is an integer in the
-range 0 to 5.
-
-Default is for a value of 1 (i.e. a C<section>).
-
-=cut
-
-sub Head1Level {
- my $self = shift;
- if (@_) {
- my $arg = shift;
- if ($arg =~ /^\d$/ && $arg <= $#LatexSections) {
- $self->{Head1Level} = $arg;
- } else {
- carp "Head1Level supplied ($arg) must be integer in range 0 to ".$#LatexSections . "- Ignoring\n";
- }
- }
- return $self->{Head1Level};
-}
-
-=item B<Label>
-
-This is the label that is prefixed to all C<latex> label and index
-entries to make them unique. In general, pods have similarly titled
-sections (NAME, DESCRIPTION etc) and a C<latex> label will be multiply
-defined if more than one pod document is to be included in a single
-C<latex> file. To overcome this, this label is prefixed to a label
-whenever a label is required (joined with an underscore) or to an
-index entry (joined by an exclamation mark which is the normal index
-separator). For example, C<\label{text}> becomes C<\label{Label_text}>.
-
-Can be used to set or retrieve the current value:
-
- $label = $parser->Label;
- $parser->Label($label);
-
-This label is only used if C<UniqueLabels> is true.
-Its value is set automatically from the C<NAME> field
-if C<ReplaceNAMEwithSection> is true. If this is not the case
-it must be set manually before starting the parse.
-
-Default value is C<undef>.
-
-=cut
-
-sub Label {
- my $self = shift;
- if (@_) {
- $self->{Label} = shift;
- }
- return $self->{Label};
-}
-
-=item B<LevelNoNum>
-
-Control the point at which C<latex> section numbering is turned off.
-For example, this can be used to make sure that C<latex> sections
-are numbered but subsections are not.
-
-Can be used to set or retrieve the current value:
-
- $lev = $parser->LevelNoNum;
- $parser->LevelNoNum(2);
-
-The argument must be an integer between 0 and 5 and is the same as the
-number described in C<Head1Level> method description. The number has
-nothing to do with the pod heading number, only the C<latex> sectioning.
-
-Default is 2. (i.e. C<latex> subsections are written as C<subsection*>
-but sections are numbered).
-
-=cut
-
-sub LevelNoNum {
- my $self = shift;
- if (@_) {
- $self->{LevelNoNum} = shift;
- }
- return $self->{LevelNoNum};
-}
-
-=item B<MakeIndex>
-
-Controls whether C<latex> commands for creating an index are to be inserted
-into the preamble and postamble
-
- $makeindex = $parser->MakeIndex;
- $parser->MakeIndex(0);
-
-Irrelevant if both C<AddPreamble> and C<AddPostamble> are false (or equivalently,
-C<UserPreamble> and C<UserPostamble> are set).
-
-Default is for an index to be created.
-
-=cut
-
-sub MakeIndex {
- my $self = shift;
- if (@_) {
- $self->{MakeIndex} = shift;
- }
- return $self->{MakeIndex};
-}
-
-=item B<ReplaceNAMEwithSection>
-
-This controls whether the C<NAME> section in the pod is to be translated
-literally or converted to a slightly modified output where the section
-name is the pod name rather than "NAME".
-
-If true, the pod segment
-
- =head1 NAME
-
- pod::name - purpose
-
- =head1 SYNOPSIS
-
-is converted to the C<latex>
-
- \section{pod::name\label{pod_name}\index{pod::name}}
-
- Purpose
-
- \subsection*{SYNOPSIS\label{pod_name_SYNOPSIS}%
- \index{pod::name!SYNOPSIS}}
-
-(dependent on the value of C<Head1Level> and C<LevelNoNum>). Note that
-subsequent C<head1> directives translate to subsections rather than
-sections and that the labels and index now include the pod name (dependent
-on the value of C<UniqueLabels>).
-
-The C<Label> is set from the pod name regardless of any current value
-of C<Label>.
-
- $mod = $parser->ReplaceNAMEwithSection;
- $parser->ReplaceNAMEwithSection(0);
-
-Default is to translate the pod literally.
-
-=cut
-
-sub ReplaceNAMEwithSection {
- my $self = shift;
- if (@_) {
- $self->{ReplaceNAMEwithSection} = shift;
- }
- return $self->{ReplaceNAMEwithSection};
-}
-
-=item B<StartWithNewPage>
-
-If true, each pod translation will begin with a C<latex>
-C<\clearpage>.
-
- $parser->StartWithNewPage(1);
- $newpage = $parser->StartWithNewPage;
-
-Default is false.
-
-=cut
-
-sub StartWithNewPage {
- my $self = shift;
- if (@_) {
- $self->{StartWithNewPage} = shift;
- }
- return $self->{StartWithNewPage};
-}
-
-=item B<TableOfContents>
-
-If true, a table of contents will be created.
-Irrelevant if C<AddPreamble> is false or C<UserPreamble>
-is set.
-
- $toc = $parser->TableOfContents;
- $parser->TableOfContents(1);
-
-Default is false.
-
-=cut
-
-sub TableOfContents {
- my $self = shift;
- if (@_) {
- $self->{TableOfContents} = shift;
- }
- return $self->{TableOfContents};
-}
-
-=item B<UniqueLabels>
-
-If true, the translator will attempt to make sure that
-each C<latex> label or index entry will be uniquely identified
-by prefixing the contents of C<Label>. This allows
-multiple documents to be combined without clashing
-common labels such as C<DESCRIPTION> and C<SYNOPSIS>
-
- $parser->UniqueLabels(1);
- $unq = $parser->UniqueLabels;
-
-Default is true.
-
-=cut
-
-sub UniqueLabels {
- my $self = shift;
- if (@_) {
- $self->{UniqueLabels} = shift;
- }
- return $self->{UniqueLabels};
-}
-
-=item B<UserPreamble>
-
-User supplied C<latex> preamble. Added before the pod translation
-data.
-
-If set, the contents will be prepended to the output file before the translated
-data regardless of the value of C<AddPreamble>.
-C<MakeIndex> and C<TableOfContents> will also be ignored.
-
-=cut
-
-sub UserPreamble {
- my $self = shift;
- if (@_) {
- $self->{UserPreamble} = shift;
- }
- return $self->{UserPreamble};
-}
-
-=item B<UserPostamble>
-
-User supplied C<latex> postamble. Added after the pod translation
-data.
-
-If set, the contents will be prepended to the output file after the translated
-data regardless of the value of C<AddPostamble>.
-C<MakeIndex> will also be ignored.
-
-=cut
-
-sub UserPostamble {
- my $self = shift;
- if (@_) {
- $self->{UserPostamble} = shift;
- }
- return $self->{UserPostamble};
-}
-
-=begin __PRIVATE__
-
-=item B<Lists>
-
-Contains details of the currently active lists.
- The array contains C<Pod::List> objects. A new C<Pod::List>
-object is created each time a list is encountered and it is
-pushed onto this stack. When the list context ends, it
-is popped from the stack. The array will be empty if no
-lists are active.
-
-Returns array of list information in list context
-Returns array ref in scalar context
-
-=cut
-
-
-
-sub lists {
- my $self = shift;
- return @{ $self->{_Lists} } if wantarray();
- return $self->{_Lists};
-}
-
-=end __PRIVATE__
-
-=back
-
-=begin __PRIVATE__
-
-=head2 Subclassed methods
-
-The following methods override methods provided in the C<Pod::Select>
-base class. See C<Pod::Parser> and C<Pod::Select> for more information
-on what these methods require.
-
-=over 4
-
-=cut
-
-######### END ACCESSORS ###################
-
-# Opening pod
-
-=item B<begin_pod>
-
-Writes the C<latex> preamble if requested. Only writes something
-if AddPreamble is true. Writes a standard header unless a UserPreamble
-is defined.
-
-=cut
-
-sub begin_pod {
- my $self = shift;
-
- # Get the pod identification
- # This should really come from the '=head1 NAME' paragraph
-
- my $infile = $self->input_file;
- my $class = ref($self);
- my $date = gmtime(time);
-
- # Comment message to say where this came from
- my $comment = << "__TEX_COMMENT__";
-%% Latex generated from POD in document $infile
-%% Using the perl module $class
-%% Converted on $date
-__TEX_COMMENT__
-
- # Write the preamble
- # If the caller has supplied one then we just use that
-
- my $preamble = '';
-
- if ($self->AddPreamble) {
-
- if (defined $self->UserPreamble) {
-
- $preamble = $self->UserPreamble;
-
- # Add the description of where this came from
- $preamble .= "\n$comment\n%% Preamble supplied by user.\n\n";
-
- } else {
-
- # Write our own preamble
-
- # Code to initialise index making
- # Use an array so that we can prepend comment if required
- my @makeidx = (
- '\usepackage{makeidx}',
- '\makeindex',
- );
-
- unless ($self->MakeIndex) {
- foreach (@makeidx) {
- $_ = '%% ' . $_;
- }
- }
- my $makeindex = join("\n", at makeidx) . "\n";
-
- # Table of contents
- my $tableofcontents = '\tableofcontents';
-
- $tableofcontents = '%% ' . $tableofcontents
- unless $self->TableOfContents;
-
- # Roll our own
- $preamble = << "__TEX_HEADER__";
-\\documentclass{article}
-\\usepackage[T1]{fontenc}
-\\usepackage{textcomp}
-
-$comment
-
-$makeindex
-
-\\begin{document}
-
-$tableofcontents
-
-__TEX_HEADER__
-
- }
- }
-
- # Write the header (blank if none)
- $self->_output($preamble);
-
- # Start on new page if requested
- $self->_output("\\clearpage\n") if $self->StartWithNewPage;
-
-}
-
-
-=item B<end_pod>
-
-Write the closing C<latex> code. Only writes something if AddPostamble
-is true. Writes a standard header unless a UserPostamble is defined.
-
-=cut
-
-sub end_pod {
- my $self = shift;
-
- # End string
- my $end = '';
-
- # Use the user version of the postamble if defined
- if ($self->AddPostamble) {
-
- if (defined $self->UserPostamble) {
- $end = $self->UserPostamble;
-
- } else {
-
- # Check for index
- my $makeindex = '\printindex';
-
- $makeindex = '%% '. $makeindex unless $self->MakeIndex;
-
- $end = "$makeindex\n\n\\end{document}\n";
- }
- }
-
- $self->_output($end);
-
-}
-
-=item B<command>
-
-Process basic pod commands.
-
-=cut
-
-sub command {
- my $self = shift;
- my ($command, $paragraph, $line_num, $parobj) = @_;
-
- # return if we dont care
- return if $command eq 'pod';
-
- # Store a copy of the raw text in case we are in a =for
- # block and need to preserve the existing latex
- my $rawpara = $paragraph;
-
- # Do the latex escapes
- $paragraph = $self->_replace_special_chars($paragraph);
-
- # Interpolate pod sequences in paragraph
- $paragraph = $self->interpolate($paragraph, $line_num);
- $paragraph =~ s/\s+$//;
-
- # Replace characters that can only be done after
- # interpolation of interior sequences
- $paragraph = $self->_replace_special_chars_late($paragraph);
-
- # Now run the command
- if ($command eq 'over') {
-
- $self->begin_list($paragraph, $line_num);
-
- } elsif ($command eq 'item') {
-
- $self->add_item($paragraph, $line_num);
-
- } elsif ($command eq 'back') {
-
- $self->end_list($line_num);
-
- } elsif ($command eq 'head1') {
-
- # Store the name of the section
- $self->{_CURRENT_HEAD1} = $paragraph;
-
- # Print it
- $self->head(1, $paragraph, $parobj);
-
- } elsif ($command eq 'head2') {
-
- $self->head(2, $paragraph, $parobj);
-
- } elsif ($command eq 'head3') {
-
- $self->head(3, $paragraph, $parobj);
-
- } elsif ($command eq 'head4') {
-
- $self->head(4, $paragraph, $parobj);
-
- } elsif ($command eq 'head5') {
-
- $self->head(5, $paragraph, $parobj);
-
- } elsif ($command eq 'head6') {
-
- $self->head(6, $paragraph, $parobj);
-
- } elsif ($command eq 'begin') {
-
- # pass through if latex
- if ($paragraph =~ /^latex/i) {
- # Make sure that subsequent paragraphs are not modfied before printing
- $self->{_dont_modify_any_para} = 1;
-
- } else {
- # Suppress all subsequent paragraphs unless
- # it is explcitly intended for latex
- $self->{_suppress_all_para} = 1;
- }
-
- } elsif ($command eq 'for') {
-
- # =for latex
- # some latex
-
- # With =for we will get the text for the full paragraph
- # as well as the format name.
- # We do not get an additional paragraph later on. The next
- # paragraph is not governed by the =for
-
- # The first line contains the format and the rest is the
- # raw code.
- my ($format, $chunk) = split(/\n/, $rawpara, 2);
-
- # If we have got some latex code print it out immediately
- # unmodified. Else do nothing.
- if ($format =~ /^latex/i) {
- # Make sure that next paragraph is not modfied before printing
- $self->_output( $chunk );
-
- }
-
- } elsif ($command eq 'end') {
-
- # Reset suppression
- $self->{_suppress_all_para} = 0;
- $self->{_dont_modify_any_para} = 0;
-
- } elsif ($command eq 'pod') {
-
- # Do nothing
-
- } else {
- carp "Command $command not recognised at line $line_num\n";
- }
-
-}
-
-=item B<verbatim>
-
-Verbatim text
-
-=cut
-
-sub verbatim {
- my $self = shift;
- my ($paragraph, $line_num, $parobj) = @_;
-
- # Expand paragraph unless in =begin block
- if ($self->{_dont_modify_any_para}) {
- # Just print as is
- $self->_output($paragraph);
-
- } else {
-
- return if $paragraph =~ /^\s+$/;
-
- # Clean trailing space
- $paragraph =~ s/\s+$//;
-
- # Clean tabs. Routine taken from Tabs.pm
- # by David Muir Sharnoff muir at idiom.com,
- # slightly modified by hsmyers at sdragons.com 10/22/01
- my @l = split("\n",$paragraph);
- foreach (@l) {
- 1 while s/(^|\n)([^\t\n]*)(\t+)/
- $1. $2 . (" " x
- (8 * length($3)
- - (length($2) % 8)))
- /sex;
- }
- $paragraph = join("\n", at l);
- # End of change.
-
-
-
- $self->_output('\begin{verbatim}' . "\n$paragraph\n". '\end{verbatim}'."\n");
- }
-}
-
-=item B<textblock>
-
-Plain text paragraph.
-
-=cut
-
-sub textblock {
- my $self = shift;
- my ($paragraph, $line_num, $parobj) = @_;
-
- # print Dumper($self);
-
- # Expand paragraph unless in =begin block
- if ($self->{_dont_modify_any_para}) {
- # Just print as is
- $self->_output($paragraph);
-
- return;
- }
-
-
- # Escape latex special characters
- $paragraph = $self->_replace_special_chars($paragraph);
-
- # Interpolate interior sequences
- my $expansion = $self->interpolate($paragraph, $line_num);
- $expansion =~ s/\s+$//;
-
- # Escape special characters that can not be done earlier
- $expansion = $self->_replace_special_chars_late($expansion);
-
- # If we are replacing 'head1 NAME' with a section
- # we need to look in the paragraph and rewrite things
- # Need to make sure this is called only on the first paragraph
- # following 'head1 NAME' and not on subsequent paragraphs that may be
- # present.
- if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection()) {
-
- # Strip white space from start and end
- $paragraph =~ s/^\s+//;
- $paragraph =~ s/\s$//;
-
- # Split the string into 2 parts
- my ($name, $purpose) = split(/\s+-\s+/, $expansion,2);
-
- # Now prevent this from triggering until a new head1 NAME is set
- $self->{_CURRENT_HEAD1} = '_NAME';
-
- # Might want to clear the Label() before doing this (CHECK)
-
- # Print the heading
- $self->head(1, $name, $parobj);
-
- # Set the labeling in case we want unique names later
- $self->Label( $self->_create_label( $name, 1 ) );
-
- # Raise the Head1Level by one so that subsequent =head1 appear
- # as subsections of the main name section unless we are already
- # at maximum [Head1Level() could check this itself - CHECK]
- $self->Head1Level( $self->Head1Level() + 1)
- unless $self->Head1Level == $#LatexSections;
-
- # Now write out the new latex paragraph
- $purpose = ucfirst($purpose);
- $self->_output("\n\n$purpose\n\n");
-
- } else {
- # Just write the output
- $self->_output("\n\n$expansion\n\n");
- }
-
-}
-
-=item B<interior_sequence>
-
-Interior sequence expansion
-
-=cut
-
-sub interior_sequence {
- my $self = shift;
-
- my ($seq_command, $seq_argument, $pod_seq) = @_;
-
- if ($seq_command eq 'B') {
- return "\\textbf{$seq_argument}";
-
- } elsif ($seq_command eq 'I') {
- return "\\textit{$seq_argument}";
-
- } elsif ($seq_command eq 'E') {
-
- # If it is simply a number
- if ($seq_argument =~ /^\d+$/) {
- return chr($seq_argument);
- # Look up escape in hash table
- } elsif (exists $HTML_Escapes{$seq_argument}) {
- return $HTML_Escapes{$seq_argument};
-
- } else {
- my ($file, $line) = $pod_seq->file_line();
- warn "Escape sequence $seq_argument not recognised at line $line of file $file\n";
- return;
- }
-
- } elsif ($seq_command eq 'Z') {
-
- # Zero width space
- return '{}';
-
- } elsif ($seq_command eq 'C') {
- return "\\texttt{$seq_argument}";
-
- } elsif ($seq_command eq 'F') {
- return "\\emph{$seq_argument}";
-
- } elsif ($seq_command eq 'S') {
- # non breakable spaces
- my $nbsp = '~';
-
- $seq_argument =~ s/\s/$nbsp/g;
- return $seq_argument;
-
- } elsif ($seq_command eq 'L') {
- my $link = new Pod::Hyperlink($seq_argument);
-
- # undef on failure
- unless (defined $link) {
- carp $@;
- return;
- }
-
- # Handle internal links differently
- my $type = $link->type;
- my $page = $link->page;
-
- if ($type eq 'section' && $page eq '') {
- # Use internal latex reference
- my $node = $link->node;
-
- # Convert to a label
- $node = $self->_create_label($node);
-
- return "\\S\\ref{$node}";
-
- } else {
- # Use default markup for external references
- # (although Starlink would use \xlabel)
- my $markup = $link->markup;
- my ($file, $line) = $pod_seq->file_line();
-
- return $self->interpolate($link->markup, $line);
- }
-
-
-
- } elsif ($seq_command eq 'P') {
- # Special markup for Pod::Hyperlink
- # Replace :: with / - but not sure if I want to do this
- # any more.
- my $link = $seq_argument;
- $link =~ s|::|/|g;
-
- my $ref = "\\emph{$seq_argument}";
- return $ref;
-
- } elsif ($seq_command eq 'Q') {
- # Special markup for Pod::Hyperlink
- return "\\textsf{$seq_argument}";
-
- } elsif ($seq_command eq 'X') {
- # Index entries
-
- # use \index command
- # I will let '!' go through for now
- # not sure how sub categories are handled in X<>
- my $index = $self->_create_index($seq_argument);
- return "\\index{$index}\n";
-
- } else {
- carp "Unknown sequence $seq_command<$seq_argument>";
- }
-
-}
-
-=back
-
-=head2 List Methods
-
-Methods used to handle lists.
-
-=over 4
-
-=item B<begin_list>
-
-Called when a new list is found (via the C<over> directive).
-Creates a new C<Pod::List> object and stores it on the
-list stack.
-
- $parser->begin_list($indent, $line_num);
-
-=cut
-
-sub begin_list {
- my $self = shift;
- my $indent = shift;
- my $line_num = shift;
-
- # Indicate that a list should be started for the next item
- # need to do this to work out the type of list
- push ( @{$self->lists}, new Pod::List(-indent => $indent,
- -start => $line_num,
- -file => $self->input_file,
- )
- );
-
-}
-
-=item B<end_list>
-
-Called when the end of a list is found (the C<back> directive).
-Pops the C<Pod::List> object off the stack of lists and writes
-the C<latex> code required to close a list.
-
- $parser->end_list($line_num);
-
-=cut
-
-sub end_list {
- my $self = shift;
- my $line_num = shift;
-
- unless (defined $self->lists->[-1]) {
- my $file = $self->input_file;
- warn "No list is active at line $line_num (file=$file). Missing =over?\n";
- return;
- }
-
- # What to write depends on list type
- my $type = $self->lists->[-1]->type;
-
- # Dont write anything if the list type is not set
- # iomplying that a list was created but no entries were
- # placed in it (eg because of a =begin/=end combination)
- $self->_output("\\end{$type}\n")
- if (defined $type && length($type) > 0);
-
- # Clear list
- pop(@{ $self->lists});
-
-}
-
-=item B<add_item>
-
-Add items to the list. The first time an item is encountered
-(determined from the state of the current C<Pod::List> object)
-the type of list is determined (ordered, unnumbered or description)
-and the relevant latex code issued.
-
- $parser->add_item($paragraph, $line_num);
-
-=cut
-
-sub add_item {
- my $self = shift;
- my $paragraph = shift;
- my $line_num = shift;
-
- unless (defined $self->lists->[-1]) {
- my $file = $self->input_file;
- warn "List has already ended by line $line_num of file $file. Missing =over?\n";
- # Replace special chars
-# $paragraph = $self->_replace_special_chars($paragraph);
- $self->_output("$paragraph\n\n");
- return;
- }
-
- # If paragraphs printing is turned off via =begin/=end or whatver
- # simply return immediately
- return if $self->{_suppress_all_para};
-
- # Check to see whether we are starting a new lists
- if (scalar($self->lists->[-1]->item) == 0) {
-
- # Examine the paragraph to determine what type of list
- # we have
- $paragraph =~ s/\s+$//;
- $paragraph =~ s/^\s+//;
-
- my $type;
- if (substr($paragraph, 0,1) eq '*') {
- $type = 'itemize';
- } elsif ($paragraph =~ /^\d/) {
- $type = 'enumerate';
- } else {
- $type = 'description';
- }
- $self->lists->[-1]->type($type);
-
- $self->_output("\\begin{$type}\n");
-
- }
-
- my $type = $self->lists->[-1]->type;
-
- if ($type eq 'description') {
- # Handle long items - long items do not wrap
- # If the string is longer than 40 characters we split
- # it into a real item header and some bold text.
- my $maxlen = 40;
- my ($hunk1, $hunk2) = $self->_split_delimited( $paragraph, $maxlen );
-
- # Print the first hunk
- $self->_output("\n\\item[{$hunk1}] ");
-
- # and the second hunk if it is defined
- if ($hunk2) {
- $self->_output("\\textbf{$hunk2}");
- } else {
- # Not there so make sure we have a new line
- $self->_output("\\mbox{}");
- }
-
- } else {
- # If the item was '* Something' or '\d+ something' we still need to write
- # out the something. Also allow 1) and 1.
- my $extra_info = $paragraph;
- $extra_info =~ s/^(\*|\d+[\.\)]?)\s*//;
- $self->_output("\n\\item $extra_info");
- }
-
- # Store the item name in the object. Required so that
- # we can tell if the list is new or not
- $self->lists->[-1]->item($paragraph);
-
-}
-
-=back
-
-=head2 Methods for headings
-
-=over 4
-
-=item B<head>
-
-Print a heading of the required level.
-
- $parser->head($level, $paragraph, $parobj);
-
-The first argument is the pod heading level. The second argument
-is the contents of the heading. The 3rd argument is a Pod::Paragraph
-object so that the line number can be extracted.
-
-=cut
-
-sub head {
- my $self = shift;
- my $num = shift;
- my $paragraph = shift;
- my $parobj = shift;
-
- # If we are replace 'head1 NAME' with a section
- # we return immediately if we get it
- return
- if ($self->{_CURRENT_HEAD1} =~ /^NAME/i && $self->ReplaceNAMEwithSection());
-
- # Create a label
- my $label = $self->_create_label($paragraph);
-
- # Create an index entry
- my $index = $self->_create_index($paragraph);
-
- # Work out position in the above array taking into account
- # that =head1 is equivalent to $self->Head1Level
-
- my $level = $self->Head1Level() - 1 + $num;
-
- # Warn if heading to large
- if ($num > $#LatexSections) {
- my $line = $parobj->file_line;
- my $file = $self->input_file;
- warn "Heading level too large ($level) for LaTeX at line $line of file $file\n";
- $level = $#LatexSections;
- }
-
- # Check to see whether section should be unnumbered
- my $star = ($level >= $self->LevelNoNum ? '*' : '');
-
- # Section
- $self->_output("\\" .$LatexSections[$level] .$star ."{$paragraph\\label{".$label ."}\\index{".$index."}}\n");
-
-}
-
-
-=back
-
-=end __PRIVATE__
-
-=begin __PRIVATE__
-
-=head2 Internal methods
-
-Internal routines are described in this section. They do not form part of the
-public interface. All private methods start with an underscore.
-
-=over 4
-
-=item B<_output>
-
-Output text to the output filehandle. This method must be always be called
-to output parsed text.
-
- $parser->_output($text);
-
-Does not write anything if a =begin is active that should be
-ignored.
-
-=cut
-
-sub _output {
- my $self = shift;
- my $text = shift;
-
- print { $self->output_handle } $text
- unless $self->{_suppress_all_para};
-
-}
-
-
-=item B<_replace_special_chars>
-
-Subroutine to replace characters that are special in C<latex>
-with the escaped forms
-
- $escaped = $parser->_replace_special_chars($paragraph);
-
-Need to call this routine before interior_sequences are munged but not
-if verbatim. It must be called before interpolation of interior
-sequences so that curly brackets and special latex characters inserted
-during interpolation are not themselves escaped. This means that < and
-> can not be modified here since the text still contains interior
-sequences.
-
-Special characters and the C<latex> equivalents are:
-
- } \}
- { \{
- _ \_
- $ \$
- % \%
- & \&
- \ $\backslash$
- ^ \^{}
- ~ \~{}
- # \#
-
-=cut
-
-sub _replace_special_chars {
- my $self = shift;
- my $paragraph = shift;
-
- # Replace a \ with $\backslash$
- # This is made more complicated because the dollars will be escaped
- # by the subsequent replacement. Easiest to add \backslash
- # now and then add the dollars
- $paragraph =~ s/\\/\\backslash/g;
-
- # Must be done after escape of \ since this command adds latex escapes
- # Replace characters that can be escaped
- $paragraph =~ s/([\$\#&%_{}])/\\$1/g;
-
- # Replace ^ characters with \^{} so that $^F works okay
- $paragraph =~ s/(\^)/\\$1\{\}/g;
-
- # Replace tilde (~) with \texttt{\~{}}
- $paragraph =~ s/~/\\texttt\{\\~\{\}\}/g;
-
- # Now add the dollars around each \backslash
- $paragraph =~ s/(\\backslash)/\$$1\$/g;
- return $paragraph;
-}
-
-=item B<_replace_special_chars_late>
-
-Replace special characters that can not be replaced before interior
-sequence interpolation. See C<_replace_special_chars> for a routine
-to replace special characters prior to interpolation of interior
-sequences.
-
-Does the following transformation:
-
- < $<$
- > $>$
- | $|$
-
-
-=cut
-
-sub _replace_special_chars_late {
- my $self = shift;
- my $paragraph = shift;
-
- # < and >
- $paragraph =~ s/(<|>)/\$$1\$/g;
-
- # Replace | with $|$
- $paragraph =~ s'\|'$|$'g;
-
-
- return $paragraph;
-}
-
-
-=item B<_create_label>
-
-Return a string that can be used as an internal reference
-in a C<latex> document (i.e. accepted by the C<\label> command)
-
- $label = $parser->_create_label($string)
-
-If UniqueLabels is true returns a label prefixed by Label()
-This can be suppressed with an optional second argument.
-
- $label = $parser->_create_label($string, $suppress);
-
-If a second argument is supplied (of any value including undef)
-the Label() is never prefixed. This means that this routine can
-be called to create a Label() without prefixing a previous setting.
-
-=cut
-
-sub _create_label {
- my $self = shift;
- my $paragraph = shift;
- my $suppress = (@_ ? 1 : 0 );
-
- # Remove latex commands
- $paragraph = $self->_clean_latex_commands($paragraph);
-
- # Remove non alphanumerics from the label and replace with underscores
- # want to protect '-' though so use negated character classes
- $paragraph =~ s/[^-:\w]/_/g;
-
- # Multiple underscores will look unsightly so remove repeats
- # This will also have the advantage of tidying up the end and
- # start of string
- $paragraph =~ s/_+/_/g;
-
- # If required need to make sure that the label is unique
- # since it is possible to have multiple pods in a single
- # document
- if (!$suppress && $self->UniqueLabels() && defined $self->Label) {
- $paragraph = $self->Label() .'_'. $paragraph;
- }
-
- return $paragraph;
-}
-
-
-=item B<_create_index>
-
-Similar to C<_create_label> except an index entry is created.
-If C<UniqueLabels> is true, the index entry is prefixed by
-the current C<Label> and an exclamation mark.
-
- $ind = $parser->_create_index($paragraph);
-
-An exclamation mark is used by C<makeindex> to generate
-sub-entries in an index.
-
-=cut
-
-sub _create_index {
- my $self = shift;
- my $paragraph = shift;
- my $suppress = (@_ ? 1 : 0 );
-
- # Remove latex commands
- $paragraph = $self->_clean_latex_commands($paragraph);
-
- # If required need to make sure that the index entry is unique
- # since it is possible to have multiple pods in a single
- # document
- if (!$suppress && $self->UniqueLabels() && defined $self->Label) {
- $paragraph = $self->Label() .'!'. $paragraph;
- }
-
- # Need to replace _ with space
- $paragraph =~ s/_/ /g;
-
- return $paragraph;
-
-}
-
-=item B<_clean_latex_commands>
-
-Removes latex commands from text. The latex command is assumed to be of the
-form C<\command{ text }>. "C<text>" is retained
-
- $clean = $parser->_clean_latex_commands($text);
-
-=cut
-
-sub _clean_latex_commands {
- my $self = shift;
- my $paragraph = shift;
-
- # Remove latex commands of the form \text{ }
- # and replace with the contents of the { }
- # need to make this non-greedy so that it can handle
- # "\text{a} and \text2{b}"
- # without converting it to
- # "a} and \text2{b"
- # This match will still get into trouble if \} is present
- # This is not vital since the subsequent replacement of non-alphanumeric
- # characters will tidy it up anyway
- $paragraph =~ s/\\\w+{(.*?)}/$1/g;
-
- return $paragraph
-}
-
-=item B<_split_delimited>
-
-Split the supplied string into two parts at approximately the
-specified word boundary. Special care is made to make sure that it
-does not split in the middle of some curly brackets.
-
-e.g. "this text is \textbf{very bold}" would not be split into
-"this text is \textbf{very" and " bold".
-
- ($hunk1, $hunk2) = $self->_split_delimited( $para, $length);
-
-The length indicates the maximum length of hunk1.
-
-=cut
-
-# initially Supplied by hsmyers at sdragons.com
-# 10/25/01, utility to split \hbox
-# busting lines. Reformatted by TimJ to match module style.
-sub _split_delimited {
- my $self = shift;
- my $input = shift;
- my $limit = shift;
-
- # Return immediately if already small
- return ($input, '') if length($input) < $limit;
-
- my @output;
- my $s = '';
- my $t = '';
- my $depth = 0;
- my $token;
-
- $input =~ s/\n/ /gm;
- $input .= ' ';
- foreach ( split ( //, $input ) ) {
- $token .= $_;
- if (/\{/) {
- $depth++;
- } elsif ( /}/ ) {
- $depth--;
- } elsif ( / / and $depth == 0) {
- push @output, $token if ( $token and $token ne ' ' );
- $token = '';
- }
- }
-
- foreach (@output) {
- if (length($s) < $limit) {
- $s .= $_;
- } else {
- $t .= $_;
- }
- }
-
- # Tidy up
- $s =~ s/\s+$//;
- $t =~ s/\s+$//;
- return ($s,$t);
-}
-
-=back
-
-=end __PRIVATE__
-
-=head1 NOTES
-
-Compatible with C<latex2e> only. Can not be used with C<latex> v2.09
-or earlier.
-
-A subclass of C<Pod::Select> so that specific pod sections can be
-converted to C<latex> by using the C<select> method.
-
-Some HTML escapes are missing and many have not been tested.
-
-=head1 SEE ALSO
-
-L<Pod::Parser>, L<Pod::Select>, L<pod2latex>
-
-=head1 AUTHORS
-
-Tim Jenness E<lt>tjenness at cpan.orgE<gt>
-
-Bug fixes and improvements have been received from: Simon Cozens
-E<lt>simon at cozens.netE<gt>, Mark A. Hershberger
-E<lt>mah at everybody.orgE<gt>, Marcel Grunauer
-E<lt>marcel at codewerk.comE<gt>, Hugh S Myers
-E<lt>hsmyers at sdragons.comE<gt>, Peter J Acklam
-E<lt>jacklam at math.uio.noE<gt>, Sudhi Herle E<lt>sudhi at herle.netE<gt>,
-Ariel Scolnicov E<lt>ariels at compugen.co.ilE<gt>,
-Adriano Rodrigues Ferreira E<lt>ferreira at triang.com.brE<gt> and
-R. de Vries E<lt>r.de.vries at dutchspace.nlE<gt>.
-
-
-=head1 COPYRIGHT
-
-Copyright (C) 2000-2004 Tim Jenness. All Rights Reserved.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=begin __PRIVATE__
-
-=head1 REVISION
-
-$Id: LaTeX.pm,v 1.1.1.2 2011-02-17 12:49:41 laffer1 Exp $
-
-=end __PRIVATE__
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/Pod/Man.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Man.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Man.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1747 +0,0 @@
-# Pod::Man -- Convert POD data to formatted *roff input.
-#
-# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
-# Russ Allbery <rra at stanford.edu>
-# Substantial contributions by Sean Burke <sburke at cpan.org>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-#
-# This module translates POD documentation into *roff markup using the man
-# macro set, and is intended for converting POD documents written as Unix
-# manual pages to manual pages that can be read by the man(1) command. It is
-# a replacement for the pod2man command distributed with versions of Perl
-# prior to 5.6.
-#
-# Perl core hackers, please note that this module is also separately
-# maintained outside of the Perl core as part of the podlators. Please send
-# me any patches at the address above in addition to sending them to the
-# standard Perl mailing lists.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Pod::Man;
-
-require 5.005;
-
-use strict;
-use subs qw(makespace);
-use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION);
-
-use Carp qw(croak);
-use Pod::Simple ();
-use POSIX qw(strftime);
-
- at ISA = qw(Pod::Simple);
-
-$VERSION = '2.22';
-
-# Set the debugging level. If someone has inserted a debug function into this
-# class already, use that. Otherwise, use any Pod::Simple debug function
-# that's defined, and failing that, define a debug level of 10.
-BEGIN {
- my $parent = defined (&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG : undef;
- unless (defined &DEBUG) {
- *DEBUG = $parent || sub () { 10 };
- }
-}
-
-# Import the ASCII constant from Pod::Simple. This is true iff we're in an
-# ASCII-based universe (including such things as ISO 8859-1 and UTF-8), and is
-# generally only false for EBCDIC.
-BEGIN { *ASCII = \&Pod::Simple::ASCII }
-
-# Pretty-print a data structure. Only used for debugging.
-BEGIN { *pretty = \&Pod::Simple::pretty }
-
-##############################################################################
-# Object initialization
-##############################################################################
-
-# Initialize the object and set various Pod::Simple options that we need.
-# Here, we also process any additional options passed to the constructor or
-# set up defaults if none were given. Note that all internal object keys are
-# in all-caps, reserving all lower-case object keys for Pod::Simple and user
-# arguments.
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new;
-
- # Tell Pod::Simple not to handle S<> by automatically inserting .
- $self->nbsp_for_S (1);
-
- # Tell Pod::Simple to keep whitespace whenever possible.
- if ($self->can ('preserve_whitespace')) {
- $self->preserve_whitespace (1);
- } else {
- $self->fullstop_space_harden (1);
- }
-
- # The =for and =begin targets that we accept.
- $self->accept_targets (qw/man MAN roff ROFF/);
-
- # Ensure that contiguous blocks of code are merged together. Otherwise,
- # some of the guesswork heuristics don't work right.
- $self->merge_text (1);
-
- # Pod::Simple doesn't do anything useful with our arguments, but we want
- # to put them in our object as hash keys and values. This could cause
- # problems if we ever clash with Pod::Simple's own internal class
- # variables.
- %$self = (%$self, @_);
-
- # Send errors to stderr if requested.
- if ($$self{stderr}) {
- $self->no_errata_section (1);
- $self->complain_stderr (1);
- delete $$self{stderr};
- }
-
- # Initialize various other internal constants based on our arguments.
- $self->init_fonts;
- $self->init_quotes;
- $self->init_page;
-
- # For right now, default to turning on all of the magic.
- $$self{MAGIC_CPP} = 1;
- $$self{MAGIC_EMDASH} = 1;
- $$self{MAGIC_FUNC} = 1;
- $$self{MAGIC_MANREF} = 1;
- $$self{MAGIC_SMALLCAPS} = 1;
- $$self{MAGIC_VARS} = 1;
-
- return $self;
-}
-
-# Translate a font string into an escape.
-sub toescape { (length ($_[0]) > 1 ? '\f(' : '\f') . $_[0] }
-
-# Determine which fonts the user wishes to use and store them in the object.
-# Regular, italic, bold, and bold-italic are constants, but the fixed width
-# fonts may be set by the user. Sets the internal hash key FONTS which is
-# used to map our internal font escapes to actual *roff sequences later.
-sub init_fonts {
- my ($self) = @_;
-
- # Figure out the fixed-width font. If user-supplied, make sure that they
- # are the right length.
- for (qw/fixed fixedbold fixeditalic fixedbolditalic/) {
- my $font = $$self{$_};
- if (defined ($font) && (length ($font) < 1 || length ($font) > 2)) {
- croak qq(roff font should be 1 or 2 chars, not "$font");
- }
- }
-
- # Set the default fonts. We can't be sure portably across different
- # implementations what fixed bold-italic may be called (if it's even
- # available), so default to just bold.
- $$self{fixed} ||= 'CW';
- $$self{fixedbold} ||= 'CB';
- $$self{fixeditalic} ||= 'CI';
- $$self{fixedbolditalic} ||= 'CB';
-
- # Set up a table of font escapes. First number is fixed-width, second is
- # bold, third is italic.
- $$self{FONTS} = { '000' => '\fR', '001' => '\fI',
- '010' => '\fB', '011' => '\f(BI',
- '100' => toescape ($$self{fixed}),
- '101' => toescape ($$self{fixeditalic}),
- '110' => toescape ($$self{fixedbold}),
- '111' => toescape ($$self{fixedbolditalic}) };
-}
-
-# Initialize the quotes that we'll be using for C<> text. This requires some
-# special handling, both to parse the user parameter if given and to make sure
-# that the quotes will be safe against *roff. Sets the internal hash keys
-# LQUOTE and RQUOTE.
-sub init_quotes {
- my ($self) = (@_);
-
- $$self{quotes} ||= '"';
- if ($$self{quotes} eq 'none') {
- $$self{LQUOTE} = $$self{RQUOTE} = '';
- } elsif (length ($$self{quotes}) == 1) {
- $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes};
- } elsif ($$self{quotes} =~ /^(.)(.)$/
- || $$self{quotes} =~ /^(..)(..)$/) {
- $$self{LQUOTE} = $1;
- $$self{RQUOTE} = $2;
- } else {
- croak(qq(Invalid quote specification "$$self{quotes}"))
- }
-
- # Double the first quote; note that this should not be s///g as two double
- # quotes is represented in *roff as three double quotes, not four. Weird,
- # I know.
- $$self{LQUOTE} =~ s/\"/\"\"/;
- $$self{RQUOTE} =~ s/\"/\"\"/;
-}
-
-# Initialize the page title information and indentation from our arguments.
-sub init_page {
- my ($self) = @_;
-
- # We used to try first to get the version number from a local binary, but
- # we shouldn't need that any more. Get the version from the running Perl.
- # Work a little magic to handle subversions correctly under both the
- # pre-5.6 and the post-5.6 version numbering schemes.
- my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
- $version[2] ||= 0;
- $version[2] *= 10 ** (3 - length $version[2]);
- for (@version) { $_ += 0 }
- my $version = join ('.', @version);
-
- # Set the defaults for page titles and indentation if the user didn't
- # override anything.
- $$self{center} = 'User Contributed Perl Documentation'
- unless defined $$self{center};
- $$self{release} = 'perl v' . $version
- unless defined $$self{release};
- $$self{indent} = 4
- unless defined $$self{indent};
-
- # Double quotes in things that will be quoted.
- for (qw/center release/) {
- $$self{$_} =~ s/\"/\"\"/g if $$self{$_};
- }
-}
-
-##############################################################################
-# Core parsing
-##############################################################################
-
-# This is the glue that connects the code below with Pod::Simple itself. The
-# goal is to convert the event stream coming from the POD parser into method
-# calls to handlers once the complete content of a tag has been seen. Each
-# paragraph or POD command will have textual content associated with it, and
-# as soon as all of a paragraph or POD command has been seen, that content
-# will be passed in to the corresponding method for handling that type of
-# object. The exceptions are handlers for lists, which have opening tag
-# handlers and closing tag handlers that will be called right away.
-#
-# The internal hash key PENDING is used to store the contents of a tag until
-# all of it has been seen. It holds a stack of open tags, each one
-# represented by a tuple of the attributes hash for the tag, formatting
-# options for the tag (which are inherited), and the contents of the tag.
-
-# Add a block of text to the contents of the current node, formatting it
-# according to the current formatting instructions as we do.
-sub _handle_text {
- my ($self, $text) = @_;
- DEBUG > 3 and print "== $text\n";
- my $tag = $$self{PENDING}[-1];
- $$tag[2] .= $self->format_text ($$tag[1], $text);
-}
-
-# Given an element name, get the corresponding method name.
-sub method_for_element {
- my ($self, $element) = @_;
- $element =~ tr/-/_/;
- $element =~ tr/A-Z/a-z/;
- $element =~ tr/_a-z0-9//cd;
- return $element;
-}
-
-# Handle the start of a new element. If cmd_element is defined, assume that
-# we need to collect the entire tree for this element before passing it to the
-# element method, and create a new tree into which we'll collect blocks of
-# text and nested elements. Otherwise, if start_element is defined, call it.
-sub _handle_element_start {
- my ($self, $element, $attrs) = @_;
- DEBUG > 3 and print "++ $element (<", join ('> <', %$attrs), ">)\n";
- my $method = $self->method_for_element ($element);
-
- # If we have a command handler, we need to accumulate the contents of the
- # tag before calling it. Turn off IN_NAME for any command other than
- # <Para> so that IN_NAME isn't still set for the first heading after the
- # NAME heading.
- if ($self->can ("cmd_$method")) {
- DEBUG > 2 and print "<$element> starts saving a tag\n";
- $$self{IN_NAME} = 0 if ($element ne 'Para');
-
- # How we're going to format embedded text blocks depends on the tag
- # and also depends on our parent tags. Thankfully, inside tags that
- # turn off guesswork and reformatting, nothing else can turn it back
- # on, so this can be strictly inherited.
- my $formatting = $$self{PENDING}[-1][1];
- $formatting = $self->formatting ($formatting, $element);
- push (@{ $$self{PENDING} }, [ $attrs, $formatting, '' ]);
- DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
- } elsif ($self->can ("start_$method")) {
- my $method = 'start_' . $method;
- $self->$method ($attrs, '');
- } else {
- DEBUG > 2 and print "No $method start method, skipping\n";
- }
-}
-
-# Handle the end of an element. If we had a cmd_ method for this element,
-# this is where we pass along the tree that we built. Otherwise, if we have
-# an end_ method for the element, call that.
-sub _handle_element_end {
- my ($self, $element) = @_;
- DEBUG > 3 and print "-- $element\n";
- my $method = $self->method_for_element ($element);
-
- # If we have a command handler, pull off the pending text and pass it to
- # the handler along with the saved attribute hash.
- if ($self->can ("cmd_$method")) {
- DEBUG > 2 and print "</$element> stops saving a tag\n";
- my $tag = pop @{ $$self{PENDING} };
- DEBUG > 4 and print "Popped: [", pretty ($tag), "]\n";
- DEBUG > 4 and print "Pending: [", pretty ($$self{PENDING}), "]\n";
- my $method = 'cmd_' . $method;
- my $text = $self->$method ($$tag[0], $$tag[2]);
- if (defined $text) {
- if (@{ $$self{PENDING} } > 1) {
- $$self{PENDING}[-1][2] .= $text;
- } else {
- $self->output ($text);
- }
- }
- } elsif ($self->can ("end_$method")) {
- my $method = 'end_' . $method;
- $self->$method ();
- } else {
- DEBUG > 2 and print "No $method end method, skipping\n";
- }
-}
-
-##############################################################################
-# General formatting
-##############################################################################
-
-# Return formatting instructions for a new block. Takes the current
-# formatting and the new element. Formatting inherits negatively, in the
-# sense that if the parent has turned off guesswork, all child elements should
-# leave it off. We therefore return a copy of the same formatting
-# instructions but possibly with more things turned off depending on the
-# element.
-sub formatting {
- my ($self, $current, $element) = @_;
- my %options;
- if ($current) {
- %options = %$current;
- } else {
- %options = (guesswork => 1, cleanup => 1, convert => 1);
- }
- if ($element eq 'Data') {
- $options{guesswork} = 0;
- $options{cleanup} = 0;
- $options{convert} = 0;
- } elsif ($element eq 'X') {
- $options{guesswork} = 0;
- $options{cleanup} = 0;
- } elsif ($element eq 'Verbatim' || $element eq 'C') {
- $options{guesswork} = 0;
- $options{literal} = 1;
- }
- return \%options;
-}
-
-# Format a text block. Takes a hash of formatting options and the text to
-# format. Currently, the only formatting options are guesswork, cleanup, and
-# convert, all of which are boolean.
-sub format_text {
- my ($self, $options, $text) = @_;
- my $guesswork = $$options{guesswork} && !$$self{IN_NAME};
- my $cleanup = $$options{cleanup};
- my $convert = $$options{convert};
- my $literal = $$options{literal};
-
- # Cleanup just tidies up a few things, telling *roff that the hyphens are
- # hard, putting a bit of space between consecutive underscores, and
- # escaping backslashes. Be careful not to mangle our character
- # translations by doing this before processing character translation.
- if ($cleanup) {
- $text =~ s/\\/\\e/g;
- $text =~ s/-/\\-/g;
- $text =~ s/_(?=_)/_\\|/g;
- }
-
- # Normally we do character translation, but we won't even do that in
- # <Data> blocks or if UTF-8 output is desired.
- if ($convert && !$$self{utf8} && ASCII) {
- $text =~ s/([^\x00-\x7F])/$ESCAPES{ord ($1)} || "X"/eg;
- }
-
- # Ensure that *roff doesn't convert literal quotes to UTF-8 single quotes,
- # but don't mess up our accept escapes.
- if ($literal) {
- $text =~ s/(?<!\\\*)\'/\\*\(Aq/g;
- $text =~ s/(?<!\\\*)\`/\\\`/g;
- }
-
- # If guesswork is asked for, do that. This involves more substantial
- # formatting based on various heuristics that may only be appropriate for
- # particular documents.
- if ($guesswork) {
- $text = $self->guesswork ($text);
- }
-
- return $text;
-}
-
-# Handles C<> text, deciding whether to put \*C` around it or not. This is a
-# whole bunch of messy heuristics to try to avoid overquoting, originally from
-# Barrie Slaymaker. This largely duplicates similar code in Pod::Text.
-sub quote_literal {
- my $self = shift;
- local $_ = shift;
-
- # A regex that matches the portion of a variable reference that's the
- # array or hash index, separated out just because we want to use it in
- # several places in the following regex.
- my $index = '(?: \[.*\] | \{.*\} )?';
-
- # Check for things that we don't want to quote, and if we find any of
- # them, return the string with just a font change and no quoting.
- m{
- ^\s*
- (?:
- ( [\'\`\"] ) .* \1 # already quoted
- | \\\*\(Aq .* \\\*\(Aq # quoted and escaped
- | \\?\` .* ( \' | \\\*\(Aq ) # `quoted'
- | \$+ [\#^]? \S $index # special ($^Foo, $")
- | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
- | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
- | [-+]? ( \d[\d.]* | \.\d+ ) (?: [eE][-+]?\d+ )? # a number
- | 0x [a-fA-F\d]+ # a hex constant
- )
- \s*\z
- }xso and return '\f(FS' . $_ . '\f(FE';
-
- # If we didn't return, go ahead and quote the text.
- return '\f(FS\*(C`' . $_ . "\\*(C'\\f(FE";
-}
-
-# Takes a text block to perform guesswork on. Returns the text block with
-# formatting codes added. This is the code that marks up various Perl
-# constructs and things commonly used in man pages without requiring the user
-# to add any explicit markup, and is applied to all non-literal text. We're
-# guaranteed that the text we're applying guesswork to does not contain any
-# *roff formatting codes. Note that the inserted font sequences must be
-# treated later with mapfonts or textmapfonts.
-#
-# This method is very fragile, both in the regular expressions it uses and in
-# the ordering of those modifications. Care and testing is required when
-# modifying it.
-sub guesswork {
- my $self = shift;
- local $_ = shift;
- DEBUG > 5 and print " Guesswork called on [$_]\n";
-
- # By the time we reach this point, all hypens will be escaped by adding a
- # backslash. We want to undo that escaping if they're part of regular
- # words and there's only a single dash, since that's a real hyphen that
- # *roff gets to consider a possible break point. Make sure that a dash
- # after the first character of a word stays non-breaking, however.
- #
- # Note that this is not user-controllable; we pretty much have to do this
- # transformation or *roff will mangle the output in unacceptable ways.
- s{
- ( (?:\G|^|\s) [\(\"]* [a-zA-Z] ) ( \\- )?
- ( (?: [a-zA-Z\']+ \\-)+ )
- ( [a-zA-Z\']+ ) (?= [\)\".?!,;:]* (?:\s|\Z|\\\ ) )
- \b
- } {
- my ($prefix, $hyphen, $main, $suffix) = ($1, $2, $3, $4);
- $hyphen ||= '';
- $main =~ s/\\-/-/g;
- $prefix . $hyphen . $main . $suffix;
- }egx;
-
- # Translate "--" into a real em-dash if it's used like one. This means
- # that it's either surrounded by whitespace, it follows a regular word, or
- # it occurs between two regular words.
- if ($$self{MAGIC_EMDASH}) {
- s{ (\s) \\-\\- (\s) } { $1 . '\*(--' . $2 }egx;
- s{ (\b[a-zA-Z]+) \\-\\- (\s|\Z|[a-zA-Z]+\b) } { $1 . '\*(--' . $2 }egx;
- }
-
- # Make words in all-caps a little bit smaller; they look better that way.
- # However, we don't want to change Perl code (like @ARGV), nor do we want
- # to fix the MIME in MIME-Version since it looks weird with the
- # full-height V.
- #
- # We change only a string of all caps (2) either at the beginning of the
- # line or following regular punctuation (like quotes) or whitespace (1),
- # and followed by either similar punctuation, an em-dash, or the end of
- # the line (3).
- if ($$self{MAGIC_SMALLCAPS}) {
- s{
- ( ^ | [\s\(\"\'\`\[\{<>] | \\\ ) # (1)
- ( [A-Z] [A-Z] (?: [/A-Z+:\d_\$&] | \\- )* ) # (2)
- (?= [\s>\}\]\(\)\'\".?!,;] | \\*\(-- | \\\ | $ ) # (3)
- } {
- $1 . '\s-1' . $2 . '\s0'
- }egx;
- }
-
- # Note that from this point forward, we have to adjust for \s-1 and \s-0
- # strings inserted around things that we've made small-caps if later
- # transforms should work on those strings.
-
- # Italize functions in the form func(), including functions that are in
- # all capitals, but don't italize if there's anything between the parens.
- # The function must start with an alphabetic character or underscore and
- # then consist of word characters or colons.
- if ($$self{MAGIC_FUNC}) {
- s{
- ( \b | \\s-1 )
- ( [A-Za-z_] ([:\w] | \\s-?[01])+ \(\) )
- } {
- $1 . '\f(IS' . $2 . '\f(IE'
- }egx;
- }
-
- # Change references to manual pages to put the page name in italics but
- # the number in the regular font, with a thin space between the name and
- # the number. Only recognize func(n) where func starts with an alphabetic
- # character or underscore and contains only word characters, periods (for
- # configuration file man pages), or colons, and n is a single digit,
- # optionally followed by some number of lowercase letters. Note that this
- # does not recognize man page references like perl(l) or socket(3SOCKET).
- if ($$self{MAGIC_MANREF}) {
- s{
- ( \b | \\s-1 )
- ( [A-Za-z_] (?:[.:\w] | \\- | \\s-?[01])+ )
- ( \( \d [a-z]* \) )
- } {
- $1 . '\f(IS' . $2 . '\f(IE\|' . $3
- }egx;
- }
-
- # Convert simple Perl variable references to a fixed-width font. Be
- # careful not to convert functions, though; there are too many subtleties
- # with them to want to perform this transformation.
- if ($$self{MAGIC_VARS}) {
- s{
- ( ^ | \s+ )
- ( [\$\@%] [\w:]+ )
- (?! \( )
- } {
- $1 . '\f(FS' . $2 . '\f(FE'
- }egx;
- }
-
- # Fix up double quotes. Unfortunately, we miss this transformation if the
- # quoted text contains any code with formatting codes and there's not much
- # we can effectively do about that, which makes it somewhat unclear if
- # this is really a good idea.
- s{ \" ([^\"]+) \" } { '\*(L"' . $1 . '\*(R"' }egx;
-
- # Make C++ into \*(C+, which is a squinched version.
- if ($$self{MAGIC_CPP}) {
- s{ \b C\+\+ } {\\*\(C+}gx;
- }
-
- # Done.
- DEBUG > 5 and print " Guesswork returning [$_]\n";
- return $_;
-}
-
-##############################################################################
-# Output
-##############################################################################
-
-# When building up the *roff code, we don't use real *roff fonts. Instead, we
-# embed font codes of the form \f(<font>[SE] where <font> is one of B, I, or
-# F, S stands for start, and E stands for end. This method turns these into
-# the right start and end codes.
-#
-# We add this level of complexity because the old pod2man didn't get code like
-# B<someI<thing> else> right; after I<> it switched back to normal text rather
-# than bold. We take care of this by using variables that state whether bold,
-# italic, or fixed are turned on as a combined pointer to our current font
-# sequence, and set each to the number of current nestings of start tags for
-# that font.
-#
-# \fP changes to the previous font, but only one previous font is kept. We
-# don't know what the outside level font is; normally it's R, but if we're
-# inside a heading it could be something else. So arrange things so that the
-# outside font is always the "previous" font and end with \fP instead of \fR.
-# Idea from Zack Weinberg.
-sub mapfonts {
- my ($self, $text) = @_;
- my ($fixed, $bold, $italic) = (0, 0, 0);
- my %magic = (F => \$fixed, B => \$bold, I => \$italic);
- my $last = '\fR';
- $text =~ s<
- \\f\((.)(.)
- > <
- my $sequence = '';
- my $f;
- if ($last ne '\fR') { $sequence = '\fP' }
- ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
- $f = $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
- if ($f eq $last) {
- '';
- } else {
- if ($f ne '\fR') { $sequence .= $f }
- $last = $f;
- $sequence;
- }
- >gxe;
- return $text;
-}
-
-# Unfortunately, there is a bug in Solaris 2.6 nroff (not present in GNU
-# groff) where the sequence \fB\fP\f(CW\fP leaves the font set to B rather
-# than R, presumably because \f(CW doesn't actually do a font change. To work
-# around this, use a separate textmapfonts for text blocks where the default
-# font is always R and only use the smart mapfonts for headings.
-sub textmapfonts {
- my ($self, $text) = @_;
- my ($fixed, $bold, $italic) = (0, 0, 0);
- my %magic = (F => \$fixed, B => \$bold, I => \$italic);
- $text =~ s<
- \\f\((.)(.)
- > <
- ${ $magic{$1} } += ($2 eq 'S') ? 1 : -1;
- $$self{FONTS}{ ($fixed && 1) . ($bold && 1) . ($italic && 1) };
- >gxe;
- return $text;
-}
-
-# Given a command and a single argument that may or may not contain double
-# quotes, handle double-quote formatting for it. If there are no double
-# quotes, just return the command followed by the argument in double quotes.
-# If there are double quotes, use an if statement to test for nroff, and for
-# nroff output the command followed by the argument in double quotes with
-# embedded double quotes doubled. For other formatters, remap paired double
-# quotes to LQUOTE and RQUOTE.
-sub switchquotes {
- my ($self, $command, $text, $extra) = @_;
- $text =~ s/\\\*\([LR]\"/\"/g;
-
- # We also have to deal with \*C` and \*C', which are used to add the
- # quotes around C<> text, since they may expand to " and if they do this
- # confuses the .SH macros and the like no end. Expand them ourselves.
- # Also separate troff from nroff if there are any fixed-width fonts in use
- # to work around problems with Solaris nroff.
- my $c_is_quote = ($$self{LQUOTE} =~ /\"/) || ($$self{RQUOTE} =~ /\"/);
- my $fixedpat = join '|', @{ $$self{FONTS} }{'100', '101', '110', '111'};
- $fixedpat =~ s/\\/\\\\/g;
- $fixedpat =~ s/\(/\\\(/g;
- if ($text =~ m/\"/ || $text =~ m/$fixedpat/) {
- $text =~ s/\"/\"\"/g;
- my $nroff = $text;
- my $troff = $text;
- $troff =~ s/\"\"([^\"]*)\"\"/\`\`$1\'\'/g;
- if ($c_is_quote and $text =~ m/\\\*\(C[\'\`]/) {
- $nroff =~ s/\\\*\(C\`/$$self{LQUOTE}/g;
- $nroff =~ s/\\\*\(C\'/$$self{RQUOTE}/g;
- $troff =~ s/\\\*\(C[\'\`]//g;
- }
- $nroff = qq("$nroff") . ($extra ? " $extra" : '');
- $troff = qq("$troff") . ($extra ? " $extra" : '');
-
- # Work around the Solaris nroff bug where \f(CW\fP leaves the font set
- # to Roman rather than the actual previous font when used in headings.
- # troff output may still be broken, but at least we can fix nroff by
- # just switching the font changes to the non-fixed versions.
- $nroff =~ s/\Q$$self{FONTS}{100}\E(.*?)\\f[PR]/$1/g;
- $nroff =~ s/\Q$$self{FONTS}{101}\E(.*?)\\f([PR])/\\fI$1\\f$2/g;
- $nroff =~ s/\Q$$self{FONTS}{110}\E(.*?)\\f([PR])/\\fB$1\\f$2/g;
- $nroff =~ s/\Q$$self{FONTS}{111}\E(.*?)\\f([PR])/\\f\(BI$1\\f$2/g;
-
- # Now finally output the command. Bother with .ie only if the nroff
- # and troff output aren't the same.
- if ($nroff ne $troff) {
- return ".ie n $command $nroff\n.el $command $troff\n";
- } else {
- return "$command $nroff\n";
- }
- } else {
- $text = qq("$text") . ($extra ? " $extra" : '');
- return "$command $text\n";
- }
-}
-
-# Protect leading quotes and periods against interpretation as commands. Also
-# protect anything starting with a backslash, since it could expand or hide
-# something that *roff would interpret as a command. This is overkill, but
-# it's much simpler than trying to parse *roff here.
-sub protect {
- my ($self, $text) = @_;
- $text =~ s/^([.\'\\])/\\&$1/mg;
- return $text;
-}
-
-# Make vertical whitespace if NEEDSPACE is set, appropriate to the indentation
-# level the situation. This function is needed since in *roff one has to
-# create vertical whitespace after paragraphs and between some things, but
-# other macros create their own whitespace. Also close out a sequence of
-# repeated =items, since calling makespace means we're about to begin the item
-# body.
-sub makespace {
- my ($self) = @_;
- $self->output (".PD\n") if $$self{ITEMS} > 1;
- $$self{ITEMS} = 0;
- $self->output ($$self{INDENT} > 0 ? ".Sp\n" : ".PP\n")
- if $$self{NEEDSPACE};
-}
-
-# Output any pending index entries, and optionally an index entry given as an
-# argument. Support multiple index entries in X<> separated by slashes, and
-# strip special escapes from index entries.
-sub outindex {
- my ($self, $section, $index) = @_;
- my @entries = map { split m%\s*/\s*% } @{ $$self{INDEX} };
- return unless ($section || @entries);
-
- # We're about to output all pending entries, so clear our pending queue.
- $$self{INDEX} = [];
-
- # Build the output. Regular index entries are marked Xref, and headings
- # pass in their own section. Undo some *roff formatting on headings.
- my @output;
- if (@entries) {
- push @output, [ 'Xref', join (' ', @entries) ];
- }
- if ($section) {
- $index =~ s/\\-/-/g;
- $index =~ s/\\(?:s-?\d|.\(..|.)//g;
- push @output, [ $section, $index ];
- }
-
- # Print out the .IX commands.
- for (@output) {
- my ($type, $entry) = @$_;
- $entry =~ s/\"/\"\"/g;
- $self->output (".IX $type " . '"' . $entry . '"' . "\n");
- }
-}
-
-# Output some text, without any additional changes.
-sub output {
- my ($self, @text) = @_;
- print { $$self{output_fh} } @text;
-}
-
-##############################################################################
-# Document initialization
-##############################################################################
-
-# Handle the start of the document. Here we handle empty documents, as well
-# as setting up our basic macros in a preamble and building the page title.
-sub start_document {
- my ($self, $attrs) = @_;
- if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) {
- DEBUG and print "Document is contentless\n";
- $$self{CONTENTLESS} = 1;
- return;
- }
-
- # If we were given the utf8 option, set an output encoding on our file
- # handle. Wrap in an eval in case we're using a version of Perl too old
- # to understand this.
- #
- # This is evil because it changes the global state of a file handle that
- # we may not own. However, we can't just blindly encode all output, since
- # there may be a pre-applied output encoding (such as from PERL_UNICODE)
- # and then we would double-encode. This seems to be the least bad
- # approach.
- if ($$self{utf8}) {
- eval { binmode ($$self{output_fh}, ':encoding(UTF-8)') };
- }
-
- # Determine information for the preamble and then output it.
- my ($name, $section);
- if (defined $$self{name}) {
- $name = $$self{name};
- $section = $$self{section} || 1;
- } else {
- ($name, $section) = $self->devise_title;
- }
- my $date = $$self{date} || $self->devise_date;
- $self->preamble ($name, $section, $date)
- unless $self->bare_output or DEBUG > 9;
-
- # Initialize a few per-document variables.
- $$self{INDENT} = 0; # Current indentation level.
- $$self{INDENTS} = []; # Stack of indentations.
- $$self{INDEX} = []; # Index keys waiting to be printed.
- $$self{IN_NAME} = 0; # Whether processing the NAME section.
- $$self{ITEMS} = 0; # The number of consecutive =items.
- $$self{ITEMTYPES} = []; # Stack of =item types, one per list.
- $$self{SHIFTWAIT} = 0; # Whether there is a shift waiting.
- $$self{SHIFTS} = []; # Stack of .RS shifts.
- $$self{PENDING} = [[]]; # Pending output.
-}
-
-# Handle the end of the document. This does nothing but print out a final
-# comment at the end of the document under debugging.
-sub end_document {
- my ($self) = @_;
- return if $self->bare_output;
- return if ($$self{CONTENTLESS} && !$$self{ALWAYS_EMIT_SOMETHING});
- $self->output (q(.\" [End document]) . "\n") if DEBUG;
-}
-
-# Try to figure out the name and section from the file name and return them as
-# a list, returning an empty name and section 1 if we can't find any better
-# information. Uses File::Basename and File::Spec as necessary.
-sub devise_title {
- my ($self) = @_;
- my $name = $self->source_filename || '';
- my $section = $$self{section} || 1;
- $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i);
- $name =~ s/\.p(od|[lm])\z//i;
-
- # If the section isn't 3, then the name defaults to just the basename of
- # the file. Otherwise, assume we're dealing with a module. We want to
- # figure out the full module name from the path to the file, but we don't
- # want to include too much of the path into the module name. Lose
- # anything up to the first off:
- #
- # */lib/*perl*/ standard or site_perl module
- # */*perl*/lib/ from -Dprefix=/opt/perl
- # */*perl*/ random module hierarchy
- #
- # which works. Also strip off a leading site, site_perl, or vendor_perl
- # component, any OS-specific component, and any version number component,
- # and strip off an initial component of "lib" or "blib/lib" since that's
- # what ExtUtils::MakeMaker creates. splitdir requires at least File::Spec
- # 0.8.
- if ($section !~ /^3/) {
- require File::Basename;
- $name = uc File::Basename::basename ($name);
- } else {
- require File::Spec;
- my ($volume, $dirs, $file) = File::Spec->splitpath ($name);
- my @dirs = File::Spec->splitdir ($dirs);
- my $cut = 0;
- my $i;
- for ($i = 0; $i < @dirs; $i++) {
- if ($dirs[$i] =~ /perl/) {
- $cut = $i + 1;
- $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib');
- last;
- }
- }
- if ($cut > 0) {
- splice (@dirs, 0, $cut);
- shift @dirs if ($dirs[0] =~ /^(site|vendor)(_perl)?$/);
- shift @dirs if ($dirs[0] =~ /^[\d.]+$/);
- shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/);
- }
- shift @dirs if $dirs[0] eq 'lib';
- splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib');
-
- # Remove empty directories when building the module name; they
- # occur too easily on Unix by doubling slashes.
- $name = join ('::', (grep { $_ ? $_ : () } @dirs), $file);
- }
- return ($name, $section);
-}
-
-# Determine the modification date and return that, properly formatted in ISO
-# format. If we can't get the modification date of the input, instead use the
-# current time. Pod::Simple returns a completely unuseful stringified file
-# handle as the source_filename for input from a file handle, so we have to
-# deal with that as well.
-sub devise_date {
- my ($self) = @_;
- my $input = $self->source_filename;
- my $time;
- if ($input) {
- $time = (stat $input)[9] || time;
- } else {
- $time = time;
- }
- return strftime ('%Y-%m-%d', localtime $time);
-}
-
-# Print out the preamble and the title. The meaning of the arguments to .TH
-# unfortunately vary by system; some systems consider the fourth argument to
-# be a "source" and others use it as a version number. Generally it's just
-# presented as the left-side footer, though, so it doesn't matter too much if
-# a particular system gives it another interpretation.
-#
-# The order of date and release used to be reversed in older versions of this
-# module, but this order is correct for both Solaris and Linux.
-sub preamble {
- my ($self, $name, $section, $date) = @_;
- my $preamble = $self->preamble_template (!$$self{utf8});
-
- # Build the index line and make sure that it will be syntactically valid.
- my $index = "$name $section";
- $index =~ s/\"/\"\"/g;
-
- # If name or section contain spaces, quote them (section really never
- # should, but we may as well be cautious).
- for ($name, $section) {
- if (/\s/) {
- s/\"/\"\"/g;
- $_ = '"' . $_ . '"';
- }
- }
-
- # Double quotes in date, since it will be quoted.
- $date =~ s/\"/\"\"/g;
-
- # Substitute into the preamble the configuration options.
- $preamble =~ s/\@CFONT\@/$$self{fixed}/;
- $preamble =~ s/\@LQUOTE\@/$$self{LQUOTE}/;
- $preamble =~ s/\@RQUOTE\@/$$self{RQUOTE}/;
- chomp $preamble;
-
- # Get the version information.
- my $version = $self->version_report;
-
- # Finally output everything.
- $self->output (<<"----END OF HEADER----");
-.\\" Automatically generated by $version
-.\\"
-.\\" Standard preamble:
-.\\" ========================================================================
-$preamble
-.\\" ========================================================================
-.\\"
-.IX Title "$index"
-.TH $name $section "$date" "$$self{release}" "$$self{center}"
-.\\" For nroff, turn off justification. Always turn off hyphenation; it makes
-.\\" way too many mistakes in technical documents.
-.if n .ad l
-.nh
-----END OF HEADER----
- $self->output (".\\\" [End of preamble]\n") if DEBUG;
-}
-
-##############################################################################
-# Text blocks
-##############################################################################
-
-# Handle a basic block of text. The only tricky part of this is if this is
-# the first paragraph of text after an =over, in which case we have to change
-# indentations for *roff.
-sub cmd_para {
- my ($self, $attrs, $text) = @_;
- my $line = $$attrs{start_line};
-
- # Output the paragraph. We also have to handle =over without =item. If
- # there's an =over without =item, SHIFTWAIT will be set, and we need to
- # handle creation of the indent here. Add the shift to SHIFTS so that it
- # will be cleaned up on =back.
- $self->makespace;
- if ($$self{SHIFTWAIT}) {
- $self->output (".RS $$self{INDENT}\n");
- push (@{ $$self{SHIFTS} }, $$self{INDENT});
- $$self{SHIFTWAIT} = 0;
- }
-
- # Add the line number for debugging, but not in the NAME section just in
- # case the comment would confuse apropos.
- $self->output (".\\\" [At source line $line]\n")
- if defined ($line) && DEBUG && !$$self{IN_NAME};
-
- # Force exactly one newline at the end and strip unwanted trailing
- # whitespace at the end.
- $text =~ s/\s*$/\n/;
-
- # Output the paragraph.
- $self->output ($self->protect ($self->textmapfonts ($text)));
- $self->outindex;
- $$self{NEEDSPACE} = 1;
- return '';
-}
-
-# Handle a verbatim paragraph. Put a null token at the beginning of each line
-# to protect against commands and wrap in .Vb/.Ve (which we define in our
-# prelude).
-sub cmd_verbatim {
- my ($self, $attrs, $text) = @_;
-
- # Ignore an empty verbatim paragraph.
- return unless $text =~ /\S/;
-
- # Force exactly one newline at the end and strip unwanted trailing
- # whitespace at the end.
- $text =~ s/\s*$/\n/;
-
- # Get a count of the number of lines before the first blank line, which
- # we'll pass to .Vb as its parameter. This tells *roff to keep that many
- # lines together. We don't want to tell *roff to keep huge blocks
- # together.
- my @lines = split (/\n/, $text);
- my $unbroken = 0;
- for (@lines) {
- last if /^\s*$/;
- $unbroken++;
- }
- $unbroken = 10 if ($unbroken > 12 && !$$self{MAGIC_VNOPAGEBREAK_LIMIT});
-
- # Prepend a null token to each line.
- $text =~ s/^/\\&/gm;
-
- # Output the results.
- $self->makespace;
- $self->output (".Vb $unbroken\n$text.Ve\n");
- $$self{NEEDSPACE} = 1;
- return '';
-}
-
-# Handle literal text (produced by =for and similar constructs). Just output
-# it with the minimum of changes.
-sub cmd_data {
- my ($self, $attrs, $text) = @_;
- $text =~ s/^\n+//;
- $text =~ s/\n{0,2}$/\n/;
- $self->output ($text);
- return '';
-}
-
-##############################################################################
-# Headings
-##############################################################################
-
-# Common code for all headings. This is called before the actual heading is
-# output. It returns the cleaned up heading text (putting the heading all on
-# one line) and may do other things, like closing bad =item blocks.
-sub heading_common {
- my ($self, $text, $line) = @_;
- $text =~ s/\s+$//;
- $text =~ s/\s*\n\s*/ /g;
-
- # This should never happen; it means that we have a heading after =item
- # without an intervening =back. But just in case, handle it anyway.
- if ($$self{ITEMS} > 1) {
- $$self{ITEMS} = 0;
- $self->output (".PD\n");
- }
-
- # Output the current source line.
- $self->output ( ".\\\" [At source line $line]\n" )
- if defined ($line) && DEBUG;
- return $text;
-}
-
-# First level heading. We can't output .IX in the NAME section due to a bug
-# in some versions of catman, so don't output a .IX for that section. .SH
-# already uses small caps, so remove \s0 and \s-1. Maintain IN_NAME as
-# appropriate.
-sub cmd_head1 {
- my ($self, $attrs, $text) = @_;
- $text =~ s/\\s-?\d//g;
- $text = $self->heading_common ($text, $$attrs{start_line});
- my $isname = ($text eq 'NAME' || $text =~ /\(NAME\)/);
- $self->output ($self->switchquotes ('.SH', $self->mapfonts ($text)));
- $self->outindex ('Header', $text) unless $isname;
- $$self{NEEDSPACE} = 0;
- $$self{IN_NAME} = $isname;
- return '';
-}
-
-# Second level heading.
-sub cmd_head2 {
- my ($self, $attrs, $text) = @_;
- $text = $self->heading_common ($text, $$attrs{start_line});
- $self->output ($self->switchquotes ('.SS', $self->mapfonts ($text)));
- $self->outindex ('Subsection', $text);
- $$self{NEEDSPACE} = 0;
- return '';
-}
-
-# Third level heading. *roff doesn't have this concept, so just put the
-# heading in italics as a normal paragraph.
-sub cmd_head3 {
- my ($self, $attrs, $text) = @_;
- $text = $self->heading_common ($text, $$attrs{start_line});
- $self->makespace;
- $self->output ($self->textmapfonts ('\f(IS' . $text . '\f(IE') . "\n");
- $self->outindex ('Subsection', $text);
- $$self{NEEDSPACE} = 1;
- return '';
-}
-
-# Fourth level heading. *roff doesn't have this concept, so just put the
-# heading as a normal paragraph.
-sub cmd_head4 {
- my ($self, $attrs, $text) = @_;
- $text = $self->heading_common ($text, $$attrs{start_line});
- $self->makespace;
- $self->output ($self->textmapfonts ($text) . "\n");
- $self->outindex ('Subsection', $text);
- $$self{NEEDSPACE} = 1;
- return '';
-}
-
-##############################################################################
-# Formatting codes
-##############################################################################
-
-# All of the formatting codes that aren't handled internally by the parser,
-# other than L<> and X<>.
-sub cmd_b { return '\f(BS' . $_[2] . '\f(BE' }
-sub cmd_i { return '\f(IS' . $_[2] . '\f(IE' }
-sub cmd_f { return '\f(IS' . $_[2] . '\f(IE' }
-sub cmd_c { return $_[0]->quote_literal ($_[2]) }
-
-# Index entries are just added to the pending entries.
-sub cmd_x {
- my ($self, $attrs, $text) = @_;
- push (@{ $$self{INDEX} }, $text);
- return '';
-}
-
-# Links reduce to the text that we're given, wrapped in angle brackets if it's
-# a URL.
-sub cmd_l {
- my ($self, $attrs, $text) = @_;
- return $$attrs{type} eq 'url' ? "<$text>" : $text;
-}
-
-##############################################################################
-# List handling
-##############################################################################
-
-# Handle the beginning of an =over block. Takes the type of the block as the
-# first argument, and then the attr hash. This is called by the handlers for
-# the four different types of lists (bullet, number, text, and block).
-sub over_common_start {
- my ($self, $type, $attrs) = @_;
- my $line = $$attrs{start_line};
- my $indent = $$attrs{indent};
- DEBUG > 3 and print " Starting =over $type (line $line, indent ",
- ($indent || '?'), "\n";
-
- # Find the indentation level.
- unless (defined ($indent) && $indent =~ /^[-+]?\d{1,4}\s*$/) {
- $indent = $$self{indent};
- }
-
- # If we've gotten multiple indentations in a row, we need to emit the
- # pending indentation for the last level that we saw and haven't acted on
- # yet. SHIFTS is the stack of indentations that we've actually emitted
- # code for.
- if (@{ $$self{SHIFTS} } < @{ $$self{INDENTS} }) {
- $self->output (".RS $$self{INDENT}\n");
- push (@{ $$self{SHIFTS} }, $$self{INDENT});
- }
-
- # Now, do record-keeping. INDENTS is a stack of indentations that we've
- # seen so far, and INDENT is the current level of indentation. ITEMTYPES
- # is a stack of list types that we've seen.
- push (@{ $$self{INDENTS} }, $$self{INDENT});
- push (@{ $$self{ITEMTYPES} }, $type);
- $$self{INDENT} = $indent + 0;
- $$self{SHIFTWAIT} = 1;
-}
-
-# End an =over block. Takes no options other than the class pointer.
-# Normally, once we close a block and therefore remove something from INDENTS,
-# INDENTS will now be longer than SHIFTS, indicating that we also need to emit
-# *roff code to close the indent. This isn't *always* true, depending on the
-# circumstance. If we're still inside an indentation, we need to emit another
-# .RE and then a new .RS to unconfuse *roff.
-sub over_common_end {
- my ($self) = @_;
- DEBUG > 3 and print " Ending =over\n";
- $$self{INDENT} = pop @{ $$self{INDENTS} };
- pop @{ $$self{ITEMTYPES} };
-
- # If we emitted code for that indentation, end it.
- if (@{ $$self{SHIFTS} } > @{ $$self{INDENTS} }) {
- $self->output (".RE\n");
- pop @{ $$self{SHIFTS} };
- }
-
- # If we're still in an indentation, *roff will have now lost track of the
- # right depth of that indentation, so fix that.
- if (@{ $$self{INDENTS} } > 0) {
- $self->output (".RE\n");
- $self->output (".RS $$self{INDENT}\n");
- }
- $$self{NEEDSPACE} = 1;
- $$self{SHIFTWAIT} = 0;
-}
-
-# Dispatch the start and end calls as appropriate.
-sub start_over_bullet { my $s = shift; $s->over_common_start ('bullet', @_) }
-sub start_over_number { my $s = shift; $s->over_common_start ('number', @_) }
-sub start_over_text { my $s = shift; $s->over_common_start ('text', @_) }
-sub start_over_block { my $s = shift; $s->over_common_start ('block', @_) }
-sub end_over_bullet { $_[0]->over_common_end }
-sub end_over_number { $_[0]->over_common_end }
-sub end_over_text { $_[0]->over_common_end }
-sub end_over_block { $_[0]->over_common_end }
-
-# The common handler for all item commands. Takes the type of the item, the
-# attributes, and then the text of the item.
-#
-# Emit an index entry for anything that's interesting, but don't emit index
-# entries for things like bullets and numbers. Newlines in an item title are
-# turned into spaces since *roff can't handle them embedded.
-sub item_common {
- my ($self, $type, $attrs, $text) = @_;
- my $line = $$attrs{start_line};
- DEBUG > 3 and print " $type item (line $line): $text\n";
-
- # Clean up the text. We want to end up with two variables, one ($text)
- # which contains any body text after taking out the item portion, and
- # another ($item) which contains the actual item text.
- $text =~ s/\s+$//;
- my ($item, $index);
- if ($type eq 'bullet') {
- $item = "\\\(bu";
- $text =~ s/\n*$/\n/;
- } elsif ($type eq 'number') {
- $item = $$attrs{number} . '.';
- } else {
- $item = $text;
- $item =~ s/\s*\n\s*/ /g;
- $text = '';
- $index = $item if ($item =~ /\w/);
- }
-
- # Take care of the indentation. If shifts and indents are equal, close
- # the top shift, since we're about to create an indentation with .IP.
- # Also output .PD 0 to turn off spacing between items if this item is
- # directly following another one. We only have to do that once for a
- # whole chain of items so do it for the second item in the change. Note
- # that makespace is what undoes this.
- if (@{ $$self{SHIFTS} } == @{ $$self{INDENTS} }) {
- $self->output (".RE\n");
- pop @{ $$self{SHIFTS} };
- }
- $self->output (".PD 0\n") if ($$self{ITEMS} == 1);
-
- # Now, output the item tag itself.
- $item = $self->textmapfonts ($item);
- $self->output ($self->switchquotes ('.IP', $item, $$self{INDENT}));
- $$self{NEEDSPACE} = 0;
- $$self{ITEMS}++;
- $$self{SHIFTWAIT} = 0;
-
- # If body text for this item was included, go ahead and output that now.
- if ($text) {
- $text =~ s/\s*$/\n/;
- $self->makespace;
- $self->output ($self->protect ($self->textmapfonts ($text)));
- $$self{NEEDSPACE} = 1;
- }
- $self->outindex ($index ? ('Item', $index) : ());
-}
-
-# Dispatch the item commands to the appropriate place.
-sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
-sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
-sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
-sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
-
-##############################################################################
-# Backward compatibility
-##############################################################################
-
-# Reset the underlying Pod::Simple object between calls to parse_from_file so
-# that the same object can be reused to convert multiple pages.
-sub parse_from_file {
- my $self = shift;
- $self->reinit;
-
- # Fake the old cutting option to Pod::Parser. This fiddings with internal
- # Pod::Simple state and is quite ugly; we need a better approach.
- if (ref ($_[0]) eq 'HASH') {
- my $opts = shift @_;
- if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
- $$self{in_pod} = 1;
- $$self{last_was_blank} = 1;
- }
- }
-
- # Do the work.
- my $retval = $self->SUPER::parse_from_file (@_);
-
- # Flush output, since Pod::Simple doesn't do this. Ideally we should also
- # close the file descriptor if we had to open one, but we can't easily
- # figure this out.
- my $fh = $self->output_fh ();
- my $oldfh = select $fh;
- my $oldflush = $|;
- $| = 1;
- print $fh '';
- $| = $oldflush;
- select $oldfh;
- return $retval;
-}
-
-# Pod::Simple failed to provide this backward compatibility function, so
-# implement it ourselves. File handles are one of the inputs that
-# parse_from_file supports.
-sub parse_from_filehandle {
- my $self = shift;
- $self->parse_from_file (@_);
-}
-
-##############################################################################
-# Translation tables
-##############################################################################
-
-# The following table is adapted from Tom Christiansen's pod2man. It assumes
-# that the standard preamble has already been printed, since that's what
-# defines all of the accent marks. We really want to do something better than
-# this when *roff actually supports other character sets itself, since these
-# results are pretty poor.
-#
-# This only works in an ASCII world. What to do in a non-ASCII world is very
-# unclear -- hopefully we can assume UTF-8 and just leave well enough alone.
- at ESCAPES{0xA0 .. 0xFF} = (
- "\\ ", undef, undef, undef, undef, undef, undef, undef,
- undef, undef, undef, undef, undef, "\\%", undef, undef,
-
- undef, undef, undef, undef, undef, undef, undef, undef,
- undef, undef, undef, undef, undef, undef, undef, undef,
-
- "A\\*`", "A\\*'", "A\\*^", "A\\*~", "A\\*:", "A\\*o", "\\*(AE", "C\\*,",
- "E\\*`", "E\\*'", "E\\*^", "E\\*:", "I\\*`", "I\\*'", "I\\*^", "I\\*:",
-
- "\\*(D-", "N\\*~", "O\\*`", "O\\*'", "O\\*^", "O\\*~", "O\\*:", undef,
- "O\\*/", "U\\*`", "U\\*'", "U\\*^", "U\\*:", "Y\\*'", "\\*(Th", "\\*8",
-
- "a\\*`", "a\\*'", "a\\*^", "a\\*~", "a\\*:", "a\\*o", "\\*(ae", "c\\*,",
- "e\\*`", "e\\*'", "e\\*^", "e\\*:", "i\\*`", "i\\*'", "i\\*^", "i\\*:",
-
- "\\*(d-", "n\\*~", "o\\*`", "o\\*'", "o\\*^", "o\\*~", "o\\*:", undef,
- "o\\*/" , "u\\*`", "u\\*'", "u\\*^", "u\\*:", "y\\*'", "\\*(th", "y\\*:",
-) if ASCII;
-
-##############################################################################
-# Premable
-##############################################################################
-
-# The following is the static preamble which starts all *roff output we
-# generate. Most is static except for the font to use as a fixed-width font,
-# which is designed by @CFONT@, and the left and right quotes to use for C<>
-# text, designated by @LQOUTE@ and @RQUOTE at . However, the second part, which
-# defines the accent marks, is only used if $escapes is set to true.
-sub preamble_template {
- my ($self, $accents) = @_;
- my $preamble = <<'----END OF PREAMBLE----';
-.de Sp \" Vertical space (when we can't use .PP)
-.if t .sp .5v
-.if n .sp
-..
-.de Vb \" Begin verbatim text
-.ft @CFONT@
-.nf
-.ne \\$1
-..
-.de Ve \" End verbatim text
-.ft R
-.fi
-..
-.\" Set up some character translations and predefined strings. \*(-- will
-.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left
-.\" double quote, and \*(R" will give a right double quote. \*(C+ will
-.\" give a nicer C++. Capital omega is used to do unbreakable dashes and
-.\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff,
-.\" nothing in troff, for use with C<>.
-.tr \(*W-
-.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
-.ie n \{\
-. ds -- \(*W-
-. ds PI pi
-. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
-. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
-. ds L" ""
-. ds R" ""
-. ds C` @LQUOTE@
-. ds C' @RQUOTE@
-'br\}
-.el\{\
-. ds -- \|\(em\|
-. ds PI \(*p
-. ds L" ``
-. ds R" ''
-'br\}
-.\"
-.\" Escape single quotes in literal strings from groff's Unicode transform.
-.ie \n(.g .ds Aq \(aq
-.el .ds Aq '
-.\"
-.\" If the F register is turned on, we'll generate index entries on stderr for
-.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index
-.\" entries marked with X<> in POD. Of course, you'll have to process the
-.\" output yourself in some meaningful fashion.
-.ie \nF \{\
-. de IX
-. tm Index:\\$1\t\\n%\t"\\$2"
-..
-. nr % 0
-. rr F
-.\}
-.el \{\
-. de IX
-..
-.\}
-----END OF PREAMBLE----
-
- if ($accents) {
- $preamble .= <<'----END OF PREAMBLE----'
-.\"
-.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2).
-.\" Fear. Run. Save yourself. No user-serviceable parts.
-. \" fudge factors for nroff and troff
-.if n \{\
-. ds #H 0
-. ds #V .8m
-. ds #F .3m
-. ds #[ \f1
-. ds #] \fP
-.\}
-.if t \{\
-. ds #H ((1u-(\\\\n(.fu%2u))*.13m)
-. ds #V .6m
-. ds #F 0
-. ds #[ \&
-. ds #] \&
-.\}
-. \" simple accents for nroff and troff
-.if n \{\
-. ds ' \&
-. ds ` \&
-. ds ^ \&
-. ds , \&
-. ds ~ ~
-. ds /
-.\}
-.if t \{\
-. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u"
-. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u'
-. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u'
-. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u'
-. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u'
-. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u'
-.\}
-. \" troff and (daisy-wheel) nroff accents
-.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V'
-.ds 8 \h'\*(#H'\(*b\h'-\*(#H'
-.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#]
-.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H'
-.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u'
-.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#]
-.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#]
-.ds ae a\h'-(\w'a'u*4/10)'e
-.ds Ae A\h'-(\w'A'u*4/10)'E
-. \" corrections for vroff
-.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u'
-.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u'
-. \" for low resolution devices (crt and lpr)
-.if \n(.H>23 .if \n(.V>19 \
-\{\
-. ds : e
-. ds 8 ss
-. ds o a
-. ds d- d\h'-1'\(ga
-. ds D- D\h'-1'\(hy
-. ds th \o'bp'
-. ds Th \o'LP'
-. ds ae ae
-. ds Ae AE
-.\}
-.rm #[ #] #H #V #F C
-----END OF PREAMBLE----
-#`# for cperl-mode
- }
- return $preamble;
-}
-
-##############################################################################
-# Module return value and documentation
-##############################################################################
-
-1;
-__END__
-
-=head1 NAME
-
-Pod::Man - Convert POD data to formatted *roff input
-
-=for stopwords
-en em ALLCAPS teeny fixedbold fixeditalic fixedbolditalic stderr utf8
-UTF-8 Allbery Sean Burke Ossanna Solaris formatters troff uppercased
-Christiansen
-
-=head1 SYNOPSIS
-
- use Pod::Man;
- my $parser = Pod::Man->new (release => $VERSION, section => 8);
-
- # Read POD from STDIN and write to STDOUT.
- $parser->parse_file (\*STDIN);
-
- # Read POD from file.pod and write to file.1.
- $parser->parse_from_file ('file.pod', 'file.1');
-
-=head1 DESCRIPTION
-
-Pod::Man is a module to convert documentation in the POD format (the
-preferred language for documenting Perl) into *roff input using the man
-macro set. The resulting *roff code is suitable for display on a terminal
-using L<nroff(1)>, normally via L<man(1)>, or printing using L<troff(1)>.
-It is conventionally invoked using the driver script B<pod2man>, but it can
-also be used directly.
-
-As a derived class from Pod::Simple, Pod::Man supports the same methods and
-interfaces. See L<Pod::Simple> for all the details.
-
-new() can take options, in the form of key/value pairs that control the
-behavior of the parser. See below for details.
-
-If no options are given, Pod::Man uses the name of the input file with any
-trailing C<.pod>, C<.pm>, or C<.pl> stripped as the man page title, to
-section 1 unless the file ended in C<.pm> in which case it defaults to
-section 3, to a centered title of "User Contributed Perl Documentation", to
-a centered footer of the Perl version it is run with, and to a left-hand
-footer of the modification date of its input (or the current date if given
-C<STDIN> for input).
-
-Pod::Man assumes that your *roff formatters have a fixed-width font named
-C<CW>. If yours is called something else (like C<CR>), use the C<fixed>
-option to specify it. This generally only matters for troff output for
-printing. Similarly, you can set the fonts used for bold, italic, and
-bold italic fixed-width output.
-
-Besides the obvious pod conversions, Pod::Man also takes care of
-formatting func(), func(3), and simple variable references like $foo or
- at bar so you don't have to use code escapes for them; complex expressions
-like C<$fred{'stuff'}> will still need to be escaped, though. It also
-translates dashes that aren't used as hyphens into en dashes, makes long
-dashes--like this--into proper em dashes, fixes "paired quotes," makes C++
-look right, puts a little space between double underscores, makes ALLCAPS
-a teeny bit smaller in B<troff>, and escapes stuff that *roff treats as
-special so that you don't have to.
-
-The recognized options to new() are as follows. All options take a single
-argument.
-
-=over 4
-
-=item center
-
-Sets the centered page header to use instead of "User Contributed Perl
-Documentation".
-
-=item date
-
-Sets the left-hand footer. By default, the modification date of the input
-file will be used, or the current date if stat() can't find that file (the
-case if the input is from C<STDIN>), and the date will be formatted as
-C<YYYY-MM-DD>.
-
-=item fixed
-
-The fixed-width font to use for verbatim text and code. Defaults to
-C<CW>. Some systems may want C<CR> instead. Only matters for B<troff>
-output.
-
-=item fixedbold
-
-Bold version of the fixed-width font. Defaults to C<CB>. Only matters
-for B<troff> output.
-
-=item fixeditalic
-
-Italic version of the fixed-width font (actually, something of a misnomer,
-since most fixed-width fonts only have an oblique version, not an italic
-version). Defaults to C<CI>. Only matters for B<troff> output.
-
-=item fixedbolditalic
-
-Bold italic (probably actually oblique) version of the fixed-width font.
-Pod::Man doesn't assume you have this, and defaults to C<CB>. Some
-systems (such as Solaris) have this font available as C<CX>. Only matters
-for B<troff> output.
-
-=item name
-
-Set the name of the manual page. Without this option, the manual name is
-set to the uppercased base name of the file being converted unless the
-manual section is 3, in which case the path is parsed to see if it is a Perl
-module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted into
-a name like C<Pod::Man>. This option, if given, overrides any automatic
-determination of the name.
-
-=item quotes
-
-Sets the quote marks used to surround CE<lt>> text. If the value is a
-single character, it is used as both the left and right quote; if it is two
-characters, the first character is used as the left quote and the second as
-the right quoted; and if it is four characters, the first two are used as
-the left quote and the second two as the right quote.
-
-This may also be set to the special value C<none>, in which case no quote
-marks are added around CE<lt>> text (but the font is still changed for troff
-output).
-
-=item release
-
-Set the centered footer. By default, this is the version of Perl you run
-Pod::Man under. Note that some system an macro sets assume that the
-centered footer will be a modification date and will prepend something like
-"Last modified: "; if this is the case, you may want to set C<release> to
-the last modified date and C<date> to the version number.
-
-=item section
-
-Set the section for the C<.TH> macro. The standard section numbering
-convention is to use 1 for user commands, 2 for system calls, 3 for
-functions, 4 for devices, 5 for file formats, 6 for games, 7 for
-miscellaneous information, and 8 for administrator commands. There is a lot
-of variation here, however; some systems (like Solaris) use 4 for file
-formats, 5 for miscellaneous information, and 7 for devices. Still others
-use 1m instead of 8, or some mix of both. About the only section numbers
-that are reliably consistent are 1, 2, and 3.
-
-By default, section 1 will be used unless the file ends in C<.pm> in which
-case section 3 will be selected.
-
-=item stderr
-
-Send error messages about invalid POD to standard error instead of
-appending a POD ERRORS section to the generated *roff output.
-
-=item utf8
-
-By default, Pod::Man produces the most conservative possible *roff output
-to try to ensure that it will work with as many different *roff
-implementations as possible. Many *roff implementations cannot handle
-non-ASCII characters, so this means all non-ASCII characters are converted
-either to a *roff escape sequence that tries to create a properly accented
-character (at least for troff output) or to C<X>.
-
-If this option is set, Pod::Man will instead output UTF-8. If your *roff
-implementation can handle it, this is the best output format to use and
-avoids corruption of documents containing non-ASCII characters. However,
-be warned that *roff source with literal UTF-8 characters is not supported
-by many implementations and may even result in segfaults and other bad
-behavior.
-
-Be aware that, when using this option, the input encoding of your POD
-source must be properly declared unless it is US-ASCII or Latin-1. POD
-input without an C<=encoding> command will be assumed to be in Latin-1,
-and if it's actually in UTF-8, the output will be double-encoded. See
-L<perlpod(1)> for more information on the C<=encoding> command.
-
-=back
-
-The standard Pod::Simple method parse_file() takes one argument naming the
-POD file to read from. By default, the output is sent to C<STDOUT>, but
-this can be changed with the output_fd() method.
-
-The standard Pod::Simple method parse_from_file() takes up to two
-arguments, the first being the input file to read POD from and the second
-being the file to write the formatted output to.
-
-You can also call parse_lines() to parse an array of lines or
-parse_string_document() to parse a document already in memory. To put the
-output into a string instead of a file handle, call the output_string()
-method. See L<Pod::Simple> for the specific details.
-
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item roff font should be 1 or 2 chars, not "%s"
-
-(F) You specified a *roff font (using C<fixed>, C<fixedbold>, etc.) that
-wasn't either one or two characters. Pod::Man doesn't support *roff fonts
-longer than two characters, although some *roff extensions do (the canonical
-versions of B<nroff> and B<troff> don't either).
-
-=item Invalid quote specification "%s"
-
-(F) The quote specification given (the quotes option to the constructor) was
-invalid. A quote specification must be one, two, or four characters long.
-
-=back
-
-=head1 BUGS
-
-Encoding handling assumes that PerlIO is available and does not work
-properly if it isn't. The C<utf8> option is therefore not supported
-unless Perl is built with PerlIO support.
-
-There is currently no way to turn off the guesswork that tries to format
-unmarked text appropriately, and sometimes it isn't wanted (particularly
-when using POD to document something other than Perl). Most of the work
-toward fixing this has now been done, however, and all that's still needed
-is a user interface.
-
-The NAME section should be recognized specially and index entries emitted
-for everything in that section. This would have to be deferred until the
-next section, since extraneous things in NAME tends to confuse various man
-page processors. Currently, no index entries are emitted for anything in
-NAME.
-
-Pod::Man doesn't handle font names longer than two characters. Neither do
-most B<troff> implementations, but GNU troff does as an extension. It would
-be nice to support as an option for those who want to use it.
-
-The preamble added to each output file is rather verbose, and most of it
-is only necessary in the presence of non-ASCII characters. It would
-ideally be nice if all of those definitions were only output if needed,
-perhaps on the fly as the characters are used.
-
-Pod::Man is excessively slow.
-
-=head1 CAVEATS
-
-If Pod::Man is given the C<utf8> option, the encoding of its output file
-handle will be forced to UTF-8 if possible, overriding any existing
-encoding. This will be done even if the file handle is not created by
-Pod::Man and was passed in from outside. This maintains consistency
-regardless of PERL_UNICODE and other settings.
-
-The handling of hyphens and em dashes is somewhat fragile, and one may get
-the wrong one under some circumstances. This should only matter for
-B<troff> output.
-
-When and whether to use small caps is somewhat tricky, and Pod::Man doesn't
-necessarily get it right.
-
-Converting neutral double quotes to properly matched double quotes doesn't
-work unless there are no formatting codes between the quote marks. This
-only matters for troff output.
-
-=head1 AUTHOR
-
-Russ Allbery <rra at stanford.edu>, based I<very> heavily on the original
-B<pod2man> by Tom Christiansen <tchrist at mox.perl.com>. The modifications to
-work with Pod::Simple instead of Pod::Parser were originally contributed by
-Sean Burke (but I've since hacked them beyond recognition and all bugs are
-mine).
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
-Russ Allbery <rra at stanford.edu>.
-
-This program is free software; you may redistribute it and/or modify it
-under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-L<Pod::Simple>, L<perlpod(1)>, L<pod2man(1)>, L<nroff(1)>, L<troff(1)>,
-L<man(1)>, L<man(7)>
-
-Ossanna, Joseph F., and Brian W. Kernighan. "Troff User's Manual,"
-Computing Science Technical Report No. 54, AT&T Bell Laboratories. This is
-the best documentation of standard B<nroff> and B<troff>. At the time of
-this writing, it's available at
-L<http://www.cs.bell-labs.com/cm/cs/cstr.html>.
-
-The man page documenting the man macro set may be L<man(5)> instead of
-L<man(7)> on your system. Also, please see L<pod2man(1)> for extensive
-documentation on writing manual pages if you've not done it before and
-aren't familiar with the conventions.
-
-The current version of this module is always available from its web site at
-L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
-Perl core distribution as of 5.6.0.
-
-=cut
Deleted: trunk/contrib/perl/lib/Pod/ParseLink.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/ParseLink.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/ParseLink.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,182 +0,0 @@
-# Pod::ParseLink -- Parse an L<> formatting code in POD text.
-#
-# Copyright 2001, 2008 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-#
-# This module implements parsing of the text of an L<> formatting code as
-# defined in perlpodspec. It should be suitable for any POD formatter. It
-# exports only one function, parselink(), which returns the five-item parse
-# defined in perlpodspec.
-#
-# Perl core hackers, please note that this module is also separately
-# maintained outside of the Perl core as part of the podlators. Please send
-# me any patches at the address above in addition to sending them to the
-# standard Perl mailing lists.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Pod::ParseLink;
-
-require 5.004;
-
-use strict;
-use vars qw(@EXPORT @ISA $VERSION);
-
-use Exporter;
- at ISA = qw(Exporter);
- at EXPORT = qw(parselink);
-
-$VERSION = '1.09';
-
-##############################################################################
-# Implementation
-##############################################################################
-
-# Parse the name and section portion of a link into a name and section.
-sub _parse_section {
- my ($link) = @_;
- $link =~ s/^\s+//;
- $link =~ s/\s+$//;
-
- # If the whole link is enclosed in quotes, interpret it all as a section
- # even if it contains a slash.
- return (undef, $1) if ($link =~ /^"\s*(.*?)\s*"$/);
-
- # Split into page and section on slash, and then clean up quoting in the
- # section. If there is no section and the name contains spaces, also
- # guess that it's an old section link.
- my ($page, $section) = split (/\s*\/\s*/, $link, 2);
- $section =~ s/^"\s*(.*?)\s*"$/$1/ if $section;
- if ($page && $page =~ / / && !defined ($section)) {
- $section = $page;
- $page = undef;
- } else {
- $page = undef unless $page;
- $section = undef unless $section;
- }
- return ($page, $section);
-}
-
-# Infer link text from the page and section.
-sub _infer_text {
- my ($page, $section) = @_;
- my $inferred;
- if ($page && !$section) {
- $inferred = $page;
- } elsif (!$page && $section) {
- $inferred = '"' . $section . '"';
- } elsif ($page && $section) {
- $inferred = '"' . $section . '" in ' . $page;
- }
- return $inferred;
-}
-
-# Given the contents of an L<> formatting code, parse it into the link text,
-# the possibly inferred link text, the name or URL, the section, and the type
-# of link (pod, man, or url).
-sub parselink {
- my ($link) = @_;
- $link =~ s/\s+/ /g;
- if ($link =~ /\A\w+:[^:\s]\S*\Z/) {
- return (undef, $link, $link, undef, 'url');
- } else {
- my $text;
- if ($link =~ /\|/) {
- ($text, $link) = split (/\|/, $link, 2);
- }
- my ($name, $section) = _parse_section ($link);
- my $inferred = $text || _infer_text ($name, $section);
- my $type = ($name && $name =~ /\(\S*\)/) ? 'man' : 'pod';
- return ($text, $inferred, $name, $section, $type);
- }
-}
-
-##############################################################################
-# Module return value and documentation
-##############################################################################
-
-# Ensure we evaluate to true.
-1;
-__END__
-
-=head1 NAME
-
-Pod::ParseLink - Parse an LE<lt>E<gt> formatting code in POD text
-
-=for stopwords
-markup Allbery URL
-
-=head1 SYNOPSIS
-
- use Pod::ParseLink;
- my ($text, $inferred, $name, $section, $type) = parselink ($link);
-
-=head1 DESCRIPTION
-
-This module only provides a single function, parselink(), which takes the
-text of an LE<lt>E<gt> formatting code and parses it. It returns the
-anchor text for the link (if any was given), the anchor text possibly
-inferred from the name and section, the name or URL, the section if any,
-and the type of link. The type will be one of C<url>, C<pod>, or C<man>,
-indicating a URL, a link to a POD page, or a link to a Unix manual page.
-
-Parsing is implemented per L<perlpodspec>. For backward compatibility,
-links where there is no section and name contains spaces, or links where the
-entirety of the link (except for the anchor text if given) is enclosed in
-double-quotes are interpreted as links to a section (LE<lt>/sectionE<gt>).
-
-The inferred anchor text is implemented per L<perlpodspec>:
-
- L<name> => L<name|name>
- L</section> => L<"section"|/section>
- L<name/section> => L<"section" in name|name/section>
-
-The name may contain embedded EE<lt>E<gt> and ZE<lt>E<gt> formatting codes,
-and the section, anchor text, and inferred anchor text may contain any
-formatting codes. Any double quotes around the section are removed as part
-of the parsing, as is any leading or trailing whitespace.
-
-If the text of the LE<lt>E<gt> escape is entirely enclosed in double
-quotes, it's interpreted as a link to a section for backward
-compatibility.
-
-No attempt is made to resolve formatting codes. This must be done after
-calling parselink() (since EE<lt>E<gt> formatting codes can be used to
-escape characters that would otherwise be significant to the parser and
-resolving them before parsing would result in an incorrect parse of a
-formatting code like:
-
- L<verticalE<verbar>barE<sol>slash>
-
-which should be interpreted as a link to the C<vertical|bar/slash> POD page
-and not as a link to the C<slash> section of the C<bar> POD page with an
-anchor text of C<vertical>. Note that not only the anchor text will need to
-have formatting codes expanded, but so will the target of the link (to deal
-with EE<lt>E<gt> and ZE<lt>E<gt> formatting codes), and special handling of
-the section may be necessary depending on whether the translator wants to
-consider markup in sections to be significant when resolving links. See
-L<perlpodspec> for more information.
-
-=head1 SEE ALSO
-
-L<Pod::Parser>
-
-The current version of this module is always available from its web site at
-L<http://www.eyrie.org/~eagle/software/podlators/>.
-
-=head1 AUTHOR
-
-Russ Allbery <rra at stanford.edu>.
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2001, 2008 Russ Allbery <rra at stanford.edu>.
-
-This program is free software; you may redistribute it and/or modify it
-under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Pod/ParseUtils.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/ParseUtils.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/ParseUtils.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,855 +0,0 @@
-#############################################################################
-# Pod/ParseUtils.pm -- helpers for POD parsing and conversion
-#
-# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved.
-# This file is part of "PodParser". PodParser is free software;
-# you can redistribute it and/or modify it under the same terms
-# as Perl itself.
-#############################################################################
-
-package Pod::ParseUtils;
-use strict;
-
-use vars qw($VERSION);
-$VERSION = '1.36'; ## Current version of this package
-require 5.005; ## requires this Perl version or later
-
-=head1 NAME
-
-Pod::ParseUtils - helpers for POD parsing and conversion
-
-=head1 SYNOPSIS
-
- use Pod::ParseUtils;
-
- my $list = new Pod::List;
- my $link = Pod::Hyperlink->new('Pod::Parser');
-
-=head1 DESCRIPTION
-
-B<Pod::ParseUtils> contains a few object-oriented helper packages for
-POD parsing and processing (i.e. in POD formatters and translators).
-
-=cut
-
-#-----------------------------------------------------------------------------
-# Pod::List
-#
-# class to hold POD list info (=over, =item, =back)
-#-----------------------------------------------------------------------------
-
-package Pod::List;
-
-use Carp;
-
-=head2 Pod::List
-
-B<Pod::List> can be used to hold information about POD lists
-(written as =over ... =item ... =back) for further processing.
-The following methods are available:
-
-=over 4
-
-=item Pod::List-E<gt>new()
-
-Create a new list object. Properties may be specified through a hash
-reference like this:
-
- my $list = Pod::List->new({ -start => $., -indent => 4 });
-
-See the individual methods/properties for details.
-
-=cut
-
-sub new {
- my $this = shift;
- my $class = ref($this) || $this;
- my %params = @_;
- my $self = {%params};
- bless $self, $class;
- $self->initialize();
- return $self;
-}
-
-sub initialize {
- my $self = shift;
- $self->{-file} ||= 'unknown';
- $self->{-start} ||= 'unknown';
- $self->{-indent} ||= 4; # perlpod: "should be the default"
- $self->{_items} = [];
- $self->{-type} ||= '';
-}
-
-=item $list-E<gt>file()
-
-Without argument, retrieves the file name the list is in. This must
-have been set before by either specifying B<-file> in the B<new()>
-method or by calling the B<file()> method with a scalar argument.
-
-=cut
-
-# The POD file name the list appears in
-sub file {
- return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
-}
-
-=item $list-E<gt>start()
-
-Without argument, retrieves the line number where the list started.
-This must have been set before by either specifying B<-start> in the
-B<new()> method or by calling the B<start()> method with a scalar
-argument.
-
-=cut
-
-# The line in the file the node appears
-sub start {
- return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start};
-}
-
-=item $list-E<gt>indent()
-
-Without argument, retrieves the indent level of the list as specified
-in C<=over n>. This must have been set before by either specifying
-B<-indent> in the B<new()> method or by calling the B<indent()> method
-with a scalar argument.
-
-=cut
-
-# indent level
-sub indent {
- return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent};
-}
-
-=item $list-E<gt>type()
-
-Without argument, retrieves the list type, which can be an arbitrary value,
-e.g. C<OL>, C<UL>, ... when thinking the HTML way.
-This must have been set before by either specifying
-B<-type> in the B<new()> method or by calling the B<type()> method
-with a scalar argument.
-
-=cut
-
-# The type of the list (UL, OL, ...)
-sub type {
- return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
-}
-
-=item $list-E<gt>rx()
-
-Without argument, retrieves a regular expression for simplifying the
-individual item strings once the list type has been determined. Usage:
-E.g. when converting to HTML, one might strip the leading number in
-an ordered list as C<E<lt>OLE<gt>> already prints numbers itself.
-This must have been set before by either specifying
-B<-rx> in the B<new()> method or by calling the B<rx()> method
-with a scalar argument.
-
-=cut
-
-# The regular expression to simplify the items
-sub rx {
- return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx};
-}
-
-=item $list-E<gt>item()
-
-Without argument, retrieves the array of the items in this list.
-The items may be represented by any scalar.
-If an argument has been given, it is pushed on the list of items.
-
-=cut
-
-# The individual =items of this list
-sub item {
- my ($self,$item) = @_;
- if(defined $item) {
- push(@{$self->{_items}}, $item);
- return $item;
- }
- else {
- return @{$self->{_items}};
- }
-}
-
-=item $list-E<gt>parent()
-
-Without argument, retrieves information about the parent holding this
-list, which is represented as an arbitrary scalar.
-This must have been set before by either specifying
-B<-parent> in the B<new()> method or by calling the B<parent()> method
-with a scalar argument.
-
-=cut
-
-# possibility for parsers/translators to store information about the
-# lists's parent object
-sub parent {
- return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent};
-}
-
-=item $list-E<gt>tag()
-
-Without argument, retrieves information about the list tag, which can be
-any scalar.
-This must have been set before by either specifying
-B<-tag> in the B<new()> method or by calling the B<tag()> method
-with a scalar argument.
-
-=back
-
-=cut
-
-# possibility for parsers/translators to store information about the
-# list's object
-sub tag {
- return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag};
-}
-
-#-----------------------------------------------------------------------------
-# Pod::Hyperlink
-#
-# class to manipulate POD hyperlinks (L<>)
-#-----------------------------------------------------------------------------
-
-package Pod::Hyperlink;
-
-=head2 Pod::Hyperlink
-
-B<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage:
-
- my $link = Pod::Hyperlink->new('alternative text|page/"section in page"');
-
-The B<Pod::Hyperlink> class is mainly designed to parse the contents of the
-C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the
-different parts of a POD hyperlink for further processing. It can also be
-used to construct hyperlinks.
-
-=over 4
-
-=item Pod::Hyperlink-E<gt>new()
-
-The B<new()> method can either be passed a set of key/value pairs or a single
-scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object
-of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a
-failure, the error message is stored in C<$@>.
-
-=cut
-
-use Carp;
-
-sub new {
- my $this = shift;
- my $class = ref($this) || $this;
- my $self = +{};
- bless $self, $class;
- $self->initialize();
- if(defined $_[0]) {
- if(ref($_[0])) {
- # called with a list of parameters
- %$self = %{$_[0]};
- $self->_construct_text();
- }
- else {
- # called with L<> contents
- return unless($self->parse($_[0]));
- }
- }
- return $self;
-}
-
-sub initialize {
- my $self = shift;
- $self->{-line} ||= 'undef';
- $self->{-file} ||= 'undef';
- $self->{-page} ||= '';
- $self->{-node} ||= '';
- $self->{-alttext} ||= '';
- $self->{-type} ||= 'undef';
- $self->{_warnings} = [];
-}
-
-=item $link-E<gt>parse($string)
-
-This method can be used to (re)parse a (new) hyperlink, i.e. the contents
-of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object.
-Warnings are stored in the B<warnings> property.
-E.g. sections like C<LE<lt>open(2)E<gt>> are deprecated, as they do not point
-to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> is wrong as well, the manpage
-section can simply be dropped.
-
-=cut
-
-sub parse {
- my $self = shift;
- local($_) = $_[0];
- # syntax check the link and extract destination
- my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0);
-
- $self->{_warnings} = [];
-
- # collapse newlines with whitespace
- s/\s*\n+\s*/ /g;
-
- # strip leading/trailing whitespace
- if(s/^[\s\n]+//) {
- $self->warning('ignoring leading whitespace in link');
- }
- if(s/[\s\n]+$//) {
- $self->warning('ignoring trailing whitespace in link');
- }
- unless(length($_)) {
- _invalid_link('empty link');
- return;
- }
-
- ## Check for different possibilities. This is tedious and error-prone
- # we match all possibilities (alttext, page, section/item)
- #warn "DEBUG: link=$_\n";
-
- # only page
- # problem: a lot of people use (), or (1) or the like to indicate
- # man page sections. But this collides with L<func()> that is supposed
- # to point to an internal funtion...
- my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)';
- # page name only
- if(/^($page_rx)$/o) {
- $page = $1;
- $type = 'page';
- }
- # alttext, page and "section"
- elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) {
- ($alttext, $page, $node) = ($1, $2, $3);
- $type = 'section';
- $quoted = 1; #... therefore | and / are allowed
- }
- # alttext and page
- elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) {
- ($alttext, $page) = ($1, $2);
- $type = 'page';
- }
- # alttext and "section"
- elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) {
- ($alttext, $node) = ($1,$2);
- $type = 'section';
- $quoted = 1;
- }
- # page and "section"
- elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) {
- ($page, $node) = ($1, $2);
- $type = 'section';
- $quoted = 1;
- }
- # page and item
- elsif(m{^($page_rx)\s*/\s*(.+)$}o) {
- ($page, $node) = ($1, $2);
- $type = 'item';
- }
- # only "section"
- elsif(m{^/?"(.+)"$}) {
- $node = $1;
- $type = 'section';
- $quoted = 1;
- }
- # only item
- elsif(m{^\s*/(.+)$}) {
- $node = $1;
- $type = 'item';
- }
-
- # non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should?
- elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) {
- ($alttext,$node) = ($1,$2);
- $type = 'hyperlink';
- }
-
- # non-standard: Hyperlink
- elsif(/^(\w+:[^:\s]\S*)$/i) {
- $node = $1;
- $type = 'hyperlink';
- }
- # alttext, page and item
- elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) {
- ($alttext, $page, $node) = ($1, $2, $3);
- $type = 'item';
- }
- # alttext and item
- elsif(m{^(.*?)\s*[|]\s*/(.+)$}) {
- ($alttext, $node) = ($1,$2);
- }
- # must be an item or a "malformed" section (without "")
- else {
- $node = $_;
- $type = 'item';
- }
- # collapse whitespace in nodes
- $node =~ s/\s+/ /gs;
-
- # empty alternative text expands to node name
- if(defined $alttext) {
- if(!length($alttext)) {
- $alttext = $node || $page;
- }
- }
- else {
- $alttext = '';
- }
-
- if($page =~ /[(]\w*[)]$/) {
- $self->warning("(section) in '$page' deprecated");
- }
- if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') {
- $self->warning("node '$node' contains non-escaped | or /");
- }
- if($alttext =~ m{[|/]}) {
- $self->warning("alternative text '$node' contains non-escaped | or /");
- }
- $self->{-page} = $page;
- $self->{-node} = $node;
- $self->{-alttext} = $alttext;
- #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n";
- $self->{-type} = $type;
- $self->_construct_text();
- 1;
-}
-
-sub _construct_text {
- my $self = shift;
- my $alttext = $self->alttext();
- my $type = $self->type();
- my $section = $self->node();
- my $page = $self->page();
- my $page_ext = '';
- $page =~ s/([(]\w*[)])$// && ($page_ext = $1);
- if($alttext) {
- $self->{_text} = $alttext;
- }
- elsif($type eq 'hyperlink') {
- $self->{_text} = $section;
- }
- else {
- $self->{_text} = ($section || '') .
- (($page && $section) ? ' in ' : '') .
- "$page$page_ext";
- }
- # for being marked up later
- # use the non-standard markers P<> and Q<>, so that the resulting
- # text can be parsed by the translators. It's their job to put
- # the correct hypertext around the linktext
- if($alttext) {
- $self->{_markup} = "Q<$alttext>";
- }
- elsif($type eq 'hyperlink') {
- $self->{_markup} = "Q<$section>";
- }
- else {
- $self->{_markup} = (!$section ? '' : "Q<$section>") .
- ($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : '');
- }
-}
-
-=item $link-E<gt>markup($string)
-
-Set/retrieve the textual value of the link. This string contains special
-markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the
-translator's interior sequence expansion engine to the
-formatter-specific code to highlight/activate the hyperlink. The details
-have to be implemented in the translator.
-
-=cut
-
-#' retrieve/set markuped text
-sub markup {
- return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup};
-}
-
-=item $link-E<gt>text()
-
-This method returns the textual representation of the hyperlink as above,
-but without markers (read only). Depending on the link type this is one of
-the following alternatives (the + and * denote the portions of the text
-that are marked up):
-
- +perl+ L<perl>
- *$|* in +perlvar+ L<perlvar/$|>
- *OPTIONS* in +perldoc+ L<perldoc/"OPTIONS">
- *DESCRIPTION* L<"DESCRIPTION">
-
-=cut
-
-# The complete link's text
-sub text {
- return $_[0]->{_text};
-}
-
-=item $link-E<gt>warning()
-
-After parsing, this method returns any warnings encountered during the
-parsing process.
-
-=cut
-
-# Set/retrieve warnings
-sub warning {
- my $self = shift;
- if(@_) {
- push(@{$self->{_warnings}}, @_);
- return @_;
- }
- return @{$self->{_warnings}};
-}
-
-=item $link-E<gt>file()
-
-=item $link-E<gt>line()
-
-Just simple slots for storing information about the line and the file
-the link was encountered in. Has to be filled in manually.
-
-=cut
-
-# The line in the file the link appears
-sub line {
- return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line};
-}
-
-# The POD file name the link appears in
-sub file {
- return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
-}
-
-=item $link-E<gt>page()
-
-This method sets or returns the POD page this link points to.
-
-=cut
-
-# The POD page the link appears on
-sub page {
- if (@_ > 1) {
- $_[0]->{-page} = $_[1];
- $_[0]->_construct_text();
- }
- return $_[0]->{-page};
-}
-
-=item $link-E<gt>node()
-
-As above, but the destination node text of the link.
-
-=cut
-
-# The link destination
-sub node {
- if (@_ > 1) {
- $_[0]->{-node} = $_[1];
- $_[0]->_construct_text();
- }
- return $_[0]->{-node};
-}
-
-=item $link-E<gt>alttext()
-
-Sets or returns an alternative text specified in the link.
-
-=cut
-
-# Potential alternative text
-sub alttext {
- if (@_ > 1) {
- $_[0]->{-alttext} = $_[1];
- $_[0]->_construct_text();
- }
- return $_[0]->{-alttext};
-}
-
-=item $link-E<gt>type()
-
-The node type, either C<section> or C<item>. As an unofficial type,
-there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>>
-
-=cut
-
-# The type: item or headn
-sub type {
- return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type};
-}
-
-=item $link-E<gt>link()
-
-Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>.
-
-=back
-
-=cut
-
-# The link itself
-sub link {
- my $self = shift;
- my $link = $self->page() || '';
- if($self->node()) {
- my $node = $self->node();
- $node =~ s/\|/E<verbar>/g;
- $node =~ s{/}{E<sol>}g;
- if($self->type() eq 'section') {
- $link .= ($link ? '/' : '') . '"' . $node . '"';
- }
- elsif($self->type() eq 'hyperlink') {
- $link = $self->node();
- }
- else { # item
- $link .= '/' . $node;
- }
- }
- if($self->alttext()) {
- my $text = $self->alttext();
- $text =~ s/\|/E<verbar>/g;
- $text =~ s{/}{E<sol>}g;
- $link = "$text|$link";
- }
- return $link;
-}
-
-sub _invalid_link {
- my ($msg) = @_;
- # this sets @_
- #eval { die "$msg\n" };
- #chomp $@;
- $@ = $msg; # this seems to work, too!
- return;
-}
-
-#-----------------------------------------------------------------------------
-# Pod::Cache
-#
-# class to hold POD page details
-#-----------------------------------------------------------------------------
-
-package Pod::Cache;
-
-=head2 Pod::Cache
-
-B<Pod::Cache> holds information about a set of POD documents,
-especially the nodes for hyperlinks.
-The following methods are available:
-
-=over 4
-
-=item Pod::Cache-E<gt>new()
-
-Create a new cache object. This object can hold an arbitrary number of
-POD documents of class Pod::Cache::Item.
-
-=cut
-
-sub new {
- my $this = shift;
- my $class = ref($this) || $this;
- my $self = [];
- bless $self, $class;
- return $self;
-}
-
-=item $cache-E<gt>item()
-
-Add a new item to the cache. Without arguments, this method returns a
-list of all cache elements.
-
-=cut
-
-sub item {
- my ($self,%param) = @_;
- if(%param) {
- my $item = Pod::Cache::Item->new(%param);
- push(@$self, $item);
- return $item;
- }
- else {
- return @{$self};
- }
-}
-
-=item $cache-E<gt>find_page($name)
-
-Look for a POD document named C<$name> in the cache. Returns the
-reference to the corresponding Pod::Cache::Item object or undef if
-not found.
-
-=back
-
-=cut
-
-sub find_page {
- my ($self,$page) = @_;
- foreach(@$self) {
- if($_->page() eq $page) {
- return $_;
- }
- }
- return;
-}
-
-package Pod::Cache::Item;
-
-=head2 Pod::Cache::Item
-
-B<Pod::Cache::Item> holds information about individual POD documents,
-that can be grouped in a Pod::Cache object.
-It is intended to hold information about the hyperlink nodes of POD
-documents.
-The following methods are available:
-
-=over 4
-
-=item Pod::Cache::Item-E<gt>new()
-
-Create a new object.
-
-=cut
-
-sub new {
- my $this = shift;
- my $class = ref($this) || $this;
- my %params = @_;
- my $self = {%params};
- bless $self, $class;
- $self->initialize();
- return $self;
-}
-
-sub initialize {
- my $self = shift;
- $self->{-nodes} = [] unless(defined $self->{-nodes});
-}
-
-=item $cacheitem-E<gt>page()
-
-Set/retrieve the POD document name (e.g. "Pod::Parser").
-
-=cut
-
-# The POD page
-sub page {
- return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page};
-}
-
-=item $cacheitem-E<gt>description()
-
-Set/retrieve the POD short description as found in the C<=head1 NAME>
-section.
-
-=cut
-
-# The POD description, taken out of NAME if present
-sub description {
- return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description};
-}
-
-=item $cacheitem-E<gt>path()
-
-Set/retrieve the POD file storage path.
-
-=cut
-
-# The file path
-sub path {
- return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path};
-}
-
-=item $cacheitem-E<gt>file()
-
-Set/retrieve the POD file name.
-
-=cut
-
-# The POD file name
-sub file {
- return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file};
-}
-
-=item $cacheitem-E<gt>nodes()
-
-Add a node (or a list of nodes) to the document's node list. Note that
-the order is kept, i.e. start with the first node and end with the last.
-If no argument is given, the current list of nodes is returned in the
-same order the nodes have been added.
-A node can be any scalar, but usually is a pair of node string and
-unique id for the C<find_node> method to work correctly.
-
-=cut
-
-# The POD nodes
-sub nodes {
- my ($self, at nodes) = @_;
- if(@nodes) {
- push(@{$self->{-nodes}}, @nodes);
- return @nodes;
- }
- else {
- return @{$self->{-nodes}};
- }
-}
-
-=item $cacheitem-E<gt>find_node($name)
-
-Look for a node or index entry named C<$name> in the object.
-Returns the unique id of the node (i.e. the second element of the array
-stored in the node array) or undef if not found.
-
-=cut
-
-sub find_node {
- my ($self,$node) = @_;
- my @search;
- push(@search, @{$self->{-nodes}}) if($self->{-nodes});
- push(@search, @{$self->{-idx}}) if($self->{-idx});
- foreach(@search) {
- if($_->[0] eq $node) {
- return $_->[1]; # id
- }
- }
- return;
-}
-
-=item $cacheitem-E<gt>idx()
-
-Add an index entry (or a list of them) to the document's index list. Note that
-the order is kept, i.e. start with the first node and end with the last.
-If no argument is given, the current list of index entries is returned in the
-same order the entries have been added.
-An index entry can be any scalar, but usually is a pair of string and
-unique id.
-
-=back
-
-=cut
-
-# The POD index entries
-sub idx {
- my ($self, at idx) = @_;
- if(@idx) {
- push(@{$self->{-idx}}, @idx);
- return @idx;
- }
- else {
- return @{$self->{-idx}};
- }
-}
-
-=head1 AUTHOR
-
-Please report bugs using L<http://rt.cpan.org>.
-
-Marek Rouchal E<lt>marekr at cpan.orgE<gt>, borrowing
-a lot of things from L<pod2man> and L<pod2roff> as well as other POD
-processing tools by Tom Christiansen, Brad Appleton and Russ Allbery.
-
-=head1 SEE ALSO
-
-L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>,
-L<pod2html>
-
-=cut
-
-1;
Deleted: trunk/contrib/perl/lib/Pod/Parser.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Parser.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Parser.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1829 +0,0 @@
-#############################################################################
-# Pod/Parser.pm -- package which defines a base class for parsing 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.
-#############################################################################
-
-package Pod::Parser;
-use strict;
-
-## These "variables" are used as local "glob aliases" for performance
-use vars qw($VERSION @ISA %myData %myOpts @input_stack);
-$VERSION = '1.37'; ## Current version of this package
-require 5.005; ## requires this Perl version or later
-
-#############################################################################
-
-=head1 NAME
-
-Pod::Parser - base class for creating POD filters and translators
-
-=head1 SYNOPSIS
-
- use Pod::Parser;
-
- package MyParser;
- @ISA = qw(Pod::Parser);
-
- sub command {
- my ($parser, $command, $paragraph, $line_num) = @_;
- ## Interpret the command and its text; sample actions might be:
- if ($command eq 'head1') { ... }
- elsif ($command eq 'head2') { ... }
- ## ... other commands and their actions
- my $out_fh = $parser->output_handle();
- my $expansion = $parser->interpolate($paragraph, $line_num);
- print $out_fh $expansion;
- }
-
- sub verbatim {
- my ($parser, $paragraph, $line_num) = @_;
- ## Format verbatim paragraph; sample actions might be:
- my $out_fh = $parser->output_handle();
- print $out_fh $paragraph;
- }
-
- sub textblock {
- my ($parser, $paragraph, $line_num) = @_;
- ## Translate/Format this block of text; sample actions might be:
- my $out_fh = $parser->output_handle();
- my $expansion = $parser->interpolate($paragraph, $line_num);
- print $out_fh $expansion;
- }
-
- sub interior_sequence {
- my ($parser, $seq_command, $seq_argument) = @_;
- ## Expand an interior sequence; sample actions might be:
- return "*$seq_argument*" if ($seq_command eq 'B');
- return "`$seq_argument'" if ($seq_command eq 'C');
- return "_${seq_argument}_'" if ($seq_command eq 'I');
- ## ... other sequence commands and their resulting text
- }
-
- package main;
-
- ## Create a parser object and have it parse file whose name was
- ## given on the command-line (use STDIN if no files were given).
- $parser = new MyParser();
- $parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0);
- for (@ARGV) { $parser->parse_from_file($_); }
-
-=head1 REQUIRES
-
-perl5.005, Pod::InputObjects, Exporter, Symbol, Carp
-
-=head1 EXPORTS
-
-Nothing.
-
-=head1 DESCRIPTION
-
-B<Pod::Parser> is a base class for creating POD filters and translators.
-It handles most of the effort involved with parsing the POD sections
-from an input stream, leaving subclasses free to be concerned only with
-performing the actual translation of text.
-
-B<Pod::Parser> parses PODs, and makes method calls to handle the various
-components of the POD. Subclasses of B<Pod::Parser> override these methods
-to translate the POD into whatever output format they desire.
-
-=head1 QUICK OVERVIEW
-
-To create a POD filter for translating POD documentation into some other
-format, you create a subclass of B<Pod::Parser> which typically overrides
-just the base class implementation for the following methods:
-
-=over 2
-
-=item *
-
-B<command()>
-
-=item *
-
-B<verbatim()>
-
-=item *
-
-B<textblock()>
-
-=item *
-
-B<interior_sequence()>
-
-=back
-
-You may also want to override the B<begin_input()> and B<end_input()>
-methods for your subclass (to perform any needed per-file and/or
-per-document initialization or cleanup).
-
-If you need to perform any preprocessing of input before it is parsed
-you may want to override one or more of B<preprocess_line()> and/or
-B<preprocess_paragraph()>.
-
-Sometimes it may be necessary to make more than one pass over the input
-files. If this is the case you have several options. You can make the
-first pass using B<Pod::Parser> and override your methods to store the
-intermediate results in memory somewhere for the B<end_pod()> method to
-process. You could use B<Pod::Parser> for several passes with an
-appropriate state variable to control the operation for each pass. If
-your input source can't be reset to start at the beginning, you can
-store it in some other structure as a string or an array and have that
-structure implement a B<getline()> method (which is all that
-B<parse_from_filehandle()> uses to read input).
-
-Feel free to add any member data fields you need to keep track of things
-like current font, indentation, horizontal or vertical position, or
-whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA">
-to avoid name collisions.
-
-For the most part, the B<Pod::Parser> base class should be able to
-do most of the input parsing for you and leave you free to worry about
-how to interpret the commands and translate the result.
-
-Note that all we have described here in this quick overview is the
-simplest most straightforward use of B<Pod::Parser> to do stream-based
-parsing. It is also possible to use the B<Pod::Parser::parse_text> function
-to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">.
-
-=head1 PARSING OPTIONS
-
-A I<parse-option> is simply a named option of B<Pod::Parser> with a
-value that corresponds to a certain specified behavior. These various
-behaviors of B<Pod::Parser> may be enabled/disabled by setting
-or unsetting one or more I<parse-options> using the B<parseopts()> method.
-The set of currently accepted parse-options is as follows:
-
-=over 3
-
-=item B<-want_nonPODs> (default: unset)
-
-Normally (by default) B<Pod::Parser> will only provide access to
-the POD sections of the input. Input paragraphs that are not part
-of the POD-format documentation are not made available to the caller
-(not even using B<preprocess_paragraph()>). Setting this option to a
-non-empty, non-zero value will allow B<preprocess_paragraph()> to see
-non-POD sections of the input as well as POD sections. The B<cutting()>
-method can be used to determine if the corresponding paragraph is a POD
-paragraph, or some other input paragraph.
-
-=item B<-process_cut_cmd> (default: unset)
-
-Normally (by default) B<Pod::Parser> handles the C<=cut> POD directive
-by itself and does not pass it on to the caller for processing. Setting
-this option to a non-empty, non-zero value will cause B<Pod::Parser> to
-pass the C<=cut> directive to the caller just like any other POD command
-(and hence it may be processed by the B<command()> method).
-
-B<Pod::Parser> will still interpret the C<=cut> directive to mean that
-"cutting mode" has been (re)entered, but the caller will get a chance
-to capture the actual C<=cut> paragraph itself for whatever purpose
-it desires.
-
-=item B<-warnings> (default: unset)
-
-Normally (by default) B<Pod::Parser> recognizes a bare minimum of
-pod syntax errors and warnings and issues diagnostic messages
-for errors, but not for warnings. (Use B<Pod::Checker> to do more
-thorough checking of POD syntax.) Setting this option to a non-empty,
-non-zero value will cause B<Pod::Parser> to issue diagnostics for
-the few warnings it recognizes as well as the errors.
-
-=back
-
-Please see L<"parseopts()"> for a complete description of the interface
-for the setting and unsetting of parse-options.
-
-=cut
-
-#############################################################################
-
-#use diagnostics;
-use Pod::InputObjects;
-use Carp;
-use Exporter;
-BEGIN {
- if ($] < 5.006) {
- require Symbol;
- import Symbol;
- }
-}
- at ISA = qw(Exporter);
-
-#############################################################################
-
-=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES
-
-B<Pod::Parser> provides several methods which most subclasses will probably
-want to override. These methods are as follows:
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=head1 B<command()>
-
- $parser->command($cmd,$text,$line_num,$pod_para);
-
-This method should be overridden by subclasses to take the appropriate
-action when a POD command paragraph (denoted by a line beginning with
-"=") is encountered. When such a POD directive is seen in the input,
-this method is called and is passed:
-
-=over 3
-
-=item C<$cmd>
-
-the name of the command for this POD paragraph
-
-=item C<$text>
-
-the paragraph text for the given POD paragraph command.
-
-=item C<$line_num>
-
-the line-number of the beginning of the paragraph
-
-=item C<$pod_para>
-
-a reference to a C<Pod::Paragraph> object which contains further
-information about the paragraph command (see L<Pod::InputObjects>
-for details).
-
-=back
-
-B<Note> that this method I<is> called for C<=pod> paragraphs.
-
-The base class implementation of this method simply treats the raw POD
-command as normal block of paragraph text (invoking the B<textblock()>
-method with the command paragraph).
-
-=cut
-
-sub command {
- my ($self, $cmd, $text, $line_num, $pod_para) = @_;
- ## Just treat this like a textblock
- $self->textblock($pod_para->raw_text(), $line_num, $pod_para);
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<verbatim()>
-
- $parser->verbatim($text,$line_num,$pod_para);
-
-This method may be overridden by subclasses to take the appropriate
-action when a block of verbatim text is encountered. It is passed the
-following parameters:
-
-=over 3
-
-=item C<$text>
-
-the block of text for the verbatim paragraph
-
-=item C<$line_num>
-
-the line-number of the beginning of the paragraph
-
-=item C<$pod_para>
-
-a reference to a C<Pod::Paragraph> object which contains further
-information about the paragraph (see L<Pod::InputObjects>
-for details).
-
-=back
-
-The base class implementation of this method simply prints the textblock
-(unmodified) to the output filehandle.
-
-=cut
-
-sub verbatim {
- my ($self, $text, $line_num, $pod_para) = @_;
- my $out_fh = $self->{_OUTPUT};
- print $out_fh $text;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<textblock()>
-
- $parser->textblock($text,$line_num,$pod_para);
-
-This method may be overridden by subclasses to take the appropriate
-action when a normal block of POD text is encountered (although the base
-class method will usually do what you want). It is passed the following
-parameters:
-
-=over 3
-
-=item C<$text>
-
-the block of text for the a POD paragraph
-
-=item C<$line_num>
-
-the line-number of the beginning of the paragraph
-
-=item C<$pod_para>
-
-a reference to a C<Pod::Paragraph> object which contains further
-information about the paragraph (see L<Pod::InputObjects>
-for details).
-
-=back
-
-In order to process interior sequences, subclasses implementations of
-this method will probably want to invoke either B<interpolate()> or
-B<parse_text()>, passing it the text block C<$text>, and the corresponding
-line number in C<$line_num>, and then perform any desired processing upon
-the returned result.
-
-The base class implementation of this method simply prints the text block
-as it occurred in the input stream).
-
-=cut
-
-sub textblock {
- my ($self, $text, $line_num, $pod_para) = @_;
- my $out_fh = $self->{_OUTPUT};
- print $out_fh $self->interpolate($text, $line_num);
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<interior_sequence()>
-
- $parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq);
-
-This method should be overridden by subclasses to take the appropriate
-action when an interior sequence is encountered. An interior sequence is
-an embedded command within a block of text which appears as a command
-name (usually a single uppercase character) followed immediately by a
-string of text which is enclosed in angle brackets. This method is
-passed the sequence command C<$seq_cmd> and the corresponding text
-C<$seq_arg>. It is invoked by the B<interpolate()> method for each interior
-sequence that occurs in the string that it is passed. It should return
-the desired text string to be used in place of the interior sequence.
-The C<$pod_seq> argument is a reference to a C<Pod::InteriorSequence>
-object which contains further information about the interior sequence.
-Please see L<Pod::InputObjects> for details if you need to access this
-additional information.
-
-Subclass implementations of this method may wish to invoke the
-B<nested()> method of C<$pod_seq> to see if it is nested inside
-some other interior-sequence (and if so, which kind).
-
-The base class implementation of the B<interior_sequence()> method
-simply returns the raw text of the interior sequence (as it occurred
-in the input) to the caller.
-
-=cut
-
-sub interior_sequence {
- my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_;
- ## Just return the raw text of the interior sequence
- return $pod_seq->raw_text();
-}
-
-#############################################################################
-
-=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES
-
-B<Pod::Parser> provides several methods which subclasses may want to override
-to perform any special pre/post-processing. These methods do I<not> have to
-be overridden, but it may be useful for subclasses to take advantage of them.
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=head1 B<new()>
-
- my $parser = Pod::Parser->new();
-
-This is the constructor for B<Pod::Parser> and its subclasses. You
-I<do not> need to override this method! It is capable of constructing
-subclass objects as well as base class objects, provided you use
-any of the following constructor invocation styles:
-
- my $parser1 = MyParser->new();
- my $parser2 = new MyParser();
- my $parser3 = $parser2->new();
-
-where C<MyParser> is some subclass of B<Pod::Parser>.
-
-Using the syntax C<MyParser::new()> to invoke the constructor is I<not>
-recommended, but if you insist on being able to do this, then the
-subclass I<will> need to override the B<new()> constructor method. If
-you do override the constructor, you I<must> be sure to invoke the
-B<initialize()> method of the newly blessed object.
-
-Using any of the above invocations, the first argument to the
-constructor is always the corresponding package name (or object
-reference). No other arguments are required, but if desired, an
-associative array (or hash-table) my be passed to the B<new()>
-constructor, as in:
-
- my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 );
- my $parser2 = new MyParser( -myflag => 1 );
-
-All arguments passed to the B<new()> constructor will be treated as
-key/value pairs in a hash-table. The newly constructed object will be
-initialized by copying the contents of the given hash-table (which may
-have been empty). The B<new()> constructor for this class and all of its
-subclasses returns a blessed reference to the initialized object (hash-table).
-
-=cut
-
-sub new {
- ## Determine if we were called via an object-ref or a classname
- my ($this,%params) = @_;
- my $class = ref($this) || $this;
- ## Any remaining arguments are treated as initial values for the
- ## hash that is used to represent this object.
- my $self = { %params };
- ## Bless ourselves into the desired class and perform any initialization
- bless $self, $class;
- $self->initialize();
- return $self;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<initialize()>
-
- $parser->initialize();
-
-This method performs any necessary object initialization. It takes no
-arguments (other than the object instance of course, which is typically
-copied to a local variable named C<$self>). If subclasses override this
-method then they I<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>.
-
-=cut
-
-sub initialize {
- #my $self = shift;
- #return;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<begin_pod()>
-
- $parser->begin_pod();
-
-This method is invoked at the beginning of processing for each POD
-document that is encountered in the input. Subclasses should override
-this method to perform any per-document initialization.
-
-=cut
-
-sub begin_pod {
- #my $self = shift;
- #return;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<begin_input()>
-
- $parser->begin_input();
-
-This method is invoked by B<parse_from_filehandle()> immediately I<before>
-processing input from a filehandle. The base class implementation does
-nothing, however, subclasses may override it to perform any per-file
-initializations.
-
-Note that if multiple files are parsed for a single POD document
-(perhaps the result of some future C<=include> directive) this method
-is invoked for every file that is parsed. If you wish to perform certain
-initializations once per document, then you should use B<begin_pod()>.
-
-=cut
-
-sub begin_input {
- #my $self = shift;
- #return;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<end_input()>
-
- $parser->end_input();
-
-This method is invoked by B<parse_from_filehandle()> immediately I<after>
-processing input from a filehandle. The base class implementation does
-nothing, however, subclasses may override it to perform any per-file
-cleanup actions.
-
-Please note that if multiple files are parsed for a single POD document
-(perhaps the result of some kind of C<=include> directive) this method
-is invoked for every file that is parsed. If you wish to perform certain
-cleanup actions once per document, then you should use B<end_pod()>.
-
-=cut
-
-sub end_input {
- #my $self = shift;
- #return;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<end_pod()>
-
- $parser->end_pod();
-
-This method is invoked at the end of processing for each POD document
-that is encountered in the input. Subclasses should override this method
-to perform any per-document finalization.
-
-=cut
-
-sub end_pod {
- #my $self = shift;
- #return;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<preprocess_line()>
-
- $textline = $parser->preprocess_line($text, $line_num);
-
-This method should be overridden by subclasses that wish to perform
-any kind of preprocessing for each I<line> of input (I<before> it has
-been determined whether or not it is part of a POD paragraph). The
-parameter C<$text> is the input line; and the parameter C<$line_num> is
-the line number of the corresponding text line.
-
-The value returned should correspond to the new text to use in its
-place. If the empty string or an undefined value is returned then no
-further processing will be performed for this line.
-
-Please note that the B<preprocess_line()> method is invoked I<before>
-the B<preprocess_paragraph()> method. After all (possibly preprocessed)
-lines in a paragraph have been assembled together and it has been
-determined that the paragraph is part of the POD documentation from one
-of the selected sections, then B<preprocess_paragraph()> is invoked.
-
-The base class implementation of this method returns the given text.
-
-=cut
-
-sub preprocess_line {
- my ($self, $text, $line_num) = @_;
- return $text;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<preprocess_paragraph()>
-
- $textblock = $parser->preprocess_paragraph($text, $line_num);
-
-This method should be overridden by subclasses that wish to perform any
-kind of preprocessing for each block (paragraph) of POD documentation
-that appears in the input stream. The parameter C<$text> is the POD
-paragraph from the input file; and the parameter C<$line_num> is the
-line number for the beginning of the corresponding paragraph.
-
-The value returned should correspond to the new text to use in its
-place If the empty string is returned or an undefined value is
-returned, then the given C<$text> is ignored (not processed).
-
-This method is invoked after gathering up all the lines in a paragraph
-and after determining the cutting state of the paragraph,
-but before trying to further parse or interpret them. After
-B<preprocess_paragraph()> returns, the current cutting state (which
-is returned by C<$self-E<gt>cutting()>) is examined. If it evaluates
-to true then input text (including the given C<$text>) is cut (not
-processed) until the next POD directive is encountered.
-
-Please note that the B<preprocess_line()> method is invoked I<before>
-the B<preprocess_paragraph()> method. After all (possibly preprocessed)
-lines in a paragraph have been assembled together and either it has been
-determined that the paragraph is part of the POD documentation from one
-of the selected sections or the C<-want_nonPODs> option is true,
-then B<preprocess_paragraph()> is invoked.
-
-The base class implementation of this method returns the given text.
-
-=cut
-
-sub preprocess_paragraph {
- my ($self, $text, $line_num) = @_;
- return $text;
-}
-
-#############################################################################
-
-=head1 METHODS FOR PARSING AND PROCESSING
-
-B<Pod::Parser> provides several methods to process input text. These
-methods typically won't need to be overridden (and in some cases they
-can't be overridden), but subclasses may want to invoke them to exploit
-their functionality.
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=head1 B<parse_text()>
-
- $ptree1 = $parser->parse_text($text, $line_num);
- $ptree2 = $parser->parse_text({%opts}, $text, $line_num);
- $ptree3 = $parser->parse_text(\%opts, $text, $line_num);
-
-This method is useful if you need to perform your own interpolation
-of interior sequences and can't rely upon B<interpolate> to expand
-them in simple bottom-up order.
-
-The parameter C<$text> is a string or block of text to be parsed
-for interior sequences; and the parameter C<$line_num> is the
-line number corresponding to the beginning of C<$text>.
-
-B<parse_text()> will parse the given text into a parse-tree of "nodes."
-and interior-sequences. Each "node" in the parse tree is either a
-text-string, or a B<Pod::InteriorSequence>. The result returned is a
-parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects>
-for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>.
-
-If desired, an optional hash-ref may be specified as the first argument
-to customize certain aspects of the parse-tree that is created and
-returned. The set of recognized option keywords are:
-
-=over 3
-
-=item B<-expand_seq> =E<gt> I<code-ref>|I<method-name>
-
-Normally, the parse-tree returned by B<parse_text()> will contain an
-unexpanded C<Pod::InteriorSequence> object for each interior-sequence
-encountered. Specifying B<-expand_seq> tells B<parse_text()> to "expand"
-every interior-sequence it sees by invoking the referenced function
-(or named method of the parser object) and using the return value as the
-expanded result.
-
-If a subroutine reference was given, it is invoked as:
-
- &$code_ref( $parser, $sequence )
-
-and if a method-name was given, it is invoked as:
-
- $parser->method_name( $sequence )
-
-where C<$parser> is a reference to the parser object, and C<$sequence>
-is a reference to the interior-sequence object.
-[I<NOTE>: If the B<interior_sequence()> method is specified, then it is
-invoked according to the interface specified in L<"interior_sequence()">].
-
-=item B<-expand_text> =E<gt> I<code-ref>|I<method-name>
-
-Normally, the parse-tree returned by B<parse_text()> will contain a
-text-string for each contiguous sequence of characters outside of an
-interior-sequence. Specifying B<-expand_text> tells B<parse_text()> to
-"preprocess" every such text-string it sees by invoking the referenced
-function (or named method of the parser object) and using the return value
-as the preprocessed (or "expanded") result. [Note that if the result is
-an interior-sequence, then it will I<not> be expanded as specified by the
-B<-expand_seq> option; Any such recursive expansion needs to be handled by
-the specified callback routine.]
-
-If a subroutine reference was given, it is invoked as:
-
- &$code_ref( $parser, $text, $ptree_node )
-
-and if a method-name was given, it is invoked as:
-
- $parser->method_name( $text, $ptree_node )
-
-where C<$parser> is a reference to the parser object, C<$text> is the
-text-string encountered, and C<$ptree_node> is a reference to the current
-node in the parse-tree (usually an interior-sequence object or else the
-top-level node of the parse-tree).
-
-=item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name>
-
-Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an
-argument to the referenced subroutine (or named method of the parser
-object) and return the result instead of the parse-tree object.
-
-If a subroutine reference was given, it is invoked as:
-
- &$code_ref( $parser, $ptree )
-
-and if a method-name was given, it is invoked as:
-
- $parser->method_name( $ptree )
-
-where C<$parser> is a reference to the parser object, and C<$ptree>
-is a reference to the parse-tree object.
-
-=back
-
-=cut
-
-sub parse_text {
- my $self = shift;
- local $_ = '';
-
- ## Get options and set any defaults
- my %opts = (ref $_[0]) ? %{ shift() } : ();
- my $expand_seq = $opts{'-expand_seq'} || undef;
- my $expand_text = $opts{'-expand_text'} || undef;
- my $expand_ptree = $opts{'-expand_ptree'} || undef;
-
- my $text = shift;
- my $line = shift;
- my $file = $self->input_file();
- my $cmd = "";
-
- ## Convert method calls into closures, for our convenience
- my $xseq_sub = $expand_seq;
- my $xtext_sub = $expand_text;
- my $xptree_sub = $expand_ptree;
- if (defined $expand_seq and $expand_seq eq 'interior_sequence') {
- ## If 'interior_sequence' is the method to use, we have to pass
- ## more than just the sequence object, we also need to pass the
- ## sequence name and text.
- $xseq_sub = sub {
- my ($sself, $iseq) = @_;
- my $args = join('', $iseq->parse_tree->children);
- return $sself->interior_sequence($iseq->name, $args, $iseq);
- };
- }
- ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) };
- ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) };
- ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) };
-
- ## Keep track of the "current" interior sequence, and maintain a stack
- ## of "in progress" sequences.
- ##
- ## NOTE that we push our own "accumulator" at the very beginning of the
- ## stack. It's really a parse-tree, not a sequence; but it implements
- ## the methods we need so we can use it to gather-up all the sequences
- ## and strings we parse. Thus, by the end of our parsing, it should be
- ## the only thing left on our stack and all we have to do is return it!
- ##
- my $seq = Pod::ParseTree->new();
- my @seq_stack = ($seq);
- my ($ldelim, $rdelim) = ('', '');
-
- ## Iterate over all sequence starts text (NOTE: split with
- ## capturing parens keeps the delimiters)
- $_ = $text;
- my @tokens = split /([A-Z]<(?:<+\s)?)/;
- while ( @tokens ) {
- $_ = shift @tokens;
- ## Look for the beginning of a sequence
- if ( /^([A-Z])(<(?:<+\s)?)$/ ) {
- ## Push a new sequence onto the stack of those "in-progress"
- my $ldelim_orig;
- ($cmd, $ldelim_orig) = ($1, $2);
- ($ldelim = $ldelim_orig) =~ s/\s+$//;
- ($rdelim = $ldelim) =~ tr/</>/;
- $seq = Pod::InteriorSequence->new(
- -name => $cmd,
- -ldelim => $ldelim_orig, -rdelim => $rdelim,
- -file => $file, -line => $line
- );
- (@seq_stack > 1) and $seq->nested($seq_stack[-1]);
- push @seq_stack, $seq;
- }
- ## Look for sequence ending
- elsif ( @seq_stack > 1 ) {
- ## Make sure we match the right kind of closing delimiter
- my ($seq_end, $post_seq) = ('', '');
- if ( ($ldelim eq '<' and /\A(.*?)(>)/s)
- or /\A(.*?)(\s+$rdelim)/s )
- {
- ## Found end-of-sequence, capture the interior and the
- ## closing the delimiter, and put the rest back on the
- ## token-list
- $post_seq = substr($_, length($1) + length($2));
- ($_, $seq_end) = ($1, $2);
- (length $post_seq) and unshift @tokens, $post_seq;
- }
- if (length) {
- ## In the middle of a sequence, append this text to it, and
- ## dont forget to "expand" it if that's what the caller wanted
- $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
- $_ .= $seq_end;
- }
- if (length $seq_end) {
- ## End of current sequence, record terminating delimiter
- $seq->rdelim($seq_end);
- ## Pop it off the stack of "in progress" sequences
- pop @seq_stack;
- ## Append result to its parent in current parse tree
- $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq)
- : $seq);
- ## Remember the current cmd-name and left-delimiter
- if(@seq_stack > 1) {
- $cmd = $seq_stack[-1]->name;
- $ldelim = $seq_stack[-1]->ldelim;
- $rdelim = $seq_stack[-1]->rdelim;
- } else {
- $cmd = $ldelim = $rdelim = '';
- }
- }
- }
- elsif (length) {
- ## In the middle of a sequence, append this text to it, and
- ## dont forget to "expand" it if that's what the caller wanted
- $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
- }
- ## Keep track of line count
- $line += s/\r*\n//;
- ## Remember the "current" sequence
- $seq = $seq_stack[-1];
- }
-
- ## Handle unterminated sequences
- my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef;
- while (@seq_stack > 1) {
- ($cmd, $file, $line) = ($seq->name, $seq->file_line);
- $ldelim = $seq->ldelim;
- ($rdelim = $ldelim) =~ tr/</>/;
- $rdelim =~ s/^(\S+)(\s*)$/$2$1/;
- pop @seq_stack;
- my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}".
- " at line $line in file $file\n";
- (ref $errorsub) and &{$errorsub}($errmsg)
- or (defined $errorsub) and $self->$errorsub($errmsg)
- or carp($errmsg);
- $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq);
- $seq = $seq_stack[-1];
- }
-
- ## Return the resulting parse-tree
- my $ptree = (pop @seq_stack)->parse_tree;
- return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<interpolate()>
-
- $textblock = $parser->interpolate($text, $line_num);
-
-This method translates all text (including any embedded interior sequences)
-in the given text string C<$text> and returns the interpolated result. The
-parameter C<$line_num> is the line number corresponding to the beginning
-of C<$text>.
-
-B<interpolate()> merely invokes a private method to recursively expand
-nested interior sequences in bottom-up order (innermost sequences are
-expanded first). If there is a need to expand nested sequences in
-some alternate order, use B<parse_text> instead.
-
-=cut
-
-sub interpolate {
- my($self, $text, $line_num) = @_;
- my %parse_opts = ( -expand_seq => 'interior_sequence' );
- my $ptree = $self->parse_text( \%parse_opts, $text, $line_num );
- return join '', $ptree->children();
-}
-
-##---------------------------------------------------------------------------
-
-=begin __PRIVATE__
-
-=head1 B<parse_paragraph()>
-
- $parser->parse_paragraph($text, $line_num);
-
-This method takes the text of a POD paragraph to be processed, along
-with its corresponding line number, and invokes the appropriate method
-(one of B<command()>, B<verbatim()>, or B<textblock()>).
-
-For performance reasons, this method is invoked directly without any
-dynamic lookup; Hence subclasses may I<not> override it!
-
-=end __PRIVATE__
-
-=cut
-
-sub parse_paragraph {
- my ($self, $text, $line_num) = @_;
- local *myData = $self; ## alias to avoid deref-ing overhead
- local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
- local $_;
-
- ## See if we want to preprocess nonPOD paragraphs as well as POD ones.
- my $wantNonPods = $myOpts{'-want_nonPODs'};
-
- ## Update cutting status
- $myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/;
-
- ## Perform any desired preprocessing if we wanted it this early
- $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num);
-
- ## Ignore up until next POD directive if we are cutting
- return if $myData{_CUTTING};
-
- ## Now we know this is block of text in a POD section!
-
- ##-----------------------------------------------------------------
- ## This is a hook (hack ;-) for Pod::Select to do its thing without
- ## having to override methods, but also without Pod::Parser assuming
- ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS
- ## field exists then we assume there is an is_selected() method for
- ## us to invoke (calling $self->can('is_selected') could verify this
- ## but that is more overhead than I want to incur)
- ##-----------------------------------------------------------------
-
- ## Ignore this block if it isnt in one of the selected sections
- if (exists $myData{_SELECTED_SECTIONS}) {
- $self->is_selected($text) or return ($myData{_CUTTING} = 1);
- }
-
- ## If we havent already, perform any desired preprocessing and
- ## then re-check the "cutting" state
- unless ($wantNonPods) {
- $text = $self->preprocess_paragraph($text, $line_num);
- return 1 unless ((defined $text) and (length $text));
- return 1 if ($myData{_CUTTING});
- }
-
- ## Look for one of the three types of paragraphs
- my ($pfx, $cmd, $arg, $sep) = ('', '', '', '');
- my $pod_para = undef;
- if ($text =~ /^(={1,2})(?=\S)/) {
- ## Looks like a command paragraph. Capture the command prefix used
- ## ("=" or "=="), as well as the command-name, its paragraph text,
- ## and whatever sequence of characters was used to separate them
- $pfx = $1;
- $_ = substr($text, length $pfx);
- ($cmd, $sep, $text) = split /(\s+)/, $_, 2;
- ## If this is a "cut" directive then we dont need to do anything
- ## except return to "cutting" mode.
- if ($cmd eq 'cut') {
- $myData{_CUTTING} = 1;
- return unless $myOpts{'-process_cut_cmd'};
- }
- }
- ## Save the attributes indicating how the command was specified.
- $pod_para = new Pod::Paragraph(
- -name => $cmd,
- -text => $text,
- -prefix => $pfx,
- -separator => $sep,
- -file => $myData{_INFILE},
- -line => $line_num
- );
- # ## Invoke appropriate callbacks
- # if (exists $myData{_CALLBACKS}) {
- # ## Look through the callback list, invoke callbacks,
- # ## then see if we need to do the default actions
- # ## (invoke_callbacks will return true if we do).
- # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para);
- # }
-
- # If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp
- if ($myData{_WHITESPACE} and $myOpts{'-warnings'}
- and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) {
- my $errorsub = $self->errorsub();
- my $line = $line_num - 1;
- my $errmsg = "*** WARNING: line containing nothing but whitespace".
- " in paragraph at line $line in file $myData{_INFILE}\n";
- (ref $errorsub) and &{$errorsub}($errmsg)
- or (defined $errorsub) and $self->$errorsub($errmsg)
- or carp($errmsg);
- }
-
- if (length $cmd) {
- ## A command paragraph
- $self->command($cmd, $text, $line_num, $pod_para);
- $myData{_PREVIOUS} = $cmd;
- }
- elsif ($text =~ /^\s+/) {
- ## Indented text - must be a verbatim paragraph
- $self->verbatim($text, $line_num, $pod_para);
- $myData{_PREVIOUS} = "verbatim";
- }
- else {
- ## Looks like an ordinary block of text
- $self->textblock($text, $line_num, $pod_para);
- $myData{_PREVIOUS} = "textblock";
- }
-
- # Update the whitespace for the next time around
- $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0;
-
- return 1;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<parse_from_filehandle()>
-
- $parser->parse_from_filehandle($in_fh,$out_fh);
-
-This method takes an input filehandle (which is assumed to already be
-opened for reading) and reads the entire input stream looking for blocks
-(paragraphs) of POD documentation to be processed. If no first argument
-is given the default input filehandle C<STDIN> is used.
-
-The C<$in_fh> parameter may be any object that provides a B<getline()>
-method to retrieve a single line of input text (hence, an appropriate
-wrapper object could be used to parse PODs from a single string or an
-array of strings).
-
-Using C<$in_fh-E<gt>getline()>, input is read line-by-line and assembled
-into paragraphs or "blocks" (which are separated by lines containing
-nothing but whitespace). For each block of POD documentation
-encountered it will invoke a method to parse the given paragraph.
-
-If a second argument is given then it should correspond to a filehandle where
-output should be sent (otherwise the default output filehandle is
-C<STDOUT> if no output filehandle is currently in use).
-
-B<NOTE:> For performance reasons, this method caches the input stream at
-the top of the stack in a local variable. Any attempts by clients to
-change the stack contents during processing when in the midst executing
-of this method I<will not affect> the input stream used by the current
-invocation of this method.
-
-This method does I<not> usually need to be overridden by subclasses.
-
-=cut
-
-sub parse_from_filehandle {
- my $self = shift;
- my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
- my ($in_fh, $out_fh) = @_;
- $in_fh = \*STDIN unless ($in_fh);
- local *myData = $self; ## alias to avoid deref-ing overhead
- local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options
- local $_;
-
- ## Put this stream at the top of the stack and do beginning-of-input
- ## processing. NOTE that $in_fh might be reset during this process.
- my $topstream = $self->_push_input_stream($in_fh, $out_fh);
- (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} );
-
- ## Initialize line/paragraph
- my ($textline, $paragraph) = ('', '');
- my ($nlines, $plines) = (0, 0);
-
- ## Use <$fh> instead of $fh->getline where possible (for speed)
- $_ = ref $in_fh;
- my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh);
-
- ## Read paragraphs line-by-line
- while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) {
- $textline = $self->preprocess_line($textline, ++$nlines);
- next unless ((defined $textline) && (length $textline));
-
- if ((! length $paragraph) && ($textline =~ /^==/)) {
- ## '==' denotes a one-line command paragraph
- $paragraph = $textline;
- $plines = 1;
- $textline = '';
- } else {
- ## Append this line to the current paragraph
- $paragraph .= $textline;
- ++$plines;
- }
-
- ## See if this line is blank and ends the current paragraph.
- ## If it isnt, then keep iterating until it is.
- next unless (($textline =~ /^([^\S\r\n]*)[\r\n]*$/)
- && (length $paragraph));
-
- ## Now process the paragraph
- parse_paragraph($self, $paragraph, ($nlines - $plines) + 1);
- $paragraph = '';
- $plines = 0;
- }
- ## Dont forget about the last paragraph in the file
- if (length $paragraph) {
- parse_paragraph($self, $paragraph, ($nlines - $plines) + 1)
- }
-
- ## Now pop the input stream off the top of the input stack.
- $self->_pop_input_stream();
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<parse_from_file()>
-
- $parser->parse_from_file($filename,$outfile);
-
-This method takes a filename and does the following:
-
-=over 2
-
-=item *
-
-opens the input and output files for reading
-(creating the appropriate filehandles)
-
-=item *
-
-invokes the B<parse_from_filehandle()> method passing it the
-corresponding input and output filehandles.
-
-=item *
-
-closes the input and output files.
-
-=back
-
-If the special input filename "-" or "<&STDIN" is given then the STDIN
-filehandle is used for input (and no open or close is performed). If no
-input filename is specified then "-" is implied. Filehandle references,
-or objects that support the regular IO operations (like C<E<lt>$fhE<gt>>
-or C<$fh-<Egt>getline>) are also accepted; the handles must already be
-opened.
-
-If a second argument is given then it should be the name of the desired
-output file. If the special output filename "-" or ">&STDOUT" is given
-then the STDOUT filehandle is used for output (and no open or close is
-performed). If the special output filename ">&STDERR" is given then the
-STDERR filehandle is used for output (and no open or close is
-performed). If no output filehandle is currently in use and no output
-filename is specified, then "-" is implied.
-Alternatively, filehandle references or objects that support the regular
-IO operations (like C<print>, e.g. L<IO::String>) are also accepted;
-the object must already be opened.
-
-This method does I<not> usually need to be overridden by subclasses.
-
-=cut
-
-sub parse_from_file {
- my $self = shift;
- my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : ();
- my ($infile, $outfile) = @_;
- my ($in_fh, $out_fh);
- if ($] < 5.006) {
- ($in_fh, $out_fh) = (gensym(), gensym());
- }
- my ($close_input, $close_output) = (0, 0);
- local *myData = $self;
- local *_;
-
- ## Is $infile a filename or a (possibly implied) filehandle
- if (defined $infile && ref $infile) {
- if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) {
- croak "Input from $1 reference not supported!\n";
- }
- ## Must be a filehandle-ref (or else assume its a ref to an object
- ## that supports the common IO read operations).
- $myData{_INFILE} = ${$infile};
- $in_fh = $infile;
- }
- elsif (!defined($infile) || !length($infile) || ($infile eq '-')
- || ($infile =~ /^<&(?:STDIN|0)$/i))
- {
- ## Not a filename, just a string implying STDIN
- $infile ||= '-';
- $myData{_INFILE} = '<standard input>';
- $in_fh = \*STDIN;
- }
- else {
- ## We have a filename, open it for reading
- $myData{_INFILE} = $infile;
- open($in_fh, "< $infile") or
- croak "Can't open $infile for reading: $!\n";
- $close_input = 1;
- }
-
- ## NOTE: we need to be *very* careful when "defaulting" the output
- ## file. We only want to use a default if this is the beginning of
- ## the entire document (but *not* if this is an included file). We
- ## determine this by seeing if the input stream stack has been set-up
- ## already
-
- ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref?
- if (ref $outfile) {
- ## we need to check for ref() first, as other checks involve reading
- if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) {
- croak "Output to $1 reference not supported!\n";
- }
- elsif (ref($outfile) eq 'SCALAR') {
-# # NOTE: IO::String isn't a part of the perl distribution,
-# # so probably we shouldn't support this case...
-# require IO::String;
-# $myData{_OUTFILE} = "$outfile";
-# $out_fh = IO::String->new($outfile);
- croak "Output to SCALAR reference not supported!\n";
- }
- else {
- ## Must be a filehandle-ref (or else assume its a ref to an
- ## object that supports the common IO write operations).
- $myData{_OUTFILE} = ${$outfile};
- $out_fh = $outfile;
- }
- }
- elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-')
- || ($outfile =~ /^>&?(?:STDOUT|1)$/i))
- {
- if (defined $myData{_TOP_STREAM}) {
- $out_fh = $myData{_OUTPUT};
- }
- else {
- ## Not a filename, just a string implying STDOUT
- $outfile ||= '-';
- $myData{_OUTFILE} = '<standard output>';
- $out_fh = \*STDOUT;
- }
- }
- elsif ($outfile =~ /^>&(STDERR|2)$/i) {
- ## Not a filename, just a string implying STDERR
- $myData{_OUTFILE} = '<standard error>';
- $out_fh = \*STDERR;
- }
- else {
- ## We have a filename, open it for writing
- $myData{_OUTFILE} = $outfile;
- (-d $outfile) and croak "$outfile is a directory, not POD input!\n";
- open($out_fh, "> $outfile") or
- croak "Can't open $outfile for writing: $!\n";
- $close_output = 1;
- }
-
- ## Whew! That was a lot of work to set up reasonably/robust behavior
- ## in the case of a non-filename for reading and writing. Now we just
- ## have to parse the input and close the handles when we're finished.
- $self->parse_from_filehandle(\%opts, $in_fh, $out_fh);
-
- $close_input and
- close($in_fh) || croak "Can't close $infile after reading: $!\n";
- $close_output and
- close($out_fh) || croak "Can't close $outfile after writing: $!\n";
-}
-
-#############################################################################
-
-=head1 ACCESSOR METHODS
-
-Clients of B<Pod::Parser> should use the following methods to access
-instance data fields:
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=head1 B<errorsub()>
-
- $parser->errorsub("method_name");
- $parser->errorsub(\&warn_user);
- $parser->errorsub(sub { print STDERR, @_ });
-
-Specifies the method or subroutine to use when printing error messages
-about POD syntax. The supplied method/subroutine I<must> return TRUE upon
-successful printing of the message. If C<undef> is given, then the B<carp>
-builtin is used to issue error messages (this is the default behavior).
-
- my $errorsub = $parser->errorsub()
- my $errmsg = "This is an error message!\n"
- (ref $errorsub) and &{$errorsub}($errmsg)
- or (defined $errorsub) and $parser->$errorsub($errmsg)
- or carp($errmsg);
-
-Returns a method name, or else a reference to the user-supplied subroutine
-used to print error messages. Returns C<undef> if the B<carp> builtin
-is used to issue error messages (this is the default behavior).
-
-=cut
-
-sub errorsub {
- return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB};
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<cutting()>
-
- $boolean = $parser->cutting();
-
-Returns the current C<cutting> state: a boolean-valued scalar which
-evaluates to true if text from the input file is currently being "cut"
-(meaning it is I<not> considered part of the POD document).
-
- $parser->cutting($boolean);
-
-Sets the current C<cutting> state to the given value and returns the
-result.
-
-=cut
-
-sub cutting {
- return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING};
-}
-
-##---------------------------------------------------------------------------
-
-##---------------------------------------------------------------------------
-
-=head1 B<parseopts()>
-
-When invoked with no additional arguments, B<parseopts> returns a hashtable
-of all the current parsing options.
-
- ## See if we are parsing non-POD sections as well as POD ones
- my %opts = $parser->parseopts();
- $opts{'-want_nonPODs}' and print "-want_nonPODs\n";
-
-When invoked using a single string, B<parseopts> treats the string as the
-name of a parse-option and returns its corresponding value if it exists
-(returns C<undef> if it doesn't).
-
- ## Did we ask to see '=cut' paragraphs?
- my $want_cut = $parser->parseopts('-process_cut_cmd');
- $want_cut and print "-process_cut_cmd\n";
-
-When invoked with multiple arguments, B<parseopts> treats them as
-key/value pairs and the specified parse-option names are set to the
-given values. Any unspecified parse-options are unaffected.
-
- ## Set them back to the default
- $parser->parseopts(-warnings => 0);
-
-When passed a single hash-ref, B<parseopts> uses that hash to completely
-reset the existing parse-options, all previous parse-option values
-are lost.
-
- ## Reset all options to default
- $parser->parseopts( { } );
-
-See L<"PARSING OPTIONS"> for more information on the name and meaning of each
-parse-option currently recognized.
-
-=cut
-
-sub parseopts {
- local *myData = shift;
- local *myOpts = ($myData{_PARSEOPTS} ||= {});
- return %myOpts if (@_ == 0);
- if (@_ == 1) {
- local $_ = shift;
- return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_};
- }
- my @newOpts = (%myOpts, @_);
- $myData{_PARSEOPTS} = { @newOpts };
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<output_file()>
-
- $fname = $parser->output_file();
-
-Returns the name of the output file being written.
-
-=cut
-
-sub output_file {
- return $_[0]->{_OUTFILE};
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<output_handle()>
-
- $fhandle = $parser->output_handle();
-
-Returns the output filehandle object.
-
-=cut
-
-sub output_handle {
- return $_[0]->{_OUTPUT};
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<input_file()>
-
- $fname = $parser->input_file();
-
-Returns the name of the input file being read.
-
-=cut
-
-sub input_file {
- return $_[0]->{_INFILE};
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<input_handle()>
-
- $fhandle = $parser->input_handle();
-
-Returns the current input filehandle object.
-
-=cut
-
-sub input_handle {
- return $_[0]->{_INPUT};
-}
-
-##---------------------------------------------------------------------------
-
-=begin __PRIVATE__
-
-=head1 B<input_streams()>
-
- $listref = $parser->input_streams();
-
-Returns a reference to an array which corresponds to the stack of all
-the input streams that are currently in the middle of being parsed.
-
-While parsing an input stream, it is possible to invoke
-B<parse_from_file()> or B<parse_from_filehandle()> to parse a new input
-stream and then return to parsing the previous input stream. Each input
-stream to be parsed is pushed onto the end of this input stack
-before any of its input is read. The input stream that is currently
-being parsed is always at the end (or top) of the input stack. When an
-input stream has been exhausted, it is popped off the end of the
-input stack.
-
-Each element on this input stack is a reference to C<Pod::InputSource>
-object. Please see L<Pod::InputObjects> for more details.
-
-This method might be invoked when printing diagnostic messages, for example,
-to obtain the name and line number of the all input files that are currently
-being processed.
-
-=end __PRIVATE__
-
-=cut
-
-sub input_streams {
- return $_[0]->{_INPUT_STREAMS};
-}
-
-##---------------------------------------------------------------------------
-
-=begin __PRIVATE__
-
-=head1 B<top_stream()>
-
- $hashref = $parser->top_stream();
-
-Returns a reference to the hash-table that represents the element
-that is currently at the top (end) of the input stream stack
-(see L<"input_streams()">). The return value will be the C<undef>
-if the input stack is empty.
-
-This method might be used when printing diagnostic messages, for example,
-to obtain the name and line number of the current input file.
-
-=end __PRIVATE__
-
-=cut
-
-sub top_stream {
- return $_[0]->{_TOP_STREAM} || undef;
-}
-
-#############################################################################
-
-=head1 PRIVATE METHODS AND DATA
-
-B<Pod::Parser> makes use of several internal methods and data fields
-which clients should not need to see or use. For the sake of avoiding
-name collisions for client data and methods, these methods and fields
-are briefly discussed here. Determined hackers may obtain further
-information about them by reading the B<Pod::Parser> source code.
-
-Private data fields are stored in the hash-object whose reference is
-returned by the B<new()> constructor for this class. The names of all
-private methods and data-fields used by B<Pod::Parser> begin with a
-prefix of "_" and match the regular expression C</^_\w+$/>.
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=begin _PRIVATE_
-
-=head1 B<_push_input_stream()>
-
- $hashref = $parser->_push_input_stream($in_fh,$out_fh);
-
-This method will push the given input stream on the input stack and
-perform any necessary beginning-of-document or beginning-of-file
-processing. The argument C<$in_fh> is the input stream filehandle to
-push, and C<$out_fh> is the corresponding output filehandle to use (if
-it is not given or is undefined, then the current output stream is used,
-which defaults to standard output if it doesnt exist yet).
-
-The value returned will be reference to the hash-table that represents
-the new top of the input stream stack. I<Please Note> that it is
-possible for this method to use default values for the input and output
-file handles. If this happens, you will need to look at the C<INPUT>
-and C<OUTPUT> instance data members to determine their new values.
-
-=end _PRIVATE_
-
-=cut
-
-sub _push_input_stream {
- my ($self, $in_fh, $out_fh) = @_;
- local *myData = $self;
-
- ## Initialize stuff for the entire document if this is *not*
- ## an included file.
- ##
- ## NOTE: we need to be *very* careful when "defaulting" the output
- ## filehandle. We only want to use a default value if this is the
- ## beginning of the entire document (but *not* if this is an included
- ## file).
- unless (defined $myData{_TOP_STREAM}) {
- $out_fh = \*STDOUT unless (defined $out_fh);
- $myData{_CUTTING} = 1; ## current "cutting" state
- $myData{_INPUT_STREAMS} = []; ## stack of all input streams
- }
-
- ## Initialize input indicators
- $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE});
- $myData{_OUTPUT} = $out_fh if (defined $out_fh);
- $in_fh = \*STDIN unless (defined $in_fh);
- $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE});
- $myData{_INPUT} = $in_fh;
- my $input_top = $myData{_TOP_STREAM}
- = new Pod::InputSource(
- -name => $myData{_INFILE},
- -handle => $in_fh,
- -was_cutting => $myData{_CUTTING}
- );
- local *input_stack = $myData{_INPUT_STREAMS};
- push(@input_stack, $input_top);
-
- ## Perform beginning-of-document and/or beginning-of-input processing
- $self->begin_pod() if (@input_stack == 1);
- $self->begin_input();
-
- return $input_top;
-}
-
-##---------------------------------------------------------------------------
-
-=begin _PRIVATE_
-
-=head1 B<_pop_input_stream()>
-
- $hashref = $parser->_pop_input_stream();
-
-This takes no arguments. It will perform any necessary end-of-file or
-end-of-document processing and then pop the current input stream from
-the top of the input stack.
-
-The value returned will be reference to the hash-table that represents
-the new top of the input stream stack.
-
-=end _PRIVATE_
-
-=cut
-
-sub _pop_input_stream {
- my ($self) = @_;
- local *myData = $self;
- local *input_stack = $myData{_INPUT_STREAMS};
-
- ## Perform end-of-input and/or end-of-document processing
- $self->end_input() if (@input_stack > 0);
- $self->end_pod() if (@input_stack == 1);
-
- ## Restore cutting state to whatever it was before we started
- ## parsing this file.
- my $old_top = pop(@input_stack);
- $myData{_CUTTING} = $old_top->was_cutting();
-
- ## Dont forget to reset the input indicators
- my $input_top = undef;
- if (@input_stack > 0) {
- $input_top = $myData{_TOP_STREAM} = $input_stack[-1];
- $myData{_INFILE} = $input_top->name();
- $myData{_INPUT} = $input_top->handle();
- } else {
- delete $myData{_TOP_STREAM};
- delete $myData{_INPUT_STREAMS};
- }
-
- return $input_top;
-}
-
-#############################################################################
-
-=head1 TREE-BASED PARSING
-
-If straightforward stream-based parsing wont meet your needs (as is
-likely the case for tasks such as translating PODs into structured
-markup languages like HTML and XML) then you may need to take the
-tree-based approach. Rather than doing everything in one pass and
-calling the B<interpolate()> method to expand sequences into text, it
-may be desirable to instead create a parse-tree using the B<parse_text()>
-method to return a tree-like structure which may contain an ordered
-list of children (each of which may be a text-string, or a similar
-tree-like structure).
-
-Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and
-to the objects described in L<Pod::InputObjects>. The former describes
-the gory details and parameters for how to customize and extend the
-parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides
-several objects that may all be used interchangeably as parse-trees. The
-most obvious one is the B<Pod::ParseTree> object. It defines the basic
-interface and functionality that all things trying to be a POD parse-tree
-should do. A B<Pod::ParseTree> is defined such that each "node" may be a
-text-string, or a reference to another parse-tree. Each B<Pod::Paragraph>
-object and each B<Pod::InteriorSequence> object also supports the basic
-parse-tree interface.
-
-The B<parse_text()> method takes a given paragraph of text, and
-returns a parse-tree that contains one or more children, each of which
-may be a text-string, or an InteriorSequence object. There are also
-callback-options that may be passed to B<parse_text()> to customize
-the way it expands or transforms interior-sequences, as well as the
-returned result. These callbacks can be used to create a parse-tree
-with custom-made objects (which may or may not support the parse-tree
-interface, depending on how you choose to do it).
-
-If you wish to turn an entire POD document into a parse-tree, that process
-is fairly straightforward. The B<parse_text()> method is the key to doing
-this successfully. Every paragraph-callback (i.e. the polymorphic methods
-for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes
-a B<Pod::Paragraph> object as an argument. Each paragraph object has a
-B<parse_tree()> method that can be used to get or set a corresponding
-parse-tree. So for each of those paragraph-callback methods, simply call
-B<parse_text()> with the options you desire, and then use the returned
-parse-tree to assign to the given paragraph object.
-
-That gives you a parse-tree for each paragraph - so now all you need is
-an ordered list of paragraphs. You can maintain that yourself as a data
-element in the object/hash. The most straightforward way would be simply
-to use an array-ref, with the desired set of custom "options" for each
-invocation of B<parse_text>. Let's assume the desired option-set is
-given by the hash C<%options>. Then we might do something like the
-following:
-
- package MyPodParserTree;
-
- @ISA = qw( Pod::Parser );
-
- ...
-
- sub begin_pod {
- my $self = shift;
- $self->{'-paragraphs'} = []; ## initialize paragraph list
- }
-
- sub command {
- my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
- my $ptree = $parser->parse_text({%options}, $paragraph, ...);
- $pod_para->parse_tree( $ptree );
- push @{ $self->{'-paragraphs'} }, $pod_para;
- }
-
- sub verbatim {
- my ($parser, $paragraph, $line_num, $pod_para) = @_;
- push @{ $self->{'-paragraphs'} }, $pod_para;
- }
-
- sub textblock {
- my ($parser, $paragraph, $line_num, $pod_para) = @_;
- my $ptree = $parser->parse_text({%options}, $paragraph, ...);
- $pod_para->parse_tree( $ptree );
- push @{ $self->{'-paragraphs'} }, $pod_para;
- }
-
- ...
-
- package main;
- ...
- my $parser = new MyPodParserTree(...);
- $parser->parse_from_file(...);
- my $paragraphs_ref = $parser->{'-paragraphs'};
-
-Of course, in this module-author's humble opinion, I'd be more inclined to
-use the existing B<Pod::ParseTree> object than a simple array. That way
-everything in it, paragraphs and sequences, all respond to the same core
-interface for all parse-tree nodes. The result would look something like:
-
- package MyPodParserTree2;
-
- ...
-
- sub begin_pod {
- my $self = shift;
- $self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree
- }
-
- sub parse_tree {
- ## convenience method to get/set the parse-tree for the entire POD
- (@_ > 1) and $_[0]->{'-ptree'} = $_[1];
- return $_[0]->{'-ptree'};
- }
-
- sub command {
- my ($parser, $command, $paragraph, $line_num, $pod_para) = @_;
- my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
- $pod_para->parse_tree( $ptree );
- $parser->parse_tree()->append( $pod_para );
- }
-
- sub verbatim {
- my ($parser, $paragraph, $line_num, $pod_para) = @_;
- $parser->parse_tree()->append( $pod_para );
- }
-
- sub textblock {
- my ($parser, $paragraph, $line_num, $pod_para) = @_;
- my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...);
- $pod_para->parse_tree( $ptree );
- $parser->parse_tree()->append( $pod_para );
- }
-
- ...
-
- package main;
- ...
- my $parser = new MyPodParserTree2(...);
- $parser->parse_from_file(...);
- my $ptree = $parser->parse_tree;
- ...
-
-Now you have the entire POD document as one great big parse-tree. You
-can even use the B<-expand_seq> option to B<parse_text> to insert
-whole different kinds of objects. Just don't expect B<Pod::Parser>
-to know what to do with them after that. That will need to be in your
-code. Or, alternatively, you can insert any object you like so long as
-it conforms to the B<Pod::ParseTree> interface.
-
-One could use this to create subclasses of B<Pod::Paragraphs> and
-B<Pod::InteriorSequences> for specific commands (or to create your own
-custom node-types in the parse-tree) and add some kind of B<emit()>
-method to each custom node/subclass object in the tree. Then all you'd
-need to do is recursively walk the tree in the desired order, processing
-the children (most likely from left to right) by formatting them if
-they are text-strings, or by calling their B<emit()> method if they
-are objects/references.
-
-=head1 CAVEATS
-
-Please note that POD has the notion of "paragraphs": this is something
-starting I<after> a blank (read: empty) line, with the single exception
-of the file start, which is also starting a paragraph. That means that
-especially a command (e.g. C<=head1>) I<must> be preceded with a blank
-line; C<__END__> is I<not> a blank line.
-
-=head1 SEE ALSO
-
-L<Pod::InputObjects>, L<Pod::Select>
-
-B<Pod::InputObjects> defines POD input objects corresponding to
-command paragraphs, parse-trees, and interior-sequences.
-
-B<Pod::Select> is a subclass of B<Pod::Parser> which provides the ability
-to selectively include and/or exclude sections of a POD document from being
-translated based upon the current heading, subheading, subsubheading, etc.
-
-=for __PRIVATE__
-B<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users
-the ability the employ I<callback functions> instead of, or in addition
-to, overriding methods of the base class.
-
-=for __PRIVATE__
-B<Pod::Select> and B<Pod::Callbacks> do not override any
-methods nor do they define any new methods with the same name. Because
-of this, they may I<both> be used (in combination) as a base class of
-the same subclass in order to combine their functionality without
-causing any namespace clashes due to multiple inheritance.
-
-=head1 AUTHOR
-
-Please report bugs using L<http://rt.cpan.org>.
-
-Brad Appleton E<lt>bradapp at enteract.comE<gt>
-
-Based on code for B<Pod::Text> written by
-Tom Christiansen E<lt>tchrist at mox.perl.comE<gt>
-
-=head1 LICENSE
-
-Pod-Parser is free software; you can redistribute it and/or modify it
-under the terms of the Artistic License distributed with Perl version
-5.000 or (at your option) any later version. Please refer to the
-Artistic License that came with your Perl distribution for more
-details. If your version of Perl was not distributed under the
-terms of the Artistic License, than you may distribute PodParser
-under the same terms as Perl itself.
-
-=cut
-
-1;
-# vim: ts=4 sw=4 et
Deleted: trunk/contrib/perl/lib/Pod/Perldoc.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Perldoc.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Perldoc.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1828 +0,0 @@
-
-require 5;
-use 5.006; # we use some open(X, "<", $y) syntax
-package Pod::Perldoc;
-use strict;
-use warnings;
-use Config '%Config';
-
-use Fcntl; # for sysopen
-use File::Spec::Functions qw(catfile catdir splitdir);
-
-use vars qw($VERSION @Pagers $Bindir $Pod2man
- $Temp_Files_Created $Temp_File_Lifetime
-);
-$VERSION = '3.14_04';
-#..........................................................................
-
-BEGIN { # Make a DEBUG constant very first thing...
- unless(defined &DEBUG) {
- if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint
- eval("sub DEBUG () {$1}");
- die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@;
- } else {
- *DEBUG = sub () {0};
- }
- }
-}
-
-use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
-
-#..........................................................................
-
-sub TRUE () {1}
-sub FALSE () {return}
-
-BEGIN {
- *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS;
- *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
- *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
- *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
- *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
- *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux;
- *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX;
-}
-
-$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
- # If it's older than five days, it's quite unlikely
- # that anyone's still looking at it!!
- # (Currently used only by the MSWin cleanup routine)
-
-
-#..........................................................................
-{ my $pager = $Config{'pager'};
- push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
-}
-$Bindir = $Config{'scriptdirexp'};
-$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
-
-# End of class-init stuff
-#
-###########################################################################
-#
-# Option accessors...
-
-foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdUL}) {
- no strict 'refs';
- *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
-}
-
-# And these are so that GetOptsOO knows they take options:
-sub opt_f_with { shift->_elem('opt_f', @_) }
-sub opt_q_with { shift->_elem('opt_q', @_) }
-sub opt_d_with { shift->_elem('opt_d', @_) }
-sub opt_L_with { shift->_elem('opt_L', @_) }
-
-sub opt_w_with { # Specify an option for the formatter subclass
- my($self, $value) = @_;
- if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) {
- my $option = $1;
- my $option_value = defined($2) ? $2 : "TRUE";
- $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
- $self->add_formatter_option( $option, $option_value );
- } else {
- warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
- }
- return;
-}
-
-sub opt_M_with { # specify formatter class name(s)
- my($self, $classes) = @_;
- return unless defined $classes and length $classes;
- DEBUG > 4 and print "Considering new formatter classes -M$classes\n";
- my @classes_to_add;
- foreach my $classname (split m/[,;]+/s, $classes) {
- next unless $classname =~ m/\S/;
- if( $classname =~ m/^(\w+(::\w+)+)$/s ) {
- # A mildly restrictive concept of what modulenames are valid.
- push @classes_to_add, $1; # untaint
- } else {
- warn "\"$classname\" isn't a valid classname. Ignoring.\n";
- }
- }
-
- unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
-
- DEBUG > 3 and print(
- "Adding @classes_to_add to the list of formatter classes, "
- . "making them @{ $self->{'formatter_classes'} }.\n"
- );
-
- return;
-}
-
-sub opt_V { # report version and exit
- print join '',
- "Perldoc v$VERSION, under perl v$] for $^O",
-
- (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
- ? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
-
- (chr(65) eq 'A') ? () : " (non-ASCII)",
-
- "\n",
- ;
- exit;
-}
-
-sub opt_t { # choose plaintext as output format
- my $self = shift;
- $self->opt_o_with('text') if @_ and $_[0];
- return $self->_elem('opt_t', @_);
-}
-
-sub opt_u { # choose raw pod as output format
- my $self = shift;
- $self->opt_o_with('pod') if @_ and $_[0];
- return $self->_elem('opt_u', @_);
-}
-
-sub opt_n_with {
- # choose man as the output format, and specify the proggy to run
- my $self = shift;
- $self->opt_o_with('man') if @_ and $_[0];
- $self->_elem('opt_n', @_);
-}
-
-sub opt_o_with { # "o" for output format
- my($self, $rest) = @_;
- return unless defined $rest and length $rest;
- if($rest =~ m/^(\w+)$/s) {
- $rest = $1; #untaint
- } else {
- warn "\"$rest\" isn't a valid output format. Skipping.\n";
- return;
- }
-
- $self->aside("Noting \"$rest\" as desired output format...\n");
-
- # Figure out what class(es) that could actually mean...
-
- my @classes;
- foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
- # Messy but smart:
- foreach my $stem (
- $rest, # Yes, try it first with the given capitalization
- "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
-
- ) {
- push @classes, $prefix . $stem;
- #print "Considering $prefix$stem\n";
- }
-
- # Tidier, but misses too much:
- #push @classes, $prefix . ucfirst(lc($rest));
- }
- $self->opt_M_with( join ";", @classes );
- return;
-}
-
-###########################################################################
-# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
-
-sub run { # to be called by the "perldoc" executable
- my $class = shift;
- if(DEBUG > 3) {
- print "Parameters to $class\->run:\n";
- my @x = @_;
- while(@x) {
- $x[1] = '<undef>' unless defined $x[1];
- $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
- print " [$x[0]] => [$x[1]]\n";
- splice @x,0,2;
- }
- print "\n";
- }
- return $class -> new(@_) -> process() || 0;
-}
-
-# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % %
-###########################################################################
-
-sub new { # yeah, nothing fancy
- my $class = shift;
- my $new = bless {@_}, (ref($class) || $class);
- DEBUG > 1 and print "New $class object $new\n";
- $new->init();
- $new;
-}
-
-#..........................................................................
-
-sub aside { # If we're in -v or DEBUG mode, say this.
- my $self = shift;
- if( DEBUG or $self->opt_v ) {
- my $out = join( '',
- DEBUG ? do {
- my $callsub = (caller(1))[3];
- my $package = quotemeta(__PACKAGE__ . '::');
- $callsub =~ s/^$package/'/os;
- # the o is justified, as $package really won't change.
- $callsub . ": ";
- } : '',
- @_,
- );
- if(DEBUG) { print $out } else { print STDERR $out }
- }
- return;
-}
-
-#..........................................................................
-
-sub usage {
- my $self = shift;
- warn "@_\n" if @_;
-
- # Erase evidence of previous errors (if any), so exit status is simple.
- $! = 0;
-
- die <<EOF;
-perldoc [options] PageName|ModuleName|ProgramName...
-perldoc [options] -f BuiltinFunction
-perldoc [options] -q FAQRegex
-
-Options:
- -h Display this help message
- -V report version
- -r Recursive search (slow)
- -i Ignore case
- -t Display pod using pod2text instead of pod2man and nroff
- (-t is the default on win32 unless -n is specified)
- -u Display unformatted pod text
- -m Display module's file in its entirety
- -n Specify replacement for nroff
- -l Display the module's file name
- -F Arguments are file names, not modules
- -v Verbosely describe what's going on
- -T Send output to STDOUT without any pager
- -d output_filename_to_send_to
- -o output_format_name
- -M FormatterModuleNameToUse
- -w formatter_option:option_value
- -L translation_code Choose doc translation (if any)
- -X use index if present (looks for pod.idx at $Config{archlib})
- -q Search the text of questions (not answers) in perlfaq[1-9]
-
-PageName|ModuleName...
- is the name of a piece of documentation that you want to look at. You
- may either give a descriptive name of the page (as in the case of
- `perlfunc') the name of a module, either like `Term::Info' or like
- `Term/Info', or the name of a program, like `perldoc'.
-
-BuiltinFunction
- is the name of a perl function. Will extract documentation from
- `perlfunc'.
-
-FAQRegex
- is a regex. Will search perlfaq[1-9] for and extract any
- questions that match.
-
-Any switches in the PERLDOC environment variable will be used before the
-command line arguments. The optional pod index file contains a list of
-filenames, one per line.
- [Perldoc v$VERSION]
-EOF
-
-}
-
-#..........................................................................
-
-sub usage_brief {
- my $me = $0; # Editing $0 is unportable
-
- $me =~ s,.*[/\\],,; # get basename
-
- die <<"EOUSAGE";
-Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName
- $me -f PerlFunc
- $me -q FAQKeywords
-
-The -h option prints more help. Also try "perldoc perldoc" to get
-acquainted with the system. [Perldoc v$VERSION]
-EOUSAGE
-
-}
-
-#..........................................................................
-
-sub pagers { @{ shift->{'pagers'} } }
-
-#..........................................................................
-
-sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_)
- if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] }
- else { return $_[0]{ $_[1] } }
-}
-#..........................................................................
-###########################################################################
-#
-# Init formatter switches, and start it off with __bindir and all that
-# other stuff that ToMan.pm needs.
-#
-
-sub init {
- my $self = shift;
-
- # Make sure creat()s are neither too much nor too little
- eval { umask(0077) }; # doubtless someone has no mask
-
- $self->{'args'} ||= \@ARGV;
- $self->{'found'} ||= [];
- $self->{'temp_file_list'} ||= [];
-
-
- $self->{'target'} = undef;
-
- $self->init_formatter_class_list;
-
- $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'};
- $self->{'bindir' } = $Bindir unless exists $self->{'bindir'};
- $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'};
-
- push @{ $self->{'formatter_switches'} = [] }, (
- # Yeah, we could use a hashref, but maybe there's some class where options
- # have to be ordered; so we'll use an arrayref.
-
- [ '__bindir' => $self->{'bindir' } ],
- [ '__pod2man' => $self->{'pod2man'} ],
- );
-
- DEBUG > 3 and printf "Formatter switches now: [%s]\n",
- join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
-
- $self->{'translators'} = [];
- $self->{'extra_search_dirs'} = [];
-
- return;
-}
-
-#..........................................................................
-
-sub init_formatter_class_list {
- my $self = shift;
- $self->{'formatter_classes'} ||= [];
-
- # Remember, no switches have been read yet, when
- # we've started this routine.
-
- $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
- $self->opt_o_with('text');
- $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
- || !($ENV{TERM} && (
- ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
- ));
-
- return;
-}
-
-#..........................................................................
-
-sub process {
- # if this ever returns, its retval will be used for exit(RETVAL)
-
- my $self = shift;
- DEBUG > 1 and print " Beginning process.\n";
- DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n";
- if(DEBUG > 3) {
- print "Object contents:\n";
- my @x = %$self;
- while(@x) {
- $x[1] = '<undef>' unless defined $x[1];
- $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY';
- print " [$x[0]] => [$x[1]]\n";
- splice @x,0,2;
- }
- print "\n";
- }
-
- # TODO: make it deal with being invoked as various different things
- # such as perlfaq".
-
- return $self->usage_brief unless @{ $self->{'args'} };
- $self->pagers_guessing;
- $self->options_reading;
- $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
- $self->drop_privs_maybe;
- $self->options_processing;
-
- # Hm, we have @pages and @found, but we only really act on one
- # file per call, with the exception of the opt_q hack, and with
- # -l things
-
- $self->aside("\n");
-
- my @pages;
- $self->{'pages'} = \@pages;
- if( $self->opt_f) { @pages = ("perlfunc") }
- elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
- else { @pages = @{$self->{'args'}};
- # @pages = __FILE__
- # if @pages == 1 and $pages[0] eq 'perldoc';
- }
-
- return $self->usage_brief unless @pages;
-
- $self->find_good_formatter_class();
- $self->formatter_sanity_check();
-
- $self->maybe_diddle_INC();
- # for when we're apparently in a module or extension directory
-
- my @found = $self->grand_search_init(\@pages);
- exit (IS_VMS ? 98962 : 1) unless @found;
-
- if ($self->opt_l) {
- DEBUG and print "We're in -l mode, so byebye after this:\n";
- print join("\n", @found), "\n";
- return;
- }
-
- $self->tweak_found_pathnames(\@found);
- $self->assert_closing_stdout;
- return $self->page_module_file(@found) if $self->opt_m;
- DEBUG > 2 and print "Found: [@found]\n";
-
- return $self->render_and_page(\@found);
-}
-
-#..........................................................................
-{
-
-my( %class_seen, %class_loaded );
-sub find_good_formatter_class {
- my $self = $_[0];
- my @class_list = @{ $self->{'formatter_classes'} || [] };
- die "WHAT? Nothing in the formatter class list!?" unless @class_list;
-
- my $good_class_found;
- foreach my $c (@class_list) {
- DEBUG > 4 and print "Trying to load $c...\n";
- if($class_loaded{$c}) {
- DEBUG > 4 and print "OK, the already-loaded $c it is!\n";
- $good_class_found = $c;
- last;
- }
-
- if($class_seen{$c}) {
- DEBUG > 4 and print
- "I've tried $c before, and it's no good. Skipping.\n";
- next;
- }
-
- $class_seen{$c} = 1;
-
- if( $c->can('parse_from_file') ) {
- DEBUG > 4 and print
- "Interesting, the formatter class $c is already loaded!\n";
-
- } elsif(
- (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
- # the alway case-insensitive fs's
- and $class_seen{lc("~$c")}++
- ) {
- DEBUG > 4 and print
- "We already used something quite like \"\L$c\E\", so no point using $c\n";
- # This avoids redefining the package.
- } else {
- DEBUG > 4 and print "Trying to eval 'require $c'...\n";
-
- local $^W = $^W;
- if(DEBUG() or $self->opt_v) {
- # feh, let 'em see it
- } else {
- $^W = 0;
- # The average user just has no reason to be seeing
- # $^W-suppressable warnings from the the require!
- }
-
- eval "require $c";
- if($@) {
- DEBUG > 4 and print "Couldn't load $c: $!\n";
- next;
- }
- }
-
- if( $c->can('parse_from_file') ) {
- DEBUG > 4 and print "Settling on $c\n";
- my $v = $c->VERSION;
- $v = ( defined $v and length $v ) ? " version $v" : '';
- $self->aside("Formatter class $c$v successfully loaded!\n");
- $good_class_found = $c;
- last;
- } else {
- DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
- }
- }
-
- die "Can't find any loadable formatter class in @class_list?!\nAborting"
- unless $good_class_found;
-
- $self->{'formatter_class'} = $good_class_found;
- $self->aside("Will format with the class $good_class_found\n");
-
- return;
-}
-
-}
-#..........................................................................
-
-sub formatter_sanity_check {
- my $self = shift;
- my $formatter_class = $self->{'formatter_class'}
- || die "NO FORMATTER CLASS YET!?";
-
- if(!$self->opt_T # so -T can FORCE sending to STDOUT
- and $formatter_class->can('is_pageable')
- and !$formatter_class->is_pageable
- and !$formatter_class->can('page_for_perldoc')
- ) {
- my $ext =
- ($formatter_class->can('output_extension')
- && $formatter_class->output_extension
- ) || '';
- $ext = ".$ext" if length $ext;
-
- die
- "When using Perldoc to format with $formatter_class, you have to\n"
- . "specify -T or -dsomefile$ext\n"
- . "See `perldoc perldoc' for more information on those switches.\n"
- ;
- }
-}
-
-#..........................................................................
-
-sub render_and_page {
- my($self, $found_list) = @_;
-
- $self->maybe_generate_dynamic_pod($found_list);
-
- my($out, $formatter) = $self->render_findings($found_list);
-
- if($self->opt_d) {
- printf "Perldoc (%s) output saved to %s\n",
- $self->{'formatter_class'} || ref($self),
- $out;
- print "But notice that it's 0 bytes long!\n" unless -s $out;
-
-
- } elsif( # Allow the formatter to "page" itself, if it wants.
- $formatter->can('page_for_perldoc')
- and do {
- $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n");
- if( $formatter->page_for_perldoc($out, $self) ) {
- $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n");
- 1;
- } else {
- $self->aside("page_for_perldoc returned false, so paging with $self instead.\n");
- '';
- }
- }
- ) {
- # Do nothing, since the formatter has "paged" it for itself.
-
- } else {
- # Page it normally (internally)
-
- if( -s $out ) { # Usual case:
- $self->page($out, $self->{'output_to_stdout'}, $self->pagers);
-
- } else {
- # Odd case:
- $self->aside("Skipping $out (from $$found_list[0] "
- . "via $$self{'formatter_class'}) as it is 0-length.\n");
-
- push @{ $self->{'temp_file_list'} }, $out;
- $self->unlink_if_temp_file($out);
- }
- }
-
- $self->after_rendering(); # any extra cleanup or whatever
-
- return;
-}
-
-#..........................................................................
-
-sub options_reading {
- my $self = shift;
-
- if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
- require Text::ParseWords;
- $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
- # Yes, appends to the beginning
- unshift @{ $self->{'args'} },
- Text::ParseWords::shellwords( $ENV{"PERLDOC"} )
- ;
- DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n";
- } else {
- DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n";
- }
-
- DEBUG > 1
- and print " Args right before switch processing: @{$self->{'args'}}\n";
-
- Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' )
- or return $self->usage;
-
- DEBUG > 1
- and print " Args after switch processing: @{$self->{'args'}}\n";
-
- return $self->usage if $self->opt_h;
-
- return;
-}
-
-#..........................................................................
-
-sub options_processing {
- my $self = shift;
-
- if ($self->opt_X) {
- my $podidx = "$Config{'archlib'}/pod.idx";
- $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
- $self->{'podidx'} = $podidx;
- }
-
- $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT;
-
- $self->options_sanity;
-
- $self->opt_n("nroff") unless $self->opt_n;
- $self->add_formatter_option( '__nroffer' => $self->opt_n );
-
- # Adjust for using translation packages
- $self->add_translator($self->opt_L) if $self->opt_L;
-
- return;
-}
-
-#..........................................................................
-
-sub options_sanity {
- my $self = shift;
-
- # The opts-counting stuff interacts quite badly with
- # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"}
- # set to -t, and I specify -u on the command line, I don't want
- # to be hectored at that -u and -t don't make sense together.
-
- #my $opts = grep $_ && 1, # yes, the count of the set ones
- # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l
- #;
- #
- #$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
-
-
- # Any sanity-checking need doing here?
-
- # But does not make sense to set either -f or -q in $ENV{"PERLDOC"}
- if( $self->opt_f or $self->opt_q ) {
- $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
- warn
- "Perldoc is only really meant for reading one word at a time.\n",
- "So these parameters are being ignored: ",
- join(' ', @{$self->{'args'}}),
- "\n"
- if @{$self->{'args'}}
- }
- return;
-}
-
-#..........................................................................
-
-sub grand_search_init {
- my($self, $pages, @found) = @_;
-
- foreach (@$pages) {
- if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
- my $searchfor = catfile split '::', $_;
- $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
- local $_;
- while (<PODIDX>) {
- chomp;
- push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
- }
- close(PODIDX) or die "Can't close $$self{'podidx'}: $!";
- next;
- }
-
- $self->aside( "Searching for $_\n" );
-
- if ($self->opt_F) {
- next unless -r;
- push @found, $_ if $self->opt_m or $self->containspod($_);
- next;
- }
-
- my @searchdirs;
-
- # prepend extra search directories (including language specific)
- push @searchdirs, @{ $self->{'extra_search_dirs'} };
-
- # We must look both in @INC for library modules and in $bindir
- # for executables, like h2xs or perldoc itself.
- push @searchdirs, ($self->{'bindir'}, @INC);
- unless ($self->opt_m) {
- if (IS_VMS) {
- my($i,$trn);
- for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
- push(@searchdirs,$trn);
- }
- push(@searchdirs,'perl_root:[lib.pod]') # installed pods
- }
- else {
- push(@searchdirs, grep(-d, split($Config{path_sep},
- $ENV{'PATH'})));
- }
- }
- my @files = $self->searchfor(0,$_, at searchdirs);
- if (@files) {
- $self->aside( "Found as @files\n" );
- }
- else {
- # no match, try recursive search
- @searchdirs = grep(!/^\.\z/s, at INC);
- @files= $self->searchfor(1,$_, at searchdirs) if $self->opt_r;
- if (@files) {
- $self->aside( "Loosely found as @files\n" );
- }
- else {
- print STDERR "No " .
- ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
- if ( @{ $self->{'found'} } ) {
- print STDERR "However, try\n";
- for my $dir (@{ $self->{'found'} }) {
- opendir(DIR, $dir) or die "opendir $dir: $!";
- while (my $file = readdir(DIR)) {
- next if ($file =~ /^\./s);
- $file =~ s/\.(pm|pod)\z//; # XXX: badfs
- print STDERR "\tperldoc $_\::$file\n";
- }
- closedir(DIR) or die "closedir $dir: $!";
- }
- }
- }
- }
- push(@found, at files);
- }
- return @found;
-}
-
-#..........................................................................
-
-sub maybe_generate_dynamic_pod {
- my($self, $found_things) = @_;
- my @dynamic_pod;
-
- $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
-
- $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
-
- if( ! $self->opt_f and ! $self->opt_q ) {
- DEBUG > 4 and print "That's a non-dynamic pod search.\n";
- } elsif ( @dynamic_pod ) {
- $self->aside("Hm, I found some Pod from that search!\n");
- my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
-
- push @{ $self->{'temp_file_list'} }, $buffer;
- # I.e., it MIGHT be deleted at the end.
-
- my $in_list = $self->opt_f;
-
- print $buffd "=over 8\n\n" if $in_list;
- print $buffd @dynamic_pod or die "Can't print $buffer: $!";
- print $buffd "=back\n" if $in_list;
-
- close $buffd or die "Can't close $buffer: $!";
-
- @$found_things = $buffer;
- # Yes, so found_things never has more than one thing in
- # it, by time we leave here
-
- $self->add_formatter_option('__filter_nroff' => 1);
-
- } else {
- @$found_things = ();
- $self->aside("I found no Pod from that search!\n");
- }
-
- return;
-}
-
-#..........................................................................
-
-sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
- my $self = shift;
- push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
-
- DEBUG > 3 and printf "Formatter switches now: [%s]\n",
- join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
-
- return;
-}
-
-#.........................................................................
-
-sub new_translator { # $tr = $self->new_translator($lang);
- my $self = shift;
- my $lang = shift;
-
- my $pack = 'POD2::' . uc($lang);
- eval "require $pack";
- if ( !$@ && $pack->can('new') ) {
- return $pack->new();
- }
-
- eval { require POD2::Base };
- return if $@;
-
- return POD2::Base->new({ lang => $lang });
-}
-
-#.........................................................................
-
-sub add_translator { # $self->add_translator($lang);
- my $self = shift;
- for my $lang (@_) {
- my $tr = $self->new_translator($lang);
- if ( defined $tr ) {
- push @{ $self->{'translators'} }, $tr;
- push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs;
-
- $self->aside( "translator for '$lang' loaded\n" );
- } else {
- # non-installed or bad translator package
- warn "Perldoc cannot load translator package for '$lang': ignored\n";
- }
-
- }
- return;
-}
-
-#..........................................................................
-
-sub search_perlfunc {
- my($self, $found_things, $pod) = @_;
-
- DEBUG > 2 and print "Search: @$found_things\n";
-
- my $perlfunc = shift @$found_things;
- open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
- or die("Can't open $perlfunc: $!");
-
- # Functions like -r, -e, etc. are listed under `-X'.
- my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
- ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
-
- DEBUG > 2 and
- print "Going to perlfunc-scan for $search_re in $perlfunc\n";
-
- my $re = 'Alphabetical Listing of Perl Functions';
- if ( $self->opt_L ) {
- my $tr = $self->{'translators'}->[0];
- $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
- }
-
- # Skip introduction
- local $_;
- while (<PFUNC>) {
- last if /^=head2 $re/;
- }
-
- # Look for our function
- my $found = 0;
- my $inlist = 0;
- while (<PFUNC>) { # "The Mothership Connection is here!"
- if ( m/^=item\s+$search_re\b/ ) {
- $found = 1;
- }
- elsif (/^=item/) {
- last if $found > 1 and not $inlist;
- }
- next unless $found;
- if (/^=over/) {
- ++$inlist;
- }
- elsif (/^=back/) {
- --$inlist;
- }
- push @$pod, $_;
- ++$found if /^\w/; # found descriptive text
- }
- if (!@$pod) {
- die sprintf
- "No documentation for perl function `%s' found\n",
- $self->opt_f
- ;
- }
- close PFUNC or die "Can't open $perlfunc: $!";
-
- return;
-}
-
-#..........................................................................
-
-sub search_perlfaqs {
- my( $self, $found_things, $pod) = @_;
-
- my $found = 0;
- my %found_in;
- my $search_key = $self->opt_q;
-
- my $rx = eval { qr/$search_key/ }
- or die <<EOD;
-Invalid regular expression '$search_key' given as -q pattern:
-$@
-Did you mean \\Q$search_key ?
-
-EOD
-
- local $_;
- foreach my $file (@$found_things) {
- die "invalid file spec: $!" if $file =~ /[<>|]/;
- open(INFAQ, "<", $file) # XXX 5.6ism
- or die "Can't read-open $file: $!\nAborting";
- while (<INFAQ>) {
- if ( m/^=head2\s+.*(?:$search_key)/i ) {
- $found = 1;
- push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
- }
- elsif (/^=head[12]/) {
- $found = 0;
- }
- next unless $found;
- push @$pod, $_;
- }
- close(INFAQ);
- }
- die("No documentation for perl FAQ keyword `$search_key' found\n")
- unless @$pod;
-
- return;
-}
-
-
-#..........................................................................
-
-sub render_findings {
- # Return the filename to open
-
- my($self, $found_things) = @_;
-
- my $formatter_class = $self->{'formatter_class'}
- || die "No formatter class set!?";
- my $formatter = $formatter_class->can('new')
- ? $formatter_class->new
- : $formatter_class
- ;
-
- if(! @$found_things) {
- die "Nothing found?!";
- # should have been caught before here
- } elsif(@$found_things > 1) {
- warn
- "Perldoc is only really meant for reading one document at a time.\n",
- "So these parameters are being ignored: ",
- join(' ', @$found_things[1 .. $#$found_things] ),
- "\n"
- }
-
- my $file = $found_things->[0];
-
- DEBUG > 3 and printf "Formatter switches now: [%s]\n",
- join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
-
- # Set formatter options:
- if( ref $formatter ) {
- foreach my $f (@{ $self->{'formatter_switches'} || [] }) {
- my($switch, $value, $silent_fail) = @$f;
- if( $formatter->can($switch) ) {
- eval { $formatter->$switch( defined($value) ? $value : () ) };
- warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
- if $@;
- } else {
- if( $silent_fail or $switch =~ m/^__/s ) {
- DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
- } else {
- warn "$formatter_class doesn't recognize the $switch switch.\n";
- }
- }
- }
- }
-
- $self->{'output_is_binary'} =
- $formatter->can('write_with_binmode') && $formatter->write_with_binmode;
-
- my ($out_fh, $out) = $self->new_output_file(
- ( $formatter->can('output_extension') && $formatter->output_extension )
- || undef,
- $self->useful_filename_bit,
- );
-
- # Now, finally, do the formatting!
- {
- local $^W = $^W;
- if(DEBUG() or $self->opt_v) {
- # feh, let 'em see it
- } else {
- $^W = 0;
- # The average user just has no reason to be seeing
- # $^W-suppressable warnings from the formatting!
- }
-
- eval { $formatter->parse_from_file( $file, $out_fh ) };
- }
-
- warn "Error while formatting with $formatter_class:\n $@\n" if $@;
- DEBUG > 2 and print "Back from formatting with $formatter_class\n";
-
- close $out_fh
- or warn "Can't close $out: $!\n(Did $formatter already close it?)";
- sleep 0; sleep 0; sleep 0;
- # Give the system a few timeslices to meditate on the fact
- # that the output file does in fact exist and is closed.
-
- $self->unlink_if_temp_file($file);
-
- unless( -s $out ) {
- if( $formatter->can( 'if_zero_length' ) ) {
- # Basically this is just a hook for Pod::Simple::Checker; since
- # what other class could /happily/ format an input file with Pod
- # as a 0-length output file?
- $formatter->if_zero_length( $file, $out, $out_fh );
- } else {
- warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
- }
- }
-
- DEBUG and print "Finished writing to $out.\n";
- return($out, $formatter) if wantarray;
- return $out;
-}
-
-#..........................................................................
-
-sub unlink_if_temp_file {
- # Unlink the specified file IFF it's in the list of temp files.
- # Really only used in the case of -f / -q things when we can
- # throw away the dynamically generated source pod file once
- # we've formatted it.
- #
- my($self, $file) = @_;
- return unless defined $file and length $file;
-
- my $temp_file_list = $self->{'temp_file_list'} || return;
- if(grep $_ eq $file, @$temp_file_list) {
- $self->aside("Unlinking $file\n");
- unlink($file) or warn "Odd, couldn't unlink $file: $!";
- } else {
- DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
- }
- return;
-}
-
-#..........................................................................
-
-sub MSWin_temp_cleanup {
-
- # Nothing particularly MSWin-specific in here, but I don't know if any
- # other OS needs its temp dir policed like MSWin does!
-
- my $self = shift;
-
- my $tempdir = $ENV{'TEMP'};
- return unless defined $tempdir and length $tempdir
- and -e $tempdir and -d _ and -w _;
-
- $self->aside(
- "Considering whether any old files of mine in $tempdir need unlinking.\n"
- );
-
- opendir(TMPDIR, $tempdir) || return;
- my @to_unlink;
-
- my $limit = time() - $Temp_File_Lifetime;
-
- DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
- ($limit) x 2;
-
- my $filespec;
-
- while(defined($filespec = readdir(TMPDIR))) {
- if(
- $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
- ) {
- if( hex($1) < $limit ) {
- push @to_unlink, "$tempdir/$filespec";
- $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
- } else {
- DEBUG > 5 and
- printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
- }
- } else {
- DEBUG > 5 and
- print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
- }
- }
- closedir(TMPDIR);
- $self->aside(sprintf "Unlinked %s items of mine in %s\n",
- scalar(unlink(@to_unlink)),
- $tempdir
- );
- return;
-}
-
-# . . . . . . . . . . . . . . . . . . . . . . . . .
-
-sub MSWin_perldoc_tempfile {
- my($self, $suffix, $infix) = @_;
-
- my $tempdir = $ENV{'TEMP'};
- return unless defined $tempdir and length $tempdir
- and -e $tempdir and -d _ and -w _;
-
- my $spec;
-
- do {
- $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
- # Yes, we embed the create-time in the filename!
- $tempdir,
- $infix || 'x',
- time(),
- $$,
- defined( &Win32::GetTickCount )
- ? (Win32::GetTickCount() & 0xff)
- : int(rand 256)
- # Under MSWin, $$ values get reused quickly! So if we ran
- # perldoc foo and then perldoc bar before there was time for
- # time() to increment time."_$$" would likely be the same
- # for each process! So we tack on the tick count's lower
- # bits (or, in a pinch, rand)
- ,
- $suffix || 'txt';
- ;
- } while( -e $spec );
-
- my $counter = 0;
-
- while($counter < 50) {
- my $fh;
- # If we are running before perl5.6.0, we can't autovivify
- if ($] < 5.006) {
- require Symbol;
- $fh = Symbol::gensym();
- }
- DEBUG > 3 and print "About to try making temp file $spec\n";
- return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism
- $self->aside("Can't create temp file $spec: $!\n");
- }
-
- $self->aside("Giving up on making a temp file!\n");
- die "Can't make a tempfile!?";
-}
-
-#..........................................................................
-
-
-sub after_rendering {
- my $self = $_[0];
- $self->after_rendering_VMS if IS_VMS;
- $self->after_rendering_MSWin32 if IS_MSWin32;
- $self->after_rendering_Dos if IS_Dos;
- $self->after_rendering_OS2 if IS_OS2;
- return;
-}
-
-sub after_rendering_VMS { return }
-sub after_rendering_Dos { return }
-sub after_rendering_OS2 { return }
-
-sub after_rendering_MSWin32 {
- shift->MSWin_temp_cleanup() if $Temp_Files_Created;
-}
-
-#..........................................................................
-# : : : : : : : : :
-#..........................................................................
-
-
-sub minus_f_nocase { # i.e., do like -f, but without regard to case
-
- my($self, $dir, $file) = @_;
- my $path = catfile($dir,$file);
- return $path if -f $path and -r _;
-
- if(!$self->opt_i
- or IS_VMS or IS_MSWin32
- or IS_Dos or IS_OS2
- ) {
- # On a case-forgiving file system, or if case is important,
- # that is it, all we can do.
- warn "Ignored $path: unreadable\n" if -f _;
- return '';
- }
-
- local *DIR;
- my @p = ($dir);
- my($p,$cip);
- foreach $p (splitdir $file){
- my $try = catfile @p, $p;
- $self->aside("Scrutinizing $try...\n");
- stat $try;
- if (-d _) {
- push @p, $p;
- if ( $p eq $self->{'target'} ) {
- my $tmp_path = catfile @p;
- my $path_f = 0;
- for (@{ $self->{'found'} }) {
- $path_f = 1 if $_ eq $tmp_path;
- }
- push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
- $self->aside( "Found as $tmp_path but directory\n" );
- }
- }
- elsif (-f _ && -r _) {
- return $try;
- }
- elsif (-f _) {
- warn "Ignored $try: unreadable\n";
- }
- elsif (-d catdir(@p)) { # at least we see the containing directory!
- my $found = 0;
- my $lcp = lc $p;
- my $p_dirspec = catdir(@p);
- opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
- while(defined( $cip = readdir(DIR) )) {
- if (lc $cip eq $lcp){
- $found++;
- last; # XXX stop at the first? what if there's others?
- }
- }
- closedir DIR or die "closedir $p_dirspec: $!";
- return "" unless $found;
-
- push @p, $cip;
- my $p_filespec = catfile(@p);
- return $p_filespec if -f $p_filespec and -r _;
- warn "Ignored $p_filespec: unreadable\n" if -f _;
- }
- }
- return "";
-}
-
-#..........................................................................
-
-sub pagers_guessing {
- my $self = shift;
-
- my @pagers;
- push @pagers, $self->pagers;
- $self->{'pagers'} = \@pagers;
-
- if (IS_MSWin32) {
- push @pagers, qw( more< less notepad );
- unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
- }
- elsif (IS_VMS) {
- push @pagers, qw( most more less type/page );
- }
- elsif (IS_Dos) {
- push @pagers, qw( less.exe more.com< );
- unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
- }
- else {
- if (IS_OS2) {
- unshift @pagers, 'less', 'cmd /c more <';
- }
- push @pagers, qw( more less pg view cat );
- unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
- }
-
- if (IS_Cygwin) {
- if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
- unshift @pagers, '/usr/bin/less -isrR';
- }
- }
-
- unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
-
- return;
-}
-
-#..........................................................................
-
-sub page_module_file {
- my($self, @found) = @_;
-
- # Security note:
- # Don't ever just pass this off to anything like MSWin's "start.exe",
- # since we might be calling on a .pl file, and we wouldn't want that
- # to actually /execute/ the file that we just want to page thru!
- # Also a consideration if one were to use a web browser as a pager;
- # doing so could trigger the browser's MIME mapping for whatever
- # it thinks .pm/.pl/whatever is. Probably just a (useless and
- # annoying) "Save as..." dialog, but potentially executing the file
- # in question -- particularly in the case of MSIE and it's, ahem,
- # occasionally hazy distinction between OS-local extension
- # associations, and browser-specific MIME mappings.
-
- if ($self->{'output_to_stdout'}) {
- $self->aside("Sending unpaged output to STDOUT.\n");
- local $_;
- my $any_error = 0;
- foreach my $output (@found) {
- unless( open(TMP, "<", $output) ) { # XXX 5.6ism
- warn("Can't open $output: $!");
- $any_error = 1;
- next;
- }
- while (<TMP>) {
- print or die "Can't print to stdout: $!";
- }
- close TMP or die "Can't close while $output: $!";
- $self->unlink_if_temp_file($output);
- }
- return $any_error; # successful
- }
-
- foreach my $pager ( $self->pagers ) {
- $self->aside("About to try calling $pager @found\n");
- if (system($pager, @found) == 0) {
- $self->aside("Yay, it worked.\n");
- return 0;
- }
- $self->aside("That didn't work.\n");
-
- # Odd -- when it fails, under Win32, this seems to neither
- # return with a fail nor return with a success!!
- # That's discouraging!
- }
-
- $self->aside(
- sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
- join(' ', @found),
- join(' ', $self->pagers),
- );
-
- if (IS_VMS) {
- DEBUG > 1 and print "Bailing out in a VMSish way.\n";
- eval q{
- use vmsish qw(status exit);
- exit $?;
- 1;
- } or die;
- }
-
- return 1;
- # i.e., an UNSUCCESSFUL return value!
-}
-
-#..........................................................................
-
-sub check_file {
- my($self, $dir, $file) = @_;
-
- unless( ref $self ) {
- # Should never get called:
- $Carp::Verbose = 1;
- require Carp;
- Carp::croak( join '',
- "Crazy ", __PACKAGE__, " error:\n",
- "check_file must be an object_method!\n",
- "Aborting"
- );
- }
-
- if(length $dir and not -d $dir) {
- DEBUG > 3 and print " No dir $dir -- skipping.\n";
- return "";
- }
-
- if ($self->opt_m) {
- return $self->minus_f_nocase($dir,$file);
- }
-
- else {
- my $path = $self->minus_f_nocase($dir,$file);
- if( length $path and $self->containspod($path) ) {
- DEBUG > 3 and print
- " The file $path indeed looks promising!\n";
- return $path;
- }
- }
- DEBUG > 3 and print " No good: $file in $dir\n";
-
- return "";
-}
-
-#..........................................................................
-
-sub containspod {
- my($self, $file, $readit) = @_;
- return 1 if !$readit && $file =~ /\.pod\z/i;
-
-
- # Under cygwin the /usr/bin/perl is legal executable, but
- # you cannot open a file with that name. It must be spelled
- # out as "/usr/bin/perl.exe".
- #
- # The following if-case under cygwin prevents error
- #
- # $ perldoc perl
- # Cannot open /usr/bin/perl: no such file or directory
- #
- # This would work though
- #
- # $ perldoc perl.pod
-
- if ( IS_Cygwin and -x $file and -f "$file.exe" )
- {
- warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_v;
- return 0;
- }
-
- local($_);
- open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism
- while (<TEST>) {
- if (/^=head/) {
- close(TEST) or die "Can't close $file: $!";
- return 1;
- }
- }
- close(TEST) or die "Can't close $file: $!";
- return 0;
-}
-
-#..........................................................................
-
-sub maybe_diddle_INC {
- my $self = shift;
-
- # Does this look like a module or extension directory?
-
- if (-f "Makefile.PL" || -f "Build.PL") {
-
- # Add "." and "lib" to @INC (if they exist)
- eval q{ use lib qw(. lib); 1; } or die;
-
- # don't add if superuser
- if ($< && $> && -d "blib") { # don't be looking too hard now!
- eval q{ use blib; 1 };
- warn $@ if $@ && $self->opt_v;
- }
- }
-
- return;
-}
-
-#..........................................................................
-
-sub new_output_file {
- my $self = shift;
- my $outspec = $self->opt_d; # Yes, -d overrides all else!
- # So don't call this twice per format-job!
-
- return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
-
- # Otherwise open a write-handle on opt_d!f
-
- my $fh;
- # If we are running before perl5.6.0, we can't autovivify
- if ($] < 5.006) {
- require Symbol;
- $fh = Symbol::gensym();
- }
- DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
- die "Can't write-open $outspec: $!"
- unless open($fh, ">", $outspec); # XXX 5.6ism
-
- DEBUG > 3 and print "Successfully opened $outspec\n";
- binmode($fh) if $self->{'output_is_binary'};
- return($fh, $outspec);
-}
-
-#..........................................................................
-
-sub useful_filename_bit {
- # This tries to provide a meaningful bit of text to do with the query,
- # such as can be used in naming the file -- since if we're going to be
- # opening windows on temp files (as a "pager" may well do!) then it's
- # better if the temp file's name (which may well be used as the window
- # title) isn't ALL just random garbage!
- # In other words "perldoc_LWPSimple_2371981429" is a better temp file
- # name than "perldoc_2371981429". So this routine is what tries to
- # provide the "LWPSimple" bit.
- #
- my $self = shift;
- my $pages = $self->{'pages'} || return undef;
- return undef unless @$pages;
-
- my $chunk = $pages->[0];
- return undef unless defined $chunk;
- $chunk =~ s/:://g;
- $chunk =~ s/\.\w+$//g; # strip any extension
- if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file
- $chunk = $1;
- } else {
- return undef;
- }
- $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things!
- $chunk = substr($chunk, -10) if length($chunk) > 10;
- return $chunk;
-}
-
-#..........................................................................
-
-sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
- my $self = shift;
-
- ++$Temp_Files_Created;
-
- if( IS_MSWin32 ) {
- my @out = $self->MSWin_perldoc_tempfile(@_);
- return @out if @out;
- # otherwise fall thru to the normal stuff below...
- }
-
- require File::Temp;
- return File::Temp::tempfile(UNLINK => 1);
-}
-
-#..........................................................................
-
-sub page { # apply a pager to the output file
- my ($self, $output, $output_to_stdout, @pagers) = @_;
- if ($output_to_stdout) {
- $self->aside("Sending unpaged output to STDOUT.\n");
- open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism
- local $_;
- while (<TMP>) {
- print or die "Can't print to stdout: $!";
- }
- close TMP or die "Can't close while $output: $!";
- $self->unlink_if_temp_file($output);
- } else {
- # On VMS, quoting prevents logical expansion, and temp files with no
- # extension get the wrong default extension (such as .LIS for TYPE)
-
- $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
-
- $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
- # Altho "/" under MSWin is in theory good as a pathsep,
- # many many corners of the OS don't like it. So we
- # have to force it to be "\" to make everyone happy.
-
- foreach my $pager (@pagers) {
- $self->aside("About to try calling $pager $output\n");
- if (IS_VMS) {
- last if system("$pager $output") == 0;
- } else {
- last if system("$pager \"$output\"") == 0;
- }
- }
- }
- return;
-}
-
-#..........................................................................
-
-sub searchfor {
- my($self, $recurse,$s, at dirs) = @_;
- $s =~ s!::!/!g;
- $s = VMS::Filespec::unixify($s) if IS_VMS;
- return $s if -f $s && $self->containspod($s);
- $self->aside( "Looking for $s in @dirs\n" );
- my $ret;
- my $i;
- my $dir;
- $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
- for ($i=0; $i<@dirs; $i++) {
- $dir = $dirs[$i];
- next unless -d $dir;
- ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
- if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
- or ( $ret = $self->check_file($dir,"$s.pm"))
- or ( $ret = $self->check_file($dir,$s))
- or ( IS_VMS and
- $ret = $self->check_file($dir,"$s.com"))
- or ( IS_OS2 and
- $ret = $self->check_file($dir,"$s.cmd"))
- or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
- $ret = $self->check_file($dir,"$s.bat"))
- or ( $ret = $self->check_file("$dir/pod","$s.pod"))
- or ( $ret = $self->check_file("$dir/pod",$s))
- or ( $ret = $self->check_file("$dir/pods","$s.pod"))
- or ( $ret = $self->check_file("$dir/pods",$s))
- ) {
- DEBUG > 1 and print " Found $ret\n";
- return $ret;
- }
-
- if ($recurse) {
- opendir(D,$dir) or die "Can't opendir $dir: $!";
- my @newdirs = map catfile($dir, $_), grep {
- not /^\.\.?\z/s and
- not /^auto\z/s and # save time! don't search auto dirs
- -d catfile($dir, $_)
- } readdir D;
- closedir(D) or die "Can't closedir $dir: $!";
- next unless @newdirs;
- # what a wicked map!
- @newdirs = map((s/\.dir\z//,$_)[1], at newdirs) if IS_VMS;
- $self->aside( "Also looking in @newdirs\n" );
- push(@dirs, at newdirs);
- }
- }
- return ();
-}
-
-#..........................................................................
-{
- my $already_asserted;
- sub assert_closing_stdout {
- my $self = shift;
-
- return if $already_asserted;
-
- eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
- # What for? to let the pager know that nothing more will come?
-
- die $@ if $@;
- $already_asserted = 1;
- return;
- }
-}
-
-#..........................................................................
-
-sub tweak_found_pathnames {
- my($self, $found) = @_;
- if (IS_MSWin32) {
- foreach (@$found) { s,/,\\,g }
- }
- return;
-}
-
-#..........................................................................
-# : : : : : : : : :
-#..........................................................................
-
-sub am_taint_checking {
- my $self = shift;
- die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
- my($k,$v) = each %ENV;
- return is_tainted($v);
-}
-
-#..........................................................................
-
-sub is_tainted { # just a function
- my $arg = shift;
- my $nada = substr($arg, 0, 0); # zero-length!
- local $@; # preserve the caller's version of $@
- eval { eval "# $nada" };
- return length($@) != 0;
-}
-
-#..........................................................................
-
-sub drop_privs_maybe {
- my $self = shift;
-
- # Attempt to drop privs if we should be tainting and aren't
- if (!(IS_VMS || IS_MSWin32 || IS_Dos
- || IS_OS2
- )
- && ($> == 0 || $< == 0)
- && !$self->am_taint_checking()
- ) {
- my $id = eval { getpwnam("nobody") };
- $id = eval { getpwnam("nouser") } unless defined $id;
- $id = -2 unless defined $id;
- #
- # According to Stevens' APUE and various
- # (BSD, Solaris, HP-UX) man pages, setting
- # the real uid first and effective uid second
- # is the way to go if one wants to drop privileges,
- # because if one changes into an effective uid of
- # non-zero, one cannot change the real uid any more.
- #
- # Actually, it gets even messier. There is
- # a third uid, called the saved uid, and as
- # long as that is zero, one can get back to
- # uid of zero. Setting the real-effective *twice*
- # helps in *most* systems (FreeBSD and Solaris)
- # but apparently in HP-UX even this doesn't help:
- # the saved uid stays zero (apparently the only way
- # in HP-UX to change saved uid is to call setuid()
- # when the effective uid is zero).
- #
- eval {
- $< = $id; # real uid
- $> = $id; # effective uid
- $< = $id; # real uid
- $> = $id; # effective uid
- };
- if( !$@ && $< && $> ) {
- DEBUG and print "OK, I dropped privileges.\n";
- } elsif( $self->opt_U ) {
- DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
- } else {
- DEBUG and print "Hm, couldn't drop privileges. Ah well.\n";
- # We used to die here; but that seemed pointless.
- }
- }
- return;
-}
-
-#..........................................................................
-
-1;
-
-__END__
-
-# See "perldoc perldoc" for basic details.
-#
-# Perldoc -- look up a piece of documentation in .pod format that
-# is embedded in the perl installation tree.
-#
-#~~~~~~
-#
-# See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
-#
-# Version 3.01: Sun Nov 10 21:38:09 MST 2002
-# Sean M. Burke <sburke at cpan.org>
-# Massive refactoring and code-tidying.
-# Now it's a module(-family)!
-# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
-# Added -T, -d, -o, -M, -w.
-# Added some improved MSWin funk.
-#
-#~~~~~~
-#
-# Version 2.05: Sat Oct 12 16:09:00 CEST 2002
-# Hugo van der Sanden <hv at crypt.org>
-# Made -U the default, based on patch from Simon Cozens
-# Version 2.04: Sun Aug 18 13:27:12 BST 2002
-# Randy W. Sims <RandyS at ThePierianSpring.org>
-# allow -n to enable nroff under Win32
-# Version 2.03: Sun Apr 23 16:56:34 BST 2000
-# Hugo van der Sanden <hv at crypt.org>
-# don't die when 'use blib' fails
-# Version 2.02: Mon Mar 13 18:03:04 MST 2000
-# Tom Christiansen <tchrist at perl.com>
-# Added -U insecurity option
-# Version 2.01: Sat Mar 11 15:22:33 MST 2000
-# Tom Christiansen <tchrist at perl.com>, querulously.
-# Security and correctness patches.
-# What a twisted bit of distasteful spaghetti code.
-# Version 2.0: ????
-#
-#~~~~~~
-#
-# Version 1.15: Tue Aug 24 01:50:20 EST 1999
-# Charles Wilson <cwilson at ece.gatech.edu>
-# changed /pod/ directory to /pods/ for cygwin
-# to support cygwin/win32
-# Version 1.14: Wed Jul 15 01:50:20 EST 1998
-# Robin Barker <rmb1 at cise.npl.co.uk>
-# -strict, -w cleanups
-# Version 1.13: Fri Feb 27 16:20:50 EST 1997
-# Gurusamy Sarathy <gsar at activestate.com>
-# -doc tweaks for -F and -X options
-# Version 1.12: Sat Apr 12 22:41:09 EST 1997
-# Gurusamy Sarathy <gsar at activestate.com>
-# -various fixes for win32
-# Version 1.11: Tue Dec 26 09:54:33 EST 1995
-# Kenneth Albanowski <kjahds at kjahds.com>
-# -added Charles Bailey's further VMS patches, and -u switch
-# -added -t switch, with pod2text support
-#
-# Version 1.10: Thu Nov 9 07:23:47 EST 1995
-# Kenneth Albanowski <kjahds at kjahds.com>
-# -added VMS support
-# -added better error recognition (on no found pages, just exit. On
-# missing nroff/pod2man, just display raw pod.)
-# -added recursive/case-insensitive matching (thanks, Andreas). This
-# slows things down a bit, unfortunately. Give a precise name, and
-# it'll run faster.
-#
-# Version 1.01: Tue May 30 14:47:34 EDT 1995
-# Andy Dougherty <doughera at lafcol.lafayette.edu>
-# -added pod documentation.
-# -added PATH searching.
-# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
-# and friends.
-#
-#~~~~~~~
-#
-# TODO:
-#
-# Cache the directories read during sloppy match
-# (To disk, or just in-memory?)
-#
-# Backport this to perl 5.005?
-#
-# Implement at least part of the "perlman" interface described
-# in Programming Perl 3e?
Deleted: trunk/contrib/perl/lib/Pod/PlainText.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/PlainText.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/PlainText.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,738 +0,0 @@
-# Pod::PlainText -- Convert POD data to formatted ASCII text.
-# $Id: PlainText.pm,v 1.1.1.2 2011-02-17 12:49:41 laffer1 Exp $
-#
-# Copyright 1999-2000 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you can redistribute it and/or modify it
-# under the same terms as Perl itself.
-#
-# This module is intended to be a replacement for Pod::Text, and attempts to
-# match its output except for some specific circumstances where other
-# decisions seemed to produce better output. It uses Pod::Parser and is
-# designed to be very easy to subclass.
-
-############################################################################
-# Modules and declarations
-############################################################################
-
-package Pod::PlainText;
-use strict;
-
-require 5.005;
-
-use Carp qw(carp croak);
-use Pod::Select ();
-
-use vars qw(@ISA %ESCAPES $VERSION);
-
-# We inherit from Pod::Select instead of Pod::Parser so that we can be used
-# by Pod::Usage.
- at ISA = qw(Pod::Select);
-
-$VERSION = '2.04';
-
-BEGIN {
- if ($] < 5.006) {
- require Symbol;
- import Symbol;
- }
-}
-
-############################################################################
-# Table of supported E<> escapes
-############################################################################
-
-# This table is taken near verbatim from Pod::PlainText in Pod::Parser,
-# which got it near verbatim from the original Pod::Text. It is therefore
-# credited to Tom Christiansen, and I'm glad I didn't have to write it. :)
-%ESCAPES = (
- 'amp' => '&', # ampersand
- 'lt' => '<', # left chevron, less-than
- 'gt' => '>', # right chevron, greater-than
- 'quot' => '"', # double quote
-
- "Aacute" => "\xC1", # capital A, acute accent
- "aacute" => "\xE1", # small a, acute accent
- "Acirc" => "\xC2", # capital A, circumflex accent
- "acirc" => "\xE2", # small a, circumflex accent
- "AElig" => "\xC6", # capital AE diphthong (ligature)
- "aelig" => "\xE6", # small ae diphthong (ligature)
- "Agrave" => "\xC0", # capital A, grave accent
- "agrave" => "\xE0", # small a, grave accent
- "Aring" => "\xC5", # capital A, ring
- "aring" => "\xE5", # small a, ring
- "Atilde" => "\xC3", # capital A, tilde
- "atilde" => "\xE3", # small a, tilde
- "Auml" => "\xC4", # capital A, dieresis or umlaut mark
- "auml" => "\xE4", # small a, dieresis or umlaut mark
- "Ccedil" => "\xC7", # capital C, cedilla
- "ccedil" => "\xE7", # small c, cedilla
- "Eacute" => "\xC9", # capital E, acute accent
- "eacute" => "\xE9", # small e, acute accent
- "Ecirc" => "\xCA", # capital E, circumflex accent
- "ecirc" => "\xEA", # small e, circumflex accent
- "Egrave" => "\xC8", # capital E, grave accent
- "egrave" => "\xE8", # small e, grave accent
- "ETH" => "\xD0", # capital Eth, Icelandic
- "eth" => "\xF0", # small eth, Icelandic
- "Euml" => "\xCB", # capital E, dieresis or umlaut mark
- "euml" => "\xEB", # small e, dieresis or umlaut mark
- "Iacute" => "\xCD", # capital I, acute accent
- "iacute" => "\xED", # small i, acute accent
- "Icirc" => "\xCE", # capital I, circumflex accent
- "icirc" => "\xEE", # small i, circumflex accent
- "Igrave" => "\xCD", # capital I, grave accent
- "igrave" => "\xED", # small i, grave accent
- "Iuml" => "\xCF", # capital I, dieresis or umlaut mark
- "iuml" => "\xEF", # small i, dieresis or umlaut mark
- "Ntilde" => "\xD1", # capital N, tilde
- "ntilde" => "\xF1", # small n, tilde
- "Oacute" => "\xD3", # capital O, acute accent
- "oacute" => "\xF3", # small o, acute accent
- "Ocirc" => "\xD4", # capital O, circumflex accent
- "ocirc" => "\xF4", # small o, circumflex accent
- "Ograve" => "\xD2", # capital O, grave accent
- "ograve" => "\xF2", # small o, grave accent
- "Oslash" => "\xD8", # capital O, slash
- "oslash" => "\xF8", # small o, slash
- "Otilde" => "\xD5", # capital O, tilde
- "otilde" => "\xF5", # small o, tilde
- "Ouml" => "\xD6", # capital O, dieresis or umlaut mark
- "ouml" => "\xF6", # small o, dieresis or umlaut mark
- "szlig" => "\xDF", # small sharp s, German (sz ligature)
- "THORN" => "\xDE", # capital THORN, Icelandic
- "thorn" => "\xFE", # small thorn, Icelandic
- "Uacute" => "\xDA", # capital U, acute accent
- "uacute" => "\xFA", # small u, acute accent
- "Ucirc" => "\xDB", # capital U, circumflex accent
- "ucirc" => "\xFB", # small u, circumflex accent
- "Ugrave" => "\xD9", # capital U, grave accent
- "ugrave" => "\xF9", # small u, grave accent
- "Uuml" => "\xDC", # capital U, dieresis or umlaut mark
- "uuml" => "\xFC", # small u, dieresis or umlaut mark
- "Yacute" => "\xDD", # capital Y, acute accent
- "yacute" => "\xFD", # small y, acute accent
- "yuml" => "\xFF", # small y, dieresis or umlaut mark
-
- "lchevron" => "\xAB", # left chevron (double less than)
- "rchevron" => "\xBB", # right chevron (double greater than)
-);
-
-
-############################################################################
-# Initialization
-############################################################################
-
-# Initialize the object. Must be sure to call our parent initializer.
-sub initialize {
- my $self = shift;
-
- $$self{alt} = 0 unless defined $$self{alt};
- $$self{indent} = 4 unless defined $$self{indent};
- $$self{loose} = 0 unless defined $$self{loose};
- $$self{sentence} = 0 unless defined $$self{sentence};
- $$self{width} = 76 unless defined $$self{width};
-
- $$self{INDENTS} = []; # Stack of indentations.
- $$self{MARGIN} = $$self{indent}; # Current left margin in spaces.
-
- return $self->SUPER::initialize;
-}
-
-
-############################################################################
-# Core overrides
-############################################################################
-
-# Called for each command paragraph. Gets the command, the associated
-# paragraph, the line number, and a Pod::Paragraph object. Just dispatches
-# the command to a method named the same as the command. =cut is handled
-# internally by Pod::Parser.
-sub command {
- my $self = shift;
- my $command = shift;
- return if $command eq 'pod';
- return if ($$self{EXCLUDE} && $command ne 'end');
- if (defined $$self{ITEM}) {
- $self->item ("\n");
- local $_ = "\n";
- $self->output($_) if($command eq 'back');
- }
- $command = 'cmd_' . $command;
- return $self->$command (@_);
-}
-
-# Called for a verbatim paragraph. Gets the paragraph, the line number, and
-# a Pod::Paragraph object. Just output it verbatim, but with tabs converted
-# to spaces.
-sub verbatim {
- my $self = shift;
- return if $$self{EXCLUDE};
- $self->item if defined $$self{ITEM};
- local $_ = shift;
- return if /^\s*$/;
- s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme;
- return $self->output($_);
-}
-
-# Called for a regular text block. Gets the paragraph, the line number, and
-# a Pod::Paragraph object. Perform interpolation and output the results.
-sub textblock {
- my $self = shift;
- return if $$self{EXCLUDE};
- if($$self{VERBATIM}) {
- $self->output($_[0]);
- return;
- }
- local $_ = shift;
- my $line = shift;
-
- # Perform a little magic to collapse multiple L<> references. This is
- # here mostly for backwards-compatibility. We'll just rewrite the whole
- # thing into actual text at this part, bypassing the whole internal
- # sequence parsing thing.
- s{
- (
- L< # A link of the form L</something>.
- /
- (
- [:\w]+ # The item has to be a simple word...
- (\(\))? # ...or simple function.
- )
- >
- (
- ,?\s+(and\s+)? # Allow lots of them, conjuncted.
- L<
- /
- (
- [:\w]+
- (\(\))?
- )
- >
- )+
- )
- } {
- local $_ = $1;
- s%L</([^>]+)>%$1%g;
- my @items = split /(?:,?\s+(?:and\s+)?)/;
- my $string = "the ";
- my $i;
- for ($i = 0; $i < @items; $i++) {
- $string .= $items[$i];
- $string .= ", " if @items > 2 && $i != $#items;
- $string .= " and " if ($i == $#items - 1);
- }
- $string .= " entries elsewhere in this document";
- $string;
- }gex;
-
- # Now actually interpolate and output the paragraph.
- $_ = $self->interpolate ($_, $line);
- s/\s*$/\n/s;
- if (defined $$self{ITEM}) {
- $self->item ($_ . "\n");
- } else {
- $self->output ($self->reformat ($_ . "\n"));
- }
-}
-
-# Called for an interior sequence. Gets the command, argument, and a
-# Pod::InteriorSequence object and is expected to return the resulting text.
-# Calls code, bold, italic, file, and link to handle those types of
-# sequences, and handles S<>, E<>, X<>, and Z<> directly.
-sub interior_sequence {
- my $self = shift;
- my $command = shift;
- local $_ = shift;
- return '' if ($command eq 'X' || $command eq 'Z');
-
- # Expand escapes into the actual character now, carping if invalid.
- if ($command eq 'E') {
- return $ESCAPES{$_} if defined $ESCAPES{$_};
- carp "Unknown escape: E<$_>";
- return "E<$_>";
- }
-
- # For all the other sequences, empty content produces no output.
- return if $_ eq '';
-
- # For S<>, compress all internal whitespace and then map spaces to \01.
- # When we output the text, we'll map this back.
- if ($command eq 'S') {
- s/\s{2,}/ /g;
- tr/ /\01/;
- return $_;
- }
-
- # Anything else needs to get dispatched to another method.
- if ($command eq 'B') { return $self->seq_b ($_) }
- elsif ($command eq 'C') { return $self->seq_c ($_) }
- elsif ($command eq 'F') { return $self->seq_f ($_) }
- elsif ($command eq 'I') { return $self->seq_i ($_) }
- elsif ($command eq 'L') { return $self->seq_l ($_) }
- else { carp "Unknown sequence $command<$_>" }
-}
-
-# Called for each paragraph that's actually part of the POD. We take
-# advantage of this opportunity to untabify the input.
-sub preprocess_paragraph {
- my $self = shift;
- local $_ = shift;
- 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me;
- return $_;
-}
-
-
-############################################################################
-# Command paragraphs
-############################################################################
-
-# All command paragraphs take the paragraph and the line number.
-
-# First level heading.
-sub cmd_head1 {
- my $self = shift;
- local $_ = shift;
- s/\s+$//s;
- $_ = $self->interpolate ($_, shift);
- if ($$self{alt}) {
- $self->output ("\n==== $_ ====\n\n");
- } else {
- $_ .= "\n" if $$self{loose};
- $self->output ($_ . "\n");
- }
-}
-
-# Second level heading.
-sub cmd_head2 {
- my $self = shift;
- local $_ = shift;
- s/\s+$//s;
- $_ = $self->interpolate ($_, shift);
- if ($$self{alt}) {
- $self->output ("\n== $_ ==\n\n");
- } else {
- $_ .= "\n" if $$self{loose};
- $self->output (' ' x ($$self{indent} / 2) . $_ . "\n");
- }
-}
-
-# third level heading - not strictly perlpodspec compliant
-sub cmd_head3 {
- my $self = shift;
- local $_ = shift;
- s/\s+$//s;
- $_ = $self->interpolate ($_, shift);
- if ($$self{alt}) {
- $self->output ("\n= $_ =\n");
- } else {
- $_ .= "\n" if $$self{loose};
- $self->output (' ' x ($$self{indent}) . $_ . "\n");
- }
-}
-
-# fourth level heading - not strictly perlpodspec compliant
-# just like head3
-*cmd_head4 = \&cmd_head3;
-
-# Start a list.
-sub cmd_over {
- my $self = shift;
- local $_ = shift;
- unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} }
- push (@{ $$self{INDENTS} }, $$self{MARGIN});
- $$self{MARGIN} += ($_ + 0);
-}
-
-# End a list.
-sub cmd_back {
- my $self = shift;
- $$self{MARGIN} = pop @{ $$self{INDENTS} };
- unless (defined $$self{MARGIN}) {
- carp 'Unmatched =back';
- $$self{MARGIN} = $$self{indent};
- }
-}
-
-# An individual list item.
-sub cmd_item {
- my $self = shift;
- if (defined $$self{ITEM}) { $self->item }
- local $_ = shift;
- s/\s+$//s;
- $$self{ITEM} = $self->interpolate ($_);
-}
-
-# Begin a block for a particular translator. Setting VERBATIM triggers
-# special handling in textblock().
-sub cmd_begin {
- my $self = shift;
- local $_ = shift;
- my ($kind) = /^(\S+)/ or return;
- if ($kind eq 'text') {
- $$self{VERBATIM} = 1;
- } else {
- $$self{EXCLUDE} = 1;
- }
-}
-
-# End a block for a particular translator. We assume that all =begin/=end
-# pairs are properly closed.
-sub cmd_end {
- my $self = shift;
- $$self{EXCLUDE} = 0;
- $$self{VERBATIM} = 0;
-}
-
-# One paragraph for a particular translator. Ignore it unless it's intended
-# for text, in which case we treat it as a verbatim text block.
-sub cmd_for {
- my $self = shift;
- local $_ = shift;
- my $line = shift;
- return unless s/^text\b[ \t]*\n?//;
- $self->verbatim ($_, $line);
-}
-
-
-############################################################################
-# Interior sequences
-############################################################################
-
-# The simple formatting ones. These are here mostly so that subclasses can
-# override them and do more complicated things.
-sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] }
-sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" }
-sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] }
-sub seq_i { return '*' . $_[1] . '*' }
-
-# The complicated one. Handle links. Since this is plain text, we can't
-# actually make any real links, so this is all to figure out what text we
-# print out.
-sub seq_l {
- my $self = shift;
- local $_ = shift;
-
- # Smash whitespace in case we were split across multiple lines.
- s/\s+/ /g;
-
- # If we were given any explicit text, just output it.
- if (/^([^|]+)\|/) { return $1 }
-
- # Okay, leading and trailing whitespace isn't important; get rid of it.
- s/^\s+//;
- s/\s+$//;
-
- # Default to using the whole content of the link entry as a section
- # name. Note that L<manpage/> forces a manpage interpretation, as does
- # something looking like L<manpage(section)>. The latter is an
- # enhancement over the original Pod::Text.
- my ($manpage, $section) = ('', $_);
- if (/^(?:https?|ftp|news):/) {
- # a URL
- return $_;
- } elsif (/^"\s*(.*?)\s*"$/) {
- $section = '"' . $1 . '"';
- } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) {
- ($manpage, $section) = ($_, '');
- } elsif (m{/}) {
- ($manpage, $section) = split (/\s*\/\s*/, $_, 2);
- }
-
- my $text = '';
- # Now build the actual output text.
- if (!length $section) {
- $text = "the $manpage manpage" if length $manpage;
- } elsif ($section =~ /^[:\w]+(?:\(\))?/) {
- $text .= 'the ' . $section . ' entry';
- $text .= (length $manpage) ? " in the $manpage manpage"
- : ' elsewhere in this document';
- } else {
- $section =~ s/^\"\s*//;
- $section =~ s/\s*\"$//;
- $text .= 'the section on "' . $section . '"';
- $text .= " in the $manpage manpage" if length $manpage;
- }
- return $text;
-}
-
-
-############################################################################
-# List handling
-############################################################################
-
-# This method is called whenever an =item command is complete (in other
-# words, we've seen its associated paragraph or know for certain that it
-# doesn't have one). It gets the paragraph associated with the item as an
-# argument. If that argument is empty, just output the item tag; if it
-# contains a newline, output the item tag followed by the newline.
-# Otherwise, see if there's enough room for us to output the item tag in the
-# margin of the text or if we have to put it on a separate line.
-sub item {
- my $self = shift;
- local $_ = shift;
- my $tag = $$self{ITEM};
- unless (defined $tag) {
- carp 'item called without tag';
- return;
- }
- undef $$self{ITEM};
- my $indent = $$self{INDENTS}[-1];
- unless (defined $indent) { $indent = $$self{indent} }
- my $space = ' ' x $indent;
- $space =~ s/^ /:/ if $$self{alt};
- if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) {
- my $margin = $$self{MARGIN};
- $$self{MARGIN} = $indent;
- my $output = $self->reformat ($tag);
- $output =~ s/\n*$/\n/;
- $self->output ($output);
- $$self{MARGIN} = $margin;
- $self->output ($self->reformat ($_)) if /\S/;
- } else {
- $_ = $self->reformat ($_);
- s/^ /:/ if ($$self{alt} && $indent > 0);
- my $tagspace = ' ' x length $tag;
- s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item';
- $self->output ($_);
- }
-}
-
-
-############################################################################
-# Output formatting
-############################################################################
-
-# Wrap a line, indenting by the current left margin. We can't use
-# Text::Wrap because it plays games with tabs. We can't use formline, even
-# though we'd really like to, because it screws up non-printing characters.
-# So we have to do the wrapping ourselves.
-sub wrap {
- my $self = shift;
- local $_ = shift;
- my $output = '';
- my $spaces = ' ' x $$self{MARGIN};
- my $width = $$self{width} - $$self{MARGIN};
- while (length > $width) {
- if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
- $output .= $spaces . $1 . "\n";
- } else {
- last;
- }
- }
- $output .= $spaces . $_;
- $output =~ s/\s+$/\n\n/;
- return $output;
-}
-
-# Reformat a paragraph of text for the current margin. Takes the text to
-# reformat and returns the formatted text.
-sub reformat {
- my $self = shift;
- local $_ = shift;
-
- # If we're trying to preserve two spaces after sentences, do some
- # munging to support that. Otherwise, smash all repeated whitespace.
- if ($$self{sentence}) {
- s/ +$//mg;
- s/\.\n/. \n/g;
- s/\n/ /g;
- s/ +/ /g;
- } else {
- s/\s+/ /g;
- }
- return $self->wrap($_);
-}
-
-# Output text to the output device.
-sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] }
-
-
-############################################################################
-# Backwards compatibility
-############################################################################
-
-# The old Pod::Text module did everything in a pod2text() function. This
-# tries to provide the same interface for legacy applications.
-sub pod2text {
- my @args;
-
- # This is really ugly; I hate doing option parsing in the middle of a
- # module. But the old Pod::Text module supported passing flags to its
- # entry function, so handle -a and -<number>.
- while ($_[0] =~ /^-/) {
- my $flag = shift;
- if ($flag eq '-a') { push (@args, alt => 1) }
- elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
- else {
- unshift (@_, $flag);
- last;
- }
- }
-
- # Now that we know what arguments we're using, create the parser.
- my $parser = Pod::PlainText->new (@args);
-
- # If two arguments were given, the second argument is going to be a file
- # handle. That means we want to call parse_from_filehandle(), which
- # means we need to turn the first argument into a file handle. Magic
- # open will handle the <&STDIN case automagically.
- if (defined $_[1]) {
- my $infh;
- if ($] < 5.006) {
- $infh = gensym();
- }
- unless (open ($infh, $_[0])) {
- croak ("Can't open $_[0] for reading: $!\n");
- }
- $_[0] = $infh;
- return $parser->parse_from_filehandle (@_);
- } else {
- return $parser->parse_from_file (@_);
- }
-}
-
-
-############################################################################
-# Module return value and documentation
-############################################################################
-
-1;
-__END__
-
-=head1 NAME
-
-Pod::PlainText - Convert POD data to formatted ASCII text
-
-=head1 SYNOPSIS
-
- use Pod::PlainText;
- my $parser = Pod::PlainText->new (sentence => 0, width => 78);
-
- # Read POD from STDIN and write to STDOUT.
- $parser->parse_from_filehandle;
-
- # Read POD from file.pod and write to file.txt.
- $parser->parse_from_file ('file.pod', 'file.txt');
-
-=head1 DESCRIPTION
-
-Pod::PlainText is a module that can convert documentation in the POD format (the
-preferred language for documenting Perl) into formatted ASCII. It uses no
-special formatting controls or codes whatsoever, and its output is therefore
-suitable for nearly any device.
-
-As a derived class from Pod::Parser, Pod::PlainText supports the same methods and
-interfaces. See L<Pod::Parser> for all the details; briefly, one creates a
-new parser with C<Pod::PlainText-E<gt>new()> and then calls either
-parse_from_filehandle() or parse_from_file().
-
-new() can take options, in the form of key/value pairs, that control the
-behavior of the parser. The currently recognized options are:
-
-=over 4
-
-=item alt
-
-If set to a true value, selects an alternate output format that, among other
-things, uses a different heading style and marks C<=item> entries with a
-colon in the left margin. Defaults to false.
-
-=item indent
-
-The number of spaces to indent regular text, and the default indentation for
-C<=over> blocks. Defaults to 4.
-
-=item loose
-
-If set to a true value, a blank line is printed after a C<=headN> headings.
-If set to false (the default), no blank line is printed after C<=headN>.
-This is the default because it's the expected formatting for manual pages;
-if you're formatting arbitrary text documents, setting this to true may
-result in more pleasing output.
-
-=item sentence
-
-If set to a true value, Pod::PlainText will assume that each sentence ends in two
-spaces, and will try to preserve that spacing. If set to false, all
-consecutive whitespace in non-verbatim paragraphs is compressed into a
-single space. Defaults to true.
-
-=item width
-
-The column at which to wrap text on the right-hand side. Defaults to 76.
-
-=back
-
-The standard Pod::Parser method parse_from_filehandle() takes up to two
-arguments, the first being the file handle to read POD from and the second
-being the file handle to write the formatted output to. The first defaults
-to STDIN if not given, and the second defaults to STDOUT. The method
-parse_from_file() is almost identical, except that its two arguments are the
-input and output disk files instead. See L<Pod::Parser> for the specific
-details.
-
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item Bizarre space in item
-
-(W) Something has gone wrong in internal C<=item> processing. This message
-indicates a bug in Pod::PlainText; you should never see it.
-
-=item Can't open %s for reading: %s
-
-(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface
-and the input file it was given could not be opened.
-
-=item Unknown escape: %s
-
-(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::PlainText didn't
-know about.
-
-=item Unknown sequence: %s
-
-(W) The POD source contained a non-standard internal sequence (something of
-the form C<XE<lt>E<gt>>) that Pod::PlainText didn't know about.
-
-=item Unmatched =back
-
-(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an
-C<=over> command.
-
-=back
-
-=head1 RESTRICTIONS
-
-Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on
-output, due to an internal implementation detail.
-
-=head1 NOTES
-
-This is a replacement for an earlier Pod::Text module written by Tom
-Christiansen. It has a revamped interface, since it now uses Pod::Parser,
-but an interface roughly compatible with the old Pod::Text::pod2text()
-function is still available. Please change to the new calling convention,
-though.
-
-The original Pod::Text contained code to do formatting via termcap
-sequences, although it wasn't turned on by default and it was problematic to
-get it to work at all. This rewrite doesn't even try to do that, but a
-subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>.
-
-=head1 SEE ALSO
-
-L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>,
-pod2text(1)
-
-=head1 AUTHOR
-
-Please report bugs using L<http://rt.cpan.org>.
-
-Russ Allbery E<lt>rra at stanford.eduE<gt>, based I<very> heavily on the
-original Pod::Text by Tom Christiansen E<lt>tchrist at mox.perl.comE<gt> and
-its conversion to Pod::Parser by Brad Appleton
-E<lt>bradapp at enteract.comE<gt>.
-
-=cut
Deleted: trunk/contrib/perl/lib/Pod/Plainer.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Plainer.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Plainer.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,69 +0,0 @@
-package Pod::Plainer;
-use strict;
-use Pod::Parser;
-our @ISA = qw(Pod::Parser);
-our $VERSION = '0.01';
-
-our %E = qw( < lt > gt );
-
-sub escape_ltgt {
- (undef, my $text) = @_;
- $text =~ s/([<>])/E<$E{$1}>/g;
- $text
-}
-
-sub simple_delimiters {
- (undef, my $seq) = @_;
- $seq -> left_delimiter( '<' );
- $seq -> right_delimiter( '>' );
- $seq;
-}
-
-sub textblock {
- my($parser,$text,$line) = @_;
- print {$parser->output_handle()}
- $parser->parse_text(
- { -expand_text => q(escape_ltgt),
- -expand_seq => q(simple_delimiters) },
- $text, $line ) -> raw_text();
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Pod::Plainer - Perl extension for converting Pod to old style Pod.
-
-=head1 SYNOPSIS
-
- use Pod::Plainer;
-
- my $parser = Pod::Plainer -> new ();
- $parser -> parse_from_filehandle(\*STDIN);
-
-=head1 DESCRIPTION
-
-Pod::Plainer uses Pod::Parser which takes Pod with the (new)
-'CE<lt>E<lt> .. E<gt>E<gt>' constructs
-and returns the old(er) style with just 'CE<lt>E<gt>';
-'<' and '>' are replaced by 'EE<lt>ltE<gt>' and 'EE<lt>gtE<gt>'.
-
-This can be used to pre-process Pod before using tools which do not
-recognise the new style Pods.
-
-=head2 EXPORT
-
-None by default.
-
-=head1 AUTHOR
-
-Robin Barker, rmb1 at cise.npl.co.uk
-
-=head1 SEE ALSO
-
-See L<Pod::Parser>.
-
-=cut
-
Deleted: trunk/contrib/perl/lib/Pod/Select.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Select.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Select.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,746 +0,0 @@
-#############################################################################
-# Pod/Select.pm -- function to select portions of 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.
-#############################################################################
-
-package Pod::Select;
-use strict;
-
-use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections);
-$VERSION = '1.36'; ## Current version of this package
-require 5.005; ## requires this Perl version or later
-
-#############################################################################
-
-=head1 NAME
-
-Pod::Select, podselect() - extract selected sections of POD from input
-
-=head1 SYNOPSIS
-
- use Pod::Select;
-
- ## Select all the POD sections for each file in @filelist
- ## and print the result on standard output.
- podselect(@filelist);
-
- ## Same as above, but write to tmp.out
- podselect({-output => "tmp.out"}, @filelist):
-
- ## Select from the given filelist, only those POD sections that are
- ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
- podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist):
-
- ## Select the "DESCRIPTION" section of the PODs from STDIN and write
- ## the result to STDERR.
- podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN);
-
-or
-
- use Pod::Select;
-
- ## Create a parser object for selecting POD sections from the input
- $parser = new Pod::Select();
-
- ## Select all the POD sections for each file in @filelist
- ## and print the result to tmp.out.
- $parser->parse_from_file("<&STDIN", "tmp.out");
-
- ## Select from the given filelist, only those POD sections that are
- ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS.
- $parser->select("NAME|SYNOPSIS", "OPTIONS");
- for (@filelist) { $parser->parse_from_file($_); }
-
- ## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from
- ## STDIN and write the result to STDERR.
- $parser->select("DESCRIPTION");
- $parser->add_selection("SEE ALSO");
- $parser->parse_from_filehandle(\*STDIN, \*STDERR);
-
-=head1 REQUIRES
-
-perl5.005, Pod::Parser, Exporter, Carp
-
-=head1 EXPORTS
-
-podselect()
-
-=head1 DESCRIPTION
-
-B<podselect()> is a function which will extract specified sections of
-pod documentation from an input stream. This ability is provided by the
-B<Pod::Select> module which is a subclass of B<Pod::Parser>.
-B<Pod::Select> provides a method named B<select()> to specify the set of
-POD sections to select for processing/printing. B<podselect()> merely
-creates a B<Pod::Select> object and then invokes the B<podselect()>
-followed by B<parse_from_file()>.
-
-=head1 SECTION SPECIFICATIONS
-
-B<podselect()> and B<Pod::Select::select()> may be given one or more
-"section specifications" to restrict the text processed to only the
-desired set of sections and their corresponding subsections. A section
-specification is a string containing one or more Perl-style regular
-expressions separated by forward slashes ("/"). If you need to use a
-forward slash literally within a section title you can escape it with a
-backslash ("\/").
-
-The formal syntax of a section specification is:
-
-=over 4
-
-=item *
-
-I<head1-title-regex>/I<head2-title-regex>/...
-
-=back
-
-Any omitted or empty regular expressions will default to ".*".
-Please note that each regular expression given is implicitly
-anchored by adding "^" and "$" to the beginning and end. Also, if a
-given regular expression starts with a "!" character, then the
-expression is I<negated> (so C<!foo> would match anything I<except>
-C<foo>).
-
-Some example section specifications follow.
-
-=over 4
-
-=item *
-
-Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections:
-
-C<NAME|SYNOPSIS>
-
-=item *
-
-Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION>
-section:
-
-C<DESCRIPTION/Question|Answer>
-
-=item *
-
-Match the C<Comments> subsection of I<all> sections:
-
-C</Comments>
-
-=item *
-
-Match all subsections of C<DESCRIPTION> I<except> for C<Comments>:
-
-C<DESCRIPTION/!Comments>
-
-=item *
-
-Match the C<DESCRIPTION> section but do I<not> match any of its subsections:
-
-C<DESCRIPTION/!.+>
-
-=item *
-
-Match all top level sections but none of their subsections:
-
-C</!.+>
-
-=back
-
-=begin _NOT_IMPLEMENTED_
-
-=head1 RANGE SPECIFICATIONS
-
-B<podselect()> and B<Pod::Select::select()> may be given one or more
-"range specifications" to restrict the text processed to only the
-desired ranges of paragraphs in the desired set of sections. A range
-specification is a string containing a single Perl-style regular
-expression (a regex), or else two Perl-style regular expressions
-(regexs) separated by a ".." (Perl's "range" operator is "..").
-The regexs in a range specification are delimited by forward slashes
-("/"). If you need to use a forward slash literally within a regex you
-can escape it with a backslash ("\/").
-
-The formal syntax of a range specification is:
-
-=over 4
-
-=item *
-
-/I<start-range-regex>/[../I<end-range-regex>/]
-
-=back
-
-Where each the item inside square brackets (the ".." followed by the
-end-range-regex) is optional. Each "range-regex" is of the form:
-
- =cmd-expr text-expr
-
-Where I<cmd-expr> is intended to match the name of one or more POD
-commands, and I<text-expr> is intended to match the paragraph text for
-the command. If a range-regex is supposed to match a POD command, then
-the first character of the regex (the one after the initial '/')
-absolutely I<must> be a single '=' character; it may not be anything
-else (not even a regex meta-character) if it is supposed to match
-against the name of a POD command.
-
-If no I<=cmd-expr> is given then the text-expr will be matched against
-plain textblocks unless it is preceded by a space, in which case it is
-matched against verbatim text-blocks. If no I<text-expr> is given then
-only the command-portion of the paragraph is matched against.
-
-Note that these two expressions are each implicitly anchored. This
-means that when matching against the command-name, there will be an
-implicit '^' and '$' around the given I<=cmd-expr>; and when matching
-against the paragraph text there will be an implicit '\A' and '\Z'
-around the given I<text-expr>.
-
-Unlike with section-specs, the '!' character does I<not> have any special
-meaning (negation or otherwise) at the beginning of a range-spec!
-
-Some example range specifications follow.
-
-=over 4
-
-=item
-Match all C<=for html> paragraphs:
-
-C</=for html/>
-
-=item
-Match all paragraphs between C<=begin html> and C<=end html>
-(note that this will I<not> work correctly if such sections
-are nested):
-
-C</=begin html/../=end html/>
-
-=item
-Match all paragraphs between the given C<=item> name until the end of the
-current section:
-
-C</=item mine/../=head\d/>
-
-=item
-Match all paragraphs between the given C<=item> until the next item, or
-until the end of the itemized list (note that this will I<not> work as
-desired if the item contains an itemized list nested within it):
-
-C</=item mine/../=(item|back)/>
-
-=back
-
-=end _NOT_IMPLEMENTED_
-
-=cut
-
-#############################################################################
-
-#use diagnostics;
-use Carp;
-use Pod::Parser 1.04;
-
- at ISA = qw(Pod::Parser);
- at EXPORT = qw(&podselect);
-
-## Maximum number of heading levels supported for '=headN' directives
-*MAX_HEADING_LEVEL = \3;
-
-#############################################################################
-
-=head1 OBJECT METHODS
-
-The following methods are provided in this module. Each one takes a
-reference to the object itself as an implicit first parameter.
-
-=cut
-
-##---------------------------------------------------------------------------
-
-## =begin _PRIVATE_
-##
-## =head1 B<_init_headings()>
-##
-## Initialize the current set of active section headings.
-##
-## =cut
-##
-## =end _PRIVATE_
-
-sub _init_headings {
- my $self = shift;
- local *myData = $self;
-
- ## Initialize current section heading titles if necessary
- unless (defined $myData{_SECTION_HEADINGS}) {
- local *section_headings = $myData{_SECTION_HEADINGS} = [];
- for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
- $section_headings[$i] = '';
- }
- }
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<curr_headings()>
-
- ($head1, $head2, $head3, ...) = $parser->curr_headings();
- $head1 = $parser->curr_headings(1);
-
-This method returns a list of the currently active section headings and
-subheadings in the document being parsed. The list of headings returned
-corresponds to the most recently parsed paragraph of the input.
-
-If an argument is given, it must correspond to the desired section
-heading number, in which case only the specified section heading is
-returned. If there is no current section heading at the specified
-level, then C<undef> is returned.
-
-=cut
-
-sub curr_headings {
- my $self = shift;
- $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS});
- my @headings = @{ $self->{_SECTION_HEADINGS} };
- return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings;
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<select()>
-
- $parser->select($section_spec1,$section_spec2,...);
-
-This method is used to select the particular sections and subsections of
-POD documentation that are to be printed and/or processed. The existing
-set of selected sections is I<replaced> with the given set of sections.
-See B<add_selection()> for adding to the current set of selected
-sections.
-
-Each of the C<$section_spec> arguments should be a section specification
-as described in L<"SECTION SPECIFICATIONS">. The section specifications
-are parsed by this method and the resulting regular expressions are
-stored in the invoking object.
-
-If no C<$section_spec> arguments are given, then the existing set of
-selected sections is cleared out (which means C<all> sections will be
-processed).
-
-This method should I<not> normally be overridden by subclasses.
-
-=cut
-
-sub select {
- my ($self, @sections) = @_;
- local *myData = $self;
- local $_;
-
-### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?)
-
- ##---------------------------------------------------------------------
- ## The following is a blatant hack for backward compatibility, and for
- ## implementing add_selection(). If the *first* *argument* is the
- ## string "+", then the remaining section specifications are *added*
- ## to the current set of selections; otherwise the given section
- ## specifications will *replace* the current set of selections.
- ##
- ## This should probably be fixed someday, but for the present time,
- ## it seems incredibly unlikely that "+" would ever correspond to
- ## a legitimate section heading
- ##---------------------------------------------------------------------
- my $add = ($sections[0] eq '+') ? shift(@sections) : '';
-
- ## Reset the set of sections to use
- unless (@sections) {
- delete $myData{_SELECTED_SECTIONS} unless ($add);
- return;
- }
- $myData{_SELECTED_SECTIONS} = []
- unless ($add && exists $myData{_SELECTED_SECTIONS});
- local *selected_sections = $myData{_SELECTED_SECTIONS};
-
- ## Compile each spec
- for my $spec (@sections) {
- if ( defined($_ = _compile_section_spec($spec)) ) {
- ## Store them in our sections array
- push(@selected_sections, $_);
- }
- else {
- carp qq{Ignoring section spec "$spec"!\n};
- }
- }
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<add_selection()>
-
- $parser->add_selection($section_spec1,$section_spec2,...);
-
-This method is used to add to the currently selected sections and
-subsections of POD documentation that are to be printed and/or
-processed. See <select()> for replacing the currently selected sections.
-
-Each of the C<$section_spec> arguments should be a section specification
-as described in L<"SECTION SPECIFICATIONS">. The section specifications
-are parsed by this method and the resulting regular expressions are
-stored in the invoking object.
-
-This method should I<not> normally be overridden by subclasses.
-
-=cut
-
-sub add_selection {
- my $self = shift;
- return $self->select('+', @_);
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<clear_selections()>
-
- $parser->clear_selections();
-
-This method takes no arguments, it has the exact same effect as invoking
-<select()> with no arguments.
-
-=cut
-
-sub clear_selections {
- my $self = shift;
- return $self->select();
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<match_section()>
-
- $boolean = $parser->match_section($heading1,$heading2,...);
-
-Returns a value of true if the given section and subsection heading
-titles match any of the currently selected section specifications in
-effect from prior calls to B<select()> and B<add_selection()> (or if
-there are no explicitly selected/deselected sections).
-
-The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of
-the corresponding sections, subsections, etc. to try and match. If
-C<$headingN> is omitted then it defaults to the current corresponding
-section heading title in the input.
-
-This method should I<not> normally be overridden by subclasses.
-
-=cut
-
-sub match_section {
- my $self = shift;
- my (@headings) = @_;
- local *myData = $self;
-
- ## Return true if no restrictions were explicitly specified
- my $selections = (exists $myData{_SELECTED_SECTIONS})
- ? $myData{_SELECTED_SECTIONS} : undef;
- return 1 unless ((defined $selections) && @{$selections});
-
- ## Default any unspecified sections to the current one
- my @current_headings = $self->curr_headings();
- for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
- (defined $headings[$i]) or $headings[$i] = $current_headings[$i];
- }
-
- ## Look for a match against the specified section expressions
- for my $section_spec ( @{$selections} ) {
- ##------------------------------------------------------
- ## Each portion of this spec must match in order for
- ## the spec to be matched. So we will start with a
- ## match-value of 'true' and logically 'and' it with
- ## the results of matching a given element of the spec.
- ##------------------------------------------------------
- my $match = 1;
- for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
- my $regex = $section_spec->[$i];
- my $negated = ($regex =~ s/^\!//);
- $match &= ($negated ? ($headings[$i] !~ /${regex}/)
- : ($headings[$i] =~ /${regex}/));
- last unless ($match);
- }
- return 1 if ($match);
- }
- return 0; ## no match
-}
-
-##---------------------------------------------------------------------------
-
-=head1 B<is_selected()>
-
- $boolean = $parser->is_selected($paragraph);
-
-This method is used to determine if the block of text given in
-C<$paragraph> falls within the currently selected set of POD sections
-and subsections to be printed or processed. This method is also
-responsible for keeping track of the current input section and
-subsections. It is assumed that C<$paragraph> is the most recently read
-(but not yet processed) input paragraph.
-
-The value returned will be true if the C<$paragraph> and the rest of the
-text in the same section as C<$paragraph> should be selected (included)
-for processing; otherwise a false value is returned.
-
-=cut
-
-sub is_selected {
- my ($self, $paragraph) = @_;
- local $_;
- local *myData = $self;
-
- $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS});
-
- ## Keep track of current sections levels and headings
- $_ = $paragraph;
- if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/)
- {
- ## This is a section heading command
- my ($level, $heading) = ($2, $3);
- $level = 1 + (length($1) / 3) if ((! length $level) || (length $1));
- ## Reset the current section heading at this level
- $myData{_SECTION_HEADINGS}->[$level - 1] = $heading;
- ## Reset subsection headings of this one to empty
- for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) {
- $myData{_SECTION_HEADINGS}->[$i] = '';
- }
- }
-
- return $self->match_section();
-}
-
-#############################################################################
-
-=head1 EXPORTED FUNCTIONS
-
-The following functions are exported by this module. Please note that
-these are functions (not methods) and therefore C<do not> take an
-implicit first argument.
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=head1 B<podselect()>
-
- podselect(\%options, at filelist);
-
-B<podselect> will print the raw (untranslated) POD paragraphs of all
-POD sections in the given input files specified by C<@filelist>
-according to the given options.
-
-If any argument to B<podselect> is a reference to a hash
-(associative array) then the values with the following keys are
-processed as follows:
-
-=over 4
-
-=item B<-output>
-
-A string corresponding to the desired output file (or ">&STDOUT"
-or ">&STDERR"). The default is to use standard output.
-
-=item B<-sections>
-
-A reference to an array of sections specifications (as described in
-L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD
-sections and subsections to be selected from input. If no section
-specifications are given, then all sections of the PODs are used.
-
-=begin _NOT_IMPLEMENTED_
-
-=item B<-ranges>
-
-A reference to an array of range specifications (as described in
-L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD
-paragraphs to be selected from the desired input sections. If no range
-specifications are given, then all paragraphs of the desired sections
-are used.
-
-=end _NOT_IMPLEMENTED_
-
-=back
-
-All other arguments should correspond to the names of input files
-containing POD sections. A file name of "-" or "<&STDIN" will
-be interpreted to mean standard input (which is the default if no
-filenames are given).
-
-=cut
-
-sub podselect {
- my(@argv) = @_;
- my %defaults = ();
- my $pod_parser = new Pod::Select(%defaults);
- my $num_inputs = 0;
- my $output = '>&STDOUT';
- my %opts;
- local $_;
- for (@argv) {
- if (ref($_)) {
- next unless (ref($_) eq 'HASH');
- %opts = (%defaults, %{$_});
-
- ##-------------------------------------------------------------
- ## Need this for backward compatibility since we formerly used
- ## options that were all uppercase words rather than ones that
- ## looked like Unix command-line options.
- ## to be uppercase keywords)
- ##-------------------------------------------------------------
- %opts = map {
- my ($key, $val) = (lc $_, $opts{$_});
- $key =~ s/^(?=\w)/-/;
- $key =~ /^-se[cl]/ and $key = '-sections';
- #! $key eq '-range' and $key .= 's';
- ($key => $val);
- } (keys %opts);
-
- ## Process the options
- (exists $opts{'-output'}) and $output = $opts{'-output'};
-
- ## Select the desired sections
- $pod_parser->select(@{ $opts{'-sections'} })
- if ( (defined $opts{'-sections'})
- && ((ref $opts{'-sections'}) eq 'ARRAY') );
-
- #! ## Select the desired paragraph ranges
- #! $pod_parser->select(@{ $opts{'-ranges'} })
- #! if ( (defined $opts{'-ranges'})
- #! && ((ref $opts{'-ranges'}) eq 'ARRAY') );
- }
- else {
- $pod_parser->parse_from_file($_, $output);
- ++$num_inputs;
- }
- }
- $pod_parser->parse_from_file('-') unless ($num_inputs > 0);
-}
-
-#############################################################################
-
-=head1 PRIVATE METHODS AND DATA
-
-B<Pod::Select> makes uses a number of internal methods and data fields
-which clients should not need to see or use. For the sake of avoiding
-name collisions with client data and methods, these methods and fields
-are briefly discussed here. Determined hackers may obtain further
-information about them by reading the B<Pod::Select> source code.
-
-Private data fields are stored in the hash-object whose reference is
-returned by the B<new()> constructor for this class. The names of all
-private methods and data-fields used by B<Pod::Select> begin with a
-prefix of "_" and match the regular expression C</^_\w+$/>.
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=begin _PRIVATE_
-
-=head1 B<_compile_section_spec()>
-
- $listref = $parser->_compile_section_spec($section_spec);
-
-This function (note it is a function and I<not> a method) takes a
-section specification (as described in L<"SECTION SPECIFICATIONS">)
-given in C<$section_sepc>, and compiles it into a list of regular
-expressions. If C<$section_spec> has no syntax errors, then a reference
-to the list (array) of corresponding regular expressions is returned;
-otherwise C<undef> is returned and an error message is printed (using
-B<carp>) for each invalid regex.
-
-=end _PRIVATE_
-
-=cut
-
-sub _compile_section_spec {
- my ($section_spec) = @_;
- my (@regexs, $negated);
-
- ## Compile the spec into a list of regexs
- local $_ = $section_spec;
- s{\\\\}{\001}g; ## handle escaped backward slashes
- s{\\/}{\002}g; ## handle escaped forward slashes
-
- ## Parse the regexs for the heading titles
- @regexs = split(/\//, $_, $MAX_HEADING_LEVEL);
-
- ## Set default regex for ommitted levels
- for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
- $regexs[$i] = '.*' unless ((defined $regexs[$i])
- && (length $regexs[$i]));
- }
- ## Modify the regexs as needed and validate their syntax
- my $bad_regexs = 0;
- for (@regexs) {
- $_ .= '.+' if ($_ eq '!');
- s{\001}{\\\\}g; ## restore escaped backward slashes
- s{\002}{\\/}g; ## restore escaped forward slashes
- $negated = s/^\!//; ## check for negation
- eval "m{$_}"; ## check regex syntax
- if ($@) {
- ++$bad_regexs;
- carp qq{Bad regular expression /$_/ in "$section_spec": $@\n};
- }
- else {
- ## Add the forward and rear anchors (and put the negator back)
- $_ = '^' . $_ unless (/^\^/);
- $_ = $_ . '$' unless (/\$$/);
- $_ = '!' . $_ if ($negated);
- }
- }
- return (! $bad_regexs) ? [ @regexs ] : undef;
-}
-
-##---------------------------------------------------------------------------
-
-=begin _PRIVATE_
-
-=head2 $self->{_SECTION_HEADINGS}
-
-A reference to an array of the current section heading titles for each
-heading level (note that the first heading level title is at index 0).
-
-=end _PRIVATE_
-
-=cut
-
-##---------------------------------------------------------------------------
-
-=begin _PRIVATE_
-
-=head2 $self->{_SELECTED_SECTIONS}
-
-A reference to an array of references to arrays. Each subarray is a list
-of anchored regular expressions (preceded by a "!" if the expression is to
-be negated). The index of the expression in the subarray should correspond
-to the index of the heading title in C<$self-E<gt>{_SECTION_HEADINGS}>
-that it is to be matched against.
-
-=end _PRIVATE_
-
-=cut
-
-#############################################################################
-
-=head1 SEE ALSO
-
-L<Pod::Parser>
-
-=head1 AUTHOR
-
-Please report bugs using L<http://rt.cpan.org>.
-
-Brad Appleton E<lt>bradapp at enteract.comE<gt>
-
-Based on code for B<pod2text> written by
-Tom Christiansen E<lt>tchrist at mox.perl.comE<gt>
-
-=cut
-
-1;
-# vim: ts=4 sw=4 et
Deleted: trunk/contrib/perl/lib/Pod/Simple.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Simple.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Simple.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,1536 +0,0 @@
-
-require 5;
-package Pod::Simple;
-use strict;
-use Carp ();
-BEGIN { *DEBUG = sub () {0} unless defined &DEBUG }
-use integer;
-use Pod::Escapes 1.03 ();
-use Pod::Simple::LinkSection ();
-use Pod::Simple::BlackBox ();
-#use utf8;
-
-use vars qw(
- $VERSION @ISA
- @Known_formatting_codes @Known_directives
- %Known_formatting_codes %Known_directives
- $NL
-);
-
- at ISA = ('Pod::Simple::BlackBox');
-$VERSION = '3.07';
-
- at Known_formatting_codes = qw(I B C L E F S X Z);
-%Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
- at Known_directives = qw(head1 head2 head3 head4 item over back);
-%Known_directives = map(($_=>'Plain'), @Known_directives);
-$NL = $/ unless defined $NL;
-
-#-----------------------------------------------------------------------------
-# Set up some constants:
-
-BEGIN {
- if(defined &ASCII) { }
- elsif(chr(65) eq 'A') { *ASCII = sub () {1} }
- else { *ASCII = sub () {''} }
-
- unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} }
- DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n";
- unless(MANY_LINES() >= 1) {
- die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting";
- }
- if(defined &UNICODE) { }
- elsif($] >= 5.008) { *UNICODE = sub() {1} }
- else { *UNICODE = sub() {''} }
-}
-if(DEBUG > 2) {
- print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n";
- print "# We are under a Unicode-safe Perl.\n";
-}
-
-# Design note:
-# This is a parser for Pod. It is not a parser for the set of Pod-like
-# languages which happens to contain Pod -- it is just for Pod, plus possibly
-# some extensions.
-
-# @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
-#@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-
-__PACKAGE__->_accessorize(
- 'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters
- 'source_filename', # Filename of the source, for use in warnings
- 'source_dead', # Whether to consider this parser's source dead
-
- 'output_fh', # The filehandle we're writing to, if applicable.
- # Used only in some derived classes.
-
- 'hide_line_numbers', # For some dumping subclasses: whether to pointedly
- # suppress the start_line attribute
-
- 'line_count', # the current line number
- 'pod_para_count', # count of pod paragraphs seen so far
-
- 'no_whining', # whether to suppress whining
- 'no_errata_section', # whether to suppress the errata section
- 'complain_stderr', # whether to complain to stderr
-
- 'doc_has_started', # whether we've fired the open-Document event yet
-
- 'bare_output', # For some subclasses: whether to prepend
- # header-code and postpend footer-code
-
- 'fullstop_space_harden', # Whether to turn ". " into ".[nbsp] ";
-
- 'nix_X_codes', # whether to ignore X<...> codes
- 'merge_text', # whether to avoid breaking a single piece of
- # text up into several events
-
- 'preserve_whitespace', # whether to try to keep whitespace as-is
-
- 'content_seen', # whether we've seen any real Pod content
- 'errors_seen', # TODO: document. whether we've seen any errors (fatal or not)
-
- 'codes_in_verbatim', # for PseudoPod extensions
-
- 'code_handler', # coderef to call when a code (non-pod) line is seen
- 'cut_handler', # coderef to call when a =cut line is seen
- #Called like:
- # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler;
- # $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler;
-
-);
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-
-sub any_errata_seen { # good for using as an exit() value...
- return shift->{'errors_seen'} || 0;
-}
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-# Pull in some functions that, for some reason, I expect to see here too:
-BEGIN {
- *pretty = \&Pod::Simple::BlackBox::pretty;
- *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol;
-}
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-
-sub version_report {
- my $class = ref($_[0]) || $_[0];
- if($class eq __PACKAGE__) {
- return "$class $VERSION";
- } else {
- my $v = $class->VERSION;
- return "$class $v (" . __PACKAGE__ . " $VERSION)";
- }
-}
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-
-#sub curr_open { # read-only list accessor
-# return @{ $_[0]{'curr_open'} || return() };
-#}
-#sub _curr_open_listref { $_[0]{'curr_open'} ||= [] }
-
-
-sub output_string {
- # Works by faking out output_fh. Simplifies our code.
- #
- my $this = shift;
- return $this->{'output_string'} unless @_; # GET.
-
- require Pod::Simple::TiedOutFH;
- my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] );
- $$x = '' unless defined $$x;
- DEBUG > 4 and print "# Output string set to $x ($$x)\n";
- $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]);
- return
- $this->{'output_string'} = $_[0];
- #${ ${ $this->{'output_fh'} } };
-}
-
-sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} }
-sub abandon_output_fh { $_[0]->output_fh(undef) }
-# These don't delete the string or close the FH -- they just delete our
-# references to it/them.
-# TODO: document these
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-
-sub new {
- # takes no parameters
- my $class = ref($_[0]) || $_[0];
- #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc "
- # . __PACKAGE__ );
- return bless {
- 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) },
- 'accept_directives' => { %Known_directives },
- 'accept_targets' => {},
- }, $class;
-}
-
-
-
-# TODO: an option for whether to interpolate E<...>'s, or just resolve to codes.
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-
-sub _handle_element_start { # OVERRIDE IN DERIVED CLASS
- my($self, $element_name, $attr_hash_r) = @_;
- return;
-}
-
-sub _handle_element_end { # OVERRIDE IN DERIVED CLASS
- my($self, $element_name) = @_;
- return;
-}
-
-sub _handle_text { # OVERRIDE IN DERIVED CLASS
- my($self, $text) = @_;
- return;
-}
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-#
-# And now directives (not targets)
-
-sub accept_directive_as_verbatim { shift->_accept_directives('Verbatim', @_) }
-sub accept_directive_as_data { shift->_accept_directives('Data', @_) }
-sub accept_directive_as_processed { shift->_accept_directives('Plain', @_) }
-
-sub _accept_directives {
- my($this, $type) = splice @_,0,2;
- foreach my $d (@_) {
- next unless defined $d and length $d;
- Carp::croak "\"$d\" isn't a valid directive name"
- unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
- Carp::croak "\"$d\" is already a reserved Pod directive name"
- if exists $Known_directives{$d};
- $this->{'accept_directives'}{$d} = $type;
- DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n";
- }
- DEBUG > 6 and print "$this\'s accept_directives : ",
- pretty($this->{'accept_directives'}), "\n";
-
- return sort keys %{ $this->{'accept_directives'} } if wantarray;
- return;
-}
-
-#--------------------------------------------------------------------------
-# TODO: document these:
-
-sub unaccept_directive { shift->unaccept_directives(@_) };
-
-sub unaccept_directives {
- my $this = shift;
- foreach my $d (@_) {
- next unless defined $d and length $d;
- Carp::croak "\"$d\" isn't a valid directive name"
- unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
- Carp::croak "But you must accept \"$d\" directives -- it's a builtin!"
- if exists $Known_directives{$d};
- delete $this->{'accept_directives'}{$d};
- DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n";
- }
- return sort keys %{ $this->{'accept_directives'} } if wantarray;
- return
-}
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-#
-# And now targets (not directives)
-
-sub accept_target { shift->accept_targets(@_) } # alias
-sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias
-
-
-sub accept_targets { shift->_accept_targets('1', @_) }
-
-sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) }
- # forces them to be processed, even when there's no ":".
-
-sub _accept_targets {
- my($this, $type) = splice @_,0,2;
- foreach my $t (@_) {
- next unless defined $t and length $t;
- # TODO: enforce some limitations on what a target name can be?
- $this->{'accept_targets'}{$t} = $type;
- DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n";
- }
- return sort keys %{ $this->{'accept_targets'} } if wantarray;
- return;
-}
-
-#--------------------------------------------------------------------------
-sub unaccept_target { shift->unaccept_targets(@_) }
-
-sub unaccept_targets {
- my $this = shift;
- foreach my $t (@_) {
- next unless defined $t and length $t;
- # TODO: enforce some limitations on what a target name can be?
- delete $this->{'accept_targets'}{$t};
- DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n";
- }
- return sort keys %{ $this->{'accept_targets'} } if wantarray;
- return;
-}
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-#
-# And now codes (not targets or directives)
-
-sub accept_code { shift->accept_codes(@_) } # alias
-
-sub accept_codes { # Add some codes
- my $this = shift;
-
- foreach my $new_code (@_) {
- next unless defined $new_code and length $new_code;
- if(ASCII) {
- # A good-enough check that it's good as an XML Name symbol:
- Carp::croak "\"$new_code\" isn't a valid element name"
- if $new_code =~
- m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
- # Characters under 0x80 that aren't legal in an XML Name.
- or $new_code =~ m/^[-\.0-9]/s
- or $new_code =~ m/:[-\.0-9]/s;
- # The legal under-0x80 Name characters that
- # an XML Name still can't start with.
- }
-
- $this->{'accept_codes'}{$new_code} = $new_code;
-
- # Yes, map to itself -- just so that when we
- # see "=extend W [whatever] thatelementname", we say that W maps
- # to whatever $this->{accept_codes}{thatelementname} is,
- # i.e., "thatelementname". Then when we go re-mapping,
- # a "W" in the treelet turns into "thatelementname". We only
- # remap once.
- # If we say we accept "W", then a "W" in the treelet simply turns
- # into "W".
- }
-
- return;
-}
-
-#--------------------------------------------------------------------------
-sub unaccept_code { shift->unaccept_codes(@_) }
-
-sub unaccept_codes { # remove some codes
- my $this = shift;
-
- foreach my $new_code (@_) {
- next unless defined $new_code and length $new_code;
- if(ASCII) {
- # A good-enough check that it's good as an XML Name symbol:
- Carp::croak "\"$new_code\" isn't a valid element name"
- if $new_code =~
- m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
- # Characters under 0x80 that aren't legal in an XML Name.
- or $new_code =~ m/^[-\.0-9]/s
- or $new_code =~ m/:[-\.0-9]/s;
- # The legal under-0x80 Name characters that
- # an XML Name still can't start with.
- }
-
- Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!"
- if grep $new_code eq $_, @Known_formatting_codes;
-
- delete $this->{'accept_codes'}{$new_code};
-
- DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n";
- }
-
- return;
-}
-
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-
-sub parse_string_document {
- my $self = shift;
- my @lines;
- foreach my $line_group (@_) {
- next unless defined $line_group and length $line_group;
- pos($line_group) = 0;
- while($line_group =~
- m/([^\n\r]*)((?:\r?\n)?)/g
- ) {
- #print(">> $1\n"),
- $self->parse_lines($1)
- if length($1) or length($2)
- or pos($line_group) != length($line_group);
- # I.e., unless it's a zero-length "empty line" at the very
- # end of "foo\nbar\n" (i.e., between the \n and the EOS).
- }
- }
- $self->parse_lines(undef); # to signal EOF
- return $self;
-}
-
-sub _init_fh_source {
- my($self, $source) = @_;
-
- #DEBUG > 1 and print "Declaring $source as :raw for starters\n";
- #$self->_apply_binmode($source, ':raw');
- #binmode($source, ":raw");
-
- return;
-}
-
-#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
-#
-
-sub parse_file {
- my($self, $source) = (@_);
-
- if(!defined $source) {
- Carp::croak("Can't use empty-string as a source for parse_file");
- } elsif(ref(\$source) eq 'GLOB') {
- $self->{'source_filename'} = '' . ($source);
- } elsif(ref $source) {
- $self->{'source_filename'} = '' . ($source);
- } elsif(!length $source) {
- Carp::croak("Can't use empty-string as a source for parse_file");
- } else {
- {
- local *PODSOURCE;
- open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!");
- $self->{'source_filename'} = $source;
- $source = *PODSOURCE{IO};
- }
- $self->_init_fh_source($source);
- }
- # By here, $source is a FH.
-
- $self->{'source_fh'} = $source;
-
- my($i, @lines);
- until( $self->{'source_dead'} ) {
- splice @lines;
- for($i = MANY_LINES; $i--;) { # read those many lines at a time
- local $/ = $NL;
- push @lines, scalar(<$source>); # readline
- last unless defined $lines[-1];
- # but pass thru the undef, which will set source_dead to true
- }
- $self->parse_lines(@lines);
- }
- delete($self->{'source_fh'}); # so it can be GC'd
- return $self;
-}
-
-#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
-
-sub parse_from_file {
- # An emulation of Pod::Parser's interface, for the sake of Perldoc.
- # Basically just a wrapper around parse_file.
-
- my($self, $source, $to) = @_;
- $self = $self->new unless ref($self); # so we tolerate being a class method
-
- if(!defined $source) { $source = *STDIN{IO}
- } elsif(ref(\$source) eq 'GLOB') { # stet
- } elsif(ref($source) ) { # stet
- } elsif(!length $source
- or $source eq '-' or $source =~ m/^<&(STDIN|0)$/i
- ) {
- $source = *STDIN{IO};
- }
-
- if(!defined $to) { $self->output_fh( *STDOUT{IO} );
- } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to );
- } elsif(ref($to)) { $self->output_fh( $to );
- } elsif(!length $to
- or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i
- ) {
- $self->output_fh( *STDOUT{IO} );
- } else {
- require Symbol;
- my $out_fh = Symbol::gensym();
- DEBUG and print "Write-opening to $to\n";
- open($out_fh, ">$to") or Carp::croak "Can't write-open $to: $!";
- binmode($out_fh)
- if $self->can('write_with_binmode') and $self->write_with_binmode;
- $self->output_fh($out_fh);
- }
-
- return $self->parse_file($source);
-}
-
-#-----------------------------------------------------------------------------
-
-sub whine {
- #my($self,$line,$complaint) = @_;
- my $self = shift(@_);
- ++$self->{'errors_seen'};
- if($self->{'no_whining'}) {
- DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n";
- return;
- }
- return $self->_complain_warn(@_) if $self->{'complain_stderr'};
- return $self->_complain_errata(@_);
-}
-
-sub scream { # like whine, but not suppressable
- #my($self,$line,$complaint) = @_;
- my $self = shift(@_);
- ++$self->{'errors_seen'};
- return $self->_complain_warn(@_) if $self->{'complain_stderr'};
- return $self->_complain_errata(@_);
-}
-
-sub _complain_warn {
- my($self,$line,$complaint) = @_;
- return printf STDERR "%s around line %s: %s\n",
- $self->{'source_filename'} || 'Pod input', $line, $complaint;
-}
-
-sub _complain_errata {
- my($self,$line,$complaint) = @_;
- if( $self->{'no_errata_section'} ) {
- DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n";
- } else {
- DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n";
- push @{$self->{'errata'}{$line}}, $complaint
- # for a report to be generated later!
- }
- return 1;
-}
-
-#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-
-sub _get_initial_item_type {
- # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n"
- my($self, $para) = @_;
- return $para->[1]{'~type'} if $para->[1]{'~type'};
-
- return $para->[1]{'~type'} = 'text'
- if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1';
- # Else fall thru to the general case:
- return $self->_get_item_type($para);
-}
-
-
-
-sub _get_item_type { # mutates the item!!
- my($self, $para) = @_;
- return $para->[1]{'~type'} if $para->[1]{'~type'};
-
-
- # Otherwise we haven't yet been to this node. Maybe alter it...
-
- my $content = join "\n", @{$para}[2 .. $#$para];
-
- if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) {
- # Like: "=item *", "=item * ", "=item"
- splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
- $para->[1]{'~orig_content'} = $content;
- return $para->[1]{'~type'} = 'bullet';
-
- } elsif($content =~ m/^\s*\*\s+(.+)/s) { # tolerance
-
- # Like: "=item * Foo bar baz";
- $para->[1]{'~orig_content'} = $content;
- $para->[1]{'~_freaky_para_hack'} = $1;
- DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n";
- splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
- return $para->[1]{'~type'} = 'bullet';
-
- } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) {
- # Like: "=item 1.", "=item 123412"
-
- $para->[1]{'~orig_content'} = $content;
- $para->[1]{'number'} = $1; # Yes, stores the number there!
-
- splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
- return $para->[1]{'~type'} = 'number';
-
- } else {
- # It's anything else.
- return $para->[1]{'~type'} = 'text';
-
- }
-}
-
-#-----------------------------------------------------------------------------
-
-sub _make_treelet {
- my $self = shift; # and ($para, $start_line)
- my $treelet;
- if(!@_) {
- return [''];
- } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') {
- # Hack so we can pass in fake-o pre-cooked paragraphs:
- # just have the first line be a reference to a ['~Top', {}, ...]
- # We use this feechure in gen_errata and stuff.
-
- DEBUG and print "Applying precooked treelet hack to $_[0][0]\n";
- $treelet = $_[0][0];
- splice @$treelet, 0, 2; # lop the top off
- return $treelet;
- } else {
- $treelet = $self->_treelet_from_formatting_codes(@_);
- }
-
- if( $self->_remap_sequences($treelet) ) {
- $self->_treat_Zs($treelet); # Might as well nix these first
- $self->_treat_Ls($treelet); # L has to precede E and S
- $self->_treat_Es($treelet);
- $self->_treat_Ss($treelet); # S has to come after E
-
- $self->_wrap_up($treelet); # Nix X's and merge texties
-
- } else {
- DEBUG and print "Formatless treelet gets fast-tracked.\n";
- # Very common case!
- }
-
- splice @$treelet, 0, 2; # lop the top off
-
- return $treelet;
-}
-
-#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
-
-sub _wrap_up {
- my($self, @stack) = @_;
- my $nixx = $self->{'nix_X_codes'};
- my $merge = $self->{'merge_text' };
- return unless $nixx or $merge;
-
- DEBUG > 2 and print "\nStarting _wrap_up traversal.\n",
- $merge ? (" Merge mode on\n") : (),
- $nixx ? (" Nix-X mode on\n") : (),
- ;
-
-
- my($i, $treelet);
- while($treelet = shift @stack) {
- DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
- for($i = 2; $i < @$treelet; ++$i) { # iterate over children
- DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n";
- if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') {
- DEBUG > 3 and print " Nixing X node at $i\n";
- splice(@$treelet, $i, 1); # just nix this node (and its descendants)
- # no need to back-update the counter just yet
- redo;
-
- } elsif($merge and $i != 2 and # non-initial
- !ref $treelet->[$i] and !ref $treelet->[$i - 1]
- ) {
- DEBUG > 3 and print " Merging ", $i-1,
- ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n";
- $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0];
- DEBUG > 4 and print " Now: ", $i-1, ":[$treelet->[$i-1]]\n";
- --$i;
- next;
- # since we just pulled the possibly last node out from under
- # ourselves, we can't just redo()
-
- } elsif( ref $treelet->[$i] ) {
- DEBUG > 4 and print " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n";
- push @stack, $treelet->[$i];
-
- if($treelet->[$i][0] eq 'L') {
- my $thing;
- foreach my $attrname ('section', 'to') {
- if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
- unshift @stack, $thing;
- DEBUG > 4 and print " +Enqueuing ",
- pretty( $treelet->[$i][1]{$attrname} ),
- " as an attribute value to tweak.\n";
- }
- }
- }
- }
- }
- }
- DEBUG > 2 and print "End of _wrap_up traversal.\n\n";
-
- return;
-}
-
-#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
-
-sub _remap_sequences {
- my($self, at stack) = @_;
-
- if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) {
- # VERY common case: abort it.
- DEBUG and print "Skipping _remap_sequences: formatless treelet.\n";
- return 0;
- }
-
- my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?");
-
- my $start_line = $stack[0][1]{'start_line'};
- DEBUG > 2 and printf
- "\nAbout to start _remap_sequences on treelet from line %s.\n",
- $start_line || '[?]'
- ;
- DEBUG > 3 and print " Map: ",
- join('; ', map "$_=" . (
- ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_}
- ),
- sort keys %$map ),
- ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map)
- ? " (all normal)\n" : "\n"
- ;
-
- # A recursive algorithm implemented iteratively! Whee!
-
- my($is, $was, $i, $treelet); # scratch
- while($treelet = shift @stack) {
- DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
- for($i = 2; $i < @$treelet; ++$i) { # iterate over children
- next unless ref $treelet->[$i]; # text nodes are uninteresting
-
- DEBUG > 4 and print " Noting child $i : $treelet->[$i][0]<...>\n";
-
- $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] };
- if( DEBUG > 3 ) {
- if(!defined $is) {
- print " Code $was<> is UNKNOWN!\n";
- } elsif($is eq $was) {
- DEBUG > 4 and print " Code $was<> stays the same.\n";
- } else {
- print " Code $was<> maps to ",
- ref($is)
- ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" )
- : "tag $is<...>.\n";
- }
- }
-
- if(!defined $is) {
- $self->whine($start_line, "Deleting unknown formatting code $was<>");
- $is = $treelet->[$i][0] = '1'; # But saving the children!
- # I could also insert a leading "$was<" and tailing ">" as
- # children of this node, but something about that seems icky.
- }
- if(ref $is) {
- my @dynasty = @$is;
- DEBUG > 4 and print " Renaming $was node to $dynasty[-1]\n";
- $treelet->[$i][0] = pop @dynasty;
- my $nugget;
- while(@dynasty) {
- DEBUG > 4 and printf
- " Grafting a new %s node between %s and %s\n",
- $dynasty[-1], $treelet->[0], $treelet->[$i][0],
- ;
-
- #$nugget = ;
- splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]];
- # relace node with a new parent
- }
- } elsif($is eq '0') {
- splice(@$treelet, $i, 1); # just nix this node (and its descendants)
- --$i; # back-update the counter
- } elsif($is eq '1') {
- splice(@$treelet, $i, 1 # replace this node with its children!
- => splice @{ $treelet->[$i] },2
- # (not catching its first two (non-child) items)
- );
- --$i; # back up for new stuff
- } else {
- # otherwise it's unremarkable
- unshift @stack, $treelet->[$i]; # just recurse
- }
- }
- }
-
- DEBUG > 2 and print "End of _remap_sequences traversal.\n\n";
-
- if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) {
- DEBUG and print "Noting that the treelet is now formatless.\n";
- return 0;
- }
- return 1;
-}
-
-# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
-
-sub _ponder_extend {
-
- # "Go to an extreme, move back to a more comfortable place"
- # -- /Oblique Strategies/, Brian Eno and Peter Schmidt
-
- my($self, $para) = @_;
- my $content = join ' ', splice @$para, 2;
- $content =~ s/^\s+//s;
- $content =~ s/\s+$//s;
-
- DEBUG > 2 and print "Ogling extensor: =extend $content\n";
-
- if($content =~
- m/^
- (\S+) # 1 : new item
- \s+
- (\S+) # 2 : fallback(s)
- (?:\s+(\S+))? # 3 : element name(s)
- \s*
- $
- /xs
- ) {
- my $new_letter = $1;
- my $fallbacks_one = $2;
- my $elements_one;
- $elements_one = defined($3) ? $3 : $1;
-
- DEBUG > 2 and print "Extensor has good syntax.\n";
-
- unless($new_letter =~ m/^[A-Z]$/s or $new_letter) {
- DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n";
- $self->whine(
- $para->[1]{'start_line'},
- "You can extend only formatting codes A-Z, not like \"$new_letter\""
- );
- return;
- }
-
- if(grep $new_letter eq $_, @Known_formatting_codes) {
- DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n";
- $self->whine(
- $para->[1]{'start_line'},
- "You can't extend an established code like \"$new_letter\""
- );
-
- #TODO: or allow if last bit is same?
-
- return;
- }
-
- unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s # like "B", "M,I", etc.
- or $fallbacks_one eq '0' or $fallbacks_one eq '1'
- ) {
- $self->whine(
- $para->[1]{'start_line'},
- "Format for second =extend parameter must be like"
- . " M or 1 or 0 or M,N or M,N,O but you have it like "
- . $fallbacks_one
- );
- return;
- }
-
- unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc.
- $self->whine(
- $para->[1]{'start_line'},
- "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like "
- . $elements_one
- );
- return;
- }
-
- my @fallbacks = split ',', $fallbacks_one, -1;
- my @elements = split ',', $elements_one, -1;
-
- foreach my $f (@fallbacks) {
- next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1';
- DEBUG > 2 and print " Can't fall back on unknown code $f\n";
- $self->whine(
- $para->[1]{'start_line'},
- "Can't use unknown formatting code '$f' as a fallback for '$new_letter'"
- );
- return;
- }
-
- DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n",
- @fallbacks, @elements;
-
- my $canonical_form;
- foreach my $e (@elements) {
- if(exists $self->{'accept_codes'}{$e}) {
- DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n";
- $canonical_form = $e;
- last; # first acceptable elementname wins!
- } else {
- DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n";
- }
- }
-
-
- if( defined $canonical_form ) {
- # We found a good N => elementname mapping
- $self->{'accept_codes'}{$new_letter} = $canonical_form;
- DEBUG > 2 and print
- "Extensor maps $new_letter => known element $canonical_form.\n";
- } else {
- # We have to use the fallback(s), which might be '0', or '1'.
- $self->{'accept_codes'}{$new_letter}
- = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks;
- DEBUG > 2 and print
- "Extensor maps $new_letter => fallbacks @fallbacks.\n";
- }
-
- } else {
- DEBUG > 2 and print "Extensor has bad syntax.\n";
- $self->whine(
- $para->[1]{'start_line'},
- "Unknown =extend syntax: $content"
- )
- }
- return;
-}
-
-
-#:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
-
-sub _treat_Zs { # Nix Z<...>'s
- my($self, at stack) = @_;
-
- my($i, $treelet);
- my $start_line = $stack[0][1]{'start_line'};
-
- # A recursive algorithm implemented iteratively! Whee!
-
- while($treelet = shift @stack) {
- for($i = 2; $i < @$treelet; ++$i) { # iterate over children
- next unless ref $treelet->[$i]; # text nodes are uninteresting
- unless($treelet->[$i][0] eq 'Z') {
- unshift @stack, $treelet->[$i]; # recurse
- next;
- }
-
- DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n";
-
- # bitch UNLESS it's empty
- unless( @{$treelet->[$i]} == 2
- or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
- ) {
- $self->whine( $start_line, "A non-empty Z<>" );
- } # but kill it anyway
-
- splice(@$treelet, $i, 1); # thereby just nix this node.
- --$i;
-
- }
- }
-
- return;
-}
-
-# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
-
-# Quoting perlpodspec:
-
-# In parsing an L<...> code, Pod parsers must distinguish at least four
-# attributes:
-
-############# Not used. Expressed via the element children plus
-############# the value of the "content-implicit" flag.
-# First:
-# The link-text. If there is none, this must be undef. (E.g., in "L<Perl
-# Functions|perlfunc>", the link-text is "Perl Functions". In
-# "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note
-# that link text may contain formatting.)
-#
-
-############# The element children
-# Second:
-# The possibly inferred link-text -- i.e., if there was no real link text,
-# then this is the text that we'll infer in its place. (E.g., for
-# "L<Getopt::Std>", the inferred link text is "Getopt::Std".)
-#
-
-############# The "to" attribute (which might be text, or a treelet)
-# Third:
-# The name or URL, or undef if none. (E.g., in "L<Perl
-# Functions|perlfunc>", the name -- also sometimes called the page -- is
-# "perlfunc". In "L</CAVEATS>", the name is undef.)
-#
-
-############# The "section" attribute (which might be next, or a treelet)
-# Fourth:
-# The section (AKA "item" in older perlpods), or undef if none. E.g., in
-# Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this
-# is not the same as a manpage section like the "5" in "man 5 crontab".
-# "Section Foo" in the Pod sense means the part of the text that's
-# introduced by the heading or item whose text is "Foo".)
-#
-# Pod parsers may also note additional attributes including:
-#
-
-############# The "type" attribute.
-# Fifth:
-# A flag for whether item 3 (if present) is a URL (like
-# "http://lists.perl.org" is), in which case there should be no section
-# attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or
-# possibly a man page name (like "crontab(5)" is).
-#
-
-############# Not implemented, I guess.
-# Sixth:
-# The raw original L<...> content, before text is split on "|", "/", etc,
-# and before E<...> codes are expanded.
-
-
-# For L<...> codes without a "name|" part, only E<...> and Z<> codes may
-# occur -- no other formatting codes. That is, authors should not use
-# "L<B<Foo::Bar>>".
-#
-# Note, however, that formatting codes and Z<>'s can occur in any and all
-# parts of an L<...> (i.e., in name, section, text, and url).
-
-sub _treat_Ls { # Process our dear dear friends, the L<...> sequences
-
- # L<name>
- # L<name/"sec"> or L<name/sec>
- # L</"sec"> or L</sec> or L<"sec">
- # L<text|name>
- # L<text|name/"sec"> or L<text|name/sec>
- # L<text|/"sec"> or L<text|/sec> or L<text|"sec">
- # L<scheme:...>
- # Ltext|scheme:...>
-
- my($self, at stack) = @_;
-
- my($i, $treelet);
- my $start_line = $stack[0][1]{'start_line'};
-
- # A recursive algorithm implemented iteratively! Whee!
-
- while($treelet = shift @stack) {
- for(my $i = 2; $i < @$treelet; ++$i) {
- # iterate over children of current tree node
- next unless ref $treelet->[$i]; # text nodes are uninteresting
- unless($treelet->[$i][0] eq 'L') {
- unshift @stack, $treelet->[$i]; # recurse
- next;
- }
-
-
- # By here, $treelet->[$i] is definitely an L node
- my $ell = $treelet->[$i];
- DEBUG > 1 and print "Ogling L node $ell\n";
-
- # bitch if it's empty
- if( @{$ell} == 2
- or (@{$ell} == 3 and $ell->[2] eq '')
- ) {
- $self->whine( $start_line, "An empty L<>" );
- $treelet->[$i] = 'L<>'; # just make it a text node
- next; # and move on
- }
-
- # Catch URLs:
-
- # there are a number of possible cases:
- # 1) text node containing url: http://foo.com
- # -> [ 'http://foo.com' ]
- # 2) text node containing url and text: foo|http://foo.com
- # -> [ 'foo|http://foo.com' ]
- # 3) text node containing url start: mailto:xE<at>foo.com
- # -> [ 'mailto:x', [ E ... ], 'foo.com' ]
- # 4) text node containing url start and text: foo|mailto:xE<at>foo.com
- # -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ]
- # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com
- # -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ]
- # ... etc.
-
- # anything before the url is part of the text.
- # anything after it is part of the url.
- # the url text node itself may contain parts of both.
-
- if (my ($url_index, $text_part, $url_part) =
- # grep is no good here; we want to bail out immediately so that we can
- # use $1, $2, etc. without having to do the match twice.
- sub {
- for (2..$#$ell) {
- next if ref $ell->[$_];
- next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s;
- return ($_, $1, $2);
- }
- return;
- }->()
- ) {
- $ell->[1]{'type'} = 'url';
-
- my @text = @{$ell}[2..$url_index-1];
- push @text, $text_part if defined $text_part;
-
- my @url = @{$ell}[$url_index+1..$#$ell];
- unshift @url, $url_part;
-
- unless (@text) {
- $ell->[1]{'content-implicit'} = 'yes';
- @text = @url;
- }
-
- $ell->[1]{to} = Pod::Simple::LinkSection->new(
- @url == 1
- ? $url[0]
- : [ '', {}, @url ],
- );
-
- splice @$ell, 2, $#$ell, @text;
-
- next;
- }
-
- # Catch some very simple and/or common cases
- if(@{$ell} == 3 and ! ref $ell->[2]) {
- my $it = $ell->[2];
- if($it =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s) { # man sections
- # Hopefully neither too broad nor too restrictive a RE
- DEBUG > 1 and print "Catching \"$it\" as manpage link.\n";
- $ell->[1]{'type'} = 'man';
- # This's the only place where man links can get made.
- $ell->[1]{'content-implicit'} = 'yes';
- $ell->[1]{'to' } =
- Pod::Simple::LinkSection->new( $it ); # treelet!
-
- next;
- }
- if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) {
- # Extremely forgiving idea of what constitutes a bare
- # modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala>
- DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n";
- $ell->[1]{'type'} = 'pod';
- $ell->[1]{'content-implicit'} = 'yes';
- $ell->[1]{'to' } =
- Pod::Simple::LinkSection->new( $it ); # treelet!
- next;
- }
- # else fall thru...
- }
-
-
-
- # ...Uhoh, here's the real L<...> parsing stuff...
- # "With the ill behavior, with the ill behavior, with the ill behavior..."
-
- DEBUG > 1 and print "Running a real parse on this non-trivial L\n";
-
-
- my $link_text; # set to an arrayref if found
- my @ell_content = @$ell;
- splice @ell_content,0,2; # Knock off the 'L' and {} bits
-
- DEBUG > 3 and print " Ell content to start: ",
- pretty(@ell_content), "\n";
-
-
- # Look for the "|" -- only in CHILDREN (not all underlings!)
- # Like L<I like the strictness|strict>
- DEBUG > 3 and
- print " Peering at L content for a '|' ...\n";
- for(my $j = 0; $j < @ell_content; ++$j) {
- next if ref $ell_content[$j];
- DEBUG > 3 and
- print " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n";
-
- if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) {
- my @link_text = ($1); # might be 0-length
- $ell_content[$j] = $2; # might be 0-length
-
- DEBUG > 3 and
- print " FOUND a '|' in it. Splitting into [$1] + [$2]\n";
-
- unshift @link_text, splice @ell_content, 0, $j;
- # leaving only things at J and after
- @ell_content = grep ref($_)||length($_), @ell_content ;
- $link_text = [grep ref($_)||length($_), @link_text ];
- DEBUG > 3 and printf
- " So link text is %s\n and remaining ell content is %s\n",
- pretty($link_text), pretty(@ell_content);
- last;
- }
- }
-
-
- # Now look for the "/" -- only in CHILDREN (not all underlings!)
- # And afterward, anything left in @ell_content will be the raw name
- # Like L<Foo::Bar/Object Methods>
- my $section_name; # set to arrayref if found
- DEBUG > 3 and print " Peering at L-content for a '/' ...\n";
- for(my $j = 0; $j < @ell_content; ++$j) {
- next if ref $ell_content[$j];
- DEBUG > 3 and
- print " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n";
-
- if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) {
- my @section_name = ($2); # might be 0-length
- $ell_content[$j] = $1; # might be 0-length
-
- DEBUG > 3 and
- print " FOUND a '/' in it.",
- " Splitting to page [...$1] + section [$2...]\n";
-
- push @section_name, splice @ell_content, 1+$j;
- # leaving only things before and including J
-
- @ell_content = grep ref($_)||length($_), @ell_content ;
- @section_name = grep ref($_)||length($_), @section_name ;
-
- # Turn L<.../"foo"> into L<.../foo>
- if(@section_name
- and !ref($section_name[0]) and !ref($section_name[-1])
- and $section_name[ 0] =~ m/^\"/s
- and $section_name[-1] =~ m/\"$/s
- and !( # catch weird degenerate case of L<"> !
- @section_name == 1 and $section_name[0] eq '"'
- )
- ) {
- $section_name[ 0] =~ s/^\"//s;
- $section_name[-1] =~ s/\"$//s;
- DEBUG > 3 and
- print " Quotes removed: ", pretty(@section_name), "\n";
- } else {
- DEBUG > 3 and
- print " No need to remove quotes in ", pretty(@section_name), "\n";
- }
-
- $section_name = \@section_name;
- last;
- }
- }
-
- # Turn L<"Foo Bar"> into L</Foo Bar>
- if(!$section_name and @ell_content
- and !ref($ell_content[0]) and !ref($ell_content[-1])
- and $ell_content[ 0] =~ m/^\"/s
- and $ell_content[-1] =~ m/\"$/s
- and !( # catch weird degenerate case of L<"> !
- @ell_content == 1 and $ell_content[0] eq '"'
- )
- ) {
- $section_name = [splice @ell_content];
- $section_name->[ 0] =~ s/^\"//s;
- $section_name->[-1] =~ s/\"$//s;
- }
-
- # Turn L<Foo Bar> into L</Foo Bar>.
- if(!$section_name and !$link_text and @ell_content
- and grep !ref($_) && m/ /s, @ell_content
- ) {
- $section_name = [splice @ell_content];
- # That's support for the now-deprecated syntax.
- # (Maybe generate a warning eventually?)
- # Note that it deliberately won't work on L<...|Foo Bar>
- }
-
-
- # Now make up the link_text
- # L<Foo> -> L<Foo|Foo>
- # L</Bar> -> L<"Bar"|Bar>
- # L<Foo/Bar> -> L<"Bar" in Foo/Foo>
- unless($link_text) {
- $ell->[1]{'content-implicit'} = 'yes';
- $link_text = [];
- push @$link_text, '"', @$section_name, '"' if $section_name;
-
- if(@ell_content) {
- $link_text->[-1] .= ' in ' if $section_name;
- push @$link_text, @ell_content;
- }
- }
-
-
- # And the E resolver will have to deal with all our treeletty things:
-
- if(@ell_content == 1 and !ref($ell_content[0])
- and $ell_content[0] =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s
- ) {
- $ell->[1]{'type'} = 'man';
- DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n";
- } else {
- $ell->[1]{'type'} = 'pod';
- DEBUG > 3 and print "Considering this a pod link (not man or url).\n";
- }
-
- if( defined $section_name ) {
- $ell->[1]{'section'} = Pod::Simple::LinkSection->new(
- ['', {}, @$section_name]
- );
- DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n";
- }
-
- if( @ell_content ) {
- $ell->[1]{'to'} = Pod::Simple::LinkSection->new(
- ['', {}, @ell_content]
- );
- DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n";
- }
-
- # And update children to be the link-text:
- @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : '');
-
- DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n";
-
- unshift @stack, $treelet->[$i]; # might as well recurse
- }
- }
-
- return;
-}
-
-# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
-
-sub _treat_Es {
- my($self, at stack) = @_;
-
- my($i, $treelet, $content, $replacer, $charnum);
- my $start_line = $stack[0][1]{'start_line'};
-
- # A recursive algorithm implemented iteratively! Whee!
-
-
- # Has frightening side effects on L nodes' attributes.
-
- #my @ells_to_tweak;
-
- while($treelet = shift @stack) {
- for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children
- next unless ref $treelet->[$i]; # text nodes are uninteresting
- if($treelet->[$i][0] eq 'L') {
- # SPECIAL STUFF for semi-processed L<>'s
-
- my $thing;
- foreach my $attrname ('section', 'to') {
- if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
- unshift @stack, $thing;
- DEBUG > 2 and print " Enqueuing ",
- pretty( $treelet->[$i][1]{$attrname} ),
- " as an attribute value to tweak.\n";
- }
- }
-
- unshift @stack, $treelet->[$i]; # recurse
- next;
- } elsif($treelet->[$i][0] ne 'E') {
- unshift @stack, $treelet->[$i]; # recurse
- next;
- }
-
- DEBUG > 1 and print "Ogling E node ", pretty($treelet->[$i]), "\n";
-
- # bitch if it's empty
- if( @{$treelet->[$i]} == 2
- or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
- ) {
- $self->whine( $start_line, "An empty E<>" );
- $treelet->[$i] = 'E<>'; # splice in a literal
- next;
- }
-
- # bitch if content is weird
- unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) {
- $self->whine( $start_line, "An E<...> surrounding strange content" );
- $replacer = $treelet->[$i]; # scratch
- splice(@$treelet, $i, 1, # fake out a literal
- 'E<',
- splice(@$replacer,2), # promote its content
- '>'
- );
- # Don't need to do --$i, as the 'E<' we just added isn't interesting.
- next;
- }
-
- DEBUG > 1 and print "Ogling E<$content>\n";
-
- $charnum = Pod::Escapes::e2charnum($content);
- DEBUG > 1 and print " Considering E<$content> with char ",
- defined($charnum) ? $charnum : "undef", ".\n";
-
- if(!defined( $charnum )) {
- DEBUG > 1 and print "I don't know how to deal with E<$content>.\n";
- $self->whine( $start_line, "Unknown E content in E<$content>" );
- $replacer = "E<$content>"; # better than nothing
- } elsif($charnum >= 255 and !UNICODE) {
- $replacer = ASCII ? "\xA4" : "?";
- DEBUG > 1 and print "This Perl version can't handle ",
- "E<$content> (chr $charnum), so replacing with $replacer\n";
- } else {
- $replacer = Pod::Escapes::e2char($content);
- DEBUG > 1 and print " Replacing E<$content> with $replacer\n";
- }
-
- splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho
- }
- }
-
- return;
-}
-
-
-# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
-
-sub _treat_Ss {
- my($self,$treelet) = @_;
-
- _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'};
-
- # TODO: or a change_nbsp_to_S
- # Normalizing nbsp's to S is harder: for each text node, make S content
- # out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/
-
-
- return;
-}
-
-
-sub _change_S_to_nbsp { # a recursive function
- # Sanely assumes that the top node in the excursion won't be an S node.
- my($treelet, $in_s) = @_;
-
- my $is_s = ('S' eq $treelet->[0]);
- $in_s ||= $is_s; # So in_s is on either by this being an S element,
- # or by an ancestor being an S element.
-
- for(my $i = 2; $i < @$treelet; ++$i) {
- if(ref $treelet->[$i]) {
- if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) {
- my $to_pull_up = $treelet->[$i];
- splice @$to_pull_up,0,2; # ...leaving just its content
- splice @$treelet, $i, 1, @$to_pull_up; # Pull up content
- $i += @$to_pull_up - 1; # Make $i skip the pulled-up stuff
- }
- } else {
- $treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s;
- # (If not in ASCIIland, we can't assume that \xA0 == nbsp.)
-
- # Note that if you apply nbsp_for_S to text, and so turn
- # "foo S<bar baz> quux" into "foo bar faz quux", you
- # end up with something that fails to say "and don't hyphenate
- # any part of 'bar baz'". However, hyphenation is such a vexing
- # problem anyway, that most Pod renderers just don't render it
- # at all. But if you do want to implement hyphenation, I guess
- # that you'd better have nbsp_for_S off.
- }
- }
-
- return $is_s;
-}
-
-#-----------------------------------------------------------------------------
-
-sub _accessorize { # A simple-minded method-maker
- no strict 'refs';
- foreach my $attrname (@_) {
- next if $attrname =~ m/::/; # a hack
- *{caller() . '::' . $attrname} = sub {
- use strict;
- $Carp::CarpLevel = 1, Carp::croak(
- "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
- ) unless (@_ == 1 or @_ == 2) and ref $_[0];
- (@_ == 1) ? $_[0]->{$attrname}
- : ($_[0]->{$attrname} = $_[1]);
- };
- }
- # Ya know, they say accessories make the ensemble!
- return;
-}
-
-# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
-# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
-#=============================================================================
-
-sub filter {
- my($class, $source) = @_;
- my $new = $class->new;
- $new->output_fh(*STDOUT{IO});
-
- if(ref($source || '') eq 'SCALAR') {
- $new->parse_string_document( $$source );
- } elsif(ref($source)) { # it's a file handle
- $new->parse_file($source);
- } else { # it's a filename
- $new->parse_file($source);
- }
-
- return $new;
-}
-
-
-#-----------------------------------------------------------------------------
-
-sub _out {
- # For use in testing: Class->_out($source)
- # returns the transformation of $source
-
- my $class = shift(@_);
-
- my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
-
- DEBUG and print "\n\n", '#' x 76,
- "\nAbout to parse source: {{\n$_[0]\n}}\n\n";
-
-
- my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new;
- $parser->hide_line_numbers(1);
-
- my $out = '';
- $parser->output_string( \$out );
- DEBUG and print " _out to ", \$out, "\n";
-
- $mutor->($parser) if $mutor;
-
- $parser->parse_string_document( $_[0] );
- # use Data::Dumper; print Dumper($parser), "\n";
- return $out;
-}
-
-
-sub _duo {
- # For use in testing: Class->_duo($source1, $source2)
- # returns the parse trees of $source1 and $source2.
- # Good in things like: &ok( Class->duo(... , ...) );
-
- my $class = shift(@_);
-
- Carp::croak "But $class->_duo is useful only in list context!"
- unless wantarray;
-
- my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
-
- Carp::croak "But $class->_duo takes two parameters, not: @_"
- unless @_ == 2;
-
- my(@out);
-
- while( @_ ) {
- my $parser = $class->new;
-
- push @out, '';
- $parser->output_string( \( $out[-1] ) );
-
- DEBUG and print " _duo out to ", $parser->output_string(),
- " = $parser->{'output_string'}\n";
-
- $parser->hide_line_numbers(1);
- $mutor->($parser) if $mutor;
- $parser->parse_string_document( shift( @_ ) );
- # use Data::Dumper; print Dumper($parser), "\n";
- }
-
- return @out;
-}
-
-
-
-#-----------------------------------------------------------------------------
-1;
-__END__
-
-TODO:
-A start_formatting_code and end_formatting_code methods, which in the
-base class call start_L, end_L, start_C, end_C, etc., if they are
-defined.
-
-have the POD FORMATTING ERRORS section note the localtime, and the
-version of Pod::Simple.
-
-option to delete all E<shy>s?
-option to scream if under-0x20 literals are found in the input, or
-under-E<32> E codes are found in the tree. And ditto \x7f-\x9f
-
-Option to turn highbit characters into their compromised form? (applies
-to E parsing too)
-
-TODO: BOM/encoding things.
-
-TODO: ascii-compat things in the XML classes?
-
Deleted: trunk/contrib/perl/lib/Pod/Simple.pod
===================================================================
--- trunk/contrib/perl/lib/Pod/Simple.pod 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Simple.pod 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,226 +0,0 @@
-
-=head1 NAME
-
-Pod::Simple - framework for parsing Pod
-
-=head1 SYNOPSIS
-
- TODO
-
-=head1 DESCRIPTION
-
-Pod::Simple is a Perl library for parsing text in the Pod ("plain old
-documentation") markup language that is typically used for writing
-documentation for Perl and for Perl modules. The Pod format is explained
-in the L<perlpod|perlpod> man page; the most common formatter is called
-"perldoc".
-
-Pod formatters can use Pod::Simple to parse Pod documents into produce
-renderings of them in plain ASCII, in HTML, or in any number of other
-formats. Typically, such formatters will be subclasses of Pod::Simple,
-and so they will inherit its methods, like C<parse_file>.
-
-If you're reading this document just because you have a Pod-processing
-subclass that you want to use, this document (plus the documentation for
-the subclass) is probably all you'll need to read.
-
-If you're reading this document because you want to write a formatter
-subclass, continue reading this document, and then read
-L<Pod::Simple::Subclassing>, and then possibly even read L<perlpodspec>
-(some of which is for parser-writers, but much of which is notes to
-formatter-writers).
-
-
-=head1 MAIN METHODS
-
-
-
-=over
-
-=item C<< $parser = I<SomeClass>->new(); >>
-
-This returns a new parser object, where I<C<SomeClass>> is a subclass
-of Pod::Simple.
-
-=item C<< $parser->output_fh( *OUT ); >>
-
-This sets the filehandle that C<$parser>'s output will be written to.
-You can pass C<*STDOUT>, otherwise you should probably do something
-like this:
-
- my $outfile = "output.txt";
- open TXTOUT, ">$outfile" or die "Can't write to $outfile: $!";
- $parser->output_fh(*TXTOUT);
-
-...before you call one of the C<< $parser->parse_I<whatever> >> methods.
-
-=item C<< $parser->output_string( \$somestring ); >>
-
-This sets the string that C<$parser>'s output will be sent to,
-instead of any filehandle.
-
-
-=item C<< $parser->parse_file( I<$some_filename> ); >>
-
-=item C<< $parser->parse_file( *INPUT_FH ); >>
-
-This reads the Pod content of the file (or filehandle) that you specify,
-and processes it with that C<$parser> object, according to however
-C<$parser>'s class works, and according to whatever parser options you
-have set up for this C<$parser> object.
-
-=item C<< $parser->parse_string_document( I<$all_content> ); >>
-
-This works just like C<parse_file> except that it reads the Pod
-content not from a file, but from a string that you have already
-in memory.
-
-=item C<< $parser->parse_lines( I<... at lines...>, undef ); >>
-
-This processes the lines in C<@lines> (where each list item must be a
-defined value, and must contain exactly one line of content -- so no
-items like C<"foo\nbar"> are allowed). The final C<undef> is used to
-indicate the end of document being parsed.
-
-The other C<parser_I<whatever>> methods are meant to be called only once
-per C<$parser> object; but C<parse_lines> can be called as many times per
-C<$parser> object as you want, as long as the last call (and only
-the last call) ends with an C<undef> value.
-
-
-=item C<< $parser->content_seen >>
-
-This returns true only if there has been any real content seen
-for this document.
-
-
-=item C<< I<SomeClass>->filter( I<$filename> ); >>
-
-=item C<< I<SomeClass>->filter( I<*INPUT_FH> ); >>
-
-=item C<< I<SomeClass>->filter( I<\$document_content> ); >>
-
-This is a shortcut method for creating a new parser object, setting the
-output handle to STDOUT, and then processing the specified file (or
-filehandle, or in-memory document). This is handy for one-liners like
-this:
-
- perl -MPod::Simple::Text -e "Pod::Simple::Text->filter('thingy.pod')"
-
-=back
-
-
-
-=head1 SECONDARY METHODS
-
-Some of these methods might be of interest to general users, as
-well as of interest to formatter-writers.
-
-Note that the general pattern here is that the accessor-methods
-read the attribute's value with C<< $value = $parser->I<attribute> >>
-and set the attribute's value with
-C<< $parser->I<attribute>(I<newvalue>) >>. For each accessor, I typically
-only mention one syntax or another, based on which I think you are actually
-most likely to use.
-
-
-=over
-
-=item C<< $parser->no_whining( I<SOMEVALUE> ) >>
-
-If you set this attribute to a true value, you will suppress the
-parser's complaints about irregularities in the Pod coding. By default,
-this attribute's value is false, meaning that irregularities will
-be reported.
-
-Note that turning this attribute to true won't suppress one or two kinds
-of complaints about rarely occurring unrecoverable errors.
-
-
-=item C<< $parser->no_errata_section( I<SOMEVALUE> ) >>
-
-If you set this attribute to a true value, you will stop the parser from
-generating a "POD ERRORS" section at the end of the document. By
-default, this attribute's value is false, meaning that an errata section
-will be generated, as necessary.
-
-
-=item C<< $parser->complain_stderr( I<SOMEVALUE> ) >>
-
-If you set this attribute to a true value, it will send reports of
-parsing errors to STDERR. By default, this attribute's value is false,
-meaning that no output is sent to STDERR.
-
-Note that errors can be noted in an errata section, or sent to STDERR,
-or both, or neither. So don't think that turning on C<complain_stderr>
-will turn off C<no_errata_section> or vice versa -- these are
-independent attributes.
-
-
-=item C<< $parser->source_filename >>
-
-This returns the filename that this parser object was set to read from.
-
-
-=item C<< $parser->doc_has_started >>
-
-This returns true if C<$parser> has read from a source, and has seen
-Pod content in it.
-
-
-=item C<< $parser->source_dead >>
-
-This returns true if C<$parser> has read from a source, and come to the
-end of that source.
-
-=back
-
-
-=head1 CAVEATS
-
-This is just a beta release -- there are a good number of things still
-left to do. Notably, support for EBCDIC platforms is still half-done,
-an untested.
-
-
-=head1 SEE ALSO
-
-L<Pod::Simple::Subclassing>
-
-L<perlpod|perlpod>
-
-L<perlpodspec|perlpodspec>
-
-L<Pod::Escapes|Pod::Escapes>
-
-L<perldoc>
-
-
-=head1 COPYRIGHT AND DISCLAIMERS
-
-Copyright (c) 2002 Sean M. Burke. All rights reserved.
-
-This library is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-This program is distributed in the hope that it will be useful, but
-without any warranty; without even the implied warranty of
-merchantability or fitness for a particular purpose.
-
-=head1 AUTHOR
-
-Original author: Sean M. Burke C<sburke at cpan.org>
-
-Maintained by:
-
-=over
-
-=item * Allison Randal C<allison at perl.org>
-
-=item * Hans Dieter Pearcey C<hdp at cpan.org>
-
-=back
-
-=cut
-
-
Deleted: trunk/contrib/perl/lib/Pod/Text.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Text.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Text.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,861 +0,0 @@
-# Pod::Text -- Convert POD data to formatted ASCII text.
-#
-# Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008
-# Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-#
-# This module converts POD to formatted text. It replaces the old Pod::Text
-# module that came with versions of Perl prior to 5.6.0 and attempts to match
-# its output except for some specific circumstances where other decisions
-# seemed to produce better output. It uses Pod::Parser and is designed to be
-# very easy to subclass.
-#
-# Perl core hackers, please note that this module is also separately
-# maintained outside of the Perl core as part of the podlators. Please send
-# me any patches at the address above in addition to sending them to the
-# standard Perl mailing lists.
-
-##############################################################################
-# Modules and declarations
-##############################################################################
-
-package Pod::Text;
-
-require 5.004;
-
-use strict;
-use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
-
-use Carp qw(carp croak);
-use Exporter ();
-use Pod::Simple ();
-
- at ISA = qw(Pod::Simple Exporter);
-
-# We have to export pod2text for backward compatibility.
- at EXPORT = qw(pod2text);
-
-$VERSION = '3.13';
-
-##############################################################################
-# Initialization
-##############################################################################
-
-# This function handles code blocks. It's registered as a callback to
-# Pod::Simple and therefore doesn't work as a regular method call, but all it
-# does is call output_code with the line.
-sub handle_code {
- my ($line, $number, $parser) = @_;
- $parser->output_code ($line . "\n");
-}
-
-# Initialize the object and set various Pod::Simple options that we need.
-# Here, we also process any additional options passed to the constructor or
-# set up defaults if none were given. Note that all internal object keys are
-# in all-caps, reserving all lower-case object keys for Pod::Simple and user
-# arguments.
-sub new {
- my $class = shift;
- my $self = $class->SUPER::new;
-
- # Tell Pod::Simple to handle S<> by automatically inserting .
- $self->nbsp_for_S (1);
-
- # Tell Pod::Simple to keep whitespace whenever possible.
- if ($self->can ('preserve_whitespace')) {
- $self->preserve_whitespace (1);
- } else {
- $self->fullstop_space_harden (1);
- }
-
- # The =for and =begin targets that we accept.
- $self->accept_targets (qw/text TEXT/);
-
- # Ensure that contiguous blocks of code are merged together. Otherwise,
- # some of the guesswork heuristics don't work right.
- $self->merge_text (1);
-
- # Pod::Simple doesn't do anything useful with our arguments, but we want
- # to put them in our object as hash keys and values. This could cause
- # problems if we ever clash with Pod::Simple's own internal class
- # variables.
- my %opts = @_;
- my @opts = map { ("opt_$_", $opts{$_}) } keys %opts;
- %$self = (%$self, @opts);
-
- # Send errors to stderr if requested.
- if ($$self{opt_stderr}) {
- $self->no_errata_section (1);
- $self->complain_stderr (1);
- delete $$self{opt_stderr};
- }
-
- # Initialize various things from our parameters.
- $$self{opt_alt} = 0 unless defined $$self{opt_alt};
- $$self{opt_indent} = 4 unless defined $$self{opt_indent};
- $$self{opt_margin} = 0 unless defined $$self{opt_margin};
- $$self{opt_loose} = 0 unless defined $$self{opt_loose};
- $$self{opt_sentence} = 0 unless defined $$self{opt_sentence};
- $$self{opt_width} = 76 unless defined $$self{opt_width};
-
- # Figure out what quotes we'll be using for C<> text.
- $$self{opt_quotes} ||= '"';
- if ($$self{opt_quotes} eq 'none') {
- $$self{LQUOTE} = $$self{RQUOTE} = '';
- } elsif (length ($$self{opt_quotes}) == 1) {
- $$self{LQUOTE} = $$self{RQUOTE} = $$self{opt_quotes};
- } elsif ($$self{opt_quotes} =~ /^(.)(.)$/
- || $$self{opt_quotes} =~ /^(..)(..)$/) {
- $$self{LQUOTE} = $1;
- $$self{RQUOTE} = $2;
- } else {
- croak qq(Invalid quote specification "$$self{opt_quotes}");
- }
-
- # If requested, do something with the non-POD text.
- $self->code_handler (\&handle_code) if $$self{opt_code};
-
- # Return the created object.
- return $self;
-}
-
-##############################################################################
-# Core parsing
-##############################################################################
-
-# This is the glue that connects the code below with Pod::Simple itself. The
-# goal is to convert the event stream coming from the POD parser into method
-# calls to handlers once the complete content of a tag has been seen. Each
-# paragraph or POD command will have textual content associated with it, and
-# as soon as all of a paragraph or POD command has been seen, that content
-# will be passed in to the corresponding method for handling that type of
-# object. The exceptions are handlers for lists, which have opening tag
-# handlers and closing tag handlers that will be called right away.
-#
-# The internal hash key PENDING is used to store the contents of a tag until
-# all of it has been seen. It holds a stack of open tags, each one
-# represented by a tuple of the attributes hash for the tag and the contents
-# of the tag.
-
-# Add a block of text to the contents of the current node, formatting it
-# according to the current formatting instructions as we do.
-sub _handle_text {
- my ($self, $text) = @_;
- my $tag = $$self{PENDING}[-1];
- $$tag[1] .= $text;
-}
-
-# Given an element name, get the corresponding method name.
-sub method_for_element {
- my ($self, $element) = @_;
- $element =~ tr/-/_/;
- $element =~ tr/A-Z/a-z/;
- $element =~ tr/_a-z0-9//cd;
- return $element;
-}
-
-# Handle the start of a new element. If cmd_element is defined, assume that
-# we need to collect the entire tree for this element before passing it to the
-# element method, and create a new tree into which we'll collect blocks of
-# text and nested elements. Otherwise, if start_element is defined, call it.
-sub _handle_element_start {
- my ($self, $element, $attrs) = @_;
- my $method = $self->method_for_element ($element);
-
- # If we have a command handler, we need to accumulate the contents of the
- # tag before calling it.
- if ($self->can ("cmd_$method")) {
- push (@{ $$self{PENDING} }, [ $attrs, '' ]);
- } elsif ($self->can ("start_$method")) {
- my $method = 'start_' . $method;
- $self->$method ($attrs, '');
- }
-}
-
-# Handle the end of an element. If we had a cmd_ method for this element,
-# this is where we pass along the text that we've accumulated. Otherwise, if
-# we have an end_ method for the element, call that.
-sub _handle_element_end {
- my ($self, $element) = @_;
- my $method = $self->method_for_element ($element);
-
- # If we have a command handler, pull off the pending text and pass it to
- # the handler along with the saved attribute hash.
- if ($self->can ("cmd_$method")) {
- my $tag = pop @{ $$self{PENDING} };
- my $method = 'cmd_' . $method;
- my $text = $self->$method (@$tag);
- if (defined $text) {
- if (@{ $$self{PENDING} } > 1) {
- $$self{PENDING}[-1][1] .= $text;
- } else {
- $self->output ($text);
- }
- }
- } elsif ($self->can ("end_$method")) {
- my $method = 'end_' . $method;
- $self->$method ();
- }
-}
-
-##############################################################################
-# Output formatting
-##############################################################################
-
-# Wrap a line, indenting by the current left margin. We can't use Text::Wrap
-# because it plays games with tabs. We can't use formline, even though we'd
-# really like to, because it screws up non-printing characters. So we have to
-# do the wrapping ourselves.
-sub wrap {
- my $self = shift;
- local $_ = shift;
- my $output = '';
- my $spaces = ' ' x $$self{MARGIN};
- my $width = $$self{opt_width} - $$self{MARGIN};
- while (length > $width) {
- if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
- $output .= $spaces . $1 . "\n";
- } else {
- last;
- }
- }
- $output .= $spaces . $_;
- $output =~ s/\s+$/\n\n/;
- return $output;
-}
-
-# Reformat a paragraph of text for the current margin. Takes the text to
-# reformat and returns the formatted text.
-sub reformat {
- my $self = shift;
- local $_ = shift;
-
- # If we're trying to preserve two spaces after sentences, do some munging
- # to support that. Otherwise, smash all repeated whitespace.
- if ($$self{opt_sentence}) {
- s/ +$//mg;
- s/\.\n/. \n/g;
- s/\n/ /g;
- s/ +/ /g;
- } else {
- s/\s+/ /g;
- }
- return $self->wrap ($_);
-}
-
-# Output text to the output device. Replace non-breaking spaces with spaces
-# and soft hyphens with nothing, and then try to fix the output encoding if
-# necessary to match the input encoding unless UTF-8 output is forced. This
-# preserves the traditional pass-through behavior of Pod::Text.
-sub output {
- my ($self, $text) = @_;
- $text =~ tr/\240\255/ /d;
- unless ($$self{opt_utf8} || $$self{CHECKED_ENCODING}) {
- my $encoding = $$self{encoding} || '';
- if ($encoding) {
- eval { binmode ($$self{output_fh}, ":encoding($encoding)") };
- }
- $$self{CHECKED_ENCODING} = 1;
- }
- print { $$self{output_fh} } $text;
-}
-
-# Output a block of code (something that isn't part of the POD text). Called
-# by preprocess_paragraph only if we were given the code option. Exists here
-# only so that it can be overridden by subclasses.
-sub output_code { $_[0]->output ($_[1]) }
-
-##############################################################################
-# Document initialization
-##############################################################################
-
-# Set up various things that have to be initialized on a per-document basis.
-sub start_document {
- my $self = shift;
- my $margin = $$self{opt_indent} + $$self{opt_margin};
-
- # Initialize a few per-document variables.
- $$self{INDENTS} = []; # Stack of indentations.
- $$self{MARGIN} = $margin; # Default left margin.
- $$self{PENDING} = [[]]; # Pending output.
-
- # We have to redo encoding handling for each document.
- delete $$self{CHECKED_ENCODING};
-
- # If we were given the utf8 option, set an output encoding on our file
- # handle. Wrap in an eval in case we're using a version of Perl too old
- # to understand this.
- #
- # This is evil because it changes the global state of a file handle that
- # we may not own. However, we can't just blindly encode all output, since
- # there may be a pre-applied output encoding (such as from PERL_UNICODE)
- # and then we would double-encode. This seems to be the least bad
- # approach.
- if ($$self{opt_utf8}) {
- eval { binmode ($$self{output_fh}, ':encoding(UTF-8)') };
- }
-
- return '';
-}
-
-##############################################################################
-# Text blocks
-##############################################################################
-
-# This method is called whenever an =item command is complete (in other words,
-# we've seen its associated paragraph or know for certain that it doesn't have
-# one). It gets the paragraph associated with the item as an argument. If
-# that argument is empty, just output the item tag; if it contains a newline,
-# output the item tag followed by the newline. Otherwise, see if there's
-# enough room for us to output the item tag in the margin of the text or if we
-# have to put it on a separate line.
-sub item {
- my ($self, $text) = @_;
- my $tag = $$self{ITEM};
- unless (defined $tag) {
- carp "Item called without tag";
- return;
- }
- undef $$self{ITEM};
-
- # Calculate the indentation and margin. $fits is set to true if the tag
- # will fit into the margin of the paragraph given our indentation level.
- my $indent = $$self{INDENTS}[-1];
- $indent = $$self{opt_indent} unless defined $indent;
- my $margin = ' ' x $$self{opt_margin};
- my $fits = ($$self{MARGIN} - $indent >= length ($tag) + 1);
-
- # If the tag doesn't fit, or if we have no associated text, print out the
- # tag separately. Otherwise, put the tag in the margin of the paragraph.
- if (!$text || $text =~ /^\s+$/ || !$fits) {
- my $realindent = $$self{MARGIN};
- $$self{MARGIN} = $indent;
- my $output = $self->reformat ($tag);
- $output =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
- $output =~ s/\n*$/\n/;
-
- # If the text is just whitespace, we have an empty item paragraph;
- # this can result from =over/=item/=back without any intermixed
- # paragraphs. Insert some whitespace to keep the =item from merging
- # into the next paragraph.
- $output .= "\n" if $text && $text =~ /^\s*$/;
-
- $self->output ($output);
- $$self{MARGIN} = $realindent;
- $self->output ($self->reformat ($text)) if ($text && $text =~ /\S/);
- } else {
- my $space = ' ' x $indent;
- $space =~ s/^$margin /$margin:/ if $$self{opt_alt};
- $text = $self->reformat ($text);
- $text =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
- my $tagspace = ' ' x length $tag;
- $text =~ s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item";
- $self->output ($text);
- }
-}
-
-# Handle a basic block of text. The only tricky thing here is that if there
-# is a pending item tag, we need to format this as an item paragraph.
-sub cmd_para {
- my ($self, $attrs, $text) = @_;
- $text =~ s/\s+$/\n/;
- if (defined $$self{ITEM}) {
- $self->item ($text . "\n");
- } else {
- $self->output ($self->reformat ($text . "\n"));
- }
- return '';
-}
-
-# Handle a verbatim paragraph. Just print it out, but indent it according to
-# our margin.
-sub cmd_verbatim {
- my ($self, $attrs, $text) = @_;
- $self->item if defined $$self{ITEM};
- return if $text =~ /^\s*$/;
- $text =~ s/^(\n*)([ \t]*\S+)/$1 . (' ' x $$self{MARGIN}) . $2/gme;
- $text =~ s/\s*$/\n\n/;
- $self->output ($text);
- return '';
-}
-
-# Handle literal text (produced by =for and similar constructs). Just output
-# it with the minimum of changes.
-sub cmd_data {
- my ($self, $attrs, $text) = @_;
- $text =~ s/^\n+//;
- $text =~ s/\n{0,2}$/\n/;
- $self->output ($text);
- return '';
-}
-
-##############################################################################
-# Headings
-##############################################################################
-
-# The common code for handling all headers. Takes the header text, the
-# indentation, and the surrounding marker for the alt formatting method.
-sub heading {
- my ($self, $text, $indent, $marker) = @_;
- $self->item ("\n\n") if defined $$self{ITEM};
- $text =~ s/\s+$//;
- if ($$self{opt_alt}) {
- my $closemark = reverse (split (//, $marker));
- my $margin = ' ' x $$self{opt_margin};
- $self->output ("\n" . "$margin$marker $text $closemark" . "\n\n");
- } else {
- $text .= "\n" if $$self{opt_loose};
- my $margin = ' ' x ($$self{opt_margin} + $indent);
- $self->output ($margin . $text . "\n");
- }
- return '';
-}
-
-# First level heading.
-sub cmd_head1 {
- my ($self, $attrs, $text) = @_;
- $self->heading ($text, 0, '====');
-}
-
-# Second level heading.
-sub cmd_head2 {
- my ($self, $attrs, $text) = @_;
- $self->heading ($text, $$self{opt_indent} / 2, '== ');
-}
-
-# Third level heading.
-sub cmd_head3 {
- my ($self, $attrs, $text) = @_;
- $self->heading ($text, $$self{opt_indent} * 2 / 3 + 0.5, '= ');
-}
-
-# Fourth level heading.
-sub cmd_head4 {
- my ($self, $attrs, $text) = @_;
- $self->heading ($text, $$self{opt_indent} * 3 / 4 + 0.5, '- ');
-}
-
-##############################################################################
-# List handling
-##############################################################################
-
-# Handle the beginning of an =over block. Takes the type of the block as the
-# first argument, and then the attr hash. This is called by the handlers for
-# the four different types of lists (bullet, number, text, and block).
-sub over_common_start {
- my ($self, $attrs) = @_;
- $self->item ("\n\n") if defined $$self{ITEM};
-
- # Find the indentation level.
- my $indent = $$attrs{indent};
- unless (defined ($indent) && $indent =~ /^\s*[-+]?\d{1,4}\s*$/) {
- $indent = $$self{opt_indent};
- }
-
- # Add this to our stack of indents and increase our current margin.
- push (@{ $$self{INDENTS} }, $$self{MARGIN});
- $$self{MARGIN} += ($indent + 0);
- return '';
-}
-
-# End an =over block. Takes no options other than the class pointer. Output
-# any pending items and then pop one level of indentation.
-sub over_common_end {
- my ($self) = @_;
- $self->item ("\n\n") if defined $$self{ITEM};
- $$self{MARGIN} = pop @{ $$self{INDENTS} };
- return '';
-}
-
-# Dispatch the start and end calls as appropriate.
-sub start_over_bullet { $_[0]->over_common_start ($_[1]) }
-sub start_over_number { $_[0]->over_common_start ($_[1]) }
-sub start_over_text { $_[0]->over_common_start ($_[1]) }
-sub start_over_block { $_[0]->over_common_start ($_[1]) }
-sub end_over_bullet { $_[0]->over_common_end }
-sub end_over_number { $_[0]->over_common_end }
-sub end_over_text { $_[0]->over_common_end }
-sub end_over_block { $_[0]->over_common_end }
-
-# The common handler for all item commands. Takes the type of the item, the
-# attributes, and then the text of the item.
-sub item_common {
- my ($self, $type, $attrs, $text) = @_;
- $self->item if defined $$self{ITEM};
-
- # Clean up the text. We want to end up with two variables, one ($text)
- # which contains any body text after taking out the item portion, and
- # another ($item) which contains the actual item text. Note the use of
- # the internal Pod::Simple attribute here; that's a potential land mine.
- $text =~ s/\s+$//;
- my ($item, $index);
- if ($type eq 'bullet') {
- $item = '*';
- } elsif ($type eq 'number') {
- $item = $$attrs{'~orig_content'};
- } else {
- $item = $text;
- $item =~ s/\s*\n\s*/ /g;
- $text = '';
- }
- $$self{ITEM} = $item;
-
- # If body text for this item was included, go ahead and output that now.
- if ($text) {
- $text =~ s/\s*$/\n/;
- $self->item ($text);
- }
- return '';
-}
-
-# Dispatch the item commands to the appropriate place.
-sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
-sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
-sub cmd_item_text { my $self = shift; $self->item_common ('text', @_) }
-sub cmd_item_block { my $self = shift; $self->item_common ('block', @_) }
-
-##############################################################################
-# Formatting codes
-##############################################################################
-
-# The simple ones.
-sub cmd_b { return $_[0]{alt} ? "``$_[2]''" : $_[2] }
-sub cmd_f { return $_[0]{alt} ? "\"$_[2]\"" : $_[2] }
-sub cmd_i { return '*' . $_[2] . '*' }
-sub cmd_x { return '' }
-
-# Apply a whole bunch of messy heuristics to not quote things that don't
-# benefit from being quoted. These originally come from Barrie Slaymaker and
-# largely duplicate code in Pod::Man.
-sub cmd_c {
- my ($self, $attrs, $text) = @_;
-
- # A regex that matches the portion of a variable reference that's the
- # array or hash index, separated out just because we want to use it in
- # several places in the following regex.
- my $index = '(?: \[.*\] | \{.*\} )?';
-
- # Check for things that we don't want to quote, and if we find any of
- # them, return the string with just a font change and no quoting.
- $text =~ m{
- ^\s*
- (?:
- ( [\'\`\"] ) .* \1 # already quoted
- | \` .* \' # `quoted'
- | \$+ [\#^]? \S $index # special ($^Foo, $")
- | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func
- | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
- | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number
- | 0x [a-fA-F\d]+ # a hex constant
- )
- \s*\z
- }xo && return $text;
-
- # If we didn't return, go ahead and quote the text.
- return $$self{opt_alt}
- ? "``$text''"
- : "$$self{LQUOTE}$text$$self{RQUOTE}";
-}
-
-# Links reduce to the text that we're given, wrapped in angle brackets if it's
-# a URL.
-sub cmd_l {
- my ($self, $attrs, $text) = @_;
- return $$attrs{type} eq 'url' ? "<$text>" : $text;
-}
-
-##############################################################################
-# Backwards compatibility
-##############################################################################
-
-# The old Pod::Text module did everything in a pod2text() function. This
-# tries to provide the same interface for legacy applications.
-sub pod2text {
- my @args;
-
- # This is really ugly; I hate doing option parsing in the middle of a
- # module. But the old Pod::Text module supported passing flags to its
- # entry function, so handle -a and -<number>.
- while ($_[0] =~ /^-/) {
- my $flag = shift;
- if ($flag eq '-a') { push (@args, alt => 1) }
- elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
- else {
- unshift (@_, $flag);
- last;
- }
- }
-
- # Now that we know what arguments we're using, create the parser.
- my $parser = Pod::Text->new (@args);
-
- # If two arguments were given, the second argument is going to be a file
- # handle. That means we want to call parse_from_filehandle(), which means
- # we need to turn the first argument into a file handle. Magic open will
- # handle the <&STDIN case automagically.
- if (defined $_[1]) {
- my @fhs = @_;
- local *IN;
- unless (open (IN, $fhs[0])) {
- croak ("Can't open $fhs[0] for reading: $!\n");
- return;
- }
- $fhs[0] = \*IN;
- $parser->output_fh ($fhs[1]);
- my $retval = $parser->parse_file ($fhs[0]);
- my $fh = $parser->output_fh ();
- close $fh;
- return $retval;
- } else {
- $parser->output_fh (\*STDOUT);
- return $parser->parse_file (@_);
- }
-}
-
-# Reset the underlying Pod::Simple object between calls to parse_from_file so
-# that the same object can be reused to convert multiple pages.
-sub parse_from_file {
- my $self = shift;
- $self->reinit;
-
- # Fake the old cutting option to Pod::Parser. This fiddings with internal
- # Pod::Simple state and is quite ugly; we need a better approach.
- if (ref ($_[0]) eq 'HASH') {
- my $opts = shift @_;
- if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
- $$self{in_pod} = 1;
- $$self{last_was_blank} = 1;
- }
- }
-
- # Do the work.
- my $retval = $self->Pod::Simple::parse_from_file (@_);
-
- # Flush output, since Pod::Simple doesn't do this. Ideally we should also
- # close the file descriptor if we had to open one, but we can't easily
- # figure this out.
- my $fh = $self->output_fh ();
- my $oldfh = select $fh;
- my $oldflush = $|;
- $| = 1;
- print $fh '';
- $| = $oldflush;
- select $oldfh;
- return $retval;
-}
-
-# Pod::Simple failed to provide this backward compatibility function, so
-# implement it ourselves. File handles are one of the inputs that
-# parse_from_file supports.
-sub parse_from_filehandle {
- my $self = shift;
- $self->parse_from_file (@_);
-}
-
-##############################################################################
-# Module return value and documentation
-##############################################################################
-
-1;
-__END__
-
-=head1 NAME
-
-Pod::Text - Convert POD data to formatted ASCII text
-
-=for stopwords
-alt stderr Allbery Sean Burke's Christiansen UTF-8 pre-Unicode utf8
-
-=head1 SYNOPSIS
-
- use Pod::Text;
- my $parser = Pod::Text->new (sentence => 0, width => 78);
-
- # Read POD from STDIN and write to STDOUT.
- $parser->parse_from_filehandle;
-
- # Read POD from file.pod and write to file.txt.
- $parser->parse_from_file ('file.pod', 'file.txt');
-
-=head1 DESCRIPTION
-
-Pod::Text is a module that can convert documentation in the POD format (the
-preferred language for documenting Perl) into formatted ASCII. It uses no
-special formatting controls or codes whatsoever, and its output is therefore
-suitable for nearly any device.
-
-As a derived class from Pod::Simple, Pod::Text supports the same methods and
-interfaces. See L<Pod::Simple> for all the details; briefly, one creates a
-new parser with C<< Pod::Text->new() >> and then normally calls parse_file().
-
-new() can take options, in the form of key/value pairs, that control the
-behavior of the parser. The currently recognized options are:
-
-=over 4
-
-=item alt
-
-If set to a true value, selects an alternate output format that, among other
-things, uses a different heading style and marks C<=item> entries with a
-colon in the left margin. Defaults to false.
-
-=item code
-
-If set to a true value, the non-POD parts of the input file will be included
-in the output. Useful for viewing code documented with POD blocks with the
-POD rendered and the code left intact.
-
-=item indent
-
-The number of spaces to indent regular text, and the default indentation for
-C<=over> blocks. Defaults to 4.
-
-=item loose
-
-If set to a true value, a blank line is printed after a C<=head1> heading.
-If set to false (the default), no blank line is printed after C<=head1>,
-although one is still printed after C<=head2>. This is the default because
-it's the expected formatting for manual pages; if you're formatting
-arbitrary text documents, setting this to true may result in more pleasing
-output.
-
-=item margin
-
-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 the I<indent> option. To set the right
-margin, see the I<width> option.
-
-=item quotes
-
-Sets the quote marks used to surround CE<lt>> text. If the value is a
-single character, it is used as both the left and right quote; if it is two
-characters, the first character is used as the left quote and the second as
-the right quoted; and if it is four characters, the first two are used as
-the left quote and the second two as the right quote.
-
-This may also be set to the special value C<none>, in which case no quote
-marks are added around CE<lt>> text.
-
-=item sentence
-
-If set to a true value, Pod::Text will assume that each sentence ends in two
-spaces, and will try to preserve that spacing. If set to false, all
-consecutive whitespace in non-verbatim paragraphs is compressed into a
-single space. Defaults to true.
-
-=item stderr
-
-Send error messages about invalid POD to standard error instead of
-appending a POD ERRORS section to the generated output.
-
-=item utf8
-
-By default, Pod::Text uses the same output encoding as the input encoding
-of the POD source (provided that Perl was built with PerlIO; otherwise, it
-doesn't encode its output). If this option is given, the output encoding
-is forced to UTF-8.
-
-Be aware that, when using this option, the input encoding of your POD
-source must be properly declared unless it is US-ASCII or Latin-1. POD
-input without an C<=encoding> command will be assumed to be in Latin-1,
-and if it's actually in UTF-8, the output will be double-encoded. See
-L<perlpod(1)> for more information on the C<=encoding> command.
-
-=item width
-
-The column at which to wrap text on the right-hand side. Defaults to 76.
-
-=back
-
-The standard Pod::Simple method parse_file() takes one argument, the file or
-file handle to read from, and writes output to standard output unless that
-has been changed with the output_fh() method. See L<Pod::Simple> for the
-specific details and for other alternative interfaces.
-
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item Bizarre space in item
-
-=item Item called without tag
-
-(W) Something has gone wrong in internal C<=item> processing. These
-messages indicate a bug in Pod::Text; you should never see them.
-
-=item Can't open %s for reading: %s
-
-(F) Pod::Text was invoked via the compatibility mode pod2text() interface
-and the input file it was given could not be opened.
-
-=item Invalid quote specification "%s"
-
-(F) The quote specification given (the quotes option to the constructor) was
-invalid. A quote specification must be one, two, or four characters long.
-
-=back
-
-=head1 BUGS
-
-Encoding handling assumes that PerlIO is available and does not work
-properly if it isn't. The C<utf8> option is therefore not supported
-unless Perl is built with PerlIO support.
-
-=head1 CAVEATS
-
-If Pod::Text is given the C<utf8> option, the encoding of its output file
-handle will be forced to UTF-8 if possible, overriding any existing
-encoding. This will be done even if the file handle is not created by
-Pod::Text and was passed in from outside. This maintains consistency
-regardless of PERL_UNICODE and other settings.
-
-If the C<utf8> option is not given, the encoding of its output file handle
-will be forced to the detected encoding of the input POD, which preserves
-whatever the input text is. This ensures backward compatibility with
-earlier, pre-Unicode versions of this module, without large numbers of
-Perl warnings.
-
-This is not ideal, but it seems to be the best compromise. If it doesn't
-work for you, please let me know the details of how it broke.
-
-=head1 NOTES
-
-This is a replacement for an earlier Pod::Text module written by Tom
-Christiansen. It has a revamped interface, since it now uses Pod::Simple,
-but an interface roughly compatible with the old Pod::Text::pod2text()
-function is still available. Please change to the new calling convention,
-though.
-
-The original Pod::Text contained code to do formatting via termcap
-sequences, although it wasn't turned on by default and it was problematic to
-get it to work at all. This rewrite doesn't even try to do that, but a
-subclass of it does. Look for L<Pod::Text::Termcap>.
-
-=head1 SEE ALSO
-
-L<Pod::Simple>, L<Pod::Text::Termcap>, L<perlpod(1)>, L<pod2text(1)>
-
-The current version of this module is always available from its web site at
-L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the
-Perl core distribution as of 5.6.0.
-
-=head1 AUTHOR
-
-Russ Allbery <rra at stanford.edu>, based I<very> heavily on the original
-Pod::Text by Tom Christiansen <tchrist at mox.perl.com> and its conversion to
-Pod::Parser by Brad Appleton <bradapp at enteract.com>. Sean Burke's initial
-conversion of Pod::Man to use Pod::Simple provided much-needed guidance on
-how to use Pod::Simple.
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008 Russ Allbery
-<rra at stanford.edu>.
-
-This program is free software; you may redistribute it and/or modify it
-under the same terms as Perl itself.
-
-=cut
Deleted: trunk/contrib/perl/lib/Pod/Usage.pm
===================================================================
--- trunk/contrib/perl/lib/Pod/Usage.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/Usage.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,730 +0,0 @@
-#############################################################################
-# Pod/Usage.pm -- print usage messages for the running script.
-#
-# 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.
-#############################################################################
-
-package Pod::Usage;
-use strict;
-
-use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '1.36'; ## Current version of this package
-require 5.005; ## requires this Perl version or later
-
-=head1 NAME
-
-Pod::Usage, pod2usage() - print a usage message from embedded pod documentation
-
-=head1 SYNOPSIS
-
- use Pod::Usage
-
- my $message_text = "This text precedes the usage message.";
- my $exit_status = 2; ## The exit status to use
- my $verbose_level = 0; ## The verbose level to use
- my $filehandle = \*STDERR; ## The filehandle to write to
-
- pod2usage($message_text);
-
- pod2usage($exit_status);
-
- pod2usage( { -message => $message_text ,
- -exitval => $exit_status ,
- -verbose => $verbose_level,
- -output => $filehandle } );
-
- pod2usage( -msg => $message_text ,
- -exitval => $exit_status ,
- -verbose => $verbose_level,
- -output => $filehandle );
-
- pod2usage( -verbose => 2,
- -noperldoc => 1 )
-
-=head1 ARGUMENTS
-
-B<pod2usage> should be given either a single argument, or a list of
-arguments corresponding to an associative array (a "hash"). When a single
-argument is given, it should correspond to exactly one of the following:
-
-=over 4
-
-=item *
-
-A string containing the text of a message to print I<before> printing
-the usage message
-
-=item *
-
-A numeric value corresponding to the desired exit status
-
-=item *
-
-A reference to a hash
-
-=back
-
-If more than one argument is given then the entire argument list is
-assumed to be a hash. If a hash is supplied (either as a reference or
-as a list) it should contain one or more elements with the following
-keys:
-
-=over 4
-
-=item C<-message>
-
-=item C<-msg>
-
-The text of a message to print immediately prior to printing the
-program's usage message.
-
-=item C<-exitval>
-
-The desired exit status to pass to the B<exit()> function.
-This should be an integer, or else the string "NOEXIT" to
-indicate that control should simply be returned without
-terminating the invoking process.
-
-=item C<-verbose>
-
-The desired level of "verboseness" to use when printing the usage
-message. If the corresponding value is 0, then only the "SYNOPSIS"
-section of the pod documentation is printed. If the corresponding value
-is 1, then the "SYNOPSIS" section, along with any section entitled
-"OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the
-corresponding value is 2 or more then the entire manpage is printed.
-
-The special verbosity level 99 requires to also specify the -sections
-parameter; then these sections are extracted (see L<Pod::Select>)
-and printed.
-
-=item C<-sections>
-
-A string representing a selection list for sections to be printed
-when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">.
-
-Alternatively, an array reference of section specifications can be used:
-
- pod2usage(-verbose => 99,
- -sections => [ qw(fred fred/subsection) ] );
-
-=item C<-output>
-
-A reference to a filehandle, or the pathname of a file to which the
-usage message should be written. The default is C<\*STDERR> unless the
-exit value is less than 2 (in which case the default is C<\*STDOUT>).
-
-=item C<-input>
-
-A reference to a filehandle, or the pathname of a file from which the
-invoking script's pod documentation should be read. It defaults to the
-file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>).
-
-If you are calling B<pod2usage()> from a module and want to display
-that module's POD, you can use this:
-
- use Pod::Find qw(pod_where);
- pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) );
-
-=item C<-pathlist>
-
-A list of directory paths. If the input file does not exist, then it
-will be searched for in the given directory list (in the order the
-directories appear in the list). It defaults to the list of directories
-implied by C<$ENV{PATH}>. The list may be specified either by a reference
-to an array, or by a string of directory paths which use the same path
-separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for
-MSWin32 and DOS).
-
-=item C<-noperldoc>
-
-By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is
-specified. This does not work well e.g. if the script was packed
-with L<PAR>. The -noperldoc option suppresses the external call to
-L<perldoc> and uses the simple text formatter (L<Pod::Text>) to
-output the POD.
-
-=back
-
-=head1 DESCRIPTION
-
-B<pod2usage> will print a usage message for the invoking script (using
-its embedded pod documentation) and then exit the script with the
-desired exit status. The usage message printed may have any one of three
-levels of "verboseness": If the verbose level is 0, then only a synopsis
-is printed. If the verbose level is 1, then the synopsis is printed
-along with a description (if present) of the command line options and
-arguments. If the verbose level is 2, then the entire manual page is
-printed.
-
-Unless they are explicitly specified, the default values for the exit
-status, verbose level, and output stream to use are determined as
-follows:
-
-=over 4
-
-=item *
-
-If neither the exit status nor the verbose level is specified, then the
-default is to use an exit status of 2 with a verbose level of 0.
-
-=item *
-
-If an exit status I<is> specified but the verbose level is I<not>, then the
-verbose level will default to 1 if the exit status is less than 2 and
-will default to 0 otherwise.
-
-=item *
-
-If an exit status is I<not> specified but verbose level I<is> given, then
-the exit status will default to 2 if the verbose level is 0 and will
-default to 1 otherwise.
-
-=item *
-
-If the exit status used is less than 2, then output is printed on
-C<STDOUT>. Otherwise output is printed on C<STDERR>.
-
-=back
-
-Although the above may seem a bit confusing at first, it generally does
-"the right thing" in most situations. This determination of the default
-values to use is based upon the following typical Unix conventions:
-
-=over 4
-
-=item *
-
-An exit status of 0 implies "success". For example, B<diff(1)> exits
-with a status of 0 if the two files have the same contents.
-
-=item *
-
-An exit status of 1 implies possibly abnormal, but non-defective, program
-termination. For example, B<grep(1)> exits with a status of 1 if
-it did I<not> find a matching line for the given regular expression.
-
-=item *
-
-An exit status of 2 or more implies a fatal error. For example, B<ls(1)>
-exits with a status of 2 if you specify an illegal (unknown) option on
-the command line.
-
-=item *
-
-Usage messages issued as a result of bad command-line syntax should go
-to C<STDERR>. However, usage messages issued due to an explicit request
-to print usage (like specifying B<-help> on the command line) should go
-to C<STDOUT>, just in case the user wants to pipe the output to a pager
-(such as B<more(1)>).
-
-=item *
-
-If program usage has been explicitly requested by the user, it is often
-desirable to exit with a status of 1 (as opposed to 0) after issuing
-the user-requested usage message. It is also desirable to give a
-more verbose description of program usage in this case.
-
-=back
-
-B<pod2usage> doesn't force the above conventions upon you, but it will
-use them by default if you don't expressly tell it to do otherwise. The
-ability of B<pod2usage()> to accept a single number or a string makes it
-convenient to use as an innocent looking error message handling function:
-
- use Pod::Usage;
- use Getopt::Long;
-
- ## Parse options
- GetOptions("help", "man", "flag1") || pod2usage(2);
- pod2usage(1) if ($opt_help);
- pod2usage(-verbose => 2) if ($opt_man);
-
- ## Check for too many filenames
- pod2usage("$0: Too many files given.\n") if (@ARGV > 1);
-
-Some user's however may feel that the above "economy of expression" is
-not particularly readable nor consistent and may instead choose to do
-something more like the following:
-
- use Pod::Usage;
- use Getopt::Long;
-
- ## Parse options
- GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0);
- pod2usage(-verbose => 1) if ($opt_help);
- pod2usage(-verbose => 2) if ($opt_man);
-
- ## Check for too many filenames
- pod2usage(-verbose => 2, -message => "$0: Too many files given.\n")
- if (@ARGV > 1);
-
-As with all things in Perl, I<there's more than one way to do it>, and
-B<pod2usage()> adheres to this philosophy. If you are interested in
-seeing a number of different ways to invoke B<pod2usage> (although by no
-means exhaustive), please refer to L<"EXAMPLES">.
-
-=head1 EXAMPLES
-
-Each of the following invocations of C<pod2usage()> will print just the
-"SYNOPSIS" section to C<STDERR> and will exit with a status of 2:
-
- pod2usage();
-
- pod2usage(2);
-
- pod2usage(-verbose => 0);
-
- pod2usage(-exitval => 2);
-
- pod2usage({-exitval => 2, -output => \*STDERR});
-
- pod2usage({-verbose => 0, -output => \*STDERR});
-
- pod2usage(-exitval => 2, -verbose => 0);
-
- pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR);
-
-Each of the following invocations of C<pod2usage()> will print a message
-of "Syntax error." (followed by a newline) to C<STDERR>, immediately
-followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and
-will exit with a status of 2:
-
- pod2usage("Syntax error.");
-
- pod2usage(-message => "Syntax error.", -verbose => 0);
-
- pod2usage(-msg => "Syntax error.", -exitval => 2);
-
- pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR});
-
- pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR});
-
- pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0);
-
- pod2usage(-message => "Syntax error.",
- -exitval => 2,
- -verbose => 0,
- -output => \*STDERR);
-
-Each of the following invocations of C<pod2usage()> will print the
-"SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to
-C<STDOUT> and will exit with a status of 1:
-
- pod2usage(1);
-
- pod2usage(-verbose => 1);
-
- pod2usage(-exitval => 1);
-
- pod2usage({-exitval => 1, -output => \*STDOUT});
-
- pod2usage({-verbose => 1, -output => \*STDOUT});
-
- pod2usage(-exitval => 1, -verbose => 1);
-
- pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT});
-
-Each of the following invocations of C<pod2usage()> will print the
-entire manual page to C<STDOUT> and will exit with a status of 1:
-
- pod2usage(-verbose => 2);
-
- pod2usage({-verbose => 2, -output => \*STDOUT});
-
- pod2usage(-exitval => 1, -verbose => 2);
-
- pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT});
-
-=head2 Recommended Use
-
-Most scripts should print some type of usage message to C<STDERR> when a
-command line syntax error is detected. They should also provide an
-option (usually C<-H> or C<-help>) to print a (possibly more verbose)
-usage message to C<STDOUT>. Some scripts may even wish to go so far as to
-provide a means of printing their complete documentation to C<STDOUT>
-(perhaps by allowing a C<-man> option). The following complete example
-uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these
-things:
-
- use Getopt::Long;
- use Pod::Usage;
-
- my $man = 0;
- my $help = 0;
- ## Parse options and print usage if there is a syntax error,
- ## or if usage was explicitly requested.
- GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
- pod2usage(1) if $help;
- pod2usage(-verbose => 2) if $man;
-
- ## If no arguments were given, then allow STDIN to be used only
- ## if it's not connected to a terminal (otherwise print usage)
- pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN));
- __END__
-
- =head1 NAME
-
- sample - Using GetOpt::Long and Pod::Usage
-
- =head1 SYNOPSIS
-
- sample [options] [file ...]
-
- Options:
- -help brief help message
- -man full documentation
-
- =head1 OPTIONS
-
- =over 8
-
- =item B<-help>
-
- Print a brief help message and exits.
-
- =item B<-man>
-
- Prints the manual page and exits.
-
- =back
-
- =head1 DESCRIPTION
-
- B<This program> will read the given input file(s) and do something
- useful with the contents thereof.
-
- =cut
-
-=head1 CAVEATS
-
-By default, B<pod2usage()> will use C<$0> as the path to the pod input
-file. Unfortunately, not all systems on which Perl runs will set C<$0>
-properly (although if C<$0> isn't found, B<pod2usage()> will search
-C<$ENV{PATH}> or else the list specified by the C<-pathlist> option).
-If this is the case for your system, you may need to explicitly specify
-the path to the pod docs for the invoking script using something
-similar to the following:
-
- pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs");
-
-In the pathological case that a script is called via a relative path
-I<and> the script itself changes the current working directory
-(see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will
-fail even on robust platforms. Don't do that.
-
-=head1 AUTHOR
-
-Please report bugs using L<http://rt.cpan.org>.
-
-Marek Rouchal E<lt>marekr at cpan.orgE<gt>
-
-Brad Appleton E<lt>bradapp at enteract.comE<gt>
-
-Based on code for B<Pod::Text::pod2text()> written by
-Tom Christiansen E<lt>tchrist at mox.perl.comE<gt>
-
-=head1 ACKNOWLEDGMENTS
-
-Steven McDougall E<lt>swmcd at world.std.comE<gt> for his help and patience
-with re-writing this manpage.
-
-=head1 SEE ALSO
-
-L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find>
-
-=cut
-
-#############################################################################
-
-#use diagnostics;
-use Carp;
-use Config;
-use Exporter;
-use File::Spec;
-
- at EXPORT = qw(&pod2usage);
-BEGIN {
- if ( $] >= 5.005_58 ) {
- require Pod::Text;
- @ISA = qw( Pod::Text );
- }
- else {
- require Pod::PlainText;
- @ISA = qw( Pod::PlainText );
- }
-}
-
-require Pod::Select;
-
-##---------------------------------------------------------------------------
-
-##---------------------------------
-## Function definitions begin here
-##---------------------------------
-
-sub pod2usage {
- local($_) = shift;
- my %opts;
- ## Collect arguments
- if (@_ > 0) {
- ## Too many arguments - assume that this is a hash and
- ## the user forgot to pass a reference to it.
- %opts = ($_, @_);
- }
- elsif (!defined $_) {
- $_ = '';
- }
- elsif (ref $_) {
- ## User passed a ref to a hash
- %opts = %{$_} if (ref($_) eq 'HASH');
- }
- elsif (/^[-+]?\d+$/) {
- ## User passed in the exit value to use
- $opts{'-exitval'} = $_;
- }
- else {
- ## User passed in a message to print before issuing usage.
- $_ and $opts{'-message'} = $_;
- }
-
- ## Need this for backward compatibility since we formerly used
- ## options that were all uppercase words rather than ones that
- ## looked like Unix command-line options.
- ## to be uppercase keywords)
- %opts = map {
- my ($key, $val) = ($_, $opts{$_});
- $key =~ s/^(?=\w)/-/;
- $key =~ /^-msg/i and $key = '-message';
- $key =~ /^-exit/i and $key = '-exitval';
- lc($key) => $val;
- } (keys %opts);
-
- ## Now determine default -exitval and -verbose values to use
- if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) {
- $opts{'-exitval'} = 2;
- $opts{'-verbose'} = 0;
- }
- elsif (! defined $opts{'-exitval'}) {
- $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2;
- }
- elsif (! defined $opts{'-verbose'}) {
- $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' ||
- $opts{'-exitval'} < 2);
- }
-
- ## Default the output file
- $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' ||
- $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR
- unless (defined $opts{'-output'});
- ## Default the input file
- $opts{'-input'} = $0 unless (defined $opts{'-input'});
-
- ## Look up input file in path if it doesnt exist.
- unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) {
- my $basename = $opts{'-input'};
- my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';'
- : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ':');
- my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB};
-
- my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec);
- for my $dirname (@paths) {
- $_ = File::Spec->catfile($dirname, $basename) if length;
- last if (-e $_) && ($opts{'-input'} = $_);
- }
- }
-
- ## Now create a pod reader and constrain it to the desired sections.
- my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts);
- if ($opts{'-verbose'} == 0) {
- $parser->select('(?:SYNOPSIS|USAGE)\s*');
- }
- elsif ($opts{'-verbose'} == 1) {
- my $opt_re = '(?i)' .
- '(?:OPTIONS|ARGUMENTS)' .
- '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
- $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" );
- }
- elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) {
- $parser->select('.*');
- }
- elsif ($opts{'-verbose'} == 99) {
- my $sections = $opts{'-sections'};
- $parser->select( (ref $sections) ? @$sections : $sections );
- $opts{'-verbose'} = 1;
- }
-
- ## Now translate the pod document and then exit with the desired status
- if ( !$opts{'-noperldoc'}
- and $opts{'-verbose'} >= 2
- and !ref($opts{'-input'})
- and $opts{'-output'} == \*STDOUT )
- {
- ## spit out the entire PODs. Might as well invoke perldoc
- my $progpath = File::Spec->catfile($Config{scriptdir}, 'perldoc');
- print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'});
- if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) {
- # the perldocs back to 5.005 should all have -F
- # without -F there are warnings in -T scripts
- system($progpath, '-F', $1);
- if($?) {
- # RT16091: fall back to more if perldoc failed
- system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1);
- }
- } else {
- croak "Unspecified input file or insecure argument.\n";
- }
- }
- else {
- $parser->parse_from_file($opts{'-input'}, $opts{'-output'});
- }
-
- exit($opts{'-exitval'}) unless (lc($opts{'-exitval'}) eq 'noexit');
-}
-
-##---------------------------------------------------------------------------
-
-##-------------------------------
-## Method definitions begin here
-##-------------------------------
-
-sub new {
- my $this = shift;
- my $class = ref($this) || $this;
- my %params = @_;
- my $self = {%params};
- bless $self, $class;
- if ($self->can('initialize')) {
- $self->initialize();
- } else {
- $self = $self->SUPER::new();
- %$self = (%$self, %params);
- }
- return $self;
-}
-
-sub select {
- my ($self, @sections) = @_;
- if ($ISA[0]->can('select')) {
- $self->SUPER::select(@sections);
- } else {
- # we're using Pod::Simple - need to mimic the behavior of Pod::Select
- my $add = ($sections[0] eq '+') ? shift(@sections) : '';
- ## Reset the set of sections to use
- unless (@sections) {
- delete $self->{USAGE_SELECT} unless ($add);
- return;
- }
- $self->{USAGE_SELECT} = []
- unless ($add && $self->{USAGE_SELECT});
- my $sref = $self->{USAGE_SELECT};
- ## Compile each spec
- for my $spec (@sections) {
- my $cs = Pod::Select::_compile_section_spec($spec);
- if ( defined $cs ) {
- ## Store them in our sections array
- push(@$sref, $cs);
- } else {
- carp qq{Ignoring section spec "$spec"!\n};
- }
- }
- }
-}
-
-# Override Pod::Text->seq_i to return just "arg", not "*arg*".
-sub seq_i { return $_[1] }
-
-# This overrides the Pod::Text method to do something very akin to what
-# Pod::Select did as well as the work done below by preprocess_paragraph.
-# Note that the below is very, very specific to Pod::Text.
-sub _handle_element_end {
- my ($self, $element) = @_;
- if ($element eq 'head1') {
- $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ];
- if ($self->{USAGE_OPTIONS}->{-verbose} < 2) {
- $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/;
- }
- } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0
- my $idx = $1 - 1;
- $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS});
- $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1];
- }
- if ($element =~ /^head\d+$/) {
- $$self{USAGE_SKIPPING} = 1;
- if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) {
- $$self{USAGE_SKIPPING} = 0;
- } else {
- my @headings = @{$$self{USAGE_HEADINGS}};
- for my $section_spec ( @{$$self{USAGE_SELECT}} ) {
- my $match = 1;
- for (my $i = 0; $i < $Pod::Select::MAX_HEADING_LEVEL; ++$i) {
- $headings[$i] = '' unless defined $headings[$i];
- my $regex = $section_spec->[$i];
- my $negated = ($regex =~ s/^\!//);
- $match &= ($negated ? ($headings[$i] !~ /${regex}/)
- : ($headings[$i] =~ /${regex}/));
- last unless ($match);
- } # end heading levels
- if ($match) {
- $$self{USAGE_SKIPPING} = 0;
- last;
- }
- } # end sections
- }
-
- # Try to do some lowercasing instead of all-caps in headings, and use
- # a colon to end all headings.
- if($self->{USAGE_OPTIONS}->{-verbose} < 2) {
- local $_ = $$self{PENDING}[-1][1];
- s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
- s/\s*$/:/ unless (/:\s*$/);
- $_ .= "\n";
- $$self{PENDING}[-1][1] = $_;
- }
- }
- if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) {
- pop @{ $$self{PENDING} };
- } else {
- $self->SUPER::_handle_element_end($element);
- }
-}
-
-# required for Pod::Simple API
-sub start_document {
- my $self = shift;
- $self->SUPER::start_document();
- my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
- my $out_fh = $self->output_fh();
- print $out_fh "$msg\n";
-}
-
-# required for old Pod::Parser API
-sub begin_pod {
- my $self = shift;
- $self->SUPER::begin_pod(); ## Have to call superclass
- my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1;
- my $out_fh = $self->output_handle();
- print $out_fh "$msg\n";
-}
-
-sub preprocess_paragraph {
- my $self = shift;
- local $_ = shift;
- my $line = shift;
- ## See if this is a heading and we arent printing the entire manpage.
- if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) {
- ## Change the title of the SYNOPSIS section to USAGE
- s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/;
- ## Try to do some lowercasing instead of all-caps in headings
- s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
- ## Use a colon to end all headings
- s/\s*$/:/ unless (/:\s*$/);
- $_ .= "\n";
- }
- return $self->SUPER::preprocess_paragraph($_);
-}
-
-1; # keep require happy
Deleted: trunk/contrib/perl/lib/Pod/t/Functions.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/Functions.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/Functions.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,159 +0,0 @@
-#!perl
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
-use File::Basename;
-use File::Spec;
-
-use Test::More;
-plan tests => 9;
-
-
-use_ok( 'Pod::Functions' );
-
-# How do you test exported vars?
-my( $pkg_ref, $exp_ref ) = ( \%Pod::Functions::Kinds, \%Kinds );
-is( $pkg_ref, $exp_ref, '%Pod::Functions::Kinds exported' );
-
-( $pkg_ref, $exp_ref ) = ( \%Pod::Functions::Type, \%Type );
-is( $pkg_ref, $exp_ref, '%Pod::Functions::Type exported' );
-
-( $pkg_ref, $exp_ref ) = ( \%Pod::Functions::Flavor, \%Flavor );
-is( $pkg_ref, $exp_ref, '%Pod::Functions::Flavor exported' );
-
-( $pkg_ref, $exp_ref ) = ( \%Pod::Functions::Type_Description,
- \%Type_Description );
-is( $pkg_ref, $exp_ref, '%Pod::Functions::Type_Description exported' );
-
-( $pkg_ref, $exp_ref ) = ( \@Pod::Functions::Type_Order, \@Type_Order );
-is( $pkg_ref, $exp_ref, '@Pod::Functions::Type_Order exported' );
-
-# Check @Type_Order
-my @catagories = qw(
- String Regexp Math ARRAY LIST HASH I/O
- Binary File Flow Namespace Misc Process Modules
- Objects Socket SysV User Network Time
-);
-
-ok( eq_array( \@Type_Order, \@catagories ),
- '@Type_Order' );
-
-my @cat_keys = grep exists $Type_Description{ $_ } => @Type_Order;
-
-ok( eq_array( \@cat_keys, \@catagories ),
- 'keys() %Type_Description' );
-
-my( undef, $path ) = fileparse( $0 );
-my $pod_functions = File::Spec->catfile(
- $path, File::Spec->updir, 'Functions.pm' );
-
-SKIP: {
- my $test_out = do { local $/; <DATA> };
-
- skip( "Can't fork '$^X': $!", 1)
- unless open my $fh, qq[$^X "-I../lib" $pod_functions |];
- my $fake_out = do { local $/; <$fh> };
- skip( "Pipe error: $!", 1)
- unless close $fh;
-
- is( $fake_out, $test_out, 'run as plain program' );
-}
-
-=head1 NAME
-
-Functions.t - Test Pod::Functions
-
-=head1 AUTHOR
-
-20011229 Abe Timmerman <abe at ztreet.demon.nl>
-
-=cut
-
-__DATA__
-
-Functions for SCALARs or strings:
- chomp, chop, chr, crypt, hex, index, lc, lcfirst, length,
- oct, ord, pack, q/STRING/, qq/STRING/, reverse, rindex,
- sprintf, substr, tr///, uc, ucfirst, y///
-
-Regular expressions and pattern matching:
- m//, pos, qr/STRING/, quotemeta, s///, split, study
-
-Numeric functions:
- abs, atan2, cos, exp, hex, int, log, oct, rand, sin, sqrt,
- srand
-
-Functions for real @ARRAYs:
- pop, push, shift, splice, unshift
-
-Functions for list data:
- grep, join, map, qw/STRING/, reverse, sort, unpack
-
-Functions for real %HASHes:
- delete, each, exists, keys, values
-
-Input and output functions:
- binmode, close, closedir, dbmclose, dbmopen, die, eof,
- fileno, flock, format, getc, print, printf, read, readdir,
- readline, rewinddir, seek, seekdir, select, syscall,
- sysread, sysseek, syswrite, tell, telldir, truncate, warn,
- write
-
-Functions for fixed length data or records:
- pack, read, syscall, sysread, sysseek, syswrite, unpack,
- vec
-
-Functions for filehandles, files, or directories:
- -X, chdir, chmod, chown, chroot, fcntl, glob, ioctl, link,
- lstat, mkdir, open, opendir, readlink, rename, rmdir,
- stat, symlink, sysopen, umask, unlink, utime
-
-Keywords related to control flow of your perl program:
- caller, continue, die, do, dump, eval, exit, goto, last,
- next, prototype, redo, return, sub, wantarray
-
-Keywords altering or affecting scoping of identifiers:
- caller, import, local, my, our, package, use
-
-Miscellaneous functions:
- defined, dump, eval, formline, local, my, our, prototype,
- reset, scalar, undef, wantarray
-
-Functions for processes and process groups:
- alarm, exec, fork, getpgrp, getppid, getpriority, kill,
- pipe, qx/STRING/, readpipe, setpgrp, setpriority, sleep,
- system, times, wait, waitpid
-
-Keywords related to perl modules:
- do, import, no, package, require, use
-
-Keywords related to classes and object-orientedness:
- bless, dbmclose, dbmopen, package, ref, tie, tied, untie,
- use
-
-Low-level socket functions:
- accept, bind, connect, getpeername, getsockname,
- getsockopt, listen, recv, send, setsockopt, shutdown,
- socket, socketpair
-
-System V interprocess communication functions:
- msgctl, msgget, msgrcv, msgsnd, semctl, semget, semop,
- shmctl, shmget, shmread, shmwrite
-
-Fetching user and group info:
- endgrent, endhostent, endnetent, endpwent, getgrent,
- getgrgid, getgrnam, getlogin, getpwent, getpwnam,
- getpwuid, setgrent, setpwent
-
-Fetching network info:
- endprotoent, endservent, gethostbyaddr, gethostbyname,
- gethostent, getnetbyaddr, getnetbyname, getnetent,
- getprotobyname, getprotobynumber, getprotoent,
- getservbyname, getservbyport, getservent, sethostent,
- setnetent, setprotoent, setservent
-
-Time-related functions:
- gmtime, localtime, time, times
Deleted: trunk/contrib/perl/lib/Pod/t/basic.cap
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.cap 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/basic.cap 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,268 +0,0 @@
-[1mNAME[m
- basic.pod - Test of various basic POD features in translators.
-
-[1mHEADINGS[m
- Try a few different levels of headings, with embedded formatting codes and
- other interesting bits.
-
-[1mThis "is" a "level 1" heading[m
- [1m``Level'' "2 [4mheading[m[m
- Level 3 [1mheading [4mwith "weird stuff "" (double quote)"[m[m
- Level "4 "heading"
- Now try again with [1mintermixed[m text.
-
-[1mThis "is" a "level 1" heading[m
- Text.
-
- [1m``Level'' 2 [4mheading[m[m
- Text.
-
- Level 3 [1mheading [4mwith "weird stuff"[m[m
- Text.
-
- Level "4 "heading"
- Text.
-
-[1mLINKS[m
- These are all taken from the Pod::Parser tests.
-
- Try out [4mLOTS[m of different ways of specifying references:
-
- Reference the "section" in manpage
-
- Reference the "section" in "manpage"
-
- Reference the "section" in manpage
-
- Now try it using the new "|" stuff ...
-
- Reference the thistext|
-
- Reference the thistext |
-
- Reference the thistext|
-
- Reference the thistext |
-
- Reference the thistext|
-
- Reference the thistext|
-
- And then throw in a few new ones of my own.
-
- foo
-
- foo
-
- "bar" in foo
-
- "baz boo" in foo
-
- "bar"
-
- "baz boo"
-
- "baz boo"
-
- "baz boo" in foo bar
-
- "boo var baz"
-
- "bar baz"
-
- "boo", "bar", and "baz"
-
- foobar
-
- Testing [4mitalics[m
-
- "[4mItalic[m text" in foo
-
- "Section "with" [4m[1mother[m markup[m" in foo|bar
-
- Nested <http://www.perl.org/>
-
-[1mOVER AND ITEMS[m
- Taken from Pod::Parser tests, this is a test to ensure that multiline
- =item paragraphs get indented appropriately.
-
- This is a test.
-
- There should be whitespace now before this line.
-
- Taken from Pod::Parser tests, this is a test to ensure the nested =item
- paragraphs get indented appropriately.
-
- 1 First section.
-
- a this is item a
-
- b this is item b
-
- 2 Second section.
-
- a this is item a
-
- b this is item b
-
- c
- d This is item c & d.
-
- Now some additional weirdness of our own. Make sure that multiple tags for
- one paragraph are properly compacted.
-
- "foo"
- [1mbar[m
- "baz"
- There shouldn't be any spaces between any of these item tags; this
- idiom is used in perlfunc.
-
- Some longer item text
- Just to make sure that we test paragraphs where the item text doesn't
- fit in the margin of the paragraph (and make sure that this paragraph
- fills a few lines).
-
- Let's also make it multiple paragraphs to be sure that works.
-
- Test use of =over without =item as a block "quote" or block paragraph.
-
- This should be indented four spaces but otherwise formatted the same
- as any other regular text paragraph. Make sure it's long enough to see
- the results of the formatting.....
-
- Now try the same thing nested, and make sure that the indentation is reset
- back properly.
-
- This paragraph should be doubly indented.
-
- This paragraph should only be singly indented.
-
- * This is an item in the middle of a block-quote, which should be
- allowed.
-
- * We're also testing tagless item commands.
-
- Should be back to the single level of indentation.
-
- Should be back to regular indentation.
-
- Now also check the transformation of * into real bullets for man pages.
-
- * An item. We're also testing using =over without a number, and making
- sure that item text wraps properly.
-
- * Another item.
-
- and now test the numbering of item blocks.
-
- 1. First item.
-
- 2. Second item.
-
-[1mFORMATTING CODES[m
- Another test taken from Pod::Parser.
-
- This is a test to see if I can do not only $self and "method()", but also
- "$self->method()" and "$self->{FIELDNAME}" and "$Foo <=> $Bar" without
- resorting to escape sequences. If I want to refer to the right-shift
- operator I can do something like "$x >> 3" or even "$y >> 5".
-
- Now for the grand finale of "$self->method()->{FIELDNAME} = {FOO=>BAR}".
- And I also want to make sure that newlines work like this "$self->{FOOBAR}
- >> 3 and [$b => $a]->[$a <=> $b]"
-
- Of course I should still be able to do all this [4mwith[m escape sequences too:
- "$self->method()" and "$self->{FIELDNAME}" and "{FOO=>BAR}".
-
- Dont forget "$self->method()->{FIELDNAME} = {FOO=>BAR}".
-
- And make sure that 0 works too!
-
- Now, if I use << or >> as my delimiters, then I have to use whitespace. So
- things like "<$self-"method()>> and "<$self-"{FIELDNAME}>> wont end up
- doing what you might expect since the first > will still terminate the
- first < seen.
-
- Lets make sure these work for empty ones too, like "" and ">>" (just to be
- obnoxious)
-
- The statement: "This is dog kind's [4mfinest[m hour!" is a parody of a
- quotation from Winston Churchill.
-
- The following tests are added to those:
-
- Make sure that a few other odd [4mthings[m still work. This should be a
- vertical bar: |. Here's a test of a few more special escapes that have to
- be supported:
-
- & An ampersand.
-
- ' An apostrophe.
-
- < A less-than sign.
-
- > A greater-than sign.
-
- " A double quotation mark.
-
- / A forward slash.
-
- Try to get this bit of text over towards the edge so
- |that all of this text inside S<> won't| be wrapped. Also test the
- |same thing with non-breaking spaces.|
-
- There is a soft hyphen in hyphen at hy-phen.
-
- This is a test of an index entry.
-
-[1mVERBATIM[m
- Throw in a few verbatim paragraphs.
-
- use Term::ANSIColor;
- print color 'bold blue';
- print "This text is bold blue.\n";
- print color 'reset';
- print "This text is normal.\n";
- print colored ("Yellow on magenta.\n", 'yellow on_magenta');
- print "This text is normal.\n";
- print colored ['yellow on_magenta'], "Yellow on magenta.\n";
-
- use Term::ANSIColor qw(uncolor);
- print uncolor '01;31', "\n";
-
- But this isn't verbatim (make sure it wraps properly), and the next
- paragraph is again:
-
- use Term::ANSIColor qw(:constants);
- print BOLD, BLUE, "This text is in bold blue.\n", RESET;
-
- use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
-
- (Ugh, that's obnoxiously long.) Try different spacing:
-
- Starting with a tab.
- Not
- starting
- with
- a
- tab. But this should still be verbatim.
- As should this.
-
- This isn't.
-
- This is. And this: is an internal tab. It should be:
- |--| <= lined up with that.
-
- (Tricky, but tabs should be expanded before the translator starts in on
- the text since otherwise text with mixed tabs and spaces will get messed
- up.)
-
- And now we test verbatim paragraphs right before a heading. Older
- versions of Pod::Man generated two spaces between paragraphs like this
- and the heading. (In order to properly test this, one may have to
- visually inspect the nroff output when run on the generated *roff
- text, unfortunately.)
-
-[1mCONCLUSION[m
- That's all, folks!
-
Deleted: trunk/contrib/perl/lib/Pod/t/basic.clr
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.clr 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/basic.clr 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,269 +0,0 @@
-[1mNAME[0m
- basic.pod - Test of various basic POD features in translators.
-
-[1mHEADINGS[0m
- Try a few different levels of headings, with embedded formatting codes
- and other interesting bits.
-
-[1mThis "is" a "level 1" heading[0m
- [1m``Level'' "2 [33mheading[0m[0m
- Level 3 [1mheading [33mwith "weird [36mstuff "" (double quote)[0m"[0m[0m
- Level "4 "heading"
- Now try again with [1mintermixed[0m [36mtext[0m.
-
-[1mThis "is" a "level 1" heading[0m
- Text.
-
- [1m``Level'' 2 [33mheading[0m[0m
- Text.
-
- Level 3 [1mheading [33mwith "weird [36mstuff[0m"[0m[0m
- Text.
-
- Level "4 "heading"
- Text.
-
-[1mLINKS[0m
- These are all taken from the Pod::Parser tests.
-
- Try out [33mLOTS[0m of different ways of specifying references:
-
- Reference the "section" in manpage
-
- Reference the "section" in "manpage"
-
- Reference the "section" in manpage
-
- Now try it using the new "|" stuff ...
-
- Reference the thistext|
-
- Reference the thistext |
-
- Reference the thistext|
-
- Reference the thistext |
-
- Reference the thistext|
-
- Reference the thistext|
-
- And then throw in a few new ones of my own.
-
- foo
-
- foo
-
- "bar" in foo
-
- "baz boo" in foo
-
- "bar"
-
- "baz boo"
-
- "baz boo"
-
- "baz boo" in foo bar
-
- "boo var baz"
-
- "bar baz"
-
- "boo", "bar", and "baz"
-
- foobar
-
- Testing [33mitalics[0m
-
- "[33mItalic[0m text" in foo
-
- "Section "with" [33m[1mother[0m markup[0m" in foo|bar
-
- Nested <http://www.perl.org/>
-
-[1mOVER AND ITEMS[0m
- Taken from Pod::Parser tests, this is a test to ensure that multiline
- =item paragraphs get indented appropriately.
-
- This is a test.
-
- There should be whitespace now before this line.
-
- Taken from Pod::Parser tests, this is a test to ensure the nested =item
- paragraphs get indented appropriately.
-
- 1 First section.
-
- a this is item a
-
- b this is item b
-
- 2 Second section.
-
- a this is item a
-
- b this is item b
-
- c
- d This is item c & d.
-
- Now some additional weirdness of our own. Make sure that multiple tags
- for one paragraph are properly compacted.
-
- "foo"
- [1mbar[0m
- "baz"
- There shouldn't be any spaces between any of these item tags; this
- idiom is used in perlfunc.
-
- Some longer item text
- Just to make sure that we test paragraphs where the item text
- doesn't fit in the margin of the paragraph (and make sure that this
- paragraph fills a few lines).
-
- Let's also make it multiple paragraphs to be sure that works.
-
- Test use of =over without =item as a block "quote" or block paragraph.
-
- This should be indented four spaces but otherwise formatted the same
- as any other regular text paragraph. Make sure it's long enough to
- see the results of the formatting.....
-
- Now try the same thing nested, and make sure that the indentation is
- reset back properly.
-
- This paragraph should be doubly indented.
-
- This paragraph should only be singly indented.
-
- * This is an item in the middle of a block-quote, which should be
- allowed.
-
- * We're also testing tagless item commands.
-
- Should be back to the single level of indentation.
-
- Should be back to regular indentation.
-
- Now also check the transformation of * into real bullets for man pages.
-
- * An item. We're also testing using =over without a number, and making
- sure that item text wraps properly.
-
- * Another item.
-
- and now test the numbering of item blocks.
-
- 1. First item.
-
- 2. Second item.
-
-[1mFORMATTING CODES[0m
- Another test taken from Pod::Parser.
-
- This is a test to see if I can do not only $self and "method()", but
- also "$self->method()" and "$self->{FIELDNAME}" and "$Foo <=> $Bar"
- without resorting to escape sequences. If I want to refer to the
- right-shift operator I can do something like "$x >> 3" or even "$y >>
- 5".
-
- Now for the grand finale of "$self->method()->{FIELDNAME} = {FOO=>BAR}".
- And I also want to make sure that newlines work like this
- "$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]"
-
- Of course I should still be able to do all this [33mwith[0m escape sequences
- too: "$self->method()" and "$self->{FIELDNAME}" and "{FOO=>BAR}".
-
- Dont forget "$self->method()->{FIELDNAME} = {FOO=>BAR}".
-
- And make sure that 0 works too!
-
- Now, if I use << or >> as my delimiters, then I have to use whitespace.
- So things like "<$self-"method()>> and "<$self-"{FIELDNAME}>> wont end
- up doing what you might expect since the first > will still terminate
- the first < seen.
-
- Lets make sure these work for empty ones too, like "" and ">>" (just to
- be obnoxious)
-
- The statement: "This is dog kind's [33mfinest[0m hour!" is a parody of a
- quotation from Winston Churchill.
-
- The following tests are added to those:
-
- Make sure that a few other odd [33mthings[0m still work. This should be a
- vertical bar: |. Here's a test of a few more special escapes that have
- to be supported:
-
- & An ampersand.
-
- ' An apostrophe.
-
- < A less-than sign.
-
- > A greater-than sign.
-
- " A double quotation mark.
-
- / A forward slash.
-
- Try to get this bit of text over towards the edge so
- |that all of this text inside S<> won't| be wrapped. Also test the
- |same thing with non-breaking spaces.|
-
- There is a soft hyphen in hyphen at hy-phen.
-
- This is a test of an index entry.
-
-[1mVERBATIM[0m
- Throw in a few verbatim paragraphs.
-
- use Term::ANSIColor;
- print color 'bold blue';
- print "This text is bold blue.\n";
- print color 'reset';
- print "This text is normal.\n";
- print colored ("Yellow on magenta.\n", 'yellow on_magenta');
- print "This text is normal.\n";
- print colored ['yellow on_magenta'], "Yellow on magenta.\n";
-
- use Term::ANSIColor qw(uncolor);
- print uncolor '01;31', "\n";
-
- But this isn't verbatim (make sure it wraps properly), and the next
- paragraph is again:
-
- use Term::ANSIColor qw(:constants);
- print BOLD, BLUE, "This text is in bold blue.\n", RESET;
-
- use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
-
- (Ugh, that's obnoxiously long.) Try different spacing:
-
- Starting with a tab.
- Not
- starting
- with
- a
- tab. But this should still be verbatim.
- As should this.
-
- This isn't.
-
- This is. And this: is an internal tab. It should be:
- |--| <= lined up with that.
-
- (Tricky, but tabs should be expanded before the translator starts in on
- the text since otherwise text with mixed tabs and spaces will get messed
- up.)
-
- And now we test verbatim paragraphs right before a heading. Older
- versions of Pod::Man generated two spaces between paragraphs like this
- and the heading. (In order to properly test this, one may have to
- visually inspect the nroff output when run on the generated *roff
- text, unfortunately.)
-
-[1mCONCLUSION[0m
- That's all, folks!
-
Deleted: trunk/contrib/perl/lib/Pod/t/basic.man
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.man 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/basic.man 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,321 +0,0 @@
-.SH "NAME"
-basic.pod \- Test of various basic POD features in translators.
-.SH "HEADINGS"
-.IX Header "HEADINGS"
-Try a few different levels of headings, with embedded formatting codes and
-other interesting bits.
-.ie n .SH "This ""is"" a ""level 1"" heading"
-.el .SH "This \f(CWis\fP a ``level 1'' heading"
-.IX Header "This is a level 1 heading"
-.SS "``Level'' ""2 \fIheading\fP"
-.IX Subsection "``Level'' ""2 heading"
-\fILevel 3 \f(BIheading \f(BIwith \f(CB\*(C`weird \f(CBstuff "" (double quote)\f(CB\*(C'\f(BI\f(BI\fI\fR
-.IX Subsection "Level 3 heading with weird stuff """" (double quote)"
-.PP
-Level "4 \f(CW\*(C`heading\*(C'\fR
-.IX Subsection "Level ""4 heading"
-.PP
-Now try again with \fBintermixed\fR \fItext\fR.
-.ie n .SH "This ""is"" a ""level 1"" heading"
-.el .SH "This \f(CWis\fP a ``level 1'' heading"
-.IX Header "This is a level 1 heading"
-Text.
-.SS "``Level'' 2 \fIheading\fP"
-.IX Subsection "``Level'' 2 heading"
-Text.
-.PP
-\fILevel 3 \f(BIheading \f(BIwith \f(CB\*(C`weird \f(CBstuff\f(CB\*(C'\f(BI\f(BI\fI\fR
-.IX Subsection "Level 3 heading with weird stuff"
-.PP
-Text.
-.PP
-Level "4 \f(CW\*(C`heading\*(C'\fR
-.IX Subsection "Level ""4 heading"
-.PP
-Text.
-.SH "LINKS"
-.IX Header "LINKS"
-These are all taken from the Pod::Parser tests.
-.PP
-Try out \fI\s-1LOTS\s0\fR of different ways of specifying references:
-.PP
-Reference the \*(L"section\*(R" in manpage
-.PP
-Reference the \*(L"section\*(R" in \*(L"manpage\*(R"
-.PP
-Reference the \*(L"section\*(R" in manpage
-.PP
-Now try it using the new \*(L"|\*(R" stuff ...
-.PP
-Reference the thistext|
-.PP
-Reference the thistext |
-.PP
-Reference the thistext|
-.PP
-Reference the thistext |
-.PP
-Reference the thistext|
-.PP
-Reference the thistext|
-.PP
-And then throw in a few new ones of my own.
-.PP
-foo
-.PP
-foo
-.PP
-\&\*(L"bar\*(R" in foo
-.PP
-\&\*(L"baz boo\*(R" in foo
-.PP
-\&\*(L"bar\*(R"
-.PP
-\&\*(L"baz boo\*(R"
-.PP
-\&\*(L"baz boo\*(R"
-.PP
-\&\*(L"baz boo\*(R" in foo bar
-.PP
-\&\*(L"boo var baz\*(R"
-.PP
-\&\*(L"bar baz\*(R"
-.PP
-\&\*(L"boo\*(R", \*(L"bar\*(R", and \*(L"baz\*(R"
-.PP
-foobar
-.PP
-Testing \fIitalics\fR
-.PP
-"\fIItalic\fR text" in foo
-.PP
-"Section \f(CW\*(C`with\*(C'\fR \fI\f(BIother\fI markup\fR" in foo|bar
-.PP
-Nested <http://www.perl.org/>
-.SH "OVER AND ITEMS"
-.IX Header "OVER AND ITEMS"
-Taken from Pod::Parser tests, this is a test to ensure that multiline
-=item paragraphs get indented appropriately.
-.IP "This is a test." 4
-.IX Item "This is a test."
-.PP
-There should be whitespace now before this line.
-.PP
-Taken from Pod::Parser tests, this is a test to ensure the nested =item
-paragraphs get indented appropriately.
-.IP "1." 2
-First section.
-.RS 2
-.IP "a" 2
-.IX Item "a"
-this is item a
-.IP "b" 2
-.IX Item "b"
-this is item b
-.RE
-.RS 2
-.RE
-.IP "2." 2
-Second section.
-.RS 2
-.IP "a" 2
-.IX Item "a"
-this is item a
-.IP "b" 2
-.IX Item "b"
-this is item b
-.IP "c" 2
-.IX Item "c"
-.PD 0
-.IP "d" 2
-.IX Item "d"
-.PD
-This is item c & d.
-.RE
-.RS 2
-.RE
-.PP
-Now some additional weirdness of our own. Make sure that multiple tags
-for one paragraph are properly compacted.
-.ie n .IP """foo""" 4
-.el .IP "``foo''" 4
-.IX Item "foo"
-.PD 0
-.IP "\fBbar\fR" 4
-.IX Item "bar"
-.ie n .IP """baz""" 4
-.el .IP "\f(CWbaz\fR" 4
-.IX Item "baz"
-.PD
-There shouldn't be any spaces between any of these item tags; this idiom
-is used in perlfunc.
-.IP "Some longer item text" 4
-.IX Item "Some longer item text"
-Just to make sure that we test paragraphs where the item text doesn't fit
-in the margin of the paragraph (and make sure that this paragraph fills a
-few lines).
-.Sp
-Let's also make it multiple paragraphs to be sure that works.
-.PP
-Test use of =over without =item as a block \*(L"quote\*(R" or block paragraph.
-.Sp
-.RS 4
-This should be indented four spaces but otherwise formatted the same as
-any other regular text paragraph. Make sure it's long enough to see the
-results of the formatting.....
-.RE
-.PP
-Now try the same thing nested, and make sure that the indentation is reset
-back properly.
-.RS 4
-.Sp
-.RS 4
-This paragraph should be doubly indented.
-.RE
-.RE
-.RS 4
-.Sp
-This paragraph should only be singly indented.
-.IP "\(bu" 4
-This is an item in the middle of a block-quote, which should be allowed.
-.IP "\(bu" 4
-We're also testing tagless item commands.
-.RE
-.RS 4
-.Sp
-Should be back to the single level of indentation.
-.RE
-.PP
-Should be back to regular indentation.
-.PP
-Now also check the transformation of * into real bullets for man pages.
-.IP "\(bu" 4
-An item. We're also testing using =over without a number, and making sure
-that item text wraps properly.
-.IP "\(bu" 4
-Another item.
-.PP
-and now test the numbering of item blocks.
-.IP "1." 4
-First item.
-.IP "2." 4
-Second item.
-.SH "FORMATTING CODES"
-.IX Header "FORMATTING CODES"
-Another test taken from Pod::Parser.
-.PP
-This is a test to see if I can do not only \f(CW$self\fR and \f(CW\*(C`method()\*(C'\fR, but
-also \f(CW\*(C`$self\->method()\*(C'\fR and \f(CW\*(C`$self\->{FIELDNAME}\*(C'\fR and
-\&\f(CW\*(C`$Foo <=> $Bar\*(C'\fR without resorting to escape sequences. If
-I want to refer to the right-shift operator I can do something
-like \f(CW\*(C`$x >> 3\*(C'\fR or even \f(CW\*(C`$y >> 5\*(C'\fR.
-.PP
-Now for the grand finale of \f(CW\*(C`$self\->method()\->{FIELDNAME} = {FOO=>BAR}\*(C'\fR.
-And I also want to make sure that newlines work like this
-\&\f(CW\*(C`$self\->{FOOBAR} >> 3 and [$b => $a]\->[$a <=> $b]\*(C'\fR
-.PP
-Of course I should still be able to do all this \fIwith\fR escape sequences
-too: \f(CW\*(C`$self\->method()\*(C'\fR and \f(CW\*(C`$self\->{FIELDNAME}\*(C'\fR and
-\&\f(CW\*(C`{FOO=>BAR}\*(C'\fR.
-.PP
-Dont forget \f(CW\*(C`$self\->method()\->{FIELDNAME} = {FOO=>BAR}\*(C'\fR.
-.PP
-And make sure that \f(CW0\fR works too!
-.PP
-Now, if I use << or >> as my delimiters, then I have to use whitespace.
-So things like \f(CW\*(C`<$self\-\*(C'\fR\fImethod()\fR>> and \f(CW\*(C`<$self\-\*(C'\fR{\s-1FIELDNAME\s0}>> wont end
-up doing what you might expect since the first > will still terminate
-the first < seen.
-.PP
-Lets make sure these work for empty ones too, like \f(CW\*(C`\*(C'\fR and \f(CW\*(C`>>\*(C'\fR
-(just to be obnoxious)
-.PP
-The statement: \f(CW\*(C`This is dog kind\*(Aqs \f(CIfinest\f(CW hour!\*(C'\fR is a parody of a
-quotation from Winston Churchill.
-.PP
-The following tests are added to those:
-.PP
-Make sure that a few other odd \fIthings\fR still work. This should be
-a vertical bar: |. Here's a test of a few more special escapes
-that have to be supported:
-.IP "&" 3
-An ampersand.
-.IP "'" 3
-An apostrophe.
-.IP "<" 3
-A less-than sign.
-.IP ">" 3
-A greater-than sign.
-.IP """" 3
-A double quotation mark.
-.IP "/" 3
-A forward slash.
-.PP
-Try to get this bit of text over towards the edge so |that\ all\ of\ this\ text\ inside\ S<>\ won't| be wrapped. Also test the
-|same\ thing\ with\ non-breaking\ spaces.|
-.PP
-There is a soft hy\%phen in hyphen at hy-phen.
-.PP
-This is a test of an index entry.
-.IX Xref "index entry"
-.SH "VERBATIM"
-.IX Header "VERBATIM"
-Throw in a few verbatim paragraphs.
-.PP
-.Vb 8
-\& use Term::ANSIColor;
-\& print color \*(Aqbold blue\*(Aq;
-\& print "This text is bold blue.\en";
-\& print color \*(Aqreset\*(Aq;
-\& print "This text is normal.\en";
-\& print colored ("Yellow on magenta.\en", \*(Aqyellow on_magenta\*(Aq);
-\& print "This text is normal.\en";
-\& print colored [\*(Aqyellow on_magenta\*(Aq], "Yellow on magenta.\en";
-\&
-\& use Term::ANSIColor qw(uncolor);
-\& print uncolor \*(Aq01;31\*(Aq, "\en";
-.Ve
-.PP
-But this isn't verbatim (make sure it wraps properly), and the next
-paragraph is again:
-.PP
-.Vb 2
-\& use Term::ANSIColor qw(:constants);
-\& print BOLD, BLUE, "This text is in bold blue.\en", RESET;
-\&
-\& use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\en"; print "This text is normal.\en";
-.Ve
-.PP
-(Ugh, that's obnoxiously long.) Try different spacing:
-.PP
-.Vb 7
-\& Starting with a tab.
-\&Not
-\&starting
-\&with
-\&a
-\&tab. But this should still be verbatim.
-\& As should this.
-.Ve
-.PP
-This isn't.
-.PP
-.Vb 2
-\& This is. And this: is an internal tab. It should be:
-\& |\-\-| <= lined up with that.
-.Ve
-.PP
-(Tricky, but tabs should be expanded before the translator starts in on
-the text since otherwise text with mixed tabs and spaces will get messed
-up.)
-.PP
-.Vb 5
-\& And now we test verbatim paragraphs right before a heading. Older
-\& versions of Pod::Man generated two spaces between paragraphs like this
-\& and the heading. (In order to properly test this, one may have to
-\& visually inspect the nroff output when run on the generated *roff
-\& text, unfortunately.)
-.Ve
-.SH "CONCLUSION"
-.IX Header "CONCLUSION"
-That's all, folks!
Deleted: trunk/contrib/perl/lib/Pod/t/basic.ovr
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.ovr 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/basic.ovr 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,269 +0,0 @@
-NNAAMMEE
- basic.pod - Test of various basic POD features in translators.
-
-HHEEAADDIINNGGSS
- Try a few different levels of headings, with embedded formatting codes
- and other interesting bits.
-
-TThhiiss ""iiss"" aa ""lleevveell 11"" hheeaaddiinngg
- ````LLeevveell'''' ""22 hheeaaddiinngg
- _L_e_v_e_l_ _3_ _h_e_a_d_i_n_g_ _w_i_t_h_ _"_w_e_i_r_d_ _s_t_u_f_f_ _"_"_ _(_d_o_u_b_l_e_ _q_u_o_t_e_)_"
- _L_e_v_e_l_ _"_4_ _"_h_e_a_d_i_n_g_"
- Now try again with iinntteerrmmiixxeedd _t_e_x_t.
-
-TThhiiss ""iiss"" aa ""lleevveell 11"" hheeaaddiinngg
- Text.
-
- ````LLeevveell'''' 22 hheeaaddiinngg
- Text.
-
- _L_e_v_e_l_ _3_ _h_e_a_d_i_n_g_ _w_i_t_h_ _"_w_e_i_r_d_ _s_t_u_f_f_"
- Text.
-
- _L_e_v_e_l_ _"_4_ _"_h_e_a_d_i_n_g_"
- Text.
-
-LLIINNKKSS
- These are all taken from the Pod::Parser tests.
-
- Try out _L_O_T_S of different ways of specifying references:
-
- Reference the "section" in manpage
-
- Reference the "section" in "manpage"
-
- Reference the "section" in manpage
-
- Now try it using the new "|" stuff ...
-
- Reference the thistext|
-
- Reference the thistext |
-
- Reference the thistext|
-
- Reference the thistext |
-
- Reference the thistext|
-
- Reference the thistext|
-
- And then throw in a few new ones of my own.
-
- foo
-
- foo
-
- "bar" in foo
-
- "baz boo" in foo
-
- "bar"
-
- "baz boo"
-
- "baz boo"
-
- "baz boo" in foo bar
-
- "boo var baz"
-
- "bar baz"
-
- "boo", "bar", and "baz"
-
- foobar
-
- Testing _i_t_a_l_i_c_s
-
- "_I_t_a_l_i_c text" in foo
-
- "Section "with" _o_t_h_e_r_ _m_a_r_k_u_p" in foo|bar
-
- Nested <http://www.perl.org/>
-
-OOVVEERR AANNDD IITTEEMMSS
- Taken from Pod::Parser tests, this is a test to ensure that multiline
- =item paragraphs get indented appropriately.
-
- This is a test.
-
- There should be whitespace now before this line.
-
- Taken from Pod::Parser tests, this is a test to ensure the nested =item
- paragraphs get indented appropriately.
-
- 1 First section.
-
- a this is item a
-
- b this is item b
-
- 2 Second section.
-
- a this is item a
-
- b this is item b
-
- c
- d This is item c & d.
-
- Now some additional weirdness of our own. Make sure that multiple tags
- for one paragraph are properly compacted.
-
- "foo"
- bbaarr
- "baz"
- There shouldn't be any spaces between any of these item tags; this
- idiom is used in perlfunc.
-
- Some longer item text
- Just to make sure that we test paragraphs where the item text
- doesn't fit in the margin of the paragraph (and make sure that this
- paragraph fills a few lines).
-
- Let's also make it multiple paragraphs to be sure that works.
-
- Test use of =over without =item as a block "quote" or block paragraph.
-
- This should be indented four spaces but otherwise formatted the same
- as any other regular text paragraph. Make sure it's long enough to
- see the results of the formatting.....
-
- Now try the same thing nested, and make sure that the indentation is
- reset back properly.
-
- This paragraph should be doubly indented.
-
- This paragraph should only be singly indented.
-
- * This is an item in the middle of a block-quote, which should be
- allowed.
-
- * We're also testing tagless item commands.
-
- Should be back to the single level of indentation.
-
- Should be back to regular indentation.
-
- Now also check the transformation of * into real bullets for man pages.
-
- * An item. We're also testing using =over without a number, and making
- sure that item text wraps properly.
-
- * Another item.
-
- and now test the numbering of item blocks.
-
- 1. First item.
-
- 2. Second item.
-
-FFOORRMMAATTTTIINNGG CCOODDEESS
- Another test taken from Pod::Parser.
-
- This is a test to see if I can do not only $self and "method()", but
- also "$self->method()" and "$self->{FIELDNAME}" and "$Foo <=> $Bar"
- without resorting to escape sequences. If I want to refer to the
- right-shift operator I can do something like "$x >> 3" or even "$y >>
- 5".
-
- Now for the grand finale of "$self->method()->{FIELDNAME} = {FOO=>BAR}".
- And I also want to make sure that newlines work like this
- "$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]"
-
- Of course I should still be able to do all this _w_i_t_h escape sequences
- too: "$self->method()" and "$self->{FIELDNAME}" and "{FOO=>BAR}".
-
- Dont forget "$self->method()->{FIELDNAME} = {FOO=>BAR}".
-
- And make sure that 0 works too!
-
- Now, if I use << or >> as my delimiters, then I have to use whitespace.
- So things like "<$self-"method()>> and "<$self-"{FIELDNAME}>> wont end
- up doing what you might expect since the first > will still terminate
- the first < seen.
-
- Lets make sure these work for empty ones too, like "" and ">>" (just to
- be obnoxious)
-
- The statement: "This is dog kind's _f_i_n_e_s_t hour!" is a parody of a
- quotation from Winston Churchill.
-
- The following tests are added to those:
-
- Make sure that a few other odd _t_h_i_n_g_s still work. This should be a
- vertical bar: |. Here's a test of a few more special escapes that have
- to be supported:
-
- & An ampersand.
-
- ' An apostrophe.
-
- < A less-than sign.
-
- > A greater-than sign.
-
- " A double quotation mark.
-
- / A forward slash.
-
- Try to get this bit of text over towards the edge so
- |that all of this text inside S<> won't| be wrapped. Also test the
- |same thing with non-breaking spaces.|
-
- There is a soft hyphen in hyphen at hy-phen.
-
- This is a test of an index entry.
-
-VVEERRBBAATTIIMM
- Throw in a few verbatim paragraphs.
-
- use Term::ANSIColor;
- print color 'bold blue';
- print "This text is bold blue.\n";
- print color 'reset';
- print "This text is normal.\n";
- print colored ("Yellow on magenta.\n", 'yellow on_magenta');
- print "This text is normal.\n";
- print colored ['yellow on_magenta'], "Yellow on magenta.\n";
-
- use Term::ANSIColor qw(uncolor);
- print uncolor '01;31', "\n";
-
- But this isn't verbatim (make sure it wraps properly), and the next
- paragraph is again:
-
- use Term::ANSIColor qw(:constants);
- print BOLD, BLUE, "This text is in bold blue.\n", RESET;
-
- use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
-
- (Ugh, that's obnoxiously long.) Try different spacing:
-
- Starting with a tab.
- Not
- starting
- with
- a
- tab. But this should still be verbatim.
- As should this.
-
- This isn't.
-
- This is. And this: is an internal tab. It should be:
- |--| <= lined up with that.
-
- (Tricky, but tabs should be expanded before the translator starts in on
- the text since otherwise text with mixed tabs and spaces will get messed
- up.)
-
- And now we test verbatim paragraphs right before a heading. Older
- versions of Pod::Man generated two spaces between paragraphs like this
- and the heading. (In order to properly test this, one may have to
- visually inspect the nroff output when run on the generated *roff
- text, unfortunately.)
-
-CCOONNCCLLUUSSIIOONN
- That's all, folks!
-
Deleted: trunk/contrib/perl/lib/Pod/t/basic.pod
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.pod 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/basic.pod 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,383 +0,0 @@
-=head1 NAME
-
-basic.pod - Test of various basic POD features in translators.
-
-=head1 HEADINGS
-
-Try a few different levels of headings, with embedded formatting codes and
-other interesting bits.
-
-=head1 This C<is> a "level 1" heading
-
-=head2 ``Level'' "2 I<heading>
-
-=head3 Level 3 B<heading I<with C<weird F<stuff "" (double quote)>>>>
-
-=head4 Level "4 C<heading>
-
-Now try again with B<intermixed> F<text>.
-
-=head1 This C<is> a "level 1" heading
-
-Text.
-
-=head2 ``Level'' 2 I<heading>
-
-Text.
-
-=head3 Level 3 B<heading I<with C<weird F<stuff>>>>
-
-Text.
-
-=head4 Level "4 C<heading>
-
-Text.
-
-=head1 LINKS
-
-These are all taken from the Pod::Parser tests.
-
-Try out I<LOTS> of different ways of specifying references:
-
-Reference the L<manpage/section>
-
-Reference the L<"manpage"/section>
-
-Reference the L<manpage/"section">
-
-Now try it using the new "|" stuff ...
-
-Reference the L<thistext|manpage/section>|
-
-Reference the L<thistext | manpage / section>|
-
-Reference the L<thistext| manpage/ section>|
-
-Reference the L<thistext |manpage /section>|
-
-Reference the L<thistext|manpage/"section">|
-
-Reference the L<thistext|
-manpage/
-section>|
-
-And then throw in a few new ones of my own.
-
-L<foo>
-
-L<foo|bar>
-
-L<foo/bar>
-
-L<foo/"baz boo">
-
-L</bar>
-
-L</"baz boo">
-
-L</baz boo>
-
-L<foo bar/baz boo>
-
-L<"boo var baz">
-
-L<bar baz>
-
-L</boo>, L</bar>, and L</baz>
-
-L<fooZ<>bar>
-
-L<Testing I<italics>|foo/bar>
-
-L<foo/I<Italic> text>
-
-L<fooE<verbar>barZ<>/Section C<with> I<B<other> markup>>
-
-L<Nested L<http://www.perl.org/>|fooE<sol>bar>
-
-=head1 OVER AND ITEMS
-
-Taken from Pod::Parser tests, this is a test to ensure that multiline
-=item paragraphs get indented appropriately.
-
-=over 4
-
-=item This
-is
-a
-test.
-
-=back
-
-There should be whitespace now before this line.
-
-Taken from Pod::Parser tests, this is a test to ensure the nested =item
-paragraphs get indented appropriately.
-
-=over 2
-
-=item 1
-
-First section.
-
-=over 2
-
-=item a
-
-this is item a
-
-=item b
-
-this is item b
-
-=back
-
-=item 2
-
-Second section.
-
-=over 2
-
-=item a
-
-this is item a
-
-=item b
-
-this is item b
-
-=item c
-
-=item d
-
-This is item c & d.
-
-=back
-
-=back
-
-Now some additional weirdness of our own. Make sure that multiple tags
-for one paragraph are properly compacted.
-
-=over 4
-
-=item "foo"
-
-=item B<bar>
-
-=item C<baz>
-
-There shouldn't be any spaces between any of these item tags; this idiom
-is used in perlfunc.
-
-=item Some longer item text
-
-Just to make sure that we test paragraphs where the item text doesn't fit
-in the margin of the paragraph (and make sure that this paragraph fills a
-few lines).
-
-Let's also make it multiple paragraphs to be sure that works.
-
-=back
-
-Test use of =over without =item as a block "quote" or block paragraph.
-
-=over 4
-
-This should be indented four spaces but otherwise formatted the same as
-any other regular text paragraph. Make sure it's long enough to see the
-results of the formatting.....
-
-=back
-
-Now try the same thing nested, and make sure that the indentation is reset
-back properly.
-
-=over 4
-
-=over 4
-
-This paragraph should be doubly indented.
-
-=back
-
-This paragraph should only be singly indented.
-
-=over 4
-
-=item
-
-This is an item in the middle of a block-quote, which should be allowed.
-
-=item
-
-We're also testing tagless item commands.
-
-=back
-
-Should be back to the single level of indentation.
-
-=back
-
-Should be back to regular indentation.
-
-Now also check the transformation of * into real bullets for man pages.
-
-=over
-
-=item *
-
-An item. We're also testing using =over without a number, and making sure
-that item text wraps properly.
-
-=item *
-
-Another item.
-
-=back
-
-and now test the numbering of item blocks.
-
-=over 4
-
-=item 1.
-
-First item.
-
-=item 2.
-
-Second item.
-
-=back
-
-=head1 FORMATTING CODES
-
-Another test taken from Pod::Parser.
-
-This is a test to see if I can do not only C<$self> and C<method()>, but
-also C<< $self->method() >> and C<< $self->{FIELDNAME} >> and
-C<< $Foo <=> $Bar >> without resorting to escape sequences. If
-I want to refer to the right-shift operator I can do something
-like C<<< $x >> 3 >>> or even C<<<< $y >> 5 >>>>.
-
-Now for the grand finale of C<< $self->method()->{FIELDNAME} = {FOO=>BAR} >>.
-And I also want to make sure that newlines work like this
-C<<<
-$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]
->>>
-
-Of course I should still be able to do all this I<with> escape sequences
-too: C<$self-E<gt>method()> and C<$self-E<gt>{FIELDNAME}> and
-C<{FOO=E<gt>BAR}>.
-
-Dont forget C<$self-E<gt>method()-E<gt>{FIELDNAME} = {FOO=E<gt>BAR}>.
-
-And make sure that C<0> works too!
-
-Now, if I use << or >> as my delimiters, then I have to use whitespace.
-So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end
-up doing what you might expect since the first > will still terminate
-the first < seen.
-
-Lets make sure these work for empty ones too, like C<< >> and C<< >> >>
-(just to be obnoxious)
-
-The statement: C<This is dog kind's I<finest> hour!> is a parody of a
-quotation from Winston Churchill.
-
-The following tests are added to those:
-
-Make sure that a few othZ<>er odd I<Z<>things> still work. This should be
-a vertical bar: E<verbar>. Here's a test of a few more special escapes
-that have to be supported:
-
-=over 3
-
-=item E<amp>
-
-An ampersand.
-
-=item E<apos>
-
-An apostrophe.
-
-=item E<lt>
-
-A less-than sign.
-
-=item E<gt>
-
-A greater-than sign.
-
-=item E<quot>
-
-A double quotation mark.
-
-=item E<sol>
-
-A forward slash.
-
-=back
-
-Try to get this bit of text over towards the edge so S<|that all of this
-text inside SE<lt>E<gt> won't|> be wrapped. Also test the
-|sameE<nbsp>thingE<nbsp>withE<nbsp>non-breakingS< spaces>.|
-
-There is a soft hyE<shy>phen in hyphen at hy-phen.
-
-This is a test of an X<index entry>index entry.
-
-=head1 VERBATIM
-
-Throw in a few verbatim paragraphs.
-
- use Term::ANSIColor;
- print color 'bold blue';
- print "This text is bold blue.\n";
- print color 'reset';
- print "This text is normal.\n";
- print colored ("Yellow on magenta.\n", 'yellow on_magenta');
- print "This text is normal.\n";
- print colored ['yellow on_magenta'], "Yellow on magenta.\n";
-
- use Term::ANSIColor qw(uncolor);
- print uncolor '01;31', "\n";
-
-But this isn't verbatim (make sure it wraps properly), and the next
-paragraph is again:
-
- use Term::ANSIColor qw(:constants);
- print BOLD, BLUE, "This text is in bold blue.\n", RESET;
-
- use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
-
-(Ugh, that's obnoxiously long.) Try different spacing:
-
- Starting with a tab.
-Not
-starting
-with
-a
-tab. But this should still be verbatim.
- As should this.
-
-This isn't.
-
- This is. And this: is an internal tab. It should be:
- |--| <= lined up with that.
-
-(Tricky, but tabs should be expanded before the translator starts in on
-the text since otherwise text with mixed tabs and spaces will get messed
-up.)
-
- And now we test verbatim paragraphs right before a heading. Older
- versions of Pod::Man generated two spaces between paragraphs like this
- and the heading. (In order to properly test this, one may have to
- visually inspect the nroff output when run on the generated *roff
- text, unfortunately.)
-
-=head1 CONCLUSION
-
-That's all, folks!
-
-=cut
Deleted: trunk/contrib/perl/lib/Pod/t/basic.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/basic.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,127 +0,0 @@
-#!/usr/bin/perl -w
-#
-# basic.t -- Basic tests for podlators.
-#
-# Copyright 2001, 2002, 2004, 2006 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..11\n";
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Man;
-use Pod::Text;
-use Pod::Text::Overstrike;
-use Pod::Text::Termcap;
-
-# Find the path to the test source files. This requires some fiddling when
-# these tests are run as part of Perl core.
-sub source_path {
- my $file = shift;
- if ($ENV{PERL_CORE}) {
- require File::Spec;
- my $updir = File::Spec->updir;
- my $dir = File::Spec->catdir ($updir, 'lib', 'Pod', 't');
- return File::Spec->catfile ($dir, $file);
- } else {
- return $file;
- }
-}
-
-$loaded = 1;
-print "ok 1\n";
-
-# Hard-code a few values to try to get reproducible results.
-$ENV{COLUMNS} = 80;
-$ENV{TERM} = 'xterm';
-$ENV{TERMCAP} = 'xterm:co=80:do=^J:md=\E[1m:us=\E[4m:me=\E[m';
-
-# Map of translators to file extensions to find the formatted output to
-# compare against.
-my %translators = ('Pod::Man' => 'man',
- 'Pod::Text' => 'txt',
- 'Pod::Text::Color' => 'clr',
- 'Pod::Text::Overstrike' => 'ovr',
- 'Pod::Text::Termcap' => 'cap');
-
-# Set default options to match those of pod2man and pod2text.
-%options = (sentence => 0);
-
-my $n = 2;
-for (sort keys %translators) {
- if ($_ eq 'Pod::Text::Color') {
- eval { require Term::ANSIColor };
- if ($@) {
- print "ok $n # skip\n";
- $n++;
- print "ok $n # skip\n";
- $n++;
- next;
- }
- require Pod::Text::Color;
- }
- my $parser = $_->new (%options);
- print (($parser && ref ($parser) eq $_) ? "ok $n\n" : "not ok $n\n");
- $n++;
-
- # For Pod::Man, strip out the autogenerated header up to the .TH title
- # line. That means that we don't check those things; oh well. The header
- # changes with each version change or touch of the input file.
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- $parser->parse_from_file (source_path ('basic.pod'), \*OUT);
- close OUT;
- if ($_ eq 'Pod::Man') {
- open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- open (OUTPUT, "> out.$translators{$_}")
- or die "Cannot create out.$translators{$_}: $!\n";
- local $_;
- while (<TMP>) { last if /^\.nh/ }
- print OUTPUT while <TMP>;
- close OUTPUT;
- close TMP;
- unlink 'out.tmp';
- } else {
- rename ('out.tmp', "out.$translators{$_}")
- or die "Cannot rename out.tmp: $!\n";
- }
- {
- local $/;
- open (MASTER, source_path ("basic.$translators{$_}"))
- or die "Cannot open basic.$translators{$_}: $!\n";
- open (OUTPUT, "out.$translators{$_}")
- or die "Cannot open out.$translators{$_}: $!\n";
- my $master = <MASTER>;
- my $output = <OUTPUT>;
- close MASTER;
- close OUTPUT;
-
- # OS/390 is EBCDIC, which uses a different character for ESC
- # apparently. Try to convert so that the test still works.
- if ($^O eq 'os390' && $_ eq 'Pod::Text::Termcap') {
- $output =~ tr/\033/\047/;
- }
-
- if ($master eq $output) {
- print "ok $n\n";
- unlink "out.$translators{$_}";
- } else {
- print "not ok $n\n";
- print "# Non-matching output left in out.$translators{$_}\n";
- }
- }
- $n++;
-}
Deleted: trunk/contrib/perl/lib/Pod/t/basic.txt
===================================================================
--- trunk/contrib/perl/lib/Pod/t/basic.txt 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/basic.txt 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,269 +0,0 @@
-NAME
- basic.pod - Test of various basic POD features in translators.
-
-HEADINGS
- Try a few different levels of headings, with embedded formatting codes
- and other interesting bits.
-
-This "is" a "level 1" heading
- ``Level'' "2 *heading*
- Level 3 heading *with "weird stuff "" (double quote)"*
- Level "4 "heading"
- Now try again with intermixed text.
-
-This "is" a "level 1" heading
- Text.
-
- ``Level'' 2 *heading*
- Text.
-
- Level 3 heading *with "weird stuff"*
- Text.
-
- Level "4 "heading"
- Text.
-
-LINKS
- These are all taken from the Pod::Parser tests.
-
- Try out *LOTS* of different ways of specifying references:
-
- Reference the "section" in manpage
-
- Reference the "section" in "manpage"
-
- Reference the "section" in manpage
-
- Now try it using the new "|" stuff ...
-
- Reference the thistext|
-
- Reference the thistext |
-
- Reference the thistext|
-
- Reference the thistext |
-
- Reference the thistext|
-
- Reference the thistext|
-
- And then throw in a few new ones of my own.
-
- foo
-
- foo
-
- "bar" in foo
-
- "baz boo" in foo
-
- "bar"
-
- "baz boo"
-
- "baz boo"
-
- "baz boo" in foo bar
-
- "boo var baz"
-
- "bar baz"
-
- "boo", "bar", and "baz"
-
- foobar
-
- Testing *italics*
-
- "*Italic* text" in foo
-
- "Section "with" *other markup*" in foo|bar
-
- Nested <http://www.perl.org/>
-
-OVER AND ITEMS
- Taken from Pod::Parser tests, this is a test to ensure that multiline
- =item paragraphs get indented appropriately.
-
- This is a test.
-
- There should be whitespace now before this line.
-
- Taken from Pod::Parser tests, this is a test to ensure the nested =item
- paragraphs get indented appropriately.
-
- 1 First section.
-
- a this is item a
-
- b this is item b
-
- 2 Second section.
-
- a this is item a
-
- b this is item b
-
- c
- d This is item c & d.
-
- Now some additional weirdness of our own. Make sure that multiple tags
- for one paragraph are properly compacted.
-
- "foo"
- bar
- "baz"
- There shouldn't be any spaces between any of these item tags; this
- idiom is used in perlfunc.
-
- Some longer item text
- Just to make sure that we test paragraphs where the item text
- doesn't fit in the margin of the paragraph (and make sure that this
- paragraph fills a few lines).
-
- Let's also make it multiple paragraphs to be sure that works.
-
- Test use of =over without =item as a block "quote" or block paragraph.
-
- This should be indented four spaces but otherwise formatted the same
- as any other regular text paragraph. Make sure it's long enough to
- see the results of the formatting.....
-
- Now try the same thing nested, and make sure that the indentation is
- reset back properly.
-
- This paragraph should be doubly indented.
-
- This paragraph should only be singly indented.
-
- * This is an item in the middle of a block-quote, which should be
- allowed.
-
- * We're also testing tagless item commands.
-
- Should be back to the single level of indentation.
-
- Should be back to regular indentation.
-
- Now also check the transformation of * into real bullets for man pages.
-
- * An item. We're also testing using =over without a number, and making
- sure that item text wraps properly.
-
- * Another item.
-
- and now test the numbering of item blocks.
-
- 1. First item.
-
- 2. Second item.
-
-FORMATTING CODES
- Another test taken from Pod::Parser.
-
- This is a test to see if I can do not only $self and "method()", but
- also "$self->method()" and "$self->{FIELDNAME}" and "$Foo <=> $Bar"
- without resorting to escape sequences. If I want to refer to the
- right-shift operator I can do something like "$x >> 3" or even "$y >>
- 5".
-
- Now for the grand finale of "$self->method()->{FIELDNAME} = {FOO=>BAR}".
- And I also want to make sure that newlines work like this
- "$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]"
-
- Of course I should still be able to do all this *with* escape sequences
- too: "$self->method()" and "$self->{FIELDNAME}" and "{FOO=>BAR}".
-
- Dont forget "$self->method()->{FIELDNAME} = {FOO=>BAR}".
-
- And make sure that 0 works too!
-
- Now, if I use << or >> as my delimiters, then I have to use whitespace.
- So things like "<$self-"method()>> and "<$self-"{FIELDNAME}>> wont end
- up doing what you might expect since the first > will still terminate
- the first < seen.
-
- Lets make sure these work for empty ones too, like "" and ">>" (just to
- be obnoxious)
-
- The statement: "This is dog kind's *finest* hour!" is a parody of a
- quotation from Winston Churchill.
-
- The following tests are added to those:
-
- Make sure that a few other odd *things* still work. This should be a
- vertical bar: |. Here's a test of a few more special escapes that have
- to be supported:
-
- & An ampersand.
-
- ' An apostrophe.
-
- < A less-than sign.
-
- > A greater-than sign.
-
- " A double quotation mark.
-
- / A forward slash.
-
- Try to get this bit of text over towards the edge so
- |that all of this text inside S<> won't| be wrapped. Also test the
- |same thing with non-breaking spaces.|
-
- There is a soft hyphen in hyphen at hy-phen.
-
- This is a test of an index entry.
-
-VERBATIM
- Throw in a few verbatim paragraphs.
-
- use Term::ANSIColor;
- print color 'bold blue';
- print "This text is bold blue.\n";
- print color 'reset';
- print "This text is normal.\n";
- print colored ("Yellow on magenta.\n", 'yellow on_magenta');
- print "This text is normal.\n";
- print colored ['yellow on_magenta'], "Yellow on magenta.\n";
-
- use Term::ANSIColor qw(uncolor);
- print uncolor '01;31', "\n";
-
- But this isn't verbatim (make sure it wraps properly), and the next
- paragraph is again:
-
- use Term::ANSIColor qw(:constants);
- print BOLD, BLUE, "This text is in bold blue.\n", RESET;
-
- use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n";
-
- (Ugh, that's obnoxiously long.) Try different spacing:
-
- Starting with a tab.
- Not
- starting
- with
- a
- tab. But this should still be verbatim.
- As should this.
-
- This isn't.
-
- This is. And this: is an internal tab. It should be:
- |--| <= lined up with that.
-
- (Tricky, but tabs should be expanded before the translator starts in on
- the text since otherwise text with mixed tabs and spaces will get messed
- up.)
-
- And now we test verbatim paragraphs right before a heading. Older
- versions of Pod::Man generated two spaces between paragraphs like this
- and the heading. (In order to properly test this, one may have to
- visually inspect the nroff output when run on the generated *roff
- text, unfortunately.)
-
-CONCLUSION
- That's all, folks!
-
Deleted: trunk/contrib/perl/lib/Pod/t/color.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/color.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/color.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,88 +0,0 @@
-#!/usr/bin/perl -w
-#
-# color.t -- Additional specialized tests for Pod::Text::Color.
-#
-# Copyright 2002, 2004, 2006 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..2\n";
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-eval { require Term::ANSIColor };
-if ($@) {
- for (1..2) {
- print "ok $_ # skip\n";
- }
- $loaded = 1;
- exit;
-}
-require Pod::Text::Color;
-
-$loaded = 1;
-print "ok 1\n";
-
-my $parser = Pod::Text::Color->new or die "Cannot create parser\n";
-my $n = 2;
-while (<DATA>) {
- next until $_ eq "###\n";
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- $parser->parse_from_file ('tmp.pod', \*OUT);
- close OUT;
- open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- my $output;
- {
- local $/;
- $output = <TMP>;
- }
- close TMP;
- unlink ('tmp.pod', 'out.tmp');
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
-}
-
-# Below the marker are bits of POD and corresponding expected output. This is
-# used to test specific features or problems with Pod::Text::Termcap. The
-# input and output are separated by lines containing only ###.
-
-__DATA__
-
-###
-=head1 WRAPPING
-
-B<I<Do>> I<B<not>> B<I<include>> B<I<formatting codes when>> B<I<wrapping>>.
-###
-[1mWRAPPING[0m
- [1m[33mDo[0m[0m [33m[1mnot[0m[0m [1m[33minclude[0m[0m [1m[33mformatting codes when[0m[0m [1m[33mwrapping[0m[0m.
-
-###
Deleted: trunk/contrib/perl/lib/Pod/t/contains_pod.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/contains_pod.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/contains_pod.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,27 +0,0 @@
-#!/usr/bin/env perl
-
-# Copyright (C) 2005 Joshua Hoblitt
-#
-# $Id: contains_pod.t,v 1.1.1.2 2011-02-17 12:49:41 laffer1 Exp $
-
-use strict;
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
- } else {
- use lib qw( ./lib );
- }
-}
-
-use Test::More tests => 2;
-
-use Pod::Find qw( contains_pod );
-
-{
- ok(contains_pod('lib/contains_pod.xr'), "contains pod");
-}
-
-{
- ok(contains_pod('lib/contains_bad_pod.xr'), "contains bad pod");
-}
Deleted: trunk/contrib/perl/lib/Pod/t/eol.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/eol.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/eol.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,95 +0,0 @@
-#!./perl -w
-
-use Test::More tests => 3;
-
-open(POD, ">$$.pod") or die "$$.pod: $!";
-print POD <<__EOF__;
-=pod
-
-=head1 NAME
-
-crlf
-
-=head1 DESCRIPTION
-
-crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
-crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
-crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
-crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
-
- crlf crlf crlf crlf
- crlf crlf crlf crlf
- crlf crlf crlf crlf
-
-crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
-crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
-crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
-crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf crlf
-
-=cut
-__EOF__
-close(POD);
-
-use Pod::Html;
-
-# --- CR ---
-
-open(POD, "<$$.pod") or die "$$.pod: $!";
-open(IN, ">$$.in") or die "$$.in: $!";
-while (<POD>) {
- s/[\r\n]+/\r/g;
- print IN $_;
-}
-close(POD);
-close(IN);
-
-pod2html("--title=eol", "--infile=$$.in", "--outfile=$$.o1");
-
-# --- LF ---
-
-open(POD, "<$$.pod") or die "$$.pod: $!";
-open(IN, ">$$.in") or die "$$.in: $!";
-while (<POD>) {
- s/[\r\n]+/\n/g;
- print IN $_;
-}
-close(POD);
-close(IN);
-
-pod2html("--title=eol", "--infile=$$.in", "--outfile=$$.o2");
-
-# --- CRLF ---
-
-open(POD, "<$$.pod") or die "$$.pod: $!";
-open(IN, ">$$.in") or die "$$.in: $!";
-while (<POD>) {
- s/[\r\n]+/\r\n/g;
- print IN $_;
-}
-close(POD);
-close(IN);
-
-pod2html("--title=eol", "--infile=$$.in", "--outfile=$$.o3");
-
-# --- now test ---
-
-local $/;
-
-open(IN, "<$$.o1") or die "$$.o1: $!";
-my $cksum1 = unpack("%32C*", <IN>);
-
-open(IN, "<$$.o2") or die "$$.o2: $!";
-my $cksum2 = unpack("%32C*", <IN>);
-
-open(IN, "<$$.o3") or die "$$.o3: $!";
-my $cksum3 = unpack("%32C*", <IN>);
-
-ok($cksum1 == $cksum2, "CR vs LF");
-ok($cksum1 == $cksum3, "CR vs CRLF");
-ok($cksum2 == $cksum3, "LF vs CRLF");
-close IN;
-
-END {
- 1 while unlink("$$.pod", "$$.in", "$$.o1", "$$.o2", "$$.o3",
- "pod2htmd.x~~", "pod2htmi.x~~");
-}
Deleted: trunk/contrib/perl/lib/Pod/t/filehandle.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/filehandle.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/filehandle.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,121 +0,0 @@
-#!/usr/bin/perl -w
-#
-# filehandle.t -- Test the parse_from_filehandle interface.
-#
-# Copyright 2006 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..3\n";
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Man;
-use Pod::Text;
-
-$loaded = 1;
-print "ok 1\n";
-
-my $man = Pod::Man->new or die "Cannot create parser\n";
-my $text = Pod::Text->new or die "Cannot create parser\n";
-my $n = 2;
-while (<DATA>) {
- next until $_ eq "###\n";
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- open (IN, '< tmp.pod') or die "Cannot open tmp.pod: $!\n";
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- $man->parse_from_filehandle (\*IN, \*OUT);
- close IN;
- close OUT;
- open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- while (<OUT>) { last if /^\.nh/ }
- my $output;
- {
- local $/;
- $output = <OUT>;
- }
- close OUT;
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
- open (IN, '< tmp.pod') or die "Cannot open tmp.pod: $!\n";
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- $text->parse_from_filehandle (\*IN, \*OUT);
- close IN;
- close OUT;
- open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- {
- local $/;
- $output = <OUT>;
- }
- close OUT;
- unlink ('tmp.pod', 'out.tmp');
- $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
-}
-
-# Below the marker are bits of POD, corresponding expected nroff output, and
-# corresponding expected text output. The input and output are separated by
-# lines containing only ###.
-
-__DATA__
-
-###
-=head1 NAME
-
-gcc - GNU project C and C++ compiler
-
-=head1 C++ NOTES
-
-Other mentions of C++.
-###
-.SH "NAME"
-gcc \- GNU project C and C++ compiler
-.SH "\*(C+ NOTES"
-.IX Header " NOTES"
-Other mentions of \*(C+.
-###
-NAME
- gcc - GNU project C and C++ compiler
-
-C++ NOTES
- Other mentions of C++.
-
-###
Deleted: trunk/contrib/perl/lib/Pod/t/htmlescp.pod
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmlescp.pod 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/htmlescp.pod 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,14 +0,0 @@
-=head1 NAME
-
-Escape Sequences Test
-
-=head1 DESCRIPTION
-
-I am a stupid fool who puts naked < & > characters in my POD
-instead of escaping them as E<lt> and E<gt>.
-
-Here is some B<bold> text, some I<italic> plus F</etc/fstab>
-file and something that looks like an E<lt>htmlE<gt> tag.
-This is some C<$code($arg1)>.
-
-=cut
Deleted: trunk/contrib/perl/lib/Pod/t/htmlescp.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmlescp.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/htmlescp.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,58 +0,0 @@
-#!/usr/bin/perl -w # -*- perl -*-
-
-BEGIN {
- chdir 't' if -d 't';
- unshift @INC, '../lib';
- unshift @INC, '../lib/Pod/t';
- require "pod2html-lib.pl";
-}
-
-use strict;
-use Test::More tests => 1;
-
-convert_n_test("htmlescp", "html escape");
-
-__DATA__
-<?xml version="1.0" ?>
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
-<title>NAME</title>
-<meta http-equiv="content-type" content="text/html; charset=utf-8" />
-<link rev="made" href="mailto:[PERLADMIN]" />
-</head>
-
-<body style="background-color: white">
-
-
-<!-- INDEX BEGIN -->
-<div name="index">
-<p><a name="__index__"></a></p>
-
-<ul>
-
- <li><a href="#name">NAME</a></li>
- <li><a href="#description">DESCRIPTION</a></li>
-</ul>
-
-<hr name="index" />
-</div>
-<!-- INDEX END -->
-
-<p>
-</p>
-<h1><a name="name">NAME</a></h1>
-<p>Escape Sequences Test</p>
-<p>
-</p>
-<hr />
-<h1><a name="description">DESCRIPTION</a></h1>
-<p>I am a stupid fool who puts naked < & > characters in my POD
-instead of escaping them as < and >.</p>
-<p>Here is some <strong>bold</strong> text, some <em>italic</em> plus <em class="file">/etc/fstab</em>
-file and something that looks like an <html> tag.
-This is some <code>$code($arg1)</code>.</p>
-
-</body>
-
-</html>
Deleted: trunk/contrib/perl/lib/Pod/t/htmllink.pod
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmllink.pod 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/htmllink.pod 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,109 +0,0 @@
-=head1 NAME
-
-htmllink - Test HTML links
-
-=head1 LINKS
-
-L</"section1">
-
-L</"section 2">
-
-L</"section three">
-
-L</"item1">
-
-L</"item 2">
-
-L</"item three">
-
-L</section1>
-
-L</section 2>
-
-L</section three>
-
-L</item1>
-
-L</item 2>
-
-L</item three>
-
-L<"section1">
-
-L<"section 2">
-
-L<"section three">
-
-L<"item1">
-
-L<"item 2">
-
-L<"item three">
-
-L<text|/"section1">
-
-L<text|/"section 2">
-
-L<text|/"section three">
-
-L<text|/"item1">
-
-L<text|/"item 2">
-
-L<text|/"item three">
-
-L<text|/section1>
-
-L<text|/section 2>
-
-L<text|/section three>
-
-L<text|/item1>
-
-L<text|/item 2>
-
-L<text|/item three>
-
-L<text|"section1">
-
-L<text|"section 2">
-
-L<text|"section three">
-
-L<text|"item1">
-
-L<text|"item 2">
-
-L<text|"item three">
-
-=head1 TARGETS
-
-=head2 section1
-
-This is section one.
-
-=head2 section 2
-
-This is section two.
-
-=head2 section three
-
-This is section three.
-
-=over 4
-
-=item item1 X<item> X<one>
-
-This is item one.
-
-=item item 2
-X<item> X<two>
-
-This is item two.
-
-=item item three X<item>
-X<three>
-
-This is item three.
-
-=back
Deleted: trunk/contrib/perl/lib/Pod/t/htmllink.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmllink.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/htmllink.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,130 +0,0 @@
-#!/usr/bin/perl -w # -*- perl -*-
-
-BEGIN {
- chdir 't' if -d 't';
- unshift @INC, '../lib';
- unshift @INC, '../lib/Pod/t';
- require "pod2html-lib.pl";
-}
-
-use strict;
-use Test::More tests => 1;
-
-convert_n_test("htmllink", "html links");
-
-__DATA__
-<?xml version="1.0" ?>
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
-<title>htmllink - Test HTML links</title>
-<meta http-equiv="content-type" content="text/html; charset=utf-8" />
-<link rev="made" href="mailto:[PERLADMIN]" />
-</head>
-
-<body style="background-color: white">
-
-
-<!-- INDEX BEGIN -->
-<div name="index">
-<p><a name="__index__"></a></p>
-
-<ul>
-
- <li><a href="#name">NAME</a></li>
- <li><a href="#links">LINKS</a></li>
- <li><a href="#targets">TARGETS</a></li>
- <ul>
-
- <li><a href="#section1">section1</a></li>
- <li><a href="#section_2">section 2</a></li>
- <li><a href="#section_three">section three</a></li>
- </ul>
-
-</ul>
-
-<hr name="index" />
-</div>
-<!-- INDEX END -->
-
-<p>
-</p>
-<h1><a name="name">NAME</a></h1>
-<p>htmllink - Test HTML links</p>
-<p>
-</p>
-<hr />
-<h1><a name="links">LINKS</a></h1>
-<p><a href="#section1">section1</a></p>
-<p><a href="#section_2">section 2</a></p>
-<p><a href="#section_three">section three</a></p>
-<p><a href="#item1">item1</a></p>
-<p><a href="#item_2">item 2</a></p>
-<p><a href="#item_three">item three</a></p>
-<p><a href="#section1">section1</a></p>
-<p><a href="#section_2">section 2</a></p>
-<p><a href="#section_three">section three</a></p>
-<p><a href="#item1">item1</a></p>
-<p><a href="#item_2">item 2</a></p>
-<p><a href="#item_three">item three</a></p>
-<p><a href="#section1">section1</a></p>
-<p><a href="#section_2">section 2</a></p>
-<p><a href="#section_three">section three</a></p>
-<p><a href="#item1">item1</a></p>
-<p><a href="#item_2">item 2</a></p>
-<p><a href="#item_three">item three</a></p>
-<p><a href="#section1">text</a></p>
-<p><a href="#section_2">text</a></p>
-<p><a href="#section_three">text</a></p>
-<p><a href="#item1">text</a></p>
-<p><a href="#item_2">text</a></p>
-<p><a href="#item_three">text</a></p>
-<p><a href="#section1">text</a></p>
-<p><a href="#section_2">text</a></p>
-<p><a href="#section_three">text</a></p>
-<p><a href="#item1">text</a></p>
-<p><a href="#item_2">text</a></p>
-<p><a href="#item_three">text</a></p>
-<p><a href="#section1">text</a></p>
-<p><a href="#section_2">text</a></p>
-<p><a href="#section_three">text</a></p>
-<p><a href="#item1">text</a></p>
-<p><a href="#item_2">text</a></p>
-<p><a href="#item_three">text</a></p>
-<p>
-</p>
-<hr />
-<h1><a name="targets">TARGETS</a></h1>
-<p>
-</p>
-<h2><a name="section1">section1</a></h2>
-<p>This is section one.</p>
-<p>
-</p>
-<h2><a name="section_2">section 2</a></h2>
-<p>This is section two.</p>
-<p>
-</p>
-<h2><a name="section_three">section three</a></h2>
-<p>This is section three.</p>
-<dl>
-<dt><strong><a name="item1" class="item">item1</a></strong></dt>
-
-<dd>
-<p>This is item one.</p>
-</dd>
-<dt><strong><a name="item_2" class="item">item 2</a></strong></dt>
-
-<dd>
-<p>This is item two.</p>
-</dd>
-<dt><strong><a name="item_three" class="item">item three</a></strong></dt>
-
-<dd>
-<p>This is item three.</p>
-</dd>
-</dl>
-
-</body>
-
-</html>
Deleted: trunk/contrib/perl/lib/Pod/t/htmlview.pod
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmlview.pod 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/htmlview.pod 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,146 +0,0 @@
-=head1 NAME
-
-Test HTML Rendering
-
-=head1 SYNOPSIS
-
- use My::Module;
-
- my $module = My::Module->new();
-
-=head1 DESCRIPTION
-
-This is the description.
-
- Here is a verbatim section.
-
-This is some more regular text.
-
-Here is some B<bold> text, some I<italic> and something that looks
-like an E<lt>htmlE<gt> tag. This is some C<$code($arg1)>.
-
-This C<text contains embedded B<bold> and I<italic> tags>. These can
-be nested, allowing B<bold and I<bold E<amp> italic> text>. The module also
-supports the extended B<< syntax >> and permits I<< nested tags E<amp>
-other B<<< cool >>> stuff >>
-
-=head1 METHODS =E<gt> OTHER STUFF
-
-Here is a list of methods
-
-=head2 new()
-
-Constructor method. Accepts the following config options:
-
-=over 4
-
-=item foo
-
-The foo item.
-
-=item bar
-
-The bar item.
-
-=over 4
-
-This is a list within a list
-
-=item *
-
-The wiz item.
-
-=item *
-
-The waz item.
-
-=back
-
-=item baz
-
-The baz item.
-
-=back
-
-Title on the same line as the =item + * bullets
-
-=over
-
-=item * C<Black> Cat
-
-=item * Sat S<I<on> the>
-
-=item * MatE<lt>!E<gt>
-
-=back
-
-Title on the same line as the =item + numerical bullets
-
-=over
-
-=item 1 Cat
-
-=item 2 Sat
-
-=item 3 Mat
-
-=back
-
-No bullets, no title
-
-=over
-
-=item
-
-Cat
-
-=item
-
-Sat
-
-=item
-
-Mat
-
-=back
-
-=head2 old()
-
-Destructor method
-
-=head1 TESTING FOR AND BEGIN
-
-=for html <br />
-<p>
-blah blah
-</p>
-
-intermediate text
-
-=begin html
-
-<more>
-HTML
-</more>
-
-some text
-
-=end html
-
-=head1 TESTING URLs hyperlinking
-
-This is an href link1: http://example.com
-
-This is an href link2: http://example.com/foo/bar.html
-
-This is an email link: mailto:foo at bar.com
-
- This is a link in a verbatim block <a href="http://perl.org"> Perl </a>
-
-=head1 SEE ALSO
-
-See also L<Test Page 2|htmlescp>, the L<Your::Module> and L<Their::Module>
-manpages and the other interesting file F</usr/local/my/module/rocks>
-as well.
-
-=cut
Deleted: trunk/contrib/perl/lib/Pod/t/htmlview.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/htmlview.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/htmlview.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,186 +0,0 @@
-#!/usr/bin/perl -w # -*- perl -*-
-
-BEGIN {
- chdir 't' if -d 't';
- unshift @INC, '../lib';
- unshift @INC, '../lib/Pod/t';
- require "pod2html-lib.pl";
-}
-
-use strict;
-use Test::More tests => 1;
-
-convert_n_test("htmlview", "html rendering");
-
-__DATA__
-<?xml version="1.0" ?>
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
-<html xmlns="http://www.w3.org/1999/xhtml">
-<head>
-<title>NAME</title>
-<meta http-equiv="content-type" content="text/html; charset=utf-8" />
-<link rev="made" href="mailto:[PERLADMIN]" />
-</head>
-
-<body style="background-color: white">
-
-
-<!-- INDEX BEGIN -->
-<div name="index">
-<p><a name="__index__"></a></p>
-
-<ul>
-
- <li><a href="#name">NAME</a></li>
- <li><a href="#synopsis">SYNOPSIS</a></li>
- <li><a href="#description">DESCRIPTION</a></li>
- <li><a href="#methods____other_stuff">METHODS => OTHER STUFF</a></li>
- <ul>
-
- <li><a href="#new__"><code>new()</code></a></li>
- <li><a href="#old__"><code>old()</code></a></li>
- </ul>
-
- <li><a href="#testing_for_and_begin">TESTING FOR AND BEGIN</a></li>
- <li><a href="#testing_urls_hyperlinking">TESTING URLs hyperlinking</a></li>
- <li><a href="#see_also">SEE ALSO</a></li>
-</ul>
-
-<hr name="index" />
-</div>
-<!-- INDEX END -->
-
-<p>
-</p>
-<h1><a name="name">NAME</a></h1>
-<p>Test HTML Rendering</p>
-<p>
-</p>
-<hr />
-<h1><a name="synopsis">SYNOPSIS</a></h1>
-<pre>
- use My::Module;</pre>
-<pre>
- my $module = My::Module->new();</pre>
-<p>
-</p>
-<hr />
-<h1><a name="description">DESCRIPTION</a></h1>
-<p>This is the description.</p>
-<pre>
- Here is a verbatim section.</pre>
-<p>This is some more regular text.</p>
-<p>Here is some <strong>bold</strong> text, some <em>italic</em> and something that looks
-like an <html> tag. This is some <code>$code($arg1)</code>.</p>
-<p>This <code>text contains embedded bold and italic tags</code>. These can
-be nested, allowing <strong>bold and <em>bold & italic</em> text</strong>. The module also
-supports the extended <strong>syntax </strong>> and permits <em>nested tags &
-other <strong>cool </strong></em>> stuff >></p>
-<p>
-</p>
-<hr />
-<h1><a name="methods____other_stuff">METHODS => OTHER STUFF</a></h1>
-<p>Here is a list of methods</p>
-<p>
-</p>
-<h2><a name="new__"><code>new()</code></a></h2>
-<p>Constructor method. Accepts the following config options:</p>
-<dl>
-<dt><strong><a name="foo" class="item">foo</a></strong></dt>
-
-<dd>
-<p>The foo item.</p>
-</dd>
-<dt><strong><a name="bar" class="item">bar</a></strong></dt>
-
-<dd>
-<p>The bar item.</p>
-<p>This is a list within a list</p>
-<ul>
-<li>
-<p>The wiz item.</p>
-</li>
-<li>
-<p>The waz item.</p>
-</li>
-</ul>
-</dd>
-<dt><strong><a name="baz" class="item">baz</a></strong></dt>
-
-<dd>
-<p>The baz item.</p>
-</dd>
-</dl>
-<p>Title on the same line as the =item + * bullets</p>
-<ul>
-<li><strong><a name="black_cat" class="item"><code>Black</code> Cat</a></strong>
-
-</li>
-<li><strong><a name="sat_on_the" class="item">Sat <em>on</em> the</a></strong>
-
-</li>
-<li><strong><a name="mat" class="item">Mat<!></a></strong>
-
-</li>
-</ul>
-<p>Title on the same line as the =item + numerical bullets</p>
-<ol>
-<li><strong><a name="cat" class="item">Cat</a></strong>
-
-</li>
-<li><strong><a name="sat" class="item">Sat</a></strong>
-
-</li>
-<li><strong><a name="mat2" class="item">Mat</a></strong>
-
-</li>
-</ol>
-<p>No bullets, no title</p>
-<dl>
-<dt>
-<dd>
-<p>Cat</p>
-</dd>
-<dt>
-<dd>
-<p>Sat</p>
-</dd>
-<dt>
-<dd>
-<p>Mat</p>
-</dd>
-</dl>
-<p>
-</p>
-<h2><a name="old__"><code>old()</code></a></h2>
-<p>Destructor method</p>
-<p>
-</p>
-<hr />
-<h1><a name="testing_for_and_begin">TESTING FOR AND BEGIN</a></h1>
-<br />
-<p>
-blah blah
-</p><p>intermediate text</p>
-<more>
-HTML
-</more>some text<p>
-</p>
-<hr />
-<h1><a name="testing_urls_hyperlinking">TESTING URLs hyperlinking</a></h1>
-<p>This is an href link1: <a href="http://example.com">http://example.com</a></p>
-<p>This is an href link2: <a href="http://example.com/foo/bar.html">http://example.com/foo/bar.html</a></p>
-<p>This is an email link: <a href="mailto:mailto:foo at bar.com">mailto:foo at bar.com</a></p>
-<pre>
- This is a link in a verbatim block <a href="<a href="http://perl.org">http://perl.org</a>"> Perl </a></pre>
-<p>
-</p>
-<hr />
-<h1><a name="see_also">SEE ALSO</a></h1>
-<p>See also <a href="/t/htmlescp.html">Test Page 2</a>, the <a href="/Your/Module.html">the Your::Module manpage</a> and <a href="/Their/Module.html">the Their::Module manpage</a>
-manpages and the other interesting file <em class="file">/usr/local/my/module/rocks</em>
-as well.</p>
-
-</body>
-
-</html>
Deleted: trunk/contrib/perl/lib/Pod/t/man-options.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/man-options.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/man-options.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,175 +0,0 @@
-#!/usr/bin/perl -w
-#
-# man-options.t -- Additional tests for Pod::Man options.
-#
-# Copyright 2002, 2004, 2006, 2008 Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..7\n";
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Man;
-
-# Redirect stderr to a file.
-sub stderr_save {
- open (OLDERR, '>&STDERR') or die "Can't dup STDERR: $!\n";
- open (STDERR, '> out.err') or die "Can't redirect STDERR: $!\n";
-}
-
-# Restore stderr.
-sub stderr_restore {
- close STDERR;
- open (STDERR, '>&OLDERR') or die "Can't dup STDERR: $!\n";
- close OLDERR;
-}
-
-$loaded = 1;
-print "ok 1\n";
-
-my $n = 2;
-while (<DATA>) {
- my %options;
- next until $_ eq "###\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- my ($option, $value) = split;
- $options{$option} = $value;
- }
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- my $parser = Pod::Man->new (%options) or die "Cannot create parser\n";
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- stderr_save;
- $parser->parse_from_file ('tmp.pod', \*OUT);
- stderr_restore;
- close OUT;
- my $accents = 0;
- open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- while (<TMP>) {
- last if /^\.nh/;
- }
- my $output;
- {
- local $/;
- $output = <TMP>;
- }
- close TMP;
- unlink ('tmp.pod', 'out.tmp');
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
- open (ERR, 'out.err') or die "Cannot open out.err: $!\n";
- my $errors;
- {
- local $/;
- $errors = <ERR>;
- }
- close ERR;
- unlink ('out.err');
- $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($errors eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected errors:\n ${expected}Errors:\n $errors";
- }
- $n++;
-}
-
-# Below the marker are bits of POD and corresponding expected text output.
-# This is used to test specific features or problems with Pod::Man. The
-# input and output are separated by lines containing only ###.
-
-__DATA__
-
-###
-fixed CR
-fixedbold CY
-fixeditalic CW
-fixedbolditalic CX
-###
-=head1 FIXED FONTS
-
-C<foo B<bar I<baz>> I<bay>>
-###
-.SH "FIXED FONTS"
-.IX Header "FIXED FONTS"
-\&\f(CR\*(C`foo \f(CYbar \f(CXbaz\f(CY\f(CR \f(CWbay\f(CR\*(C'\fR
-###
-###
-
-###
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
-.IP "Foo" 4
-.IX Item "Foo"
-Bar.
-.SH "NEXT"
-.IX Header "NEXT"
-.SH "POD ERRORS"
-.IX Header "POD ERRORS"
-Hey! \fBThe above document had some coding errors, which are explained below:\fR
-.IP "Around line 7:" 4
-.IX Item "Around line 7:"
-You forgot a '=back' before '=head1'
-###
-###
-
-###
-stderr 1
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
-.IP "Foo" 4
-.IX Item "Foo"
-Bar.
-.SH "NEXT"
-.IX Header "NEXT"
-###
-tmp.pod around line 7: You forgot a '=back' before '=head1'
-###
Deleted: trunk/contrib/perl/lib/Pod/t/man-utf8.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/man-utf8.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/man-utf8.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,141 +0,0 @@
-#!/usr/bin/perl -w
-#
-# man-options.t -- Additional tests for Pod::Man options.
-#
-# Copyright 2002, 2004, 2006, 2008 Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..5\n";
-
- # UTF-8 support requires Perl 5.8 or later.
- if ($] < 5.008) {
- my $n;
- for $n (1..5) {
- print "ok $n # skip -- Perl 5.8 required for UTF-8 support\n";
- }
- exit;
- }
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Man;
-
-$loaded = 1;
-print "ok 1\n";
-
-my $n = 2;
-eval { binmode (\*DATA, ':encoding(utf-8)') };
-eval { binmode (\*STDOUT, ':encoding(utf-8)') };
-while (<DATA>) {
- my %options;
- next until $_ eq "###\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- my ($option, $value) = split;
- $options{$option} = $value;
- }
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
- eval { binmode (\*TMP, ':encoding(utf-8)') };
- print TMP "=encoding utf-8\n\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- my $parser = Pod::Man->new (%options) or die "Cannot create parser\n";
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- $parser->parse_from_file ('tmp.pod', \*OUT);
- close OUT;
- my $accents = 0;
- open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- eval { binmode (\*TMP, ':encoding(utf-8)') };
- while (<TMP>) {
- $accents = 1 if /Accent mark definitions/;
- last if /^\.nh/;
- }
- my $output;
- {
- local $/;
- $output = <TMP>;
- }
- close TMP;
- unlink ('tmp.pod', 'out.tmp');
- if (($options{utf8} && !$accents) || (!$options{utf8} && $accents)) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print ($accents ? "Saw accents\n" : "Saw no accents\n");
- print ($options{utf8} ? "Wanted no accents\n" : "Wanted accents\n");
- }
- $n++;
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
-}
-
-# Below the marker are bits of POD and corresponding expected text output.
-# This is used to test specific features or problems with Pod::Man. The
-# input and output are separated by lines containing only ###.
-
-__DATA__
-
-###
-utf8 1
-###
-=head1 BEYONCÉ
-
-Beyoncé! Beyoncé! Beyoncé!!
-
- Beyoncé! Beyoncé!
- Beyoncé! Beyoncé!
- Beyoncé! Beyoncé!
-
-Older versions did not convert Beyoncé in verbatim.
-###
-.SH "BEYONCÉ"
-.IX Header "BEYONCÉ"
-Beyoncé! Beyoncé! Beyoncé!!
-.PP
-.Vb 3
-\& Beyoncé! Beyoncé!
-\& Beyoncé! Beyoncé!
-\& Beyoncé! Beyoncé!
-.Ve
-.PP
-Older versions did not convert Beyoncé in verbatim.
-###
-
-###
-utf8 1
-###
-=head1 SE<lt>E<gt> output with UTF-8
-
-This is S<non-breaking output>.
-###
-.SH "S<> output with UTF\-8"
-.IX Header "S<> output with UTF-8"
-This is non-breaking output.
-###
Deleted: trunk/contrib/perl/lib/Pod/t/man.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/man.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/man.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,484 +0,0 @@
-#!/usr/bin/perl -w
-#
-# man.t -- Additional specialized tests for Pod::Man.
-#
-# Copyright 2002, 2003, 2004, 2006, 2007, 2008
-# Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..25\n";
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Man;
-
-$loaded = 1;
-print "ok 1\n";
-
-# Test whether we can use binmode to set encoding.
-my $have_encoding = (eval { require PerlIO::encoding; 1 } and not $@);
-
-my $parser = Pod::Man->new or die "Cannot create parser\n";
-my $n = 2;
-while (<DATA>) {
- next until $_ eq "###\n";
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
-
- # We have a test in ISO 8859-1 encoding. Make sure that nothing strange
- # happens if Perl thinks the world is Unicode. Wrap this in eval so that
- # older versions of Perl don't croak.
- eval { binmode (\*TMP, ':encoding(iso-8859-1)') if $have_encoding };
-
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- $parser->parse_from_file ('tmp.pod', \*OUT);
- close OUT;
- open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- while (<OUT>) { last if /^\.nh/ }
- my $output;
- {
- local $/;
- $output = <OUT>;
- }
- close OUT;
- unlink ('tmp.pod', 'out.tmp');
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
-}
-
-# Below the marker are bits of POD and corresponding expected nroff output.
-# This is used to test specific features or problems with Pod::Man. The input
-# and output are separated by lines containing only ###.
-
-__DATA__
-
-###
-=head1 NAME
-
-gcc - GNU project C and C++ compiler
-
-=head1 C++ NOTES
-
-Other mentions of C++.
-###
-.SH "NAME"
-gcc \- GNU project C and C++ compiler
-.SH "\*(C+ NOTES"
-.IX Header " NOTES"
-Other mentions of \*(C+.
-###
-
-###
-=head1 PERIODS
-
-This C<.> should be quoted.
-###
-.SH "PERIODS"
-.IX Header "PERIODS"
-This \f(CW\*(C`.\*(C'\fR should be quoted.
-###
-
-###
-=over 4
-
-=item *
-
-A bullet.
-
-=item *
-
-Another bullet.
-
-=item * Also a bullet.
-
-=back
-###
-.IP "\(bu" 4
-A bullet.
-.IP "\(bu" 4
-Another bullet.
-.IP "\(bu" 4
-Also a bullet.
-###
-
-###
-=over 4
-
-=item foo
-
-Not a bullet.
-
-=item *
-
-Also not a bullet.
-
-=back
-###
-.IP "foo" 4
-.IX Item "foo"
-Not a bullet.
-.IP "*" 4
-Also not a bullet.
-###
-
-###
-=encoding iso-8859-1
-
-=head1 ACCENTS
-
-Beyonc\xE9! Beyonc\xE9! Beyonc\xE9!!
-
- Beyonc\xE9! Beyonc\xE9!
- Beyonc\xE9! Beyonc\xE9!
- Beyonc\xE9! Beyonc\xE9!
-
-Older versions didn't convert Beyonc\xE9 in verbatim.
-###
-.SH "ACCENTS"
-.IX Header "ACCENTS"
-Beyonce\*'! Beyonce\*'! Beyonce\*'!!
-.PP
-.Vb 3
-\& Beyonce\*'! Beyonce\*'!
-\& Beyonce\*'! Beyonce\*'!
-\& Beyonce\*'! Beyonce\*'!
-.Ve
-.PP
-Older versions didn't convert Beyonce\*' in verbatim.
-###
-
-###
-=over 4
-
-=item 1. Not a number
-
-=item 2. Spaced right
-
-=back
-
-=over 2
-
-=item 1 Not a number
-
-=item 2 Spaced right
-
-=back
-###
-.IP "1. Not a number" 4
-.IX Item "1. Not a number"
-.PD 0
-.IP "2. Spaced right" 4
-.IX Item "2. Spaced right"
-.IP "1 Not a number" 2
-.IX Item "1 Not a number"
-.IP "2 Spaced right" 2
-.IX Item "2 Spaced right"
-###
-
-###
-=over 4
-
-=item Z<>*
-
-Not bullet.
-
-=back
-###
-.IP "*" 4
-Not bullet.
-###
-
-###
-=head1 SEQS
-
-"=over ... Z<>=back"
-
-"SE<lt>...E<gt>"
-
-The quotes should be converted in the above to paired quotes.
-###
-.SH "SEQS"
-.IX Header "SEQS"
-\&\*(L"=over ... =back\*(R"
-.PP
-\&\*(L"S<...>\*(R"
-.PP
-The quotes should be converted in the above to paired quotes.
-###
-
-###
-=head1 YEN
-
-It cost me E<165>12345! That should be an X.
-###
-.SH "YEN"
-.IX Header "YEN"
-It cost me X12345! That should be an X.
-###
-
-###
-=head1 agrave
-
-Open E<agrave> la shell. Previous versions mapped it wrong.
-###
-.SH "agrave"
-.IX Header "agrave"
-Open a\*` la shell. Previous versions mapped it wrong.
-###
-
-###
-=over
-
-=item First level
-
-Blah blah blah....
-
-=over
-
-=item *
-
-Should be a bullet.
-
-=back
-
-=back
-###
-.IP "First level" 4
-.IX Item "First level"
-Blah blah blah....
-.RS 4
-.IP "\(bu" 4
-Should be a bullet.
-.RE
-.RS 4
-.RE
-###
-
-###
-=over 4
-
-=item 1. Check fonts in @CARP_NOT test.
-
-=back
-###
-.ie n .IP "1. Check fonts in @CARP_NOT test." 4
-.el .IP "1. Check fonts in \f(CW at CARP_NOT\fR test." 4
-.IX Item "1. Check fonts in @CARP_NOT test."
-###
-
-###
-=head1 LINK QUOTING
-
-There should not be double quotes: L<C<< (?>pattern) >>>.
-###
-.SH "LINK QUOTING"
-.IX Header "LINK QUOTING"
-There should not be double quotes: \f(CW\*(C`(?>pattern)\*(C'\fR.
-###
-
-###
-=head1 SE<lt>E<gt> MAGIC
-
-Magic should be applied S<RISC OS> to that.
-###
-.SH "S<> MAGIC"
-.IX Header "S<> MAGIC"
-Magic should be applied \s-1RISC\s0\ \s-1OS\s0 to that.
-###
-
-###
-=head1 MAGIC MONEY
-
-These should be identical.
-
-Bippity boppity boo "The
-price is $Z<>100."
-
-Bippity boppity boo "The
-price is $100."
-###
-.SH "MAGIC MONEY"
-.IX Header "MAGIC MONEY"
-These should be identical.
-.PP
-Bippity boppity boo \*(L"The
-price is \f(CW$100\fR.\*(R"
-.PP
-Bippity boppity boo \*(L"The
-price is \f(CW$100\fR.\*(R"
-###
-
-###
-=head1 NAME
-
-"Stuff" (no guesswork)
-
-=head2 THINGS
-
-Oboy, is this C++ "fun" yet! (guesswork)
-###
-.SH "NAME"
-"Stuff" (no guesswork)
-.SS "\s-1THINGS\s0"
-.IX Subsection "THINGS"
-Oboy, is this \*(C+ \*(L"fun\*(R" yet! (guesswork)
-###
-
-###
-=head1 Newline C Quote Weirdness
-
-Blorp C<'
-''>. Yes.
-###
-.SH "Newline C Quote Weirdness"
-.IX Header "Newline C Quote Weirdness"
-Blorp \f(CW\*(Aq
-\&\*(Aq\*(Aq\fR. Yes.
-###
-
-###
-=head1 Soft Hypen Testing
-
-sigE<shy>action
-manuE<shy>script
-JarkE<shy>ko HieE<shy>taE<shy>nieE<shy>mi
-
-And again:
-
-sigE<173>action
-manuE<173>script
-JarkE<173>ko HieE<173>taE<173>nieE<173>mi
-
-And one more time:
-
-sigE<0x00AD>action
-manuE<0x00AD>script
-JarkE<0x00AD>ko HieE<0x00AD>taE<0x00AD>nieE<0x00AD>mi
-###
-.SH "Soft Hypen Testing"
-.IX Header "Soft Hypen Testing"
-sig\%action
-manu\%script
-Jark\%ko Hie\%ta\%nie\%mi
-.PP
-And again:
-.PP
-sig\%action
-manu\%script
-Jark\%ko Hie\%ta\%nie\%mi
-.PP
-And one more time:
-.PP
-sig\%action
-manu\%script
-Jark\%ko Hie\%ta\%nie\%mi
-###
-
-###
-=head1 XE<lt>E<gt> Whitespace
-
-Blorpy L<B<prok>|blap> X<bivav> wugga chachacha.
-###
-.SH "X<> Whitespace"
-.IX Header "X<> Whitespace"
-Blorpy \fBprok\fR wugga chachacha.
-.IX Xref "bivav"
-###
-
-###
-=head1 Hyphen in SE<lt>E<gt>
-
-Don't S<transform even-this hyphen>. This "one's-fine!", as well. However,
-$-0.13 should have a real hyphen.
-###
-.SH "Hyphen in S<>"
-.IX Header "Hyphen in S<>"
-Don't transform\ even-this\ hyphen. This \*(L"one's-fine!\*(R", as well. However,
-$\-0.13 should have a real hyphen.
-###
-
-###
-=head1 Quote escaping
-
-Don't escape `this' but do escape C<`this'> (and don't surround it in quotes).
-###
-.SH "Quote escaping"
-.IX Header "Quote escaping"
-Don't escape `this' but do escape \f(CW\`this\*(Aq\fR (and don't surround it in quotes).
-###
-
-###
-=pod
-
-E<eth>
-###
-.PP
-\&\*(d-
-###
-
-###
-=head1 C<one> and C<two>
-###
-.ie n .SH """one"" and ""two"""
-.el .SH "\f(CWone\fP and \f(CWtwo\fP"
-.IX Header "one and two"
-###
-
-###
-=pod
-
-Some text.
-
-=for man
-Some raw nroff.
-
-=for roff \fBBold text.\fP
-
-=for html
-Stuff that's hidden.
-
-=for MAN \fIItalic text.\fP
-
-=for ROFF
-.PP
-\&A paragraph.
-
-More text.
-###
-Some text.
-Some raw nroff.
-\fBBold text.\fP
-\fIItalic text.\fP
-.PP
-\&A paragraph.
-.PP
-More text.
-###
Deleted: trunk/contrib/perl/lib/Pod/t/parselink.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/parselink.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/parselink.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,132 +0,0 @@
-#!/usr/bin/perl -w
-#
-# parselink.t -- Tests for Pod::ParseLink.
-#
-# Copyright 2001 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-# The format of each entry in this array is the L<> text followed by the
-# five-element parse returned by parselink. When adding a new test, also
-# increment the test count in the BEGIN block below. We don't use any of the
-# fancy test modules intentionally for backward compatibility to older
-# versions of Perl.
- at TESTS = (
- [ 'foo',
- undef, 'foo', 'foo', undef, 'pod' ],
-
- [ 'foo|bar',
- 'foo', 'foo', 'bar', undef, 'pod' ],
-
- [ 'foo/bar',
- undef, '"bar" in foo', 'foo', 'bar', 'pod' ],
-
- [ 'foo/"baz boo"',
- undef, '"baz boo" in foo', 'foo', 'baz boo', 'pod' ],
-
- [ '/bar',
- undef, '"bar"', undef, 'bar', 'pod' ],
-
- [ '/"baz boo"',
- undef, '"baz boo"', undef, 'baz boo', 'pod' ],
-
- [ '/baz boo',
- undef, '"baz boo"', undef, 'baz boo', 'pod' ],
-
- [ 'foo bar/baz boo',
- undef, '"baz boo" in foo bar', 'foo bar', 'baz boo', 'pod' ],
-
- [ 'foo bar / baz boo',
- undef, '"baz boo" in foo bar', 'foo bar', 'baz boo', 'pod' ],
-
- [ "foo\nbar\nbaz\n/\nboo",
- undef, '"boo" in foo bar baz', 'foo bar baz', 'boo', 'pod' ],
-
- [ 'anchor|name/section',
- 'anchor', 'anchor', 'name', 'section', 'pod' ],
-
- [ '"boo var baz"',
- undef, '"boo var baz"', undef, 'boo var baz', 'pod' ],
-
- [ 'bar baz',
- undef, '"bar baz"', undef, 'bar baz', 'pod' ],
-
- [ '"boo bar baz / baz boo"',
- undef, '"boo bar baz / baz boo"', undef, 'boo bar baz / baz boo',
- 'pod' ],
-
- [ 'fooZ<>bar',
- undef, 'fooZ<>bar', 'fooZ<>bar', undef, 'pod' ],
-
- [ 'Testing I<italics>|foo/bar',
- 'Testing I<italics>', 'Testing I<italics>', 'foo', 'bar', 'pod' ],
-
- [ 'foo/I<Italic> text',
- undef, '"I<Italic> text" in foo', 'foo', 'I<Italic> text', 'pod' ],
-
- [ 'fooE<verbar>barZ<>/Section C<with> I<B<other> markup',
- undef, '"Section C<with> I<B<other> markup" in fooE<verbar>barZ<>',
- 'fooE<verbar>barZ<>', 'Section C<with> I<B<other> markup', 'pod' ],
-
- [ 'Nested L<http://www.perl.org/>|fooE<sol>bar',
- 'Nested L<http://www.perl.org/>', 'Nested L<http://www.perl.org/>',
- 'fooE<sol>bar', undef, 'pod' ],
-
- [ 'ls(1)',
- undef, 'ls(1)', 'ls(1)', undef, 'man' ],
-
- [ ' perlfunc(1)/open ',
- undef, '"open" in perlfunc(1)', 'perlfunc(1)', 'open', 'man' ],
-
- [ 'some manual page|perl(1)',
- 'some manual page', 'some manual page', 'perl(1)', undef, 'man' ],
-
- [ 'http://www.perl.org/',
- undef, 'http://www.perl.org/', 'http://www.perl.org/', undef, 'url' ],
-
- [ 'news:yld72axzc8.fsf at windlord.stanford.edu',
- undef, 'news:yld72axzc8.fsf at windlord.stanford.edu',
- 'news:yld72axzc8.fsf at windlord.stanford.edu', undef, 'url' ]
-);
-
-BEGIN {
- chdir 't' if -d 't';
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..25\n";
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::ParseLink;
-$loaded = 1;
-print "ok 1\n";
-
-# Used for reporting test failures.
-my @names = qw(text inferred name section type);
-
-my $n = 2;
-for (@TESTS) {
- my @expected = @$_;
- my $link = shift @expected;
- my @results = parselink ($link);
- my $okay = 1;
- for (0..4) {
- # Make sure to check undef explicitly; we don't want undef to match
- # the empty string because they're semantically different.
- unless ((!defined ($results[$_]) && !defined ($expected[$_]))
- || (defined ($results[$_]) && defined ($expected[$_])
- && $results[$_] eq $expected[$_])) {
- print "not ok $n\n" if $okay;
- print "# Incorrect $names[$_]:\n";
- print "# expected: $expected[$_]\n";
- print "# seen: $results[$_]\n";
- $okay = 0;
- }
- }
- print "ok $n\n" if $okay;
- $n++;
-}
Deleted: trunk/contrib/perl/lib/Pod/t/pod-parser.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod-parser.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/pod-parser.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,102 +0,0 @@
-#!/usr/bin/perl -w
-#
-# pod-parser.t -- Tests for backward compatibility with Pod::Parser.
-#
-# Copyright 2006, 2008 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..4\n";
-}
-
-my $loaded;
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Man;
-use Pod::Text;
-use strict;
-
-$loaded = 1;
-print "ok 1\n";
-
-my $parser = Pod::Man->new or die "Cannot create parser\n";
-open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
-print TMP "Some random B<text>.\n";
-close TMP;
-open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
-$parser->parse_from_file ({ -cutting => 0 }, 'tmp.pod', \*OUT);
-close OUT;
-open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
-while (<OUT>) { last if /^\.nh/ }
-my $output;
-{
- local $/;
- $output = <OUT>;
-}
-close OUT;
-if ($output eq "Some random \\fBtext\\fR.\n") {
- print "ok 2\n";
-} else {
- print "not ok 2\n";
- print "Expected\n========\nSome random \\fBtext\\fR.\n\n";
- print "Output\n======\n$output\n";
-}
-
-$parser = Pod::Text->new or die "Cannot create parser\n";
-open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
-$parser->parse_from_file ({ -cutting => 0 }, 'tmp.pod', \*OUT);
-close OUT;
-open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
-{
- local $/;
- $output = <OUT>;
-}
-close OUT;
-if ($output eq " Some random text.\n\n") {
- print "ok 3\n";
-} else {
- print "not ok 3\n";
- print "Expected\n========\n Some random text.\n\n\n";
- print "Output\n======\n$output\n";
-}
-
-# Test the pod2text function, particularly with only one argument.
-open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
-print TMP "=pod\n\nSome random B<text>.\n";
-close TMP;
-open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
-open (SAVE, '>&STDOUT') or die "Cannot dup stdout: $!\n";
-open (STDOUT, '>&OUT') or die "Cannot replace stdout: $!\n";
-pod2text ('tmp.pod');
-close OUT;
-open (STDOUT, '>&SAVE') or die "Cannot fix stdout: $!\n";
-close SAVE;
-open (OUT, 'out.tmp') or die "Cannot open out.tmp: $!\n";
-{
- local $/;
- $output = <OUT>;
-}
-close OUT;
-if ($output eq " Some random text.\n\n") {
- print "ok 4\n";
-} else {
- print "not ok 4\n";
- print "Expected\n========\n Some random text.\n\n\n";
- print "Output\n======\n$output\n";
-}
-
-unlink ('tmp.pod', 'out.tmp');
-exit 0;
Deleted: trunk/contrib/perl/lib/Pod/t/pod-spelling.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod-spelling.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/pod-spelling.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,76 +0,0 @@
-#!/usr/bin/perl
-#
-# t/pod-spelling.t -- Test POD spelling.
-#
-# Copyright 2008 Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-# Called to skip all tests with a reason.
-sub skip_all {
- print "1..0 # Skipped: @_\n";
- exit;
-}
-
-# Skip all spelling tests unless flagged to run maintainer tests.
-skip_all "Spelling tests only run for maintainer"
- unless $ENV{RRA_MAINTAINER_TESTS};
-
-# Make sure we have prerequisites. hunspell is currently not supported due to
-# lack of support for contractions.
-eval 'use Test::Pod 1.00';
-skip_all "Test::Pod 1.00 required for testing POD" if $@;
-eval 'use Pod::Spell';
-skip_all "Pod::Spell required to test POD spelling" if $@;
-my @spell;
-my %options = (aspell => [ qw(-d en_US --home-dir=./ list) ],
- ispell => [ qw(-d american -l -p /dev/null) ]);
-SEARCH: for my $program (qw/aspell ispell/) {
- for my $dir (split ':', $ENV{PATH}) {
- if (-x "$dir/$program") {
- @spell = ("$dir/$program", @{ $options{$program} });
- }
- last SEARCH if @spell;
- }
-}
-skip_all "aspell or ispell required to test POD spelling" unless @spell;
-
-# Run the test, one for each POD file.
-$| = 1;
-my @pod = all_pod_files ();
-my $count = scalar @pod;
-print "1..$count\n";
-my $n = 1;
-for my $pod (@pod) {
- my $child = open (CHILD, '-|');
- if (not defined $child) {
- die "Cannot fork: $!\n";
- } elsif ($child == 0) {
- my $pid = open (SPELL, '|-', @spell)
- or die "Cannot run @spell: $!\n";
- open (POD, '<', $pod) or die "Cannot open $pod: $!\n";
- my $parser = Pod::Spell->new;
- $parser->parse_from_filehandle (\*POD, \*SPELL);
- close POD;
- close SPELL;
- exit ($? >> 8);
- } else {
- my @words = <CHILD>;
- close CHILD;
- if ($? != 0) {
- print "ok $n # skip - @spell failed: $?\n";
- } elsif (@words) {
- for (@words) {
- s/^\s+//;
- s/\s+$//;
- }
- print "not ok $n\n";
- print " - Misspelled words found in $pod\n";
- print " @words\n";
- } else {
- print "ok $n\n";
- }
- $n++;
- }
-}
Deleted: trunk/contrib/perl/lib/Pod/t/pod.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/pod.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,11 +0,0 @@
-#!/usr/bin/perl
-#
-# t/pod.t -- Test POD formatting.
-
-eval 'use Test::Pod 1.00';
-if ($@) {
- print "1..1\n";
- print "ok 1 # skip - Test::Pod 1.00 required for testing POD\n";
- exit;
-}
-all_pod_files_ok ();
Deleted: trunk/contrib/perl/lib/Pod/t/pod2html-lib.pl
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod2html-lib.pl 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/pod2html-lib.pl 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,62 +0,0 @@
-require Cwd;
-require Pod::Html;
-require Config;
-use File::Spec::Functions;
-
-sub convert_n_test {
- my($podfile, $testname) = @_;
-
- my $cwd = Cwd::cwd();
- my $base_dir = catdir $cwd, updir(), "lib", "Pod";
- my $new_dir = catdir $base_dir, "t";
- my $infile = catfile $new_dir, "$podfile.pod";
- my $outfile = catfile $new_dir, "$podfile.html";
-
- Pod::Html::pod2html(
- "--podpath=t",
- "--podroot=$base_dir",
- "--htmlroot=/",
- "--infile=$infile",
- "--outfile=$outfile"
- );
-
-
- my ($expect, $result);
- {
- local $/;
- # expected
- $expect = <DATA>;
- $expect =~ s/\[PERLADMIN\]/$Config::Config{perladmin}/;
- if (ord("A") == 193) { # EBCDIC.
- $expect =~ s/item_mat_3c_21_3e/item_mat_4c_5a_6e/;
- }
-
- # result
- open my $in, $outfile or die "cannot open $outfile: $!";
- $result = <$in>;
- close $in;
- }
-
- ok($expect eq $result, $testname) or do {
- my $diff = '/bin/diff';
- -x $diff or $diff = '/usr/bin/diff';
- if (-x $diff) {
- my $expectfile = "pod2html-lib.tmp";
- open my $tmpfile, ">", $expectfile or die $!;
- print $tmpfile $expect;
- close $tmpfile;
- my $diffopt = $^O eq 'linux' ? 'u' : 'c';
- open my $diff, "diff -$diffopt $expectfile $outfile |" or die $!;
- print "# $_" while <$diff>;
- close $diff;
- unlink $expectfile;
- }
- };
-
- # pod2html creates these
- 1 while unlink $outfile;
- 1 while unlink "pod2htmd.tmp";
- 1 while unlink "pod2htmi.tmp";
-}
-
-1;
Deleted: trunk/contrib/perl/lib/Pod/t/pod2latex.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/pod2latex.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/pod2latex.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,401 +0,0 @@
-#!perl
-# Test that Pod::LaTeX works
-# This test relies on the DATA filehandle
-# DATA contains the latex that is used for comparison
-# and the pod that was used to generate it. The two
-# are separated by '=pod'
-# Note that if the translator is adjusted the output tex
-# will probably not match what is currently there. You
-# will need to adjust it to match (assuming it is correct).
-
-use Test;
-use strict;
-
-BEGIN { plan tests => 177 }
-
-use Pod::LaTeX;
-
-# The link parsing changed between v0.22 and v0.30 of Pod::ParseUtils
-use Pod::ParseUtils;
-my $linkver = $Pod::ParseUtils::VERSION;
-
-# Set up an END block to remove the test output file
-END {
- unlink "test.tex";
-};
-
-ok(1);
-
-# First thing to do is to read the expected output from
-# the DATA filehandle and store it in a scalar.
-# Do this until we read an =pod
-my @reference;
-while (my $line = <DATA>) {
- last if $line =~ /^=pod/;
- push(@reference,$line);
-}
-
-# Create a new parser
-my $parser = Pod::LaTeX->new;
-ok($parser);
-$parser->Head1Level(1);
-# Add the preamble but remember not to compare the timestamps
-$parser->AddPreamble(1);
-$parser->AddPostamble(1);
-
-# For a laugh add a table of contents
-$parser->TableOfContents(1);
-
-# Create an output file
-open(OUTFH, "> test.tex" ) or die "Unable to open test tex file: $!\n";
-
-# Read from the DATA filehandle and write to a new output file
-# Really want to write this to a scalar
-$parser->parse_from_filehandle(\*DATA,\*OUTFH);
-
-close(OUTFH) or die "Error closing OUTFH test.tex: $!\n";
-
-# Now read in OUTFH and compare
-open(INFH, "< test.tex") or die "Unable to read test tex file: $!\n";
-my @output = <INFH>;
-
-ok(@output, @reference);
-for my $i (0..$#reference) {
- next if $reference[$i] =~ /^%%/; # skip timestamp comments
-
- # if we are running a new version of Pod::ParseUtils we need
- # to change the link text. This is a kluge until we drop support
- # for older versions of Pod::ParseUtils
- if ($linkver < 0.29 && $output[$i] =~ /manpage/) {
- # convert our expectations from new to old new format
- $reference[$i] =~ s/Standard link: \\emph\{Pod::LaTeX\}/Standard link: the \\emph\{Pod::LaTeX\} manpage/;
- $reference[$i] =~ s/\\textsf\{sec\} in \\emph\{Pod::LaTeX\}/the section on \\textsf\{sec\} in the \\emph\{Pod::LaTeX\} manpage/;
- }
- ok($output[$i], $reference[$i]);
-}
-
-close(INFH) or die "Error closing INFH test.tex: $!\n";
-
-
-__DATA__
-\documentclass{article}
-\usepackage[T1]{fontenc}
-\usepackage{textcomp}
-
-%% Latex generated from POD in document (unknown)
-%% Using the perl module Pod::LaTeX
-%% Converted on Sat Apr 5 21:16:02 2003
-
-
-\usepackage{makeidx}
-\makeindex
-
-
-\begin{document}
-
-\tableofcontents
-
-\section{Introduction\label{Introduction}\index{Introduction}}
-\begin{itemize}
-
-\item
-
-Always check the return codes of system calls. Good error messages should
-go to STDERR, include which program caused the problem, what the failed
-system call and arguments were, and (\textbf{very important}) should contain
-the standard system error message for what went wrong. Here's a simple
-but sufficient example:
-
-\begin{verbatim}
- opendir(D, $dir) or die "can't opendir $dir: $!";
-\end{verbatim}
-
-\item
-
-Line up your transliterations when it makes sense:
-
-\begin{verbatim}
- tr [abc]
- [xyz];
-\end{verbatim}
-
-
-The above should be aligned since it includes an embedded tab.
-
-
-\item
-
-Think about reusability. Why waste brainpower on a one-shot when you
-might want to do something like it again? Consider generalizing your
-code. Consider writing a module or object class. Consider making your
-code run cleanly with \texttt{use strict} and \texttt{-w} (or \texttt{use warnings} in
-Perl 5.6) in effect. Consider giving away your code. Consider changing
-your whole world view. Consider... oh, never mind.
-
-
-\item
-
-Be consistent.
-
-
-\item
-
-Be nice.
-
-\end{itemize}
-\section{Links\label{Links}\index{Links}}
-
-
-This link should just include one word: \textsf{Pod::LaTeX}
-
-
-
-This link should include the text \texttt{test} even though
-it refers to \texttt{Pod::LaTeX}: \textsf{test}.
-
-
-
-Standard link: \emph{Pod::LaTeX}.
-
-
-
-Now refer to an external section: \textsf{sec} in \emph{Pod::LaTeX}
-
-\section{Lists\label{Lists}\index{Lists}}
-
-
-Test description list with long lines
-
-\begin{description}
-
-\item[{Some short text}] \mbox{}
-
-Some additional para.
-
-\begin{itemize}
-
-\item
-
-Nested itemized list
-
-
-\item
-
-Second item
-
-\end{itemize}
-
-\item[{some longer text than that}] \mbox{}
-
-and again.
-
-
-\item[{this text is even longer and greater than}] \textbf{40 characters}
-
-Some more content for the item.
-
-
-\item[{this is some text with \textit{something across}}] \textbf{the 40 char boundary}
-
-This is item content.
-
-
-\item[{square [ bracket in item}] \mbox{}
-
-Square bracket content
-
-\end{description}
-
-
-And this should be an enumerated list without any cruft after the numbers or additional numbers at all.
-
-\begin{enumerate}
-
-\item
-
-item 1
-
-
-\item
-
-item 2
-
-\end{enumerate}
-\section{Escapes\label{Escapes}\index{Escapes}}
-
-
-Test some normal escapes such as $<$ (lt) and $>$ (gt) and $|$ (verbar) and
-\texttt{\~{}} (tilde) and \& (amp) as well as $<$ (Esc lt) and $|$ (Esc
-verbar) and \textfractionsolidus{} (Esc sol) and $>$ (Esc gt) and \& (Esc amp)
-and " (Esc quot) and even $\alpha$ (Esc alpha).
-
-\section{For blocks\label{For_blocks}\index{For blocks}}
- Some latex code \textbf{here}.
-
-
-
-Some text that should appear.
-
-
-
-Some more text that should appear
-
-Some latex in a \textsf{begin block}
-
-and some more
-
-\begin{equation}
-a = \frac{3}{2}
-\end{equation}
-
-
-
-Back to pod.
-
-\printindex
-
-\end{document}
-=pod
-
-=head1 Introduction
-
-=over 4
-
-=item *
-
-Always check the return codes of system calls. Good error messages should
-go to STDERR, include which program caused the problem, what the failed
-system call and arguments were, and (B<very important>) should contain
-the standard system error message for what went wrong. Here's a simple
-but sufficient example:
-
- opendir(D, $dir) or die "can't opendir $dir: $!";
-
-=item *
-
-Line up your transliterations when it makes sense:
-
- tr [abc]
- [xyz];
-
-The above should be aligned since it includes an embedded tab.
-
-=item *
-
-Think about reusability. Why waste brainpower on a one-shot when you
-might want to do something like it again? Consider generalizing your
-code. Consider writing a module or object class. Consider making your
-code run cleanly with C<use strict> and C<-w> (or C<use warnings> in
-Perl 5.6) in effect. Consider giving away your code. Consider changing
-your whole world view. Consider... oh, never mind.
-
-=item *
-
-Be consistent.
-
-=item *
-
-Be nice.
-
-=back
-
-=head1 Links
-
-This link should just include one word: L<Pod::LaTeX|Pod::LaTeX>
-
-This link should include the text C<test> even though
-it refers to C<Pod::LaTeX>: L<test|Pod::LaTeX>.
-
-Standard link: L<Pod::LaTeX>.
-
-Now refer to an external section: L<Pod::LaTeX/"sec">
-
-
-=head1 Lists
-
-Test description list with long lines
-
-=over 4
-
-=item Some short text
-
-Some additional para.
-
-=over 4
-
-=item *
-
-Nested itemized list
-
-=item *
-
-Second item
-
-=back
-
-=item some longer text than that
-
-and again.
-
-=item this text is even longer and greater than 40 characters
-
-Some more content for the item.
-
-=item this is some text with I<something across> the 40 char boundary
-
-This is item content.
-
-=item square [ bracket in item
-
-Square bracket content
-
-=back
-
-And this should be an enumerated list without any cruft after the numbers or additional numbers at all.
-
-=over 4
-
-=item 1)
-
-item 1
-
-=item 2.
-
-item 2
-
-=back
-
-=head1 Escapes
-
-Test some normal escapes such as < (lt) and > (gt) and | (verbar) and
-~ (tilde) and & (amp) as well as E<lt> (Esc lt) and E<verbar> (Esc
-verbar) and E<sol> (Esc sol) and E<gt> (Esc gt) and E<amp> (Esc amp)
-and E<quot> (Esc quot) and even E<alpha> (Esc alpha).
-
-=head1 For blocks
-
-=for latex
- Some latex code \textbf{here}.
-
-Some text that should appear.
-
-=for comment
- Should not print anything
-
-Some more text that should appear
-
-=begin latex
-
-Some latex in a \textsf{begin block}
-
-and some more
-
-\begin{equation}
-a = \frac{3}{2}
-\end{equation}
-
-=end latex
-
-Back to pod.
-
-=cut
Deleted: trunk/contrib/perl/lib/Pod/t/termcap.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/termcap.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/termcap.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,85 +0,0 @@
-#!/usr/bin/perl -w
-#
-# termcap.t -- Additional specialized tests for Pod::Text::Termcap.
-#
-# Copyright 2002, 2004, 2006 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..2\n";
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-# Hard-code a few values to try to get reproducible results.
-$ENV{COLUMNS} = 80;
-$ENV{TERM} = 'xterm';
-$ENV{TERMCAP} = 'xterm:co=80:do=^J:md=\E[1m:us=\E[4m:me=\E[m';
-
-use Pod::Text::Termcap;
-
-$loaded = 1;
-print "ok 1\n";
-
-my $parser = Pod::Text::Termcap->new or die "Cannot create parser\n";
-my $n = 2;
-while (<DATA>) {
- next until $_ eq "###\n";
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- $parser->parse_from_file ('tmp.pod', \*OUT);
- close OUT;
- open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- my $output;
- {
- local $/;
- $output = <TMP>;
- }
- close TMP;
- unlink ('tmp.pod', 'out.tmp');
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
-}
-
-# Below the marker are bits of POD and corresponding expected output. This is
-# used to test specific features or problems with Pod::Text::Termcap. The
-# input and output are separated by lines containing only ###.
-
-__DATA__
-
-###
-=head1 WRAPPING
-
-B<I<Do>> I<B<not>> B<I<include>> B<I<formatting codes when>> B<I<wrapping>>.
-###
-[1mWRAPPING[m
- [1m[4mDo[m[m [4m[1mnot[m[m [1m[4minclude[m[m [1m[4mformatting codes when[m[m [1m[4mwrapping[m[m.
-
-###
Deleted: trunk/contrib/perl/lib/Pod/t/text-encoding.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/text-encoding.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/text-encoding.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,142 +0,0 @@
-#!/usr/bin/perl -w
-#
-# text-encoding.t -- Test Pod::Text with various weird encoding combinations.
-#
-# Copyright 2002, 2004, 2006, 2007, 2008 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..4\n";
-
- # PerlIO encoding support requires Perl 5.8 or later.
- if ($] < 5.008) {
- my $n;
- for $n (1..4) {
- print "ok $n # skip -- Perl 5.8 required for UTF-8 support\n";
- }
- exit;
- }
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Text;
-
-$loaded = 1;
-print "ok 1\n";
-
-my $n = 2;
-eval { binmode (\*DATA, ':raw') };
-eval { binmode (\*STDOUT, ':raw') };
-while (<DATA>) {
- my %opts;
- $opts{utf8} = 1 if $n == 4;
- my $parser = Pod::Text->new (%opts) or die "Cannot create parser\n";
- next until $_ eq "###\n";
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
- eval { binmode (\*TMP, ':raw') };
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- eval { binmode (\*OUT, ':raw') };
- $parser->parse_from_file ('tmp.pod', \*OUT);
- close OUT;
- open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- eval { binmode (\*TMP, ':raw') };
- my $output;
- {
- local $/;
- $output = <TMP>;
- }
- close TMP;
- unlink ('tmp.pod', 'out.tmp');
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
-}
-
-# Below the marker are bits of POD and corresponding expected text output.
-# This is used to test specific features or problems with Pod::Text. The
-# input and output are separated by lines containing only ###.
-
-__DATA__
-
-###
-=head1 Test of SE<lt>E<gt>
-
-This is S<some whitespace>.
-###
-Test of S<>
- This is some whitespace.
-
-###
-
-###
-=encoding utf-8
-
-=head1 I can eat glass
-
-=over 4
-
-=item Esperanto
-
-Mi povas manÄi vitron, Äi ne damaÄas min.
-
-=item Braille
-
-⠊⠀⠉â â ⠀⠑â ⠞⠀⠛⠇â â Žâ Žâ €â â ⠙⠀⠊⠞⠀⠙⠕⠑⠎â ⠞⠀⠓⠥⠗⠞⠀â â ‘
-
-=item Hindi
-
-मैं काà¤à¤š खा सकता हूठऔर मà¥à¤à¥‡ उससे कोई चोट नहीं पहà¥à¤‚चती.
-
-=back
-
-See L<http://www.columbia.edu/kermit/utf8.html>
-###
-I can eat glass
- Esperanto
- Mi povas manÄi vitron, Äi ne damaÄas min.
-
- Braille
- ⠊⠀⠉â â ⠀⠑â ⠞⠀⠛⠇â â Žâ Žâ €â â ⠙⠀⠊⠞â
- €â ™â •â ‘â Žâ ⠞⠀⠓⠥⠗⠞⠀â â ‘
-
- Hindi
- मैं काà¤à¤š खा सकता हूठऔर
- मà¥à¤à¥‡ उससे कोई चोट नहीं
- पहà¥à¤‚चती.
-
- See <http://www.columbia.edu/kermit/utf8.html>
-
-###
-
-###
-=head1 Beyoncé
-###
-Beyoncé
-###
Deleted: trunk/contrib/perl/lib/Pod/t/text-options.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/text-options.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/text-options.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,271 +0,0 @@
-#!/usr/bin/perl -w
-#
-# text-options.t -- Additional tests for Pod::Text options.
-#
-# Copyright 2002, 2004, 2006, 2008 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..13\n";
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Text;
-
-# Redirect stderr to a file.
-sub stderr_save {
- open (OLDERR, '>&STDERR') or die "Can't dup STDERR: $!\n";
- open (STDERR, '> out.err') or die "Can't redirect STDERR: $!\n";
-}
-
-# Restore stderr.
-sub stderr_restore {
- close STDERR;
- open (STDERR, '>&OLDERR') or die "Can't dup STDERR: $!\n";
- close OLDERR;
-}
-
-$loaded = 1;
-print "ok 1\n";
-
-my $n = 2;
-while (<DATA>) {
- my %options;
- next until $_ eq "###\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- my ($option, $value) = split;
- $options{$option} = $value;
- }
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- my $parser = Pod::Text->new (%options) or die "Cannot create parser\n";
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- stderr_save;
- $parser->parse_from_file ('tmp.pod', \*OUT);
- stderr_restore;
- close OUT;
- open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- my $output;
- {
- local $/;
- $output = <TMP>;
- }
- close TMP;
- 1 while unlink ('tmp.pod', 'out.tmp');
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
- open (ERR, 'out.err') or die "Cannot open out.err: $!\n";
- my $errors;
- {
- local $/;
- $errors = <ERR>;
- }
- close ERR;
- unlink ('out.err');
- $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($errors eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected errors:\n ${expected}Errors:\n $errors";
- }
- $n++;
-}
-
-# Below the marker are bits of POD and corresponding expected text output.
-# This is used to test specific features or problems with Pod::Text. The
-# input and output are separated by lines containing only ###.
-
-__DATA__
-
-###
-alt 1
-###
-=head1 SAMPLE
-
-=over 4
-
-=item F
-
-Paragraph.
-
-=item Bar
-
-=item B
-
-Paragraph.
-
-=item Longer
-
-Paragraph.
-
-=back
-
-###
-
-==== SAMPLE ====
-
-: F Paragraph.
-
-: Bar
-: B Paragraph.
-
-: Longer
- Paragraph.
-
-###
-###
-
-###
-margin 4
-###
-=head1 SAMPLE
-
-This is some body text that is long enough to be a paragraph that wraps,
-thereby testing margins with wrapped paragraphs.
-
- This is some verbatim text.
-
-=over 6
-
-=item Test
-
-This is a test of an indented paragraph.
-
-This is another indented paragraph.
-
-=back
-###
- SAMPLE
- This is some body text that is long enough to be a paragraph that
- wraps, thereby testing margins with wrapped paragraphs.
-
- This is some verbatim text.
-
- Test This is a test of an indented paragraph.
-
- This is another indented paragraph.
-
-###
-###
-
-###
-code 1
-###
-This is some random text.
-This is more random text.
-
-This is some random text.
-This is more random text.
-
-=head1 SAMPLE
-
-This is POD.
-
-=cut
-
-This is more random text.
-###
-This is some random text.
-This is more random text.
-
-This is some random text.
-This is more random text.
-
-SAMPLE
- This is POD.
-
-
-This is more random text.
-###
-###
-
-###
-sentence 1
-###
-=head1 EXAMPLE
-
-Whitespace around C<< this. >> must be ignored per perlpodspec. >>
-needs to eat all of the space in front of it.
-
-=cut
-###
-EXAMPLE
- Whitespace around "this." must be ignored per perlpodspec. >> needs to
- eat all of the space in front of it.
-
-###
-###
-
-###
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
- Foo Bar.
-
-NEXT
-POD ERRORS
- Hey! The above document had some coding errors, which are explained
- below:
-
- Around line 7:
- You forgot a '=back' before '=head1'
-
-###
-###
-
-###
-stderr 1
-###
-=over 4
-
-=item Foo
-
-Bar.
-
-=head1 NEXT
-###
- Foo Bar.
-
-NEXT
-###
-tmp.pod around line 7: You forgot a '=back' before '=head1'
-###
Deleted: trunk/contrib/perl/lib/Pod/t/text-utf8.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/text-utf8.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/text-utf8.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,129 +0,0 @@
-#!/usr/bin/perl -w
-#
-# text-utf8.t -- Test Pod::Text with UTF-8 input.
-#
-# Copyright 2002, 2004, 2006, 2007, 2008 by Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..3\n";
-
- # UTF-8 support requires Perl 5.8 or later.
- if ($] < 5.008) {
- my $n;
- for $n (1..3) {
- print "ok $n # skip -- Perl 5.8 required for UTF-8 support\n";
- }
- exit;
- }
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Text;
-
-$loaded = 1;
-print "ok 1\n";
-
-my $parser = Pod::Text->new or die "Cannot create parser\n";
-my $n = 2;
-eval { binmode (\*DATA, ':encoding(utf-8)') };
-eval { binmode (\*STDOUT, ':encoding(utf-8)') };
-while (<DATA>) {
- next until $_ eq "###\n";
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
- eval { binmode (\*TMP, ':encoding(utf-8)') };
- print TMP "=encoding UTF-8\n\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- $parser->parse_from_file ('tmp.pod', \*OUT);
- close OUT;
- open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- eval { binmode (\*TMP, ':encoding(utf-8)') };
- my $output;
- {
- local $/;
- $output = <TMP>;
- }
- close TMP;
- unlink ('tmp.pod', 'out.tmp');
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
-}
-
-# Below the marker are bits of POD and corresponding expected text output.
-# This is used to test specific features or problems with Pod::Text. The
-# input and output are separated by lines containing only ###.
-
-__DATA__
-
-###
-=head1 Test of SE<lt>E<gt>
-
-This is S<some whitespace>.
-###
-Test of S<>
- This is some whitespace.
-
-###
-
-###
-=head1 I can eat glass
-
-=over 4
-
-=item Esperanto
-
-Mi povas manĝi vitron, ĝi ne damaĝas min.
-
-=item Braille
-
-⠊⠀⠉⠁⠝⠀⠑⠁⠞⠀⠛⠇⠁⠎⠎⠀⠁⠝⠙⠀⠊⠞⠀⠙⠕⠑⠎⠝⠞⠀⠓⠥⠗⠞⠀⠍⠑
-
-=item Hindi
-
-मैं काँच खा सकता हूँ और मुझे उससे कोई चोट नहीं पहुंचती.
-
-=back
-
-See L<http://www.columbia.edu/kermit/utf8.html>
-###
-I can eat glass
- Esperanto
- Mi povas manĝi vitron, ĝi ne damaĝas min.
-
- Braille
- ⠊⠀⠉⠁⠝⠀⠑⠁⠞⠀⠛⠇⠁⠎⠎⠀⠁⠝⠙⠀⠊⠞⠀⠙⠕⠑⠎⠝⠞⠀⠓⠥⠗⠞⠀⠍⠑
-
- Hindi
- मैं काँच खा सकता हूँ और मुझे उससे कोई चोट नहीं पहुंचती.
-
- See <http://www.columbia.edu/kermit/utf8.html>
-
-###
Deleted: trunk/contrib/perl/lib/Pod/t/text.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/text.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/text.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,147 +0,0 @@
-#!/usr/bin/perl -w
-#
-# text.t -- Additional specialized tests for Pod::Text.
-#
-# Copyright 2002, 2004, 2006, 2007, 2008, 2009 Russ Allbery <rra at stanford.edu>
-#
-# This program is free software; you may redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-BEGIN {
- chdir 't' if -d 't';
- if ($ENV{PERL_CORE}) {
- @INC = '../lib';
- } else {
- unshift (@INC, '../blib/lib');
- }
- unshift (@INC, '../blib/lib');
- $| = 1;
- print "1..6\n";
-}
-
-END {
- print "not ok 1\n" unless $loaded;
-}
-
-use Pod::Text;
-use Pod::Simple;
-
-$loaded = 1;
-print "ok 1\n";
-
-my $parser = Pod::Text->new or die "Cannot create parser\n";
-my $n = 2;
-while (<DATA>) {
- next until $_ eq "###\n";
- open (TMP, '> tmp.pod') or die "Cannot create tmp.pod: $!\n";
- while (<DATA>) {
- last if $_ eq "###\n";
- print TMP $_;
- }
- close TMP;
- open (OUT, '> out.tmp') or die "Cannot create out.tmp: $!\n";
- $parser->parse_from_file ('tmp.pod', \*OUT);
- close OUT;
- open (TMP, 'out.tmp') or die "Cannot open out.tmp: $!\n";
- my $output;
- {
- local $/;
- $output = <TMP>;
- }
- close TMP;
- unlink ('tmp.pod', 'out.tmp');
- my $expected = '';
- while (<DATA>) {
- last if $_ eq "###\n";
- $expected .= $_;
- }
- if ($output eq $expected) {
- print "ok $n\n";
- } elsif ($n == 4 && $Pod::Simple::VERSION < 3.06) {
- print "ok $n # skip Pod::Simple S<> parsing bug\n";
- } else {
- print "not ok $n\n";
- print "Expected\n========\n$expected\nOutput\n======\n$output\n";
- }
- $n++;
-}
-
-# Below the marker are bits of POD and corresponding expected text output.
-# This is used to test specific features or problems with Pod::Text. The
-# input and output are separated by lines containing only ###.
-
-__DATA__
-
-###
-=head1 PERIODS
-
-This C<.> should be quoted.
-###
-PERIODS
- This "." should be quoted.
-
-###
-
-###
-=head1 CE<lt>E<gt> WITH SPACES
-
-What does C<< this. >> end up looking like?
-###
-C<> WITH SPACES
- What does "this." end up looking like?
-
-###
-
-###
-=head1 Test of SE<lt>E<gt>
-
-This is some S< > whitespace.
-###
-Test of S<>
- This is some whitespace.
-
-###
-
-###
-=head1 Test of =for
-
-=for comment
-This won't be seen.
-
-Yes.
-
-=for text
-This should be seen.
-
-=for TEXT As should this.
-
-=for man
-But this shouldn't.
-
-Some more text.
-###
-Test of =for
- Yes.
-
-This should be seen.
-As should this.
- Some more text.
-
-###
-
-###
-=pod
-
-text
-
- line1
-
- line3
-###
- text
-
- line1
-
- line3
-
-###
Deleted: trunk/contrib/perl/lib/Pod/t/user.t
===================================================================
--- trunk/contrib/perl/lib/Pod/t/user.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Pod/t/user.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,104 +0,0 @@
-#!perl
-
-# Purpose: test UserPreamble and UserPostamble
-# It's a minor variation of 'pod2latex.t',
-# subject to the same limitations.
-# Variant provided by
-# Adriano Rodrigues Ferreira <ferreira at triang.com.br>
-
-use Test;
-use strict;
-
-BEGIN { plan tests => 17 }
-
-use Pod::LaTeX;
-
-# The link parsing changed between v0.22 and v0.30 of Pod::ParseUtils
-use Pod::ParseUtils;
-my $linkver = $Pod::ParseUtils::VERSION;
-
-# Set up an END block to remove the test output file
-END {
- unlink "test.tex";
-};
-
-ok(1);
-
-# First thing to do is to read the expected output from
-# the DATA filehandle and store it in a scalar.
-# Do this until we read an =pod
-my @reference;
-while (my $line = <DATA>) {
- last if $line =~ /^=pod/;
- push(@reference,$line);
-}
-
-my $user_preamble = <<PRE;
-
-\\documentclass{article}
-
-\\begin{document}
-PRE
-
-my $user_postamble = <<POST;
-\\end{document}
-
-POST
-
-# Create a new parser
-my %params = (
- UserPreamble => $user_preamble,
- UserPostamble => $user_postamble
-);
-
-my $parser = Pod::LaTeX->new(%params);
-ok($parser);
-
-# Create an output file
-open(OUTFH, "> test.tex" ) or die "Unable to open test tex file: $!\n";
-
-# Read from the DATA filehandle and write to a new output file
-# Really want to write this to a scalar
-$parser->parse_from_filehandle(\*DATA,\*OUTFH);
-
-close(OUTFH) or die "Error closing OUTFH test.tex: $!\n";
-
-# Now read in OUTFH and compare
-open(INFH, "< test.tex") or die "Unable to read test tex file: $!\n";
-my @output = <INFH>;
-
-ok(@output, @reference);
-
-for my $i (0..$#reference) {
- next if $reference[$i] =~ /^%%/; # skip timestamp comments
- ok($output[$i], $reference[$i]);
-}
-
-close(INFH) or die "Error closing INFH test.tex: $!\n";
-
-
-__DATA__
-
-\documentclass{article}
-
-\begin{document}
-
-%% Latex generated from POD in document (unknown)
-%% Using the perl module Pod::LaTeX
-%% Converted on Wed Jan 14 19:04:22 2004
-
-%% Preamble supplied by user.
-
-\section{POD\label{POD}\index{POD}}
-
-
-This is a POD file, very simple. \textit{Bye}.
-
-\end{document}
-
-=pod
-
-=head1 POD
-
-This is a POD file, very simple. I<Bye>.
-
Deleted: trunk/contrib/perl/lib/SelfLoader-buggy.t
===================================================================
--- trunk/contrib/perl/lib/SelfLoader-buggy.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/SelfLoader-buggy.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,48 +0,0 @@
-#!./perl
-
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
-}
-
-use SelfLoader;
-print "1..1\n";
-
-# this script checks that errors on self-loaded
-# subroutines that affect $@ are reported
-
-eval { buggy(); };
-unless ($@ =~ /^syntax error/) {
- print "not ";
-}
-print "ok 1 - syntax errors are reported\n";
-
-__END__
-
-sub buggy
-{
- +>*;
-}
-
-
-# RT 40216
-#
-# by Bo Lindbergh <blgl at hagernas.com>, at Aug 22, 2006 5:42 PM
-#
-# In the example below, there's a syntax error in the selfloaded
-# code for main::buggy. When the eval fails, SelfLoader::AUTOLOAD
-# tries to report this with "croak $@;". Unfortunately,
-# SelfLoader::croak does "require Carp;" without protecting $@,
-# which gets clobbered. The program then dies with the
-# uninformative message " at ./example line 3".
-#
-# #! /usr/local/bin/perl
-# use SelfLoader;
-# buggy();
-# __END__
-# sub buggy
-# {
-# +>*;
-# }
Deleted: trunk/contrib/perl/lib/SelfLoader.pm
===================================================================
--- trunk/contrib/perl/lib/SelfLoader.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/SelfLoader.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,435 +0,0 @@
-package SelfLoader;
-use 5.008;
-use strict;
-our $VERSION = "1.17";
-
-# The following bit of eval-magic is necessary to make this work on
-# perls < 5.009005.
-use vars qw/$AttrList/;
-BEGIN {
- if ($] > 5.009004) {
- eval <<'NEWERPERL';
-use 5.009005; # due to new regexp features
-# allow checking for valid ': attrlist' attachments
-# see also AutoSplit
-$AttrList = qr{
- \s* : \s*
- (?:
- # one attribute
- (?> # no backtrack
- (?! \d) \w+
- (?<nested> \( (?: [^()]++ | (?&nested)++ )*+ \) ) ?
- )
- (?: \s* : \s* | \s+ (?! :) )
- )*
-}x;
-
-NEWERPERL
- }
- else {
- eval <<'OLDERPERL';
-# allow checking for valid ': attrlist' attachments
-# (we use 'our' rather than 'my' here, due to the rather complex and buggy
-# behaviour of lexicals with qr// and (??{$lex}) )
-our $nested;
-$nested = qr{ \( (?: (?> [^()]+ ) | (??{ $nested }) )* \) }x;
-our $one_attr = qr{ (?> (?! \d) \w+ (?:$nested)? ) (?:\s*\:\s*|\s+(?!\:)) }x;
-$AttrList = qr{ \s* : \s* (?: $one_attr )* }x;
-OLDERPERL
- }
-}
-use Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT = qw(AUTOLOAD);
-sub Version {$VERSION}
-sub DEBUG () { 0 }
-
-my %Cache; # private cache for all SelfLoader's client packages
-
-# in croak and carp, protect $@ from "require Carp;" RT #40216
-
-sub croak { { local $@; require Carp; } goto &Carp::croak }
-sub carp { { local $@; require Carp; } goto &Carp::carp }
-
-AUTOLOAD {
- our $AUTOLOAD;
- print STDERR "SelfLoader::AUTOLOAD for $AUTOLOAD\n" if DEBUG;
- my $SL_code = $Cache{$AUTOLOAD};
- my $save = $@; # evals in both AUTOLOAD and _load_stubs can corrupt $@
- unless ($SL_code) {
- # Maybe this pack had stubs before __DATA__, and never initialized.
- # Or, this maybe an automatic DESTROY method call when none exists.
- $AUTOLOAD =~ m/^(.*)::/;
- SelfLoader->_load_stubs($1) unless exists $Cache{"${1}::<DATA"};
- $SL_code = $Cache{$AUTOLOAD};
- $SL_code = "sub $AUTOLOAD { }"
- if (!$SL_code and $AUTOLOAD =~ m/::DESTROY$/);
- croak "Undefined subroutine $AUTOLOAD" unless $SL_code;
- }
- print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if DEBUG;
-
- {
- no strict;
- eval $SL_code;
- }
- if ($@) {
- $@ =~ s/ at .*\n//;
- croak $@;
- }
- $@ = $save;
- defined(&$AUTOLOAD) || die "SelfLoader inconsistency error";
- delete $Cache{$AUTOLOAD};
- goto &$AUTOLOAD
-}
-
-sub load_stubs { shift->_load_stubs((caller)[0]) }
-
-sub _load_stubs {
- # $endlines is used by Devel::SelfStubber to capture lines after __END__
- my($self, $callpack, $endlines) = @_;
- no strict "refs";
- my $fh = \*{"${callpack}::DATA"};
- use strict;
- my $currpack = $callpack;
- my($line,$name, at lines, @stubs, $protoype);
-
- print STDERR "SelfLoader::load_stubs($callpack)\n" if DEBUG;
- croak("$callpack doesn't contain an __DATA__ token")
- unless defined fileno($fh);
- # Protect: fork() shares the file pointer between the parent and the kid
- if(sysseek($fh, tell($fh), 0)) {
- open my $nfh, '<&', $fh or croak "reopen: $!";# dup() the fd
- close $fh or die "close: $!"; # autocloses, but be paranoid
- open $fh, '<&', $nfh or croak "reopen2: $!"; # dup() the fd "back"
- close $nfh or die "close after reopen: $!"; # autocloses, but be paranoid
- }
- $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
-
- local($/) = "\n";
- while(defined($line = <$fh>) and $line !~ m/^__END__/) {
- if ($line =~ m/^\s*sub\s+([\w:]+)\s*((?:\([\\\$\@\%\&\*\;]*\))?(?:$AttrList)?)/) {
- push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
- $protoype = $2;
- @lines = ($line);
- if (index($1,'::') == -1) { # simple sub name
- $name = "${currpack}::$1";
- } else { # sub name with package
- $name = $1;
- $name =~ m/^(.*)::/;
- if (defined(&{"${1}::AUTOLOAD"})) {
- \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
- die 'SelfLoader Error: attempt to specify Selfloading',
- " sub $name in non-selfloading module $1";
- } else {
- $self->export($1,'AUTOLOAD');
- }
- }
- } elsif ($line =~ m/^package\s+([\w:]+)/) { # A package declared
- push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
- $self->_package_defined($line);
- $name = '';
- @lines = ();
- $currpack = $1;
- $Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
- if (defined(&{"${1}::AUTOLOAD"})) {
- \&{"${1}::AUTOLOAD"} == \&SelfLoader::AUTOLOAD ||
- die 'SelfLoader Error: attempt to specify Selfloading',
- " package $currpack which already has AUTOLOAD";
- } else {
- $self->export($currpack,'AUTOLOAD');
- }
- } else {
- push(@lines,$line);
- }
- }
- if (defined($line) && $line =~ /^__END__/) { # __END__
- unless ($line =~ /^__END__\s*DATA/) {
- if ($endlines) {
- # Devel::SelfStubber would like us to capture the lines after
- # __END__ so it can write out the entire file
- @$endlines = <$fh>;
- }
- close($fh);
- }
- }
- push(@stubs, $self->_add_to_cache($name, $currpack, \@lines, $protoype));
- no strict;
- eval join('', @stubs) if @stubs;
-}
-
-
-sub _add_to_cache {
- my($self,$fullname,$pack,$lines, $protoype) = @_;
- return () unless $fullname;
- carp("Redefining sub $fullname")
- if exists $Cache{$fullname};
- $Cache{$fullname} = join('', "\n\#line 1 \"sub $fullname\"\npackage $pack; ", @$lines);
- #$Cache{$fullname} = join('', "package $pack; ",@$lines);
- print STDERR "SelfLoader cached $fullname: $Cache{$fullname}" if DEBUG;
- # return stub to be eval'd
- defined($protoype) ? "sub $fullname $protoype;" : "sub $fullname;"
-}
-
-sub _package_defined {}
-
-1;
-__END__
-
-=head1 NAME
-
-SelfLoader - load functions only on demand
-
-=head1 SYNOPSIS
-
- package FOOBAR;
- use SelfLoader;
-
- ... (initializing code)
-
- __DATA__
- sub {....
-
-
-=head1 DESCRIPTION
-
-This module tells its users that functions in the FOOBAR package are to be
-autoloaded from after the C<__DATA__> token. See also
-L<perlsub/"Autoloading">.
-
-=head2 The __DATA__ token
-
-The C<__DATA__> token tells the perl compiler that the perl code
-for compilation is finished. Everything after the C<__DATA__> token
-is available for reading via the filehandle FOOBAR::DATA,
-where FOOBAR is the name of the current package when the C<__DATA__>
-token is reached. This works just the same as C<__END__> does in
-package 'main', but for other modules data after C<__END__> is not
-automatically retrievable, whereas data after C<__DATA__> is.
-The C<__DATA__> token is not recognized in versions of perl prior to
-5.001m.
-
-Note that it is possible to have C<__DATA__> tokens in the same package
-in multiple files, and that the last C<__DATA__> token in a given
-package that is encountered by the compiler is the one accessible
-by the filehandle. This also applies to C<__END__> and main, i.e. if
-the 'main' program has an C<__END__>, but a module 'require'd (_not_ 'use'd)
-by that program has a 'package main;' declaration followed by an 'C<__DATA__>',
-then the C<DATA> filehandle is set to access the data after the C<__DATA__>
-in the module, _not_ the data after the C<__END__> token in the 'main'
-program, since the compiler encounters the 'require'd file later.
-
-=head2 SelfLoader autoloading
-
-The B<SelfLoader> works by the user placing the C<__DATA__>
-token I<after> perl code which needs to be compiled and
-run at 'require' time, but I<before> subroutine declarations
-that can be loaded in later - usually because they may never
-be called.
-
-The B<SelfLoader> will read from the FOOBAR::DATA filehandle to
-load in the data after C<__DATA__>, and load in any subroutine
-when it is called. The costs are the one-time parsing of the
-data after C<__DATA__>, and a load delay for the _first_
-call of any autoloaded function. The benefits (hopefully)
-are a speeded up compilation phase, with no need to load
-functions which are never used.
-
-The B<SelfLoader> will stop reading from C<__DATA__> if
-it encounters the C<__END__> token - just as you would expect.
-If the C<__END__> token is present, and is followed by the
-token DATA, then the B<SelfLoader> leaves the FOOBAR::DATA
-filehandle open on the line after that token.
-
-The B<SelfLoader> exports the C<AUTOLOAD> subroutine to the
-package using the B<SelfLoader>, and this loads the called
-subroutine when it is first called.
-
-There is no advantage to putting subroutines which will _always_
-be called after the C<__DATA__> token.
-
-=head2 Autoloading and package lexicals
-
-A 'my $pack_lexical' statement makes the variable $pack_lexical
-local _only_ to the file up to the C<__DATA__> token. Subroutines
-declared elsewhere _cannot_ see these types of variables,
-just as if you declared subroutines in the package but in another
-file, they cannot see these variables.
-
-So specifically, autoloaded functions cannot see package
-lexicals (this applies to both the B<SelfLoader> and the Autoloader).
-The C<vars> pragma provides an alternative to defining package-level
-globals that will be visible to autoloaded routines. See the documentation
-on B<vars> in the pragma section of L<perlmod>.
-
-=head2 SelfLoader and AutoLoader
-
-The B<SelfLoader> can replace the AutoLoader - just change 'use AutoLoader'
-to 'use SelfLoader' (though note that the B<SelfLoader> exports
-the AUTOLOAD function - but if you have your own AUTOLOAD and
-are using the AutoLoader too, you probably know what you're doing),
-and the C<__END__> token to C<__DATA__>. You will need perl version 5.001m
-or later to use this (version 5.001 with all patches up to patch m).
-
-There is no need to inherit from the B<SelfLoader>.
-
-The B<SelfLoader> works similarly to the AutoLoader, but picks up the
-subs from after the C<__DATA__> instead of in the 'lib/auto' directory.
-There is a maintenance gain in not needing to run AutoSplit on the module
-at installation, and a runtime gain in not needing to keep opening and
-closing files to load subs. There is a runtime loss in needing
-to parse the code after the C<__DATA__>. Details of the B<AutoLoader> and
-another view of these distinctions can be found in that module's
-documentation.
-
-=head2 __DATA__, __END__, and the FOOBAR::DATA filehandle.
-
-This section is only relevant if you want to use
-the C<FOOBAR::DATA> together with the B<SelfLoader>.
-
-Data after the C<__DATA__> token in a module is read using the
-FOOBAR::DATA filehandle. C<__END__> can still be used to denote the end
-of the C<__DATA__> section if followed by the token DATA - this is supported
-by the B<SelfLoader>. The C<FOOBAR::DATA> filehandle is left open if an
-C<__END__> followed by a DATA is found, with the filehandle positioned at
-the start of the line after the C<__END__> token. If no C<__END__> token is
-present, or an C<__END__> token with no DATA token on the same line, then
-the filehandle is closed.
-
-The B<SelfLoader> reads from wherever the current
-position of the C<FOOBAR::DATA> filehandle is, until the
-EOF or C<__END__>. This means that if you want to use
-that filehandle (and ONLY if you want to), you should either
-
-1. Put all your subroutine declarations immediately after
-the C<__DATA__> token and put your own data after those
-declarations, using the C<__END__> token to mark the end
-of subroutine declarations. You must also ensure that the B<SelfLoader>
-reads first by calling 'SelfLoader-E<gt>load_stubs();', or by using a
-function which is selfloaded;
-
-or
-
-2. You should read the C<FOOBAR::DATA> filehandle first, leaving
-the handle open and positioned at the first line of subroutine
-declarations.
-
-You could conceivably do both.
-
-=head2 Classes and inherited methods.
-
-For modules which are not classes, this section is not relevant.
-This section is only relevant if you have methods which could
-be inherited.
-
-A subroutine stub (or forward declaration) looks like
-
- sub stub;
-
-i.e. it is a subroutine declaration without the body of the
-subroutine. For modules which are not classes, there is no real
-need for stubs as far as autoloading is concerned.
-
-For modules which ARE classes, and need to handle inherited methods,
-stubs are needed to ensure that the method inheritance mechanism works
-properly. You can load the stubs into the module at 'require' time, by
-adding the statement 'SelfLoader-E<gt>load_stubs();' to the module to do
-this.
-
-The alternative is to put the stubs in before the C<__DATA__> token BEFORE
-releasing the module, and for this purpose the C<Devel::SelfStubber>
-module is available. However this does require the extra step of ensuring
-that the stubs are in the module. If this is done I strongly recommend
-that this is done BEFORE releasing the module - it should NOT be done
-at install time in general.
-
-=head1 Multiple packages and fully qualified subroutine names
-
-Subroutines in multiple packages within the same file are supported - but you
-should note that this requires exporting the C<SelfLoader::AUTOLOAD> to
-every package which requires it. This is done automatically by the
-B<SelfLoader> when it first loads the subs into the cache, but you should
-really specify it in the initialization before the C<__DATA__> by putting
-a 'use SelfLoader' statement in each package.
-
-Fully qualified subroutine names are also supported. For example,
-
- __DATA__
- sub foo::bar {23}
- package baz;
- sub dob {32}
-
-will all be loaded correctly by the B<SelfLoader>, and the B<SelfLoader>
-will ensure that the packages 'foo' and 'baz' correctly have the
-B<SelfLoader> C<AUTOLOAD> method when the data after C<__DATA__> is first
-parsed.
-
-=head1 AUTHOR
-
-C<SelfLoader> is maintained by the perl5-porters. Please direct
-any questions to the canonical mailing list. Anything that
-is applicable to the CPAN release can be sent to its maintainer,
-though.
-
-Author and Maintainer: The Perl5-Porters <perl5-porters at perl.org>
-
-Maintainer of the CPAN release: Steffen Mueller <smueller at cpan.org>
-
-=head1 COPYRIGHT AND LICENSE
-
-This package has been part of the perl core since the first release
-of perl5. It has been released separately to CPAN so older installations
-can benefit from bug fixes.
-
-This package has the same copyright and license as the perl core:
-
- Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- 2000, 2001, 2002, 2003, 2004, 2005, 2006 by Larry Wall and others
-
- All rights reserved.
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of either:
-
- a) the GNU General Public License as published by the Free
- Software Foundation; either version 1, or (at your option) any
- later version, or
-
- b) the "Artistic License" which comes with this Kit.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either
- the GNU General Public License or the Artistic License for more details.
-
- You should have received a copy of the Artistic License with this
- Kit, in the file named "Artistic". If not, I'll be glad to provide one.
-
- You should also have received a copy of the GNU General Public License
- along with this program in the file named "Copying". If not, write to the
- Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
- 02111-1307, USA or visit their web page on the internet at
- http://www.gnu.org/copyleft/gpl.html.
-
- For those of you that choose to use the GNU General Public License,
- my interpretation of the GNU General Public License is that no Perl
- script falls under the terms of the GPL unless you explicitly put
- said script under the terms of the GPL yourself. Furthermore, any
- object code linked with perl does not automatically fall under the
- terms of the GPL, provided such object code only adds definitions
- of subroutines and variables, and does not otherwise impair the
- resulting interpreter from executing any standard Perl script. I
- consider linking in C subroutines in this manner to be the moral
- equivalent of defining subroutines in the Perl language itself. You
- may sell such an object file as proprietary provided that you provide
- or offer to provide the Perl source, as specified by the GNU General
- Public License. (This is merely an alternate way of specifying input
- to the program.) You may also sell a binary produced by the dumping of
- a running Perl script that belongs to you, provided that you provide or
- offer to provide the Perl source as specified by the GPL. (The
- fact that a Perl interpreter and your code are in the same binary file
- is, in this case, a form of mere aggregation.) This is my interpretation
- of the GPL. If you still have concerns or difficulties understanding
- my intent, feel free to contact me. Of course, the Artistic License
- spells all this out for your protection, so you may prefer to use that.
-
-=cut
Deleted: trunk/contrib/perl/lib/SelfLoader.t
===================================================================
--- trunk/contrib/perl/lib/SelfLoader.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/SelfLoader.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,208 +0,0 @@
-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- $dir = "self-$$";
- $sep = "/";
-
- if ($^O eq 'MacOS') {
- $dir = ":" . $dir;
- $sep = ":";
- }
-
- @INC = $dir;
- push @INC, '../lib';
-
- print "1..19\n";
-
- # First we must set up some selfloader files
- mkdir $dir, 0755 or die "Can't mkdir $dir: $!";
-
- open(FOO, ">$dir${sep}Foo.pm") or die;
- print FOO <<'EOT';
-package Foo;
-use SelfLoader;
-
-sub new { bless {}, shift }
-sub foo;
-sub bar;
-sub bazmarkhianish;
-sub a;
-sub never; # declared but definition should never be read
-1;
-__DATA__
-
-sub foo { shift; shift || "foo" };
-
-sub bar { shift; shift || "bar" }
-
-sub bazmarkhianish { shift; shift || "baz" }
-
-package sheep;
-sub bleat { shift; shift || "baa" }
-
-__END__
-sub never { die "D'oh" }
-EOT
-
- close(FOO);
-
- open(BAR, ">$dir${sep}Bar.pm") or die;
- print BAR <<'EOT';
-package Bar;
-use SelfLoader;
-
- at ISA = 'Baz';
-
-sub new { bless {}, shift }
-sub a;
-
-1;
-__DATA__
-
-sub a { 'a Bar'; }
-sub b { 'b Bar' }
-
-__END__ DATA
-sub never { die "D'oh" }
-EOT
-
- close(BAR);
-};
-
-
-package Baz;
-
-sub a { 'a Baz' }
-sub b { 'b Baz' }
-sub c { 'c Baz' }
-
-
-package main;
-use Foo;
-use Bar;
-
-$foo = new Foo;
-
-print "not " unless $foo->foo eq 'foo'; # selfloaded first time
-print "ok 1\n";
-
-print "not " unless $foo->foo eq 'foo'; # regular call
-print "ok 2\n";
-
-# Try an undefined method
-eval {
- $foo->will_fail;
-};
-if ($@ =~ /^Undefined subroutine/) {
- print "ok 3\n";
-} else {
- print "not ok 3 $@\n";
-}
-
-# Used to be trouble with this
-eval {
- my $foo = new Foo;
- die "oops";
-};
-if ($@ =~ /oops/) {
- print "ok 4\n";
-} else {
- print "not ok 4 $@\n";
-}
-
-# Pass regular expression variable to autoloaded function. This used
-# to go wrong in AutoLoader because it used regular expressions to generate
-# autoloaded filename.
-"foo" =~ /(\w+)/;
-print "not " unless $1 eq 'foo';
-print "ok 5\n";
-
-print "not " unless $foo->bar($1) eq 'foo';
-print "ok 6\n";
-
-print "not " unless $foo->bar($1) eq 'foo';
-print "ok 7\n";
-
-print "not " unless $foo->bazmarkhianish($1) eq 'foo';
-print "ok 8\n";
-
-print "not " unless $foo->bazmarkhianish($1) eq 'foo';
-print "ok 9\n";
-
-# Check nested packages inside __DATA__
-print "not " unless sheep::bleat() eq 'baa';
-print "ok 10\n";
-
-# Now check inheritance:
-
-$bar = new Bar;
-
-# Before anything is SelfLoaded there is no declaration of Foo::b so we should
-# get Baz::b
-print "not " unless $bar->b() eq 'b Baz';
-print "ok 11\n";
-
-# There is no Bar::c so we should get Baz::c
-print "not " unless $bar->c() eq 'c Baz';
-print "ok 12\n";
-
-# This selfloads Bar::a because it is stubbed. It also stubs Bar::b as a side
-# effect
-print "not " unless $bar->a() eq 'a Bar';
-print "ok 13\n";
-
-print "not " unless $bar->b() eq 'b Bar';
-print "ok 14\n";
-
-print "not " unless $bar->c() eq 'c Baz';
-print "ok 15\n";
-
-
-
-# Check that __END__ is honoured
-# Try an subroutine that should never be noticed by selfloader
-eval {
- $foo->never;
-};
-if ($@ =~ /^Undefined subroutine/) {
- print "ok 16\n";
-} else {
- print "not ok 16 $@\n";
-}
-
-# Try to read from the data file handle
-my $foodata = <Foo::DATA>;
-close Foo::DATA;
-if (defined $foodata) {
- print "not ok 17 # $foodata\n";
-} else {
- print "ok 17\n";
-}
-
-# Check that __END__ DATA is honoured
-# Try an subroutine that should never be noticed by selfloader
-eval {
- $bar->never;
-};
-if ($@ =~ /^Undefined subroutine/) {
- print "ok 18\n";
-} else {
- print "not ok 18 $@\n";
-}
-
-# Try to read from the data file handle
-my $bardata = <Bar::DATA>;
-close Bar::DATA;
-if ($bardata ne "sub never { die \"D'oh\" }\n") {
- print "not ok 19 # $bardata\n";
-} else {
- print "ok 19\n";
-}
-
-# cleanup
-END {
-return unless $dir && -d $dir;
-unlink "$dir${sep}Foo.pm", "$dir${sep}Bar.pm";
-rmdir "$dir";
-}
Deleted: trunk/contrib/perl/lib/Shell.pm
===================================================================
--- trunk/contrib/perl/lib/Shell.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Shell.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,270 +0,0 @@
-package Shell;
-use 5.006_001;
-use strict;
-use warnings;
-use File::Spec::Functions;
-
-our($capture_stderr, $raw, $VERSION, $AUTOLOAD);
-
-$VERSION = '0.72_01';
-$VERSION = eval $VERSION;
-
-sub new { bless \my $foo, shift }
-sub DESTROY { }
-
-sub import {
- my $self = shift;
- my ($callpack, $callfile, $callline) = caller;
- my @EXPORT;
- if (@_) {
- @EXPORT = @_;
- } else {
- @EXPORT = 'AUTOLOAD';
- }
- foreach my $sym (@EXPORT) {
- no strict 'refs';
- *{"${callpack}::$sym"} = \&{"Shell::$sym"};
- }
-}
-
-# NOTE: this is used to enable constant folding in
-# expressions like (OS eq 'MSWin32') and
-# (OS eq 'os2') just like it happened in 0.6 version
-# which used eval "string" to install subs on the fly.
-use constant OS => $^O;
-
-=begin private
-
-=item B<_make_cmd>
-
- $sub = _make_cmd($cmd);
- $sub = $shell->_make_cmd($cmd);
-
-Creates a closure which invokes the system command C<$cmd>.
-
-=end private
-
-=cut
-
-sub _make_cmd {
- shift if ref $_[0] && $_[0]->isa( 'Shell' );
- my $cmd = shift;
- my $null = File::Spec::Functions::devnull();
- $Shell::capture_stderr ||= 0;
- # closing over $^O, $cmd, and $null
- return sub {
- shift if ref $_[0] && $_[0]->isa( 'Shell' );
- if (@_ < 1) {
- $Shell::capture_stderr == 1 ? `$cmd 2>&1` :
- $Shell::capture_stderr == -1 ? `$cmd 2>$null` :
- `$cmd`;
- } elsif (OS eq 'os2') {
- local(*SAVEOUT, *READ, *WRITE);
-
- open SAVEOUT, '>&STDOUT' or die;
- pipe READ, WRITE or die;
- open STDOUT, '>&WRITE' or die;
- close WRITE;
-
- my $pid = system(1, $cmd, @_);
- die "Can't execute $cmd: $!\n" if $pid < 0;
-
- open STDOUT, '>&SAVEOUT' or die;
- close SAVEOUT;
-
- if (wantarray) {
- my @ret = <READ>;
- close READ;
- waitpid $pid, 0;
- @ret;
- } else {
- local($/) = undef;
- my $ret = <READ>;
- close READ;
- waitpid $pid, 0;
- $ret;
- }
- } else {
- my $a;
- my @arr = @_;
- unless( $Shell::raw ){
- if (OS eq 'MSWin32') {
- # XXX this special-casing should not be needed
- # if we do quoting right on Windows. :-(
- #
- # First, escape all quotes. Cover the case where we
- # want to pass along a quote preceded by a backslash
- # (i.e., C<"param \""" end">).
- # Ugly, yup? You know, windoze.
- # Enclose in quotes only the parameters that need it:
- # try this: c:> dir "/w"
- # and this: c:> dir /w
- for (@arr) {
- s/"/\\"/g;
- s/\\\\"/\\\\"""/g;
- $_ = qq["$_"] if /\s/;
- }
- } else {
- for (@arr) {
- s/(['\\])/\\$1/g;
- $_ = $_;
- }
- }
- }
- push @arr, '2>&1' if $Shell::capture_stderr == 1;
- push @arr, '2>$null' if $Shell::capture_stderr == -1;
- open(SUBPROC, join(' ', $cmd, @arr, '|'))
- or die "Can't exec $cmd: $!\n";
- if (wantarray) {
- my @ret = <SUBPROC>;
- close SUBPROC; # XXX Oughta use a destructor.
- @ret;
- } else {
- local($/) = undef;
- my $ret = <SUBPROC>;
- close SUBPROC;
- $ret;
- }
- }
- };
- }
-
-sub AUTOLOAD {
- shift if ref $_[0] && $_[0]->isa( 'Shell' );
- my $cmd = $AUTOLOAD;
- $cmd =~ s/^.*:://;
- no strict 'refs';
- *$AUTOLOAD = _make_cmd($cmd);
- goto &$AUTOLOAD;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Shell - run shell commands transparently within perl
-
-=head1 SYNOPSIS
-
- use Shell qw(cat ps cp);
- $passwd = cat('</etc/passwd');
- @pslines = ps('-ww'),
- cp("/etc/passwd", "/tmp/passwd");
-
- # object oriented
- my $sh = Shell->new;
- print $sh->ls('-l');
-
-=head1 DESCRIPTION
-
-=head2 Caveats
-
-This package is included as a show case, illustrating a few Perl features.
-It shouldn't be used for production programs. Although it does provide a
-simple interface for obtaining the standard output of arbitrary commands,
-there may be better ways of achieving what you need.
-
-Running shell commands while obtaining standard output can be done with the
-C<qx/STRING/> operator, or by calling C<open> with a filename expression that
-ends with C<|>, giving you the option to process one line at a time.
-If you don't need to process standard output at all, you might use C<system>
-(in preference of doing a print with the collected standard output).
-
-Since Shell.pm and all of the aforementioned techniques use your system's
-shell to call some local command, none of them is portable across different
-systems. Note, however, that there are several built in functions and
-library packages providing portable implementations of functions operating
-on files, such as: C<glob>, C<link> and C<unlink>, C<mkdir> and C<rmdir>,
-C<rename>, C<File::Compare>, C<File::Copy>, C<File::Find> etc.
-
-Using Shell.pm while importing C<foo> creates a subroutine C<foo> in the
-namespace of the importing package. Calling C<foo> with arguments C<arg1>,
-C<arg2>,... results in a shell command C<foo arg1 arg2...>, where the
-function name and the arguments are joined with a blank. (See the subsection
-on Escaping magic characters.) Since the result is essentially a command
-line to be passed to the shell, your notion of arguments to the Perl
-function is not necessarily identical to what the shell treats as a
-command line token, to be passed as an individual argument to the program.
-Furthermore, note that this implies that C<foo> is callable by file name
-only, which frequently depends on the setting of the program's environment.
-
-Creating a Shell object gives you the opportunity to call any command
-in the usual OO notation without requiring you to announce it in the
-C<use Shell> statement. Don't assume any additional semantics being
-associated with a Shell object: in no way is it similar to a shell
-process with its environment or current working directory or any
-other setting.
-
-=head2 Escaping Magic Characters
-
-It is, in general, impossible to take care of quoting the shell's
-magic characters. For some obscure reason, however, Shell.pm quotes
-apostrophes (C<'>) and backslashes (C<\>) on UNIX, and spaces and
-quotes (C<">) on Windows.
-
-=head2 Configuration
-
-If you set $Shell::capture_stderr to 1, the module will attempt to
-capture the standard error output of the process as well. This is
-done by adding C<2E<gt>&1> to the command line, so don't try this on
-a system not supporting this redirection.
-
-Setting $Shell::capture_stderr to -1 will send standard error to the
-bit bucket (i.e., the equivalent of adding C<2E<gt>/dev/null> to the
-command line). The same caveat regarding redirection applies.
-
-If you set $Shell::raw to true no quoting whatsoever is done.
-
-=head1 BUGS
-
-Quoting should be off by default.
-
-It isn't possible to call shell built in commands, but it can be
-done by using a workaround, e.g. shell( '-c', 'set' ).
-
-Capturing standard error does not work on some systems (e.g. VMS).
-
-=head1 AUTHOR
-
- Date: Thu, 22 Sep 94 16:18:16 -0700
- Message-Id: <9409222318.AA17072 at scalpel.netlabs.com>
- To: perl5-porters at isu.edu
- From: Larry Wall <lwall at scalpel.netlabs.com>
- Subject: a new module I just wrote
-
-Here's one that'll whack your mind a little out.
-
- #!/usr/bin/perl
-
- use Shell;
-
- $foo = echo("howdy", "<funny>", "world");
- print $foo;
-
- $passwd = cat("</etc/passwd");
- print $passwd;
-
- sub ps;
- print ps -ww;
-
- cp("/etc/passwd", "/etc/passwd.orig");
-
-That's maybe too gonzo. It actually exports an AUTOLOAD to the current
-package (and uncovered a bug in Beta 3, by the way). Maybe the usual
-usage should be
-
- use Shell qw(echo cat ps cp);
-
-Larry Wall
-
-Changes by Jenda at Krynicky.cz and Dave Cottle <d.cottle at csc.canterbury.ac.nz>.
-
-Changes for OO syntax and bug fixes by Casey West <casey at geeknest.com>.
-
-C<$Shell::raw> and pod rewrite by Wolfgang Laun.
-
-Rewritten to use closures rather than C<eval "string"> by Adriano Ferreira.
-
-=cut
Deleted: trunk/contrib/perl/lib/Shell.t
===================================================================
--- trunk/contrib/perl/lib/Shell.t 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Shell.t 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,84 +0,0 @@
-#!./perl
-
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't' if -d 't';
- @INC = '../lib';
- }
-}
-
-use Test::More tests => 7;
-
-BEGIN { use_ok('Shell'); }
-
-my $so = Shell->new;
-ok($so, 'Shell->new');
-
-my $Is_VMS = $^O eq 'VMS';
-my $Is_MSWin32 = $^O eq 'MSWin32';
-my $Is_NetWare = $^O eq 'NetWare';
-
-$Shell::capture_stderr = 1;
-
-# Now test that that works ..
-
-my $tmpfile = 'sht0001';
-while ( -f $tmpfile ) {
- $tmpfile++;
-}
-END { -f $tmpfile && (open STDERR, '>&SAVERR' and unlink $tmpfile) }
-
-no warnings 'once';
-# no false warning about Name "main::SAVERR" used only once: possible typo
-
-open(SAVERR, ">&STDERR");
-open(STDERR, ">$tmpfile");
-
-xXx_not_there(); # Ok someone could have a program called this :(
-
-# On os2 the warning is on by default...
-ok(($^O eq 'os2' xor !(-s $tmpfile)), '$Shell::capture_stderr');
-
-$Shell::capture_stderr = 0;
-
-# Trying to do two repeated C<ls>s in t in core and expecting the same output
-# is a race condition when tests are running in parallel, and using it as a
-# temporary directory. So go somewhere quieter.
-if ($ENV{PERL_CORE} && -d 'uni') {
- chdir 'uni';
- $chdir++;
-}
-
-# someone will have to fill in the blanks for other platforms
-
-if ($Is_VMS) {
- ok(directory(), 'Execute command');
- my @files = directory('*.*');
- ok(@files, 'Quoted arguments');
-
- ok(eq_array(\@files, [$so->directory('*.*')]), 'object method');
- eval { $so->directory };
- ok(!$@, '2 methods calls');
-} elsif ($Is_MSWin32) {
- ok(dir(), 'Execute command');
- my @files = dir('*.*');
- ok(@files, 'Quoted arguments');
-
- ok(eq_array(\@files, [$so->dir('*.*')]), 'object method');
- eval { $so->dir };
- ok(!$@, '2 methods calls');
-} else {
- ok(ls(), 'Execute command');
- my @files = ls('*');
- ok(@files, 'Quoted arguments');
-
- ok(eq_array(\@files, [$so->ls('*')]), 'object method');
- eval { $so->ls };
- ok(!$@, '2 methods calls');
-
-}
-open(STDERR, ">&SAVERR") ;
-
-if ($chdir) {
- chdir "..";
-}
Deleted: trunk/contrib/perl/lib/Switch.pm
===================================================================
--- trunk/contrib/perl/lib/Switch.pm 2013-12-04 01:19:50 UTC (rev 6453)
+++ trunk/contrib/perl/lib/Switch.pm 2013-12-04 02:10:19 UTC (rev 6454)
@@ -1,878 +0,0 @@
-package Switch;
-
-use strict;
-use vars qw($VERSION);
-use Carp;
-
-$VERSION = '2.14';
-
-
-# LOAD FILTERING MODULE...
-use Filter::Util::Call;
-
-sub __();
-
-# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch
-
-$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };
-
-my $offset;
-my $fallthrough;
-my ($Perl5, $Perl6) = (0,0);
-
-sub import
-{
- $fallthrough = grep /\bfallthrough\b/, @_;
- $offset = (caller)[2]+1;
- filter_add({}) unless @_>1 && $_[1] eq 'noimport';
- my $pkg = caller;
- no strict 'refs';
- for ( qw( on_defined on_exists ) )
- {
- *{"${pkg}::$_"} = \&$_;
- }
- *{"${pkg}::__"} = \&__ if grep /__/, @_;
- $Perl6 = 1 if grep(/Perl\s*6/i, @_);
- $Perl5 = 1 if grep(/Perl\s*5/i, @_) || !grep(/Perl\s*6/i, @_);
- 1;
-}
-
-sub unimport
-{
- filter_del()
-}
-
-sub filter
-{
- my($self) = @_ ;
- local $Switch::file = (caller)[1];
-
- my $status = 1;
- $status = filter_read(1_000_000);
- return $status if $status<0;
- $_ = filter_blocks($_,$offset);
- $_ = "# line $offset\n" . $_ if $offset; undef $offset;
- return $status;
-}
-
-use Text::Balanced ':ALL';
-
-sub line
-{
- my ($pretext,$offset) = @_;
- ($pretext=~tr/\n/\n/)+($offset||0);
-}
-
-sub is_block
-{
- local $SIG{__WARN__}=sub{die$@};
- local $^W=1;
- my $ishash = defined eval 'my $hr='.$_[0];
- undef $@;
- return !$ishash;
-}
-
-my $pod_or_DATA = qr/ ^=[A-Za-z] .*? ^=cut (?![A-Za-z]) .*? $
- | ^__(DATA|END)__\n.*
- /smx;
-
-my $casecounter = 1;
-sub filter_blocks
-{
- my ($source, $line) = @_;
- return $source unless $Perl5 && $source =~ /case|switch/
- || $Perl6 && $source =~ /when|given|default/;
- pos $source = 0;
- my $text = "";
- component: while (pos $source < length $source)
- {
- if ($source =~ m/(\G\s*use\s+Switch\b)/gc)
- {
- $text .= q{use Switch 'noimport'};
- next component;
- }
- my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
- if (defined $pos[0])
- {
- my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
- my $iEol;
- if( substr($source,$pos[4],$pos[5]) eq '/' && # 1st delimiter
- substr($source,$pos[2],$pos[3]) eq '' && # no op like 'm'
- index( substr($source,$pos[16],$pos[17]), 'x' ) == -1 && # no //x
- ($iEol = index( $source, "\n", $pos[4] )) > 0 &&
- $iEol < $pos[8] ){ # embedded newlines
- # If this is a pattern, it isn't compatible with Switch. Backup past 1st '/'.
- pos( $source ) = $pos[6];
- $text .= $pre . substr($source,$pos[2],$pos[6]-$pos[2]);
- } else {
- $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
- }
- next component;
- }
- if ($source =~ m/(\G\s*$pod_or_DATA)/gc) {
- $text .= $1;
- next component;
- }
- @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
- if (defined $pos[0])
- {
- $text .= " " if $pos[0] < $pos[2];
- $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
- next component;
- }
-
- if ($Perl5 && $source =~ m/\G(\n*)(\s*)(switch)\b(?=\s*[(])/gc
- || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(?=\s*[(])/gc
- || $Perl6 && $source =~ m/\G(\n*)(\s*)(given)\b(.*)(?=\{)/gc)
- {
- my $keyword = $3;
- my $arg = $4;
- $text .= $1.$2.'S_W_I_T_C_H: while (1) ';
- unless ($arg) {
- @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\(/,qr/\)/,qr/[[{(<]/,qr/[]})>]/,undef)
- or do {
- die "Bad $keyword statement (problem in the parentheses?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
- };
- $arg = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- }
- $arg =~ s {^\s*[(]\s*%} { ( \\\%} ||
- $arg =~ s {^\s*[(]\s*m\b} { ( qr} ||
- $arg =~ s {^\s*[(]\s*/} { ( qr/} ||
- $arg =~ s {^\s*[(]\s*qw} { ( \\qw};
- @pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)
- or do {
- die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0, pos $source), $line), "\n";
- };
- my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- $code =~ s/{/{ local \$::_S_W_I_T_C_H; Switch::switch $arg;/;
- $text .= $code . 'continue {last}';
- next component;
- }
- elsif ($Perl5 && $source =~ m/\G(\s*)(case\b)(?!\s*=>)/gc
- || $Perl6 && $source =~ m/\G(\s*)(when\b)(?!\s*=>)/gc
- || $Perl6 && $source =~ m/\G(\s*)(default\b)(?=\s*\{)/gc)
- {
- my $keyword = $2;
- $text .= $1 . ($keyword eq "default"
- ? "if (1)"
- : "if (Switch::case");
-
- if ($keyword eq "default") {
- # Nothing to do
- }
- elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)) {
- my $code = substr($source,$pos[0],$pos[4]-$pos[0]);
- $text .= " " if $pos[0] < $pos[2];
- $text .= "sub " if is_block $code;
- $text .= filter_blocks($code,line(substr($source,0,$pos[0]),$line)) . ")";
- }
- elsif (@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/[[(]/,qr/[])]/,qr/[[({]/,qr/[])}]/,undef)) {
- my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- $code =~ s {^\s*[(]\s*%} { ( \\\%} ||
- $code =~ s {^\s*[(]\s*m\b} { ( qr} ||
- $code =~ s {^\s*[(]\s*/} { ( qr/} ||
- $code =~ s {^\s*[(]\s*qw} { ( \\qw};
- $text .= " " if $pos[0] < $pos[2];
- $text .= "$code)";
- }
- elsif ($Perl6 && do{@pos = Text::Balanced::_match_variable(\$source,qr/\s*/)}) {
- my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- $code =~ s {^\s*%} { \%} ||
- $code =~ s {^\s*@} { \@};
- $text .= " " if $pos[0] < $pos[2];
- $text .= "$code)";
- }
- elsif ( @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0)) {
- my $code = substr($source,$pos[2],$pos[18]-$pos[2]);
- $code = filter_blocks($code,line(substr($source,0,$pos[2]),$line));
- $code =~ s {^\s*m} { qr} ||
- $code =~ s {^\s*/} { qr/} ||
- $code =~ s {^\s*qw} { \\qw};
- $text .= " " if $pos[0] < $pos[2];
- $text .= "$code)";
- }
- elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc
- || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) {
- my $code = filter_blocks($1,line(substr($source,0,pos $source),$line));
- $text .= ' \\' if $2 eq '%';
- $text .= " $code)";
- }
- else {
- die "Bad $keyword statement (invalid $keyword value?) near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n";
- }
-
- die "Missing opening brace or semi-colon after 'when' value near $Switch::file line ", line(substr($source,0,pos $source), $line), "\n"
- unless !$Perl6 || $source =~ m/\G(\s*)(?=;|\{)/gc;
-
- do{@pos = Text::Balanced::_match_codeblock(\$source,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef)}
- or do {
- if ($source =~ m/\G\s*(?=([};]|\Z))/gc) {
- $casecounter++;
- next component;
- }
- die "Bad $keyword statement (problem in the code block?) near $Switch::file line ", line(substr($source,0,pos $source),$line), "\n";
- };
- my $code = filter_blocks(substr($source,$pos[0],$pos[4]-$pos[0]),line(substr($source,0,$pos[0]),$line));
- $code =~ s/}(?=\s*\Z)/;last S_W_I_T_C_H }/
- unless $fallthrough;
- $text .= "{ while (1) $code continue { goto C_A_S_E_$casecounter } last S_W_I_T_C_H; C_A_S_E_$casecounter: }";
- $casecounter++;
- next component;
- }
-
- $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
- $text .= $1;
- }
- $text;
-}
-
-
-
-sub in
-{
- my ($x,$y) = @_;
- my @numy;
- for my $nextx ( @$x )
- {
- my $numx = ref($nextx) || defined $nextx && (~$nextx&$nextx) eq 0;
- for my $j ( 0..$#$y )
- {
- my $nexty = $y->[$j];
- push @numy, ref($nexty) || defined $nexty && (~$nexty&$nexty) eq 0
- if @numy <= $j;
- return 1 if $numx && $numy[$j] && $nextx==$nexty
- || $nextx eq $nexty;
-
- }
- }
- return "";
-}
-
-sub on_exists
-{
- my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
- [ keys %$ref ]
-}
-
-sub on_defined
-{
- my $ref = @_==1 && ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
- [ grep { defined $ref->{$_} } keys %$ref ]
-}
-
-sub switch(;$)
-{
- my ($s_val) = @_ ? $_[0] : $_;
- my $s_ref = ref $s_val;
-
- if ($s_ref eq 'CODE')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- return $s_val == $c_val if ref $c_val eq 'CODE';
- return $s_val->(@$c_val) if ref $c_val eq 'ARRAY';
- return $s_val->($c_val);
- };
- }
- elsif ($s_ref eq "" && defined $s_val && (~$s_val&$s_val) eq 0) # NUMERIC SCALAR
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return $s_val == $c_val if $c_ref eq ""
- && defined $c_val
- && (~$c_val&$c_val) eq 0;
- return $s_val eq $c_val if $c_ref eq "";
- return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
- return $c_val->($s_val) if $c_ref eq 'CODE';
- return $c_val->call($s_val) if $c_ref eq 'Switch';
- return scalar $s_val=~/$c_val/
- if $c_ref eq 'Regexp';
- return scalar $c_val->{$s_val}
- if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq "") # STRING SCALAR
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return $s_val eq $c_val if $c_ref eq "";
- return in([$s_val],$c_val) if $c_ref eq 'ARRAY';
- return $c_val->($s_val) if $c_ref eq 'CODE';
- return $c_val->call($s_val) if $c_ref eq 'Switch';
- return scalar $s_val=~/$c_val/
- if $c_ref eq 'Regexp';
- return scalar $c_val->{$s_val}
- if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq 'ARRAY')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return in($s_val,[$c_val]) if $c_ref eq "";
- return in($s_val,$c_val) if $c_ref eq 'ARRAY';
- return $c_val->(@$s_val) if $c_ref eq 'CODE';
- return $c_val->call(@$s_val)
- if $c_ref eq 'Switch';
- return scalar grep {$_=~/$c_val/} @$s_val
- if $c_ref eq 'Regexp';
- return scalar grep {$c_val->{$_}} @$s_val
- if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq 'Regexp')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return $c_val=~/s_val/ if $c_ref eq "";
- return scalar grep {$_=~/s_val/} @$c_val
- if $c_ref eq 'ARRAY';
- return $c_val->($s_val) if $c_ref eq 'CODE';
- return $c_val->call($s_val) if $c_ref eq 'Switch';
- return $s_val eq $c_val if $c_ref eq 'Regexp';
- return grep {$_=~/$s_val/ && $c_val->{$_}} keys %$c_val
- if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq 'HASH')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- my $c_ref = ref $c_val;
- return $s_val->{$c_val} if $c_ref eq "";
- return scalar grep {$s_val->{$_}} @$c_val
- if $c_ref eq 'ARRAY';
- return $c_val->($s_val) if $c_ref eq 'CODE';
- return $c_val->call($s_val) if $c_ref eq 'Switch';
- return grep {$_=~/$c_val/ && $s_val->{"$_"}} keys %$s_val
- if $c_ref eq 'Regexp';
- return $s_val==$c_val if $c_ref eq 'HASH';
- return;
- };
- }
- elsif ($s_ref eq 'Switch')
- {
- $::_S_W_I_T_C_H =
- sub { my $c_val = $_[0];
- return $s_val == $c_val if ref $c_val eq 'Switch';
- return $s_val->call(@$c_val)
- if ref $c_val eq 'ARRAY';
- return $s_val->call($c_val);
- };
- }
- else
- {
- croak "Cannot switch on $s_ref";
- }
- return 1;
-}
-
-sub case($) { local $SIG{__WARN__} = \&carp;
- $::_S_W_I_T_C_H->(@_); }
-
-# IMPLEMENT __
-
-my $placeholder = bless { arity=>1, impl=>sub{$_[1+$_[0]]} };
-
-sub __() { $placeholder }
-
-sub __arg($)
-{
- my $index = $_[0]+1;
- bless { arity=>0, impl=>sub{$_[$index]} };
-}
-
-sub hosub(&@)
-{
- # WRITE THIS
-}
-
-sub call
-{
- my ($self, at args) = @_;
- return $self->{impl}->(0, at args);
-}
-
-sub meta_bop(&)
-{
- my ($op) = @_;
- sub
- {
- my ($left, $right, $reversed) = @_;
- ($right,$left) = @_ if $reversed;
-
- my $rop = ref $right eq 'Switch'
- ? $right
- : bless { arity=>0, impl=>sub{$right} };
-
- my $lop = ref $left eq 'Switch'
- ? $left
- : bless { arity=>0, impl=>sub{$left} };
-
- my $arity = $lop->{arity} + $rop->{arity};
-
- return bless {
- arity => $arity,
- impl => sub { my $start = shift;
- return $op->($lop->{impl}->($start, at _),
- $rop->{impl}->($start+$lop->{arity}, at _));
- }
- };
- };
-}
-
-sub meta_uop(&)
-{
- my ($op) = @_;
- sub
- {
- my ($left) = @_;
-
- my $lop = ref $left eq 'Switch'
- ? $left
- : bless { arity=>0, impl=>sub{$left} };
-
- my $arity = $lop->{arity};
-
- return bless {
- arity => $arity,
- impl => sub { $op->($lop->{impl}->(@_)) }
- };
- };
-}
-
-
-use overload
- "+" => meta_bop {$_[0] + $_[1]},
- "-" => meta_bop {$_[0] - $_[1]},
- "*" => meta_bop {$_[0] * $_[1]},
- "/" => meta_bop {$_[0] / $_[1]},
- "%" => meta_bop {$_[0] % $_[1]},
- "**" => meta_bop {$_[0] ** $_[1]},
- "<<" => meta_bop {$_[0] << $_[1]},
- ">>" => meta_bop {$_[0] >> $_[1]},
- "x" => meta_bop {$_[0] x $_[1]},
- "." => meta_bop {$_[0] . $_[1]},
- "<" => meta_bop {$_[0] < $_[1]},
- "<=" => meta_bop {$_[0] <= $_[1]},
- ">" => meta_bop {$_[0] > $_[1]},
- ">=" => meta_bop {$_[0] >= $_[1]},
- "==" => meta_bop {$_[0] == $_[1]},
- "!=" => meta_bop {$_[0] != $_[1]},
- "<=>" => meta_bop {$_[0] <=> $_[1]},
- "lt" => meta_bop {$_[0] lt $_[1]},
- "le" => meta_bop {$_[0] le $_[1]},
- "gt" => meta_bop {$_[0] gt $_[1]},
- "ge" => meta_bop {$_[0] ge $_[1]},
- "eq" => meta_bop {$_[0] eq $_[1]},
- "ne" => meta_bop {$_[0] ne $_[1]},
- "cmp" => meta_bop {$_[0] cmp $_[1]},
- "\&" => meta_bop {$_[0] & $_[1]},
- "^" => meta_bop {$_[0] ^ $_[1]},
- "|" => meta_bop {$_[0] | $_[1]},
- "atan2" => meta_bop {atan2 $_[0], $_[1]},
-
- "neg" => meta_uop {-$_[0]},
- "!" => meta_uop {!$_[0]},
- "~" => meta_uop {~$_[0]},
- "cos" => meta_uop {cos $_[0]},
- "sin" => meta_uop {sin $_[0]},
- "exp" => meta_uop {exp $_[0]},
- "abs" => meta_uop {abs $_[0]},
- "log" => meta_uop {log $_[0]},
- "sqrt" => meta_uop {sqrt $_[0]},
- "bool" => sub { croak "Can't use && or || in expression containing __" },
-
- # "&()" => sub { $_[0]->{impl} },
-
- # "||" => meta_bop {$_[0] || $_[1]},
- # "&&" => meta_bop {$_[0] && $_[1]},
- # fallback => 1,
- ;
-1;
-
-__END__
-
-
-=head1 NAME
-
-Switch - A switch statement for Perl
-
-=head1 VERSION
-
-This document describes version 2.14 of Switch,
-released Dec 29, 2008.
-
-=head1 SYNOPSIS
-
- use Switch;
-
- switch ($val) {
- case 1 { print "number 1" }
- case "a" { print "string a" }
- case [1..10,42] { print "number in list" }
- case (\@array) { print "number in list" }
- case /\w+/ { print "pattern" }
- case qr/\w+/ { print "pattern" }
- case (\%hash) { print "entry in hash" }
- case (\&sub) { print "arg to subroutine" }
- else { print "previous case not true" }
- }
-
-=head1 BACKGROUND
-
-[Skip ahead to L<"DESCRIPTION"> if you don't care about the whys
-and wherefores of this control structure]
-
-In seeking to devise a "Swiss Army" case mechanism suitable for Perl,
-it is useful to generalize this notion of distributed conditional
-testing as far as possible. Specifically, the concept of "matching"
-between the switch value and the various case values need not be
-restricted to numeric (or string or referential) equality, as it is in other
-languages. Indeed, as Table 1 illustrates, Perl
-offers at least eighteen different ways in which two values could
-generate a match.
-
- Table 1: Matching a switch value ($s) with a case value ($c)
-
- Switch Case Type of Match Implied Matching Code
- Value Value
- ====== ===== ===================== =============
-
- number same numeric or referential match if $s == $c;
- or ref equality
-
- object method result of method call match if $s->$c();
- ref name match if defined $s->$c();
- or ref
-
- other other string equality match if $s eq $c;
- non-ref non-ref
- scalar scalar
-
- string regexp pattern match match if $s =~ /$c/;
-
- array scalar array entry existence match if 0<=$c && $c<@$s;
- ref array entry definition match if defined $s->[$c];
- array entry truth match if $s->[$c];
-
- array array array intersection match if intersects(@$s, @$c);
- ref ref (apply this table to
- all pairs of elements
- $s->[$i] and
- $c->[$j])
-
- array regexp array grep match if grep /$c/, @$s;
- ref
-
- hash scalar hash entry existence match if exists $s->{$c};
- ref hash entry definition match if defined $s->{$c};
- hash entry truth match if $s->{$c};
-
- hash regexp hash grep match if grep /$c/, keys %$s;
- ref
-
- sub scalar return value defn match if defined $s->($c);
- ref return value truth match if $s->($c);
-
- sub array return value defn match if defined $s->(@$c);
- ref ref return value truth match if $s->(@$c);
-
-
-In reality, Table 1 covers 31 alternatives, because only the equality and
-intersection tests are commutative; in all other cases, the roles of
-the C<$s> and C<$c> variables could be reversed to produce a
-different test. For example, instead of testing a single hash for
-the existence of a series of keys (C<match if exists $s-E<gt>{$c}>),
-one could test for the existence of a single key in a series of hashes
-(C<match if exists $c-E<gt>{$s}>).
-
-=head1 DESCRIPTION
-
-The Switch.pm module implements a generalized case mechanism that covers
-most (but not all) of the numerous possible combinations of switch and case
-values described above.
-
-The module augments the standard Perl syntax with two new control
-statements: C<switch> and C<case>. The C<switch> statement takes a
-single scalar argument of any type, specified in parentheses.
-C<switch> stores this value as the
-current switch value in a (localized) control variable.
-The value is followed by a block which may contain one or more
-Perl statements (including the C<case> statement described below).
-The block is unconditionally executed once the switch value has
-been cached.
-
-A C<case> statement takes a single scalar argument (in mandatory
-parentheses if it's a variable; otherwise the parens are optional) and
-selects the appropriate type of matching between that argument and the
-current switch value. The type of matching used is determined by the
-respective types of the switch value and the C<case> argument, as
-specified in Table 1. If the match is successful, the mandatory
-block associated with the C<case> statement is executed.
-
-In most other respects, the C<case> statement is semantically identical
-to an C<if> statement. For example, it can be followed by an C<else>
-clause, and can be used as a postfix statement qualifier.
-
-However, when a C<case> block has been executed control is automatically
-transferred to the statement after the immediately enclosing C<switch>
-block, rather than to the next statement within the block. In other
-words, the success of any C<case> statement prevents other cases in the
-same scope from executing. But see L<"Allowing fall-through"> below.
-
-Together these two new statements provide a fully generalized case
-mechanism:
-
- use Switch;
-
- # AND LATER...
-
- %special = ( woohoo => 1, d'oh => 1 );
-
- while (<>) {
- chomp;
- switch ($_) {
- case (%special) { print "homer\n"; } # if $special{$_}
- case /[a-z]/i { print "alpha\n"; } # if $_ =~ /a-z/i
- case [1..9] { print "small num\n"; } # if $_ in [1..9]
- case { $_[0] >= 10 } { print "big num\n"; } # if $_ >= 10
- print "must be punctuation\n" case /\W/; # if $_ ~= /\W/
- }
- }
-
-Note that C<switch>es can be nested within C<case> (or any other) blocks,
-and a series of C<case> statements can try different types of matches
--- hash membership, pattern match, array intersection, simple equality,
-etc. -- against the same switch value.
-
-The use of intersection tests against an array reference is particularly
-useful for aggregating integral cases:
-
- sub classify_digit
- {
- switch ($_[0]) { case 0 { return 'zero' }
- case [2,4,6,8] { return 'even' }
- case [1,3,5,7,9] { return 'odd' }
- case /[A-F]/i { return 'hex' }
- }
- }
-
-
-=head2 Allowing fall-through
-
-Fall-though (trying another case after one has already succeeded)
-is usually a Bad Idea in a switch statement. However, this
-is Perl, not a police state, so there I<is> a way to do it, if you must.
-
-If a C<case> block executes an untargeted C<next>, control is
-immediately transferred to the statement I<after> the C<case> statement
-(i.e. usually another case), rather than out of the surrounding
-C<switch> block.
-
-For example:
-
- switch ($val) {
- case 1 { handle_num_1(); next } # and try next case...
- case "1" { handle_str_1(); next } # and try next case...
- case [0..9] { handle_num_any(); } # and we're done
- case /\d/ { handle_dig_any(); next } # and try next case...
- case /.*/ { handle_str_any(); next } # and try next case...
- }
-
-If $val held the number C<1>, the above C<switch> block would call the
-first three C<handle_...> subroutines, jumping to the next case test
-each time it encountered a C<next>. After the third C<case> block
-was executed, control would jump to the end of the enclosing
-C<switch> block.
-
-On the other hand, if $val held C<10>, then only the last two C<handle_...>
-subroutines would be called.
-
-Note that this mechanism allows the notion of I<conditional fall-through>.
-For example:
-
- switch ($val) {
- case [0..9] { handle_num_any(); next if $val < 7; }
- case /\d/ { handle_dig_any(); }
- }
-
-If an untargeted C<last> statement is executed in a case block, this
-immediately transfers control out of the enclosing C<switch> block
-(in other words, there is an implicit C<last> at the end of each
-normal C<case> block). Thus the previous example could also have been
-written:
-
- switch ($val) {
- case [0..9] { handle_num_any(); last if $val >= 7; next; }
- case /\d/ { handle_dig_any(); }
- }
-
-
-=head2 Automating fall-through
-
-In situations where case fall-through should be the norm, rather than an
-exception, an endless succession of terminal C<next>s is tedious and ugly.
-Hence, it is possible to reverse the default behaviour by specifying
-the string "fallthrough" when importing the module. For example, the
-following code is equivalent to the first example in L<"Allowing fall-through">:
-
- use Switch 'fallthrough';
-
- switch ($val) {
- case 1 { handle_num_1(); }
- case "1" { handle_str_1(); }
- case [0..9] { handle_num_any(); last }
- case /\d/ { handle_dig_any(); }
- case /.*/ { handle_str_any(); }
- }
-
-Note the explicit use of a C<last> to preserve the non-fall-through
-behaviour of the third case.
-
-
-
-=head2 Alternative syntax
-
-Perl 6 will provide a built-in switch statement with essentially the
-same semantics as those offered by Switch.pm, but with a different
-pair of keywords. In Perl 6 C<switch> will be spelled C<given>, and
-C<case> will be pronounced C<when>. In addition, the C<when> statement
-will not require switch or case values to be parenthesized.
-
-This future syntax is also (largely) available via the Switch.pm module, by
-importing it with the argument C<"Perl6">. For example:
-
- use Switch 'Perl6';
-
- given ($val) {
- when 1 { handle_num_1(); }
- when ($str1) { handle_str_1(); }
- when [0..9] { handle_num_any(); last }
- when /\d/ { handle_dig_any(); }
- when /.*/ { handle_str_any(); }
- default { handle anything else; }
- }
-
-Note that scalars still need to be parenthesized, since they would be
-ambiguous in Perl 5.
-
-Note too that you can mix and match both syntaxes by importing the module
-with:
-
- use Switch 'Perl5', 'Perl6';
-
-
-=head2 Higher-order Operations
-
-One situation in which C<switch> and C<case> do not provide a good
-substitute for a cascaded C<if>, is where a switch value needs to
-be tested against a series of conditions. For example:
-
- sub beverage {
- switch (shift) {
- case { $_[0] < 10 } { return 'milk' }
- case { $_[0] < 20 } { return 'coke' }
- case { $_[0] < 30 } { return 'beer' }
- case { $_[0] < 40 } { return 'wine' }
- case { $_[0] < 50 } { return 'malt' }
- case { $_[0] < 60 } { return 'Moet' }
- else { return 'milk' }
- }
- }
-
-(This is equivalent to writing C<case (sub { $_[0] < 10 })>, etc.; C<$_[0]>
-is the argument to the anonymous subroutine.)
-
-The need to specify each condition as a subroutine block is tiresome. To
-overcome this, when importing Switch.pm, a special "placeholder"
-subroutine named C<__> [sic] may also be imported. This subroutine
-converts (almost) any expression in which it appears to a reference to a
-higher-order function. That is, the expression:
-
- use Switch '__';
-
- __ < 2
-
-is equivalent to:
-
- sub { $_[0] < 2 }
-
-With C<__>, the previous ugly case statements can be rewritten:
-
- case __ < 10 { return 'milk' }
- case __ < 20 { return 'coke' }
- case __ < 30 { return 'beer' }
- case __ < 40 { return 'wine' }
- case __ < 50 { return 'malt' }
- case __ < 60 { return 'Moet' }
- else { return 'milk' }
-
-The C<__> subroutine makes extensive use of operator overloading to
-perform its magic. All operations involving __ are overloaded to
-produce an anonymous subroutine that implements a lazy version
-of the original operation.
-
-The only problem is that operator overloading does not allow the
-boolean operators C<&&> and C<||> to be overloaded. So a case statement
-like this:
-
- case 0 <= __ && __ < 10 { return 'digit' }
-
-doesn't act as expected, because when it is
-executed, it constructs two higher order subroutines
-and then treats the two resulting references as arguments to C<&&>:
-
- sub { 0 <= $_[0] } && sub { $_[0] < 10 }
-
-This boolean expression is inevitably true, since both references are
-non-false. Fortunately, the overloaded C<'bool'> operator catches this
-situation and flags it as an error.
-
-=head1 DEPENDENCIES
-
-The module is implemented using Filter::Util::Call and Text::Balanced
-and requires both these modules to be installed.
-
-=head1 AUTHOR
-
-Damian Conway (damian at conway.org). This module is now maintained by Rafael
-Garcia-Suarez (rgarciasuarez at gmail.com) and more generally by the Perl 5
-Porters (perl5-porters at perl.org), as part of the Perl core.
-
-=head1 BUGS
-
-There are undoubtedly serious bugs lurking somewhere in code this funky :-)
-Bug reports and other feedback are most welcome.
-
-=head1 LIMITATIONS
-
-Due to the heuristic nature of Switch.pm's source parsing, the presence of
-regexes with embedded newlines that are specified with raw C</.../>
-delimiters and don't have a modifier C<//x> are indistinguishable from
-code chunks beginning with the division operator C</>. As a workaround
-you must use C<m/.../> or C<m?...?> for such patterns. Also, the presence
-of regexes specified with raw C<?...?> delimiters may cause mysterious
-errors. The workaround is to use C<m?...?> instead.
-
-Due to the way source filters work in Perl, you can't use Switch inside
-an string C<eval>.
-
-If your source file is longer then 1 million characters and you have a
-switch statement that crosses the 1 million (or 2 million, etc.)
-character boundary you will get mysterious errors. The workaround is to
-use smaller source files.
-
-=head1 COPYRIGHT
-
- Copyright (c) 1997-2008, Damian Conway. All Rights Reserved.
- This module is free software. It may be used, redistributed
- and/or modified under the same terms as Perl itself.
More information about the Midnightbsd-cvs
mailing list