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
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
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)
{
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
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;
#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
$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;
}
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
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);
$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",
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)
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;
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;
}
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;
# 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,
# 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 ####
}
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 '';
# 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]+)?$/ ) {
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.
=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
sub stringify {
my $n = ${$_[0]};
- $n =~ s/^\+//;
+ my $minus = ($n =~ s/^([+-])// && $1 eq '-');
$n =~ s/E//;
$n =~ s/([-+]\d+)$//;
} else {
$n = '.' . ("0" x (abs($e) - $ln)) . $n;
}
+ $n = "-$n" if $minus;
# 1 while $n =~ s/(.*\d)(\d\d\d)/$1,$2/;
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:
($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;
}
@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
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;
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
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
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);
-}
-
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",
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();
}
=head2 SEE ALSO
+L<perlop/"Regexp Quote-Like Operators">.
+
+L<perlfunc/pos>.
+
+L<perllocale>.
+
"Mastering Regular Expressions" (see L<perlbook>) by Jeffrey Friedl.
# 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);
# 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";
@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";
@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],
--- /dev/null
+#!./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";
+}
+
--- /dev/null
+#!./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);
+
--- /dev/null
+#!./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);
+
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 {
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 }
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
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) */
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
projects / p5sagit/p5-mst-13.2.git / commitdiff