Change 19991 by [EMAIL PROTECTED] on 2003/07/04 13:54:33
Integrate:
[ 19976]
Subject: [PATCH: [EMAIL PROTECTED] switch vmspipe.com over to using local
symbols instead of global
From: [EMAIL PROTECTED]
Date: Thu, 3 Jul 2003 23:59:51 -0400
Message-ID: <[EMAIL PROTECTED]>
[ 19977]
$0 is pain.
[ 19979]
Remove PL_earlytaint since the hash seed code
can be delayed until perl_parse().
[ 19980]
line_t is U32, not I32.
[ 19981]
AUTHORS updates.
[ 19982]
No energy now to figure out what is wrong with $0
(or ps) in Tru64. The test works fine when run from
command line.
[ 19984]
Upgrade to CGI.pm 2.97.
[ 19985]
Upgrade to CPAN 1.71.
[ 19986]
Upgrade to Digest::MD5 2.24, with few extra tweaks:
(1) make the PATCHLEVEL logic as it is with List::Util
(more portable to older Perls)
(2) regen the MD5 checksums with ...
(3) ... the Mac OS Classic checksums generated via MacRoman
(just a guess)
(4) Keep the core Makefile.PL.
[ 19987]
Upgrade to Locale::Maketext 1.06.
[ 19988]
Upgrade to Net::Ping 2.31.
[ 19989]
Upgrade to Text::Balanced 1.94.
[ 19990]
Upgrade to PodParser 1.23; but do not update
t/pod/find.t or t/pod/testp2pt.pl since the
first one does not work at all under core,
and the second change would drop MacOS Classic
portability tweaks introduced by change #18669.
Affected files ...
... //depot/maint-5.8/perl/AUTHORS#6 integrate
... //depot/maint-5.8/perl/MANIFEST#67 integrate
... //depot/maint-5.8/perl/bytecode.pl#6 integrate
... //depot/maint-5.8/perl/dosish.h#9 integrate
... //depot/maint-5.8/perl/embedvar.h#22 integrate
... //depot/maint-5.8/perl/epoc/epocish.h#5 integrate
... //depot/maint-5.8/perl/ext/Digest/MD5/Changes#5 integrate
... //depot/maint-5.8/perl/ext/Digest/MD5/MD5.pm#5 integrate
... //depot/maint-5.8/perl/ext/Digest/MD5/MD5.xs#5 integrate
... //depot/maint-5.8/perl/ext/Digest/MD5/t/files.t#7 integrate
... //depot/maint-5.8/perl/ext/threads/t/join.t#13 integrate
... //depot/maint-5.8/perl/lib/CGI.pm#6 integrate
... //depot/maint-5.8/perl/lib/CGI/Carp.pm#4 integrate
... //depot/maint-5.8/perl/lib/CPAN.pm#4 integrate
... //depot/maint-5.8/perl/lib/Locale/Maketext.pm#4 integrate
... //depot/maint-5.8/perl/lib/Locale/Maketext/ChangeLog#4 integrate
... //depot/maint-5.8/perl/lib/Locale/Maketext/Guts.pm#1 branch
... //depot/maint-5.8/perl/lib/Locale/Maketext/GutsLoader.pm#1 branch
... //depot/maint-5.8/perl/lib/Locale/Maketext/t/90utf8.t#1 branch
... //depot/maint-5.8/perl/lib/Net/Ping.pm#8 integrate
... //depot/maint-5.8/perl/lib/Net/Ping/Changes#4 integrate
... //depot/maint-5.8/perl/lib/Net/Ping/t/250_ping_hires.t#3 integrate
... //depot/maint-5.8/perl/lib/Net/Ping/t/300_ping_stream.t#3 integrate
... //depot/maint-5.8/perl/lib/Net/Ping/t/450_service.t#6 integrate
... //depot/maint-5.8/perl/lib/Pod/Find.pm#2 integrate
... //depot/maint-5.8/perl/lib/Pod/Usage.pm#5 integrate
... //depot/maint-5.8/perl/lib/Text/Balanced.pm#2 integrate
... //depot/maint-5.8/perl/lib/Text/Balanced/Changes#2 integrate
... //depot/maint-5.8/perl/lib/Text/Balanced/README#2 integrate
... //depot/maint-5.8/perl/lib/Text/Balanced/t/extcbk.t#2 integrate
... //depot/maint-5.8/perl/lib/Text/Balanced/t/extvar.t#2 integrate
... //depot/maint-5.8/perl/lib/Text/Balanced/t/gentag.t#2 integrate
... //depot/maint-5.8/perl/mpeix/mpeixish.h#4 integrate
... //depot/maint-5.8/perl/os2/os2ish.h#6 integrate
... //depot/maint-5.8/perl/perl.c#39 integrate
... //depot/maint-5.8/perl/perl.h#37 integrate
... //depot/maint-5.8/perl/perlapi.h#20 integrate
... //depot/maint-5.8/perl/perlvars.h#10 integrate
... //depot/maint-5.8/perl/plan9/plan9ish.h#5 integrate
... //depot/maint-5.8/perl/unixish.h#8 integrate
... //depot/maint-5.8/perl/vms/vms.c#11 integrate
... //depot/maint-5.8/perl/vms/vmsish.h#6 integrate
... //depot/maint-5.8/perl/vms/vmspipe.com#2 integrate
Differences ...
==== //depot/maint-5.8/perl/AUTHORS#6 (text) ====
Index: perl/AUTHORS
--- perl/AUTHORS#5~19970~ Thu Jul 3 14:28:08 2003
+++ perl/AUTHORS Fri Jul 4 06:54:33 2003
@@ -148,7 +148,7 @@
Daniel Lieberman <[EMAIL PROTECTED]>
Daniel Mui�o <[EMAIL PROTECTED]>
Daniel P. Berrange <[EMAIL PROTECTED]>
-Daniel S. Lewart <[EMAIL PROTECTED]>
+Daniel S. Lewart <[EMAIL PROTECTED]>
Daniel Yacob <[EMAIL PROTECTED]>
Danny R. Faught <[EMAIL PROTECTED]>
Danny Sadinoff <[EMAIL PROTECTED]>
@@ -701,7 +701,7 @@
Tye McQueen <[EMAIL PROTECTED]>
Ulrich Kunitz <[EMAIL PROTECTED]>
Ulrich Pfeifer <[EMAIL PROTECTED]>
-Vadim Konovalov <[EMAIL PROTECTED]>
+Vadim Konovalov <[EMAIL PROTECTED]>
Valeriy E. Ushakov <[EMAIL PROTECTED]>
Ville Skytt� <[EMAIL PROTECTED]>
Vishal Bhatia <[EMAIL PROTECTED]>
==== //depot/maint-5.8/perl/MANIFEST#67 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#66~19970~ Thu Jul 3 14:28:08 2003
+++ perl/MANIFEST Fri Jul 4 06:54:33 2003
@@ -1276,11 +1276,14 @@
lib/Locale/Maketext.pm Locale::Maketext
lib/Locale/Maketext.pod Locale::Maketext documentation
lib/Locale/Maketext/ChangeLog Locale::Maketext
+lib/Locale/Maketext/Guts.pm Locale::Maketext
+lib/Locale/Maketext/GutsLoader.pm Locale::Maketext
lib/Locale/Maketext/README Locale::Maketext
lib/Locale/Maketext/t/00about.t See if Locale::Maketext works
lib/Locale/Maketext/t/01make.t See if Locale::Maketext works
lib/Locale/Maketext/t/02get.t See if Locale::Maketext works
lib/Locale/Maketext/t/03http.t See if Locale::Maketext works
+lib/Locale/Maketext/t/90utf8.t Locale::Maketext
lib/Locale/Maketext/TPJ13.pod Locale::Maketext documentation article
lib/Locale/Script.pm Locale::Codes
lib/Locale/Script.pod Locale::Codes documentation
==== //depot/maint-5.8/perl/bytecode.pl#6 (text) ====
Index: perl/bytecode.pl
--- perl/bytecode.pl#5~19951~ Thu Jul 3 01:47:35 2003
+++ perl/bytecode.pl Fri Jul 4 06:54:33 2003
@@ -4,10 +4,10 @@
}
use strict;
my %alias_to = (
- U32 => [qw(PADOFFSET STRLEN)],
- I32 => [qw(SSize_t line_t long)],
+ U32 => [qw(PADOFFSET STRLEN line_t)],
+ I32 => [qw(SSize_t long)],
U16 => [qw(OPCODE short)],
- U8 => [qw(char)],
+ U8 => [qw(char)],
);
my @optype= qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
==== //depot/maint-5.8/perl/dosish.h#9 (text) ====
Index: perl/dosish.h
--- perl/dosish.h#8~19891~ Mon Jun 30 02:39:29 2003
+++ perl/dosish.h Fri Jul 4 06:54:33 2003
@@ -16,7 +16,7 @@
#ifdef DJGPP
# define BIT_BUCKET "nul"
# define OP_BINARY O_BINARY
-# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
Perl_DJGPP_init(c,v)
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_DJGPP_init(c,v)
# define init_os_extras Perl_init_os_extras
# include <signal.h>
# define HAS_UTIME
@@ -32,15 +32,15 @@
# define PERL_FS_VER_FMT "%d_%d_%d"
#else /* DJGPP */
# ifdef WIN32
-# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
Perl_win32_init(c,v)
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_win32_init(c,v)
# define PERL_SYS_TERM() Perl_win32_term()
# define BIT_BUCKET "nul"
# else
# ifdef NETWARE
-# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
Perl_nw5_init(c,v)
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) Perl_nw5_init(c,v)
# define BIT_BUCKET "nwnul"
# else
-# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v)
# define BIT_BUCKET "\\dev\\nul" /* "wanna be like, umm, Newlined, or somethin?"
*/
# endif /* NETWARE */
# endif
==== //depot/maint-5.8/perl/embedvar.h#22 (text+w) ====
Index: perl/embedvar.h
--- perl/embedvar.h#21~19891~ Mon Jun 30 02:39:29 2003
+++ perl/embedvar.h Fri Jul 4 06:54:33 2003
@@ -1421,7 +1421,6 @@
#define PL_curinterp (PL_Vars.Gcurinterp)
#define PL_do_undump (PL_Vars.Gdo_undump)
#define PL_dollarzero_mutex (PL_Vars.Gdollarzero_mutex)
-#define PL_earlytaint (PL_Vars.Gearlytaint)
#define PL_hexdigit (PL_Vars.Ghexdigit)
#define PL_malloc_mutex (PL_Vars.Gmalloc_mutex)
#define PL_op_mutex (PL_Vars.Gop_mutex)
@@ -1436,7 +1435,6 @@
#define PL_Gcurinterp PL_curinterp
#define PL_Gdo_undump PL_do_undump
#define PL_Gdollarzero_mutex PL_dollarzero_mutex
-#define PL_Gearlytaint PL_earlytaint
#define PL_Ghexdigit PL_hexdigit
#define PL_Gmalloc_mutex PL_malloc_mutex
#define PL_Gop_mutex PL_op_mutex
==== //depot/maint-5.8/perl/epoc/epocish.h#5 (text) ====
Index: perl/epoc/epocish.h
--- perl/epoc/epocish.h#4~19891~ Mon Jun 30 02:39:29 2003
+++ perl/epoc/epocish.h Fri Jul 4 06:54:33 2003
@@ -108,7 +108,7 @@
/* epocemx setenv bug workaround */
#ifndef PERL_SYS_INIT
-# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
putenv(".dummy=foo"); putenv(".dummy"); MALLOC_INIT
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) putenv(".dummy=foo");
putenv(".dummy"); MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
==== //depot/maint-5.8/perl/ext/Digest/MD5/Changes#5 (text) ====
Index: perl/ext/Digest/MD5/Changes
--- perl/ext/Digest/MD5/Changes#4~18743~ Tue Feb 18 06:12:11 2003
+++ perl/ext/Digest/MD5/Changes Fri Jul 4 06:54:33 2003
@@ -1,3 +1,13 @@
+2003-03-09 Gisle Aas <[EMAIL PROTECTED]>
+
+ Release 2.24
+
+ Don't let the $^W test get confused by lexical warnings.
+
+ Sync up with bleadperl; safer patchlevel include.
+
+
+
2003-01-18 Gisle Aas <[EMAIL PROTECTED]>
Release 2.23
==== //depot/maint-5.8/perl/ext/Digest/MD5/MD5.pm#5 (text) ====
Index: perl/ext/Digest/MD5/MD5.pm
--- perl/ext/Digest/MD5/MD5.pm#4~18743~ Tue Feb 18 06:12:11 2003
+++ perl/ext/Digest/MD5/MD5.pm Fri Jul 4 06:54:33 2003
@@ -3,7 +3,7 @@
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
-$VERSION = '2.23'; # $Date: 2003/01/19 04:42:15 $
+$VERSION = '2.24'; # $Date: 2003/03/09 15:23:10 $
require Exporter;
*import = \&Exporter::import;
==== //depot/maint-5.8/perl/ext/Digest/MD5/MD5.xs#5 (text) ====
Index: perl/ext/Digest/MD5/MD5.xs
--- perl/ext/Digest/MD5/MD5.xs#4~18743~ Tue Feb 18 06:12:11 2003
+++ perl/ext/Digest/MD5/MD5.xs Fri Jul 4 06:54:33 2003
@@ -1,4 +1,4 @@
-/* $Id: MD5.xs,v 1.35 2003/01/05 00:54:17 gisle Exp $ */
+/* $Id: MD5.xs,v 1.37 2003/03/09 15:20:43 gisle Exp $ */
/*
* This library is free software; you can redistribute it and/or
@@ -44,17 +44,26 @@
}
#endif
-#ifndef PATCHLEVEL
+#ifndef PERL_VERSION
# include <patchlevel.h>
# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
# include <could_not_find_Perl_patchlevel.h>
# endif
+# define PERL_REVISION 5
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
#endif
#if PATCHLEVEL <= 4 && !defined(PL_dowarn)
#define PL_dowarn dowarn
#endif
+#ifdef G_WARN_ON
+ #define DOWARN (PL_dowarn & G_WARN_ON)
+#else
+ #define DOWARN PL_dowarn
+#endif
+
#ifdef SvPVbyte
#if PERL_REVISION == 5 && PERL_VERSION < 7
/* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
@@ -664,7 +673,7 @@
PPCODE:
MD5Init(&ctx);
- if (PL_dowarn) {
+ if (DOWARN) {
char *msg = 0;
if (items == 1) {
if (SvROK(ST(0))) {
==== //depot/maint-5.8/perl/ext/Digest/MD5/t/files.t#7 (text) ====
Index: perl/ext/Digest/MD5/t/files.t
--- perl/ext/Digest/MD5/t/files.t#6~18946~ Tue Mar 11 22:13:00 2003
+++ perl/ext/Digest/MD5/t/files.t Fri Jul 4 06:54:33 2003
@@ -20,27 +20,27 @@
my $EXPECT;
if (ord "A" == 193) { # EBCDIC
$EXPECT = <<EOT;
-aab6fda26844b46ca878f46394c52bb2 Changes
+4ee4091bda2bb74fb2416c2fdb0c4d4a Changes
0565ec21b15c0f23f4c51fb327c8926d README
-5d2a638a7323f5bd5b5c120c9330b99d MD5.pm
-de2c149900efee0fbb39ad87dea68a43 MD5.xs
+b00637894d2bd395ffda2fa84adefdfd MD5.pm
+cd20b0f03df85e12d32c112311cba82f MD5.xs
276da0aa4e9a08b7fe09430c9c5690aa rfc1321.txt
EOT
} elsif ("\n" eq "\015") { # MacOS
$EXPECT = <<EOT;
-48ce3d9c310bd3173f6fe0a336f349cf Changes
-53a0461b093f6c9d3e03d31f7133e62c README
-7dcff59ab5cb7ad4998fb518047b2e59 MD5.pm
-10542966f7609cb13816dc6a18527775 MD5.xs
+0b95218ddeca76d2ccd6362b8e7c05a4 Changes
+6c950a0211a5a28f023bb482037698cd README
+f854bd4984ad0e73c483a49a28893c74 MD5.pm
+f62fea72c62d50d14ebd825eb8bbb8b4 MD5.xs
754b9db19f79dbc4992f7166eb0f37ce rfc1321.txt
EOT
} else {
# This is the output of: 'md5sum Changes README MD5.pm MD5.xs rfc1321.txt'
$EXPECT = <<EOT;
-d286d6c6a61e44e88d1deba9954ce37a Changes
+d7b1bf11283114d1b765f433a5d7b447 Changes
6c950a0211a5a28f023bb482037698cd README
-d31c9aefa1a9e40beda9fff1e1d9c02d MD5.pm
-df178436ead9d354d63089fa0e01af27 MD5.xs
+f854bd4984ad0e73c483a49a28893c74 MD5.pm
+f62fea72c62d50d14ebd825eb8bbb8b4 MD5.xs
754b9db19f79dbc4992f7166eb0f37ce rfc1321.txt
EOT
}
@@ -61,7 +61,7 @@
for (split /^/, $EXPECT) {
my($md5hex, $file) = split ' ';
my $base = $file;
- print "# $base\n";
+# print "# $base\n";
if ($ENV{PERL_CORE}) {
if ($file eq 'rfc1321.txt') { # Don't have it in core.
print "ok ", ++$testno, " # Skip: PERL_CORE\n";
@@ -88,7 +88,9 @@
next;
}
if ($ENV{MAC_MD5SUM}) {
+ require Encode;
my $data = cat_file($file);
+ Encode::from_to($data, 'latin1', 'MacRoman');
print md5_hex($data), " $base\n";
next;
}
==== //depot/maint-5.8/perl/ext/threads/t/join.t#13 (text) ====
Index: perl/ext/threads/t/join.t
--- perl/ext/threads/t/join.t#12~19891~ Mon Jun 30 02:39:29 2003
+++ perl/ext/threads/t/join.t Fri Jul 4 06:54:33 2003
@@ -92,7 +92,7 @@
}
# We parse ps output so this is OS-dependent.
-if ($^O =~ /^(linux|dec_osf)$/) {
+if ($^O eq 'linux') {
# First modify $0 in a subthread.
print "# mainthread: \$0 = $0\n";
threads->new( sub {
@@ -108,7 +108,7 @@
print "# [$_]\n";
if (/^\S+\s+$$\s/) {
$sawpid++;
- if (/\sfoobar$/) {
+ if (/\sfoobar\s*$/) { # Linux 2.2 leaves extra trailing spaces.
$sawexe++;
}
last;
==== //depot/maint-5.8/perl/lib/CGI.pm#6 (text) ====
Index: perl/lib/CGI.pm
--- perl/lib/CGI.pm#5~19919~ Tue Jul 1 14:28:15 2003
+++ perl/lib/CGI.pm Fri Jul 4 06:54:33 2003
@@ -18,8 +18,8 @@
# The most recent version and complete docs are available at:
# http://stein.cshl.org/WWW/software/CGI/
-$CGI::revision = '$Id: CGI.pm,v 1.112 2003/04/28 13:35:56 lstein Exp $';
-$CGI::VERSION='2.93';
+$CGI::revision = '$Id: CGI.pm,v 1.125 2003/06/16 18:54:19 lstein Exp $';
+$CGI::VERSION='2.97';
# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
@@ -221,7 +221,7 @@
base body Link nextid title meta kbd start_html end_html
input Select option comment charset escapeHTML/],
':html3'=>[qw/div table caption th td TR Tr sup Sub strike applet
Param
- embed basefont style span layer ilayer font frameset frame
script small big/],
+ embed basefont style span layer ilayer font frameset frame
script small big Area Map/],
':html4'=>[qw/abbr acronym bdo col colgroup del fieldset iframe
ins label legend noframes noscript object optgroup Q
thead tbody tfoot/],
@@ -238,7 +238,6 @@
remote_user user_name header redirect import_names put
Delete Delete_all url_param cgi_error/],
':ssl' => [qw/https/],
- ':imagemap' => [qw/Area Map/],
':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam
Vars/],
':html' => [qw/:html2 :html3 :html4 :netscape/],
':standard' => [qw/:html2 :html3 :html4 :form :cgi/],
@@ -445,6 +444,12 @@
# avoid unreasonably large postings
if (($POST_MAX > 0) && ($content_length > $POST_MAX)) {
+ # quietly read and discard the post
+ my $buffer;
+ my $max = $content_length;
+ while ($max > 0 && (my $bytes = read(STDIN,$buffer,$max < 10000 ? $max :
10000))) {
+ $max -= $bytes;
+ }
$self->cgi_error("413 Request entity too large");
last METHOD;
}
@@ -529,7 +534,8 @@
# YL: Begin Change for XML handler 10/19/2001
if ($meth eq 'POST'
&& defined($ENV{'CONTENT_TYPE'})
- && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded| ) {
+ && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
+ && $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
my($param) = 'POSTDATA' ;
$self->add_parameter($param) ;
push (@{$self->{$param}},$query_string);
@@ -662,7 +668,7 @@
my([EMAIL PROTECTED]) = make_attributes(\$a,\$q->{'escape'});
\$attr = " [EMAIL PROTECTED]" if [EMAIL PROTECTED];
} else {
- unshift [EMAIL PROTECTED],\$a;
+ unshift [EMAIL PROTECTED],\$a if defined \$a;
}
);
if ($tagname=~/start_(\w+)/i) {
@@ -671,8 +677,7 @@
$func .= qq! return "<\L/$1\E>"; } !;
} else {
$func .= qq#
-\# return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless
[EMAIL PROTECTED];
- return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless
[EMAIL PROTECTED] && defined(\$rest[0]);
+ return \$XHTML ? "\L<$tagname\E\$attr />" : "\L<$tagname\E\$attr>" unless
[EMAIL PROTECTED];
my(\$tag,\$untag) = ("\L<$tagname\E\$attr>","\L</$tagname>\E");
my [EMAIL PROTECTED] = map { "\$tag\$_\$untag" }
(ref(\$rest[0]) eq 'ARRAY') ? [EMAIL PROTECTED] :
"[EMAIL PROTECTED]";
@@ -839,8 +844,8 @@
####
sub delete {
my($self,@p) = self_or_default(@_);
- my($name) = rearrange([NAME],@p);
- my @to_delete = ref($name) eq 'ARRAY' ? @$name : ($name);
+ my(@names) = rearrange([NAME],@p);
+ my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
my %to_delete;
foreach my $name (@to_delete)
{
@@ -1051,7 +1056,7 @@
'delete_all' => <<'EOF',
sub delete_all {
my($self) = self_or_default(@_);
- my @param = $self->param;
+ my @param = $self->param();
$self->delete(@param);
}
EOF
@@ -1136,12 +1141,12 @@
push(@result,"<ul>");
foreach $param ($self->param) {
my($name)=$self->escapeHTML($param);
- push(@result,"<li><strong>$param</strong>");
+ push(@result,"<li><strong>$param</strong></li>");
push(@result,"<ul>");
foreach $value ($self->param($param)) {
$value = $self->escapeHTML($value);
- $value =~ s/\n/<br>\n/g;
- push(@result,"<li>$value");
+ $value =~ s/\n/<br />\n/g;
+ push(@result,"<li>$value</li>");
}
push(@result,"</ul>");
}
@@ -1504,32 +1509,35 @@
my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
if (ref($style)) {
- my($src,$code,$verbatim,$stype,@other) =
+ my($src,$code,$verbatim,$stype,$foo,@other) =
rearrange([SRC,CODE,VERBATIM,TYPE],
- '-foo'=>'bar', # a trick to allow the '-' to be omitted
+ '-foo'=>'bar', # trick to allow dash to be omitted
ref($style) eq 'ARRAY' ? @$style : %$style);
- $type = $stype if $stype;
-
+ $type = $stype if $stype;
+ my $other = @other ? join ' ',@other : '';
+
if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array
reference
{ # If it is, push a LINK tag for each one
foreach $src (@$src)
{
- push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
- : qq(<link rel="stylesheet" type="$type" href="$src">))
if $src;
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src"
$other/>)
+ : qq(<link rel="stylesheet" type="$type"
href="$src"$other>)) if $src;
}
}
else
{ # Otherwise, push the single -src, if it exists.
- push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src" />)
- : qq(<link rel="stylesheet" type="$type" href="$src">)
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src"
$other/>)
+ : qq(<link rel="stylesheet" type="$type"
href="$src"$other>)
) if $src;
}
if ($verbatim) {
push(@result, "<style type=\"text/css\">\n$verbatim\n</style>");
- }
+ }
push(@result,style({'type'=>$type},"$cdata_start\n$code\n$cdata_end")) if $code;
} else {
- push(@result,style({'type'=>$type},"$cdata_start\n$style\n$cdata_end"));
+ my $src = $style;
+ push(@result,$XHTML ? qq(<link rel="stylesheet" type="$type" href="$src"
$other/>)
+ : qq(<link rel="stylesheet" type="$type"
href="$src"$other>));
}
@result;
}
@@ -1632,6 +1640,7 @@
$action .= "?$ENV{QUERY_STRING}";
}
}
+ $action =~ s/\"/%22/g; # fix cross-site scripting bug reported by obscure
$action = qq(action="$action");
my($other) = @other ? " @other" : '';
$self->{'.parametersToAdd'}={};
@@ -1875,7 +1884,6 @@
sub reset {
my($self,@p) = self_or_default(@_);
my($label,$value,@other) = rearrange(['NAME',['VALUE','LABEL']],@p);
- warn "label = $label, value = $value";
$label=$self->escapeHTML($label);
$value=$self->escapeHTML($value,1);
my ($name) = ' name=".reset"';
@@ -6460,6 +6468,26 @@
@import url("/server-common/css/main.css");
</style>
+Any additional arguments passed in the -style value will be
+incorporated into the <link> tag. For example:
+
+ start_html(-style=>{-src=>['/styles/print.css','/styles/layout.css'],
+ -media => 'all'});
+
+This will give:
+
+ <link rel="stylesheet" type="text/css" href="/styles/print.css" media="all"/>
+ <link rel="stylesheet" type="text/css" href="/styles/layout.css" media="all"/>
+
+<p>
+
+To make more complicated <link> tags, use the Link() function
+and pass it to start_html() in the -head argument, as in:
+
+ @h = (Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/ss.css',-media=>'all'}),
+
Link({-rel=>'stylesheet',-type=>'text/css',-src=>'/ss/fred.css',-media=>'paper'}));
+ print start_html({-head=>[EMAIL PROTECTED])
+
=head1 DEBUGGING
If you are running the script from the command line or in the perl
@@ -6595,7 +6623,6 @@
if the former is unavailable.
=item B<script_name()>
-
Return the script name as a partial URL, for self-refering
scripts.
==== //depot/maint-5.8/perl/lib/CGI/Carp.pm#4 (text) ====
Index: perl/lib/CGI/Carp.pm
--- perl/lib/CGI/Carp.pm#3~19682~ Tue Jun 3 22:22:46 2003
+++ perl/lib/CGI/Carp.pm Fri Jul 4 06:54:33 2003
@@ -239,6 +239,10 @@
1.24 Patch from Scott Gifford ([EMAIL PROTECTED]): Add support
for overriding program name.
+1.26 Replaced CORE::GLOBAL::die with the evil $SIG{__DIE__} because the
+ former isn't working in some people's hands. There is no such thing
+ as reliable exception handling in Perl.
+
=head1 AUTHORS
Copyright 1995-2002, Lincoln D. Stein. All rights reserved.
@@ -262,18 +266,23 @@
require 5.000;
use Exporter;
#use Carp;
-BEGIN { require Carp; }
+BEGIN {
+ require Carp;
+ *CORE::GLOBAL::die = \&CGI::Carp::die;
+}
+
use File::Spec;
@ISA = qw(Exporter);
@EXPORT = qw(confess croak carp);
[EMAIL PROTECTED] = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message
set_progname cluck ^name=);
[EMAIL PROTECTED] = qw(carpout fatalsToBrowser warningsToBrowser wrap set_message
set_progname cluck ^name= die);
$main::SIG{__WARN__}=\&CGI::Carp::warn;
-*CORE::GLOBAL::die = \&CGI::Carp::die;
-$CGI::Carp::VERSION = '1.25';
+
+$CGI::Carp::VERSION = '1.26';
$CGI::Carp::CUSTOM_MSG = undef;
+
# fancy import routine detects and handles 'errorWrap' specially.
sub import {
my $pkg = shift;
@@ -294,6 +303,8 @@
$Exporter::ExportLevel = 1;
Exporter::import($pkg,keys %routines);
$Exporter::ExportLevel = $oldlevel;
+ $main::SIG{__DIE__} =\&CGI::Carp::die if $routines{'fatalsToBrowser'};
+# $pkg->export('CORE::GLOBAL','die');
}
# These are the originals
@@ -442,7 +453,7 @@
$outer_message = $CUSTOM_MSG;
}
}
-
+
my $mess = <<END;
<h1>Software error:</h1>
<pre>$msg</pre>
@@ -451,7 +462,7 @@
</p>
END
;
-
+
if ($mod_perl) {
require mod_perl;
if ($mod_perl::VERSION >= 1.99) {
@@ -472,15 +483,11 @@
$r->print($mess);
$mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
} else {
- # MSIE browsers don't show the $mess when sent
- # a custom 500 response.
+ # MSIE won't display a custom 500 response unless it is >512 bytes!
if ($ENV{HTTP_USER_AGENT} =~ /MSIE/) {
- $r->send_http_header('text/html');
- $r->print($mess);
- $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
- } else {
- $r->custom_response(500,$mess);
+ $mess = "<!-- " . (' ' x 513) . " -->\n$mess";
}
+ $r->custom_response(500,$mess);
}
} else {
print STDOUT $mess;
==== //depot/maint-5.8/perl/lib/CPAN.pm#4 (text) ====
Index: perl/lib/CPAN.pm
--- perl/lib/CPAN.pm#3~19576~ Tue May 20 13:05:45 2003
+++ perl/lib/CPAN.pm Fri Jul 4 06:54:33 2003
@@ -1,11 +1,11 @@
# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
package CPAN;
-$VERSION = '1.70_54';
-# $Id: CPAN.pm,v 1.404 2003/05/15 20:43:14 k Exp $
+$VERSION = '1.71';
+# $Id: CPAN.pm,v 1.405 2003/07/04 08:06:11 k Exp $
# only used during development:
$Revision = "";
-# $Revision = "[".substr(q$Revision: 1.404 $, 10)."]";
+# $Revision = "[".substr(q$Revision: 1.405 $, 10)."]";
use Carp ();
use Config ();
==== //depot/maint-5.8/perl/lib/Locale/Maketext.pm#4 (text) ====
Index: perl/lib/Locale/Maketext.pm
--- perl/lib/Locale/Maketext.pm#3~19294~ Mon Apr 21 08:36:02 2003
+++ perl/lib/Locale/Maketext.pm Fri Jul 4 06:54:33 2003
@@ -1,5 +1,5 @@
-# Time-stamp: "2003-04-18 22:03:06 AHDT"
+# Time-stamp: "2003-06-21 23:41:57 AHDT"
require 5;
package Locale::Maketext;
@@ -14,7 +14,7 @@
BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
# define the constant 'DEBUG' at compile-time
-$VERSION = "1.05";
+$VERSION = "1.06";
@ISA = ();
$MATCH_SUPERS = 1;
@@ -328,6 +328,8 @@
#
###########################################################################
+use Locale::Maketext::GutsLoader;
+
sub _http_accept_langs {
# Deal with HTTP "Accept-Language:" stuff. Hassle.
# This code is more lenient than RFC 3282, which you must read.
@@ -380,285 +382,6 @@
map @{$pref{$_}},
sort {$b <=> $a}
keys %pref;
-}
-
-###########################################################################
-
-sub _compile {
- # This big scarp routine compiles an entry.
- # It returns either a coderef if there's brackety bits in this, or
- # otherwise a ref to a scalar.
-
- my $target = ref($_[0]) || $_[0];
-
- my(@code);
- my(@c) = (''); # "chunks" -- scratch.
- my $call_count = 0;
- my $big_pile = '';
- {
- my $in_group = 0; # start out outside a group
- my($m, @params); # scratch
-
- while($_[1] =~ # Iterate over chunks.
- m<\G(
- [^\~\[\]]+ # non-~[] stuff
- |
- ~. # ~[, ~], ~~, ~other
- |
- \[ # [ presumably opening a group
- |
- \] # ] presumably closing a group
- |
- ~ # terminal ~ ?
- |
- $
- )>xgs
- ) {
- print " \"$1\"\n" if DEBUG > 2;
-
- if($1 eq '[' or $1 eq '') { # "[" or end
- # Whether this is "[" or end, force processing of any
- # preceding literal.
- if($in_group) {
- if($1 eq '') {
- $target->_die_pointing($_[1], "Unterminated bracket group");
- } else {
- $target->_die_pointing($_[1], "You can't nest bracket groups");
- }
- } else {
- if($1 eq '') {
- print " [end-string]\n" if DEBUG > 2;
- } else {
- $in_group = 1;
- }
- die "How come [EMAIL PROTECTED] is empty?? in <$_[1]>" unless @c; # sanity
- if(length $c[-1]) {
- # Now actually processing the preceding literal
- $big_pile .= $c[-1];
- if($USE_LITERALS and (
- (ord('A') == 65)
- ? $c[-1] !~ m<[^\x20-\x7E]>s
- # ASCII very safe chars
- : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>[EMAIL PROTECTED]|}~\x07]/s
- # EBCDIC very safe chars
- )) {
- # normal case -- all very safe chars
- $c[-1] =~ s/'/\\'/g;
- push @code, q{ '} . $c[-1] . "',\n";
- $c[-1] = ''; # reuse this slot
- } else {
- push @code, ' $c[' . $#c . "],\n";
- push @c, ''; # new chunk
- }
- }
- # else just ignore the empty string.
- }
-
- } elsif($1 eq ']') { # "]"
- # close group -- go back in-band
- if($in_group) {
- $in_group = 0;
-
- print " --Closing group [$c[-1]]\n" if DEBUG > 2;
-
- # And now process the group...
-
- if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
- DEBUG > 2 and print " -- (Ignoring)\n";
- $c[-1] = ''; # reset out chink
- next;
- }
-
- #$c[-1] =~ s/^\s+//s;
- #$c[-1] =~ s/\s+$//s;
- ($m,@params) = split(",", $c[-1], -1); # was /\s*,\s*/
-
- # A bit of a hack -- we've turned "~,"'s into DELs, so turn
- # 'em into real commas here.
- if (ord('A') == 65) { # ASCII, etc
- foreach($m, @params) { tr/\x7F/,/ }
- } else { # EBCDIC (1047, 0037, POSIX-BC)
- # Thanks to Peter Prymmer for the EBCDIC handling
- foreach($m, @params) { tr/\x07/,/ }
- }
-
- # Special-case handling of some method names:
- if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) {
- # Treat [_1,...] as [,_1,...], etc.
- unshift @params, $m;
- $m = '';
- } elsif($m eq '*') {
- $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
- } elsif($m eq '#') {
- $m = 'numf'; # "#" for "number": [#,_1] for "the number _1"
- }
-
- # Most common case: a simple, legal-looking method name
- if($m eq '') {
- # 0-length method name means to just interpolate:
- push @code, ' (';
- } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s
- and $m !~ m<(?:^|\:)\d>s
- # exclude starting a (sub)package or symbol with a digit
- ) {
- # Yes, it even supports the demented (and undocumented?)
- # $obj->Foo::bar(...) syntax.
- $target->_die_pointing(
- $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method",
- 2 + length($c[-1])
- )
- if $m =~ m/^SUPER::/s;
- # Because for SUPER:: to work, we'd have to compile this into
- # the right package, and that seems just not worth the bother,
- # unless someone convinces me otherwise.
-
- push @code, ' $_[0]->' . $m . '(';
- } else {
- # TODO: implement something? or just too icky to consider?
- $target->_die_pointing(
- $_[1],
- "Can't use \"$m\" as a method name in bracket group",
- 2 + length($c[-1])
- );
- }
-
- pop @c; # we don't need that chunk anymore
- ++$call_count;
-
- foreach my $p (@params) {
- if($p eq '_*') {
- # Meaning: all parameters except $_[0]
- $code[-1] .= ' @_[1 .. $#_], ';
- # and yes, that does the right thing for all @_ < 3
- } elsif($p =~ m<^_(-?\d+)$>s) {
- # _3 meaning $_[3]
- $code[-1] .= '$_[' . (0 + $1) . '], ';
- } elsif($USE_LITERALS and (
- (ord('A') == 65)
- ? $p !~ m<[^\x20-\x7E]>s
- # ASCII very safe chars
- : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>[EMAIL PROTECTED]|}~\x07]/s
- # EBCDIC very safe chars
- )) {
- # Normal case: a literal containing only safe characters
- $p =~ s/'/\\'/g;
- $code[-1] .= q{'} . $p . q{', };
- } else {
- # Stow it on the chunk-stack, and just refer to that.
- push @c, $p;
- push @code, ' $c[' . $#c . "], ";
- }
- }
- $code[-1] .= "),\n";
-
- push @c, '';
- } else {
- $target->_die_pointing($_[1], "Unbalanced ']'");
- }
-
- } elsif(substr($1,0,1) ne '~') {
- # it's stuff not containing "~" or "[" or "]"
- # i.e., a literal blob
- $c[-1] .= $1;
-
- } elsif($1 eq '~~') { # "~~"
- $c[-1] .= '~';
-
- } elsif($1 eq '~[') { # "~["
- $c[-1] .= '[';
-
- } elsif($1 eq '~]') { # "~]"
- $c[-1] .= ']';
-
- } elsif($1 eq '~,') { # "~,"
- if($in_group) {
- # This is a hack, based on the assumption that no-one will actually
- # want a DEL inside a bracket group. Let's hope that's it's true.
- if (ord('A') == 65) { # ASCII etc
- $c[-1] .= "\x7F";
- } else { # EBCDIC (cp 1047, 0037, POSIX-BC)
- $c[-1] .= "\x07";
- }
- } else {
- $c[-1] .= '~,';
- }
-
- } elsif($1 eq '~') { # possible only at string-end, it seems.
- $c[-1] .= '~';
-
- } else {
- # It's a "~X" where X is not a special character.
- # Consider it a literal ~ and X.
- $c[-1] .= $1;
- }
- }
- }
-
- if($call_count) {
- undef $big_pile; # Well, nevermind that.
- } else {
- # It's all literals! Ahwell, that can happen.
- # So don't bother with the eval. Return a SCALAR reference.
- return \$big_pile;
- }
-
- die "Last chunk isn't null??" if @c and length $c[-1]; # sanity
- print scalar(@c), " chunks under closure\n" if DEBUG;
- if(@code == 0) { # not possible?
- print "Empty code\n" if DEBUG;
- return \'';
- } elsif(@code > 1) { # most cases, presumably!
- unshift @code, "join '',\n";
- }
- unshift @code, "use strict; sub {\n";
- push @code, "}\n";
-
- print @code if DEBUG;
- my $sub = eval(join '', @code);
- die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
- return $sub;
-}
-
-# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-
-sub _die_pointing {
- # This is used by _compile to throw a fatal error
- my $target = shift; # class name
- # ...leaving $_[0] the error-causing text, and $_[1] the error message
-
- my $i = index($_[0], "\n");
-
- my $pointy;
- my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
- if($pos < 1) {
- $pointy = "^=== near there\n";
- } else { # we need to space over
- my $first_tab = index($_[0], "\t");
- if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) {
- # No tabs, or the first tab is harmlessly after where we will point to,
- # AND we're far enough from the margin that we can draw a proper arrow.
- $pointy = ('=' x $pos) . "^ near there\n";
- } else {
- # tabs screw everything up!
- $pointy = substr($_[0],0,$pos);
- $pointy =~ tr/\t //cd;
- # make everything into whitespace, but preseving tabs
- $pointy .= "^=== near there\n";
- }
- }
-
- my $errmsg = "$_[1], in\:\n$_[0]";
-
- if($i == -1) {
- # No newline.
- $errmsg .= "\n" . $pointy;
- } elsif($i == (length($_[0]) - 1) ) {
- # Already has a newline at end.
- $errmsg .= $pointy;
- } else {
- # don't bother with the pointy bit, I guess.
- }
- Carp::croak( "$errmsg via $target, as used" );
}
###########################################################################
==== //depot/maint-5.8/perl/lib/Locale/Maketext/ChangeLog#4 (text) ====
Index: perl/lib/Locale/Maketext/ChangeLog
--- perl/lib/Locale/Maketext/ChangeLog#3~19294~ Mon Apr 21 08:36:02 2003
+++ perl/lib/Locale/Maketext/ChangeLog Fri Jul 4 06:54:33 2003
@@ -1,6 +1,11 @@
Revision history for Perl suite Locale::Maketext
- Time-stamp: "2003-04-18 22:07:29 AHDT"
+ Time-stamp: "2003-06-21 23:38:38 AHDT"
+2003-06-21 Sean M. Burke [EMAIL PROTECTED]
+ * Release 1.06: Now has "use utf8" to make the things work
+ happily. Some fancy footwork is required to make this work under
+ pre-utf8 perl versions.
+
2003-04-18 Sean M. Burke [EMAIL PROTECTED]
* Release 1.05: Different Makefile.PL, same .pm code.
==== //depot/maint-5.8/perl/lib/Locale/Maketext/Guts.pm#1 (text) ====
Index: perl/lib/Locale/Maketext/Guts.pm
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/lib/Locale/Maketext/Guts.pm Fri Jul 4 06:54:33 2003
@@ -0,0 +1,295 @@
+
+package Locale::Maketext::Guts;
+BEGIN { *zorp = sub { return scalar @_ } unless defined &zorp; }
+ # Just so we're nice and define SOMETHING in "our" package.
+
+package Locale::Maketext;
+use strict;
+use vars qw($USE_LITERALS $GUTSPATH);
+
+BEGIN {
+ $GUTSPATH = __FILE__;
+ *DEBUG = sub () {0} unless defined &DEBUG;
+}
+
+use utf8;
+
+sub _compile {
+ # This big scary routine compiles an entry.
+ # It returns either a coderef if there's brackety bits in this, or
+ # otherwise a ref to a scalar.
+
+ my $target = ref($_[0]) || $_[0];
+
+ my(@code);
+ my(@c) = (''); # "chunks" -- scratch.
+ my $call_count = 0;
+ my $big_pile = '';
+ {
+ my $in_group = 0; # start out outside a group
+ my($m, @params); # scratch
+
+ while($_[1] =~ # Iterate over chunks.
+ m<\G(
+ [^\~\[\]]+ # non-~[] stuff
+ |
+ ~. # ~[, ~], ~~, ~other
+ |
+ \[ # [ presumably opening a group
+ |
+ \] # ] presumably closing a group
+ |
+ ~ # terminal ~ ?
+ |
+ $
+ )>xgs
+ ) {
+ print " \"$1\"\n" if DEBUG > 2;
+
+ if($1 eq '[' or $1 eq '') { # "[" or end
+ # Whether this is "[" or end, force processing of any
+ # preceding literal.
+ if($in_group) {
+ if($1 eq '') {
+ $target->_die_pointing($_[1], "Unterminated bracket group");
+ } else {
+ $target->_die_pointing($_[1], "You can't nest bracket groups");
+ }
+ } else {
+ if($1 eq '') {
+ print " [end-string]\n" if DEBUG > 2;
+ } else {
+ $in_group = 1;
+ }
+ die "How come [EMAIL PROTECTED] is empty?? in <$_[1]>" unless @c; # sanity
+ if(length $c[-1]) {
+ # Now actually processing the preceding literal
+ $big_pile .= $c[-1];
+ if($USE_LITERALS and (
+ (ord('A') == 65)
+ ? $c[-1] !~ m<[^\x20-\x7E]>s
+ # ASCII very safe chars
+ : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>[EMAIL PROTECTED]|}~\x07]/s
+ # EBCDIC very safe chars
+ )) {
+ # normal case -- all very safe chars
+ $c[-1] =~ s/'/\\'/g;
+ push @code, q{ '} . $c[-1] . "',\n";
+ $c[-1] = ''; # reuse this slot
+ } else {
+ push @code, ' $c[' . $#c . "],\n";
+ push @c, ''; # new chunk
+ }
+ }
+ # else just ignore the empty string.
+ }
+
+ } elsif($1 eq ']') { # "]"
+ # close group -- go back in-band
+ if($in_group) {
+ $in_group = 0;
+
+ print " --Closing group [$c[-1]]\n" if DEBUG > 2;
+
+ # And now process the group...
+
+ if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
+ DEBUG > 2 and print " -- (Ignoring)\n";
+ $c[-1] = ''; # reset out chink
+ next;
+ }
+
+ #$c[-1] =~ s/^\s+//s;
+ #$c[-1] =~ s/\s+$//s;
+ ($m,@params) = split(",", $c[-1], -1); # was /\s*,\s*/
+
+ # A bit of a hack -- we've turned "~,"'s into DELs, so turn
+ # 'em into real commas here.
+ if (ord('A') == 65) { # ASCII, etc
+ foreach($m, @params) { tr/\x7F/,/ }
+ } else { # EBCDIC (1047, 0037, POSIX-BC)
+ # Thanks to Peter Prymmer for the EBCDIC handling
+ foreach($m, @params) { tr/\x07/,/ }
+ }
+
+ # Special-case handling of some method names:
+ if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) {
+ # Treat [_1,...] as [,_1,...], etc.
+ unshift @params, $m;
+ $m = '';
+ } elsif($m eq '*') {
+ $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
+ } elsif($m eq '#') {
+ $m = 'numf'; # "#" for "number": [#,_1] for "the number _1"
+ }
+
+ # Most common case: a simple, legal-looking method name
+ if($m eq '') {
+ # 0-length method name means to just interpolate:
+ push @code, ' (';
+ } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s
+ and $m !~ m<(?:^|\:)\d>s
+ # exclude starting a (sub)package or symbol with a digit
+ ) {
+ # Yes, it even supports the demented (and undocumented?)
+ # $obj->Foo::bar(...) syntax.
+ $target->_die_pointing(
+ $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method",
+ 2 + length($c[-1])
+ )
+ if $m =~ m/^SUPER::/s;
+ # Because for SUPER:: to work, we'd have to compile this into
+ # the right package, and that seems just not worth the bother,
+ # unless someone convinces me otherwise.
+
+ push @code, ' $_[0]->' . $m . '(';
+ } else {
+ # TODO: implement something? or just too icky to consider?
+ $target->_die_pointing(
+ $_[1],
+ "Can't use \"$m\" as a method name in bracket group",
+ 2 + length($c[-1])
+ );
+ }
+
+ pop @c; # we don't need that chunk anymore
+ ++$call_count;
+
+ foreach my $p (@params) {
+ if($p eq '_*') {
+ # Meaning: all parameters except $_[0]
+ $code[-1] .= ' @_[1 .. $#_], ';
+ # and yes, that does the right thing for all @_ < 3
+ } elsif($p =~ m<^_(-?\d+)$>s) {
+ # _3 meaning $_[3]
+ $code[-1] .= '$_[' . (0 + $1) . '], ';
+ } elsif($USE_LITERALS and (
+ (ord('A') == 65)
+ ? $p !~ m<[^\x20-\x7E]>s
+ # ASCII very safe chars
+ : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>[EMAIL PROTECTED]|}~\x07]/s
+ # EBCDIC very safe chars
+ )) {
+ # Normal case: a literal containing only safe characters
+ $p =~ s/'/\\'/g;
+ $code[-1] .= q{'} . $p . q{', };
+ } else {
+ # Stow it on the chunk-stack, and just refer to that.
+ push @c, $p;
+ push @code, ' $c[' . $#c . "], ";
+ }
+ }
+ $code[-1] .= "),\n";
+
+ push @c, '';
+ } else {
+ $target->_die_pointing($_[1], "Unbalanced ']'");
+ }
+
+ } elsif(substr($1,0,1) ne '~') {
+ # it's stuff not containing "~" or "[" or "]"
+ # i.e., a literal blob
+ $c[-1] .= $1;
+
+ } elsif($1 eq '~~') { # "~~"
+ $c[-1] .= '~';
+
+ } elsif($1 eq '~[') { # "~["
+ $c[-1] .= '[';
+
+ } elsif($1 eq '~]') { # "~]"
+ $c[-1] .= ']';
+
+ } elsif($1 eq '~,') { # "~,"
+ if($in_group) {
+ # This is a hack, based on the assumption that no-one will actually
+ # want a DEL inside a bracket group. Let's hope that's it's true.
+ if (ord('A') == 65) { # ASCII etc
+ $c[-1] .= "\x7F";
+ } else { # EBCDIC (cp 1047, 0037, POSIX-BC)
+ $c[-1] .= "\x07";
+ }
+ } else {
+ $c[-1] .= '~,';
+ }
+
+ } elsif($1 eq '~') { # possible only at string-end, it seems.
+ $c[-1] .= '~';
+
+ } else {
+ # It's a "~X" where X is not a special character.
+ # Consider it a literal ~ and X.
+ $c[-1] .= $1;
+ }
+ }
+ }
+
+ if($call_count) {
+ undef $big_pile; # Well, nevermind that.
+ } else {
+ # It's all literals! Ahwell, that can happen.
+ # So don't bother with the eval. Return a SCALAR reference.
+ return \$big_pile;
+ }
+
+ die "Last chunk isn't null??" if @c and length $c[-1]; # sanity
+ print scalar(@c), " chunks under closure\n" if DEBUG;
+ if(@code == 0) { # not possible?
+ print "Empty code\n" if DEBUG;
+ return \'';
+ } elsif(@code > 1) { # most cases, presumably!
+ unshift @code, "join '',\n";
+ }
+ unshift @code, "use strict; sub {\n";
+ push @code, "}\n";
+
+ print @code if DEBUG;
+ my $sub = eval(join '', @code);
+ die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
+ return $sub;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _die_pointing {
+ # This is used by _compile to throw a fatal error
+ my $target = shift; # class name
+ # ...leaving $_[0] the error-causing text, and $_[1] the error message
+
+ my $i = index($_[0], "\n");
+
+ my $pointy;
+ my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
+ if($pos < 1) {
+ $pointy = "^=== near there\n";
+ } else { # we need to space over
+ my $first_tab = index($_[0], "\t");
+ if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) {
+ # No tabs, or the first tab is harmlessly after where we will point to,
+ # AND we're far enough from the margin that we can draw a proper arrow.
+ $pointy = ('=' x $pos) . "^ near there\n";
+ } else {
+ # tabs screw everything up!
+ $pointy = substr($_[0],0,$pos);
+ $pointy =~ tr/\t //cd;
+ # make everything into whitespace, but preseving tabs
+ $pointy .= "^=== near there\n";
+ }
+ }
+
+ my $errmsg = "$_[1], in\:\n$_[0]";
+
+ if($i == -1) {
+ # No newline.
+ $errmsg .= "\n" . $pointy;
+ } elsif($i == (length($_[0]) - 1) ) {
+ # Already has a newline at end.
+ $errmsg .= $pointy;
+ } else {
+ # don't bother with the pointy bit, I guess.
+ }
+ Carp::croak( "$errmsg via $target, as used" );
+}
+
+1;
+
==== //depot/maint-5.8/perl/lib/Locale/Maketext/GutsLoader.pm#1 (text) ====
Index: perl/lib/Locale/Maketext/GutsLoader.pm
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/lib/Locale/Maketext/GutsLoader.pm Fri Jul 4 06:54:33 2003
@@ -0,0 +1,47 @@
+
+package Locale::Maketext::GutsLoader;
+use strict;
+sub zorp { return scalar @_ }
+
+BEGIN {
+ $Locale::Maketext::GutsLoader::GUTSPATH = __FILE__;
+ *Locale::Maketext::DEBUG = sub () {0}
+ unless defined &Locale::Maketext::DEBUG;
+}
+
+#
+# This whole drama is so that we can load the utf8'd code
+# in Locale::Maketext::Guts, but if that fails, snip the
+# utf8 and then try THAT.
+#
+
+$Locale::Maketext::GUTSPATH = '';
+Locale::Maketext::DEBUG and print "Requiring Locale::Maketext::Guts...\n";
+eval 'require Locale::Maketext::Guts';
+
+if($@) {
+ my $path = $Locale::Maketext::GUTSPATH;
+
+ die "Can't load Locale::Maketext::Guts\nAborting" unless $path;
+
+ die "No readable file $Locale::Maketext::GutsLoader::GUTSPATH\nAborting"
+ unless -e $path and -f _ and -r _;
+
+ open(IN, $path) or die "Can't read-open $path\nAborting";
+
+ my $source;
+ { local $/; $source = <IN>; }
+ close(IN);
+ unless( $source =~ s/\b(use utf8)/# $1/ ) {
+ Locale::Maketext::DEBUG and
+ print "I didn't see 'use utf8' in $path\n";
+ }
+ eval $source;
+ die "Can't compile $path\n...The error I got was:[EMAIL PROTECTED]" if $@;
+ Locale::Maketext::DEBUG and print "Non-utf8'd Locale::Maketext::Guts fine\n";
+} else {
+ Locale::Maketext::DEBUG and print "Loaded Locale::Maketext::Guts fine\n";
+}
+
+1;
+
==== //depot/maint-5.8/perl/lib/Locale/Maketext/t/90utf8.t#1 (text) ====
Index: perl/lib/Locale/Maketext/t/90utf8.t
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/lib/Locale/Maketext/t/90utf8.t Fri Jul 4 06:54:33 2003
@@ -0,0 +1,39 @@
+
+require 5;
+use Test;
+BEGIN { plan tests => 4; }
+use Locale::Maketext 1.01;
+print "# Hi there...\n";
+ok 1;
+
+
+print "# --- Making sure that get_handle works with utf8 ---\n";
+use utf8;
+
+# declare some classes...
+{
+ package Woozle;
+ @ISA = ('Locale::Maketext');
+ sub dubbil { return $_[1] * 2 .chr(2000)}
+ sub numerate { return $_[2] . 'en' }
+}
+{
+ package Woozle::eu_mt;
+ @ISA = ('Woozle');
+ %Lexicon = (
+ 'd2' => chr(1000) . 'hum [dubbil,_1]',
+ 'd3' => chr(1000) . 'hoo [quant,_1,zaz]',
+ 'd4' => chr(1000) . 'hoo [*,_1,zaz]',
+ );
+ keys %Lexicon; # dodges the 'used only once' warning
+}
+
+my $lh;
+print "# Basic sanity:\n";
+ok defined( $lh = Woozle->get_handle('eu-mt') ) && ref($lh);
+ok $lh && $lh->maketext('d2', 7), chr(1000)."hum 14".chr(2000) ;
+
+
+print "# Byebye!\n";
+ok 1;
+
==== //depot/maint-5.8/perl/lib/Net/Ping.pm#8 (text) ====
Index: perl/lib/Net/Ping.pm
--- perl/lib/Net/Ping.pm#7~19551~ Sun May 18 00:55:50 2003
+++ perl/lib/Net/Ping.pm Fri Jul 4 06:54:33 2003
@@ -16,7 +16,10 @@
@ISA = qw(Exporter);
@EXPORT = qw(pingecho);
-$VERSION = "2.30";
+$VERSION = "2.31";
+
+sub SOL_IP { 0; };
+sub IP_TOS { 1; };
# Constants
@@ -74,6 +77,7 @@
$timeout, # Optional timeout in seconds
$data_size, # Optional additional bytes of data
$device, # Optional device to use
+ $tos, # Optional ToS to set
) = @_;
my $class = ref($this) || $this;
my $self = {};
@@ -95,6 +99,8 @@
$self->{"device"} = $device;
+ $self->{"tos"} = $tos;
+
$min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size
$data_size = $min_datasize unless defined($data_size) && $proto ne "tcp";
croak("Data for ping must be from $min_datasize to $max_datasize bytes")
@@ -127,6 +133,10 @@
setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*",
$self->{'device'}))
or croak "error binding to device $self->{'device'} $!";
}
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
}
elsif ($self->{"proto"} eq "icmp")
{
@@ -141,6 +151,10 @@
setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*",
$self->{'device'}))
or croak "error binding to device $self->{'device'} $!";
}
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
}
elsif ($self->{"proto"} eq "tcp" || $self->{"proto"} eq "stream")
{
@@ -203,7 +217,7 @@
CORE::bind($self->{"fh"}, sockaddr_in(0, $ip)) ||
croak("$self->{'proto'} bind error - $!");
}
- elsif ($self->{"proto"} ne "tcp")
+ elsif (($self->{"proto"} ne "tcp") && ($self->{"proto"} ne "syn"))
{
croak("Unknown protocol \"$self->{proto}\" in bind()");
}
@@ -562,6 +576,10 @@
setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*",
$self->{'device'}))
or croak("error binding to device $self->{'device'} $!");
}
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
};
my $do_connect = sub {
$self->{"ip"} = $ip;
@@ -1002,7 +1020,10 @@
setsockopt($fh, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*", $self->{'device'}))
or croak("error binding to device $self->{'device'} $!");
}
-
+ if ($self->{'tos'}) {
+ setsockopt($fh, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
# Set O_NONBLOCK property on filehandle
$self->socket_blocking_mode($fh, 0);
@@ -1068,6 +1089,10 @@
setsockopt($self->{"fh"}, SOL_SOCKET, SO_BINDTODEVICE(), pack("Z*",
$self->{'device'}))
or croak("error binding to device $self->{'device'} $!");
}
+ if ($self->{'tos'}) {
+ setsockopt($self->{"fh"}, SOL_IP, IP_TOS(), pack("I*", $self->{'tos'}))
+ or croak "error configuring tos to $self->{'tos'} $!";
+ }
$!=0;
# Try to connect (could take a long time)
@@ -1459,7 +1484,7 @@
=over 4
-=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device ]]]]);
+=item Net::Ping->new([$proto [, $def_timeout [, $bytes [, $device [, $tos ]]]]]);
Create a new ping object. All of the parameters are optional. $proto
specifies the protocol to use when doing a ping. The current choices
@@ -1481,6 +1506,8 @@
before sending the ping packet. I beleive this only works with
superuser privileges and with udp and icmp protocols at this time.
+If $tos is given, this ToS is configured into the soscket.
+
=item $p->ping($host [, $timeout]);
Ping the remote host and wait for a response. $host can be either the
@@ -1712,6 +1739,6 @@
This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.
-$Id: Ping.pm,v 1.81 2003/04/18 04:16:03 rob Exp $
+$Id: Ping.pm,v 1.86 2003/06/27 21:31:07 rob Exp $
=cut
==== //depot/maint-5.8/perl/lib/Net/Ping/Changes#4 (text) ====
Index: perl/lib/Net/Ping/Changes
--- perl/lib/Net/Ping/Changes#3~19290~ Mon Apr 21 08:14:17 2003
+++ perl/lib/Net/Ping/Changes Fri Jul 4 06:54:33 2003
@@ -1,7 +1,14 @@
CHANGES
-------
-3.30 Apr 18 14:00 2003
+2.31 Jun 28 14:00 2003
+ - Win32 Compatibility fixes.
+ Patch by [EMAIL PROTECTED] (Marcus Holland-Moritz)
+ - Apply bleadperl patch #22204
+ - Add ToS support.
+ Patch by [EMAIL PROTECTED] (Martin Lorensen)
+
+2.30 Apr 18 14:00 2003
- Fix select() bug for UDP and ICMP protocols
in case packet comes from wrong source or seq.
- Allow UDP ping to different IP addresses
==== //depot/maint-5.8/perl/lib/Net/Ping/t/250_ping_hires.t#3 (text) ====
Index: perl/lib/Net/Ping/t/250_ping_hires.t
--- perl/lib/Net/Ping/t/250_ping_hires.t#2~19727~ Mon Jun 9 11:53:58 2003
+++ perl/lib/Net/Ping/t/250_ping_hires.t Fri Jul 4 06:54:33 2003
@@ -57,7 +57,5 @@
ok $ret;
# It is extremely likely that the duration contains a decimal
-# point if Time::HiRes is functioning properly, except when it
-# it is fast enough to be "zero".
-print "# duration=[$duration]\n";
-ok $duration =~ /\.|^0$/;
+# point if Time::HiRes is functioning properly.
+ok $duration =~ /\./;
==== //depot/maint-5.8/perl/lib/Net/Ping/t/300_ping_stream.t#3 (text) ====
Index: perl/lib/Net/Ping/t/300_ping_stream.t
--- perl/lib/Net/Ping/t/300_ping_stream.t#2~18673~ Sat Feb 8 09:38:33 2003
+++ perl/lib/Net/Ping/t/300_ping_stream.t Fri Jul 4 06:54:33 2003
@@ -14,7 +14,7 @@
if (my $port = getservbyname('echo', 'tcp')) {
socket(*ECHO, &Socket::PF_INET(), &Socket::SOCK_STREAM(), (getprotobyname
'tcp')[2]);
unless (connect(*ECHO, scalar &Socket::sockaddr_in($port,
&Socket::inet_aton("localhost")))) {
- print "1..0 \# Skip: loopback echo service is off ($!)\n";
+ print "1..0 \# Skip: loopback tcp echo service is off ($!)\n";
exit;
}
close (*ECHO);
==== //depot/maint-5.8/perl/lib/Net/Ping/t/450_service.t#6 (text) ====
Index: perl/lib/Net/Ping/t/450_service.t
--- perl/lib/Net/Ping/t/450_service.t#5~19727~ Mon Jun 9 11:53:58 2003
+++ perl/lib/Net/Ping/t/450_service.t Fri Jul 4 06:54:33 2003
@@ -19,7 +19,7 @@
# for the TCP Server stuff instead of doing
# all that direct socket() junk manually.
-plan tests => 26, ($^O eq 'MSWin32' ? (todo => [18]) : ());
+plan tests => 26;
# Everything loaded fine
ok 1;
==== //depot/maint-5.8/perl/lib/Pod/Find.pm#2 (text) ====
Index: perl/lib/Pod/Find.pm
--- perl/lib/Pod/Find.pm#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/lib/Pod/Find.pm Fri Jul 4 06:54:33 2003
@@ -13,7 +13,7 @@
package Pod::Find;
use vars qw($VERSION);
-$VERSION = 0.22; ## Current version of this package
+$VERSION = 0.23; ## Current version of this package
require 5.005; ## requires this Perl version or later
use Carp;
@@ -416,6 +416,9 @@
if -d $Config::Config{'scriptdir'};
}
+ warn "Search path is: ".join(' ', @search_dirs)."\n"
+ if $options{'-verbose'};
+
# Loop over directories
Dir: foreach my $dir ( @search_dirs ) {
@@ -442,6 +445,16 @@
warn "Directory $dir does not exist\n"
if $options{'-verbose'};
next Dir;
+ }
+ # for some strange reason the path on MacOS/darwin is
+ # 'pods' not 'pod'
+ # this could be the case also for other systems that
+ # have a case-tolerant file system, but File::Spec
+ # does not recognize 'darwin' yet
+ #if(File::Spec->case_tolerant && -d File::Spec->catdir($dir,'pods')) {
+ if($^O =~ /macos|darwin/i && -d File::Spec->catdir($dir,'pods')) {
+ $dir = File::Spec->catdir($dir,'pods');
+ redo Dir;
}
if(-d File::Spec->catdir($dir,'pod')) {
$dir = File::Spec->catdir($dir,'pod');
==== //depot/maint-5.8/perl/lib/Pod/Usage.pm#5 (text) ====
Index: perl/lib/Pod/Usage.pm
--- perl/lib/Pod/Usage.pm#4~18890~ Mon Mar 10 12:18:55 2003
+++ perl/lib/Pod/Usage.pm Fri Jul 4 06:54:33 2003
@@ -10,7 +10,7 @@
package Pod::Usage;
use vars qw($VERSION);
-$VERSION = 1.14; ## Current version of this package
+$VERSION = 1.16; ## Current version of this package
require 5.005; ## requires this Perl version or later
=head1 NAME
@@ -469,7 +469,8 @@
}
## Default the output file
- $opts{"-output"} = ($opts{"-exitval"} < 2) ? \*STDOUT : \*STDERR
+ $opts{"-output"} = (lc($opts{"-exitval"}) eq "noexit" ||
+ $opts{"-exitval"} < 2) ? \*STDOUT : \*STDERR
unless (defined $opts{"-output"});
## Default the input file
$opts{"-input"} = $0 unless (defined $opts{"-input"});
@@ -506,7 +507,7 @@
and $opts{"-output"} == \*STDOUT )
{
## spit out the entire PODs. Might as well invoke perldoc
- my $progpath = File::Spec->catfile($Config{bin}, "perldoc");
+ my $progpath = File::Spec->catfile($Config{scriptdir}, "perldoc");
system($progpath, $opts{"-input"});
}
else {
==== //depot/maint-5.8/perl/lib/Text/Balanced.pm#2 (text) ====
Index: perl/lib/Text/Balanced.pm
--- perl/lib/Text/Balanced.pm#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/lib/Text/Balanced.pm Fri Jul 4 06:54:33 2003
@@ -10,7 +10,7 @@
use SelfLoader;
use vars qw { $VERSION @ISA %EXPORT_TAGS };
-$VERSION = '1.89';
+$VERSION = '1.95';
@ISA = qw ( Exporter );
%EXPORT_TAGS = ( ALL => [ qw(
@@ -30,15 +30,6 @@
Exporter::export_ok_tags('ALL');
-##
-## These shenanagins are to avoid using $& in perl5.6+
-##
-my $GetMatchedText = ($] < 5.006) ? eval 'sub { $& } '
- : eval 'sub {
- substr($_[0], $-[0], $+[0] - $-[0])
- }';
-
-
# PROTOTYPES
sub _match_bracketed($$$$$$);
@@ -337,8 +328,7 @@
if (!defined $rdel)
{
- $rdelspec = &$GetMatchedText($$textref);
-
+ $rdelspec = $&;
unless ($rdelspec =~ s/\A([[(<{]+)($XMLNAME).*/ quotemeta "$1\/$2".
revbracket($1) /oes)
{
_failmsg "Unable to construct closing tag to match: $rdel",
@@ -348,7 +338,16 @@
}
else
{
- $rdelspec = eval "qq{$rdel}";
+ $rdelspec = eval "qq{$rdel}" || do {
+ my $del;
+ for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',)
+ { next if $rdel =~ /\Q$_/; $del = $_; last }
+ unless ($del) {
+ use Carp;
+ croak "Can't interpolate right delimiter $rdel"
+ }
+ eval "qq$del$rdel$del";
+ };
}
while (pos($$textref) < length($$textref))
@@ -450,7 +449,7 @@
return;
}
my $varpos = pos($$textref);
- unless ($$textref =~ m{\G\$\s*(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci)
+ unless ($$textref =~
m{\G\$\s*(?!::)(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci)
{
unless ($$textref =~ m/\G((\$#?|[EMAIL PROTECTED]|\\&)+)/gc)
{
@@ -472,6 +471,7 @@
while (1)
{
+ next if $$textref =~ m/\G\s*(?:->)?\s*[{]\w+[}]/gc;
next if _match_codeblock($textref,
qr/\s*->\s*(?:[_a-zA-Z]\w+\s*)?/,
qr/[({[]/, qr/[)}\]]/,
@@ -583,11 +583,13 @@
# NEED TO COVER MANY MORE CASES HERE!!!
- if ($$textref =~ m#\G\s*( [-+*x/%^&|.]=?
+ if ($$textref =~ m#\G\s*(?!$ldel_inner)
+ ( [-+*x/%^&|.]=?
| [!=]~
| =(?!>)
| (\*\*|&&|\|\||<<|>>)=?
| split|grep|map|return
+ | [([]
)#gcx)
{
$patvalid = 1;
@@ -717,7 +719,7 @@
);
}
- unless ($$textref =~ m{\G((?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc)
+ unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc)
{
_failmsg q{No quotelike operator found after prefix at "} .
substr($$textref, pos($$textref), 20) .
@@ -908,7 +910,7 @@
FIELD: while (pos($$textref) < length($$textref))
{
- my $field;
+ my ($field, $rem);
my @bits;
foreach my $i ( 0..$#func )
{
@@ -917,12 +919,13 @@
$class = $class[$i];
$lastpos = pos $$textref;
if (ref($func) eq 'CODE')
- { ($field,undef,$pref) = @bits =
$func->($$textref) }
+ { ($field,$rem,$pref) = @bits =
$func->($$textref);
+ # print "[$field|$rem]" if $field;
+ }
elsif (ref($func) eq 'Text::Balanced::Extractor')
{ @bits = $field = $func->extract($$textref) }
elsif( $$textref =~ m/\G$func/gc )
- { @bits = $field = defined($1) ? $1 :
&$GetMatchedText($$textref) }
- # substr() on previous line is "$&", without
the pain
+ { @bits = $field = defined($1) ? $1 : $& }
$pref ||= "";
if (defined($field) && length($field))
{
@@ -1057,7 +1060,7 @@
# Extract the initial substring of $text that is bounded by
- # an HTML/XML tag.
+ # an XML tag.
($extracted, $remainder) = extract_tagged($text);
@@ -1113,11 +1116,23 @@
=head1 DESCRIPTION
-The various C<extract_...> subroutines may be used to extract a
-delimited string (possibly after skipping a specified prefix string).
-The search for the string always begins at the current C<pos>
-location of the string's variable (or at index zero, if no C<pos>
-position is defined).
+The various C<extract_...> subroutines may be used to
+extract a delimited substring, possibly after skipping a
+specified prefix string. By default, that prefix is
+optional whitespace (C</\s*/>), but you can change it to whatever
+you wish (see below).
+
+The substring to be extracted must appear at the
+current C<pos> location of the string's variable
+(or at index zero, if no C<pos> position is defined).
+In other words, the C<extract_...> subroutines I<don't>
+extract the first occurance of a substring anywhere
+in a string (like an unanchored regex would). Rather,
+they extract an occurance of the substring appearing
+immediately at the current matching position in the
+string (like a C<\G>-anchored regex would).
+
+
=head2 General behaviour in list contexts
@@ -1219,7 +1234,7 @@
is also not specified, the set C</["'`]/> is used. If the text to be processed
is not specified either, C<$_> is used.
-In list context, C<extract_delimited> returns an array of three
+In list context, C<extract_delimited> returns a array of three
elements, the extracted substring (I<including the surrounding
delimiters>), the remainder of the text, and the skipped prefix (if
any). If a suitable delimited substring is not found, the first
@@ -1375,6 +1390,58 @@
See also: C<"extract_quotelike"> and C<"extract_codeblock">.
+=head2 C<extract_variable>
+
+C<extract_variable> extracts any valid Perl variable or
+variable-involved expression, including scalars, arrays, hashes, array
+accesses, hash look-ups, method calls through objects, subroutine calles
+through subroutine references, etc.
+
+The subroutine takes up to two optional arguments:
+
+=over 4
+
+=item 1.
+
+A string to be processed (C<$_> if the string is omitted or C<undef>)
+
+=item 2.
+
+A string specifying a pattern to be matched as a prefix (which is to be
+skipped). If omitted, optional whitespace is skipped.
+
+=back
+
+On success in a list context, an array of 3 elements is returned. The
+elements are:
+
+=over 4
+
+=item [0]
+
+the extracted variable, or variablish expression
+
+=item [1]
+
+the remainder of the input text,
+
+=item [2]
+
+the prefix substring (if any),
+
+=back
+
+On failure, all of these values (except the remaining text) are C<undef>.
+
+In a scalar context, C<extract_variable> returns just the complete
+substring that matched a variablish expression. C<undef> is returned on
+failure. In addition, the original input text has the returned substring
+(and any prefix) removed from it.
+
+In a void context, the input text just has the matched substring (and
+any specified prefix) removed.
+
+
=head2 C<extract_tagged>
C<extract_tagged> extracts and segments text between (balanced)
@@ -1392,7 +1459,7 @@
A string specifying a pattern to be matched as the opening tag.
If the pattern string is omitted (or C<undef>) then a pattern
-that matches any standard HTML/XML tag is used.
+that matches any standard XML tag is used.
=item 3.
@@ -1427,7 +1494,7 @@
For example, to extract
an HTML link (which should not contain nested links) use:
- extract_tagged($text, '<A>', '</A>', undef, {reject => ['<A>']} );
+ extract_tagged($text, '<A>', '</A>', undef, {reject => ['<A>']} );
=item C<ignore =E<gt> $listref>
@@ -1437,7 +1504,7 @@
For example, to extract an arbitrary XML tag, but ignore "empty" elements:
- extract_tagged($text, undef, undef, undef, {ignore => ['<[^>]*/>']} );
+ extract_tagged($text, undef, undef, undef, {ignore => ['<[^>]*/>']} );
(also see L<"gen_delimited_pat"> below).
@@ -1454,28 +1521,28 @@
If the string is "PARA", C<extract_tagged> returns only the first paragraph
after the tag (up to the first line that is either empty or contains
only whitespace characters).
-If the string is "", the default behaviour (i.e. failure) is reinstated.
+If the string is "", the the default behaviour (i.e. failure) is reinstated.
For example, suppose the start tag "/para" introduces a paragraph, which then
continues until the next "/endpara" tag or until another "/para" tag is
encountered:
- $text = "/para line 1\n\nline 3\n/para line 4";
+ $text = "/para line 1\n\nline 3\n/para line 4";
- extract_tagged($text, '/para', '/endpara', undef,
- {reject => '/para', fail => MAX );
+ extract_tagged($text, '/para', '/endpara', undef,
+ {reject => '/para', fail => MAX );
- # EXTRACTED: "/para line 1\n\nline 3\n"
+ # EXTRACTED: "/para line 1\n\nline 3\n"
Suppose instead, that if no matching "/endpara" tag is found, the "/para"
tag refers only to the immediately following paragraph:
- $text = "/para line 1\n\nline 3\n/para line 4";
+ $text = "/para line 1\n\nline 3\n/para line 4";
- extract_tagged($text, '/para', '/endpara', undef,
- {reject => '/para', fail => MAX );
+ extract_tagged($text, '/para', '/endpara', undef,
+ {reject => '/para', fail => MAX );
- # EXTRACTED: "/para line 1\n"
+ # EXTRACTED: "/para line 1\n"
Note that the specified C<fail> behaviour applies to nested tags as well.
@@ -1558,12 +1625,12 @@
In other words, the implementation of C<extract_tagged> is exactly
equivalent to:
- sub extract_tagged
- {
- my $text = shift;
- $extractor = gen_extract_tagged(@_);
- return $extractor->($text);
- }
+ sub extract_tagged
+ {
+ my $text = shift;
+ $extractor = gen_extract_tagged(@_);
+ return $extractor->($text);
+ }
(although C<extract_tagged> is not currently implemented that way, in order
to preserve pre-5.005 compatibility).
@@ -1582,13 +1649,13 @@
delimiters (for the quotelike operators), and trailing modifiers are
all caught. For example, in:
- extract_quotelike 'q # an octothorpe: \# (not the end of the q!) #'
-
- extract_quotelike ' "You said, \"Use sed\"." '
+ extract_quotelike 'q # an octothorpe: \# (not the end of the q!) #'
+
+ extract_quotelike ' "You said, \"Use sed\"." '
- extract_quotelike ' s{([A-Z]{1,8}\.[A-Z]{3})} /\L$1\E/; '
+ extract_quotelike ' s{([A-Z]{1,8}\.[A-Z]{3})} /\L$1\E/; '
- extract_quotelike ' tr/\\\/\\\\/\\\//ds; '
+ extract_quotelike ' tr/\\\/\\\\/\\\//ds; '
the full Perl quotelike operations are all extracted correctly.
@@ -1596,17 +1663,17 @@
containing the current pattern delimiter will cause the regex to be
immediately terminated. In other words:
- 'm /
- (?i) # CASE INSENSITIVE
- [a-z_] # LEADING ALPHABETIC/UNDERSCORE
- [a-z0-9]* # FOLLOWED BY ANY NUMBER OF ALPHANUMERICS
- /x'
+ 'm /
+ (?i) # CASE INSENSITIVE
+ [a-z_] # LEADING ALPHABETIC/UNDERSCORE
+ [a-z0-9]* # FOLLOWED BY ANY NUMBER OF ALPHANUMERICS
+ /x'
will be extracted as if it were:
- 'm /
- (?i) # CASE INSENSITIVE
- [a-z_] # LEADING ALPHABETIC/'
+ 'm /
+ (?i) # CASE INSENSITIVE
+ [a-z_] # LEADING ALPHABETIC/'
This behaviour is identical to that of the actual compiler.
@@ -1653,7 +1720,7 @@
=item [7]
the left delimiter of the second block of the operation
-(that is, if it is an C<s>, C<tr>, or C<y>),
+(that is, if it is a C<s>, C<tr>, or C<y>),
=item [8]
@@ -1683,27 +1750,27 @@
Examples:
- # Remove the first quotelike literal that appears in text
+ # Remove the first quotelike literal that appears in text
- $quotelike = extract_quotelike($text,'.*?');
+ $quotelike = extract_quotelike($text,'.*?');
- # Replace one or more leading whitespace-separated quotelike
- # literals in $_ with "<QLL>"
+ # Replace one or more leading whitespace-separated quotelike
+ # literals in $_ with "<QLL>"
- do { $_ = join '<QLL>', (extract_quotelike)[2,1] } until $@;
+ do { $_ = join '<QLL>', (extract_quotelike)[2,1] } until $@;
- # Isolate the search pattern in a quotelike operation from $text
+ # Isolate the search pattern in a quotelike operation from $text
- ($op,$pat) = (extract_quotelike $text)[3,5];
- if ($op =~ /[ms]/)
- {
- print "search pattern: $pat\n";
- }
- else
- {
- print "$op is not a pattern matching operation\n";
- }
+ ($op,$pat) = (extract_quotelike $text)[3,5];
+ if ($op =~ /[ms]/)
+ {
+ print "search pattern: $pat\n";
+ }
+ else
+ {
+ print "$op is not a pattern matching operation\n";
+ }
=head2 C<extract_quotelike> and "here documents"
@@ -1718,7 +1785,7 @@
<<'EOMSG' || die;
This is the message.
EOMSG
- exit;
+ exit;
Given this as an input string in a scalar context, C<extract_quotelike>
would correctly return the string "<<'EOMSG'\nThis is the message.\nEOMSG",
@@ -1771,7 +1838,7 @@
which would cause the earlier " || die;\nexit;" to be skipped in any
sequence of code fragment extractions.
-To avoid this problem, when it encounters a here document while
+To avoid this problem, when it encounters a here document whilst
extracting from a modifiable string, C<extract_quotelike> silently
rearranges the string to an equivalent piece of Perl:
@@ -1779,7 +1846,7 @@
This is the message.
EOMSG
|| die;
- exit;
+ exit;
in which the here document I<is> contiguous. It still leaves the
matching position after the here document, but now the rest of the line
@@ -1811,7 +1878,7 @@
Omitting the fourth argument (outermost delimiter brackets) indicates that the
value of the second argument is to be used for the outermost delimiters.
-Once the prefix an the outermost opening delimiter bracket have been
+Once the prefix an dthe outermost opening delimiter bracket have been
recognized, code blocks are extracted by stepping through the input text and
trying the following alternatives in sequence:
@@ -1898,7 +1965,7 @@
C<extract_multiple> starts at the current C<pos> of the string, and
sets that C<pos> appropriately after it matches.
-Hence, the aim of a call to C<extract_multiple> in a list context
+Hence, the aim of of a call to C<extract_multiple> in a list context
is to split the processed string into as many non-overlapping fields as
possible, by repeatedly applying each of the specified extractors
to the remainder of the string. Thus C<extract_multiple> is
@@ -1930,7 +1997,7 @@
=item 3.
-A number specifying the maximum number of fields to return. If this
+An number specifying the maximum number of fields to return. If this
argument is omitted (or C<undef>), split continues as long as possible.
If the third argument is I<N>, then extraction continues until I<N> fields
@@ -1986,7 +2053,7 @@
character is extracted from the start of the text and the extraction
subroutines reapplied. Characters which are thus removed are accumulated and
eventually become the next field (unless the fourth argument is true, in which
-case they are discarded).
+case they are disgarded).
For example, the following extracts substrings that are valid Perl variables:
==== //depot/maint-5.8/perl/lib/Text/Balanced/Changes#2 (text) ====
Index: perl/lib/Text/Balanced/Changes
--- perl/lib/Text/Balanced/Changes#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/lib/Text/Balanced/Changes Fri Jul 4 06:54:33 2003
@@ -261,3 +261,41 @@
1.89 Sun Nov 18 22:49:50 2001
- Fixed extvar.t tests
+
+
+1.90 Tue Mar 25 11:14:38 2003
+
+ - Fixed subtle bug in gen_extract_tagged (thanks Martin)
+
+ - Doc fix: removed suggestion that extract_tagged defaults
+ to matching HTML tags
+
+ - Doc fix: clarified general matching behaviour
+
+ - Fixed bug in parsing /.../ after a (
+
+ - Doc fix: documented extract_variable
+
+ - Fixed extract_variable handling of $h{qr}, $h{tr}, etc.
+ (thanks, Briac)
+
+ - Fixed incorrect handling of $::var (thanks Tim)
+
+
+1.91 Fri Mar 28 23:19:17 2003
+
+ - Fixed error count on t/extract_variable.t
+
+ - Fixed bug in extract_codelike when non-standard delimiters used
+
+
+1.94 Sun Apr 13 02:18:41 2003
+
+ - rereleased in attempt to fix CPAN problems
+
+
+1.95 Mon Apr 28 00:22:04 2003
+
+ - Constrainted _match_quote to only match at word boundaries
+ (so "exemplum(hic)" doesn't match "m(hic)")
+ (thanks Craig)
==== //depot/maint-5.8/perl/lib/Text/Balanced/README#2 (xtext) ====
Index: perl/lib/Text/Balanced/README
--- perl/lib/Text/Balanced/README#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/lib/Text/Balanced/README Fri Jul 4 06:54:33 2003
@@ -1,5 +1,5 @@
==============================================================================
- Release of version 1.89 of Text::Balanced
+ Release of version 1.95 of Text::Balanced
==============================================================================
@@ -66,10 +66,12 @@
==============================================================================
-CHANGES IN VERSION 1.89
+CHANGES IN VERSION 1.95
- - Fixed extvar.t tests
+ - Constrainted _match_quote to only match at word boundaries
+ (so "exemplum(hic)" doesn't match "m(hic)")
+ (thanks Craig)
==============================================================================
@@ -77,8 +79,5 @@
AVAILABILITY
Text::Balanced has been uploaded to the CPAN
-and is also available from:
-
- http://www.csse.monash.edu.au/~damian/CPAN/Text-Balanced.tar.gz
==============================================================================
==== //depot/maint-5.8/perl/lib/Text/Balanced/t/extcbk.t#2 (text) ====
Index: perl/lib/Text/Balanced/t/extcbk.t
--- perl/lib/Text/Balanced/t/extcbk.t#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/lib/Text/Balanced/t/extcbk.t Fri Jul 4 06:54:33 2003
@@ -59,11 +59,11 @@
__DATA__
-# USING: extract_codeblock($str);
-{ $data[4] =~ /['"]/; };
-
# USING: extract_codeblock($str,'(){}',undef,'()');
(Foo(')'));
+
+# USING: extract_codeblock($str);
+{ $data[4] =~ /['"]/; };
# USING: extract_codeblock($str,'<>');
< %x = ( try => "this") >;
==== //depot/maint-5.8/perl/lib/Text/Balanced/t/extvar.t#2 (text) ====
Index: perl/lib/Text/Balanced/t/extvar.t
--- perl/lib/Text/Balanced/t/extvar.t#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/lib/Text/Balanced/t/extvar.t Fri Jul 4 06:54:33 2003
@@ -13,7 +13,7 @@
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
-BEGIN { $| = 1; print "1..181\n"; }
+BEGIN { $| = 1; print "1..183\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( extract_variable );
$loaded = 1;
@@ -65,6 +65,7 @@
$a (1..3) { print $a };
# USING: extract_variable($str);
+$::obj;
$obj->nextval;
*var;
*$var;
==== //depot/maint-5.8/perl/lib/Text/Balanced/t/gentag.t#2 (text) ====
Index: perl/lib/Text/Balanced/t/gentag.t
--- perl/lib/Text/Balanced/t/gentag.t#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/lib/Text/Balanced/t/gentag.t Fri Jul 4 06:54:33 2003
@@ -13,7 +13,7 @@
# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)
-BEGIN { $| = 1; print "1..35\n"; }
+BEGIN { $| = 1; print "1..37\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( gen_extract_tagged );
$loaded = 1;
@@ -64,6 +64,9 @@
}
__DATA__
+
+# USING: gen_extract_tagged('{','}');
+ { a test };
# USING: gen_extract_tagged(qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]});
<A>aaa<B>bbb<BR>ccc</B>ddd</A>;
==== //depot/maint-5.8/perl/mpeix/mpeixish.h#4 (text) ====
Index: perl/mpeix/mpeixish.h
--- perl/mpeix/mpeixish.h#3~19891~ Mon Jun 30 02:39:29 2003
+++ perl/mpeix/mpeixish.h Fri Jul 4 06:54:33 2003
@@ -113,7 +113,7 @@
#define Mkdir(path,mode) mkdir((path),(mode))
#ifndef PERL_SYS_INIT
-# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) PERL_FPU_INIT MALLOC_INIT
+# define PERL_SYS_INIT(c,v) PERL_FPU_INIT MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
==== //depot/maint-5.8/perl/os2/os2ish.h#6 (text) ====
Index: perl/os2/os2ish.h
--- perl/os2/os2ish.h#5~19891~ Mon Jun 30 02:39:29 2003
+++ perl/os2/os2ish.h Fri Jul 4 06:54:33 2003
@@ -220,7 +220,6 @@
# define PERL_SYS_INIT3(argcp, argvp, envp) \
{ void *xreg[2]; \
- EARLY_INIT3(argcp, argvp, envp) \
MALLOC_CHECK_TAINT(*argcp, *argvp, *envp) \
_response(argcp, argvp); \
_wildcard(argcp, argvp); \
@@ -228,7 +227,6 @@
# define PERL_SYS_INIT(argcp, argvp) { \
{ void *xreg[2]; \
- EARLY_INIT2(argcp, argvp) \
_response(argcp, argvp); \
_wildcard(argcp, argvp); \
Perl_OS2_init3(NULL, xreg, 0)
@@ -237,11 +235,9 @@
# define PERL_SYS_INIT3(argcp, argvp, envp) \
{ void *xreg[2]; \
- EARLY_INIT3(argcp, argvp, envp) \
Perl_OS2_init3(*envp, xreg, 0)
# define PERL_SYS_INIT(argcp, argvp) { \
{ void *xreg[2]; \
- EARLY_INIT2(argcp, argvp) \
Perl_OS2_init3(NULL, xreg, 0)
#endif
==== //depot/maint-5.8/perl/perl.c#39 (text) ====
Index: perl/perl.c
--- perl/perl.c#38~19919~ Tue Jul 1 14:28:15 2003
+++ perl/perl.c Fri Jul 4 06:54:33 2003
@@ -315,39 +315,6 @@
PL_stashcache = newHV();
-#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
- /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 */
- {
- char *s = NULL;
-
- if (!PL_earlytaint)
- s = PerlEnv_getenv("PERL_HASH_SEED");
- if (s)
- while (isSPACE(*s)) s++;
- if (s && isDIGIT(*s))
- PL_hash_seed = (UV)Atoul(s);
-#ifndef USE_HASH_SEED_EXPLICIT
- else {
- /* Compute a random seed */
- (void)seedDrand01((Rand_seed_t)seed());
- PL_srand_called = TRUE;
- PL_hash_seed = (UV)(Drand01() * (NV)UV_MAX);
-#if RANDBITS < (UVSIZE * 8)
- {
- int skip = (UVSIZE * 8) - RANDBITS;
- PL_hash_seed >>= skip;
- /* The low bits might need extra help. */
- PL_hash_seed += (UV)(Drand01() * ((1 << skip) - 1));
- }
-#endif /* RANDBITS < (UVSIZE * 8) */
- }
-#endif /* USE_HASH_SEED_EXPLICIT */
- if (!PL_earlytaint && (s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG")))
- PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
- PL_hash_seed);
- }
-#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
-
ENTER;
}
@@ -1060,6 +1027,41 @@
#endif
#endif
+#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
+ /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
+ * This MUST be done before any hash stores or fetches take place. */
+ {
+ bool earlytaint = doing_taint(argc, argv, env);
+ char *s = NULL;
+
+ if (!earlytaint)
+ s = PerlEnv_getenv("PERL_HASH_SEED");
+ if (s)
+ while (isSPACE(*s)) s++;
+ if (s && isDIGIT(*s))
+ PL_hash_seed = (UV)Atoul(s);
+#ifndef USE_HASH_SEED_EXPLICIT
+ else {
+ /* Compute a random seed */
+ (void)seedDrand01((Rand_seed_t)seed());
+ PL_srand_called = TRUE;
+ PL_hash_seed = (UV)(Drand01() * (NV)UV_MAX);
+#if RANDBITS < (UVSIZE * 8)
+ {
+ int skip = (UVSIZE * 8) - RANDBITS;
+ PL_hash_seed >>= skip;
+ /* The low bits might need extra help. */
+ PL_hash_seed += (UV)(Drand01() * ((1 << skip) - 1));
+ }
+#endif /* RANDBITS < (UVSIZE * 8) */
+ }
+#endif /* USE_HASH_SEED_EXPLICIT */
+ if (!earlytaint && (s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG")))
+ PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
+ PL_hash_seed);
+ }
+#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
+
PL_origargc = argc;
PL_origargv = argv;
@@ -3548,8 +3550,7 @@
/* This is used very early in the lifetime of the program,
* before even the options are parsed, so PL_tainting has
- * not been initialized properly. The variable PL_earlytaint
- * is set early in main() to the result of this function. */
+ * not been initialized properly. */
bool
Perl_doing_taint(int argc, char *argv[], char *envp[])
{
==== //depot/maint-5.8/perl/perl.h#37 (text) ====
Index: perl/perl.h
--- perl/perl.h#36~19919~ Tue Jul 1 14:28:15 2003
+++ perl/perl.h Fri Jul 4 06:54:33 2003
@@ -518,7 +518,7 @@
panic_write2("panic: tainting with $ENV{PERL_MALLOC_OPT}\n");\
exit(1); })
# define MALLOC_CHECK_TAINT(argc,argv,env) STMT_START { \
- if (PL_earlytaint) { \
+ if (doing_taint(argc,argv,env)) { \
MallocCfg_ptr[MallocCfg_skip_cfg_env] = 1; \
}} STMT_END;
#else /* MYMALLOC */
@@ -1976,23 +1976,6 @@
# define PERL_FPU_INIT
# endif
# endif
-#endif
-
-/* The PL_earlytaint is to be used instead PL_tainting before
- * perl_parse() has had the chance to set up PL_tainting. */
-
-#ifndef EARLY_INIT3
-# define EARLY_INIT3(argcp,argvp,envp) \
- STMT_START { \
- PL_earlytaint = doing_taint(argcp, argvp, envp); \
- } STMT_END;
-#endif
-
-#ifndef EARLY_INIT2
-# define EARLY_INIT2(argcp,argvp) \
- STMT_START { \
- PL_earlytaint = doing_taint(argcp, argvp, 0); \
- } STMT_END;
#endif
#ifndef PERL_SYS_INIT3
==== //depot/maint-5.8/perl/perlapi.h#20 (text+w) ====
Index: perl/perlapi.h
--- perl/perlapi.h#19~19891~ Mon Jun 30 02:39:29 2003
+++ perl/perlapi.h Fri Jul 4 06:54:33 2003
@@ -992,8 +992,6 @@
#define PL_do_undump (*Perl_Gdo_undump_ptr(NULL))
#undef PL_dollarzero_mutex
#define PL_dollarzero_mutex (*Perl_Gdollarzero_mutex_ptr(NULL))
-#undef PL_earlytaint
-#define PL_earlytaint (*Perl_Gearlytaint_ptr(NULL))
#undef PL_hexdigit
#define PL_hexdigit (*Perl_Ghexdigit_ptr(NULL))
#undef PL_malloc_mutex
==== //depot/maint-5.8/perl/perlvars.h#10 (text) ====
Index: perl/perlvars.h
--- perl/perlvars.h#9~19891~ Mon Jun 30 02:39:29 2003
+++ perl/perlvars.h Fri Jul 4 06:54:33 2003
@@ -55,5 +55,3 @@
/* This is constant on most architectures, a global on OS/2 */
PERLVARI(Gsh_path, char *, SH_PATH)/* full path of shell */
-PERLVAR(Gearlytaint, bool) /* Early warning for taint, before PL_tainting is set
*/
-
==== //depot/maint-5.8/perl/plan9/plan9ish.h#5 (text) ====
Index: perl/plan9/plan9ish.h
--- perl/plan9/plan9ish.h#4~19891~ Mon Jun 30 02:39:29 2003
+++ perl/plan9/plan9ish.h Fri Jul 4 06:54:33 2003
@@ -106,7 +106,7 @@
#define ABORT() kill(PerlProc_getpid(),SIGABRT);
#define BIT_BUCKET "/dev/null"
-#define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
MALLOC_INIT
+#define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) MALLOC_INIT
#define dXSUB_SYS
#define PERL_SYS_TERM() MALLOC_TERM
==== //depot/maint-5.8/perl/unixish.h#8 (text) ====
Index: perl/unixish.h
--- perl/unixish.h#7~19891~ Mon Jun 30 02:39:29 2003
+++ perl/unixish.h Fri Jul 4 06:54:33 2003
@@ -129,7 +129,7 @@
#define Mkdir(path,mode) mkdir((path),(mode))
#ifndef PERL_SYS_INIT
-# define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
PERL_FPU_INIT MALLOC_INIT
+# define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT MALLOC_INIT
#endif
#ifndef PERL_SYS_TERM
==== //depot/maint-5.8/perl/vms/vms.c#11 (text) ====
Index: perl/vms/vms.c
--- perl/vms/vms.c#10~19256~ Thu Apr 17 11:26:24 2003
+++ perl/vms/vms.c Fri Jul 4 06:54:33 2003
@@ -2299,7 +2299,7 @@
}
if (!fp) return 0; /* we're hosed */
- fprintf(fp,"$! 'f$verify(0)\n");
+ fprintf(fp,"$! 'f$verify(0)'\n");
fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
fprintf(fp,"$ perl_define = \"define/nolog\"\n");
@@ -2317,16 +2317,8 @@
fprintf(fp,"$c=c+perl_popen_cmd2\n");
fprintf(fp,"$x=perl_popen_cmd3\n");
fprintf(fp,"$c=c+x\n");
- fprintf(fp,"$! --- get rid of global symbols\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
fprintf(fp,"$ perl_on\n");
- fprintf(fp,"$ 'c\n");
+ fprintf(fp,"$ 'c'\n");
fprintf(fp,"$ perl_status = $STATUS\n");
fprintf(fp,"$ perl_del 'perl_cfile'\n");
fprintf(fp,"$ perl_exit 'perl_status'\n");
@@ -2358,7 +2350,11 @@
{
static int handler_set_up = FALSE;
unsigned long int sts, flags = CLI$M_NOWAIT;
- unsigned int table = LIB$K_CLI_GLOBAL_SYM;
+ /* The use of a GLOBAL table (as was done previously) rendered
+ * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
+ * environment. Hence we've switched to LOCAL symbol table.
+ */
+ unsigned int table = LIB$K_CLI_LOCAL_SYM;
int j, wait = 0;
char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
char in[512], out[512], err[512], mbx[512];
==== //depot/maint-5.8/perl/vms/vmsish.h#6 (text) ====
Index: perl/vms/vmsish.h
--- perl/vms/vmsish.h#5~19891~ Mon Jun 30 02:39:29 2003
+++ perl/vms/vmsish.h Fri Jul 4 06:54:33 2003
@@ -331,7 +331,7 @@
#endif
#define BIT_BUCKET "_NLA0:"
-#define PERL_SYS_INIT(c,v) EARLY_INIT2(*c,*v) MALLOC_CHECK_TAINT2(*c,*v)
vms_image_init((c),(v)); MALLOC_INIT
+#define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) vms_image_init((c),(v));
MALLOC_INIT
#define PERL_SYS_TERM() OP_REFCNT_TERM; MALLOC_TERM
#define dXSUB_SYS
#define HAS_KILL
==== //depot/maint-5.8/perl/vms/vmspipe.com#2 (text) ====
Index: perl/vms/vmspipe.com
--- perl/vms/vmspipe.com#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/vms/vmspipe.com Fri Jul 4 06:54:33 2003
@@ -1,4 +1,4 @@
-$! 'f$verify(0)
+$! 'f$verify(0)'
$! --- protect against nonstandard definitions ---
$ perl_define = "define/nolog"
$ perl_on = "on error then exit $STATUS"
@@ -15,14 +15,6 @@
$c=c+perl_popen_cmd2
$x=perl_popen_cmd3
$c=c+x
-$! --- get rid of global symbols
-$ perl_del/symbol/global perl_popen_cmd0
-$ perl_del/symbol/global perl_popen_cmd1
-$ perl_del/symbol/global perl_popen_cmd2
-$ perl_del/symbol/global perl_popen_cmd3
-$ perl_del/symbol/global perl_popen_in
-$ perl_del/symbol/global perl_popen_err
-$ perl_del/symbol/global perl_popen_out
$ perl_on
-$ 'c
+$ 'c'
$ perl_exit '$STATUS'
End of Patch.
