Change 18866 by [EMAIL PROTECTED] on 2003/03/09 13:59:01
Integrate:
[ 18851]
regen_headers tiny tidying:
- regen.pl renamed as regen_lib.pl
- regen_headers.pl renamed as regen.pl
- added make target 'regen' (kept target 'regen_headers'
for porters' brains' backward compatibility)
- regen.pl fancified a bit to display the names
of the files that got changed by running the scripts
[ 18852]
Subject: [PATCH] long %ENV values for VMS
From: "Craig A. Berry" <[EMAIL PROTECTED]>
Date: Fri, 07 Mar 2003 13:49:50 -0600
Message-ID: <[EMAIL PROTECTED]>
[ 18853]
Subject: [PATCH] Re: [perl #20551] Documentation error for IO::Select
From: Richard Soderberg <[EMAIL PROTECTED]>
Date: Sat, 15 Feb 2003 01:27:17 -0500
Message-Id: <[EMAIL PROTECTED]>
[ 18854]
Enache Adrian reads comments.
[ 18855]
Subject: [PATCH perldebug.pod] to explain new [<>{] behaviour - attached
From: [EMAIL PROTECTED]
Date: Fri, 21 Feb 2003 13:51:51 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 18856]
Add a B::COP::io() method, to return the cop_io field of COPs.
Print it in B::Debug. Can be used later in B::Deparse to deparse
the open pragma.
[ 18857]
From Inaba Hiroto: the UTF-8 length cache wasn't
updated when fbm_compile() appended a "\n".
[ 18858]
From Inaba Hiroto: re_intuit_start set a value to
PL_bostr before calling find_byclass when regexp has
ROPT_UTF8 flag on. But right value for PL_bostr is set
before re_intuit_start is called. PL_regdata is always
assigned by cache_re(), so the whole if(prog->reganch & ROPT_UTF8){}
can be deleted.
[ 18859]
Adjust test count.
[ 18860]
Subject: Re: [perl #20798] foo(eval {}) crashes Perl 5.8
From: Enache Adrian <[EMAIL PROTECTED]>
Date: Fri, 7 Mar 2003 00:12:03 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 18861]
Subject: Re: [perl #21498] printf behaviour changes 5.6.1(and earlier) -> 5.8
From: Enache Adrian <[EMAIL PROTECTED]>
Date: Fri, 7 Mar 2003 23:28:37 +0200
Message-ID: <[EMAIL PROTECTED]>
(and few more test cases from the thread)
[ 18862]
... and add a test case for bug #20798
[ 18863]
At Sarathy's request restore the bin5005compat Perl_foo_sv()
function stubs, should be helpful for really simple extensions.
Undoes large parts of changes #16289 and #16290.
[ 18864]
Tru64: additional instructions for building a newer Berkeley DB.
[ 18865]
From Inaba Hiroto: DATA wasn't properly utf8ed
under 'use encoding'.
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#31 integrate
... //depot/maint-5.8/perl/Makefile.SH#6 integrate
... //depot/maint-5.8/perl/README.tru64#4 integrate
... //depot/maint-5.8/perl/autodoc.pl#4 integrate
... //depot/maint-5.8/perl/bytecode.pl#3 integrate
... //depot/maint-5.8/perl/embed.pl#8 integrate
... //depot/maint-5.8/perl/ext/B/B.pm#6 integrate
... //depot/maint-5.8/perl/ext/B/B.xs#6 integrate
... //depot/maint-5.8/perl/ext/B/B/Debug.pm#3 integrate
... //depot/maint-5.8/perl/ext/Encode/MANIFEST#7 integrate
... //depot/maint-5.8/perl/ext/Encode/t/enc_data.t#1 branch
... //depot/maint-5.8/perl/ext/IO/lib/IO/Select.pm#2 integrate
... //depot/maint-5.8/perl/hints/dec_osf.sh#4 integrate
... //depot/maint-5.8/perl/keywords.pl#6 integrate
... //depot/maint-5.8/perl/op.c#16 integrate
... //depot/maint-5.8/perl/opcode.pl#6 integrate
... //depot/maint-5.8/perl/perl.h#20 integrate
... //depot/maint-5.8/perl/pod/perldebug.pod#3 integrate
... //depot/maint-5.8/perl/regcomp.pl#3 integrate
... //depot/maint-5.8/perl/regen.pl#2 integrate
... //depot/maint-5.8/perl/regen_headers.pl#2 delete
... //depot/maint-5.8/perl/regen_lib.pl#1 branch
... //depot/maint-5.8/perl/regexec.c#14 integrate
... //depot/maint-5.8/perl/sv.c#32 integrate
... //depot/maint-5.8/perl/t/op/eval.t#5 integrate
... //depot/maint-5.8/perl/t/op/pat.t#14 integrate
... //depot/maint-5.8/perl/t/op/sprintf.t#4 integrate
... //depot/maint-5.8/perl/toke.c#12 integrate
... //depot/maint-5.8/perl/util.c#15 integrate
... //depot/maint-5.8/perl/vms/vms.c#3 integrate
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#31 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#30~18850~ Fri Mar 7 12:38:51 2003
+++ perl/MANIFEST Sun Mar 9 05:59:01 2003
@@ -261,6 +261,7 @@
ext/Encode/t/CJKT.t test script
ext/Encode/t/Encode.t test script
ext/Encode/t/Encoder.t test script
+ext/Encode/t/enc_data.t test script for utf8 DATA
ext/Encode/t/enc_eucjp.t test script
ext/Encode/t/enc_module.enc test data for t/enc_module.t
ext/Encode/t/enc_module.t test script
@@ -2366,8 +2367,8 @@
regcomp.h Private declarations for above
regcomp.pl Builder of regnodes.h
regcomp.sym Data for regnodes.h
-regen.pl Common file routines for generator scripts
-regen_headers.pl Run all scripts that (re)generate files
+regen.pl Run all scripts that (re)generate files
+regen_lib.pl Common file routines for generator scripts
regexec.c Regular expression evaluator
regexp.h Public declarations for the above
regnodes.h Description of nodes of RE engine
==== //depot/maint-5.8/perl/Makefile.SH#6 (text) ====
Index: perl/Makefile.SH
--- perl/Makefile.SH#5~18790~ Thu Feb 27 22:34:27 2003
+++ perl/Makefile.SH Sun Mar 9 05:59:01 2003
@@ -812,20 +812,20 @@
CHMOD_W = chmod +w
# The following files are generated automatically
-# keywords.pl: keywords.h
-# opcode.pl: opcode.h opnames.h pp_proto.h pp.sym
-# [* embed.pl needs pp.sym generated by opcode.pl! *]
-# embed.pl: proto.h embed.h embedvar.h global.sym
-# perlapi.h perlapi.c pod/perlintern.pod
-# pod/perlapi.pod
+# autodoc.pl: pod/perlapi.pod pod/perlintern.pod
# bytecode.pl: ext/ByteLoader/byterun.h ext/ByteLoader/byterun.c
# ext/B/B/Asmdata.pm
+# embed.pl: proto.h embed.h embedvar.h global.sym
+# perlapi.h perlapi.c
+# [* embed.pl needs pp.sym generated by opcode.pl! *]
+# keywords.pl: keywords.h
+# opcode.pl: opcode.h opnames.h pp_proto.h pp.sym
# regcomp.pl: regnodes.h
# warnings.pl: warnings.h lib/warnings.pm
# The correct versions should be already supplied with the perl kit,
# in case you don't have perl available.
# To force them to be regenerated, run
-# perl regen_headers.pl
+# perl regen.pl
# with your existing copy of perl
# (make regen_headers is kept for backwards compatibility)
@@ -838,13 +838,13 @@
.PHONY: regen_headers regen_pods regen_all
-regen_headers: FORCE
- -perl regen_headers.pl
+regen regen_headers: FORCE
+ -perl regen.pl
regen_pods: FORCE
-cd pod; $(LDLIBPTH) $(MAKE) regen_pods
-regen_all: $(PERLYVMS) regen_headers regen_pods
+regen_all: $(PERLYVMS) regen regen_pods
# Extensions:
# Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will
==== //depot/maint-5.8/perl/README.tru64#4 (text) ====
Index: perl/README.tru64
--- perl/README.tru64#3~18095~ Mon Nov 4 09:45:47 2002
+++ perl/README.tru64 Sun Mar 9 05:59:01 2003
@@ -79,7 +79,8 @@
the DB_File extension test db-hash.t may fail by dumping core after
the subtest 21. There really is no good cure as of Tru64 V5.1A expect
installing a newer Berkeley DB and supplying the right directories for
--Dlocincpth=/some/include and -Dloclibpth=/some/lib when running Configure.
+-Dlocincpth=/some/include and -Dloclibpth=/some/lib when running Configure
+B<and> before running "make test" setting your LD_LIBRARY_PATH to /some/lib.
You can also work around the problem by disabling the DB_File by
specifying -Ui_db to Configure, and then using the BerkeleyFile module
==== //depot/maint-5.8/perl/autodoc.pl#4 (text) ====
Index: perl/autodoc.pl
--- perl/autodoc.pl#3~18173~ Fri Nov 22 18:02:33 2002
+++ perl/autodoc.pl Sun Mar 9 05:59:01 2003
@@ -5,7 +5,7 @@
BEGIN {
push @INC, 'lib';
- require 'regen.pl';
+ require 'regen_lib.pl';
} # glob() below requires File::Glob
==== //depot/maint-5.8/perl/bytecode.pl#3 (text) ====
Index: perl/bytecode.pl
--- perl/bytecode.pl#2~18173~ Fri Nov 22 18:02:33 2002
+++ perl/bytecode.pl Sun Mar 9 05:59:01 2003
@@ -1,6 +1,6 @@
BEGIN {
push @INC, './lib';
- require 'regen.pl';
+ require 'regen_lib.pl';
}
use strict;
my %alias_to = (
==== //depot/maint-5.8/perl/embed.pl#8 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl#7~18804~ Sun Mar 2 08:22:35 2003
+++ perl/embed.pl Sun Mar 9 05:59:01 2003
@@ -5,7 +5,7 @@
BEGIN {
# Get function prototypes
- require 'regen.pl';
+ require 'regen_lib.pl';
}
#
==== //depot/maint-5.8/perl/ext/B/B.pm#6 (text) ====
Index: perl/ext/B/B.pm
--- perl/ext/B/B.pm#5~18791~ Fri Feb 28 12:05:43 2003
+++ perl/ext/B/B.pm Sun Mar 9 05:59:01 2003
@@ -1042,6 +1042,8 @@
=item stash
+=item stashpv
+
=item file
=item cop_seq
@@ -1049,6 +1051,10 @@
=item arybase
=item line
+
+=item warnings
+
+=item io
=back
==== //depot/maint-5.8/perl/ext/B/B.xs#6 (text) ====
Index: perl/ext/B/B.xs
--- perl/ext/B/B.xs#5~18791~ Fri Feb 28 12:05:43 2003
+++ perl/ext/B/B.xs Sun Mar 9 05:59:01 2003
@@ -897,6 +897,7 @@
#define COP_arybase(o) o->cop_arybase
#define COP_line(o) CopLINE(o)
#define COP_warnings(o) o->cop_warnings
+#define COP_io(o) o->cop_io
MODULE = B PACKAGE = B::COP PREFIX = COP_
@@ -930,6 +931,10 @@
B::SV
COP_warnings(o)
+ B::COP o
+
+B::SV
+COP_io(o)
B::COP o
MODULE = B PACKAGE = B::SV PREFIX = Sv
==== //depot/maint-5.8/perl/ext/B/B/Debug.pm#3 (text) ====
Index: perl/ext/B/B/Debug.pm
--- perl/ext/B/B/Debug.pm#2~18791~ Fri Feb 28 12:05:43 2003
+++ perl/ext/B/B/Debug.pm Sun Mar 9 05:59:01 2003
@@ -72,7 +72,8 @@
sub B::COP::debug {
my ($op) = @_;
$op->B::OP::debug();
- printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->seq, $op->arybase,
$op->line, ${$op->warnings};
+ my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
+ printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->seq, $op->arybase,
$op->line, ${$op->warnings}, cstring($cop_io);
cop_label %s
cop_stashpv %s
cop_file %s
@@ -80,6 +81,7 @@
cop_arybase %d
cop_line %d
cop_warnings 0x%x
+ cop_io %s
EOT
}
==== //depot/maint-5.8/perl/ext/Encode/MANIFEST#7 (text) ====
Index: perl/ext/Encode/MANIFEST
--- perl/ext/Encode/MANIFEST#6~18824~ Mon Mar 3 21:39:18 2003
+++ perl/ext/Encode/MANIFEST Sun Mar 9 05:59:01 2003
@@ -62,6 +62,7 @@
t/big5-eten.utf test data
t/big5-hkscs.enc test data
t/big5-hkscs.utf test data
+t/enc_data.t test script for utf8 DATA
t/enc_eucjp.t test script
t/enc_module.enc test data for t/enc_module.t
t/enc_module.t test script
==== //depot/maint-5.8/perl/ext/Encode/t/enc_data.t#1 (text) ====
Index: perl/ext/Encode/t/enc_data.t
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/ext/Encode/t/enc_data.t Sun Mar 9 05:59:01 2003
@@ -0,0 +1,24 @@
+use encoding 'euc-jp';
+use Test::More tests => 1;
+
+my @a;
+
+while (<DATA>) {
+ chomp;
+ tr/��-��-��/��-��-��/;
+ push @a, $_;
+}
+
+SKIP: {
+ skip("pre-5.8.1 does not do utf8 DATA", 1) if $] < 5.008001;
+ ok(@a == 3 &&
+ $a[0] eq "�����DATA�դ�����Ϥ�ɤ�ΤƤ��ȥǥ���" &&
+ $a[1] eq "���ܸ쥬�������Ѵ��ǥ��륫" &&
+ $a[2] eq "�ɥ����ΤƤ��ȥƥ��ޥ���",
+ "utf8 (euc-jp) DATA")
+}
+
+__DATA__
+�����DATA�ե�����ϥ�ɥ�Υƥ��ȤǤ���
+���ܸ줬�������Ѵ��Ǥ��뤫
+�ɤ����Υƥ��ȤƤ��ޤ���
==== //depot/maint-5.8/perl/ext/IO/lib/IO/Select.pm#2 (text) ====
Index: perl/ext/IO/lib/IO/Select.pm
--- perl/ext/IO/lib/IO/Select.pm#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/ext/IO/lib/IO/Select.pm Sun Mar 9 05:59:01 2003
@@ -250,13 +250,13 @@
@ready = $s->can_read($timeout);
- @ready = IO::Select->new(@handles)->read(0);
+ @ready = IO::Select->new(@handles)->can_read(0);
=head1 DESCRIPTION
The C<IO::Select> package implements an object approach to the system C<select>
function call. It allows the user to see what IO handles, see L<IO::Handle>,
-are ready for reading, writing or have an error condition pending.
+are ready for reading, writing or have an exception pending.
=head1 CONSTRUCTOR
@@ -324,16 +324,16 @@
Return the bit string suitable as argument to the core select() call.
-=item select ( READ, WRITE, ERROR [, TIMEOUT ] )
+=item select ( READ, WRITE, EXCEPTION [, TIMEOUT ] )
-C<select> is a static method, that is you call it with the package
-name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef>
-or C<IO::Select> objects. C<TIMEOUT> is optional and has the same
-effect as for the core select call.
+C<select> is a static method, that is you call it with the package name
+like C<new>. C<READ>, C<WRITE> and C<EXCEPTION> are either C<undef> or
+C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as
+for the core select call.
The result will be an array of 3 elements, each a reference to an array
which will hold the handles that are ready for reading, writing and have
-error conditions respectively. Upon error an empty array is returned.
+exceptions respectively. Upon error an empty list is returned.
=back
==== //depot/maint-5.8/perl/hints/dec_osf.sh#4 (text) ====
Index: perl/hints/dec_osf.sh
--- perl/hints/dec_osf.sh#3~18095~ Mon Nov 4 09:45:47 2002
+++ perl/hints/dec_osf.sh Sun Mar 9 05:59:01 2003
@@ -409,6 +409,10 @@
"$old_LD_LIBRARY_PATH") ;;
*) echo "LD_LIBRARY_PATH is now $LD_LIBRARY_PATH." >& 4 ;;
esac
+case "$LD_LIBRARY_PATH" in
+'') ;;
+* ) export LD_LIBRARY_PATH ;;
+esac
#
# Unset temporary variables no more needed.
==== //depot/maint-5.8/perl/keywords.pl#6 (xtext) ====
Index: perl/keywords.pl
--- perl/keywords.pl#5~18808~ Sun Mar 2 13:29:38 2003
+++ perl/keywords.pl Sun Mar 9 05:59:01 2003
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-require 'regen.pl';
+require 'regen_lib.pl';
safer_unlink ("keywords.h");
open(KW, ">keywords.h") || die "Can't create keywords.h: $!\n";
select KW;
==== //depot/maint-5.8/perl/op.c#16 (text) ====
Index: perl/op.c
--- perl/op.c#15~18824~ Mon Mar 3 21:39:18 2003
+++ perl/op.c Sun Mar 9 05:59:01 2003
@@ -4868,10 +4868,9 @@
o->op_flags &= ~OPf_KIDS;
op_null(o);
}
- else if (kid->op_type == OP_LINESEQ) {
+ else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
- kid->op_next = o->op_next;
cUNOPo->op_first = 0;
op_free(o);
==== //depot/maint-5.8/perl/opcode.pl#6 (xtext) ====
Index: perl/opcode.pl
--- perl/opcode.pl#5~18804~ Sun Mar 2 08:22:35 2003
+++ perl/opcode.pl Sun Mar 9 05:59:01 2003
@@ -1,7 +1,7 @@
#!/usr/bin/perl
BEGIN {
# Get function prototypes
- require 'regen.pl';
+ require 'regen_lib.pl';
}
$opcode_new = 'opcode.h-new';
==== //depot/maint-5.8/perl/perl.h#20 (text) ====
Index: perl/perl.h
--- perl/perl.h#19~18815~ Sun Mar 2 21:43:25 2003
+++ perl/perl.h Sun Mar 9 05:59:01 2003
@@ -4319,7 +4319,7 @@
#endif
/* Use instead of abs() since abs() forces its argument to be an int,
- * but also beware since evaluates its argument thrice. */
+ * but also beware since this evaluates its argument twice, so no x++. */
#define PERL_ABS(x) ((x) < 0 ? -(x) : (x))
/* and finally... */
==== //depot/maint-5.8/perl/pod/perldebug.pod#3 (text) ====
Index: perl/pod/perldebug.pod
--- perl/pod/perldebug.pod#2~18700~ Thu Feb 13 06:55:54 2003
+++ perl/pod/perldebug.pod Sun Mar 9 05:59:01 2003
@@ -351,7 +351,10 @@
Set an action (Perl command) to happen before every debugger prompt.
A multi-line command may be entered by backslashing the newlines.
-B<WARNING> If C<command> is missing, all actions are wiped out!
+
+=item < *
+
+Delete all pre-prompt Perl command actions.
=item << command
@@ -367,8 +370,11 @@
Set an action (Perl command) to happen after the prompt when you've
just given a command to return to executing the script. A multi-line
command may be entered by backslashing the newlines (we bet you
-couldn't've guessed this by now). B<WARNING> If C<command> is
-missing, all actions are wiped out!
+couldn't've guessed this by now).
+
+=item > *
+
+Delete all post-prompt Perl command actions.
=item >> command
@@ -384,12 +390,15 @@
Set an action (debugger command) to happen before every debugger prompt.
A multi-line command may be entered in the customary fashion.
-B<WARNING> If C<command> is missing, all actions are wiped out!
Because this command is in some senses new, a warning is issued if
you appear to have accidentally entered a block instead. If that's
what you mean to do, write it as with C<;{ ... }> or even
C<do { ... }>.
+
+=item { *
+
+Delete all pre-prompt debugger commands.
=item {{ command
==== //depot/maint-5.8/perl/regcomp.pl#3 (text) ====
Index: perl/regcomp.pl
--- perl/regcomp.pl#2~18173~ Fri Nov 22 18:02:33 2002
+++ perl/regcomp.pl Sun Mar 9 05:59:01 2003
@@ -1,6 +1,6 @@
BEGIN {
# Get function prototypes
- require 'regen.pl';
+ require 'regen_lib.pl';
}
#use Fatal qw(open close rename chmod unlink);
open DESC, 'regcomp.sym';
==== //depot/maint-5.8/perl/regen.pl#2 (text) ====
Index: perl/regen.pl
--- perl/regen.pl#1~18173~ Fri Nov 22 18:02:33 2002
+++ perl/regen.pl Sun Mar 9 05:59:01 2003
@@ -1,45 +1,64 @@
#!/usr/bin/perl -w
-use strict;
-use vars qw($Is_W32 $Is_OS2 $Is_Cygwin $Is_NetWare $Needs_Write);
-use Config; # Remember, this is running using an existing perl
-
-# Common functions needed by the regen scripts
+require 5.003; # keep this compatible, an old perl is all we may have before
+ # we build the new one
-$Is_W32 = $^O eq 'MSWin32';
-$Is_OS2 = $^O eq 'os2';
-$Is_Cygwin = $^O eq 'cygwin';
-$Is_NetWare = $Config{osname} eq 'NetWare';
-if ($Is_NetWare) {
- $Is_W32 = 0;
-}
+# The idea is to move the regen_headers target out of the Makefile so that
+# it is possible to rebuild the headers before the Makefile is available.
+# (and the Makefile is unavailable until after Configure is run, and we may
+# wish to make a clean source tree but with current headers without running
+# anything else.
-$Needs_Write = $Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare;
-
-sub safer_unlink {
- my @names = @_;
- my $cnt = 0;
-
- my $name;
- foreach $name (@names) {
- next unless -e $name;
- chmod 0777, $name if $Needs_Write;
- ( CORE::unlink($name) and ++$cnt
- or warn "Couldn't unlink $name: $!\n" );
- }
- return $cnt;
-}
-
-sub safer_rename_silent {
- my ($from, $to) = @_;
+use strict;
+my $perl = $^X;
- # Some dosish systems can't rename over an existing file:
- safer_unlink $to;
- chmod 0600, $from if $Needs_Write;
- rename $from, $to;
+require 'regen_lib.pl';
+# keep warnings.pl in sync with the CPAN distribution by not requiring core
+# changes
+safer_unlink ("warnings.h", "lib/warnings.pm");
+
+my %gen = (
+ 'autodoc.pl' => [qw[pod/perlapi.pod pod/perlintern.pod]],
+ 'bytecode.pl' => [qw[ext/ByteLoader/byterun.h
+ ext/ByteLoader/byterun.c
+ ext/B/B/Asmdata.pm]],
+ 'embed.pl' => [qw[proto.h embed.h embedvar.h global.sym
+ perlapi.h perlapi.c]],
+ 'keywords.pl' => [qw[keywords.h]],
+ 'opcode.pl' => [qw[opcode.h opnames.h pp_proto.h pp.sym]],
+ 'regcomp.pl' => [qw[regnodes.h]],
+ 'warnings.pl' => [qw[warnings.h lib/warnings.pm]]
+ );
+
+sub do_cksum {
+ my $pl = shift;
+ my %cksum;
+ for my $f (@{ $gen{$pl} }) {
+ local *FH;
+ if (open(FH, $f)) {
+ local $/;
+ $cksum{$f} = unpack("%32C*", <FH>);
+ close FH;
+ } else {
+ warn "$0: $f: $!\n";
+ }
+ }
+ return %cksum;
}
-sub safer_rename {
- my ($from, $to) = @_;
- safer_rename_silent($from, $to) or die "renaming $from to $to: $!";
+foreach my $pl (qw (keywords.pl opcode.pl embed.pl bytecode.pl
+ regcomp.pl warnings.pl autodoc.pl)) {
+ print "$^X $pl\n";
+ my %cksum0;
+ %cksum0 = do_cksum($pl) unless $pl eq 'warnings.pl'; # the files were removed
+ system "$^X $pl";
+ next if $pl eq 'warnings.pl'; # the files were removed
+ my %cksum1 = do_cksum($pl);
+ my @chg;
+ for my $f (@{ $gen{$pl} }) {
+ push(@chg, $f)
+ if !defined($cksum0{$f}) ||
+ !defined($cksum1{$f}) ||
+ $cksum0{$f} ne $cksum1{$f};
+ }
+ print "Changed: @chg\n" if @chg;
}
-1;
==== //depot/maint-5.8/perl/regen_lib.pl#1 (text) ====
Index: perl/regen_lib.pl
--- /dev/null Tue May 5 13:32:27 1998
+++ perl/regen_lib.pl Sun Mar 9 05:59:01 2003
@@ -0,0 +1,45 @@
+#!/usr/bin/perl -w
+use strict;
+use vars qw($Is_W32 $Is_OS2 $Is_Cygwin $Is_NetWare $Needs_Write);
+use Config; # Remember, this is running using an existing perl
+
+# Common functions needed by the regen scripts
+
+$Is_W32 = $^O eq 'MSWin32';
+$Is_OS2 = $^O eq 'os2';
+$Is_Cygwin = $^O eq 'cygwin';
+$Is_NetWare = $Config{osname} eq 'NetWare';
+if ($Is_NetWare) {
+ $Is_W32 = 0;
+}
+
+$Needs_Write = $Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare;
+
+sub safer_unlink {
+ my @names = @_;
+ my $cnt = 0;
+
+ my $name;
+ foreach $name (@names) {
+ next unless -e $name;
+ chmod 0777, $name if $Needs_Write;
+ ( CORE::unlink($name) and ++$cnt
+ or warn "Couldn't unlink $name: $!\n" );
+ }
+ return $cnt;
+}
+
+sub safer_rename_silent {
+ my ($from, $to) = @_;
+
+ # Some dosish systems can't rename over an existing file:
+ safer_unlink $to;
+ chmod 0600, $from if $Needs_Write;
+ rename $from, $to;
+}
+
+sub safer_rename {
+ my ($from, $to) = @_;
+ safer_rename_silent($from, $to) or die "renaming $from to $to: $!";
+}
+1;
==== //depot/maint-5.8/perl/regexec.c#14 (text) ====
Index: perl/regexec.c
--- perl/regexec.c#13~18804~ Sun Mar 2 08:22:35 2003
+++ perl/regexec.c Sun Mar 9 05:59:01 2003
@@ -852,10 +852,6 @@
char *startpos = strbeg;
t = s;
- if (prog->reganch & ROPT_UTF8) {
- PL_regdata = prog->data;
- PL_bostr = startpos;
- }
cache_re(prog);
s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
if (!s) {
==== //depot/maint-5.8/perl/sv.c#32 (text) ====
Index: perl/sv.c
--- perl/sv.c#31~18824~ Mon Mar 3 21:39:18 2003
+++ perl/sv.c Sun Mar 9 05:59:01 2003
@@ -2890,6 +2890,16 @@
return ptr;
}
+/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
+{
+ return sv_2pv_flags(sv, lp, SV_GMAGIC);
+}
+
/*
=for apidoc sv_2pv_flags
@@ -3348,6 +3358,17 @@
}
}
+/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
+ * this function provided for binary compatibility only
+ */
+
+
+STRLEN
+Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
+{
+ return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
+}
+
/*
=for apidoc sv_utf8_upgrade
@@ -3529,6 +3550,16 @@
return TRUE;
}
+/* sv_setsv() is now a macro using Perl_sv_setsv_flags();
+ * this function provided for binary compatibility only
+ */
+
+void
+Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
+{
+ sv_setsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
/*
=for apidoc sv_setsv
@@ -4266,6 +4297,16 @@
SvIVX(sv) += delta;
}
+/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
+ * this function provided for binary compatibility only
+ */
+
+void
+Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
+{
+ sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
+}
+
/*
=for apidoc sv_catpvn
@@ -4318,6 +4359,16 @@
SvSETMAGIC(sv);
}
+/* sv_catsv() is now a macro using Perl_sv_catsv_flags();
+ * this function provided for binary compatibility only
+ */
+
+void
+Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
+{
+ sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
/*
=for apidoc sv_catsv
@@ -7198,6 +7249,21 @@
return sv_2nv(sv);
}
+/* sv_pv() is now a macro using SvPV_nolen();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pv(pTHX_ SV *sv)
+{
+ STRLEN n_a;
+
+ if (SvPOK(sv))
+ return SvPVX(sv);
+
+ return sv_2pv(sv, &n_a);
+}
+
/*
=for apidoc sv_pv
@@ -7232,6 +7298,16 @@
return sv_2pv_flags(sv, lp, 0);
}
+/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
+{
+ return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
+}
+
/*
=for apidoc sv_pvn_force
@@ -7290,6 +7366,17 @@
return SvPVX(sv);
}
+/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pvbyte(pTHX_ SV *sv)
+{
+ sv_utf8_downgrade(sv,0);
+ return sv_pv(sv);
+}
+
/*
=for apidoc sv_pvbyte
@@ -7328,6 +7415,17 @@
return sv_pvn_force(sv,lp);
}
+/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pvutf8(pTHX_ SV *sv)
+{
+ sv_utf8_upgrade(sv);
+ return sv_pv(sv);
+}
+
/*
=for apidoc sv_pvutf8
@@ -7794,6 +7892,44 @@
return FALSE;
}
+/*
+=for apidoc sv_setpviv
+
+Copies an integer into the given SV, also updating its string value.
+Does not handle 'set' magic. See C<sv_setpviv_mg>.
+
+=cut
+*/
+
+void
+Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
+{
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
+}
+
+/*
+=for apidoc sv_setpviv_mg
+
+Like C<sv_setpviv>, but also handles 'set' magic.
+
+=cut
+*/
+
+void
+Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
+{
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
+ SvSETMAGIC(sv);
+}
+
#if defined(PERL_IMPLICIT_CONTEXT)
/* pTHX_ magic can't cope with varargs, so this is a no-context
@@ -8082,6 +8218,7 @@
STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
+ I32 osvix = svix;
bool is_utf8 = FALSE; /* is this item utf8? */
#ifdef HAS_LDBL_SPRINTF_BUG
/* This is to try to fix a bug with irix/nonstop-ux/powerux and
@@ -8833,7 +8970,6 @@
default:
unknown:
- vectorize = FALSE;
if (!args && ckWARN(WARN_PRINTF) &&
(PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
@@ -8865,6 +9001,7 @@
p += elen;
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
+ svix = osvix;
continue; /* not "break" */
}
==== //depot/maint-5.8/perl/t/op/eval.t#5 (xtext) ====
Index: perl/t/op/eval.t
--- perl/t/op/eval.t#4~18791~ Fri Feb 28 12:05:43 2003
+++ perl/t/op/eval.t Sun Mar 9 05:59:01 2003
@@ -5,7 +5,7 @@
@INC = '../lib';
}
-print "1..87\n";
+print "1..88\n";
eval 'print "ok 1\n";';
@@ -419,3 +419,6 @@
$test++;
}
}
+
+sub Foo {} print Foo(eval {});
+print "ok ",$test++," - #20798 (used to dump core)\n";
==== //depot/maint-5.8/perl/t/op/pat.t#14 (xtext) ====
Index: perl/t/op/pat.t
--- perl/t/op/pat.t#13~18808~ Sun Mar 2 13:29:38 2003
+++ perl/t/op/pat.t Sun Mar 9 05:59:01 2003
@@ -6,7 +6,7 @@
$| = 1;
-print "1..994\n";
+print "1..996\n";
BEGIN {
chdir 't' if -d 't';
@@ -3145,5 +3145,18 @@
"[perl #21411] (??{ .. }) corrupts split's stack")
}
-# last test 994
+{
+ ok("\x{100}\n" =~ /\x{100}\n$/, "UTF8 length cache and fbm_compile");
+}
+
+{
+ package Str;
+ use overload q/""/ => sub { ${$_[0]}; };
+ sub new { my ($c, $v) = @_; bless \$v, $c; }
+
+ package main;
+ $_ = Str->new("a\x{100}/\x{100}b");
+ ok(join(":", /\b(.)\x{100}/g) eq "a:/", "re_intuit_start and PL_bostr");
+}
+# last test 996
==== //depot/maint-5.8/perl/t/op/sprintf.t#4 (xtext) ====
Index: perl/t/op/sprintf.t
--- perl/t/op/sprintf.t#3~18700~ Thu Feb 13 06:55:54 2003
+++ perl/t/op/sprintf.t Sun Mar 9 05:59:01 2003
@@ -359,7 +359,7 @@
>%2$d %d %d< >[12, 34]< >34 12 34<
>%3$d %d %d< >[12, 34, 56]< >56 12 34<
>%2$*3$d %d< >[12, 34, 3]< > 34 12<
->%*3$2$d %d< >[12, 34, 3]< >%*3$2$d 34 INVALID<
+>%*3$2$d %d< >[12, 34, 3]< >%*3$2$d 12 INVALID<
>%2$d< >12< >0 UNINIT<
>%0$d< >12< >%0$d INVALID<
>%1$$d< >12< >%1$$d INVALID<
@@ -374,4 +374,9 @@
>%vs,%d< >[1, 2, 3]< >1,2<
>%v_< >''< >%v_ INVALID<
>%v#x< >''< >%v#x INVALID<
->%v02x< >"foo\n"< >66.6f.6f.0a<
+>%v02x< >"foo\n"< >66.6f.6f.0a<
+>%V-%s< >["Hello"]< >%V-Hello INVALID<
+>%K %d %d< >[13, 29]< >%K 13 29 INVALID<
+>%*.*K %d< >[13, 29, 76]< >%*.*K 13 INVALID<
+>%4$K %d< >[45, 67]< >%4$K 45 INVALID<
+>%d %K %d< >[23, 45]< >23 %K 45 INVALID<
==== //depot/maint-5.8/perl/toke.c#12 (text) ====
Index: perl/toke.c
--- perl/toke.c#11~18804~ Sun Mar 2 08:22:35 2003
+++ perl/toke.c Sun Mar 9 05:59:01 2003
@@ -4159,8 +4159,29 @@
}
#endif
#ifdef PERLIO_LAYERS
- if (UTF && !IN_BYTES)
- PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
+ if (!IN_BYTES) {
+ if (UTF)
+ PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
+ else if (PL_encoding) {
+ SV *name;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ EXTEND(SP, 1);
+ XPUSHs(PL_encoding);
+ PUTBACK;
+ call_method("name", G_SCALAR);
+ SPAGAIN;
+ name = POPs;
+ PUTBACK;
+ PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
+ Perl_form(aTHX_ ":encoding(%"SVf")",
+ name));
+ FREETMPS;
+ LEAVE;
+ }
+ }
#endif
PL_rsfp = Nullfp;
}
==== //depot/maint-5.8/perl/util.c#15 (text) ====
Index: perl/util.c
--- perl/util.c#14~18804~ Sun Mar 2 08:22:35 2003
+++ perl/util.c Sun Mar 9 05:59:01 2003
@@ -357,8 +357,12 @@
I32 rarest = 0;
U32 frequency = 256;
- if (flags & FBMcf_TAIL)
+ if (flags & FBMcf_TAIL) {
+ MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
+ if (mg && mg->mg_len >= 0)
+ mg->mg_len++;
+ }
s = (U8*)SvPV_force(sv, len);
(void)SvUPGRADE(sv, SVt_PVBM);
if (len == 0) /* TAIL might be on a zero-length string. */
==== //depot/maint-5.8/perl/vms/vms.c#3 (text) ====
Index: perl/vms/vms.c
--- perl/vms/vms.c#2~18744~ Tue Feb 18 06:46:18 2003
+++ perl/vms/vms.c Sun Mar 9 05:59:01 2003
@@ -137,6 +137,36 @@
static int tz_updated = 1;
#endif
+/* my_maxidx
+ * Routine to retrieve the maximum equivalence index for an input
+ * logical name. Some calls to this routine have no knowledge if
+ * the variable is a logical or not. So on error we return a max
+ * index of zero.
+ */
+/*{{{int my_maxidx(char *lnm) */
+static int
+my_maxidx(char *lnm)
+{
+ int status;
+ int midx;
+ int attr = LNM$M_CASE_BLIND;
+ struct dsc$descriptor lnmdsc;
+ struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
+ {0, 0, 0, 0}};
+
+ lnmdsc.dsc$w_length = strlen(lnm);
+ lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
+ lnmdsc.dsc$b_class = DSC$K_CLASS_S;
+ lnmdsc.dsc$a_pointer = lnm;
+
+ status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
+ if ((status & 1) == 0)
+ midx = 0;
+
+ return (midx);
+}
+/*}}}*/
+
/*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct
dsc$descriptor_s **tabvec, unsigned long int flags) */
int
Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
@@ -145,6 +175,7 @@
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
unsigned long int retsts, attr = LNM$M_CASE_BLIND;
+ int midx;
unsigned char acmode;
struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
@@ -174,7 +205,7 @@
# endif
#endif
- if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
+ if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
}
for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
@@ -253,22 +284,41 @@
}
}
else if (!ivlnm) {
- retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
- if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
- if (retsts == SS$_NOLOGNAM) continue;
- /* PPFs have a prefix */
- if (
+ if (idx == 0) {
+ midx = my_maxidx((char *) lnm);
+ for (idx = 0, cp1 = eqv; idx <= midx; idx++) {
+ lnmlst[1].bufadr = cp1;
+ eqvlen = 0;
+ retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
+ if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
+ if (retsts == SS$_NOLOGNAM) break;
+ /* PPFs have a prefix */
+ if (
#if INTSIZE == 4
- *((int *)uplnm) == *((int *)"SYS$") &&
+ *((int *)uplnm) == *((int *)"SYS$") &&
#endif
- eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
- ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
- (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
- (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
- (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
- memcpy(eqv,eqv+4,eqvlen-4);
- eqvlen -= 4;
+ eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
+ ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
+ (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
+ (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
+ (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
+ memcpy(eqv,eqv+4,eqvlen-4);
+ eqvlen -= 4;
+ }
+ cp1 += eqvlen;
+ *cp1 = '\0';
+ }
+ if ((retsts == SS$_IVLOGNAM) ||
+ (retsts == SS$_NOLOGNAM)) { continue; }
}
+ else {
+ idx -= 1;
+ retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
+ if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
+ if (retsts == SS$_NOLOGNAM) continue;
+ eqv[eqvlen] = '\0';
+ }
+ eqvlen = strlen(eqv);
break;
}
}
@@ -309,20 +359,33 @@
char *
Perl_my_getenv(pTHX_ const char *lnm, bool sys)
{
- static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
+ static char *__my_getenv_eqv = NULL;
char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
unsigned long int idx = 0;
int trnsuccess, success, secure, saverr, savvmserr;
+ int midx;
SV *tmpsv;
+ midx = my_maxidx((char *) lnm) + 1;
+
if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
/* Set up a temporary buffer for the return value; Perl will
* clean it up at the next statement transition */
- tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
+ tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
if (!tmpsv) return NULL;
eqv = SvPVX(tmpsv);
}
- else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
+ else {
+ /* Assume no interpreter ==> single thread */
+ if (__my_getenv_eqv != NULL) {
+ Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ else {
+ New(1380,__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ eqv = __my_getenv_eqv;
+ }
+
for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
getcwd(eqv,LNM$C_NAMLENGTH);
@@ -332,7 +395,7 @@
if ((cp2 = strchr(lnm,';')) != NULL) {
strcpy(uplnm,lnm);
uplnm[cp2-lnm] = '\0';
- idx = strtoul(cp2+1,NULL,0);
+ idx = strtoul(cp2+1,NULL,0) + 1;
lnm = uplnm;
}
/* Impose security constraints only if tainting */
@@ -367,18 +430,31 @@
{
char *buf, *cp1, *cp2;
unsigned long idx = 0;
- static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
+ int midx;
+ static char *__my_getenv_len_eqv = NULL;
int secure, saverr, savvmserr;
SV *tmpsv;
+ midx = my_maxidx((char *) lnm) + 1;
+
if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
/* Set up a temporary buffer for the return value; Perl will
* clean it up at the next statement transition */
- tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
+ tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
if (!tmpsv) return NULL;
buf = SvPVX(tmpsv);
}
- else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
+ else {
+ /* Assume no interpreter ==> single thread */
+ if (__my_getenv_len_eqv != NULL) {
+ Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ else {
+ New(1381,__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
+ }
+ buf = __my_getenv_len_eqv;
+ }
+
for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
getcwd(buf,LNM$C_NAMLENGTH);
@@ -389,7 +465,7 @@
if ((cp2 = strchr(lnm,';')) != NULL) {
strcpy(buf,lnm);
buf[cp2-lnm] = '\0';
- idx = strtoul(cp2+1,NULL,0);
+ idx = strtoul(cp2+1,NULL,0) + 1;
lnm = buf;
}
if (sys) {
@@ -633,9 +709,11 @@
int
Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
{
- char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+ char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2, *c;
unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
+ int nseg = 0, j;
unsigned long int retsts, usermode = PSL$C_USER;
+ struct itmlst_3 *ile, *ilist;
struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
@@ -721,12 +799,42 @@
else {
if (!*eqv) eqvdsc.dsc$w_length = 1;
if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
- eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
- if (ckWARN(WARN_MISC)) {
- Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long.
Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
+
+ nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
+ if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long.
Truncating to %i bytes",
+ lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
+ eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
+ nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
+ }
+
+ New(1382,ilist,nseg+1,struct itmlst_3);
+ ile = ilist;
+ if (!ile) {
+ set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
+ return SS$_INSFMEM;
}
+ memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
+
+ for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c +=
LNM$C_NAMLENGTH) {
+ ile->itmcode = LNM$_STRING;
+ ile->bufadr = c;
+ if ((j+1) == nseg) {
+ ile->buflen = strlen(c);
+ /* in case we are truncating one that's too long */
+ if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
+ }
+ else {
+ ile->buflen = LNM$C_NAMLENGTH;
+ }
+ }
+
+ retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
+ Safefree (ilist);
+ }
+ else {
+ retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
}
- retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
}
}
}
End of Patch.
