diff options
| -rw-r--r-- | MANIFEST | 3 | ||||
| -rw-r--r-- | doio.c | 23 | ||||
| -rw-r--r-- | lib/File/CheckTree.pm | 6 | ||||
| -rw-r--r-- | lib/Getopt/Long.pm | 61 | ||||
| -rw-r--r-- | lib/Math/BigFloat.pm | 3 | ||||
| -rw-r--r-- | lib/Text/ParseWords.pm | 293 | ||||
| -rw-r--r-- | lib/Text/Wrap.pm | 154 | ||||
| -rw-r--r-- | lib/base.pm | 3 | ||||
| -rw-r--r-- | perl.c | 10 | ||||
| -rw-r--r-- | pod/perlre.pod | 6 | ||||
| -rwxr-xr-x | t/lib/io_sock.t | 5 | ||||
| -rwxr-xr-x | t/lib/io_udp.t | 8 | ||||
| -rwxr-xr-x | t/lib/parsewords.t | 73 | ||||
| -rwxr-xr-x | t/lib/timelocal.t | 2 | ||||
| -rwxr-xr-x | t/op/die_exit.t | 48 | ||||
| -rwxr-xr-x | t/op/ipcmsg.t | 124 | ||||
| -rwxr-xr-x | t/op/ipcsem.t | 136 | ||||
| -rwxr-xr-x | t/op/stat.t | 9 | ||||
| -rw-r--r-- | toke.c | 18 |
19 files changed, 732 insertions, 253 deletions
@@ -817,6 +817,7 @@ t/op/closure.t See if closures work t/op/cmp.t See if the various string and numeric compare work t/op/cond.t See if conditional expressions work t/op/delete.t See if delete works +t/op/die_exit.t See if die and exit status interaction works t/op/do.t See if subroutines work t/op/each.t See if hash iterators work t/op/eval.t See if eval operator works @@ -832,6 +833,8 @@ t/op/hashwarn.t See if warnings for bad hash assignments work t/op/inc.t See if inc/dec of integers near 32 bit limit work t/op/index.t See if index works t/op/int.t See if int works +t/op/ipcmsg.t See if msg* ops work +t/op/ipcsem.t See if sem* ops work t/op/join.t See if join works t/op/list.t See if array lists work t/op/local.t See if local works @@ -1305,6 +1305,18 @@ do_ipcget(I32 optype, SV **mark, SV **sp) return -1; /* should never happen */ } +#if defined(__sun__) && defined(__svr4__) /* XXX Need metaconfig test */ +/* Solaris manpage says that it uses (like linux) + int semctl (int semid, int semnum, int cmd, union semun arg) + but the system include files do not define union semun !!!! +*/ +union semun { + int val; + struct semid_ds *buf; + ushort *array; +}; +#endif + I32 do_ipcctl(I32 optype, SV **mark, SV **sp) { @@ -1313,7 +1325,8 @@ do_ipcctl(I32 optype, SV **mark, SV **sp) char *a; I32 id, n, cmd, infosize, getinfo; I32 ret = -1; -#ifdef __linux__ /* XXX Need metaconfig test */ +#if defined(__linux__) || (defined(__sun__) && defined(__svr4__)) +/* XXX Need metaconfig test */ union semun unsemds; #endif @@ -1345,8 +1358,9 @@ do_ipcctl(I32 optype, SV **mark, SV **sp) else if (cmd == GETALL || cmd == SETALL) { struct semid_ds semds; -#ifdef __linux__ /* XXX Need metaconfig test */ -/* linux (and Solaris2?) uses : +#if defined(__linux__) || (defined(__sun__) && defined(__svr4__)) + /* XXX Need metaconfig test */ +/* linux and Solaris2 uses : int semctl (int semid, int semnum, int cmd, union semun arg) union semun { int val; @@ -1405,7 +1419,8 @@ do_ipcctl(I32 optype, SV **mark, SV **sp) #endif #ifdef HAS_SEM case OP_SEMCTL: -#ifdef __linux__ /* XXX Need metaconfig test */ +#if defined(__linux__) || (defined(__sun__) && defined(__svr4__)) + /* XXX Need metaconfig test */ unsemds.buf = (struct semid_ds *)a; ret = semctl(id, n, cmd, unsemds); #else diff --git a/lib/File/CheckTree.pm b/lib/File/CheckTree.pm index a39308b6c9..dca7f6aff3 100644 --- a/lib/File/CheckTree.pm +++ b/lib/File/CheckTree.pm @@ -137,13 +137,13 @@ sub valmess { $mess =~ s/ does not / should not / || $mess =~ s/ not / /; } - print STDERR $mess,"\n"; } else { $this =~ s/\$file/'$file'/g; - print STDERR "Can't do $this.\n"; + $mess = "Can't do $this.\n"; } - if ($disposition eq 'die') { exit 1; } + die "$mess\n" if $disposition eq 'die'; + warn "$mess\n"; ++$warnings; } diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm index 38b396771b..5b5b495b57 100644 --- a/lib/Getopt/Long.pm +++ b/lib/Getopt/Long.pm @@ -2,17 +2,17 @@ package Getopt::Long; -# RCS Status : $Id: GetoptLong.pm,v 2.13 1997-12-25 16:20:17+01 jv Exp $ +# RCS Status : $Id: GetoptLong.pm,v 2.16 1998-03-13 11:05:29+01 jv Exp $ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Thu Dec 25 16:18:08 1997 -# Update Count : 647 +# Last Modified On: Fri Mar 13 11:05:28 1998 +# Update Count : 659 # Status : Released ################ Copyright ################ -# This program is Copyright 1990,1997 by Johan Vromans. +# This program is Copyright 1990,1998 by Johan Vromans. # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 2 @@ -32,10 +32,10 @@ package Getopt::Long; use strict; BEGIN { - require 5.003; + require 5.004; use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); - $VERSION = sprintf("%d.%02d", q$Revision: 2.13 $ =~ /(\d+)\.(\d+)/); + $VERSION = sprintf("%d.%02d", q$Revision: 2.16 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); @@ -87,7 +87,7 @@ sub GetOptions { $genprefix = $gen_prefix; # so we can call the same module many times $error = ''; - print STDERR ('GetOptions $Revision: 2.13 $ ', + print STDERR ('GetOptions $Revision: 2.16 $ ', "[GetOpt::Long $Getopt::Long::VERSION] -- ", "called from package \"$pkg\".\n", " (@ARGV)\n", @@ -127,7 +127,7 @@ sub GetOptions { my $opt = shift (@optionlist); # Strip leading prefix so people can specify "--foo=i" if they like. - $opt = $2 if $opt =~ /^$genprefix+(.*)$/; + $opt = $+ if $opt =~ /^$genprefix+(.*)$/s; if ( $opt eq '<>' ) { if ( (defined $userlinkage) @@ -420,9 +420,9 @@ sub config (@) { foreach $opt ( @options ) { my $try = lc ($opt); my $action = 1; - if ( $try =~ /^no_?(.*)$/ ) { + if ( $try =~ /^no_?(.*)$/s ) { $action = 0; - $try = $1; + $try = $+; } if ( $try eq 'default' or $try eq 'defaults' ) { &$config_defaults () if $action; @@ -454,6 +454,21 @@ sub config (@) { elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { $passthrough = $action; } + elsif ( $try =~ /^prefix=(.+)$/ ) { + $gen_prefix = $1; + # Turn into regexp. Needs to be parenthesized! + $gen_prefix = "(" . quotemeta($gen_prefix) . ")"; + eval { '' =~ /$gen_prefix/; }; + &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@; + } + elsif ( $try =~ /^prefix_pattern=(.+)$/ ) { + $gen_prefix = $1; + # Parenthesize if needed. + $gen_prefix = "(" . $gen_prefix . ")" + unless $gen_prefix =~ /^\(.*\)$/; + eval { '' =~ /$gen_prefix/; }; + &$croak ("Getopt::Long: invalid pattern \"$gen_prefix\"") if $@; + } elsif ( $try eq 'debug' ) { $debug = $action; } @@ -476,9 +491,9 @@ $find_option = sub { print STDERR ("=> find \"$opt\", genprefix=\"$genprefix\"\n") if $debug; - return 0 unless $opt =~ /^$genprefix(.*)$/; + return 0 unless $opt =~ /^$genprefix(.*)$/s; - $opt = $2; + $opt = $+; my ($starter) = $1; print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; @@ -488,7 +503,7 @@ $find_option = sub { # If it is a long option, it may include the value. if (($starter eq "--" || ($getopt_compat && !$bundling)) - && $opt =~ /^([^=]+)=(.*)$/ ) { + && $opt =~ /^([^=]+)=(.*)$/s ) { $opt = $1; $optarg = $2; print STDERR ("=> option \"", $opt, @@ -626,7 +641,7 @@ $find_option = sub { # Get key if this is a "name=value" pair for a hash option. $key = undef; if ($hash && defined $arg) { - ($key, $arg) = ($arg =~ /^(.*)=(.*)$/o) ? ($1, $2) : ($arg, 1); + ($key, $arg) = ($arg =~ /^(.*)=(.*)$/s) ? ($1, $2) : ($arg, 1); } #### Check if the argument is valid for this option #### @@ -650,7 +665,7 @@ $find_option = sub { } elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer - if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/ ) { + if ( $bundling && defined $rest && $rest =~ /^(-?[0-9]+)(.*)$/s ) { $arg = $1; $rest = $2; unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; @@ -683,9 +698,9 @@ $find_option = sub { # and at least one digit following the point and 'e'. # [-]NN[.NN][eNN] if ( $bundling && defined $rest && - $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/ ) { + $rest =~ /^(-?[0-9]+(\.[0-9]+)?([eE]-?[0-9]+)?)(.*)$/s ) { $arg = $1; - $rest = $4; + $rest = $+; unshift (@ARGV, $starter.$rest) if defined $rest && $rest ne ''; } elsif ( $arg !~ /^-?[0-9.]+(\.[0-9]+)?([eE]-?[0-9]+)?$/ ) { @@ -1228,6 +1243,16 @@ remaining options to some other program. This can be very confusing, especially when B<permute> is also set. +=item prefix + +The string that starts options. See also B<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 debug (default: reset) Enable copious debugging output. @@ -1262,7 +1287,7 @@ Johan Vromans E<lt>jvromans@squirrel.nlE<gt> =head1 COPYRIGHT AND DISCLAIMER -This program is Copyright 1990,1997 by Johan Vromans. +This program is Copyright 1990,1998 by Johan Vromans. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 diff --git a/lib/Math/BigFloat.pm b/lib/Math/BigFloat.pm index 7551ad01a3..77fb5dd818 100644 --- a/lib/Math/BigFloat.pm +++ b/lib/Math/BigFloat.pm @@ -37,7 +37,7 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead sub stringify { my $n = ${$_[0]}; - $n =~ s/^\+//; + my $minus = ($n =~ s/^([+-])// && $1 eq '-'); $n =~ s/E//; $n =~ s/([-+]\d+)$//; @@ -52,6 +52,7 @@ sub stringify { } else { $n = '.' . ("0" x (abs($e) - $ln)) . $n; } + $n = "-$n" if $minus; # 1 while $n =~ s/(.*\d)(\d\d\d)/$1,$2/; diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 62da1d273f..d3a89f03b8 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -1,140 +1,93 @@ package Text::ParseWords; -require 5.000; -use Carp; +use vars qw($VERSION @ISA @EXPORT); +$VERSION = "3.0"; -require AutoLoader; -*AUTOLOAD = \&AutoLoader::AUTOLOAD; +require 5.000; -require Exporter; +use Exporter; @ISA = qw(Exporter); -@EXPORT = qw(shellwords quotewords); +@EXPORT = qw(shellwords quotewords nested_quotewords parse_line); @EXPORT_OK = qw(old_shellwords); -=head1 NAME - -Text::ParseWords - parse text into an array of tokens - -=head1 SYNOPSIS - - use Text::ParseWords; - @words = "ewords($delim, $keep, @lines); - @words = &shellwords(@lines); - @words = &old_shellwords(@lines); - -=head1 DESCRIPTION -"ewords() accepts a delimiter (which can be a regular expression) -and a list of lines and then breaks those lines up into a list of -words ignoring delimiters that appear inside quotes. - -The $keep argument is a boolean flag. If true, the quotes are kept -with each word, otherwise quotes are stripped in the splitting process. -$keep also defines whether unprotected backslashes are retained. - -A &shellwords() replacement is included to demonstrate the new package. -This version differs from the original in that it will _NOT_ default -to using $_ if no arguments are given. I personally find the old behavior -to be a mis-feature. - -"ewords() works by simply jamming all of @lines into a single -string in $_ and then pulling off words a bit at a time until $_ -is exhausted. +sub shellwords { + local(@lines) = @_; + $lines[$#lines] =~ s/\s+$//; + return(quotewords('\s+', 0, @lines)); +} -=head1 AUTHORS -Hal Pomeranz (pomeranz@netcom.com), 23 March 1994 -Basically an update and generalization of the old shellwords.pl. -Much code shamelessly stolen from the old version (author unknown). +sub quotewords { + my($delim, $keep, @lines) = @_; + my($line, @words, @allwords); + + + foreach $line (@lines) { + @words = parse_line($delim, $keep, $line); + return() unless (@words || !length($line)); + push(@allwords, @words); + } + return(@allwords); +} -=cut -1; -__END__ -sub shellwords { - local(@lines) = @_; - $lines[$#lines] =~ s/\s+$//; - "ewords('\s+', 0, @lines); +sub nested_quotewords { + my($delim, $keep, @lines) = @_; + my($i, @allwords); + + for ($i = 0; $i < @lines; $i++) { + @{$allwords[$i]} = parse_line($delim, $keep, $lines[$i]); + return() unless (@{$allwords[$i]} || !length($lines[$i])); + } + return(@allwords); } -sub quotewords { - -# The inner "for" loop builds up each word (or $field) one $snippet -# at a time. A $snippet is a quoted string, a backslashed character, -# or an unquoted string. We fall out of the "for" loop when we reach -# the end of $_ or when we hit a delimiter. Falling out of the "for" -# loop, we push the $field we've been building up onto the list of -# @words we'll be returning, and then loop back and pull another word -# off of $_. -# -# The first two cases inside the "for" loop deal with quoted strings. -# The first case matches a double quoted string, removes it from $_, -# and assigns the double quoted string to $snippet in the body of the -# conditional. The second case handles single quoted strings. In -# the third case we've found a quote at the current beginning of $_, -# but it didn't match the quoted string regexps in the first two cases, -# so it must be an unbalanced quote and we croak with an error (which can -# be caught by eval()). -# -# The next case handles backslashed characters, and the next case is the -# exit case on reaching the end of the string or finding a delimiter. -# -# Otherwise, we've found an unquoted thing and we pull of characters one -# at a time until we reach something that could start another $snippet-- -# a quote of some sort, a backslash, or the delimiter. This one character -# at a time behavior was necessary if the delimiter was going to be a -# regexp (love to hear it if you can figure out a better way). - - my ($delim, $keep, @lines) = @_; - my (@words, $snippet, $field); - - local $_ = join ('', @lines); - - while (length) { - $field = ''; +sub parse_line { + my($delimiter, $keep, $line) = @_; + my($quote, $quoted, $unquoted, $delim, $word, @pieces); - for (;;) { - $snippet = ''; + while (length($line)) { + ($quote, $quoted, $unquoted, $delim) = + $line =~ m/^(["']) # a $quote + ((?:\\.|[^\1\\])*?) # and $quoted text + \1 # followed by the same quote + | # --OR-- + ^((?:\\.|[^\\"'])*?) # an $unquoted text + (\Z(?!\n)|$delimiter|(?!^)(?=["'])) + # plus EOL, delimiter, or quote + /x; # extended layout - if (s/^"([^"\\]*(\\.[^"\\]*)*)"//) { - $snippet = $1; - $snippet = qq|"$snippet"| if $keep; - } - elsif (s/^'([^'\\]*(\\.[^'\\]*)*)'//) { - $snippet = $1; - $snippet = "'$snippet'" if $keep; - } - elsif (/^["']/) { - croak 'Unmatched quote'; - } - elsif (s/^\\(.)//) { - $snippet = $1; - $snippet = "\\$snippet" if $keep; - } - elsif (!length || s/^$delim//) { - last; - } - else { - while (length && !(/^$delim/ || /^['"\\]/)) { - $snippet .= substr ($_, 0, 1); - substr($_, 0, 1) = ''; - } - } + return() unless(length($&)); + $line = $'; - $field .= $snippet; + if ($keep) { + $quoted = "$quote$quoted$quote"; + } + else { + $unquoted =~ s/\\(.)/$1/g; + $quoted =~ s/\\(.)/$1/g if ($quote eq '"'); + } + $word .= ($quote) ? $quoted : $unquoted; + + if (length($delim)) { + push(@pieces, $word); + push(@pieces, $delim) if ($keep eq 'delimiters'); + undef $word; + } + if (!length($line)) { + push(@pieces, $word); } - - push @words, $field; } - - return @words; + return(@pieces); } + sub old_shellwords { # Usage: @@ -154,13 +107,13 @@ sub old_shellwords { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^"/) { - croak "Unmatched double quote: $_"; + return(); } elsif (s/^'(([^'\\]|\\.)*)'//) { ($snippet = $1) =~ s#\\(.)#$1#g; } elsif (/^'/) { - croak "Unmatched single quote: $_"; + return(); } elsif (s/^\\(.)//) { $snippet = $1; @@ -178,3 +131,117 @@ sub old_shellwords { } @words; } + +1; + +__END__ + +=head1 NAME + +Text::ParseWords - parse text into an array of tokens or array of arrays + +=head1 SYNOPSIS + + use Text::ParseWords; + @lists = &nested_quotewords($delim, $keep, @lines); + @words = "ewords($delim, $keep, @lines); + @words = &shellwords(@lines); + @words = &parse_line($delim, $keep, $line); + @words = &old_shellwords(@lines); # DEPRECATED! + +=head1 DESCRIPTION + +The &nested_quotewords() and "ewords() functions accept a delimiter +(which can be a regular expression) +and a list of lines and then breaks those lines up into a list of +words ignoring delimiters that appear inside quotes. "ewords() +returns all of the tokens in a single long list, while &nested_quotewords() +returns a list of token lists corresponding to the elements of @lines. +&parse_line() does tokenizing on a single string. The &*quotewords() +functions simply call &parse_lines(), so if you're only splitting +one line you can call &parse_lines() directly and save a function +call. + +The $keep argument is a boolean flag. If true, then the tokens are +split on the specified delimiter, but all other characters (quotes, +backslashes, etc.) are kept in the tokens. If $keep is false then the +&*quotewords() functions remove all quotes and backslashes that are +not themselves backslash-escaped or inside of single quotes (i.e., +"ewords() tries to interpret these characters just like the Bourne +shell). NB: these semantics are significantly different from the +original version of this module shipped with Perl 5.000 through 5.004. +As an additional feature, $keep may be the keyword "delimiters" which +causes the functions to preserve the delimiters in each string as +tokens in the token lists, in addition to preserving quote and +backslash characters. + +&shellwords() is written as a special case of "ewords(), and it +does token parsing with whitespace as a delimiter-- similar to most +Unix shells. + +=head1 EXAMPLES + +The sample program: + + use Text::ParseWords; + @words = "ewords('\s+', 0, q{this is "a test" of\ quotewords \"for you}); + $i = 0; + foreach (@words) { + print "$i: <$_>\n"; + $i++; + } + +produces: + + 0: <this> + 1: <is> + 2: <a test> + 3: <of quotewords> + 4: <"for> + 5: <you> + +demonstrating: + +=over 4 + +=item 0 +a simple word + +=item 1 +multiple spaces are skipped because of our $delim + +=item 2 +use of quotes to include a space in a word + +=item 3 +use of a backslash to include a space in a word + +=item 4 +use of a backslash to remove the special meaning of a double-quote + +=item 5 +another simple word (note the lack of effect of the +backslashed double-quote) + +=back + +Replacing C<"ewords('\s+', 0, q{this is...})> +with C<&shellwords(q{this is...})> +is a simpler way to accomplish the same thing. + +=head1 AUTHORS + +Maintainer is Hal Pomeranz <pomeranz@netcom.com>, 1994-1997 (Original +author unknown). Much of the code for &parse_line() (including the +primary regexp) from Joerk Behrends <jbehrends@multimediaproduzenten.de>. + +Examples section another documentation provided by John Heidemann +<johnh@ISI.EDU> + +Bug reports, patches, and nagging provided by lots of folks-- thanks +everybody! Special thanks to Michael Schwern <schwern@envirolink.org> +for assuring me that a &nested_quotewords() would be useful, and to +Jeff Friedl <jfriedl@yahoo-inc.com> for telling me not to worry about +error-checking (sort of-- you had to be there). + +=cut diff --git a/lib/Text/Wrap.pm b/lib/Text/Wrap.pm index 0910a2ab34..0fe7fb93c2 100644 --- a/lib/Text/Wrap.pm +++ b/lib/Text/Wrap.pm @@ -1,71 +1,74 @@ package Text::Wrap; -require Exporter; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $columns $debug); +use strict; +use Exporter; -@ISA = (Exporter); +$VERSION = "97.02"; +@ISA = qw(Exporter); @EXPORT = qw(wrap); -@EXPORT_OK = qw($columns); +@EXPORT_OK = qw($columns $tabstop fill); -$VERSION = 97.011701; +use Text::Tabs qw(expand unexpand $tabstop); -use vars qw($VERSION $columns $debug); -use strict; BEGIN { - $columns = 76; # <= screen width - $debug = 0; + $columns = 76; # <= screen width + $debug = 0; } -use Text::Tabs qw(expand unexpand); - sub wrap { - my ($ip, $xp, @t) = @_; - - my $r = ""; - my $t = expand(join(" ",@t)); - my $lead = $ip; - my $ll = $columns - length(expand($lead)) - 1; - my $nl = ""; - - # remove up to a line length of things that aren't - # new lines and tabs. - - if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm) { - - # accept it. - $r .= unexpand($lead . $1); - - # recompute the leader - $lead = $xp; - $ll = $columns - length(expand($lead)) - 1; - $nl = $2; - - # repeat the above until there's none left - while ($t) { - if ( $t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm ) { - print "\$2 is '$2'\n" if $debug; - $nl = $2; - $r .= unexpand("\n" . $lead . $1); - } elsif ($t =~ s/^([^\n]{$ll})//) { - $nl = "\n"; - $r .= unexpand("\n" . $lead . $1); - } - } - $r .= $nl; - } + my ($ip, $xp, @t) = @_; + + my @rv; + my $t = expand(join(" ",@t)); + + my $lead = $ip; + my $ll = $columns - length(expand($lead)) - 1; + my $nl = ""; + + $t =~ s/^\s+//; + while(length($t) > $ll) { + # remove up to a line length of things that + # aren't new lines and tabs. + if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//) { + my ($l,$r) = ($1,$2); + $l =~ s/\s+$//; + print "WRAP $lead$l..($r)\n" if $debug; + push @rv, unexpand($lead . $l), "\n"; + + } elsif ($t =~ s/^([^\n]{$ll})//) { + print "SPLIT $lead$1..\n" if $debug; + push @rv, unexpand($lead . $1),"\n"; + } + # recompute the leader + $lead = $xp; + $ll = $columns - length(expand($lead)) - 1; + $t =~ s/^\s+//; + } + print "TAIL $lead$t\n" if $debug; + push @rv, $lead.$t if $t ne ""; + return join '', @rv; +} - die "couldn't wrap '$t'" - if length($t) > $ll; - print "-----------$r---------\n" if $debug; +sub fill +{ + my ($ip, $xp, @raw) = @_; + my @para; + my $pp; - print "Finish up with '$lead', '$t'\n" if $debug; + for $pp (split(/\n\s+/, join("\n",@raw))) { + $pp =~ s/\s+/ /g; + my $x = wrap($ip, $xp, $pp); + push(@para, $x); + } - $r .= $lead . $t if $t ne ""; + # if paragraph_indent is the same as line_indent, + # separate paragraphs with blank lines - print "-----------$r---------\n" if $debug;; - return $r; + return join ($ip eq $xp ? "\n\n" : "\n", @para); } 1; @@ -81,9 +84,13 @@ Text::Wrap - line wrapping to form simple paragraphs print wrap($initial_tab, $subsequent_tab, @text); - use Text::Wrap qw(wrap $columns); + use Text::Wrap qw(wrap $columns $tabstop fill); $columns = 132; + $tabstop = 4; + + print fill($initial_tab, $subsequent_tab, @text); + print fill("", "", `cat book`); =head1 DESCRIPTION @@ -93,6 +100,12 @@ Indentation is controlled for the first line ($initial_tab) and all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns should be set to the full width of your output device. +Text::Wrap::fill() is a simple multi-paragraph formatter. It formats +each paragraph separately and then joins them together when it's done. It +will destory any whitespace in the original text. It breaks text into +paragraphs by looking for whitespace after a newline. In other respects +it acts like wrap(). + =head1 EXAMPLE print wrap("\t","","This is a bit of text that forms @@ -102,44 +115,11 @@ should be set to the full width of your output device. It's not clear what the correct behavior should be when Wrap() is presented with a word that is longer than a line. The previous -behavior was to die. Now the word is split at line-length. +behavior was to die. Now the word is now split at line-length. =head1 AUTHOR David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and -others. +others. Updated by Jacqui Caren. =cut - -Latest change by Andreas Koenig <k@anna.in-berlin.de> - 1/17/97 - - print fill($initial_tab, $subsequent_tab, @text); - - print fill("", "", `cat book`); - -Text::Wrap::fill() is a simple multi-paragraph formatter. It formats -each paragraph separately and then joins them together when it's done. It -will destory any whitespace in the original text. It breaks text into -paragraphs by looking for whitespace after a newline. In other respects -it acts like wrap(). - -# Tim Pierce did a faster version of this: - -sub fill -{ - my ($ip, $xp, @raw) = @_; - my @para; - my $pp; - - for $pp (split(/\n\s+/, join("\n",@raw))) { - $pp =~ s/\s+/ /g; - my $x = wrap($ip, $xp, $pp); - push(@para, $x); - } - - # if paragraph_indent is the same as line_indent, - # separate paragraphs with blank lines - - return join ($ip eq $xp ? "\n\n" : "\n", @para); -} - diff --git a/lib/base.pm b/lib/base.pm index e20a64bc9a..4c4fb8b86b 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -34,6 +34,9 @@ sub import { foreach my $base (@_) { unless (defined %{"$base\::"}) { eval "require $base"; + # Only ignore "Can't locate" errors from our eval require. + # Other fatal errors (syntax etc) must be reported. + die if $@ && $@ !~ /^Can't locate .*? at \(eval /; unless (defined %{"$base\::"}) { require Carp; Carp::croak("Base class package \"$base\" is empty.\n", @@ -2795,10 +2795,16 @@ my_failure_exit(void) STATUS_NATIVE_SET(vaxc$errno); } #else + int exitstatus; if (errno & 255) STATUS_POSIX_SET(errno); - else if (STATUS_POSIX == 0) - STATUS_POSIX_SET(255); + else { + exitstatus = STATUS_POSIX >> 8; + if (exitstatus & 255) + STATUS_POSIX_SET(exitstatus); + else + STATUS_POSIX_SET(255); + } #endif my_exit_jump(); } diff --git a/pod/perlre.pod b/pod/perlre.pod index e985377586..95da75d95f 100644 --- a/pod/perlre.pod +++ b/pod/perlre.pod @@ -704,4 +704,10 @@ different things on the I<left> side of the C<s///>. =head2 SEE ALSO +L<perlop/"Regexp Quote-Like Operators">. + +L<perlfunc/pos>. + +L<perllocale>. + "Mastering Regular Expressions" (see L<perlbook>) by Jeffrey Friedl. diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t index 0971e7803f..9fab56b237 100755 --- a/t/lib/io_sock.t +++ b/t/lib/io_sock.t @@ -55,11 +55,14 @@ if($pid = fork()) { # This can fail if localhost is undefined or the # special 'loopback' address 127.0.0.1 is not configured # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + # As a shortcut (not recommended) you could change 'localhost' + # here to be the name of this machine eg 'myhost.mycompany.com'. $sock = IO::Socket::INET->new(PeerPort => $port, Proto => 'tcp', PeerAddr => 'localhost' - ) or die "$!"; + ) + or die "$! (maybe your system does not have the 'localhost' address defined)"; $sock->autoflush(1); diff --git a/t/lib/io_udp.t b/t/lib/io_udp.t index 3e16714118..014e12dc58 100755 --- a/t/lib/io_udp.t +++ b/t/lib/io_udp.t @@ -30,9 +30,13 @@ use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); # This can fail if localhost is undefined or the # special 'loopback' address 127.0.0.1 is not configured # on your system. (/etc/rc.config.d/netconfig on HP-UX.) + # As a shortcut (not recommended) you could change 'localhost' + # here to be the name of this machine eg 'myhost.mycompany.com'. -$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); -$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); +$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') + or die "$! (maybe your system does not have the 'localhost' address defined)"; +$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost') + or die "$! (maybe your system does not have the 'localhost' address defined)"; print "ok 1\n"; diff --git a/t/lib/parsewords.t b/t/lib/parsewords.t index 47a75881dc..21ed0d3eae 100755 --- a/t/lib/parsewords.t +++ b/t/lib/parsewords.t @@ -5,24 +5,77 @@ BEGIN { @INC = '../lib'; } -print "1..4\n"; - use Text::ParseWords; -@words = shellwords(qq(foo "bar quiz" zoo)); -#print join(";", @words), "\n"; +print "1..15\n"; +@words = shellwords(qq(foo "bar quiz" zoo)); print "not " if $words[0] ne 'foo'; print "ok 1\n"; - print "not " if $words[1] ne 'bar quiz'; print "ok 2\n"; - print "not " if $words[2] ne 'zoo'; print "ok 3\n"; -# Test quotewords() with other parameters -@words = quotewords(":+", 1, qq(foo:::"bar:foo":zoo zoo:)); -#print join(";", @words), "\n"; -print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo); +# Test quotewords() with other parameters and null last field +@words = quotewords(':+', 1, 'foo:::"bar:foo":zoo zoo:'); +print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo;); print "ok 4\n"; + +# Test $keep eq 'delimiters' and last field zero +@words = quotewords('\s+', 'delimiters', '4 3 2 1 0'); +print "not " unless join(";", @words) eq qq(4; ;3; ;2; ;1; ;0); +print "ok 5\n"; + +# Big ol' nasty test (thanks, Joerk!) +$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd" eee\\\\\\"ffff" "gg"'; + +# First with $keep == 1 +$result = join('|', parse_line('\s+', 1, $string)); +print "not " unless $result eq 'aaaa"bbbbb"|cc\\ cc|\\\\\\"dddd" eee\\\\\\"ffff"|"gg"'; +print "ok 6\n"; + +# Now, $keep == 0 +$result = join('|', parse_line('\s+', 0, $string)); +print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\"ffff|gg'; +print "ok 7\n"; + +# Now test single quote behavior +$string = 'aaaa"bbbbb" cc\\ cc \\\\\\"dddd\' eee\\\\\\"ffff\' gg'; +$result = join('|', parse_line('\s+', 0, $string)); +print "not " unless $result eq 'aaaabbbbb|cc cc|\\"dddd eee\\\\\\"ffff|gg'; +print "ok 8\n"; + +# Make sure @nested_quotewords does the right thing +@lists = nested_quotewords('\s+', 0, 'a b c', '1 2 3', 'x y z'); +print "not " unless (@lists == 3 && @{$lists[0]} == 3 && @{$lists[1]} == 3 && @{$lists[2]} == 3); +print "ok 9\n"; + +# Now test error return +$string = 'foo bar baz"bach blech boop'; + +@words = shellwords($string); +print "not " if (@words); +print "ok 10\n"; + +@words = parse_line('s+', 0, $string); +print "not " if (@words); +print "ok 11\n"; + +@words = quotewords('s+', 0, $string); +print "not " if (@words); +print "ok 12\n"; + +@words = nested_quotewords('s+', 0, $string); +print "not " if (@words); +print "ok 13\n"; + +# Now test empty fields +$result = join('|', parse_line(':', 0, 'foo::0:"":::')); +print "not " unless ($result eq 'foo||0||||'); +print "ok 14\n"; + +# Test for 0 in quotes without $keep +$result = join('|', parse_line(':', 0, ':"0":')); +print "not " unless ($result eq '|0|'); +print "ok 15\n"; diff --git a/t/lib/timelocal.t b/t/lib/timelocal.t index 938ca695b1..100e0768aa 100755 --- a/t/lib/timelocal.t +++ b/t/lib/timelocal.t @@ -11,7 +11,7 @@ use Time::Local; @time = ( #year,mon,day,hour,min,sec - [1970, 1, 1, 00, 00, 00], + [1970, 1, 2, 00, 00, 00], [1980, 2, 28, 12, 00, 00], [1980, 2, 29, 12, 00, 00], [1999, 12, 31, 23, 59, 59], diff --git a/t/op/die_exit.t b/t/op/die_exit.t new file mode 100755 index 0000000000..b01dd35a97 --- /dev/null +++ b/t/op/die_exit.t @@ -0,0 +1,48 @@ +#!./perl + +# +# Verify that C<die> return the return code +# -- Robin Barker <rmb@cise.npl.co.uk> +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -e '../lib'; +} +my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl'; + +use strict; + +my %tests = ( + 1 => [ 0, 0], + 2 => [ 0, 1], + 3 => [ 0, 127], + 4 => [ 0, 128], + 5 => [ 0, 255], + 6 => [ 0, 256], + 7 => [ 0, 512], + 8 => [ 1, 0], + 9 => [ 1, 1], + 10 => [ 1, 256], + 11 => [ 128, 0], + 12 => [ 128, 1], + 13 => [ 128, 256], + 14 => [ 255, 0], + 15 => [ 255, 1], + 16 => [ 255, 256], +); + +my $max = keys %tests; + +print "1..$max\n"; + +foreach my $test (1 .. $max) { + my($bang, $query) = @{$tests{$test}}; + my $exit = + system qq($perl -e '\$! = $bang; \$? = $query; die;' 2> /dev/null); + + printf "# 0x%04x 0x%04x 0x%04x\nnot ", $exit, $bang, $query + unless $exit == (($bang || ($query >> 8) || 255) << 8); + print "ok $test\n"; +} + diff --git a/t/op/ipcmsg.t b/t/op/ipcmsg.t new file mode 100755 index 0000000000..336d6d1253 --- /dev/null +++ b/t/op/ipcmsg.t @@ -0,0 +1,124 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +my @define; + +BEGIN { + @define = qw( + IPC_PRIVATE + IPC_RMID + IPC_NOWAIT + IPC_STAT + S_IRWXU + S_IRWXG + S_IRWXO + ); +} + +use Config; +use vars map { '$' . $_ } @define; + +BEGIN { + unless($Config{'d_msgget'} eq 'define' && + $Config{'d_msgctl'} eq 'define' && + $Config{'d_msgsnd'} eq 'define' && + $Config{'d_msgrcv'} eq 'define') { + print "0..0\n"; + exit; + } + my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth})); + my %done = (); + my %define = (); + + sub process_file { + my($file) = @_; + + return unless defined $file; + + my $path = undef; + my $dir; + foreach $dir (@incpath) { + my $tmp = $dir . "/" . $file; + next unless -r $tmp; + $path = $tmp; + last; + } + + return if exists $done{$path}; + $done{$path} = 1; + + unless(defined $path) { + warn "Cannot find '$file'"; + return; + } + + open(F,$path) or return; + while(<F>) { + s#/\*.*(\*/|$)##; + + process_file($mm,$1) + if /^#\s*include\s*[<"]([^>"]+)[>"]/; + + s/(?:\([^)]*\)\s*)//; + + $define{$1} = $2 + if /^#\s*define\s+(\w+)\s+((0x)?\d+|\w+)/; + } + close(F); + } + + process_file("sys/sem.h"); + process_file("sys/ipc.h"); + process_file("sys/stat.h"); + + foreach $d (@define) { + while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) { + $define{$d} = exists $define{$define{$d}} + ? $define{$define{$d}} : undef; + } + unless(defined $define{$d}) { + print "0..0\n"; + exit; + }; + ${ $d } = eval $define{$d}; + } +} + +use strict; + +print "1..6\n"; + +my $msg = msgget($IPC_PRIVATE, $S_IRWXU | $S_IRWXG | $S_IRWXO) + || die "msgget failed: $!\n"; + +print "ok 1\n"; + +#Putting a message on the queue +my $msgtype = 1; +my $msgtext = "hello"; + +msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not "; +print "ok 2\n"; + +my $data; +msgctl($msg,$IPC_STAT,$data) or print "not "; +print "ok 3\n"; + +print "not " unless length($data); +print "ok 4\n"; + +my $msgbuf; +msgrcv($msg,$msgbuf,256,0,$IPC_NOWAIT) or print "not "; +print "ok 5\n"; + +my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf); + +print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext); +print "ok 6\n"; + +msgctl($msg,$IPC_RMID,0); + diff --git a/t/op/ipcsem.t b/t/op/ipcsem.t new file mode 100755 index 0000000000..abe32fbf51 --- /dev/null +++ b/t/op/ipcsem.t @@ -0,0 +1,136 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +my @define; + +BEGIN { + @define = qw( + GETALL + SETALL + IPC_PRIVATE + IPC_CREAT + IPC_RMID + IPC_STAT + S_IRWXU + S_IRWXG + S_IRWXO + ); +} + +use Config; +use vars map { '$' . $_ } @define; + +BEGIN { + unless($Config{'d_semget'} eq 'define' && + $Config{'d_semctl'} eq 'define') { + print "0..0\n"; + exit; + } + my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth})); + my %done = (); + my %define = (); + + sub process_file { + my($file) = @_; + + return unless defined $file; + + my $path = undef; + my $dir; + foreach $dir (@incpath) { + my $tmp = $dir . "/" . $file; + next unless -r $tmp; + $path = $tmp; + last; + } + + return if exists $done{$path}; + $done{$path} = 1; + + unless(defined $path) { + warn "Cannot find '$file'"; + return; + } + + open(F,$path) or return; + while(<F>) { + s#/\*.*(\*/|$)##; + + process_file($mm,$1) + if /^#\s*include\s*[<"]([^>"]+)[>"]/; + + s/(?:\([^)]*\)\s*)//; + + $define{$1} = $2 + if /^#\s*define\s+(\w+)\s+((0x)?\d+|\w+)/; + } + close(F); + } + + process_file("sys/sem.h"); + process_file("sys/ipc.h"); + process_file("sys/stat.h"); + + foreach $d (@define) { + while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) { + $define{$d} = exists $define{$define{$d}} + ? $define{$define{$d}} : undef; + } + unless(defined $define{$d}) { + print "0..0\n"; + exit; + }; + ${ $d } = eval $define{$d}; + } +} + +use strict; + +print "1..10\n"; + +my $sem = semget($IPC_PRIVATE, 10, $S_IRWXU | $S_IRWXG | $S_IRWXO | $IPC_CREAT) + || die "semget: $!\n"; + +print "ok 1\n"; + +my $data; +semctl($sem,0,$IPC_STAT,$data) or print "not "; +print "ok 2\n"; + +print "not " unless length($data); +print "ok 3\n"; + +semctl($sem,0,$SETALL,pack("s*",(0) x 10)) or print "not "; +print "ok 4\n"; + +$data = ""; +semctl($sem,0,$GETALL,$data) or print "not "; +print "ok 5\n"; + +print "not " unless length($data); +print "ok 6\n"; + +my @data = unpack("s*",$data); + +print "not " unless join("",@data) eq "0000000000"; +print "ok 7\n"; + +$data[2] = 1; +semctl($sem,0,$SETALL,pack("s*",@data)) or print "not "; +print "ok 8\n"; + +$data = ""; +semctl($sem,0,$GETALL,$data) or print "not "; +print "ok 9\n"; + +@data = unpack("s*",$data); + +print "not " unless join("",@data) eq "0010000000"; +print "ok 10\n"; + +semctl($sem,0,$IPC_RMID,undef); + diff --git a/t/op/stat.t b/t/op/stat.t index 9d4b3a6787..c7cd0961f3 100755 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -45,7 +45,12 @@ else { if ($Is_MSWin32 || $Is_Dos || $Config{dont_use_nlink} || $nlink == 2) {print "ok 3\n";} else {print "# \$nlink is |$nlink|\nnot ok 3\n";} -if ($Is_MSWin32 || $Is_Dos || ($mtime && $mtime != $ctime) || $cwd =~ m#/afs/# || $^O eq 'amigaos') { +if ( ($mtime && $mtime != $ctime) + || $Is_MSWin32 + || $Is_Dos + || ($cwd eq '/tmp' and $mtime && $mtime==$ctime) # Solaris tmpfs bug + || $cwd =~ m#/afs/# + || $^O eq 'amigaos') { print "ok 4\n"; } else { @@ -53,7 +58,7 @@ else { print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n"; print "#4 of some sort. Building in /tmp sometimes has this problem.\n"; } -print "#4 :$mtime: != :$ctime:\n"; +print "#4 :$mtime: should != :$ctime:\n"; unlink "Op.stat.tmp"; if ($Is_MSWin32) { open F, '>Op.stat.tmp' and close F } @@ -768,6 +768,12 @@ sublex_done(void) processing a pattern (lex_inpat is true), a transliteration (lex_inwhat & OP_TRANS is true), or a double-quoted string. + Returns a pointer to the character scanned up to. Iff this is + advanced from the start pointer supplied (ie if anything was + successfully parsed), will leave an OP for the substring scanned + in yylval. Caller must intuit reason for not parsing further + by looking at the next characters herself. + In patterns: backslashes: double-quoted style: \r and \n @@ -835,17 +841,11 @@ scan_const(char *start) bool dorange = FALSE; /* are we in a translit range? */ I32 len; /* ? */ - /* - leave is the set of acceptably-backslashed characters. - - I do *not* understand why there's the double hook here. - */ + /* leaveit is the set of acceptably-backslashed characters */ char *leaveit = lex_inpat ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#" - : (lex_inwhat & OP_TRANS) - ? "" - : ""; + : ""; while (s < send || dorange) { /* get transliterations out of the way (they're most literal) */ @@ -1032,7 +1032,7 @@ scan_const(char *start) Renew(SvPVX(sv), SvLEN(sv), char); } - /* ??? */ + /* return the substring (via yylval) only if we parsed anything */ if (s > bufptr) yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); else |