Carl M. Fongheiser <cmf@ins.infonet.net>
Carl Witty <cwitty@newtonlabs.com>
Cary D. Renzema <caryr@mxim.com>
-Casey R. Tweten <crt@kiski.net>
+Casey West <casey@geeknest.com>
Castor Fu
Chaim Frenkel <chaimf@pobox.com>
Charles Bailey <bailey@newman.upenn.edu>
Dominique Dumont <Dominique_Dumont@grenoble.hp.com>
Doug Campbell <soup@ampersand.com>
Doug MacEachern <dougm@covalent.net>
-Douglas E. Wegscheid <wegscd@whirlpool.com>
+Douglas E. Wegscheid <dwegscheid@qtm.net>
Douglas Lankshear <dougl@activestate.com>
Dov Grobgeld <dov@Orbotech.Co.IL>
Drago Goricanec <drago@raptor.otsd.ts.fujitsu.co.jp>
Version v5.7.1 Development release working toward v5.8
--------------
____________________________________________________________________________
+[ 9717] By: jhi on 2001/04/16 03:06:28
+ Log: Regen toc.
+ Branch: perl
+ ! pod/perltoc.pod
+____________________________________________________________________________
+[ 9716] By: jhi on 2001/04/16 02:58:42
+ Log: Subject: [PATCH: perl@9699] updates to apidoc in utf8.c
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Sun, 15 Apr 2001 20:47:45 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0104152037470.8946-100000@shell8.ba.best.com>
+ Branch: perl
+ ! utf8.c
+____________________________________________________________________________
+[ 9715] By: jhi on 2001/04/15 23:40:35
+ Log: Subject: Re: Net::Ping patch, adds stream protocol
+ From: bronson@rinspin.com (Scott Bronson)
+ Date: Tue, 10 Apr 2001 23:58:33 -0700
+ Message-ID: <20010410235833.N29719@rinspin.com>
+ Branch: perl
+ ! lib/Net/Ping.pm
+____________________________________________________________________________
+[ 9714] By: jhi on 2001/04/15 23:31:46
+ Log: Printing out the ok messages helps successful testing.
+ Branch: perl
+ ! t/lib/time-hires.t
+____________________________________________________________________________
+[ 9713] By: jhi on 2001/04/15 21:43:24
+ Log: Update Douglas Wegscheid's email.
+ Branch: perl
+ ! AUTHORS
+____________________________________________________________________________
+[ 9712] By: jhi on 2001/04/15 21:40:41
+ Log: Subject: [PATCH t/lib/exporter.t lib/Exporter/Heavy.pm] Testing Exporter
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 14 Apr 2001 22:40:50 +0100
+ Message-ID: <20010414224050.A1872@blackrider.blackstar.co.uk>
+ Branch: perl
+ + t/lib/exporter.t
+ ! MANIFEST lib/Exporter/Heavy.pm
+____________________________________________________________________________
+[ 9711] By: jhi on 2001/04/15 21:39:21
+ Log: Subject: [PATCH t/op/loopctl.t] Exit via last, part 1
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 14 Apr 2001 22:13:59 +0100
+ Message-ID: <20010414221359.A413@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! t/op/loopctl.t
+____________________________________________________________________________
+[ 9710] By: jhi on 2001/04/15 21:30:19
+ Log: Subject: [PATCH t/pragma/warnings.t] Doesn't skip RCS files
+ From: Michael G Schwern <schwern@pobox.com>
+ Date: Sat, 14 Apr 2001 22:05:32 +0100
+ Message-ID: <20010414220531.A30178@blackrider.blackstar.co.uk>
+ Branch: perl
+ ! t/pragma/warnings.t
+____________________________________________________________________________
+[ 9709] By: jhi on 2001/04/15 19:34:09
+ Log: Integrate changes #9706,9707 from maintperl into mainline.
+
+ change#7210 broke .packlist generation
+
+ ExtUtils::Installed doesn't quote regex metacharacters in paths
+ before using them in match; also make it work for dosish platforms
+ Branch: perl
+ !> lib/ExtUtils/Install.pm lib/ExtUtils/Installed.pm
+____________________________________________________________________________
+[ 9708] By: jhi on 2001/04/15 19:31:01
+ Log: Test also the scalar aspect of getitimer().
+ Branch: perl
+ ! t/lib/time-hires.t
+____________________________________________________________________________
+[ 9707] By: gsar on 2001/04/15 17:24:20
+ Log: ExtUtils::Installed doesn't quote regex metacharacters in paths
+ before using them in match; also make it work for dosish platforms
+ Branch: maint-5.6/perl
+ ! lib/ExtUtils/Installed.pm
+____________________________________________________________________________
+[ 9706] By: gsar on 2001/04/15 17:21:59
+ Log: change#7210 broke .packlist generation (listed only filename
+ rather than fully qualified path name)
+ Branch: maint-5.6/perl
+ ! lib/ExtUtils/Install.pm
+____________________________________________________________________________
+[ 9705] By: jhi on 2001/04/15 12:36:33
+ Log: Add interval timer (setitimer, getitimer) support to Time::HiRes.
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.pm ext/Time/HiRes/HiRes.xs
+ ! t/lib/time-hires.t
+____________________________________________________________________________
+[ 9704] By: jhi on 2001/04/15 10:49:08
+ Log: Subject: [PATCH: perl@9622]update perlebcdic.pod with UTF tbl; tweak utf8.pm
+ From: Prymmer/Kahn <pvhp@best.com>
+ Date: Sat, 14 Apr 2001 21:36:24 -0700 (PDT)
+ Message-ID: <Pine.BSF.4.21.0104142127580.27582-100000@shell8.ba.best.com>
+ Branch: perl
+ ! lib/utf8.pm pod/perlebcdic.pod
+____________________________________________________________________________
+[ 9703] By: jhi on 2001/04/15 02:26:26
+ Log: I keep forgetting to sort MANIFEST.
+ Branch: perl
+ ! MANIFEST
+____________________________________________________________________________
+[ 9702] By: jhi on 2001/04/15 02:07:47
+ Log: Add Scalar-List-Utils 1.02, from Graham Barr.
+ Now we have blessed, reftype, tainted, first, reduce, ...
+ Branch: perl
+ + ext/List/Util/ChangeLog ext/List/Util/Makefile.PL
+ + ext/List/Util/README ext/List/Util/Util.xs
+ + ext/List/Util/lib/List/Util.pm
+ + ext/List/Util/lib/Scalar/Util.pm t/lib/u-blessed.t
+ + t/lib/u-dualvar.t t/lib/u-first.t t/lib/u-max.t
+ + t/lib/u-maxstr.t t/lib/u-min.t t/lib/u-minstr.t
+ + t/lib/u-readonly.t t/lib/u-reduce.t t/lib/u-reftype.t
+ + t/lib/u-sum.t t/lib/u-tainted.t t/lib/u-weak.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 9701] By: jhi on 2001/04/14 15:05:25
+ Log: Subject: RE: dprofpp.pl updates
+ From: Carl Eklof <CEklof@endeca.com>
+ Date: Thu, 12 Apr 2001 18:45:46 -0400
+ Message-ID: <D99914D9109BD411823800508BD957180E1269@exch01.ops.endeca.com>
+ Branch: perl
+ ! utils/dprofpp.PL
+____________________________________________________________________________
+[ 9700] By: jhi on 2001/04/14 14:44:55
+ Log: Do not just blindly add CR.
+ Branch: perl
+ ! Porting/makerel
+____________________________________________________________________________
+[ 9699] By: jhi on 2001/04/13 13:17:01
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+____________________________________________________________________________
+[ 9698] By: jhi on 2001/04/13 12:44:48
+ Log: Integrate perlio.
+ Branch: perl
+ !> ext/PerlIO/Scalar/Scalar.xs
+____________________________________________________________________________
+[ 9697] By: jhi on 2001/04/13 12:29:15
+ Log: Add more debug output to the test.
+ Branch: perl
+ ! t/lib/cwd.t
+____________________________________________________________________________
+[ 9696] By: nick on 2001/04/13 10:14:29
+ Log: Fix core dump on binmode($fh,'Scalar')
+ Branch: perlio
+ ! ext/PerlIO/Scalar/Scalar.xs
+____________________________________________________________________________
+[ 9695] By: nick on 2001/04/13 09:05:42
+ Log: Integrate mainline
+ Branch: perlio
+ +> ext/Time/HiRes/Changes ext/Time/HiRes/HiRes.pm
+ +> ext/Time/HiRes/HiRes.xs ext/Time/HiRes/Makefile.PL
+ +> t/lib/time-hires.t
+ !> AUTHORS MANIFEST Makefile.SH Todo-5.6 configure.com
+ !> ext/Digest/MD5/MD5.xs ext/File/Glob/Glob.pm
+ !> ext/File/Glob/Glob.xs ext/File/Glob/bsd_glob.c
+ !> ext/File/Glob/bsd_glob.h ext/MIME/Base64/Base64.xs
+ !> hints/uts.sh hints/vmesa.sh lib/Devel/SelfStubber.pm opcode.pl
+ !> pod/perlfaq5.pod pp.c regexec.c t/comp/proto.t
+ !> t/lib/md5-file.t t/op/pat.t win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 9694] By: jhi on 2001/04/12 22:23:35
+ Log: Integrate change #9693 from maintperl into mainline.
+
+ $VERSION and Version() on the same line provokes a warning from
+ CPAN.pm (from Jonathan Leffler <jleffler@informix.com>)
+ Branch: perl
+ !> lib/Devel/SelfStubber.pm
+____________________________________________________________________________
+[ 9693] By: gsar on 2001/04/12 21:55:56
+ Log: $VERSION and Version() on the same line provokes a warning from
+ CPAN.pm (from Jonathan Leffler <jleffler@informix.com>)
+ Branch: maint-5.6/perl
+ ! lib/Devel/SelfStubber.pm
+____________________________________________________________________________
+[ 9692] By: jhi on 2001/04/12 13:54:00
+ Log: This is at least 5.005.
+ Branch: perl
+ ! ext/Time/HiRes/HiRes.xs
+____________________________________________________________________________
+[ 9691] By: jhi on 2001/04/12 13:37:20
+ Log: Non-UNIX platforms extensions update. (Well, UTS is UNIX.)
+ Branch: perl
+ ! Makefile.SH configure.com hints/uts.sh hints/vmesa.sh
+ ! win32/Makefile win32/makefile.mk
+____________________________________________________________________________
+[ 9690] By: jhi on 2001/04/12 01:34:46
+ Log: Integrate Time::Hires 1.20 from Douglas E. Wegscheid.
+ Branch: perl
+ + ext/Time/HiRes/Changes ext/Time/HiRes/HiRes.pm
+ + ext/Time/HiRes/HiRes.xs ext/Time/HiRes/Makefile.PL
+ + t/lib/time-hires.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 9689] By: jhi on 2001/04/12 00:28:39
+ Log: Subject: [PATCH] Digest::MD5 on UTF8 strings
+ From: Gisle Aas <gisle@ActiveState.com>
+ Date: 11 Apr 2001 16:36:11 -0700
+ Message-ID: <lrlmp7102c.fsf@caliper.ActiveState.com>
+ Branch: perl
+ ! ext/Digest/MD5/MD5.xs t/lib/md5-file.t
+____________________________________________________________________________
+[ 9688] By: jhi on 2001/04/12 00:27:39
+ Log: Subject: Re: [PATCH] [ID 20010410.001] Not OK: perl v5.7.1 on i386-freebsd 4.3-rc (UNINSTALLED)
+ From: Gisle Aas <gisle@ActiveState.com>
+ Date: 11 Apr 2001 11:13:24 -0700
+ Message-ID: <lrbsq371a3.fsf@caliper.ActiveState.com>
+ Branch: perl
+ ! ext/MIME/Base64/Base64.xs
+____________________________________________________________________________
+[ 9687] By: jhi on 2001/04/11 19:51:47
+ Log: Slight update on the Todo list. (Should integrate to Todo?)
+ Branch: perl
+ ! Todo-5.6
+____________________________________________________________________________
+[ 9686] By: jhi on 2001/04/11 16:54:25
+ Log: Subject: [PATCH opcode.pl] Documentation of table format
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Wed, 11 Apr 2001 12:59:31 +0100
+ Message-ID: <20010411125931.A25681@netthink.co.uk>
+ Branch: perl
+ ! opcode.pl
+____________________________________________________________________________
+[ 9685] By: jhi on 2001/04/11 16:53:15
+ Log: Subject: [PATCH] prototype("CORE::recv")
+ From: Simon Cozens <simon@netthink.co.uk>
+ Date: Wed, 11 Apr 2001 13:24:35 +0100
+ Message-ID: <20010411132435.A26169@netthink.co.uk>
+ Branch: perl
+ ! pp.c t/comp/proto.t
+____________________________________________________________________________
+[ 9684] By: jhi on 2001/04/11 16:47:13
+ Log: FAQ (and AUTHORS) update from Dan Carson: the information
+ was several years obsolete, Term::Readkey has been updated
+ to have the functionality.
+ Branch: perl
+ ! AUTHORS pod/perlfaq5.pod
+____________________________________________________________________________
+[ 9683] By: jhi on 2001/04/11 12:15:46
+ Log: Subject: Re: [PATCH] [ID 20010410.001] Not OK: perl v5.7.1 on i386-freebsd 4.3-rc (UNINSTALLED)
+ From: Calle Dybedahl <calle@lysator.liu.se>
+ Date: 10 Apr 2001 16:44:16 +0200
+ Message-ID: <86d7akbyrj.fsf@tezcatlipoca.algonet.se>
+ Branch: perl
+ ! ext/MIME/Base64/Base64.xs
+____________________________________________________________________________
+[ 9682] By: jhi on 2001/04/11 12:12:26
+ Log: A more minimal fix for 20010410.006 from Hugo.
+ Branch: perl
+ ! regexec.c
+____________________________________________________________________________
+[ 9681] By: jhi on 2001/04/11 11:34:23
+ Log: Integrate changes #9678,9679 from maintline into mainperl.
+
+ addendum to change#9676
+
+ up $File::Glob::VERSION; add a note pointing out the version of
+ the OpenBSD glob bsd_glob.c resembles
+ Branch: perl
+ !> ext/File/Glob/Glob.pm ext/File/Glob/bsd_glob.c
+ !> ext/File/Glob/bsd_glob.h
+____________________________________________________________________________
+[ 9680] By: jhi on 2001/04/11 11:30:38
+ Log: Bad test numbering in integrate in #9677.
+ Fixes ID 20010411.001.
+ Branch: perl
+ ! t/op/pat.t
+____________________________________________________________________________
+[ 9679] By: gsar on 2001/04/11 03:38:40
+ Log: up $File::Glob::VERSION; add a note pointing out the version of
+ the OpenBSD glob bsd_glob.c resembles
+ Branch: maint-5.6/perl
+ ! ext/File/Glob/Glob.pm ext/File/Glob/bsd_glob.c
+ ! ext/File/Glob/bsd_glob.h
+____________________________________________________________________________
+[ 9678] By: gsar on 2001/04/11 03:09:48
+ Log: addendum to change#9676: some missing changes from OpenBSD glob.c
+ revision 1.8.10.1 found here:
+
+ http://www.openbsd.org/cgi-bin/cvsweb/src/lib/libc/gen/glob.c
+ Branch: maint-5.6/perl
+ ! ext/File/Glob/bsd_glob.c
+____________________________________________________________________________
+[ 9677] By: jhi on 2001/04/11 02:54:39
+ Log: Integrate changes #9675,9676 from maintperl into mainline.
+
+ fix for bug 20010410.006, undo change#7115
+
+ port the OpenBSD glob() security patch
+ Branch: perl
+ !> ext/File/Glob/Glob.pm ext/File/Glob/Glob.xs
+ !> ext/File/Glob/bsd_glob.c ext/File/Glob/bsd_glob.h regexec.c
+ !> t/op/pat.t
+____________________________________________________________________________
+[ 9676] By: gsar on 2001/04/11 02:19:02
+ Log: port the glob() security patch found at:
+
+ ftp://ftp.openbsd.org/pub/OpenBSD/patches/2.8/common/025_glob.patch
+
+ CERT advisory for the issue is here:
+
+ http://www.cert.org/advisories/CA-2001-07.html
+
+ Note that the security scare is only relevant for those who are
+ foolish enough to build suidperl (which is now officially discouraged)
+ Branch: maint-5.6/perl
+ ! ext/File/Glob/Glob.pm ext/File/Glob/Glob.xs
+ ! ext/File/Glob/bsd_glob.c ext/File/Glob/bsd_glob.h
+____________________________________________________________________________
+[ 9675] By: gsar on 2001/04/10 23:52:11
+ Log: fix for bug 20010410.006
+
+ undo change#7115 (came into maint-5.6 as change#8156)
+
+ add tests to keep it from coming back
+ Branch: maint-5.6/perl
+ ! regexec.c t/op/pat.t
+____________________________________________________________________________
+[ 9674] By: nick on 2001/04/10 20:39:31
+ Log: Integrate mainline
+ Branch: perlio
+ +> Porting/testall.atom
+ !> MANIFEST t/lib/lc-all.t t/lib/lc-constants.t
+ !> t/lib/lc-country.t t/lib/lc-currency.t t/lib/lc-language.t
+ !> t/lib/lc-uk.t t/pod/find.t
+____________________________________________________________________________
+[ 9673] By: nick on 2001/04/10 18:46:14
+ Log: Integrate against change 9670 aka perl-5.7.1
+ Branch: perlio
+ +> jpl/ChangeLog jpl/README.JUST-JNI jpl/docs/Tutorial.pod
+ !> (integrate 53 files)
+____________________________________________________________________________
+[ 9672] By: jhi on 2001/04/10 13:45:01
+ Log: Add a script for doing cumulative profile of the test suite.
+ (Requires ATOM, that is, Tru64.)
+ Branch: perl
+ + Porting/testall.atom
+ ! MANIFEST
+____________________________________________________________________________
+[ 9671] By: jhi on 2001/04/10 12:38:53
+ Log: Missing std block.
+ Branch: perl
+ ! t/lib/lc-all.t t/lib/lc-constants.t t/lib/lc-country.t
+ ! t/lib/lc-currency.t t/lib/lc-language.t t/lib/lc-uk.t
+ ! t/pod/find.t
+____________________________________________________________________________
+[ 9670] By: jhi on 2001/04/10 01:25:58
+ Log: This is 5.7.1.
+ Branch: perl
+ ! patchlevel.h
+____________________________________________________________________________
+[ 9669] By: jhi on 2001/04/10 01:09:14
+ Log: Update Changes.
+ Branch: perl
+ ! Changes patchlevel.h
+____________________________________________________________________________
[ 9668] By: jhi on 2001/04/10 01:00:38
Log: Regen toc.
Branch: perl
ext/IPC/SysV/hints/next_3.pl Hint for IPC::SysV for named architecture
ext/IPC/SysV/t/msg.t IPC::SysV extension Perl module
ext/IPC/SysV/t/sem.t IPC::SysV extension Perl module
+ext/List/Util/ChangeLog Util extension
+ext/List/Util/Makefile.PL Util extension
+ext/List/Util/README Util extension
+ext/List/Util/Util.xs Util extension
+ext/List/Util/lib/List/Util.pm List::Util
+ext/List/Util/lib/Scalar/Util.pm Scalar::Util
ext/MIME/Base64/Base64.pm MIME::Base64 extension
ext/MIME/Base64/Base64.xs MIME::Base64 extension
ext/MIME/Base64/Changes MIME::Base64 extension
t/lib/env-array.t See if Env works for arrays
t/lib/env.t See if Env works
t/lib/errno.t See if Errno works
+t/lib/exporter.t See if Exporter works
t/lib/fatal.t See if Fatal works
t/lib/fields.t See if base/fields works
t/lib/filecache.t See if FileCache works
t/lib/time-hires.t Time::HiRes
t/lib/timelocal.t See if Time::Local works
t/lib/trig.t See if Math::Trig works
+t/lib/u-blessed.t Scalar::Util
+t/lib/u-dualvar.t Scalar::Util
+t/lib/u-first.t List::Util
+t/lib/u-max.t List::Util
+t/lib/u-maxstr.t List::Util
+t/lib/u-min.t List::Util
+t/lib/u-minstr.t List::Util
+t/lib/u-readonly.t Scalar::Util
+t/lib/u-reduce.t List::Util
+t/lib/u-reftype.t Scalar::Util
+t/lib/u-sum.t List::Util
+t/lib/u-tainted.t Scalar::Util
+t/lib/u-weak.t Scalar::Util
t/lib/xs-typemap.t test that typemaps work
t/op/64bitint.t See if 64 bit integers work
t/op/anonsub.t See if anonymous subroutines work
win32/Makefile
win32/makefile.mk
);
-system("perl -pi -e 's/\$/\\r/' @crlf");
+system("perl -pi -e 's/\015*\012/\015\012/' @crlf");
print "\n";
chdir ".." or die $!;
# The regex below corresponds to the isCONTROLVAR macro
# from toke.c
- $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e;
+ $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
+ chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;
+
+ # When we say unicode_to_native we really mean ascii_to_native,
+ # which matters iff this is a non-ASCII platform (EBCDIC).
+
return $name;
}
"link", "symlink", "mkdir", "rmdir", "wait", "waitpid", "system",
"exec", "kill", "getppid", "getpgrp", "setpgrp", "getpriority",
"setpriority", "time", "sleep");
-@{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", "$[", "BARE", "WARN");
+@{$priv{"const"}}{8,16,32,64,128} = ("STRICT","ENTERED", '$[', "BARE", "WARN");
$priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
$priv{"list"}{64} = "GUESSED";
$priv{"delete"}{64} = "SLICE";
$h{svclass} = $h{svaddr} = $h{svval} = "";
if ($h{class} eq "PMOP") {
my $precomp = $op->precomp;
- $precomp = defined($precomp) ? "/$precomp/" : "";
+ if (defined $precomp) {
+ # Escape literal control sequences
+ for ($precomp) {
+ s/\t/\\t/g; s/\n/\\n/g; s/\r/\\r/g;
+ # How can we do the below portably?
+ #s/([\0-\037\177-\377])/"\\".sprintf("%03o", ord($1))/eg;
+ }
+ $precomp = "/$precomp/";
+ }
+ else { $precomp = ""; }
my $pmreplroot = $op->pmreplroot;
my ($pmreplroot, $pmreplstart);
if ($ {$pmreplroot = $op->pmreplroot} && $pmreplroot->isa("B::GV")) {
package B::Deparse;
use Carp 'cluck', 'croak';
-use B qw(class main_root main_start main_cv svref_2object opnumber
+use B qw(class main_root main_start main_cv svref_2object opnumber cstring
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
+ OPpCONST_ARYBASE
SVf_IOK SVf_NOK SVf_ROK SVf_POK
CVf_METHOD CVf_LOCKED CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
$self->{'linenums'} = 0;
$self->{'parens'} = 0;
$self->{'ex_const'} = "'???'";
+ $self->{'arybase'} = 0;
+ $self->{'warnings'} = "\0"x12;
while (my $arg = shift @_) {
if (substr($arg, 0, 2) eq "-u") {
$self->stash_subs(substr($arg, 2));
# cluck if class($op) eq "NULL";
# cluck unless $op;
# return $self->$ {\("pp_" . $op->name)}($op, $cx);
+require Carp;
+Carp::confess() unless defined $op;
my $meth = "pp_" . $op->name;
return $self->$meth($op, $cx);
}
$expr .= $self->deparse($ops[$i], 0);
push @exprs, $expr if length $expr;
}
+ for(@exprs[0..@exprs-1]) { s/;\n\z// }
return join(";\n", @exprs);
}
if ($cx > 0) { # inside an expression, (a do {} while for lineseq)
return "do { " . $self->lineseq(@kids) . " }";
} else {
- return $self->lineseq(@kids) . ";";
+ my $lineseq = $self->lineseq(@kids);
+ return (length ($lineseq) ? "$lineseq;" : "");
}
}
push @text, "\f#line " . $op->line .
' "' . $op->file, qq'"\n';
}
+ if ($self->{'arybase'} != $op->arybase) {
+ push @text, '$[ = '. $op->arybase .";\n";
+ $self->{'arybase'} = $op->arybase;
+ }
+
+ my $warnings = $op->warnings;
+ my $warning_bits;
+ if ($warnings->isa("B::SPECIAL") && $$warnings == 4) {
+ $warning_bits = $warnings::Bits{"all"};
+ }
+ elsif ($warnings->isa("B::SPECIAL")) {
+ $warning_bits = "\0"x12;
+ }
+ else {
+ $warning_bits = $warnings->PV;
+ }
+
+ if ($self->{'warnings'} ne $warning_bits) {
+ push @text, 'BEGIN {${^WARNING_BITS} = '. cstring($warning_bits) ."}\n";
+ $self->{'warnings'} = $warning_bits;
+ }
+
return join("", @text);
}
$self->deparse($cont, 0) . "\n\b}\cK";
}
} else {
+ return "" if !defined $body;
$cont = "\cK";
$body = $self->deparse($body, 0);
}
my $self = shift;
my($op, $cx) = @_;
my $gv = $self->gv_or_padgv($op);
- return "\$" . $self->gv_name($gv) . "[" . $op->private . "]";
+ return "\$" . $self->gv_name($gv) . "[" .
+ ($op->private + $self->{'arybase'}) . "]";
}
sub rv2x {
$left . $self->deparse($idx, 1) . $right;
}
$idx = $self->deparse($idx, 1);
+
+ # Outer parens in an array index will confuse perl
+ # if we're interpolating in a regular expression, i.e.
+ # /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
+ #
+ # If $self->{parens}, then an initial '(' will
+ # definitely be paired with a final ')'. If
+ # !$self->{parens}, the misleading parens won't
+ # have been added in the first place.
+ #
+ # [You might think that we could get "(...)...(...)"
+ # where the initial and final parens do not match
+ # each other. But we can't, because the above would
+ # only happen if there's an infix binop between the
+ # two pairs of parens, and *that* means that the whole
+ # expression would be parenthesized as well.]
+ #
+ $idx =~ s/^\((.*)\)$/$1/ if $self->{'parens'};
+
return "\$" . $array . $left . $idx . $right;
}
my $sv = shift;
if (class($sv) eq "SPECIAL") {
return ('undef', '1', '0')[$$sv-1]; # sv_undef, sv_yes, sv_no
+ } elsif (class($sv) eq "NULL") {
+ return 'undef';
} elsif ($sv->FLAGS & SVf_IOK) {
return $sv->int_value;
} elsif ($sv->FLAGS & SVf_NOK) {
return $sv->NV;
- } elsif ($sv->FLAGS & SVf_ROK) {
+ } elsif ($sv->FLAGS & SVf_ROK && $sv->can("RV")) {
return "\\(" . const($sv->RV) . ")"; # constant folded
} else {
my $str = $sv->PV;
# }
my $sv = $self->const_sv($op);
# return const($sv);
+ if ($op->private & OPpCONST_ARYBASE) {
+ return '$[';
+ }
my $c = const $sv;
return $c =~ /^-\d/ ? $self->maybe_parens($c, $cx, 21) : $c;
}
sub import {
my ($class, $backend, @options) = @_;
- eval "use B::$backend ()";
- if ($@) {
- croak "use of backend $backend failed: $@";
- }
- my $compilesub = &{"B::${backend}::compile"}(@options);
- if (ref($compilesub) eq "CODE") {
- minus_c;
- save_BEGINs;
- eval 'CHECK { &$compilesub() }';
- } else {
- die $compilesub;
- }
+ eval q[
+ BEGIN {
+ minus_c;
+ save_BEGINs;
+ }
+
+ CHECK {
+ use B::].$backend.q[ ();
+ if ($@) {
+ croak "use of backend $backend failed: $@";
+ }
+
+
+ my $compilesub = &{"B::${backend}::compile"}(@options);
+ if (ref($compilesub) ne "CODE") {
+ die $compilesub;
+ }
+
+ &$compilesub();
+ }
+ ];
+ die $@ if $@;
}
1;
#endif
#ifndef ARG_MAX
-# ifdef _SC_ARG_MAX
-# define ARG_MAX (sysconf(_SC_ARG_MAX))
+# ifdef MACOS_TRADITIONAL
+# define ARG_MAX 65536 /* Mac OS is actually unlimited */
# else
-# ifdef _POSIX_ARG_MAX
-# define ARG_MAX _POSIX_ARG_MAX
+# ifdef _SC_ARG_MAX
+# define ARG_MAX (sysconf(_SC_ARG_MAX))
# else
-# ifdef WIN32
-# define ARG_MAX 14500 /* from VC's limits.h */
+# ifdef _POSIX_ARG_MAX
+# define ARG_MAX _POSIX_ARG_MAX
# else
-# define ARG_MAX 4096 /* from POSIX, be conservative */
+# ifdef WIN32
+# define ARG_MAX 14500 /* from VC's limits.h */
+# else
+# define ARG_MAX 4096 /* from POSIX, be conservative */
+# endif
# endif
# endif
# endif
#ifdef MACOS_TRADITIONAL
if ( (*pattern == BG_TILDE) && (pglob->gl_flags & GLOB_TILDE) ) {
- return(globextend(pattern, pglob));
+ return(globextend(pattern, pglob, &limit));
}
#endif
--- /dev/null
+Change 482 on 2000/04/10 by <gbarr@pobox.com> (Graham Barr)
+
+ Check for SvMAGICAL on argument for reftype and blessed
+
+Change 366 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ Release 1.01
+
+Change 365 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added auto-detection for a compiler and install the perl version
+ if not found
+ - Better perl implemenation of reftype, should be thread-safe now
+
+Change 364 on 2000/03/03 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added some examples of simple subs that have been requested
+ but not added
+ - Updated copyright dates
+
+Change 344 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr)
+
+ - Better testcase for reftype
+
+Change 343 on 1999/11/10 by <gbarr@pobox.com> (Graham Barr)
+
+ - Modules are now called List::Util & Scalar::Util
+ - Supports non-XS install
+ - perl version of reftype now returns "REF" when it should
+
+Change 311 on 1999/06/01 by <gbarr@pobox.com> (Graham Barr)
+
+ Updated README
+
+Change 275 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Removed forall as it is very broken
+
+Change 274 on 1999/03/22 by <gbarr@pobox.com> (Graham Barr)
+
+ Added List::Util::forall
+
+Change 273 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Added weaken and isweak to Ref::Util
+
+Change 272 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Add new .pm files to repository
+
+Change 271 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ - Split into three packages Ref::Util, List::Util and Scalar::DualVar
+ - readonly and clock were removed in favor of other modules
+
+Change 270 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Rename package
+
+Change 269 on 1999/03/21 by <gbarr@pobox.com> (Graham Barr)
+
+ - Added reftype
+ - improved reduce by not doing a sub call
+ - reduce now uses $a and $b
+ - now compiles with 5.005_5x
+
+Change 178 on 1998/07/26 by <gbarr@pobox.com> (Graham Barr)
+
+ Modified XS code so it will compile with 5.004 and 5.005
+
+Change 115 on 1998/02/21 by <gbarr@pobox.com> (Graham Barr)
+
+ Fri Feb 20 1998 Graham Barr <gbarr@pobox.com>
+
+ t/min.t, t/max.t
+ - Change sor to do a numerical sort
+
+ Fri Dec 19 1997 Graham Barr <gbarr@pobox.com>
+
+ - Added readonly()
+
+ Wed Nov 19 1997 Graham Barr <gbarr@pobox.com>
+
+ - Initial release
+
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ VERSION_FROM => "lib/List/Util.pm",
+ NAME => "List::Util",
+);
+
--- /dev/null
+This distribution is a replacement for the builtin distribution.
+
+This package contains a selection of subroutines that people have
+expressed would be nice to have in the perl core, but the usage would not
+really be high enough to warrant the use of a keyword, and the size so
+small such that being individual extensions would be wasteful.
+
+After unpacking the distribution, to install this module type
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+This distribution provides
+
+ min
+ max
+ minstr
+ maxstr
+ sum
+ reduce
+ reftype
+ blessed
+ weaken (5.005_57 and later only)
+ isweak (5.005_57 and later only)
+ dualvar
+
+Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
--- /dev/null
+/* Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ * This program is free software; you can redistribute it and/or
+ * modify it under the same terms as Perl itself.
+ */
+
+#include <EXTERN.h>
+#include <perl.h>
+#include <XSUB.h>
+#include <patchlevel.h>
+
+#if PATCHLEVEL < 5
+# ifndef gv_stashpvn
+# define gv_stashpvn(n,l,c) gv_stashpv(n,c)
+# endif
+# ifndef SvTAINTED
+
+static bool
+sv_tainted(SV *sv)
+{
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ MAGIC *mg = mg_find(sv, 't');
+ if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
+ return TRUE;
+ }
+ return FALSE;
+}
+
+# define SvTAINTED_on(sv) sv_magic((sv), Nullsv, 't', Nullch, 0)
+# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
+# endif
+# define PL_defgv defgv
+# define PL_op op
+# define PL_curpad curpad
+# define CALLRUNOPS runops
+# define PL_curpm curpm
+# define PL_sv_undef sv_undef
+# define PERL_CONTEXT struct context
+#endif
+#if (PATCHLEVEL < 5) || (PATCHLEVEL == 5 && SUBVERSION <50)
+# ifndef PL_tainting
+# define PL_tainting tainting
+# endif
+# ifndef PL_stack_base
+# define PL_stack_base stack_base
+# endif
+# ifndef PL_stack_sp
+# define PL_stack_sp stack_sp
+# endif
+# ifndef PL_ppaddr
+# define PL_ppaddr ppaddr
+# endif
+#endif
+
+MODULE=List::Util PACKAGE=List::Util
+
+void
+min(...)
+PROTOTYPE: @
+ALIAS:
+ min = 0
+ max = 1
+CODE:
+{
+ int index;
+ NV retval;
+ SV *retsv;
+ if(!items) {
+ XSRETURN_UNDEF;
+ }
+ retsv = ST(0);
+ retval = SvNV(retsv);
+ for(index = 1 ; index < items ; index++) {
+ SV *stacksv = ST(index);
+ NV val = SvNV(stacksv);
+ if(val < retval ? !ix : ix) {
+ retsv = stacksv;
+ retval = val;
+ }
+ }
+ ST(0) = retsv;
+ XSRETURN(1);
+}
+
+
+
+NV
+sum(...)
+PROTOTYPE: @
+CODE:
+{
+ int index;
+ NV ret;
+ if(!items) {
+ XSRETURN_UNDEF;
+ }
+ RETVAL = SvNV(ST(0));
+ for(index = 1 ; index < items ; index++) {
+ RETVAL += SvNV(ST(index));
+ }
+}
+OUTPUT:
+ RETVAL
+
+
+void
+minstr(...)
+PROTOTYPE: @
+ALIAS:
+ minstr = 2
+ maxstr = 0
+CODE:
+{
+ SV *left;
+ int index;
+ if(!items) {
+ XSRETURN_UNDEF;
+ }
+ /*
+ sv_cmp & sv_cmp_locale return 1,0,-1 for gt,eq,lt
+ so we set ix to the value we are looking for
+ xsubpp does not allow -ve values, so we start with 0,2 and subtract 1
+ */
+ ix -= 1;
+ left = ST(0);
+#ifdef OPpLOCALE
+ if(MAXARG & OPpLOCALE) {
+ for(index = 1 ; index < items ; index++) {
+ SV *right = ST(index);
+ if(sv_cmp_locale(left, right) == ix)
+ left = right;
+ }
+ }
+ else {
+#endif
+ for(index = 1 ; index < items ; index++) {
+ SV *right = ST(index);
+ if(sv_cmp(left, right) == ix)
+ left = right;
+ }
+#ifdef OPpLOCALE
+ }
+#endif
+ ST(0) = left;
+ XSRETURN(1);
+}
+
+
+
+void
+reduce(block,...)
+ SV * block
+PROTOTYPE: &@
+CODE:
+{
+ SV *ret;
+ int index;
+ I32 markix;
+ GV *agv,*bgv,*gv;
+ HV *stash;
+ CV *cv;
+ OP *reducecop;
+ if(items <= 1) {
+ XSRETURN_UNDEF;
+ }
+ agv = gv_fetchpv("a", TRUE, SVt_PV);
+ bgv = gv_fetchpv("b", TRUE, SVt_PV);
+ SAVESPTR(GvSV(agv));
+ SAVESPTR(GvSV(bgv));
+ cv = sv_2cv(block, &stash, &gv, 0);
+ reducecop = CvSTART(cv);
+ SAVESPTR(CvROOT(cv)->op_ppaddr);
+ CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ SAVETMPS;
+ SAVESPTR(PL_op);
+ ret = ST(1);
+ markix = sp - PL_stack_base;
+ for(index = 2 ; index < items ; index++) {
+ GvSV(agv) = ret;
+ GvSV(bgv) = ST(index);
+ PL_op = reducecop;
+ CALLRUNOPS(aTHX);
+ ret = *PL_stack_sp;
+ }
+ ST(0) = ret;
+ XSRETURN(1);
+}
+
+void
+first(block,...)
+ SV * block
+PROTOTYPE: &@
+CODE:
+{
+ SV *ret;
+ int index;
+ I32 markix;
+ GV *gv;
+ HV *stash;
+ CV *cv;
+ OP *reducecop;
+ if(items <= 1) {
+ XSRETURN_UNDEF;
+ }
+ SAVESPTR(GvSV(PL_defgv));
+ cv = sv_2cv(block, &stash, &gv, 0);
+ reducecop = CvSTART(cv);
+ SAVESPTR(CvROOT(cv)->op_ppaddr);
+ CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
+ SAVESPTR(PL_curpad);
+ PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
+ SAVETMPS;
+ SAVESPTR(PL_op);
+ markix = sp - PL_stack_base;
+ for(index = 1 ; index < items ; index++) {
+ GvSV(PL_defgv) = ST(index);
+ PL_op = reducecop;
+ CALLRUNOPS(aTHX);
+ if (SvTRUE(*PL_stack_sp)) {
+ ST(0) = ST(index);
+ XSRETURN(1);
+ }
+ }
+ XSRETURN_UNDEF;
+}
+
+MODULE=List::Util PACKAGE=Scalar::Util
+
+void
+dualvar(num,str)
+ SV * num
+ SV * str
+PROTOTYPE: $$
+CODE:
+{
+ STRLEN len;
+ char *ptr = SvPV(str,len);
+ ST(0) = sv_newmortal();
+ SvUPGRADE(ST(0),SVt_PVNV);
+ sv_setpvn(ST(0),ptr,len);
+ if(SvNOKp(num) || !SvIOKp(num)) {
+ SvNVX(ST(0)) = SvNV(num);
+ SvNOK_on(ST(0));
+ }
+ else {
+ SvIVX(ST(0)) = SvIV(num);
+ SvIOK_on(ST(0));
+ }
+ if(PL_tainting && (SvTAINTED(num) || SvTAINTED(str)))
+ SvTAINTED_on(ST(0));
+ XSRETURN(1);
+}
+
+char *
+blessed(sv)
+ SV * sv
+PROTOTYPE: $
+CODE:
+{
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if(!sv_isobject(sv)) {
+ XSRETURN_UNDEF;
+ }
+ RETVAL = sv_reftype(SvRV(sv),TRUE);
+}
+OUTPUT:
+ RETVAL
+
+char *
+reftype(sv)
+ SV * sv
+PROTOTYPE: $
+CODE:
+{
+ if (SvMAGICAL(sv))
+ mg_get(sv);
+ if(!SvROK(sv)) {
+ XSRETURN_UNDEF;
+ }
+ RETVAL = sv_reftype(SvRV(sv),FALSE);
+}
+OUTPUT:
+ RETVAL
+
+void
+weaken(sv)
+ SV *sv
+PROTOTYPE: $
+CODE:
+#ifdef SvWEAKREF
+ sv_rvweaken(sv);
+#else
+ croak("weak references are not implemented in this release of perl");
+#endif
+
+SV *
+isweak(sv)
+ SV *sv
+PROTOTYPE: $
+CODE:
+#ifdef SvWEAKREF
+ ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
+ XSRETURN(1);
+#else
+ croak("weak references are not implemented in this release of perl");
+#endif
+
+int
+readonly(sv)
+ SV *sv
+PROTOTYPE: $
+CODE:
+ RETVAL = SvREADONLY(sv);
+OUTPUT:
+ RETVAL
+
+int
+tainted(sv)
+ SV *sv
+PROTOTYPE: $
+CODE:
+ RETVAL = SvTAINTED(sv);
+OUTPUT:
+ RETVAL
+
+BOOT:
+{
+#ifndef SvWEAKREF
+ HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
+ GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
+ AV *varav;
+ if (SvTYPE(vargv) != SVt_PVGV)
+ gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
+ varav = GvAVn(vargv);
+ av_push(varav, newSVpv("weaken",6));
+ av_push(varav, newSVpv("isweak",6));
+#endif
+}
--- /dev/null
+# List::Util.pm
+#
+# Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package List::Util;
+
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(first min max minstr maxstr reduce sum);
+$VERSION = $VERSION = "1.02";
+
+eval {
+ require DynaLoader;
+ local @ISA = qw(DynaLoader);
+ bootstrap List::Util $VERSION;
+ 1
+};
+
+eval <<'ESQ' unless defined &reduce;
+
+# This code is only compiled if the XS did not load
+
+use vars qw($a $b);
+
+sub reduce (&@) {
+ my $code = shift;
+
+ return shift unless @_ > 1;
+
+ my $caller = caller;
+ local(*{$caller."::a"}) = \my $a;
+ local(*{$caller."::b"}) = \my $b;
+
+ $a = shift;
+ foreach (@_) {
+ $b = $_;
+ $a = &{$code}();
+ }
+
+ $a;
+}
+
+sub sum (@) { reduce { $a + $b } @_ }
+
+sub min (@) { reduce { $a < $b ? $a : $b } @_ }
+
+sub max (@) { reduce { $a > $b ? $a : $b } @_ }
+
+sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ }
+
+sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ }
+
+sub first (&@) {
+ my $code = shift;
+
+ foreach (@_) {
+ return $_ if &{$code}();
+ }
+
+ undef;
+}
+ESQ
+
+1;
+
+__END__
+
+=head1 NAME
+
+List::Util - A selection of general-utility list subroutines
+
+=head1 SYNOPSIS
+
+ use List::Util qw(first sum min max minstr maxstr reduce);
+
+=head1 DESCRIPTION
+
+C<List::Util> contains a selection of subroutines that people have
+expressed would be nice to have in the perl core, but the usage would
+not really be high enough to warrant the use of a keyword, and the size
+so small such that being individual extensions would be wasteful.
+
+By default C<List::Util> does not export any subroutines. The
+subroutines defined are
+
+=over 4
+
+=item first BLOCK LIST
+
+Similar to C<grep> in that it evaluates BLOCK setting C<$_> to each element
+of LIST in turn. C<first> returns the first element where the result from
+BLOCK is a true value. If BLOCK never returns true or LIST was empty then
+C<undef> is returned.
+
+ $foo = first { defined($_) } @list # first defined value in @list
+ $foo = first { $_ > $value } @list # first value in @list which
+ # is greater than $value
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list
+
+for example wanted() could be defined() which would return the first
+defined value in @list
+
+=item max LIST
+
+Returns the entry in the list with the highest numerical value. If the
+list is empty then C<undef> is returned.
+
+ $foo = max 1..10 # 10
+ $foo = max 3,9,12 # 12
+ $foo = max @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a > $b ? $a : $b } 1..10
+
+=item maxstr LIST
+
+Similar to C<max>, but treats all the entries in the list as strings
+and returns the highest string as defined by the C<gt> operator.
+If the list is empty then C<undef> is returned.
+
+ $foo = maxstr 'A'..'Z' # 'Z'
+ $foo = maxstr "hello","world" # "world"
+ $foo = maxstr @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z'
+
+=item min LIST
+
+Similar to C<max> but returns the entry in the list with the lowest
+numerical value. If the list is empty then C<undef> is returned.
+
+ $foo = min 1..10 # 1
+ $foo = min 3,9,12 # 3
+ $foo = min @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10
+
+=item minstr LIST
+
+Similar to C<min>, but treats all the entries in the list as strings
+and returns the lowest string as defined by the C<lt> operator.
+If the list is empty then C<undef> is returned.
+
+ $foo = maxstr 'A'..'Z' # 'A'
+ $foo = maxstr "hello","world" # "hello"
+ $foo = maxstr @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z'
+
+=item reduce BLOCK LIST
+
+Reduces LIST by calling BLOCK multiple times, setting C<$a> and C<$b>
+each time. The first call will be with C<$a> and C<$b> set to the first
+two elements of the list, subsequent calls will be done by
+setting C<$a> to the result of the previous call and C<$b> to the next
+element in the list.
+
+Returns the result of the last call to BLOCK. If LIST is empty then
+C<undef> is returned. If LIST only contains one element then that
+element is returned and BLOCK is not executed.
+
+ $foo = reduce { $a < $b ? $a : $b } 1..10 # min
+ $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr
+ $foo = reduce { $a + $b } 1 .. 10 # sum
+ $foo = reduce { $a . $b } @bar # concat
+
+=item sum LIST
+
+Returns the sum of all the elements in LIST.
+
+ $foo = sum 1..10 # 55
+ $foo = sum 3,9,12 # 24
+ $foo = sum @bar, @baz # whatever
+
+This function could be implemented using C<reduce> like this
+
+ $foo = reduce { $a + $b } 1..10
+
+=back
+
+=head1 SUGGESTED ADDITIONS
+
+The following are additions that have been requested, but I have been reluctant
+to add due to them being very simple to implement in perl
+
+ # One argument is true
+
+ sub any { $_ && return 1 for @_; 0 }
+
+ # All arguments are true
+
+ sub all { $_ || return 0 for @_; 1 }
+
+ # All arguments are false
+
+ sub none { $_ && return 0 for @_; 1 }
+
+ # One argument is false
+
+ sub notall { $_ || return 1 for @_; 0 }
+
+ # How many elements are true
+
+ sub true { scalar grep { $_ } @_ }
+
+ # How many elements are false
+
+ sub false { scalar grep { !$_ } @_ }
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+# Scalar::Util.pm
+#
+# Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Scalar::Util;
+
+require Exporter;
+require List::Util; # List::Util loads the XS
+
+$VERSION = $VERSION = $List::Util::VERSION;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly);
+
+sub export_fail {
+ if (grep { /^(weaken|isweak)$/ } @_ ) {
+ require Carp;
+ Carp::croak("Weak references are not implemented in the version of perl");
+ }
+ if (grep { /^dualvar$/ } @_ ) {
+ require Carp;
+ Carp::croak("dualvar is only avaliable with the XS version");
+ }
+
+ @_;
+}
+
+eval <<'ESQ' unless defined &dualvar;
+
+push @EXPORT_FAIL, qw(weaken isweak dualvar);
+
+# The code beyond here is only used if the XS is not installed
+
+# Hope nobody defines a sub by this name
+sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }
+
+sub blessed ($) {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ length(ref($_[0]))
+ ? eval { $_[0]->a_sub_not_likely_to_be_here }
+ : undef
+}
+
+sub reftype ($) {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ my $r = shift;
+ my $t;
+
+ length($t = ref($r)) or return undef;
+
+ # This eval will fail if the reference is not blessed
+ eval { $r->a_sub_not_likely_to_be_here; 1 }
+ ? do {
+ $t = eval {
+ # we have a GLOB or an IO. Stringify a GLOB gives it's name
+ my $q = *$r;
+ $q =~ /^\*/ ? "GLOB" : "IO";
+ }
+ or do {
+ # OK, if we don't have a GLOB what parts of
+ # a glob will it populate.
+ # NOTE: A glob always has a SCALAR
+ local *glob = $r;
+ defined *glob{ARRAY} && "ARRAY"
+ or defined *glob{HASH} && "HASH"
+ or defined *glob{CODE} && "CODE"
+ or length(ref(${$r})) ? "REF" : "SCALAR";
+ }
+ }
+ : $t
+}
+
+sub tainted {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ local $^W = 0;
+ eval { kill 0 * $_[0] };
+ $@ =~ /^Insecure/;
+}
+
+sub readonly {
+ return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
+
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ my $tmp = $_[0];
+
+ !eval { $_[0] = $tmp; 1 };
+}
+
+ESQ
+
+1;
+
+__END__
+
+=head1 NAME
+
+Scalar::Util - A selection of general-utility scalar subroutines
+
+=head1 SYNOPSIS
+
+ use Scalar::Util qw(blessed dualvar reftype weaken isweak);
+
+=head1 DESCRIPTION
+
+C<Scalar::Util> contains a selection of subroutines that people have
+expressed would be nice to have in the perl core, but the usage would
+not really be high enough to warrant the use of a keyword, and the size
+so small such that being individual extensions would be wasteful.
+
+By default C<Scalar::Util> does not export any subroutines. The
+subroutines defined are
+
+=over 4
+
+=item blessed EXPR
+
+If EXPR evaluates to a blessed reference the name of the package
+that it is blessed into is returned. Otherwise C<undef> is returned.
+
+=item dualvar NUM, STRING
+
+Returns a scalar that has the value NUM in a numeric context and the
+value STRING in a string context.
+
+ $foo = dualvar 10, "Hello";
+ $num = $foo + 2; # 12
+ $str = $foo . " world"; # Hello world
+
+=item isweak EXPR
+
+If EXPR is a scalar which is a weak reference the result is true.
+
+=item reftype EXPR
+
+If EXPR evaluates to a reference the type of the variable referenced
+is returned. Otherwise C<undef> is returned.
+
+=item weaken REF
+
+REF will be turned into a weak reference. This means that it will not
+hold a reference count on the object it references. Also when the reference
+count on that object reaches zero, REF will be set to undef.
+
+This is useful for keeping copies of references , but you don't want to
+prevent the object being DESTROY-ed at it's usual time.
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997-2000 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+except weaken and isweak which are
+
+Copyright (c) 1999 Tuomas J. Lukka <lukka@iki.fi>. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as perl itself.
+
+=head1 BLATANT PLUG
+
+The weaken and isweak subroutines in this module and the patch to the core Perl
+were written in connection with the APress book `Tuomas J. Lukka's Definitive
+Guide to Object-Oriented Programming in Perl', to avoid explaining why certain
+things would have to be done in cumbersome ways.
+
+=cut
package Time::HiRes;
use strict;
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK @EXPORT_FAIL);
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
require Exporter;
-require DynaLoader;
+use XSLoader;
-@ISA = qw(Exporter DynaLoader);
+@ISA = qw(Exporter);
@EXPORT = qw( );
-@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval);
-
-$VERSION = do{my@r=q$Revision: 1.20 $=~/\d+/g;sprintf '%02d.'.'%02d'x$#r,@r};
-
-bootstrap Time::HiRes $VERSION;
+@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
+ getitimer setitimer ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF);
+
+$VERSION = '1.21';
+
+sub AUTOLOAD {
+ my $constname;
+ ($constname= $AUTOLOAD) =~ s/.*:://;
+ my $val = constant($constname, @_ ? $_[0] : 0);
+ if ($!) {
+ my ($pack,$file,$line) = caller;
+ die "Your vendor has not defined Time::HiRes macro $constname, used at $file line $line.\n";
+ }
+ {
+ no strict 'refs';
+ *$AUTOLOAD = sub { $val };
+ }
+ goto &$AUTOLOAD;
+}
-@EXPORT_FAIL = grep { ! defined &$_ } @EXPORT_OK;
+XSLoader::load 'Time::HiRes', $VERSION;
# Preloaded methods go here.
(${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000);
}
-# I'm only supplying this because the version of it in 5.003's Export.pm
-# is buggy (it doesn't shift off the class name).
-
-sub export_fail {
- my $self = shift;
- @_;
-}
-
# Autoload methods go after =cut, and are processed by the autosplit program.
1;
$elapsed = tv_interval ( $t0 );
use Time::HiRes qw ( time alarm sleep );
+
$now_fractions = time;
sleep ($floating_seconds);
alarm ($floating_seconds);
alarm ($floating_seconds, $floating_interval);
+ use Time::HiRes qw( setitimer getitimer
+ ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF );
+
+ setitimer ($which, $floating_seconds, $floating_interval );
+ getitimer ($which);
+
=head1 DESCRIPTION
The C<Time::HiRes> module implements a Perl interface to the usleep, ualarm,
If your system lacks gettimeofday(2) you don't get gettimeofday() or the
one-arg form of tv_interval(). If you don't have usleep(3) or select(2)
you don't get usleep() or sleep(). If your system don't have ualarm(3)
-or setitimer(2) you don't
-get ualarm() or alarm(). If you try to import an unimplemented function
-in the C<use> statement it will fail at compile time.
+or setitimer(2) you don't get ualarm() or alarm().
+If you try to import an unimplemented function in the C<use> statement
+it will fail at compile time.
-The following functions can be imported from this module. No
-functions are exported by default.
+The following functions can be imported from this module.
+No functions are exported by default.
=over 4
behaviour. This function can be imported, resulting in a nice drop-in
replacement for the C<alarm> provided with perl, see the EXAMPLES below.
+=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] )
+
+Start up an interval timer: after a certain time, a signal is arrives,
+and more may keep arriving at certain intervals. To disable a timer,
+use time of zero. If interval is set to zero (or unspecified), the
+timer is disabled after the next delivered signal.
+
+Use of interval timers may interfere with alarm(), sleep(), and usleep().
+In standard-speak the "interaction is unspecified", which means that
+I<anything> may happen: it may work, it may not.
+
+In scalar context, the remaining time in the timer is returned.
+
+In list context, both the remaining time and the interval are returned.
+
+There are three interval timers: the $which can be ITIMER_REAL,
+ITIMER_VIRTUAL, or ITIMER_PROF.
+
+ITIMER_REAL results in alarm()-like behavior. Time is counted in
+I<real time>, that is, wallclock time. SIGALRM is delivered when
+the timer expires.
+
+ITIMER_VIRTUAL counts time in (process) I<virtual time>, that is, only
+when the process is running. In multiprocessing/user/CPU systems this
+may be much less than real time. (This time is also known as the
+I<user time>.) SIGVTALRM is delivered when the timer expires.
+
+ITIMER_PROF counts time when either the process virtual time or when
+the operating system is running on behalf of the process (such as
+I/O). (This time is also known as the I<system time>.) (Collectively
+these times are also known as the I<CPU time>.) SIGPROF is delivered
+when the timer expires. SIGPROF can interrupt system calls.
+
+The semantics of interval timers for multithreaded programs are
+system-specific, and some systems may support additional interval
+timers. See your setitimer() documentation.
+
+=item getitimer ( $which )
+
+Return the remaining time in the interval timer specified by $which.
+
+In scalar context, the remaining time is returned.
+
+In list context, both the remaining time and the interval are returned.
+The interval is always what you put in using setitimer().
+
=back
=head1 EXAMPLES
sleep (2.5);
alarm (10.6666666);
+ # Arm an interval timer to go off first at 10 seconds and
+ # after that every 2.5 seconds, in process virtual time
+
+ use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time );
+
+ $SIG{VTLARM} = sub { print time, "\n" };
+ setitimer(ITIMER_VIRTUAL, 10, 2.5);
+
=head1 C API
In addition to the perl API described above, a C API is available for
}
#endif
+static IV
+constant(char *name, int arg)
+{
+ errno = 0;
+ switch (*name) {
+ case 'I':
+ if (strEQ(name, "ITIMER_REAL"))
+#ifdef ITIMER_REAL
+ return ITIMER_REAL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ITIMER_REALPROF"))
+#ifdef ITIMER_REALPROF
+ return ITIMER_REALPROF;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ITIMER_VIRTUAL"))
+#ifdef ITIMER_VIRTUAL
+ return ITIMER_VIRTUAL;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "ITIMER_PROF"))
+#ifdef ITIMER_PROF
+ return ITIMER_PROF;
+#else
+ goto not_there;
+#endif
+ break;
+ }
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
#if !defined(HAS_GETTIMEOFDAY) && defined(WIN32)
#define HAS_GETTIMEOFDAY
ret[1] = Tp.tv_usec;
}
-static double
+static NV
myNVtime()
{
struct timeval Tp;
hv_store(PL_modglobal, "Time::U2time", 12, newSViv((IV) myU2time), 0);
#endif
+IV
+constant(name, arg)
+ char * name
+ int arg
+
#ifdef HAS_USLEEP
void
void
sleep(fseconds)
- double fseconds
+ NV fseconds
CODE:
int useconds = fseconds * 1000000;
usleep (useconds);
int
alarm(fseconds,finterval=0)
- double fseconds
- double finterval
+ NV fseconds
+ NV finterval
PREINIT:
int useconds, uinterval;
CODE:
PUSHs(sv_2mortal(newSVnv(Tp.tv_sec + (Tp.tv_usec / 1000000.0))));
}
-double
+NV
time()
PREINIT:
struct timeval Tp;
#endif
+#if defined(HAS_GETITIMER) && defined(HAS_SETITIMER)
+
+#define TV2NV(tv) ((NV)((tv).tv_sec) + 0.000001 * (NV)((tv).tv_usec))
+
+void
+setitimer(which, seconds, interval = 0)
+ int which
+ NV seconds
+ NV interval
+ PREINIT:
+ struct itimerval newit;
+ struct itimerval oldit;
+ PPCODE:
+ newit.it_value.tv_sec = seconds;
+ newit.it_value.tv_usec =
+ (seconds - (NV)newit.it_value.tv_sec) * 1000000.0;
+ newit.it_interval.tv_sec = interval;
+ newit.it_interval.tv_usec =
+ (interval - (NV)newit.it_interval.tv_sec) * 1000000.0;
+ if (setitimer(which, &newit, &oldit) == 0) {
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_value))));
+ if (GIMME == G_ARRAY) {
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVnv(TV2NV(oldit.it_interval))));
+ }
+ }
+
+void
+getitimer(which)
+ int which
+ PREINIT:
+ struct itimerval nowit;
+ PPCODE:
+ if (getitimer(which, &nowit) == 0) {
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_value))));
+ if (GIMME == G_ARRAY) {
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVnv(TV2NV(nowit.it_interval))));
+ }
+ }
+
+#endif
+
# $Id: HiRes.xs,v 1.11 1999/03/16 02:27:38 wegscd Exp wegscd $
# $Log: HiRes.xs,v $
* module, don't bother warning */
if (file
&& PERL_FILE_IS_ABSOLUTE(file)
- && (instr(file, "/lib/") || instr(file, ".pm")))
+#ifdef MACOS_TRADITIONAL
+ && (instr(file, ":lib:")
+#else
+ && (instr(file, "/lib/")
+#endif
+ || instr(file, ".pm")))
{
continue;
}
=head1 Author and Modification History
-Modified by Casey Tweten, 2000-11-08, v0.59.
+Modified by Casey West, 2000-11-08, v0.59.
Added the ability for compile time class creation.
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
my $version = ${"${pkg}::VERSION"};
- if (!$version or $version < $wanted) {
- $version ||= "(undef)";
+ if (!defined $version or $version < $wanted) {
+ $version = defined $version ? $version : "(undef)";
# %INC contains slashes, but $pkg contains double-colons.
my $file = (map {s,::,/,g; $INC{$_}} "$pkg.pm")[0];
- $file &&= " ($file)";
+ $file = defined $file ? " ($file)" : '';
require Carp;
Carp::croak("$pkg $wanted required--this is only version $version$file")
}
return unless -f _;
return if $_ eq ".exists";
my $targetdir = MY->catdir($targetroot, $File::Find::dir);
- my $origfile = $_;
my $targetfile = MY->catfile($targetdir, $_);
my $diff = 0;
} else {
inc_uninstall($_,$File::Find::dir,$verbose,0); # nonono set to 0
}
- $packlist->{$origfile}++;
+ $packlist->{$targetfile}++;
}, ".");
chdir($cwd) or Carp::croak("Couldn't chdir to $cwd: $!");
use Config;
use File::Find;
use File::Basename;
-our $VERSION = '0.02';
+our $VERSION = '0.03';
+
+my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
+
+sub _is_prefix
+{
+my ($self, $path, $prefix) = @_;
+if (substr($path, 0, length($prefix)) eq $prefix)
+ {
+ return(1);
+ }
+if ($DOSISH)
+ {
+ $path =~ s|\\|/|g;
+ $prefix =~ s|\\|/|g;
+ if ($path =~ m{^\Q$prefix\E}i)
+ {
+ return(1);
+ }
+ }
+return(0);
+}
sub _is_type($$$)
{
return(1) if ($type eq "all");
if ($type eq "doc")
{
- return(substr($path, 0, length($Config{installman1dir}))
- eq $Config{installman1dir}
+ return($self->_is_prefix($path, $Config{installman1dir})
||
- substr($path, 0, length($Config{installman3dir}))
- eq $Config{installman3dir}
+ $self->_is_prefix($path, $Config{installman3dir})
? 1 : 0)
}
if ($type eq "prog")
{
- return(substr($path, 0, length($Config{prefix})) eq $Config{prefix}
+ return($self->_is_prefix($path, $Config{prefix})
&&
- substr($path, 0, length($Config{installman1dir}))
- ne $Config{installman1dir}
+ !$self->_is_prefix($path, $Config{installman1dir})
&&
- substr($path, 0, length($Config{installman3dir}))
- ne $Config{installman3dir}
+ !$self->_is_prefix($path, $Config{installman3dir})
? 1 : 0);
}
return(0);
$under[0] = "" if (! @under);
foreach my $dir (@under)
{
- return(1) if (substr($path, 0, length($dir)) eq $dir);
+ return(1) if ($self->_is_prefix($path, $dir));
}
return(0);
}
$class = ref($class) || $class;
my $self = {};
+my $installarchlib = $Config{installarchlib};
+my $archlib = $Config{archlib};
+my $sitearch = $Config{sitearch};
+
+if ($DOSISH)
+ {
+ $installarchlib =~ s|\\|/|g;
+ $archlib =~ s|\\|/|g;
+ $sitearch =~ s|\\|/|g;
+ }
+
# Read the core packlist
$self->{Perl}{packlist} =
- ExtUtils::Packlist->new("$Config{installarchlib}/.packlist");
+ ExtUtils::Packlist->new("$installarchlib/.packlist");
$self->{Perl}{version} = $Config{version};
# Read the module packlists
my $sub = sub
{
# Only process module .packlists
- return if ($_) ne ".packlist" || $File::Find::dir eq $Config{installarchlib};
+ return if ($_) ne ".packlist" || $File::Find::dir eq $installarchlib;
# Hack of the leading bits of the paths & convert to a module name
my $module = $File::Find::name;
- $module =~ s!$Config{archlib}/auto/(.*)/.packlist!$1!s;
- $module =~ s!$Config{sitearch}/auto/(.*)/.packlist!$1!s;
+ $module =~ s!\Q$archlib\E/auto/(.*)/.packlist!$1!s;
+ $module =~ s!\Q$sitearch\E/auto/(.*)/.packlist!$1!s;
my $modfile = "$module.pm";
$module =~ s!/!::!g;
# Read the .packlist
$self->{$module}{packlist} = ExtUtils::Packlist->new($File::Find::name);
};
-find($sub, $Config{archlib}, $Config{sitearch});
+find($sub, $archlib, $sitearch);
return(bless($self, $class));
}
package Net::Ping;
# Current maintainer: colinm@cpan.org (Colin McMillen)
+# stream protocol: bronson@trestle.com (Scott Bronson)
#
# Original author: mose@ccsn.edu (Russell Mosemann)
#
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = 2.03;
+$VERSION = 2.04;
# Constants
bless($self, $class);
$proto = $def_proto unless $proto; # Determine the protocol
- croak('Protocol for ping must be "icmp", "tcp", "udp", or "external"')
- unless $proto =~ m/^(tcp|udp|icmp|external)$/;
+ croak('Protocol for ping must be "icmp", "udp", "tcp", "stream", or "external"')
+ unless $proto =~ m/^(icmp|udp|tcp|stream|external)$/;
$self->{"proto"} = $proto;
$timeout = $def_timeout unless $timeout; # Determine the timeout
socket($self->{"fh"}, &PF_INET(), &SOCK_RAW(), $self->{"proto_num"}) ||
croak("icmp socket error - $!");
}
- elsif ($self->{"proto"} eq "tcp") # Just a file handle for now
+ elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
{
$self->{"proto_num"} = (getprotobyname('tcp'))[2] ||
croak("Can't get tcp protocol by name");
return $self->ping_udp($ip, $timeout) if $self->{"proto"} eq "udp";
return $self->ping_icmp($ip, $timeout) if $self->{"proto"} eq "icmp";
return $self->ping_tcp($ip, $timeout) if $self->{"proto"} eq "tcp";
+ return $self->ping_stream($ip, $timeout) if $self->{"proto"} eq "stream";
croak("Unknown protocol \"$self->{proto}\" in ping()");
}
return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement
}
-# Description: Perform a tcp echo ping. Since a tcp connection is
-# host specific, we have to open and close each connection here. We
-# can't just leave a socket open. Because of the robust nature of
-# tcp, it will take a while before it gives up trying to establish a
-# connection. Therefore, we use select() on a non-blocking socket to
-# check against our timeout. No data bytes are actually
-# sent since the successful establishment of a connection is proof
-# enough of the reachability of the remote host. Also, tcp is
-# expensive and doesn't need our help to add to the overhead.
-
-sub ping_tcp
-{
- my ($self,
- $ip, # Packed IP number of the host
- $timeout # Seconds after which ping times out
- ) = @_;
- my ($saddr, # sockaddr_in with port and ip
- $rin, # Used in select()
- $ret # The return value
- );
-
- socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
- croak("tcp socket error - $!");
-
- $saddr = sockaddr_in($self->{"port_num"}, $ip);
-
- $ret = 0; # Default to unreachable
-
- # Buggy Winsock API doesn't allow us to use non-blocking connect()
- # calls. Hence, if our OS is Windows, we need to create a new process
- # to run a blocking connect attempt, and kill it after the timeout has
- # passed.
- if ($^O =~ /win32/i)
- {
- my ($child, $ret, $pid, $time);
- my $host = inet_ntoa($ip);
-
- # The code we will be executing in our new process.
- my $code = '"use Net::Ping; $p = Net::Ping->new(\'tcp\'); ';
- $code .= 'exit($p->_ping_tcp_win(' . $host . '))"';
-
- # Call the process.
- $pid = system(1, "perl", "-e", $code);
-
- # Import the POSIX version of <sys/wait.h>
- require POSIX;
- import POSIX qw(:sys_wait_h);
-
- # Get the current time; will be used to tell if we've timed out.
- $time = time;
-
- # Wait for the child to return or for the timeout to expire.
- do {
- $child = waitpid($pid, &WNOHANG);
- $ret = $?;
- } until time > ($time + $timeout) or $child;
-
- # Return an appropriate value; 0 if the child didn't return,
- # the return value of the child otherwise.
- return $ret >> 8 if $child;
-
- kill $pid;
- return 0;
- }
-
- # If our OS isn't Windows, do this stuff instead...
- else
- {
- # Try a non-blocking TCP connect to the remote echo port.
- # Our call to select() below will stop after the timeout has
- # passed or set the return value to true if the connection
- # succeeds in time.
- $self->{"fh"}->blocking(0);
- connect($self->{"fh"}, $saddr);
-
- $rin = "";
- vec($rin, fileno($self->{"fh"}), 1) = 1;
- $ret = 1 if select($rin, undef, undef, $timeout);
-
- # Close our filehandle, restore it to its default state (i.e. blocking),
- # and return our result.
- $self->{"fh"}->blocking(1);
- $self->{"fh"}->close();
- }
- return($ret);
-}
-
# Warning: this method may generate false positives.
# It is meant to be a private method and should only
# be invoked by ping_tcp() if $^O =~ /win32/i.
+
sub _ping_tcp_win
{
my ($self,
return $ret;
}
+# Buggy Winsock API doesn't allow us to use non-blocking connect()
+# calls. Hence, if our OS is Windows, we need to create a new process
+# to run a blocking connect attempt, and kill it after the timeout has
+# passed. Unfortunately, this won't work with the stream protocol.
+
+sub ping_tcp_win32
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which open times out
+ ) = @_;
+
+ socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
+ croak("tcp socket error - $!");
+
+ my $saddr = sockaddr_in($self->{"port_num"}, $ip);
+
+ my ($child, $ret, $pid, $time);
+ my $host = inet_ntoa($ip);
+
+ # The code we will be executing in our new process.
+ my $code = '"use Net::Ping; $p = Net::Ping->new(\'tcp\'); ';
+ $code .= 'exit($p->_ping_tcp_win(' . $host . '))"';
+
+ # Call the process.
+ $pid = system(1, "perl", "-e", $code);
+
+ # Import the POSIX version of <sys/wait.h>
+ require POSIX;
+ import POSIX qw(:sys_wait_h);
+
+ # Get the current time; will be used to tell if we've timed out.
+ $time = time;
+
+ # Wait for the child to return or for the timeout to expire.
+ do {
+ $child = waitpid($pid, &WNOHANG);
+ $ret = $?;
+ } until time > ($time + $timeout) or $child;
+
+ # Return an appropriate value; 0 if the child didn't return,
+ # the return value of the child otherwise.
+ return $ret >> 8 if $child;
+
+ kill $pid;
+ return 0;
+}
+
+# This writes the given string to the socket and then reads it
+# back. It returns 1 on success, 0 on failure.
+sub tcp_echo
+{
+ my $self = shift;
+ my $timeout = shift;
+ my $pingstring = shift;
+
+ my $ret = undef;
+ my $time = time;
+ my $wrstr = $pingstring;
+ my $rdstr = "";
+
+ eval <<'EOM';
+ do {
+ my $rin = "";
+ vec($rin, $self->{"fh"}->fileno(), 1) = 1;
+
+ my $rout = undef;
+ if($wrstr) {
+ $rout = "";
+ vec($rout, $self->{"fh"}->fileno(), 1) = 1;
+ }
+
+ if(select($rin, $rout, undef, ($time + $timeout) - time())) {
+
+ if($rout && vec($rout,$self->{"fh"}->fileno(),1)) {
+ my $num = syswrite($self->{"fh"}, $wrstr);
+ if($num) {
+ # If it was a partial write, update and try again.
+ $wrstr = substr($wrstr,$num);
+ } else {
+ # There was an error.
+ $ret = 0;
+ }
+ }
+
+ if(vec($rin,$self->{"fh"}->fileno(),1)) {
+ my $reply;
+ if(sysread($self->{"fh"},$reply,length($pingstring)-length($rdstr))) {
+ $rdstr .= $reply;
+ $ret = 1 if $rdstr eq $pingstring;
+ } else {
+ # There was an error.
+ $ret = 0;
+ }
+ }
+
+ }
+ } until time() > ($time + $timeout) || defined($ret);
+EOM
+
+ return $ret;
+}
+
+sub tcp_connect
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which open times out
+ ) = @_;
+
+ # Should we go back to using blocking IO and alarms to implement
+ # the stream protocol on win32?
+ croak "no nonblocking io -- can't stream ping on win32"
+ if ($^O =~ /win32/i);
+
+ $self->{"ip"} = $ip;
+
+ socket($self->{"fh"}, &PF_INET(), &SOCK_STREAM(), $self->{"proto_num"}) ||
+ croak("tcp socket error - $!");
+
+ my $saddr = sockaddr_in($self->{"port_num"}, $ip);
+ my $ret = 0;
+
+ # Try a non-blocking TCP connect to the remote echo port.
+ # Our call to select() below will stop after the timeout has
+ # passed or set the return value to true if the connection
+ # succeeds in time.
+ $self->{"fh"}->blocking(0);
+ connect($self->{"fh"}, $saddr);
+
+ # This replaces the breakage where we were listening on a
+ # socket that would never produce any data. This works, but
+ # it's now quite a bit heavier than the old Net::Ping. I'd
+ # like to see it reverted.
+ return $self->tcp_echo($timeout, "ping!\n");
+}
+
+# Description: Perform a tcp echo ping. Since a tcp connection is
+# host specific, we have to open and close each connection here. We
+# can't just leave a socket open. Because of the robust nature of
+# tcp, it will take a while before it gives up trying to establish a
+# connection. Therefore, we use select() on a non-blocking socket to
+# check against our timeout. No data bytes are actually
+# sent since the successful establishment of a connection is proof
+# enough of the reachability of the remote host. Also, tcp is
+# expensive and doesn't need our help to add to the overhead.
+
+sub ping_tcp
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+
+ my $ret;
+
+ # tcp_connect won't work on win32, so special-case it if need be.
+ if ($^O =~ /win32/i) {
+ $ret = $self->ping_tcp_win32($ip, $timeout);
+ } else {
+ $ret = $self->tcp_connect($ip, $timeout);
+ $self->{"fh"}->close();
+ }
+
+ return $ret;
+}
+
+# Description: Perform a stream ping. If the tcp connection isn't
+# already open, it opens it. It then sends some data and waits for
+# a reply. It leaves the stream open on exit.
+
+sub ping_stream
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which ping times out
+ ) = @_;
+
+ my $pingstring = "ping!\n"; # The data we exchange with the server
+
+ # Open the stream if it's not already open
+ if(!defined $self->{"fh"}->fileno()) {
+ $self->tcp_connect($ip, $timeout) or return 0;
+ }
+
+ croak "tried to switch servers while stream pinging"
+ if $self->{"ip"} ne $ip;
+
+ return $self->tcp_echo($timeout, "pingschwingping!\n");
+}
+
+# Description: opens the stream. You would do this if you want to
+# separate the overhead of opening the stream from the first ping.
+
+sub open
+{
+ my ($self,
+ $ip, # Packed IP number of the host
+ $timeout # Seconds after which open times out
+ ) = @_;
+
+ $timeout = $self->{"timeout"} unless $timeout;
+
+ if($self->{"proto"} eq "stream") {
+ if(defined($self->{"fh"}->fileno())) {
+ croak("socket is already open");
+ } else {
+ $self->tcp_connect($ip, $timeout);
+ }
+ }
+}
+
# Description: Perform a udp echo ping. Construct a message of
# at least the one-byte sequence number and any additional data bytes.
# Send the message out and wait for a message to come back. If we
parameters, a variable number of hosts may be pinged multiple
times and then the connection is closed.
-You may choose one of four different protocols to use for the
-ping. The "udp" protocol is the default. Note that a live remote host
-may still fail to be pingable by one or more of these protocols. For
-example, www.microsoft.com is generally alive but not pingable.
+Ping supports five ping protocols, each with its own strengths
+and weaknesses. The "udp" protocol is the default. A host
+may be configured to respond to only a few of these protocols,
+or even none at all. For example, www.microsoft.com is generally
+alive but not pingable.
-With the "tcp" protocol the ping() method attempts to establish a
-connection to the remote host's echo port. If the connection is
-successfully established, the remote host is considered reachable. No
-data is actually echoed. This protocol does not require any special
-privileges but has higher overhead than the other two protocols.
+=over 4
+
+=item icmp
+
+The C<ping()> method sends an icmp echo message to the remote host
+(this is what the UNIX ping program does).
+If the echoed message is received from the remote host and
+the echoed information is correct, the remote host is considered
+reachable. Specifying this protocol requires that the program
+be run as root or that the program be setuid to root.
-Specifying the "udp" protocol causes the ping() method to send a udp
+=item udp
+
+The C<ping()> method sends a udp
packet to the remote host's echo port. If the echoed packet is
received from the remote host and the received packet contains the
same data as the packet that was sent, the remote host is considered
reachable. This protocol does not require any special privileges.
-It should be borne in mind that, for both udp ping, a host
+It should be borne in mind that, for both udp and tcp ping, a host
will be reported as unreachable if it is not running the
appropriate echo service. For Unix-like systems see L<inetd(8)> for
more information.
-If the "icmp" protocol is specified, the ping() method sends an icmp
-echo message to the remote host, which is what the UNIX ping program
-does. If the echoed message is received from the remote host and
-the echoed information is correct, the remote host is considered
-reachable. Specifying the "icmp" protocol requires that the program
-be run as root or that the program be setuid to root.
+=item tcp
-If the "external" protocol is specified, the ping() method attempts to
-use the C<Net::Ping::External> module to ping the remote host.
-C<Net::Ping::External> interfaces with your system's default C<ping>
-utility to perform the ping, and generally produces relatively
+The C<ping()> method attempts to establish a
+connection to the remote host's echo port. If the connection is
+successfully established, the remote host is considered reachable.
+Once the connection is made, it is torn down immediately -- no data
+is actually echoed. This protocol does not require any special
+privileges but has highest overhead of the protocols.
+
+=item stream
+
+This is just like the tcp protocol, except that once it establishes
+the tcp connection, it keeps it up. Each subsequent ping
+request re-uses the existing connection. stream
+provides better performance than tcp since the connection
+doesn't need to be created and torn down with every ping. It is
+also the only protocol that will recognize that the original host is
+gone, even if it is immediately replaced by an
+identical host responding in exactly the same way. The drawback
+is that you can only ping one host per Ping instance. You will get
+an error if you neglect to call C<close()> before trying to ping
+a different network device.
+
+=item external
+
+The ping() method attempts to use the C<Net::Ping::External> module to ping
+the remote host. C<Net::Ping::External> interfaces with your system's default
+L<ping(8)> utility to perform the ping, and generally produces relatively
accurate results. If C<Net::Ping::External> if not installed on your
system, specifying the "external" protocol will result in an error.
1 is returned if the host is reachable and 0 if it is not. For all
practical purposes, undef and 0 and can be treated as the same case.
+=item $p->open($host);
+
+When you are using the stream protocol, this call pre-opens the
+tcp socket. It's only necessary to do this if you want to
+provide a different timeout when creating the connection, or
+remove the overhead of establishing the connection from the
+first ping. If you don't call C<open()>, the connection is
+automatically openeed the first time C<ping()> is called.
+This call simply does nothing if you are using any protocol other
+than stream.
+
=item $p->close();
Close the network connection for this ping object. The network
avoid flooding your network with packets.
The icmp protocol requires that the program be run as root or that it
-be setuid to root. The tcp and udp protocols do not require special
-privileges, but not all network devices implement the echo protocol
-for tcp or udp.
+be setuid to root. The other protocols do not require special
+privileges, but not all network devices implement tcp or udp echo.
Local hosts should normally respond to pings within milliseconds.
However, on a very congested network it may take up to 3 seconds or
host is not reachable (which is almost the truth).
Reachability doesn't necessarily mean that the remote host is actually
-functioning beyond its ability to echo packets.
+functioning beyond its ability to echo packets. tcp is slightly better
+at indicating the health of a system than icmp because it uses more
+of the networking stack to respond.
Because of a lack of anything better, this module uses its own
routines to pack and unpack ICMP packets. It would be better for a
Changes by Jenda@Krynicky.cz and Dave Cottle <d.cottle@csc.canterbury.ac.nz>
-Changes and bug fixes by Casey Tweten <crt@kiski.net>
+Changes and bug fixes by Casey West <casey@geeknest.com>
=cut
Tom Phoenix, E<lt>F<rootbeer@redcat.com>E<gt>, with help from
many other folks.
-Multiple constant declarations at once added by Casey Tweten,
-E<lt>F<crt@kiski.net>E<gt>.
+Multiple constant declarations at once added by Casey West,
+E<lt>F<casey@geeknest.com>E<gt>.
=head1 COPYRIGHT
Bytes in the source text that have their high-bit set will be treated
as being part of a literal UTF-8 character. This includes most literals
such as identifiers, string constants, constant regular expression patterns
-and package names. On EBCDIC platforms, characters in the C1 control group
-and the Latin 1 character set are treated as being part of a literal
-UTF-EBCDIC character.
+and package names. On EBCDIC platforms characters in the Latin 1
+character set are treated as being part of a literal UTF-EBCDIC character.
=item *
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
GvCV(gv) = GvCV(glob_gv);
+ SvREFCNT_inc((SV*)GvCV(gv));
GvIMPORTED_CV_on(gv);
LEAVE;
}
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT) && !defined(LOCAL_PATCH_COUNT)
static char *local_patches[] = {
NULL
+ ,"DEVEL9717"
,NULL
};
An exploration of some of the issues facing Perl programmers
on EBCDIC based computers. We do not cover localization,
-internationalization, or multi byte character set issues (yet).
+internationalization, or multi byte character set issues other
+than some discussion of UTF-8 and UTF-EBCDIC.
Portions that are still incomplete are marked with XXX.
=head2 EBCDIC
-The Extended Binary Coded Decimal Interchange Code refers to a
+The Extended Binary Coded Decimal Interchange Code refers to a
large collection of slightly different single and multi byte
coded character sets that are different from ASCII or ISO 8859-1
and typically run on host computers. The EBCDIC encodings derive
Character code set ID 1047 is also a mapping of the ASCII plus
Latin-1 characters (i.e. ISO 8859-1) to an EBCDIC set. 1047 is
-used under Unix System Services for OS/390, and OpenEdition for VM/ESA.
-CCSID 1047 differs from CCSID 0037 in eight places.
+used under Unix System Services for OS/390 or z/OS, and OpenEdition
+for VM/ESA. CCSID 1047 differs from CCSID 0037 in eight places.
=head2 POSIX-BC
The EBCDIC code page in use on Siemens' BS2000 system is distinct from
1047 and 0037. It is identified below as the POSIX-BC set.
+=head2 Unicode and UTF
+
+UTF is a Unicode Transformation Format. UTF-8 is a Unicode conforming
+representation of the Unicode standard that looks very much like ASCII.
+UTF-EBCDIC is an attempt to represent Unicode characters in an EBCDIC
+transparent manner.
+
=head1 SINGLE OCTET TABLES
The following tables list the ASCII and Latin 1 ordered sets including
C1 controls (80..9f), and Latin-1 (a.k.a. ISO 8859-1) (a0..ff). In the
table non-printing control character names as well as the Latin 1
extensions to ASCII have been labelled with character names roughly
-corresponding to I<The Unicode Standard, Version 2.0> albeit with
+corresponding to I<The Unicode Standard, Version 3.0> albeit with
substitutions such as s/LATIN// and s/VULGAR// in all cases,
s/CAPITAL LETTER// in some cases, and s/SMALL LETTER ([A-Z])/\l$1/
in some other cases (the C<charnames> pragma names unfortunately do
=back
perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \
- -e '{printf("%s%-9o%-9o%-9o%-9o\n",$1,$2,$3,$4,$5)}' perlebcdic.pod
+ -e '{printf("%s%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5)}' perlebcdic.pod
+
+If you want to retain the UTF-x code points then in script form you
+might want to write:
+
+=over 4
+
+=item recipe 1
+
+=back
+
+ open(FH,"<perlebcdic.pod") or die "Could not open perlebcdic.pod: $!";
+ while (<FH>) {
+ if (/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\.?(\d*)\s+(\d+)\.?(\d*)/) {
+ if ($7 ne '' && $9 ne '') {
+ printf("%s%-9o%-9o%-9o%-9o%-3o.%-5o%-3o.%o\n",$1,$2,$3,$4,$5,$6,$7,$8,$9);
+ }
+ elsif ($7 ne '') {
+ printf("%s%-9o%-9o%-9o%-9o%-3o.%-5o%o\n",$1,$2,$3,$4,$5,$6,$7,$8);
+ }
+ else {
+ printf("%s%-9o%-9o%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5,$6,$8);
+ }
+ }
+ }
If you would rather see this table listing hexadecimal values then
run the table through:
=over 4
-=item recipe 1
+=item recipe 2
=back
perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \
- -e '{printf("%s%-9X%-9X%-9X%-9X\n",$1,$2,$3,$4,$5)}' perlebcdic.pod
-
-
- 8859-1
- chr 0819 0037 1047 POSIX-BC
- ----------------------------------------------------------------
- <NULL> 0 0 0 0
- <START OF HEADING> 1 1 1 1
- <START OF TEXT> 2 2 2 2
- <END OF TEXT> 3 3 3 3
- <END OF TRANSMISSION> 4 55 55 55
- <ENQUIRY> 5 45 45 45
- <ACKNOWLEDGE> 6 46 46 46
- <BELL> 7 47 47 47
- <BACKSPACE> 8 22 22 22
- <HORIZONTAL TABULATION> 9 5 5 5
- <LINE FEED> 10 37 21 21 ***
- <VERTICAL TABULATION> 11 11 11 11
- <FORM FEED> 12 12 12 12
- <CARRIAGE RETURN> 13 13 13 13
- <SHIFT OUT> 14 14 14 14
- <SHIFT IN> 15 15 15 15
- <DATA LINK ESCAPE> 16 16 16 16
- <DEVICE CONTROL ONE> 17 17 17 17
- <DEVICE CONTROL TWO> 18 18 18 18
- <DEVICE CONTROL THREE> 19 19 19 19
- <DEVICE CONTROL FOUR> 20 60 60 60
- <NEGATIVE ACKNOWLEDGE> 21 61 61 61
- <SYNCHRONOUS IDLE> 22 50 50 50
- <END OF TRANSMISSION BLOCK> 23 38 38 38
- <CANCEL> 24 24 24 24
- <END OF MEDIUM> 25 25 25 25
- <SUBSTITUTE> 26 63 63 63
- <ESCAPE> 27 39 39 39
- <FILE SEPARATOR> 28 28 28 28
- <GROUP SEPARATOR> 29 29 29 29
- <RECORD SEPARATOR> 30 30 30 30
- <UNIT SEPARATOR> 31 31 31 31
- <SPACE> 32 64 64 64
- ! 33 90 90 90
- " 34 127 127 127
- # 35 123 123 123
- $ 36 91 91 91
- % 37 108 108 108
- & 38 80 80 80
- ' 39 125 125 125
- ( 40 77 77 77
- ) 41 93 93 93
- * 42 92 92 92
- + 43 78 78 78
- , 44 107 107 107
- - 45 96 96 96
- . 46 75 75 75
- / 47 97 97 97
- 0 48 240 240 240
- 1 49 241 241 241
- 2 50 242 242 242
- 3 51 243 243 243
- 4 52 244 244 244
- 5 53 245 245 245
- 6 54 246 246 246
- 7 55 247 247 247
- 8 56 248 248 248
- 9 57 249 249 249
- : 58 122 122 122
- ; 59 94 94 94
- < 60 76 76 76
- = 61 126 126 126
- > 62 110 110 110
- ? 63 111 111 111
- @ 64 124 124 124
- A 65 193 193 193
- B 66 194 194 194
- C 67 195 195 195
- D 68 196 196 196
- E 69 197 197 197
- F 70 198 198 198
- G 71 199 199 199
- H 72 200 200 200
- I 73 201 201 201
- J 74 209 209 209
- K 75 210 210 210
- L 76 211 211 211
- M 77 212 212 212
- N 78 213 213 213
- O 79 214 214 214
- P 80 215 215 215
- Q 81 216 216 216
- R 82 217 217 217
- S 83 226 226 226
- T 84 227 227 227
- U 85 228 228 228
- V 86 229 229 229
- W 87 230 230 230
- X 88 231 231 231
- Y 89 232 232 232
- Z 90 233 233 233
- [ 91 186 173 187 *** ###
- \ 92 224 224 188 ###
- ] 93 187 189 189 ***
- ^ 94 176 95 106 *** ###
- _ 95 109 109 109
- ` 96 121 121 74 ###
- a 97 129 129 129
- b 98 130 130 130
- c 99 131 131 131
- d 100 132 132 132
- e 101 133 133 133
- f 102 134 134 134
- g 103 135 135 135
- h 104 136 136 136
- i 105 137 137 137
- j 106 145 145 145
- k 107 146 146 146
- l 108 147 147 147
- m 109 148 148 148
- n 110 149 149 149
- o 111 150 150 150
- p 112 151 151 151
- q 113 152 152 152
- r 114 153 153 153
- s 115 162 162 162
- t 116 163 163 163
- u 117 164 164 164
- v 118 165 165 165
- w 119 166 166 166
- x 120 167 167 167
- y 121 168 168 168
- z 122 169 169 169
- { 123 192 192 251 ###
- | 124 79 79 79
- } 125 208 208 253 ###
- ~ 126 161 161 255 ###
- <DELETE> 127 7 7 7
- <C1 0> 128 32 32 32
- <C1 1> 129 33 33 33
- <C1 2> 130 34 34 34
- <C1 3> 131 35 35 35
- <C1 4> 132 36 36 36
- <C1 5> 133 21 37 37 ***
- <C1 6> 134 6 6 6
- <C1 7> 135 23 23 23
- <C1 8> 136 40 40 40
- <C1 9> 137 41 41 41
- <C1 10> 138 42 42 42
- <C1 11> 139 43 43 43
- <C1 12> 140 44 44 44
- <C1 13> 141 9 9 9
- <C1 14> 142 10 10 10
- <C1 15> 143 27 27 27
- <C1 16> 144 48 48 48
- <C1 17> 145 49 49 49
- <C1 18> 146 26 26 26
- <C1 19> 147 51 51 51
- <C1 20> 148 52 52 52
- <C1 21> 149 53 53 53
- <C1 22> 150 54 54 54
- <C1 23> 151 8 8 8
- <C1 24> 152 56 56 56
- <C1 25> 153 57 57 57
- <C1 26> 154 58 58 58
- <C1 27> 155 59 59 59
- <C1 28> 156 4 4 4
- <C1 29> 157 20 20 20
- <C1 30> 158 62 62 62
- <C1 31> 159 255 255 95 ###
- <NON-BREAKING SPACE> 160 65 65 65
- <INVERTED EXCLAMATION MARK> 161 170 170 170
- <CENT SIGN> 162 74 74 176 ###
- <POUND SIGN> 163 177 177 177
- <CURRENCY SIGN> 164 159 159 159
- <YEN SIGN> 165 178 178 178
- <BROKEN BAR> 166 106 106 208 ###
- <SECTION SIGN> 167 181 181 181
- <DIAERESIS> 168 189 187 121 *** ###
- <COPYRIGHT SIGN> 169 180 180 180
- <FEMININE ORDINAL INDICATOR> 170 154 154 154
- <LEFT POINTING GUILLEMET> 171 138 138 138
- <NOT SIGN> 172 95 176 186 *** ###
- <SOFT HYPHEN> 173 202 202 202
- <REGISTERED TRADE MARK SIGN> 174 175 175 175
- <MACRON> 175 188 188 161 ###
- <DEGREE SIGN> 176 144 144 144
- <PLUS-OR-MINUS SIGN> 177 143 143 143
- <SUPERSCRIPT TWO> 178 234 234 234
- <SUPERSCRIPT THREE> 179 250 250 250
- <ACUTE ACCENT> 180 190 190 190
- <MICRO SIGN> 181 160 160 160
- <PARAGRAPH SIGN> 182 182 182 182
- <MIDDLE DOT> 183 179 179 179
- <CEDILLA> 184 157 157 157
- <SUPERSCRIPT ONE> 185 218 218 218
- <MASC. ORDINAL INDICATOR> 186 155 155 155
- <RIGHT POINTING GUILLEMET> 187 139 139 139
- <FRACTION ONE QUARTER> 188 183 183 183
- <FRACTION ONE HALF> 189 184 184 184
- <FRACTION THREE QUARTERS> 190 185 185 185
- <INVERTED QUESTION MARK> 191 171 171 171
- <A WITH GRAVE> 192 100 100 100
- <A WITH ACUTE> 193 101 101 101
- <A WITH CIRCUMFLEX> 194 98 98 98
- <A WITH TILDE> 195 102 102 102
- <A WITH DIAERESIS> 196 99 99 99
- <A WITH RING ABOVE> 197 103 103 103
- <CAPITAL LIGATURE AE> 198 158 158 158
- <C WITH CEDILLA> 199 104 104 104
- <E WITH GRAVE> 200 116 116 116
- <E WITH ACUTE> 201 113 113 113
- <E WITH CIRCUMFLEX> 202 114 114 114
- <E WITH DIAERESIS> 203 115 115 115
- <I WITH GRAVE> 204 120 120 120
- <I WITH ACUTE> 205 117 117 117
- <I WITH CIRCUMFLEX> 206 118 118 118
- <I WITH DIAERESIS> 207 119 119 119
- <CAPITAL LETTER ETH> 208 172 172 172
- <N WITH TILDE> 209 105 105 105
- <O WITH GRAVE> 210 237 237 237
- <O WITH ACUTE> 211 238 238 238
- <O WITH CIRCUMFLEX> 212 235 235 235
- <O WITH TILDE> 213 239 239 239
- <O WITH DIAERESIS> 214 236 236 236
- <MULTIPLICATION SIGN> 215 191 191 191
- <O WITH STROKE> 216 128 128 128
- <U WITH GRAVE> 217 253 253 224 ###
- <U WITH ACUTE> 218 254 254 254
- <U WITH CIRCUMFLEX> 219 251 251 221 ###
- <U WITH DIAERESIS> 220 252 252 252
- <Y WITH ACUTE> 221 173 186 173 *** ###
- <CAPITAL LETTER THORN> 222 174 174 174
- <SMALL LETTER SHARP S> 223 89 89 89
- <a WITH GRAVE> 224 68 68 68
- <a WITH ACUTE> 225 69 69 69
- <a WITH CIRCUMFLEX> 226 66 66 66
- <a WITH TILDE> 227 70 70 70
- <a WITH DIAERESIS> 228 67 67 67
- <a WITH RING ABOVE> 229 71 71 71
- <SMALL LIGATURE ae> 230 156 156 156
- <c WITH CEDILLA> 231 72 72 72
- <e WITH GRAVE> 232 84 84 84
- <e WITH ACUTE> 233 81 81 81
- <e WITH CIRCUMFLEX> 234 82 82 82
- <e WITH DIAERESIS> 235 83 83 83
- <i WITH GRAVE> 236 88 88 88
- <i WITH ACUTE> 237 85 85 85
- <i WITH CIRCUMFLEX> 238 86 86 86
- <i WITH DIAERESIS> 239 87 87 87
- <SMALL LETTER eth> 240 140 140 140
- <n WITH TILDE> 241 73 73 73
- <o WITH GRAVE> 242 205 205 205
- <o WITH ACUTE> 243 206 206 206
- <o WITH CIRCUMFLEX> 244 203 203 203
- <o WITH TILDE> 245 207 207 207
- <o WITH DIAERESIS> 246 204 204 204
- <DIVISION SIGN> 247 225 225 225
- <o WITH STROKE> 248 112 112 112
- <u WITH GRAVE> 249 221 221 192 ###
- <u WITH ACUTE> 250 222 222 222
- <u WITH CIRCUMFLEX> 251 219 219 219
- <u WITH DIAERESIS> 252 220 220 220
- <y WITH ACUTE> 253 141 141 141
- <SMALL LETTER thorn> 254 142 142 142
- <y WITH DIAERESIS> 255 223 223 223
+ -e '{printf("%s%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5)}' perlebcdic.pod
+
+Or, in order to retain the UTF-x code points in hexadecimal:
+
+=over 4
+
+=item recipe 3
+
+=back
+
+ open(FH,"<perlebcdic.pod") or die "Could not open perlebcdic.pod: $!";
+ while (<FH>) {
+ if (/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\.?(\d*)\s+(\d+)\.?(\d*)/) {
+ if ($7 ne '' && $9 ne '') {
+ printf("%s%-9X%-9X%-9X%-9X%-2X.%-6X%-2X.%X\n",$1,$2,$3,$4,$5,$6,$7,$8,$9);
+ }
+ elsif ($7 ne '') {
+ printf("%s%-9X%-9X%-9X%-9X%-2X.%-6X%X\n",$1,$2,$3,$4,$5,$6,$7,$8);
+ }
+ else {
+ printf("%s%-9X%-9X%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5,$6,$8);
+ }
+ }
+ }
+
+
+ incomp- incomp-
+ 8859-1 lete lete
+ chr 0819 0037 1047 POSIX-BC UTF-8 UTF-EBCDIC
+ ------------------------------------------------------------------------------------
+ <NULL> 0 0 0 0 0 0
+ <START OF HEADING> 1 1 1 1 1 1
+ <START OF TEXT> 2 2 2 2 2 2
+ <END OF TEXT> 3 3 3 3 3 3
+ <END OF TRANSMISSION> 4 55 55 55 4 55
+ <ENQUIRY> 5 45 45 45 5 45
+ <ACKNOWLEDGE> 6 46 46 46 6 46
+ <BELL> 7 47 47 47 7 47
+ <BACKSPACE> 8 22 22 22 8 22
+ <HORIZONTAL TABULATION> 9 5 5 5 9 5
+ <LINE FEED> 10 37 21 21 10 21 ***
+ <VERTICAL TABULATION> 11 11 11 11 11 11
+ <FORM FEED> 12 12 12 12 12 12
+ <CARRIAGE RETURN> 13 13 13 13 13 13
+ <SHIFT OUT> 14 14 14 14 14 14
+ <SHIFT IN> 15 15 15 15 15 15
+ <DATA LINK ESCAPE> 16 16 16 16 16 16
+ <DEVICE CONTROL ONE> 17 17 17 17 17 17
+ <DEVICE CONTROL TWO> 18 18 18 18 18 18
+ <DEVICE CONTROL THREE> 19 19 19 19 19 19
+ <DEVICE CONTROL FOUR> 20 60 60 60 20 60
+ <NEGATIVE ACKNOWLEDGE> 21 61 61 61 21 61
+ <SYNCHRONOUS IDLE> 22 50 50 50 22 50
+ <END OF TRANSMISSION BLOCK> 23 38 38 38 23 38
+ <CANCEL> 24 24 24 24 24 24
+ <END OF MEDIUM> 25 25 25 25 25 25
+ <SUBSTITUTE> 26 63 63 63 26 63
+ <ESCAPE> 27 39 39 39 27 39
+ <FILE SEPARATOR> 28 28 28 28 28 28
+ <GROUP SEPARATOR> 29 29 29 29 29 29
+ <RECORD SEPARATOR> 30 30 30 30 30 30
+ <UNIT SEPARATOR> 31 31 31 31 31 31
+ <SPACE> 32 64 64 64 32 64
+ ! 33 90 90 90 33 90
+ " 34 127 127 127 34 127
+ # 35 123 123 123 35 123
+ $ 36 91 91 91 36 91
+ % 37 108 108 108 37 108
+ & 38 80 80 80 38 80
+ ' 39 125 125 125 39 125
+ ( 40 77 77 77 40 77
+ ) 41 93 93 93 41 93
+ * 42 92 92 92 42 92
+ + 43 78 78 78 43 78
+ , 44 107 107 107 44 107
+ - 45 96 96 96 45 96
+ . 46 75 75 75 46 75
+ / 47 97 97 97 47 97
+ 0 48 240 240 240 48 240
+ 1 49 241 241 241 49 241
+ 2 50 242 242 242 50 242
+ 3 51 243 243 243 51 243
+ 4 52 244 244 244 52 244
+ 5 53 245 245 245 53 245
+ 6 54 246 246 246 54 246
+ 7 55 247 247 247 55 247
+ 8 56 248 248 248 56 248
+ 9 57 249 249 249 57 249
+ : 58 122 122 122 58 122
+ ; 59 94 94 94 59 94
+ < 60 76 76 76 60 76
+ = 61 126 126 126 61 126
+ > 62 110 110 110 62 110
+ ? 63 111 111 111 63 111
+ @ 64 124 124 124 64 124
+ A 65 193 193 193 65 193
+ B 66 194 194 194 66 194
+ C 67 195 195 195 67 195
+ D 68 196 196 196 68 196
+ E 69 197 197 197 69 197
+ F 70 198 198 198 70 198
+ G 71 199 199 199 71 199
+ H 72 200 200 200 72 200
+ I 73 201 201 201 73 201
+ J 74 209 209 209 74 209
+ K 75 210 210 210 75 210
+ L 76 211 211 211 76 211
+ M 77 212 212 212 77 212
+ N 78 213 213 213 78 213
+ O 79 214 214 214 79 214
+ P 80 215 215 215 80 215
+ Q 81 216 216 216 81 216
+ R 82 217 217 217 82 217
+ S 83 226 226 226 83 226
+ T 84 227 227 227 84 227
+ U 85 228 228 228 85 228
+ V 86 229 229 229 86 229
+ W 87 230 230 230 87 230
+ X 88 231 231 231 88 231
+ Y 89 232 232 232 89 232
+ Z 90 233 233 233 90 233
+ [ 91 186 173 187 91 173 *** ###
+ \ 92 224 224 188 92 224 ###
+ ] 93 187 189 189 93 189 ***
+ ^ 94 176 95 106 94 95 *** ###
+ _ 95 109 109 109 95 109
+ ` 96 121 121 74 96 121 ###
+ a 97 129 129 129 97 129
+ b 98 130 130 130 98 130
+ c 99 131 131 131 99 131
+ d 100 132 132 132 100 132
+ e 101 133 133 133 101 133
+ f 102 134 134 134 102 134
+ g 103 135 135 135 103 135
+ h 104 136 136 136 104 136
+ i 105 137 137 137 105 137
+ j 106 145 145 145 106 145
+ k 107 146 146 146 107 146
+ l 108 147 147 147 108 147
+ m 109 148 148 148 109 148
+ n 110 149 149 149 110 149
+ o 111 150 150 150 111 150
+ p 112 151 151 151 112 151
+ q 113 152 152 152 113 152
+ r 114 153 153 153 114 153
+ s 115 162 162 162 115 162
+ t 116 163 163 163 116 163
+ u 117 164 164 164 117 164
+ v 118 165 165 165 118 165
+ w 119 166 166 166 119 166
+ x 120 167 167 167 120 167
+ y 121 168 168 168 121 168
+ z 122 169 169 169 122 169
+ { 123 192 192 251 123 192 ###
+ | 124 79 79 79 124 79
+ } 125 208 208 253 125 208 ###
+ ~ 126 161 161 255 126 161 ###
+ <DELETE> 127 7 7 7 127 7
+ <C1 0> 128 32 32 32 194.128 32
+ <C1 1> 129 33 33 33 194.129 33
+ <C1 2> 130 34 34 34 194.130 34
+ <C1 3> 131 35 35 35 194.131 35
+ <C1 4> 132 36 36 36 194.132 36
+ <C1 5> 133 21 37 37 194.133 37 ***
+ <C1 6> 134 6 6 6 194.134 6
+ <C1 7> 135 23 23 23 194.135 23
+ <C1 8> 136 40 40 40 194.136 40
+ <C1 9> 137 41 41 41 194.137 41
+ <C1 10> 138 42 42 42 194.138 42
+ <C1 11> 139 43 43 43 194.139 43
+ <C1 12> 140 44 44 44 194.140 44
+ <C1 13> 141 9 9 9 194.141 9
+ <C1 14> 142 10 10 10 194.142 10
+ <C1 15> 143 27 27 27 194.143 27
+ <C1 16> 144 48 48 48 194.144 48
+ <C1 17> 145 49 49 49 194.145 49
+ <C1 18> 146 26 26 26 194.146 26
+ <C1 19> 147 51 51 51 194.147 51
+ <C1 20> 148 52 52 52 194.148 52
+ <C1 21> 149 53 53 53 194.149 53
+ <C1 22> 150 54 54 54 194.150 54
+ <C1 23> 151 8 8 8 194.151 8
+ <C1 24> 152 56 56 56 194.152 56
+ <C1 25> 153 57 57 57 194.153 57
+ <C1 26> 154 58 58 58 194.154 58
+ <C1 27> 155 59 59 59 194.155 59
+ <C1 28> 156 4 4 4 194.156 4
+ <C1 29> 157 20 20 20 194.157 20
+ <C1 30> 158 62 62 62 194.158 62
+ <C1 31> 159 255 255 95 194.159 255 ###
+ <NON-BREAKING SPACE> 160 65 65 65 194.160 128.65
+ <INVERTED EXCLAMATION MARK> 161 170 170 170 194.161 128.66
+ <CENT SIGN> 162 74 74 176 194.162 128.67 ###
+ <POUND SIGN> 163 177 177 177 194.163 128.68
+ <CURRENCY SIGN> 164 159 159 159 194.164 128.69
+ <YEN SIGN> 165 178 178 178 194.165 128.70
+ <BROKEN BAR> 166 106 106 208 194.166 128.71 ###
+ <SECTION SIGN> 167 181 181 181 194.167 128.72
+ <DIAERESIS> 168 189 187 121 194.168 128.73 *** ###
+ <COPYRIGHT SIGN> 169 180 180 180 194.169 128.74
+ <FEMININE ORDINAL INDICATOR> 170 154 154 154 194.170 128.81
+ <LEFT POINTING GUILLEMET> 171 138 138 138 194.171 128.82
+ <NOT SIGN> 172 95 176 186 194.172 128.83 *** ###
+ <SOFT HYPHEN> 173 202 202 202 194.173 128.84
+ <REGISTERED TRADE MARK SIGN> 174 175 175 175 194.174 128.85
+ <MACRON> 175 188 188 161 194.175 128.86 ###
+ <DEGREE SIGN> 176 144 144 144 194.176 128.87
+ <PLUS-OR-MINUS SIGN> 177 143 143 143 194.177 128.88
+ <SUPERSCRIPT TWO> 178 234 234 234 194.178 128.89
+ <SUPERSCRIPT THREE> 179 250 250 250 194.179 128.98
+ <ACUTE ACCENT> 180 190 190 190 194.180 128.99
+ <MICRO SIGN> 181 160 160 160 194.181 128.100
+ <PARAGRAPH SIGN> 182 182 182 182 194.182 128.101
+ <MIDDLE DOT> 183 179 179 179 194.183 128.102
+ <CEDILLA> 184 157 157 157 194.184 128.103
+ <SUPERSCRIPT ONE> 185 218 218 218 194.185 128.104
+ <MASC. ORDINAL INDICATOR> 186 155 155 155 194.186 128.105
+ <RIGHT POINTING GUILLEMET> 187 139 139 139 194.187 128.106
+ <FRACTION ONE QUARTER> 188 183 183 183 194.188 128.112
+ <FRACTION ONE HALF> 189 184 184 184 194.189 128.113
+ <FRACTION THREE QUARTERS> 190 185 185 185 194.190 128.114
+ <INVERTED QUESTION MARK> 191 171 171 171 194.191 128.115
+ <A WITH GRAVE> 192 100 100 100 195.128 138.65
+ <A WITH ACUTE> 193 101 101 101 195.129 138.66
+ <A WITH CIRCUMFLEX> 194 98 98 98 195.130 138.67
+ <A WITH TILDE> 195 102 102 102 195.131 138.68
+ <A WITH DIAERESIS> 196 99 99 99 195.132 138.69
+ <A WITH RING ABOVE> 197 103 103 103 195.133 138.70
+ <CAPITAL LIGATURE AE> 198 158 158 158 195.134 138.71
+ <C WITH CEDILLA> 199 104 104 104 195.135 138.72
+ <E WITH GRAVE> 200 116 116 116 195.136 138.73
+ <E WITH ACUTE> 201 113 113 113 195.137 138.74
+ <E WITH CIRCUMFLEX> 202 114 114 114 195.138 138.81
+ <E WITH DIAERESIS> 203 115 115 115 195.139 138.82
+ <I WITH GRAVE> 204 120 120 120 195.140 138.83
+ <I WITH ACUTE> 205 117 117 117 195.141 138.84
+ <I WITH CIRCUMFLEX> 206 118 118 118 195.142 138.85
+ <I WITH DIAERESIS> 207 119 119 119 195.143 138.86
+ <CAPITAL LETTER ETH> 208 172 172 172 195.144 138.87
+ <N WITH TILDE> 209 105 105 105 195.145 138.88
+ <O WITH GRAVE> 210 237 237 237 195.146 138.89
+ <O WITH ACUTE> 211 238 238 238 195.147 138.98
+ <O WITH CIRCUMFLEX> 212 235 235 235 195.148 138.99
+ <O WITH TILDE> 213 239 239 239 195.149 138.100
+ <O WITH DIAERESIS> 214 236 236 236 195.150 138.101
+ <MULTIPLICATION SIGN> 215 191 191 191 195.151 138.102
+ <O WITH STROKE> 216 128 128 128 195.152 138.103
+ <U WITH GRAVE> 217 253 253 224 195.153 138.104 ###
+ <U WITH ACUTE> 218 254 254 254 195.154 138.105
+ <U WITH CIRCUMFLEX> 219 251 251 221 195.155 138.106 ###
+ <U WITH DIAERESIS> 220 252 252 252 195.156 138.112
+ <Y WITH ACUTE> 221 173 186 173 195.157 138.113 *** ###
+ <CAPITAL LETTER THORN> 222 174 174 174 195.158 138.114
+ <SMALL LETTER SHARP S> 223 89 89 89 195.159 138.115
+ <a WITH GRAVE> 224 68 68 68 195.160 139.65
+ <a WITH ACUTE> 225 69 69 69 195.161 139.66
+ <a WITH CIRCUMFLEX> 226 66 66 66 195.162 139.67
+ <a WITH TILDE> 227 70 70 70 195.163 139.68
+ <a WITH DIAERESIS> 228 67 67 67 195.164 139.69
+ <a WITH RING ABOVE> 229 71 71 71 195.165 139.70
+ <SMALL LIGATURE ae> 230 156 156 156 195.166 139.71
+ <c WITH CEDILLA> 231 72 72 72 195.167 139.72
+ <e WITH GRAVE> 232 84 84 84 195.168 139.73
+ <e WITH ACUTE> 233 81 81 81 195.169 139.74
+ <e WITH CIRCUMFLEX> 234 82 82 82 195.170 139.81
+ <e WITH DIAERESIS> 235 83 83 83 195.171 139.82
+ <i WITH GRAVE> 236 88 88 88 195.172 139.83
+ <i WITH ACUTE> 237 85 85 85 195.173 139.84
+ <i WITH CIRCUMFLEX> 238 86 86 86 195.174 139.85
+ <i WITH DIAERESIS> 239 87 87 87 195.175 139.86
+ <SMALL LETTER eth> 240 140 140 140 195.176 139.87
+ <n WITH TILDE> 241 73 73 73 195.177 139.88
+ <o WITH GRAVE> 242 205 205 205 195.178 139.89
+ <o WITH ACUTE> 243 206 206 206 195.179 139.98
+ <o WITH CIRCUMFLEX> 244 203 203 203 195.180 139.99
+ <o WITH TILDE> 245 207 207 207 195.181 139.100
+ <o WITH DIAERESIS> 246 204 204 204 195.182 139.101
+ <DIVISION SIGN> 247 225 225 225 195.183 139.102
+ <o WITH STROKE> 248 112 112 112 195.184 139.103
+ <u WITH GRAVE> 249 221 221 192 195.185 139.104 ###
+ <u WITH ACUTE> 250 222 222 222 195.186 139.105
+ <u WITH CIRCUMFLEX> 251 219 219 219 195.187 139.106
+ <u WITH DIAERESIS> 252 220 220 220 195.188 139.112
+ <y WITH ACUTE> 253 141 141 141 195.189 139.113
+ <SMALL LETTER thorn> 254 142 142 142 195.190 139.114
+ <y WITH DIAERESIS> 255 223 223 223 195.191 139.115
If you would rather see the above table in CCSID 0037 order rather than
ASCII + Latin-1 order then run the table through:
=over 4
-=item recipe 2
+=item recipe 4
=back
perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\
-e '{push(@l,$_)}' \
-e 'END{print map{$_->[0]}' \
- -e ' sort{$a->[1] <=> $b->[1]}' \
+ -e ' sort{$a->[1] <=> $b->[1]}' \
-e ' map{[$_,substr($_,42,3)]}@l;}' perlebcdic.pod
If you would rather see it in CCSID 1047 order then change the digit
=over 4
-=item recipe 3
+=item recipe 5
=back
perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\
-e '{push(@l,$_)}' \
-e 'END{print map{$_->[0]}' \
- -e ' sort{$a->[1] <=> $b->[1]}' \
+ -e ' sort{$a->[1] <=> $b->[1]}' \
-e ' map{[$_,substr($_,51,3)]}@l;}' perlebcdic.pod
If you would rather see it in POSIX-BC order then change the digit
=over 4
-=item recipe 4
+=item recipe 6
=back
perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\
-e '{push(@l,$_)}' \
-e 'END{print map{$_->[0]}' \
- -e ' sort{$a->[1] <=> $b->[1]}' \
+ -e ' sort{$a->[1] <=> $b->[1]}' \
-e ' map{[$_,substr($_,60,3)]}@l;}' perlebcdic.pod
available from the shell or from the C library. Consult your system's
documentation for information on iconv.
-On OS/390 see the iconv(1) man page. One way to invoke the iconv
+On OS/390 or z/OS see the iconv(1) man page. One way to invoke the iconv
shell utility from within perl would be to:
- # OS/390 example
+ # OS/390 or z/OS example
$ascii_data = `echo '$ebcdic_data'| iconv -f IBM-1047 -t ISO8859-1`
or the inverse map:
- # OS/390 example
+ # OS/390 or z/OS example
$ebcdic_data = `echo '$ascii_data'| iconv -f ISO8859-1 -t IBM-1047`
For other perl based conversion options see the Convert::* modules on CPAN.
=head2 C RTL
-The OS/390 C run time library provides _atoe() and _etoa() functions.
+The OS/390 and z/OS C run time libraries provide _atoe() and _etoa() functions.
=head1 OPERATOR DIFFERENCES
print "Content-type:\ttext/html\015\012\015\012";
# this may be wrong on EBCDIC
-Under the IBM OS/390 USS Web Server for example you should instead
-write that as:
+Under the IBM OS/390 USS Web Server or WebSphere on z/OS for example
+you should instead write that as:
print "Content-type:\ttext/html\r\n\r\n"; # OK for DGW et alia
This strategy can employ a network connection. As such
it would be computationally expensive.
-=head1 TRANFORMATION FORMATS
+=head1 TRANSFORMATION FORMATS
There are a variety of ways of transforming data with an intra character set
mapping that serve a variety of purposes. Sorting was discussed in the
$string =~ s/=([0-9A-Fa-f][0-9A-Fa-f])/chr $a2e[hex $1]/ge;
$string =~ s/=[\n\r]+$//;
-=head2 Caesarian cyphers
+=head2 Caesarian ciphers
The practice of shifting an alphabet one or more characters for encipherment
dates back thousands of years and was explicitly detailed by Gaius Julius
=head1 Hashing order and checksums
+To the extent that it is possible to write code that depends on
+hashing order there may be differences between hashes as stored
+on an ASCII based machine and hashes stored on an EBCDIC based machine.
XXX
=head1 I18N AND L10N
=head1 MULTI OCTET CHARACTER SETS
-Multi byte EBCDIC code pages; Unicode, UTF-8, UTF-EBCDIC, XXX.
+Perl may work with an internal UTF-EBCDIC encoding form for wide characters
+on EBCDIC platforms in a manner analogous to the way that it works with
+the UTF-8 internal encoding form on ASCII based platforms.
+
+Legacy multi byte EBCDIC code pages XXX.
=head1 OS ISSUES
=back
-=head2 OS/390
+=head2 OS/390, z/OS
Perl runs under Unix Systems Services or USS.
See also the OS390::Stdio module on CPAN.
-=item OS/390 iconv
+=item OS/390, z/OS iconv
B<iconv> is supported as both a shell utility and a C RTL routine.
See also the iconv(1) and iconv(3) manual pages.
=item locales
-On OS/390 see L<locale> for information on locales. The L10N files
-are in F</usr/nls/locale>. $Config{d_setlocale} is 'define' on OS/390.
+On OS/390 or z/OS see L<locale> for information on locales. The L10N files
+are in F</usr/nls/locale>. $Config{d_setlocale} is 'define' on OS/390
+or z/OS.
=back
while attempting to view this document through the B<pod2man> program
(for example, you may see a plain C<y> rather than one with a diaeresis
as in E<yuml>). Another nroff truncated the resultant man page at
-the first occurence of 8 bit characters.
+the first occurrence of 8 bit characters.
Not all shells will allow multiple C<-e> string arguments to perl to
-be concatenated together properly as recipes 2, 3, and 4 might seem
-to imply.
-
-Perl does not yet work with any Unicode features on EBCDIC platforms.
+be concatenated together properly as recipes 0, 2, 4, 5, and 6 might
+seem to imply.
=head1 SEE ALSO
-L<perllocale>, L<perlfunc>.
+L<perllocale>, L<perlfunc>, L<perlunicode>, L<utf8>.
=head1 REFERENCES
B<ASCII: American Standard Code for Information Infiltration> Tom Jennings,
September 1999.
-B<The Unicode Standard Version 2.0> The Unicode Consortium,
-ISBN 0-201-48345-9, Addison Wesley Developers Press, July 1996.
-
-B<The Unicode Standard Version 3.0> The Unicode Consortium, Lisa Moore ed.,
+B<The Unicode Standard, Version 3.0> The Unicode Consortium, Lisa Moore ed.,
ISBN 0-201-61633-5, Addison Wesley Developers Press, February 2000.
B<CDRA: IBM - Character Data Representation Architecture -
Fred B. Wrixon, ISBN 1-57912-040-7, Black Dog & Leventhal Publishers,
1998.
+http://www.bobbemer.com/P-BIT.HTM
+B<IBM - EBCDIC and the P-bit; The biggest Computer Goof Ever> Robert Bemer.
+
+=head1 HISTORY
+
+15 April 2001: added UTF-8 and UTF-EBCDIC to main table, pvhp.
+
=head1 AUTHOR
Peter Prymmer pvhp@best.com wrote this in 1999 and 2000
UNTIE by Nick Ing-Simmons <F<nick@ing-simmons.net>>
-Tying Arrays by Casey Tweten <F<crt@kiski.net>>
+Tying Arrays by Casey West <F<casey@geeknest.com>>
=item POSIX-BC
+=item Unicode and UTF
+
=back
=item SINGLE OCTET TABLES
-recipe 0, recipe 1, recipe 2, recipe 3, recipe 4
+recipe 0, recipe 1, recipe 2, recipe 3, recipe 4, recipe 5, recipe 6
=item IDENTIFYING CHARACTER CODE SETS
=back
-=item TRANFORMATION FORMATS
+=item TRANSFORMATION FORMATS
=over 4
=item Quoted-Printable encoding and decoding
-=item Caesarian cyphers
+=item Caesarian ciphers
=back
IFS access
-=item OS/390
+=item OS/390, z/OS
-chcp, dataset access, OS/390 iconv, locales
+chcp, dataset access, OS/390, z/OS iconv, locales
=item VM/ESA?
=item REFERENCES
+=item HISTORY
+
=item AUTHOR
=back
=item DESCRIPTION
-C<GLOB_ERR>, C<GLOB_MARK>, C<GLOB_NOCASE>, C<GLOB_NOCHECK>, C<GLOB_NOSORT>,
-C<GLOB_BRACE>, C<GLOB_NOMAGIC>, C<GLOB_QUOTE>, C<GLOB_TILDE>, C<GLOB_CSH>,
-C<GLOB_ALPHASORT>
+C<GLOB_ERR>, C<GLOB_LIMIT>, C<GLOB_MARK>, C<GLOB_NOCASE>, C<GLOB_NOCHECK>,
+C<GLOB_NOSORT>, C<GLOB_BRACE>, C<GLOB_NOMAGIC>, C<GLOB_QUOTE>,
+C<GLOB_TILDE>, C<GLOB_CSH>, C<GLOB_ALPHASORT>
=item DIAGNOSTICS
=back
+=head2 List::Util - A selection of general-utility list subroutines
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+first BLOCK LIST, max LIST, maxstr LIST, min LIST, minstr LIST, reduce
+BLOCK LIST, sum LIST
+
+=item SUGGESTED ADDITIONS
+
+=item COPYRIGHT
+
+=back
+
+=head2 List::Utilib::List::Util, List::Util - A selection of
+general-utility list subroutines
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+first BLOCK LIST, max LIST, maxstr LIST, min LIST, minstr LIST, reduce
+BLOCK LIST, sum LIST
+
+=item SUGGESTED ADDITIONS
+
+=item COPYRIGHT
+
+=back
+
+=head2 List::Utilib::Scalar::Util, Scalar::Util - A selection of
+general-utility scalar subroutines
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+blessed EXPR, dualvar NUM, STRING, isweak EXPR, reftype EXPR, weaken REF
+
+=item COPYRIGHT
+
+=item BLATANT PLUG
+
+=back
+
=head2 Locale::Constants - constants for Locale codes
=over 4
=item DESCRIPTION
+icmp, udp, tcp, stream, external
+
=over 4
=item Functions
Net::Ping->new([$proto [, $def_timeout [, $bytes]]]);, $p->ping($host [,
-$timeout]);, $p->close();, pingecho($host [, $timeout]);
+$timeout]);, $p->open($host);, $p->close();, pingecho($host [, $timeout]);
=back
=back
+=head2 Scalar::Util - A selection of general-utility scalar subroutines
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+blessed EXPR, dualvar NUM, STRING, isweak EXPR, reftype EXPR, weaken REF
+
+=item COPYRIGHT
+
+=item BLATANT PLUG
+
+=back
+
=head2 Search::Dict, look - search for key in dictionary file
=over 4
=back
+=head2 Time::HiRes - High resolution ualarm, usleep, and gettimeofday
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+gettimeofday (), usleep ( $useconds ), ualarm ( $useconds [,
+$interval_useconds ] ), tv_interval ( $ref_to_gettimeofday [,
+$ref_to_later_gettimeofday] ), time (), sleep ( $floating_seconds ), alarm
+( $floating_seconds [, $interval_floating_seconds ] ), setitimer ( $which,
+$floating_seconds [, $interval_floating_seconds ] ), getitimer ( $which )
+
+=item EXAMPLES
+
+=item C API
+
+=item AUTHORS
+
+=item REVISION
+
+=item COPYRIGHT
+
+=back
+
=head2 Time::Local - efficiently compute time from local and GMT time
=over 4
=back
+=head2 Time::Piece - Object Oriented time objects
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item USAGE
+
+=over 4
+
+=item Local Locales
+
+=item Date Calculations
+
+=item Date Comparisons
+
+=item Global Overriding
+
+=back
+
+=item AUTHOR
+
+=over 4
+
+=item License
+
+=item Bugs
+
+=back
+
+=back
+
+=head2 Time::Piece::Seconds, Time::Seconds - a simple API to convert
+seconds to other date values
+
+=over 4
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item METHODS
+
+=item AUTHOR
+
+=item LICENSE
+
+=item Bugs
+
+=back
+
=head2 Time::gmtime - by-name interface to Perl's built-in gmtime()
function
}
if ($Config{d_symlink}) {
- my @dirs = split " " => $Config{libpth};
- my $target = pop @dirs;
- symlink $target => "linktest";
- mkdir "pteerslt";
- chdir "pteerslt";
- my $rel = "../../t/linktest";
-
- my $abs_path = Cwd::abs_path($rel);
- my $fast_abs_path = Cwd::fast_abs_path($rel);
- print +($abs_path eq $target ? "" : "not "), "ok 13\n";
- print +($fast_abs_path eq $target ? "" : "not "), "ok 14\n";
-
- chdir "..";
- rmdir "pteerslt";
- unlink "linktest";
+ my @dirs = grep(! -l $_ => (split " " => $Config{libpth}));
+ if (@dirs) {
+ my $target = pop @dirs;
+ symlink $target => "linktest";
+ mkdir "pteerslt";
+ chdir "pteerslt";
+ my $rel = "../../t/linktest";
+
+ my $abs_path = Cwd::abs_path($rel);
+ my $fast_abs_path = Cwd::fast_abs_path($rel);
+ print "# abs_path $abs_path\n";
+ print "# fast_abs_path $fast_abs_path\n";
+ print "# target $target\n";
+ print +($abs_path eq $target ? "" : "not "), "ok 13\n";
+ print +($fast_abs_path eq $target ? "" : "not "), "ok 14\n";
+
+ chdir "..";
+ rmdir "pteerslt";
+ unlink "linktest";
+ } else {
+ print "ok 13 # skipped\n";
+ print "ok 14 # skipped\n";
+ }
} else {
print "ok 13 # skipped\n";
print "ok 14 # skipped\n";
--- /dev/null
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+# Utility testing functions.
+my $test_num = 1;
+sub ok ($;$) {
+ my($test, $name) = @_;
+ print "not " unless $test;
+ print "ok $test_num";
+ print " - $name" if defined $name;
+ print "\n";
+ $test_num++;
+}
+
+
+my $loaded;
+BEGIN { $| = 1; $^W = 1; }
+END {print "not ok $test_num\n" unless $loaded;}
+print "1..$Total_tests\n";
+use Exporter;
+$loaded = 1;
+ok(1, 'compile');
+
+
+BEGIN {
+ # Methods which Exporter says it implements.
+ @Exporter_Methods = qw(import
+ export_to_level
+ require_version
+ export_fail
+ );
+}
+
+BEGIN { $Total_tests = 14 + @Exporter_Methods }
+
+package Testing;
+require Exporter;
+@ISA = qw(Exporter);
+
+# Make sure Testing can do everything its supposed to.
+foreach my $meth (@::Exporter_Methods) {
+ ::ok( Testing->can($meth), "subclass can $meth()" );
+}
+
+%EXPORT_TAGS = (
+ This => [qw(stuff %left)],
+ That => [qw(Above the @wailing)],
+ tray => [qw(Fasten $seatbelt)],
+ );
+@EXPORT = qw(lifejacket);
+@EXPORT_OK = qw(under &your $seat);
+$VERSION = '1.05';
+
+::ok( Testing->require_version(1.05), 'require_version()' );
+eval { Testing->require_version(1.11); 1 };
+::ok( $@, 'require_version() fail' );
+::ok( Testing->require_version(0), 'require_version(0)' );
+
+sub lifejacket { 'lifejacket' }
+sub stuff { 'stuff' }
+sub Above { 'Above' }
+sub the { 'the' }
+sub Fasten { 'Fasten' }
+sub your { 'your' }
+sub under { 'under' }
+use vars qw($seatbelt $seat @wailing %left);
+$seatbelt = 'seatbelt';
+$seat = 'seat';
+@wailing = qw(AHHHHHH);
+%left = ( left => "right" );
+
+
+Exporter::export_ok_tags;
+
+my %tags = map { $_ => 1 } map { @$_ } values %EXPORT_TAGS;
+my %exportok = map { $_ => 1 } @EXPORT_OK;
+my $ok = 1;
+foreach my $tag (keys %tags) {
+ $ok = exists $exportok{$tag};
+}
+::ok( $ok, 'export_ok_tags()' );
+
+
+package Foo;
+Testing->import;
+
+::ok( defined &lifejacket, 'simple import' );
+
+
+package Bar;
+my @imports = qw($seatbelt &Above stuff @wailing %left);
+Testing->import(@imports);
+
+::ok( (!grep { eval "!defined $_" } map({ /^\w/ ? "&$_" : $_ } @imports)),
+ 'import by symbols' );
+
+
+package Yar;
+my @tags = qw(:This :tray);
+Testing->import(@tags);
+
+::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
+ map { @$_ } @{$Testing::EXPORT_TAGS{@tags}}),
+ 'import by tags' );
+
+
+package Arrr;
+Testing->import(qw(!lifejacket));
+
+::ok( !defined &lifejacket, 'deny import by !' );
+
+
+package Mars;
+Testing->import('/e/');
+
+::ok( (!grep { eval "!defined $_" } map { /^\w/ ? "&$_" : $_ }
+ grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
+ 'import by regex');
+
+
+package Venus;
+Testing->import('!/e/');
+
+::ok( (!grep { eval "defined $_" } map { /^\w/ ? "&$_" : $_ }
+ grep { /e/ } @Testing::EXPORT, @Testing::EXPORT_OK),
+ 'deny import by regex');
+::ok( !defined &lifejacket, 'further denial' );
+
+
+package More::Testing;
+@ISA = qw(Exporter);
+$VERSION = 0;
+eval { More::Testing->require_version(0); 1 };
+::ok(!$@, 'require_version(0) and $VERSION = 0');
+
+
+package Yet::More::Testing;
+@ISA = qw(Exporter);
+$VERSION = 0;
+eval { Yet::More::Testing->require_version(10); 1 };
+::ok($@ !~ /\(undef\)/, 'require_version(10) and $VERSION = 0');
@INC = '../lib';
}
-BEGIN { $| = 1; print "1..17\n"; }
+BEGIN { $| = 1; print "1..19\n"; }
END {print "not ok 1\n" unless $loaded;}
import Time::HiRes 'usleep' if $have_usleep;
import Time::HiRes 'ualarm' if $have_ualarm;
+use Config;
+
sub skip {
map { print "ok $_ (skipped)\n" } @_;
}
$SIG{ALRM} = "tick";
while ($i)
{
- alarm(2.5);
+ alarm(0.3);
select (undef, undef, undef, 10);
- print "# Select returned! ", Time::HiRes::tv_interval ($r), "\n";
+ print "# Select returned! $i ", Time::HiRes::tv_interval ($r), "\n";
}
sub tick
{
- print "# Tick! ", Time::HiRes::tv_interval ($r), "\n";
$i--;
+ print "# Tick! $i ", Time::HiRes::tv_interval ($r), "\n";
}
$SIG{ALRM} = 'DEFAULT';
print "ok 17\n";
}
+unless (defined &Time::HiRes::setitimer
+ && defined &Time::HiRes::getitimer
+ && exists &Time::HiRes::ITIMER_VIRTUAL
+ && $Config{d_select}) {
+ for (18..19) {
+ print "ok $_ # Skip: no virtual interval timers\n";
+ }
+} else {
+ use Time::HiRes qw (setitimer getitimer ITIMER_VIRTUAL);
+
+ my $i = 3;
+ my $r = [Time::HiRes::gettimeofday];
+
+ $SIG{VTALRM} = sub {
+ $i ? $i-- : setitimer(ITIMER_VIRTUAL, 0);
+ print "# Tick! $i ", Time::HiRes::tv_interval($r), "\n";
+ };
+
+ print "# setitimer: ", join(" ", setitimer(ITIMER_VIRTUAL, 0.5, 0.4)), "\n";
+
+ # Assume interval timer granularity of 0.05 seconds. Too bold?
+ print "not " unless abs(getitimer(ITIMER_VIRTUAL) / 0.5) - 1 < 0.1;
+ print "ok 18\n";
+
+ print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
+
+ while (getitimer(ITIMER_VIRTUAL)) {
+ my $j; $j++ for 1..1000; # Can't be unbreakable, must test getitimer().
+ }
+
+ print "# getitimer: ", join(" ", getitimer(ITIMER_VIRTUAL)), "\n";
+
+ print "not " unless getitimer(ITIMER_VIRTUAL) == 0;
+ print "ok 19\n";
+
+ $SIG{VTALRM} = 'DEFAULT';
+}
+
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Scalar::Util qw(blessed);
+use vars qw($t $y $x);
+
+print "1..7\n";
+
+print "not " if blessed(1);
+print "ok 1\n";
+
+print "not " if blessed('A');
+print "ok 2\n";
+
+print "not " if blessed({});
+print "ok 3\n";
+
+print "not " if blessed([]);
+print "ok 4\n";
+
+$y = \$t;
+
+print "not " if blessed($y);
+print "ok 5\n";
+
+$x = bless [], "ABC";
+
+print "not " unless blessed($x);
+print "ok 6\n";
+
+print "not " unless blessed($x) eq 'ABC';
+print "ok 7\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+BEGIN {
+ require Scalar::Util;
+
+ if (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) {
+ print "1..0\n";
+ exit;
+ }
+}
+
+use Scalar::Util qw(dualvar);
+
+print "1..6\n";
+
+$var = dualvar 2.2,"string";
+
+print "not " unless $var == 2.2;
+print "ok 1\n";
+
+print "not " unless $var eq "string";
+print "ok 2\n";
+
+$var2 = $var;
+
+$var++;
+
+print "not " unless $var == 3.2;
+print "ok 3\n";
+
+print "not " unless $var ne "string";
+print "ok 4\n";
+
+print "not " unless $var2 == 2.2;
+print "ok 5\n";
+
+print "not " unless $var2 eq "string";
+print "ok 6\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(first);
+
+print "1..4\n";
+
+print "not " unless defined &first;
+print "ok 1\n";
+
+print "not " unless 9 == first { 8 == ($_ - 1) } 9,4,5,6;
+print "ok 2\n";
+
+print "not " if defined(first { 0 } 1,2,3,4);
+print "ok 3\n";
+
+print "not " if defined(first { 0 });
+print "ok 4\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(max);
+
+print "1..5\n";
+
+print "not " unless defined &max;
+print "ok 1\n";
+
+print "not " unless max(1) == 1;
+print "ok 2\n";
+
+print "not " unless max(1,2) == 2;
+print "ok 3\n";
+
+print "not " unless max(2,1) == 2;
+print "ok 4\n";
+
+my @a = map { rand() } 1 .. 20;
+my @b = sort { $a <=> $b } @a;
+print "not " unless max(@a) == $b[-1];
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(maxstr);
+
+print "1..5\n";
+
+print "not " unless defined &maxstr;
+print "ok 1\n";
+
+print "not " unless maxstr('a') eq 'a';
+print "ok 2\n";
+
+print "not " unless maxstr('a','b') eq 'b';
+print "ok 3\n";
+
+print "not " unless maxstr('B','A') eq 'B';
+print "ok 4\n";
+
+my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
+my @b = sort { $a cmp $b } @a;
+print "not " unless maxstr(@a) eq $b[-1];
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(min);
+
+print "1..5\n";
+
+print "not " unless defined &min;
+print "ok 1\n";
+
+print "not " unless min(9) == 9;
+print "ok 2\n";
+
+print "not " unless min(1,2) == 1;
+print "ok 3\n";
+
+print "not " unless min(2,1) == 1;
+print "ok 4\n";
+
+my @a = map { rand() } 1 .. 20;
+my @b = sort { $a <=> $b } @a;
+print "not " unless min(@a) == $b[0];
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(minstr);
+
+print "1..5\n";
+
+print "not " unless defined &minstr;
+print "ok 1\n";
+
+print "not " unless minstr('a') eq 'a';
+print "ok 2\n";
+
+print "not " unless minstr('a','b') eq 'a';
+print "ok 3\n";
+
+print "not " unless minstr('B','A') eq 'A';
+print "ok 4\n";
+
+my @a = map { pack("u", pack("C*",map { int(rand(256))} (0..int(rand(10) + 2)))) } 0 .. 20;
+my @b = sort { $a cmp $b } @a;
+print "not " unless minstr(@a) eq $b[0];
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Scalar::Util qw(readonly);
+
+print "1..9\n";
+
+print "not " unless readonly(1);
+print "ok 1\n";
+
+my $var = 2;
+
+print "not " if readonly($var);
+print "ok 2\n";
+
+print "not " unless $var == 2;
+print "ok 3\n";
+
+print "not " unless readonly("fred");
+print "ok 4\n";
+
+$var = "fred";
+
+print "not " if readonly($var);
+print "ok 5\n";
+
+print "not " unless $var eq "fred";
+print "ok 6\n";
+
+$var = \2;
+
+print "not " if readonly($var);
+print "ok 7\n";
+
+print "not " unless readonly($$var);
+print "ok 8\n";
+
+print "not " if readonly(*STDOUT);
+print "ok 9\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(reduce min);
+
+print "1..5\n";
+
+print "not " if defined reduce {};
+print "ok 1\n";
+
+print "not " unless 9 == reduce { $a / $b } 756,3,7,4;
+print "ok 2\n";
+
+print "not " unless 9 == reduce { $a / $b } 9;
+print "ok 3\n";
+
+@a = map { rand } 0 .. 20;
+print "not " unless min(@a) == reduce { $a < $b ? $a : $b } @a;
+print "ok 4\n";
+
+@a = map { pack("C", int(rand(256))) } 0 .. 20;
+print "not " unless join("",@a) eq reduce { $a . $b } @a;
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Scalar::Util qw(reftype);
+use vars qw($t $y $x *F);
+use Symbol qw(gensym);
+
+# Ensure we do not trigger and tied methods
+tie *F, 'MyTie';
+
+@test = (
+ [ undef, 1],
+ [ undef, 'A'],
+ [ HASH => {} ],
+ [ ARRAY => [] ],
+ [ SCALAR => \$t ],
+ [ REF => \(\$t) ],
+ [ GLOB => \*F ],
+ [ GLOB => gensym ],
+ [ CODE => sub {} ],
+# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN
+);
+
+print "1..", @test*4, "\n";
+
+my $i = 1;
+foreach $test (@test) {
+ my($type,$what) = @$test;
+ my $pack;
+ foreach $pack (undef,"ABC","0",undef) {
+ print "# $what\n";
+ my $res = reftype($what);
+ printf "# %s - %s\n", map { defined($_) ? $_ : 'undef' } $type,$res;
+ print "not " if $type ? $res ne $type : defined($res);
+ bless $what, $pack if $type && defined $pack;
+ print "ok ",$i++,"\n";
+ }
+}
+
+package MyTie;
+
+sub TIEHANDLE { bless {} }
+sub DESTROY {}
+
+sub AUTOLOAD {
+ warn "$AUTOLOAD called";
+ exit 1; # May be in an eval
+}
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use List::Util qw(sum);
+
+print "1..3\n";
+
+print "not " if defined sum;
+print "ok 1\n";
+
+print "not " unless sum(9) == 9;
+print "ok 2\n";
+
+print "not " unless sum(1,2,3,4) == 10;
+print "ok 3\n";
+
--- /dev/null
+#!./perl -T
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use lib qw(blib/lib blib/arch);
+use Scalar::Util qw(tainted);
+use Config;
+
+print "1..5\n";
+
+print "not " if tainted(1);
+print "ok 1\n";
+
+my $var = 2;
+
+print "not " if tainted($var);
+print "ok 2\n";
+
+my $key = (keys %ENV)[0];
+
+$var = $ENV{$key};
+
+print "not " unless tainted($var);
+print "ok 3\n";
+
+print "not " unless tainted($ENV{$key});
+print "ok 4\n";
+
+print "not " if @ARGV and not tainted($ARGV[0]);
+print "ok 5\n";
--- /dev/null
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+BEGIN {
+ $|=1;
+ require Scalar::Util;
+ if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
+ print("1..0\n");
+ exit;
+ }
+
+ $DEBUG = 0;
+
+ if ($DEBUG && eval { require Devel::Peek } ) {
+ Devel::Peek->import('Dump');
+ }
+ else {
+ *Dump = sub {};
+ }
+}
+
+use Scalar::Util qw(weaken isweak);
+print "1..17\n";
+
+######################### End of black magic.
+
+$cnt = 0;
+
+sub ok {
+ ++$cnt;
+ if($_[0]) { print "ok $cnt\n"; } else {print "not ok $cnt\n"; }
+}
+
+$| = 1;
+
+if(1) {
+
+my ($y,$z);
+
+#
+# Case 1: two references, one is weakened, the other is then undef'ed.
+#
+
+{
+ my $x = "foo";
+ $y = \$x;
+ $z = \$x;
+}
+print "# START:\n";
+Dump($y); Dump($z);
+
+ok( $y ne "" and $z ne "" );
+weaken($y);
+
+print "# WEAK:\n";
+Dump($y); Dump($z);
+
+ok( $y ne "" and $z ne "" );
+undef($z);
+
+print "# UNDZ:\n";
+Dump($y); Dump($z);
+
+ok( not (defined($y) and defined($z)) );
+undef($y);
+
+print "# UNDY:\n";
+Dump($y); Dump($z);
+
+ok( not (defined($y) and defined($z)) );
+
+print "# FIN:\n";
+Dump($y); Dump($z);
+
+# exit(0);
+
+# }
+# {
+
+#
+# Case 2: one reference, which is weakened
+#
+
+# kill 5,$$;
+
+print "# CASE 2:\n";
+
+{
+ my $x = "foo";
+ $y = \$x;
+}
+
+ok( $y ne "" );
+print "# BW: \n";
+Dump($y);
+weaken($y);
+print "# AW: \n";
+Dump($y);
+ok( not defined $y );
+
+print "# EXITBLOCK\n";
+}
+
+# exit(0);
+
+#
+# Case 3: a circular structure
+#
+
+# kill 5, $$;
+
+$flag = 0;
+{
+ my $y = bless {}, Dest;
+ Dump($y);
+ print "# 1: $y\n";
+ $y->{Self} = $y;
+ Dump($y);
+ print "# 2: $y\n";
+ $y->{Flag} = \$flag;
+ print "# 3: $y\n";
+ weaken($y->{Self});
+ print "# WKED\n";
+ ok( $y ne "" );
+ print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y,
+ " FLAG: ",\$y->{Flag},"\n";
+ print "# VPRINT\n";
+}
+print "# OUT $flag\n";
+ok( $flag == 1 );
+
+print "# AFTER\n";
+
+undef $flag;
+
+print "# FLAGU\n";
+
+#
+# Case 4: a more complicated circular structure
+#
+
+$flag = 0;
+{
+ my $y = bless {}, Dest;
+ my $x = bless {}, Dest;
+ $x->{Ref} = $y;
+ $y->{Ref} = $x;
+ $x->{Flag} = \$flag;
+ $y->{Flag} = \$flag;
+ weaken($x->{Ref});
+}
+ok( $flag == 2 );
+
+#
+# Case 5: deleting a weakref before the other one
+#
+
+{
+ my $x = "foo";
+ $y = \$x;
+ $z = \$x;
+}
+
+print "# CASE5\n";
+Dump($y);
+
+weaken($y);
+Dump($y);
+undef($y);
+
+ok( not defined $y);
+ok($z ne "");
+
+
+#
+# Case 6: test isweakref
+#
+
+$a = 5;
+ok(!isweak($a));
+$b = \$a;
+ok(!isweak($b));
+weaken($b);
+ok(isweak($b));
+$b = \$a;
+ok(!isweak($b));
+
+$x = {};
+weaken($x->{Y} = \$a);
+ok(isweak($x->{Y}));
+ok(!isweak($x->{Z}));
+
+
+package Dest;
+
+sub DESTROY {
+ print "# INCFLAG\n";
+ ${$_[0]{Flag}} ++;
+}
#
# -- .robin. <robin@kitsite.com> 2001-03-13
-print "1..39\n";
+print "1..41\n";
my $ok;
}
}
print ($ok ? "ok 39\n" : "not ok 39\n");
+
+
+### Test that loop control is dynamicly scoped.
+
+sub test_last_label { last TEST40 }
+
+TEST40: {
+ $ok = 1;
+ test_last_label();
+ $ok = 0;
+}
+print ($ok ? "ok 40\n" : "not ok 40\n");
+
+sub test_last { last }
+
+TEST41: {
+ $ok = 1;
+ test_last();
+ $ok = 0;
+}
+print ($ok ? "ok 41\n" : "not ok 41\n");
my $files = 0;
foreach my $file (@w_files) {
- next if /(~|\.orig|,v)$/;
+ next if $file =~ /(~|\.orig|,v)$/;
open F, "<$file" or die "Cannot open $file: $!\n" ;
my $line = 0;
/* Unicode support */
/*
-=for apidoc A|U8*|uvuni_to_utf8|U8 *d|UV uv
+=for apidoc A|U8 *|uvuni_to_utf8|U8 *d|UV uv
Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
The actual number of bytes in the UTF-8 character will be returned if
it is valid, otherwise 0.
-=cut */
+=cut
+*/
STRLEN
Perl_is_utf8_char(pTHX_ U8 *s)
{
Most code should use utf8_to_uvchr() rather than call this directly.
-=cut */
+=cut
+*/
UV
-Perl_utf8n_to_uvuni(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
+Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
{
UV uv = *s, ouv;
STRLEN len = 1;
}
/*
-=for apidoc A|U8* s|utf8_to_uvchr|STRLEN *retlen
+=for apidoc A|UV|utf8_to_uvchr|U8 *s|STRLEN *retlen
Returns the native character value of the first character in the string C<s>
which is assumed to be in UTF8 encoding; C<retlen> will be set to the
*/
UV
-Perl_utf8_to_uvchr(pTHX_ U8* s, STRLEN* retlen)
+Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
{
return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen, 0);
}
/*
-=for apidoc A|U8* s|utf8_to_uvuni|STRLEN *retlen
+=for apidoc A|UV|utf8_to_uvuni|U8 *s|STRLEN *retlen
Returns the Unicode code point of the first character in the string C<s>
which is assumed to be in UTF8 encoding; C<retlen> will be set to the
*/
UV
-Perl_utf8_to_uvuni(pTHX_ U8* s, STRLEN* retlen)
+Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
{
/* Call the low level routine asking for checks */
return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen, 0);
}
/*
-=for apidoc A|STRLEN|utf8_length|U8* s|U8 *e
+=for apidoc A|STRLEN|utf8_length|U8 *s|U8 *e
Return the length of the UTF-8 char encoded string C<s> in characters.
Stops at C<e> (inclusive). If C<e E<lt> s> or if the scan would end
*/
STRLEN
-Perl_utf8_length(pTHX_ U8* s, U8* e)
+Perl_utf8_length(pTHX_ U8 *s, U8 *e)
{
STRLEN len = 0;
WARNING: use only if you *know* that the pointers point inside the
same UTF-8 buffer.
-=cut */
+=cut
+*/
IV
Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
}
/*
-=for apidoc A|U8*|utf8_hop|U8 *s|I32 off
+=for apidoc A|U8 *|utf8_hop|U8 *s|I32 off
Return the UTF-8 pointer C<s> displaced by C<off> characters, either
forward or backward.
the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
on the first byte of character or just after the last byte of a character.
-=cut */
+=cut
+*/
U8 *
Perl_utf8_hop(pTHX_ U8 *s, I32 off)
*/
U8 *
-Perl_utf8_to_bytes(pTHX_ U8* s, STRLEN *len)
+Perl_utf8_to_bytes(pTHX_ U8 *s, STRLEN *len)
{
U8 *send;
U8 *d;
is unchanged. Do nothing if C<is_utf8> points to 0. Sets C<is_utf8> to
0 if C<s> is converted or contains all 7bit characters.
-=cut */
+=cut
+*/
U8 *
-Perl_bytes_from_utf8(pTHX_ U8* s, STRLEN *len, bool *is_utf8)
+Perl_bytes_from_utf8(pTHX_ U8 *s, STRLEN *len, bool *is_utf8)
{
U8 *d;
U8 *start = s;
*/
U8*
-Perl_bytes_to_utf8(pTHX_ U8* s, STRLEN *len)
+Perl_bytes_to_utf8(pTHX_ U8 *s, STRLEN *len)
{
U8 *send;
U8 *d;
/*
-=for apidoc A|U8*|uvchr_to_utf8|U8 *d|UV uv
+=for apidoc A|U8 *|uvchr_to_utf8|U8 *d|UV uv
Adds the UTF8 representation of the Native codepoint C<uv> to the end
of the string C<d>; C<d> should be have at least C<UTF8_MAXLEN+1> free
/*
-=for apidoc A|U8* s|utf8n_to_uvchr|STRLEN curlen, STRLEN *retlen, U32 flags
+=for apidoc A|UV|utf8n_to_uvchr|U8 *s|STRLEN curlen|STRLEN *retlen|U32 flags
Returns the native character value of the first character in the string C<s>
which is assumed to be in UTF8 encoding; C<retlen> will be set to the
*/
#undef Perl_utf8n_to_uvchr
UV
-Perl_utf8n_to_uvchr(pTHX_ U8* s, STRLEN curlen, STRLEN* retlen, U32 flags)
+Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
{
UV uv = Perl_utf8n_to_uvuni(aTHX_ s, curlen, retlen, flags);
return UNI_TO_NATIVE(uv);
=head1 SYNOPSIS
-dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [profile]
-
+dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-d>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [B<-G> <regexp> [B<-P>]] [B<-f> <regexp>] [profile]
+
dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
+dprofpp B<-G> <regexp> [B<-P>] [profile]
+
dprofpp B<-p script> [B<-Q>] [other opts]
dprofpp B<-V> [profile]
Sort alphabetically by subroutine names.
+=item B<-d>
+
+Reverse whatever sort is used
+
=item B<-A>
Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
Ignore subroutines except C<subroutine> and whatever is called from it.
+=item B<-G> <regexp>
+
+Aggregate "Group" all calls matching the pattern together.
+For example this can be used to group all calls of a set of packages
+
+ -G "(package1::)|(package2::)|(package3::)"
+
+or to group subroutines by name:
+
+ -G "getNum"
+
+=item B<-P>
+
+Used with -G to aggregate "Pull" together all calls that did not match -G.
+
+=item B<-f> <regexp>
+
+Filter all calls matching the pattern.
+
=back
=head1 ENVIRONMENT
use Config '%Config';
Setup: {
- my $options = 'O:g:lzaAvuTtqrRsUFEIp:QVS';
+ my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVS';
$Monfile = 'tmon.out';
if( exists $ENV{DPROFPP_OPTS} ){
# -g subr count only those who are SUBR or called from SUBR
# -S Create statistics for all the depths
+# -G Group all calls matching the pattern together.
+# -P Used with -G to pull all other calls together.
+# -f Filter all calls mathcing the pattern.
+# -d Reverse sort
+
if( defined $opt_V ){
my $fh = 'main::fh';
print "$0 version: $VERSION\n";
$sort = 'by_calls' if defined $opt_l;
$sort = 'by_alpha' if defined $opt_a;
$sort = 'by_avgcpu' if defined $opt_v;
+
+ if(defined $opt_d){
+ $sort = "r".$sort;
+ }
$incl_excl = 'Exclusive';
$incl_excl = 'Inclusive' if defined $opt_I;
$whichtime = 'User+System';
parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
+ #filter calls
+ if( $opt_f ){
+ for(my $i = 0;$i < @$idkeys - 2;){
+ $key = $$idkeys[$i];
+ if($key =~ /$opt_f/){
+ splice(@$idkeys, $i, 1);
+ $runtime -= $$times{$key};
+ next;
+ }
+ $i++;
+ }
+ }
+
+ if( $opt_G ){
+ group($names, $calls, $times, $ctimes, $idkeys );
+ }
+
settime( \$runtime, $hz ) unless $opt_g;
exit(0) if $opt_T || $opt_t;
$deep_times);
}
+sub group{
+ my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
+ print "Option G Grouping: [$opt_G]\n";
+ # create entries to store grouping
+ $$names{$opt_G} = $opt_G;
+ $$calls{$opt_G} = 0;
+ $$times{$opt_G} = 0;
+ $$ctimes{$opt_G} = 0;
+ $$idkeys[@$idkeys] = $opt_G;
+ # Sum calls for the grouping
+
+ my $other = "other";
+ if($opt_P){
+ $$names{$other} = $other;
+ $$calls{$other} = 0;
+ $$times{$other} = 0;
+ $$ctimes{$other} = 0;
+ $$idkeys[@$idkeys] = $other;
+ }
+
+ for(my $i = 0;$i < @$idkeys - 2;){
+ $key = $$idkeys[$i];
+ if($key =~ /$opt_G/){
+ $$calls{$opt_G} += $$calls{$key};
+ $$times{$opt_G} += $$times{$key};
+ $$ctimes{$opt_G} += $$ctimes{$key};
+ splice(@$idkeys, $i, 1);
+ next;
+ }else{
+ if($opt_P){
+ $$calls{$other} += $$calls{$key};
+ $$times{$other} += $$times{$key};
+ $$ctimes{$other} += $$ctimes{$key};
+ splice(@$idkeys, $i, 1);
+ next;
+ }
+ }
+ $i++;
+ }
+ print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
+ "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
+ "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
+}
# Sets $runtime to user, system, real, or user+system time. The
# result is given in seconds.
pop @$curdeep_times;
}
+
sub parsestack {
my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
my( $dir, $name );
if( ! defined $x ){
die "Garbled profile, missing an enter time stamp";
}
- if( $x->[0] ne $name ){
+ if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
if ($x->[0] =~ /::AUTOLOAD$/) {
if ($opt_A) {
$name = $x->[0];
sub by_calls { $calls->{$b} <=> $calls->{$a} }
sub by_alpha { $names->{$a} cmp $names->{$b} }
sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
+# Reversed
+sub rby_time { $times->{$a} <=> $times->{$b} }
+sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
+sub rby_calls { $calls->{$a} <=> $calls->{$b} }
+sub rby_alpha { $names->{$b} cmp $names->{$a} }
+sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
format CSTAT_top =
close OUT or die "Can't close $file: $!";
chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+
projects / p5sagit/p5-mst-13.2.git / commitdiff