summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorCharles Bailey <bailey@newman.upenn.edu>2000-03-13 02:31:44 +0000
committerbailey <bailey@newman.upenn.edu>2000-03-13 02:31:44 +0000
commita32e82edde068d007913f66170d881838f070558 (patch)
treeb263f210818e8a9977e4a12080386f6af4a33282 /lib
parentfd7385b97d6c0b537b272f194ad6f88a70d3dd39 (diff)
parent24ef60581ee187bb6d4388e124dfc34b8cf0b663 (diff)
downloadperl-a32e82edde068d007913f66170d881838f070558.tar.gz
Resync with mainline post RC1
p4raw-id: //depot/vmsperl@5690
Diffstat (limited to 'lib')
-rwxr-xr-xlib/ExtUtils/xsubpp22
-rw-r--r--lib/Fatal.pm54
-rw-r--r--lib/File/DosGlob.pm13
-rw-r--r--lib/File/Path.pm6
-rw-r--r--lib/File/Spec/VMS.pm7
-rw-r--r--lib/Getopt/Long.pm69
-rw-r--r--lib/IPC/Open2.pm66
-rw-r--r--lib/IPC/Open3.pm78
-rw-r--r--lib/Math/Complex.pm173
-rw-r--r--lib/Pod/Html.pm70
-rw-r--r--lib/Pod/InputObjects.pm10
-rw-r--r--lib/Pod/Man.pm102
-rw-r--r--lib/Pod/Parser.pm3
-rw-r--r--lib/Pod/Plainer.pm69
-rw-r--r--lib/Pod/Text.pm39
-rw-r--r--lib/bytes.pm2
-rw-r--r--lib/lib.pm7
-rw-r--r--lib/open.pm70
-rw-r--r--lib/perl5db.pl66
-rw-r--r--lib/utf8.pm2
20 files changed, 601 insertions, 327 deletions
diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index 08e7436760..96e1bb44c4 100755
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -273,7 +273,7 @@ $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
$BLOCK_re= '\s*(' . join('|', qw(
REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
- SCOPE INTERFACE INTERFACE_MACRO C_ARGS POST_CALL
+ SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL
)) . "|$END)\\s*:";
# Input: ($_, @line) == unparsed input.
@@ -436,7 +436,7 @@ sub INPUT_handler {
$func_args =~ s/\b($var_name)\b/&$1/;
}
if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
- or $in_out{$var_name} and $in_out{$var_name} eq 'outlist'
+ or $in_out{$var_name} and $in_out{$var_name} eq 'OUTLIST'
and $var_init !~ /\S/) {
if ($name_printed) {
print ";\n";
@@ -522,7 +522,7 @@ EOF
sub CLEANUP_handler() { print_section() }
sub PREINIT_handler() { print_section() }
-sub POST_CALL_handler() { print_section() }
+sub POSTCALL_handler() { print_section() }
sub INIT_handler() { print_section() }
sub GetAliases
@@ -1041,10 +1041,10 @@ while (fetch_para()) {
next unless length $pre;
my $out_type;
my $inout_var;
- if ($process_inout and s/^(in|in_outlist|outlist)\s+//) {
+ if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) {
my $type = $1;
- $out_type = $type if $type ne 'in';
- $arg =~ s/^(in|in_outlist|outlist)\s+//;
+ $out_type = $type if $type ne 'IN';
+ $arg =~ s/^(IN|IN_OUTLIST|OUTLIST)\s+//;
}
if (/\W/) { # Has a type
push @arg_with_types, $arg;
@@ -1052,7 +1052,7 @@ while (fetch_para()) {
$arg_types{$name} = $arg;
$_ = "$name$default";
}
- $out_vars{$_} = 1 if $out_type eq 'outlist';
+ $out_vars{$_} = 1 if $out_type eq 'OUTLIST';
push @in_out, $name if $out_type;
$in_out{$name} = $out_type if $out_type;
}
@@ -1063,10 +1063,10 @@ while (fetch_para()) {
} else {
@args = split(/\s*,\s*/, $orig_args);
for (@args) {
- if ($process_inout and s/^(in|in_outlist|outlist)\s+//) {
+ if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST)\s+//) {
my $out_type = $1;
- next if $out_type eq 'in';
- $out_vars{$_} = 1 if $out_type eq 'outlist';
+ next if $out_type eq 'IN';
+ $out_vars{$_} = 1 if $out_type eq 'OUTLIST';
push @in_out, $name;
$in_out{$_} = $out_type;
}
@@ -1278,7 +1278,7 @@ EOF
# $wantRETVAL set if 'RETVAL =' autogenerated
($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
undef %outargs ;
- process_keyword("POST_CALL|OUTPUT|ALIAS|PROTOTYPE");
+ process_keyword("POSTCALL|OUTPUT|ALIAS|PROTOTYPE");
# all OUTPUT done, so now push the return value on the stack
if ($gotRETVAL && $RETVAL_code) {
diff --git a/lib/Fatal.pm b/lib/Fatal.pm
index 5b832f6427..1496117c89 100644
--- a/lib/Fatal.pm
+++ b/lib/Fatal.pm
@@ -12,9 +12,15 @@ $Debug = 0 unless defined $Debug;
sub import {
my $self = shift(@_);
my($sym, $pkg);
+ my $void = 0;
$pkg = (caller)[0];
foreach $sym (@_) {
- &_make_fatal($sym, $pkg);
+ if ($sym eq ":void") {
+ $void = 1;
+ }
+ else {
+ &_make_fatal($sym, $pkg, $void);
+ }
}
};
@@ -42,11 +48,11 @@ sub fill_protos {
}
sub write_invocation {
- my ($core, $call, $name, @argvs) = @_;
+ my ($core, $call, $name, $void, @argvs) = @_;
if (@argvs == 1) { # No optional arguments
my @argv = @{$argvs[0]};
shift @argv;
- return "\t" . one_invocation($core, $call, $name, @argv) . ";\n";
+ return "\t" . one_invocation($core, $call, $name, $void, @argv) . ";\n";
} else {
my $else = "\t";
my (@out, @argv, $n);
@@ -56,7 +62,7 @@ sub write_invocation {
push @out, "$ {else}if (\@_ == $n) {\n";
$else = "\t} els";
push @out,
- "\t\treturn " . one_invocation($core, $call, $name, @argv) . ";\n";
+ "\t\treturn " . one_invocation($core, $call, $name, $void, @argv) . ";\n";
}
push @out, <<EOC;
}
@@ -67,21 +73,27 @@ EOC
}
sub one_invocation {
- my ($core, $call, $name, @argv) = @_;
+ my ($core, $call, $name, $void, @argv) = @_;
local $" = ', ';
- return qq{$call(@argv) || croak "Can't $name(\@_)} .
- ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+ if ($void) {
+ return qq/(defined wantarray)?$call(@argv):
+ $call(@argv) || croak "Can't $name(\@_)/ .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '"'
+ } else {
+ return qq{$call(@argv) || croak "Can't $name(\@_)} .
+ ($core ? ': $!' : ', \$! is \"$!\"') . '"';
+ }
}
sub _make_fatal {
- my($sub, $pkg) = @_;
+ my($sub, $pkg, $void) = @_;
my($name, $code, $sref, $real_proto, $proto, $core, $call);
my $ini = $sub;
$sub = "${pkg}::$sub" unless $sub =~ /::/;
$name = $sub;
$name =~ s/.*::// or $name =~ s/^&//;
- print "# _make_fatal: sub=$sub pkg=$pkg name=$name\n" if $Debug;
+ print "# _make_fatal: sub=$sub pkg=$pkg name=$name void=$void\n" if $Debug;
croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
if (defined(&$sub)) { # user subroutine
$sref = \&$sub;
@@ -109,7 +121,7 @@ sub$real_proto {
local(\$", \$!) = (', ', 0);
EOS
my @protos = fill_protos($proto);
- $code .= write_invocation($core, $call, $name, @protos);
+ $code .= write_invocation($core, $call, $name, $void, @protos);
$code .= "}\n";
print $code if $Debug;
{
@@ -139,11 +151,10 @@ Fatal - replace functions with equivalents which succeed or die
=head1 DESCRIPTION
C<Fatal> provides a way to conveniently replace functions which normally
-return a false value when they fail with equivalents which halt execution
+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. Errors are
-reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you
-wish to take some action before the program exits.
+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
@@ -151,6 +162,21 @@ replaced. You may wrap both user-defined functions and overridable
CORE operators (except C<exec>, C<system> which 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(open(FH, "< /bogotic") {
+ warn "bogo file, dude: $!";
+ }
+
+ # not checked, so error raises an exception
+ close FH;
+
=head1 AUTHOR
Lionel.Cons@cern.ch
diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm
index e5a2467927..d7dea7b46c 100644
--- a/lib/File/DosGlob.pm
+++ b/lib/File/DosGlob.pm
@@ -19,13 +19,18 @@ sub doglob {
my $sepchr = '/';
next OUTER unless defined $_ and $_ ne '';
# if arg is within quotes strip em and do no globbing
- if (/^"(.*)"$/) {
+ if (/^"(.*)"\z/s) {
$_ = $1;
if ($cond eq 'd') { push(@retval, $_) if -d $_ }
else { push(@retval, $_) if -e $_ }
next OUTER;
}
- if (m|^(.*)([\\/])([^\\/]*)$|) {
+ # wildcards with a drive prefix such as h:*.pm must be changed
+ # to h:./*.pm to expand correctly
+ if (m|^([A-Za-z]:)[^/\\]|s) {
+ substr($_,0,2) = $1 . "./";
+ }
+ if (m|^(.*)([\\/])([^\\/]*)\z|s) {
my $tail;
($head, $sepchr, $tail) = ($1,$2,$3);
#print "div: |$head|$sepchr|$tail|\n";
@@ -35,7 +40,7 @@ sub doglob {
push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
next OUTER if @globdirs;
}
- $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/;
+ $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
$_ = $tail;
}
#
@@ -142,7 +147,7 @@ sub import {
my $pkg = shift;
return unless @_;
my $sym = shift;
- my $callpkg = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0));
+ my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
*{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
}
diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index 79fdfb6ca1..46f360a461 100644
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -73,7 +73,7 @@ than VMS is settled. (defaults to FALSE)
=back
It returns the number of files successfully deleted. Symlinks are
-treated as ordinary files.
+simply deleted and not followed.
B<NOTE:> If the third parameter is not TRUE, C<rmtree> is B<unsecure>
in the face of failure or interruption. Files and directories which
@@ -205,7 +205,9 @@ sub rmtree {
}
else {
if ($safe &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
+ ($Is_VMS ? !&VMS::Filespec::candelete($root)
+ : !(-l $root || -w $root)))
+ {
print "skipped $root\n" if $verbose;
next;
}
diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm
index 28c1050576..cf048c5f0a 100644
--- a/lib/File/Spec/VMS.pm
+++ b/lib/File/Spec/VMS.pm
@@ -142,6 +142,13 @@ sub canonpath {
else { return vmsify($path); }
}
else {
+>>>> ORIGINAL VMS.pm#13
+ $path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar
+ $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo
+ if ($reduce_ricochet) {
+ $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/g;
+ $path =~ s/([\[<\.])([^\[<\.]+)\.-\.?/$1/g;
+ }
$path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar
$path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo
1 while $path =~ s{-\.-}{--}; # -.- ==> --
diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm
index 4e9ef8b6a0..097e14a7d6 100644
--- a/lib/Getopt/Long.pm
+++ b/lib/Getopt/Long.pm
@@ -100,75 +100,6 @@ sub ConfigDefaults () {
ConfigDefaults();
-################ Object Oriented routines ################
-
-=experimental
-
-# NOTE: The object oriented routines use $error for thread locking.
-eval "sub lock{}" if $] < 5.005;
-
-# 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 { lock ($error); Configure () };
-
-sub new {
- my $that = shift;
- my $class = ref($that) || $that;
-
- # Register the callers package.
- my $self = { caller => (caller)[0] };
-
- bless ($self, $class);
-
- # Process construct time configuration.
- if ( @_ > 0 ) {
- lock ($error);
- my $save = Configure ($default_config, @_);
- $self->{settings} = Configure ($save);
- }
- # Else use default config.
- else {
- $self->{settings} = $default_config;
- }
-
- $self;
-}
-
-sub configure {
- my ($self) = shift;
-
- lock ($error);
-
- # Restore settings, merge new settings in.
- my $save = Configure ($self->{settings}, @_);
-
- # Restore orig config and save the new config.
- $self->{settings} = Configure ($save);
-}
-
-sub getoptions {
- my ($self) = shift;
-
- lock ($error);
-
- # Restore config settings.
- my $save = Configure ($self->{settings});
-
- # Call main routine.
- my $ret = 0;
- $caller = $self->{caller};
- eval { $ret = GetOptions (@_); };
-
- # Restore saved settings.
- Configure ($save);
-
- # Handle errors and return value.
- die ($@) if $@;
- return $ret;
-}
-
-=cut
-
################ Package return ################
1;
diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm
index 32282d62b3..161620ba24 100644
--- a/lib/IPC/Open2.pm
+++ b/lib/IPC/Open2.pm
@@ -1,7 +1,7 @@
package IPC::Open2;
use strict;
-use vars qw($VERSION @ISA @EXPORT);
+our ($VERSION, @ISA, @EXPORT);
require 5.000;
require Exporter;
@@ -17,47 +17,64 @@ IPC::Open2, open2 - open a process for both reading and writing
=head1 SYNOPSIS
use IPC::Open2;
- $pid = open2(\*RDR, \*WTR, 'some cmd and args');
- # or
- $pid = open2(\*RDR, \*WTR, 'some', 'cmd', 'and', 'args');
+
+ $pid = open2(\*RDRFH, \*WTRFH, 'some cmd and args');
+ # or without using the shell
+ $pid = open2(\*RDRFH, \*WTRFH, 'some', 'cmd', 'and', 'args');
+
+ # or with handle autovivification
+ my($rdrfh, $wtrfh);
+ $pid = open2($rdrfh, $wtrfh, 'some cmd and args');
+ # or without using the shell
+ $pid = open2($rdrfh, $wtrfh, 'some', 'cmd', 'and', 'args');
=head1 DESCRIPTION
-The open2() function spawns the given $cmd and connects $rdr for
-reading and $wtr for writing. It's what you think should work
+The open2() function runs the given $cmd and connects $rdrfh for
+reading and $wtrfh for writing. It's what you think should work
when you try
- open(HANDLE, "|cmd args|");
+ $pid = open(HANDLE, "|cmd args|");
The write filehandle will have autoflush turned on.
-If $rdr is a string (that is, a bareword filehandle rather than a glob
-or a reference) and it begins with ">&", then the child will send output
-directly to that file handle. If $wtr is a string that begins with
-"<&", then WTR will be closed in the parent, and the child will read
+If $rdrfh is a string (that is, a bareword filehandle rather than a glob
+or a reference) and it begins with C<< >& >>, then the child will send output
+directly to that file handle. If $wtrfh is a string that begins with
+C<< <& >>, then $wtrfh will be closed in the parent, and the child will read
from it directly. In both cases, there will be a dup(2) instead of a
pipe(2) made.
-open2() returns the process ID of the child process. It doesn't return on
-failure: it just raises an exception matching C</^open2:/>.
-
-=head1 WARNING
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle. If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
-It will not create these file handles for you. You have to do this yourself.
-So don't pass it empty variables expecting them to get filled in for you.
+open2() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open2:/>. However,
+C<exec> failures in the child are not detected. You'll have to
+trap SIGPIPE yourself.
-Additionally, this is very dangerous as you may block forever.
-It assumes it's going to talk to something like B<bc>, both writing to
-it and reading from it. This is presumably safe because you "know"
-that commands like B<bc> will read a line at a time and output a line at
-a time. Programs like B<sort> that read their entire input stream first,
-however, are quite apt to cause deadlock.
+This whole affair is quite dangerous, as you may block forever. It
+assumes it's going to talk to something like B<bc>, both writing
+to it and reading from it. This is presumably safe because you
+"know" that commands like B<bc> will read a line at a time and
+output a line at a time. Programs like B<sort> that read their
+entire input stream first, however, are quite apt to cause deadlock.
The big problem with this approach is that if you don't have control
over source code being run in the child process, you can't control
what it does with pipe buffering. Thus you can't just open a pipe to
C<cat -v> and continually read and write a line from it.
+The IO::Pty and Expect modules from CPAN can help with this, as they
+provide a real tty (well, a pseudo-tty, actually), which gets you
+back to line buffering in the invoked command again.
+
+=head1 WARNING
+
+The order of arguments differs from that of open3().
+
=head1 SEE ALSO
See L<IPC::Open3> for an alternative that handles STDERR as well. This
@@ -86,10 +103,9 @@ function is really just a wrapper around open3().
require IPC::Open3;
sub open2 {
- my ($read, $write, @cmd) = @_;
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
return IPC::Open3::_open3('open2', scalar caller,
- $write, $read, '>&STDERR', @cmd);
+ $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
}
1
diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm
index d0790417bc..d43f1bdb4b 100644
--- a/lib/IPC/Open3.pm
+++ b/lib/IPC/Open3.pm
@@ -2,9 +2,8 @@ package IPC::Open3;
use strict;
no strict 'refs'; # because users pass me bareword filehandles
-use vars qw($VERSION @ISA @EXPORT $Me);
+our ($VERSION, @ISA, @EXPORT);
-require 5.001;
require Exporter;
use Carp;
@@ -23,37 +22,43 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling
$pid = open3(\*WTRFH, \*RDRFH, \*ERRFH,
'some cmd and args', 'optarg', ...);
+ my($wtr, $rdr, $err);
+ $pid = open3($wtr, $rdr, $err,
+ 'some cmd and args', 'optarg', ...);
+
=head1 DESCRIPTION
Extremely similar to open2(), open3() spawns the given $cmd and
connects RDRFH for reading, WTRFH for writing, and ERRFH for errors. If
-ERRFH is '', or the same as RDRFH, then STDOUT and STDERR of the child are
-on the same file handle. The WTRFH will have autoflush turned on.
+ERRFH is false, or the same file descriptor as RDRFH, then STDOUT and
+STDERR of the child are on the same filehandle. The WTRFH will have
+autoflush turned on.
-If WTRFH begins with "E<lt>&", then WTRFH will be closed in the parent, and
+If WTRFH begins with C<< <& >>, then WTRFH will be closed in the parent, and
the child will read from it directly. If RDRFH or ERRFH begins with
-"E<gt>&", then the child will send output directly to that file handle.
+C<< >& >>, then the child will send output directly to that filehandle.
In both cases, there will be a dup(2) instead of a pipe(2) made.
-If you try to read from the child's stdout writer and their stderr
-writer, you'll have problems with blocking, which means you'll
-want to use select(), which means you'll have to use sysread() instead
-of normal stuff.
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle. If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
open3() returns the process ID of the child process. It doesn't return on
-failure: it just raises an exception matching C</^open3:/>.
-
-=head1 WARNING
-
-It will not create these file handles for you. You have to do this
-yourself. So don't pass it empty variables expecting them to get filled
-in for you.
+failure: it just raises an exception matching C</^open3:/>. However,
+C<exec> failures in the child are not detected. You'll have to
+trap SIGPIPE yourself.
-Additionally, this is very dangerous as you may block forever. It
-assumes it's going to talk to something like B<bc>, both writing to it
-and reading from it. This is presumably safe because you "know" that
-commands like B<bc> will read a line at a time and output a line at a
-time. Programs like B<sort> that read their entire input stream first,
+If you try to read from the child's stdout writer and their stderr
+writer, you'll have problems with blocking, which means you'll want
+to use select() or the IO::Select, which means you'd best use
+sysread() instead of readline() for normal stuff.
+
+This is very dangerous, as you may block forever. It assumes it's
+going to talk to something like B<bc>, both writing to it and reading
+from it. This is presumably safe because you "know" that commands
+like B<bc> will read a line at a time and output a line at a time.
+Programs like B<sort> that read their entire input stream first,
however, are quite apt to cause deadlock.
The big problem with this approach is that if you don't have control
@@ -61,12 +66,17 @@ over source code being run in the child process, you can't control
what it does with pipe buffering. Thus you can't just open a pipe to
C<cat -v> and continually read and write a line from it.
+=head1 WARNING
+
+The order of arguments differs from that of open2().
+
=cut
# &open3: Marc Horowitz <marc@mit.edu>
# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
+# fixed for autovivving FHs, tchrist again
#
# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
#
@@ -94,7 +104,7 @@ C<cat -v> and continually read and write a line from it.
# rdr or wtr are null
# a system call fails
-$Me = 'open3 (bug)'; # you should never see this, it's always localized
+our $Me = 'open3 (bug)'; # you should never see this, it's always localized
# Fatal.pm needs to be fixed WRT prototypes.
@@ -126,15 +136,27 @@ sub _open3 {
my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
- $dad_wtr or croak "$Me: wtr should not be null";
- $dad_rdr or croak "$Me: rdr should not be null";
- $dad_err = $dad_rdr if ($dad_err eq '');
+ # simulate autovivification of filehandles because
+ # it's too ugly to use @_ throughout to make perl do it for us
+ # tchrist 5-Mar-00
+
+ unless (eval {
+ $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
+ $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
+ 1; })
+ {
+ # must strip crud for croak to add back, or looks ugly
+ $@ =~ s/(?<=value attempted) at .*//s;
+ croak "$Me: $@";
+ }
+
+ $dad_err ||= $dad_rdr;
$dup_wtr = ($dad_wtr =~ s/^[<>]&//);
$dup_rdr = ($dad_rdr =~ s/^[<>]&//);
$dup_err = ($dad_err =~ s/^[<>]&//);
- # force unqualified filehandles into callers' package
+ # force unqualified filehandles into caller's package
$dad_wtr = qualify $dad_wtr, $package;
$dad_rdr = qualify $dad_rdr, $package;
$dad_err = qualify $dad_err, $package;
@@ -185,7 +207,7 @@ sub _open3 {
xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
}
local($")=(" ");
- exec @cmd
+ exec @cmd # XXX: wrong process to croak from
or croak "$Me: exec of @cmd failed";
} elsif ($do_spawn) {
# All the bookkeeping of coincidence between handles is
diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm
index 5b7ddb6f2c..1a47f4af5e 100644
--- a/lib/Math/Complex.pm
+++ b/lib/Math/Complex.pm
@@ -66,9 +66,10 @@ use overload
# Package "privates"
#
-my $package = 'Math::Complex'; # Package name
-my $display = 'cartesian'; # Default display format
-my $eps = 1e-14; # Epsilon
+my $package = 'Math::Complex'; # Package name
+my %DISPLAY_FORMAT = ('style' => 'cartesian',
+ 'polar_pretty_print' => 1);
+my $eps = 1e-14; # Epsilon
#
# Object attributes (internal):
@@ -161,7 +162,7 @@ sub new { &make } # For backward compatibility only.
#
sub cplx {
my ($re, $im) = @_;
- return $package->make($re, defined $im ? $im : 0);
+ return __PACKAGE__->make($re, defined $im ? $im : 0);
}
#
@@ -172,7 +173,7 @@ sub cplx {
#
sub cplxe {
my ($rho, $theta) = @_;
- return $package->emake($rho, defined $theta ? $theta : 0);
+ return __PACKAGE__->emake($rho, defined $theta ? $theta : 0);
}
#
@@ -836,7 +837,7 @@ sub acos {
my $u = CORE::atan2(CORE::sqrt(1-$beta*$beta), $beta);
my $v = CORE::log($alpha + CORE::sqrt($alpha*$alpha-1));
$v = -$v if $y > 0 || ($y == 0 && $x < -1);
- return $package->make($u, $v);
+ return __PACKAGE__->make($u, $v);
}
#
@@ -858,7 +859,7 @@ sub asin {
my $u = CORE::atan2($beta, CORE::sqrt(1-$beta*$beta));
my $v = -CORE::log($alpha + CORE::sqrt($alpha*$alpha-1));
$v = -$v if $y > 0 || ($y == 0 && $x < -1);
- return $package->make($u, $v);
+ return __PACKAGE__->make($u, $v);
}
#
@@ -1154,34 +1155,53 @@ sub atan2 {
# display_format
# ->display_format
#
-# Set (fetch if no argument) display format for all complex numbers that
+# Set (get if no argument) the display format for all complex numbers that
# don't happen to have overridden it via ->display_format
#
-# When called as a method, this actually sets the display format for
+# When called as an object method, this actually sets the display format for
# the current object.
#
# Valid object formats are 'c' and 'p' for cartesian and polar. The first
# letter is used actually, so the type can be fully spelled out for clarity.
#
sub display_format {
- my $self = shift;
- my $format = undef;
+ my $self = shift;
+ my %display_format = %DISPLAY_FORMAT;
- if (ref $self) { # Called as a method
- $format = shift;
- } else { # Regular procedure call
- $format = $self;
- undef $self;
+ if (ref $self) { # Called as an object method
+ if (exists $self->{display_format}) {
+ my %obj = %{$self->{display_format}};
+ @display_format{keys %obj} = values %obj;
+ }
+ if (@_ == 1) {
+ $display_format{style} = shift;
+ } else {
+ my %new = @_;
+ @display_format{keys %new} = values %new;
+ }
+ } else { # Called as a class method
+ if (@_ = 1) {
+ $display_format{style} = $self;
+ } else {
+ my %new = @_;
+ @display_format{keys %new} = values %new;
+ }
+ undef $self;
}
if (defined $self) {
- return defined $self->{display} ? $self->{display} : $display
- unless defined $format;
- return $self->{display} = $format;
+ $self->{display_format} = { %display_format };
+ return
+ wantarray ?
+ %{$self->{display_format}} :
+ $self->{display_format}->{style};
}
- return $display unless defined $format;
- return $display = $format;
+ %DISPLAY_FORMAT = %display_format;
+ return
+ wantarray ?
+ %DISPLAY_FORMAT :
+ $DISPLAY_FORMAT{style};
}
#
@@ -1196,12 +1216,12 @@ sub display_format {
#
sub stringify {
my ($z) = shift;
- my $format;
- $format = $display;
- $format = $z->{display} if defined $z->{display};
+ my $style = $z->display_format;
+
+ $style = $DISPLAY_FORMAT{style} unless defined $style;
- return $z->stringify_polar if $format =~ /^p/i;
+ return $z->stringify_polar if $style =~ /^p/i;
return $z->stringify_cartesian;
}
@@ -1221,17 +1241,27 @@ sub stringify_cartesian {
if int(CORE::abs($y)) != int(CORE::abs($y) + $eps);
$re = "$x" if CORE::abs($x) >= $eps;
- if ($y == 1) { $im = 'i' }
- elsif ($y == -1) { $im = '-i' }
- elsif (CORE::abs($y) >= $eps) { $im = $y . "i" }
+
+ my %format = $z->display_format;
+ my $format = $format{format};
+
+ if ($y == 1) { $im = 'i' }
+ elsif ($y == -1) { $im = '-i' }
+ elsif (CORE::abs($y) >= $eps) {
+ $im = (defined $format ? sprintf($format, $y) : $y) . "i";
+ }
my $str = '';
- $str = $re if defined $re;
- $str .= "+$im" if defined $im;
- $str =~ s/\+-/-/;
- $str =~ s/^\+//;
- $str =~ s/([-+])1i/$1i/; # Not redundant with the above 1/-1 tests.
- $str = '0' unless $str;
+ $str = defined $format ? sprintf($format, $re) : $re
+ if defined $re;
+ if (defined $im) {
+ if ($y < 0) {
+ $str .= $im;
+ } elsif ($y > 0) {
+ $str .= "+" if defined $re;
+ $str .= $im;
+ }
+ }
return $str;
}
@@ -1278,6 +1308,8 @@ sub stringify_polar {
return '[0,0]' if $r <= $eps;
+ my %format = $z->display_format;
+
my $nt = $t / pit2;
$nt = ($nt - int($nt)) * pit2;
$nt += pit2 if $nt < 0; # Range [0, 2pi]
@@ -1300,7 +1332,7 @@ sub stringify_polar {
$nt -= pit2 if $nt > pi;
- if (CORE::abs($nt) >= deg1) {
+ if ($format{polar_pretty_print} && CORE::abs($nt) >= deg1) {
my ($n, $k, $kpi);
for ($k = 1, $kpi = pi; $k < 10; $k++, $kpi += pi) {
@@ -1329,12 +1361,19 @@ sub stringify_polar {
if ($theta !~ m(^-?\d*pi/\d+$) and
int(CORE::abs($theta)) != int(CORE::abs($theta) + $eps));
+ my $format = $format{format};
+ if (defined $format) {
+ $r = sprintf($format, $r);
+ $theta = sprintf($format, $theta);
+ }
+
return "\[$r,$theta\]";
}
1;
__END__
+=pod
=head1 NAME
Math::Complex - complex numbers and associated mathematical functions
@@ -1618,9 +1657,9 @@ It is possible to write:
$x = cplxe(-3, pi/4);
-but that will be silently converted into C<[3,-3pi/4]>, since the modulus
-must be non-negative (it represents the distance to the origin in the complex
-plane).
+but that will be silently converted into C<[3,-3pi/4]>, since the
+modulus must be non-negative (it represents the distance to the origin
+in the complex plane).
It is also possible to have a complex number as either argument of
either the C<make> or C<emake>: the appropriate component of
@@ -1632,31 +1671,67 @@ the argument will be used.
=head1 STRINGIFICATION
When printed, a complex number is usually shown under its cartesian
-form I<a+bi>, but there are legitimate cases where the polar format
+style I<a+bi>, but there are legitimate cases where the polar style
I<[r,t]> is more appropriate.
-By calling the routine C<Math::Complex::display_format> and supplying either
-C<"polar"> or C<"cartesian">, you override the default display format,
-which is C<"cartesian">. Not supplying any argument returns the current
-setting.
+By calling the class method C<Math::Complex::display_format> and
+supplying either C<"polar"> or C<"cartesian"> as an argument, you
+override the default display style, which is C<"cartesian">. Not
+supplying any argument returns the current settings.
This default can be overridden on a per-number basis by calling the
C<display_format> method instead. As before, not supplying any argument
-returns the current display format for this number. Otherwise whatever you
-specify will be the new display format for I<this> particular number.
+returns the current display style for this number. Otherwise whatever you
+specify will be the new display style for I<this> particular number.
For instance:
use Math::Complex;
Math::Complex::display_format('polar');
- $j = ((root(1, 3))[1];
- print "j = $j\n"; # Prints "j = [1,2pi/3]
+ $j = (root(1, 3))[1];
+ print "j = $j\n"; # Prints "j = [1,2pi/3]"
$j->display_format('cartesian');
print "j = $j\n"; # Prints "j = -0.5+0.866025403784439i"
-The polar format attempts to emphasize arguments like I<k*pi/n>
-(where I<n> is a positive integer and I<k> an integer within [-9,+9]).
+The polar style attempts to emphasize arguments like I<k*pi/n>
+(where I<n> is a positive integer and I<k> an integer within [-9,+9]),
+this is called I<polar pretty-printing>.
+
+=head2 CHANGED IN PERL 5.6
+
+The C<display_format> class method and the corresponding
+C<display_format> object method can now be called using
+a parameter hash instead of just a one parameter.
+
+The old display format style, which can have values C<"cartesian"> or
+C<"polar">, can be changed using the C<"style"> parameter. (The one
+parameter calling convention also still works.)
+
+There are two new display parameters.
+
+The first one is C<"format">, which is a sprintf()-style format
+string to be used for both parts of the complex number(s). The
+default is C<undef>, which corresponds usually (this is somewhat
+system-dependent) to C<"%.15g">. You can revert to the default by
+setting the format string to C<undef>.
+
+ # the $j from the above example
+
+ $j->display_format('format' => '%.5f');
+ print "j = $j\n"; # Prints "j = -0.50000+0.86603i"
+ $j->display_format('format' => '%.6f');
+ print "j = $j\n"; # Prints "j = -0.5+0.86603i"
+
+Notice that this affects also the return values of the
+C<display_format> methods: in list context the whole parameter hash
+will be returned, as opposed to only the style parameter value. If
+you want to know the whole truth for a complex number, you must call
+both the class method and the object method:
+
+The second new display parameter is C<"polar_pretty_print">, which can
+be set to true or false, the default being true. See the previous
+section for what this means.
=head1 USAGE
diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm
index d8dced66c8..89e3d0f432 100644
--- a/lib/Pod/Html.pm
+++ b/lib/Pod/Html.pm
@@ -1399,7 +1399,9 @@ sub process_puretext {
# converted to html commands.
#
-sub process_text1($$;$);
+sub process_text1($$;$$);
+sub pattern ($) { $_[0] ? '[^\S\n]+'.('>' x ($_[0] + 1)) : '>' }
+sub closing ($) { local($_) = shift; (defined && s/\s+$//) ? length : 0 }
sub process_text {
return if $ignore;
@@ -1408,12 +1410,15 @@ sub process_text {
$$tref = $res;
}
-sub process_text1($$;$){
- my( $lev, $rstr, $func ) = @_;
- $lev++ unless defined $func;
+sub process_text1($$;$$){
+ my( $lev, $rstr, $func, $closing ) = @_;
my $res = '';
- $func ||= '';
+ unless (defined $func) {
+ $func = '';
+ $lev++;
+ }
+
if( $func eq 'B' ){
# B<text> - boldface
$res = '<STRONG>' . process_text1( $lev, $rstr ) . '</STRONG>';
@@ -1421,7 +1426,7 @@ sub process_text1($$;$){
} elsif( $func eq 'C' ){
# C<code> - can be a ref or <CODE></CODE>
# need to extract text
- my $par = go_ahead( $rstr, 'C' );
+ my $par = go_ahead( $rstr, 'C', $closing );
## clean-up of the link target
my $text = depod( $par );
@@ -1449,7 +1454,7 @@ sub process_text1($$;$){
## 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' );
+ my $par = go_ahead( $rstr, 'L', $closing );
# some L<>'s that shouldn't be:
# a) full-blown URL's are emitted as-is
@@ -1574,17 +1579,17 @@ sub process_text1($$;$){
unless $$rstr =~ s/^>//;
} else {
- while( $$rstr =~ s/\A(.*?)([BCEFILSXZ]<|>)//s ){
+ 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
+ # terminate at closing angle bracket(s)
my $pt = $1;
- $pt .= '>' if $2 eq '>' && $lev == 1;
+ $pt .= $2 if !$3 && $lev == 1;
$res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt );
- return $res if $2 eq '>' && $lev > 1;
- if( $2 ne '>' ){
- $res .= process_text1( $lev, $rstr, substr($2,0,1) );
- }
-
+ return $res if !$3 && $lev > 1;
+ if( $3 ){
+ $res .= process_text1( $lev, $rstr, $3, closing $4 );
+ }
}
if( $lev == 1 ){
$res .= pure_text( $$rstr );
@@ -1598,16 +1603,18 @@ sub process_text1($$;$){
#
# go_ahead: extract text of an IS (can be nested)
#
-sub go_ahead($$){
- my( $rstr, $func ) = @_;
+sub go_ahead($$$){
+ my( $rstr, $func, $closing ) = @_;
my $res = '';
- my $level = 1;
- while( $$rstr =~ s/\A(.*?)([BCEFILSXZ]<|>)//s ){
+ my @closing = ($closing);
+ while( $$rstr =~
+ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|@{[pattern $closing[0]]})//s ){
$res .= $1;
- if( $2 eq '>' ){
- return $res if --$level == 0;
+ unless( $3 ){
+ shift @closing;
+ return $res unless @closing;
} else {
- ++$level;
+ unshift @closing, closing $4;
}
$res .= $2;
}
@@ -1621,7 +1628,7 @@ sub go_ahead($$){
#
sub emit_C($;$$){
my( $text, $nocode, $args ) = @_;
- $args ||= '';
+ $args = '' unless defined $args;
my $res;
my( $url, $fid ) = coderef( undef(), $text );
@@ -1907,7 +1914,7 @@ $E2c{sol} = '/';
$E2c{verbar} = '|';
$E2c{amp} = '&'; # in Tk's pods
-sub depod1($;$);
+sub depod1($;$$);
sub depod($){
my $string;
@@ -1920,15 +1927,15 @@ sub depod($){
}
}
-sub depod1($;$){
- my( $rstr, $func ) = @_;
+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])<// ){
+ while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?// ){
# recurse into its text
- $res .= $1 . depod1( $rstr, $2 );
+ $res .= $1 . depod1( $rstr, $2, closing $3);
}
$res .= $$rstr;
} elsif( $func eq 'E' ){
@@ -1944,10 +1951,11 @@ sub depod1($;$){
} else {
# all others: either recurse into new function or
# terminate at closing angle bracket
- while( $$rstr =~ s/\A(.*?)([BCEFILSXZ]<|>)// ){
+ my $term = pattern $closing;
+ while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)// ){
$res .= $1;
- last if $2 eq '>';
- $res .= depod1( $rstr, substr($2,0,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.
diff --git a/lib/Pod/InputObjects.pm b/lib/Pod/InputObjects.pm
index 9029f8ccf3..646c00862a 100644
--- a/lib/Pod/InputObjects.pm
+++ b/lib/Pod/InputObjects.pm
@@ -523,7 +523,9 @@ sub _set_child2parent_links {
## Make sure any sequences know who their parent is
for (@children) {
next if (!ref || ref eq 'SCALAR');
- if ($_->isa('Pod::InteriorSequence') or $_->can('nested')) {
+ if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or
+ UNIVERSAL::can($_, 'nested'))
+ {
$_->nested($self);
}
}
@@ -537,7 +539,8 @@ sub _unset_child2parent_links {
my $ptree = $self->{'-ptree'};
for (@$ptree) {
next unless (length and ref and ref ne 'SCALAR');
- $_->_unset_child2parent_links() if $_->isa('Pod::InteriorSequence');
+ $_->_unset_child2parent_links()
+ if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
}
}
@@ -890,7 +893,8 @@ sub _unset_child2parent_links {
local *ptree = $self;
for (@ptree) {
next unless (length and ref and ref ne 'SCALAR');
- $_->_unset_child2parent_links() if $_->isa('Pod::InteriorSequence');
+ $_->_unset_child2parent_links()
+ if UNIVERSAL::isa($_, 'Pod::InteriorSequence');
}
}
diff --git a/lib/Pod/Man.pm b/lib/Pod/Man.pm
index f096c626c8..898b5442a1 100644
--- a/lib/Pod/Man.pm
+++ b/lib/Pod/Man.pm
@@ -1,15 +1,21 @@
# Pod::Man -- Convert POD data to formatted *roff input.
-# $Id: Man.pm,v 0.8 1999/10/07 09:39:37 eagle Exp $
+# $Id: Man.pm,v 1.0 2000/03/06 10:16:31 eagle Exp $
#
-# Copyright 1999 by Russ Allbery <rra@stanford.edu>
+# Copyright 1999, 2000 by Russ Allbery <rra@stanford.edu>
#
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
#
-# This module is intended to be a replacement for pod2man, 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.
+# This module is intended to be a replacement for the pod2man script
+# distributed with versions of Perl prior to 5.6, 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 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
@@ -28,7 +34,11 @@ use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION);
@ISA = qw(Pod::Parser);
-($VERSION = (split (' ', q$Revision: 0.8 $ ))[1]) =~ s/\.(\d)$/.0$1/;
+# Don't use the CVS revision as the version, since this module is also in
+# Perl core and too many things could munge CVS magic revision strings.
+# This number should ideally be the same as the CVS revision in podlators,
+# however.
+$VERSION = 1.00;
############################################################################
@@ -254,8 +264,15 @@ $PREAMBLE = <<'----END OF PREAMBLE----';
# Static helper functions
############################################################################
-# Protect leading quotes and periods against interpretation as commands.
-sub protect { local $_ = shift; s/^([.\'])/\\&$1/mg; $_ }
+# Protect leading quotes and periods against interpretation as commands. A
+# leading *roff font escape apparently still leaves a period interpretable
+# as a command by some *roff implementations, so look for a period even
+# after one of those.
+sub protect {
+ local $_ = shift;
+ s{ ^ ( (?: \\f(?:.|\(..) )* [.\'] ) } {\\&$1}xmg;
+ $_;
+}
# 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
@@ -336,16 +353,20 @@ sub initialize {
# 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.
+ # Perl. Work a little magic to handle subversions correctly under both
+ # the pre-5.6 and the post-5.6 version numbering schemes.
if (!defined $$self{release}) {
- my ($rev, $ver, $sver) = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
- $sver ||= 0; $sver *= 10 ** (3-length($sver));
- $rev += 0; $ver += 0; $sver += 0;
- $$self{release} = "perl v$rev.$ver.$sver";
+ my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/);
+ $version[2] ||= 0;
+ $version[2] *= 10 ** (3 - length $version[2]);
+ for (@version) { $_ += 0 }
+ $$self{release} = 'perl v' . join ('.', @version);
}
# Double quotes in things that will be quoted.
- for (qw/center date release/) { $$self{$_} =~ s/\"/\"\"/g }
+ for (qw/center date release/) {
+ $$self{$_} =~ s/\"/\"\"/g if $$self{$_};
+ }
$$self{INDENT} = 0; # Current indentation level.
$$self{INDENTS} = []; # Stack of indentations.
@@ -378,11 +399,11 @@ sub begin_pod {
# which works. Should be fixed to use File::Spec.
for ($name) {
s%//+%/%g;
- if ( s%^.*?/lib/[^/]*perl[^/]*/%%is
- or s%^.*?/[^/]*perl[^/]*/(?:lib/)?%%is) {
- s%^site(_perl)?/%%s; # site and site_perl
- s%^(.*-$^O|$^O-.*)/%%os; # arch
- s%^\d+\.\d+%%s; # version
+ if ( s%^.*?/lib/[^/]*perl[^/]*/%%si
+ or s%^.*?/[^/]*perl[^/]*/(?:lib/)?%%si) {
+ s%^site(_perl)?/%%s; # site and site_perl
+ s%^(.*-$^O|$^O-.*)/%%so; # arch
+ s%^\d+\.\d+%%s; # version
}
s%/%::%g;
}
@@ -396,7 +417,7 @@ sub begin_pod {
my ($day, $month, $year) = (localtime $time)[3,4,5];
$month++;
$year += 1900;
- $$self{date} = join ('-', $year, $month, $day);
+ $$self{date} = sprintf ('%4d-%02d-%02d', $year, $month, $day);
}
# Now, print out the preamble and the title.
@@ -469,7 +490,8 @@ sub textblock {
# Perform a little magic to collapse multiple L<> references. We'll
# just rewrite the whole thing into actual text at this part, bypassing
# the whole internal sequence parsing thing.
- s{
+ my $text = shift;
+ $text =~ s{
(L< # A link of the form L</something>.
/
(
@@ -487,25 +509,26 @@ sub textblock {
)
} {
local $_ = $1;
- s{ L< / ([^>]+ ) } {$1}g;
+ s{ L< / ( [^>]+ ) > } {$1}xg;
my @items = split /(?:,?\s+(?:and\s+)?)/;
- my $string = "the ";
+ 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 .= ', ' if @items > 2 && $i != $#items;
+ $string .= ' ' if @items == 2 && $i == 2;
+ $string .= 'and ' if ($i == $#items - 1);
}
- $string .= " entries elsewhere in this document";
+ $string .= ' entries elsewhere in this document';
$string;
}gex;
# Parse the tree and output it. collapse knows about references to
# scalars as well as scalars and does the right thing with them.
- local $_ = $self->parse (@_);
- s/\n\s*$/\n/;
+ $text = $self->parse ($text, @_);
+ $text =~ s/\n\s*$/\n/;
$self->makespace if $$self{NEEDSPACE};
- $self->output (protect $self->mapfonts ($_));
+ $self->output (protect $self->mapfonts ($text));
$self->outindex;
$$self{NEEDSPACE} = 1;
}
@@ -520,7 +543,9 @@ sub sequence {
# Zero-width characters.
if ($command eq 'Z') {
- my $v = '\&'; return bless \ $v, 'Pod::Man::String';
+ # Workaround to generate a blessable reference, needed by 5.005.
+ my $tmp = '\&';
+ return bless \ "$tmp", 'Pod::Man::String';
}
# C<>, L<>, X<>, and E<> don't apply guesswork to their contents.
@@ -557,10 +582,9 @@ sub sequence {
# Handle links.
if ($command eq 'L') {
- # XXX bug in lvalue subroutines prevents this from working
- #return bless \ ($self->buildlink ($_)), 'Pod::Man::String';
- my $v = $self->buildlink($_);
- return bless \$v, 'Pod::Man::String';
+ # A bug in lvalue subs in 5.6 requires the temporary variable.
+ my $tmp = $self->buildlink ($_);
+ return bless \ "$tmp", 'Pod::Man::String';
}
# Whitespace protection replaces whitespace with "\ ".
@@ -692,7 +716,6 @@ sub cmd_end {
sub cmd_for {
my $self = shift;
local $_ = shift;
- my $line = shift;
return unless s/^(?:man|roff)\b[ \t]*\n?//;
$self->output ($_);
}
@@ -842,7 +865,7 @@ sub guesswork {
( ^ | [\s\(\"\'\`\[\{<>] )
( [A-Z] [A-Z] [/A-Z+:\d_\$&-]* )
(?: (?= [\s>\}\]\)\'\".?!,;:] | -- ) | $ )
- } { $1 . '\s-1' . $2 . '\s0' . $3 }egx;
+ } { $1 . '\s-1' . $2 . '\s0' }egx;
# Turn PI into a pretty pi.
s{ (?: \\s-1 | \b ) PI (?: \\s0 | \b ) } {\\*\(PI}gx;
@@ -1166,11 +1189,6 @@ separators.
Pod::Man is excessively slow.
-=head1 NOTES
-
-The intention is for this module and its driver script to eventually replace
-B<pod2man> in Perl core.
-
=head1 SEE ALSO
L<Pod::Parser|Pod::Parser>, perlpod(1), pod2man(1), nroff(1), troff(1),
diff --git a/lib/Pod/Parser.pm b/lib/Pod/Parser.pm
index 9ad5d161ed..88d9aa7a8f 100644
--- a/lib/Pod/Parser.pm
+++ b/lib/Pod/Parser.pm
@@ -956,8 +956,7 @@ sub parse_paragraph {
## and whatever sequence of characters was used to separate them
$pfx = $1;
$_ = substr($text, length $pfx);
- $sep = /(\s+)(?=\S)/ ? $1 : '';
- ($cmd, $text) = split(" ", $_, 2);
+ ($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') {
diff --git a/lib/Pod/Plainer.pm b/lib/Pod/Plainer.pm
new file mode 100644
index 0000000000..373e8d090a
--- /dev/null
+++ b/lib/Pod/Plainer.pm
@@ -0,0 +1,69 @@
+package Pod::Plainer;
+use strict;
+use Pod::Parser;
+our @ISA = qw(Pod::Parser);
+our $VERSION = '0.01';
+
+our %E = qw( < lt > gt );
+
+sub escape_ltgt {
+ (undef, my $text) = @_;
+ $text =~ s/([<>])/E<$E{$1}>/g;
+ $text
+}
+
+sub simple_delimiters {
+ (undef, my $seq) = @_;
+ $seq -> left_delimiter( '<' );
+ $seq -> right_delimiter( '>' );
+ $seq;
+}
+
+sub textblock {
+ my($parser,$text,$line) = @_;
+ print {$parser->output_handle()}
+ $parser->parse_text(
+ { -expand_text => q(escape_ltgt),
+ -expand_seq => q(simple_delimiters) },
+ $text, $line ) -> raw_text();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Plainer - Perl extension for converting Pod to old style Pod.
+
+=head1 SYNOPSIS
+
+ use Pod::Plainer;
+
+ my $parser = Pod::Plainer -> new ();
+ $parser -> parse_from_filehandle(\*STDIN);
+
+=head1 DESCRIPTION
+
+Pod::Plainer uses Pod::Parser which takes Pod with the (new)
+'CE<lt>E<lt> .. E<gt>E<gt>' constructs
+and returns the old(er) style with just 'CE<lt>E<gt>';
+'<' and '>' are replaced by 'EE<lt>ltE<gt>' and 'EE<lt>gtE<gt>'.
+
+This can be used to pre-process Pod before using tools which do not
+recognise the new style Pods.
+
+=head2 EXPORT
+
+None by default.
+
+=head1 AUTHOR
+
+Robin Barker, rmb1@cise.npl.co.uk
+
+=head1 SEE ALSO
+
+See L<Pod::Parser>.
+
+=cut
+
diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm
index 1425ea2438..d93e5a4b71 100644
--- a/lib/Pod/Text.pm
+++ b/lib/Pod/Text.pm
@@ -43,6 +43,7 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
# 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. :)
+# "iexcl" to "divide" added by Tim Jenness
%ESCAPES = (
'amp' => '&', # ampersand
'lt' => '<', # left chevron, less-than
@@ -112,8 +113,42 @@ use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
"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)
+ "lchevron" => "\xAB", # left chevron (double less than) laquo
+ "rchevron" => "\xBB", # right chevron (double greater than) raquo
+
+ "iexcl" => "\xA1", # inverted exclamation mark
+ "cent" => "\xA2", # cent sign
+ "pound" => "\xA3", # (UK) pound sign
+ "curren" => "\xA4", # currency sign
+ "yen" => "\xA5", # yen sign
+ "brvbar" => "\xA6", # broken vertical bar
+ "sect" => "\xA7", # section sign
+ "uml" => "\xA8", # diaresis
+ "copy" => "\xA9", # Copyright symbol
+ "ordf" => "\xAA", # feminine ordinal indicator
+ "laquo" => "\xAB", # left pointing double angle quotation mark
+ "not" => "\xAC", # not sign
+ "shy" => "\xAD", # soft hyphen
+ "reg" => "\xAE", # registered trademark
+ "macr" => "\xAF", # macron, overline
+ "deg" => "\xB0", # degree sign
+ "plusmn" => "\xB1", # plus-minus sign
+ "sup2" => "\xB2", # superscript 2
+ "sup3" => "\xB3", # superscript 3
+ "acute" => "\xB4", # acute accent
+ "micro" => "\xB5", # micro sign
+ "para" => "\xB6", # pilcrow sign = paragraph sign
+ "middot" => "\xB7", # middle dot = Georgian comma
+ "cedil" => "\xB8", # cedilla
+ "sup1" => "\xB9", # superscript 1
+ "ordm" => "\xBA", # masculine ordinal indicator
+ "raquo" => "\xBB", # right pointing double angle quotation mark
+ "frac14" => "\xBC", # vulgar fraction one quarter
+ "frac12" => "\xBD", # vulgar fraction one half
+ "frac34" => "\xBE", # vulgar fraction three quarters
+ "iquest" => "\xBF", # inverted question mark
+ "times" => "\xD7", # multiplication sign
+ "divide" => "\xF7", # division sign
);
diff --git a/lib/bytes.pm b/lib/bytes.pm
index ae7b5fbf5a..f93d6158d9 100644
--- a/lib/bytes.pm
+++ b/lib/bytes.pm
@@ -32,7 +32,7 @@ bytes - Perl pragma to force byte semantics rather than character semantics
=head1 DESCRIPTION
WARNING: The implementation of Unicode support in Perl is incomplete.
-Expect sudden and unannounced changes!
+See L<perlunicode> for the exact details.
The C<use bytes> pragma disables character semantics for the rest of the
lexical scope in which it appears. C<no bytes> can be used to reverse
diff --git a/lib/lib.pm b/lib/lib.pm
index e46c5fefa6..98e2f733cb 100644
--- a/lib/lib.pm
+++ b/lib/lib.pm
@@ -3,9 +3,10 @@ package lib;
use 5.005_64;
use Config;
-my $archname = $Config{'archname'};
-my $ver = $Config{'version'};
-my @inc_version_list = reverse split / /, $Config{'inc_version_list'};
+my $archname = defined($Config{'archname'}) ? $Config{'archname'} : '';
+my $ver = defined($Config{'version'}) ? $Config{'version'} : '';
+my @inc_version_list = defined($Config{'inc_version_list'}) ?
+ reverse split / /, $Config{'inc_version_list'} : ();
our @ORIG_INC = @INC; # take a handy copy of 'original' value
our $VERSION = '0.5564';
diff --git a/lib/open.pm b/lib/open.pm
index da8a04453c..a845459da6 100644
--- a/lib/open.pm
+++ b/lib/open.pm
@@ -1,4 +1,27 @@
package open;
+$open::hint_bits = 0x20000;
+
+sub import {
+ shift;
+ die "`use open' needs explicit list of disciplines" unless @_;
+ $^H |= $open::hint_bits;
+ while (@_) {
+ my $type = shift;
+ if ($type =~ /^(IN|OUT)\z/s) {
+ my $discp = shift;
+ unless ($discp =~ /^\s*:(raw|crlf)\s*\z/s) {
+ die "Unknown discipline '$discp'";
+ }
+ $^H{"open_$type"} = $discp;
+ }
+ else {
+ die "Unknown discipline class '$type'";
+ }
+ }
+}
+
+1;
+__END__
=head1 NAME
@@ -6,31 +29,48 @@ open - perl pragma to set default disciplines for input and output
=head1 SYNOPSIS
- use open IN => ":any", OUT => ":utf8"; # unimplemented
+ use open IN => ":crlf", OUT => ":raw";
=head1 DESCRIPTION
-NOTE: This pragma is not yet implemented.
-
The open pragma is used to declare one or more default disciplines for
-I/O operations. Any constructors for file, socket, pipe, or directory
-handles found within the lexical scope of this pragma will use the
-declared default.
+I/O operations. Any open() and readpipe() (aka qx//) operators found
+within the lexical scope of this pragma will use the declared defaults.
+Neither open() with an explicit set of disciplines, nor sysopen() are
+influenced by this pragma.
+
+Only the two pseudo-disciplines ":raw" and ":crlf" are currently
+available.
+
+The ":raw" discipline corresponds to "binary mode" and the ":crlf"
+discipline corresponds to "text mode" on platforms that distinguish
+between the two modes when opening files (which is many DOS-like
+platforms, including Windows). These two disciplines are currently
+no-ops on platforms where binmode() is a no-op, but will be
+supported everywhere in future.
-Handle constructors that are called with an explicit set of disciplines
-are not influenced by the declared defaults.
+=head1 UNIMPLEMENTED FUNCTIONALITY
-The default disciplines so declared are available by the special
-discipline name ":def", and can be used within handle constructors
-that allow disciplines to be specified. This makes it possible to
-stack new disciplines over the default ones.
+Full-fledged support for I/O disciplines is currently unimplemented.
+When they are eventually supported, this pragma will serve as one of
+the interfaces to declare default disciplines for all I/O.
+
+In future, any default disciplines declared by this pragma will be
+available by the special discipline name ":def", and could be used
+within handle constructors that allow disciplines to be specified.
+This would make it possible to stack new disciplines over the default
+ones.
open FH, "<:para :def", $file or die "can't open $file: $!";
+Socket and directory handles will also support disciplines in
+future.
+
+Full support for I/O disciplines will enable all of the supported
+disciplines to work on all platforms.
+
=head1 SEE ALSO
-L<perlunicode>, L<perlfunc/"open">
+L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>
=cut
-
-1;
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index de75bd7d86..7c5b0a909c 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -2,7 +2,7 @@ package DB;
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 1.05;
+$VERSION = 1.06;
$header = "perl5db.pl version $VERSION";
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
@@ -530,7 +530,7 @@ EOP
}
next CMD; };
$cmd =~ /^t$/ && do {
- ($trace & 1) ? ($trace &= ~1) : ($trace |= 1);
+ $trace ^= 1;
print $OUT "Trace = " .
(($trace & 1) ? "on" : "off" ) . "\n";
next CMD; };
@@ -700,11 +700,14 @@ EOP
}
}
}
+
+ if (not $had_breakpoints{$file} &= ~1) {
+ delete $had_breakpoints{$file};
+ }
}
undef %postponed;
undef %postponed_file;
undef %break_on_load;
- undef %had_breakpoints;
next CMD; };
$cmd =~ /^L$/ && do {
my $file;
@@ -779,7 +782,7 @@ EOP
$break_on_load{$::INC{$file}} = 1 if $::INC{$file};
$file .= '.pm', redo unless $file =~ /\./;
}
- $had_breakpoints{$file} = 1;
+ $had_breakpoints{$file} |= 1;
print $OUT "Will stop on load of `@{[join '\', `', sort keys %break_on_load]}'.\n";
next CMD; };
$cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
@@ -805,7 +808,7 @@ EOP
if ($i) {
local $filename = $file;
local *dbline = $main::{'_<' . $filename};
- $had_breakpoints{$filename} = 1;
+ $had_breakpoints{$filename} |= 1;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
$dbline{$i} =~ s/^[^\0]*/$cond/;
@@ -814,21 +817,22 @@ EOP
}
next CMD; };
$cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
- $i = ($1?$1:$line);
+ $i = $1 || $line;
$cond = $2 || '1';
if ($dbline[$i] == 0) {
print $OUT "Line $i not breakable.\n";
} else {
- $had_breakpoints{$filename} = 1;
+ $had_breakpoints{$filename} |= 1;
$dbline{$i} =~ s/^[^\0]*/$cond/;
}
next CMD; };
- $cmd =~ /^d\b\s*(\d+)?/ && do {
- $i = ($1?$1:$line);
+ $cmd =~ /^d\b\s*(\d*)/ && do {
+ $i = $1 || $line;
$dbline{$i} =~ s/^[^\0]*//;
delete $dbline{$i} if $dbline{$i} eq '';
next CMD; };
$cmd =~ /^A$/ && do {
+ print $OUT "Deleting all actions...\n";
my $file;
for $file (keys %had_breakpoints) {
local *dbline = $main::{'_<' . $file};
@@ -841,6 +845,10 @@ EOP
delete $dbline{$i} if $dbline{$i} eq '';
}
}
+
+ if (not $had_breakpoints{$file} &= ~2) {
+ delete $had_breakpoints{$file};
+ }
}
next CMD; };
$cmd =~ /^O\s*$/ && do {
@@ -872,13 +880,19 @@ EOP
$pretype = [], next CMD unless $1;
$pretype = [$1];
next CMD; };
- $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
- $i = $1; $j = $3;
- if ($dbline[$i] == 0) {
- print $OUT "Line $i may not have an action.\n";
+ $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
+ $i = $1 || $line; $j = $2;
+ if (length $j) {
+ if ($dbline[$i] == 0) {
+ print $OUT "Line $i may not have an action.\n";
+ } else {
+ $had_breakpoints{$filename} |= 2;
+ $dbline{$i} =~ s/\0[^\0]*//;
+ $dbline{$i} .= "\0" . action($j);
+ }
} else {
$dbline{$i} =~ s/\0[^\0]*//;
- $dbline{$i} .= "\0" . action($j);
+ delete $dbline{$i} if $dbline{$i} eq '';
}
next CMD; };
$cmd =~ /^n$/ && do {
@@ -906,7 +920,7 @@ EOP
if ($i) {
$filename = $file;
*dbline = $main::{'_<' . $filename};
- $had_breakpoints{$filename}++;
+ $had_breakpoints{$filename} |= 1;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
} else {
@@ -1086,7 +1100,7 @@ EOP
next CMD; };
$cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
pop(@hist) if length($cmd) > 1;
- $i = $1 ? ($#hist-($2?$2:1)) : ($2?$2:$#hist);
+ $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
$cmd = $hist[$i];
print $OUT $cmd, "\n";
redo CMD; };
@@ -1301,7 +1315,7 @@ sub postponed_sub {
$i += $offset;
local *dbline = $main::{'_<' . $file};
local $^W = 0; # != 0 is magical below
- $had_breakpoints{$file}++;
+ $had_breakpoints{$file} |= 1;
my $max = $#dbline;
++$i until $dbline[$i] != 0 or $i >= $max;
$dbline{$i} = delete $postponed{$subname};
@@ -1329,7 +1343,7 @@ sub postponed {
if $break_on_load{$filename};
print $LINEINFO ' ' x $stack_depth, "Package $filename.\n" if $frame;
return unless $postponed_file{$filename};
- $had_breakpoints{$filename}++;
+ $had_breakpoints{$filename} |= 1;
#%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
my $key;
for $key (keys %{$postponed_file{$filename}}) {
@@ -1821,7 +1835,7 @@ B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
B<l> I<min>B<->I<max> List lines I<min> through I<max>.
B<l> I<line> List single I<line>.
B<l> I<subname> List first window of lines from subroutine.
-B<l> I<$var> List first window of lines from subroutine referenced by I<$var>.
+B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
B<l> List next window of lines.
B<-> List previous window of lines.
B<w> [I<line>] List window around I<line>.
@@ -1844,7 +1858,7 @@ B<b> [I<line>] [I<condition>]
I<condition> breaks if it evaluates to true, defaults to '1'.
B<b> I<subname> [I<condition>]
Set breakpoint at first line of subroutine.
-B<b> I<$var> Set breakpoint at first line of subroutine referenced by I<$var>.
+B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
B<b> B<postpone> I<subname> [I<condition>]
Set breakpoint at first line of subroutine after
@@ -1854,10 +1868,12 @@ B<b> B<compile> I<subname>
B<d> [I<line>] Delete the breakpoint for I<line>.
B<D> Delete all breakpoints.
B<a> [I<line>] I<command>
- Set an action to be done before the I<line> is executed.
+ Set an action to be done before the I<line> is executed;
+ I<line> defaults to the current execution line.
Sequence is: check for breakpoint/watchpoint, print line
if necessary, do action, prompt user if necessary,
- execute expression.
+ execute line.
+B<a> [I<line>] Delete the action for I<line>.
B<A> Delete all actions.
B<W> I<expr> Add a global watch-expression.
B<W> Delete all watch-expressions.
@@ -1877,14 +1893,14 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
I<signalLevel> I<warnLevel> I<dieLevel>: level of verbosity;
I<inhibit_exit> Allows stepping off the end of the script.
I<ImmediateStop> Debugger should stop as early as possible.
- I<RemotePort>: Remote hostname:port for remote debugging
+ I<RemotePort>: Remote hostname:port for remote debugging
The following options affect what happens with B<V>, B<X>, and B<x> commands:
I<arrayDepth>, I<hashDepth>: print only first N elements ('' for all);
I<compactDump>, I<veryCompact>: change style of array and hash dump;
I<globPrint>: whether to print contents of globs;
I<DumpDBFiles>: dump arrays holding debugged files;
I<DumpPackages>: dump symbol tables of packages;
- I<DumpReused>: dump contents of \"reused\" addresses;
+ I<DumpReused>: dump contents of \"reused\" addresses;
I<quote>, I<HighBit>, I<undefPrint>: change style of string dump;
I<bareStringify>: Do not print the overload-stringified value;
Option I<PrintRet> affects printing of return value after B<r> command,
@@ -1899,7 +1915,7 @@ B<O> [I<opt>[B<=>I<val>]] [I<opt>B<\">I<val>B<\">] [I<opt>B<?>]...
B<<> I<expr> Define Perl command to run before each prompt.
B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
B<>> I<expr> Define Perl command to run after each prompt.
-B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
+B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
B<{> I<db_command> Define debugger command to run before each prompt.
B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
B<$prc> I<number> Redo a previous command (default previous command).
diff --git a/lib/utf8.pm b/lib/utf8.pm
index c362a1c516..17ec37bbe2 100644
--- a/lib/utf8.pm
+++ b/lib/utf8.pm
@@ -31,7 +31,7 @@ utf8 - Perl pragma to enable/disable UTF-8 in source code
=head1 DESCRIPTION
WARNING: The implementation of Unicode support in Perl is incomplete.
-Expect sudden and unannounced changes!
+See L<perlunicode> for the exact details.
The C<use utf8> pragma tells the Perl parser to allow UTF-8 in the
program text in the current lexical scope. The C<no utf8> pragma