Change 18617 by jhi@kosh on 2003/02/01 20:05:08
Integrate:
[ 18616]
Integrate from perlio:
[ 18591]
PERL_IMPLICIT_SYS does NOT vector PerlIO_xxx but PerlSIO_xxx, so
correct XSUB.h
[ 18611]
Michael Schroeder's fix for re-try if stdio ops after
interrupts. (Calls to PERL_ASYNC_CHECK added by NI-S).
[ 18612]
PerlIO friendly version of speed up of $/ = undef case.
[ 18613]
fflush() before invalidating stdio's fileno.
[ 18615]
Don't free thread before using it, breaks platforms that
trust that I really want to free what I free, (like HPUX
and AIX).
[ 18614]
Subject: Re: bleadperl: PerlIOStdio_invalidate_fileno breaks fclose semantics
From: Nick Ing-Simmons <[EMAIL PROTECTED]>
Date: Sat, 01 Feb 2003 13:03:52 +0000
Message-Id: <[EMAIL PROTECTED]>
[ 18609]
Go even further (back) than change #18608 and revert
to the 5.8.0 code, since otherwise split.t #40 fails.
The four new tests of pat.t should keep us more honest.
[ 18608]
Subject: [FIX] Re: UTF-8 failures (surprise!)
From: Enache Adrian <[EMAIL PROTECTED]>
Date: Fri, 31 Jan 2003 09:20:59 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 18607]
Fix typo in version check ($[ to $]).
[ 18606]
Subject: [PATCH] Upper<->Lower case mistake in perlunicode.pod ?
From: [EMAIL PROTECTED]
Date: Thu, 30 Jan 2003 12:40:53 -0300
Message-ID: <[EMAIL PROTECTED]>
[ 18605]
[perl #20616] code example in the FAQ that isn't strict-friendly.
Subject: [perl #20616] Tie::IxHash doc error.
From: Beckett Richard-qswi266 (via RT) <[EMAIL PROTECTED]>
Date: 30 Jan 2003 11:43:17 -0000
Message-Id: <[EMAIL PROTECTED]>
[ 18604]
FAQ sync.
[ 18603]
Subject: [FIX] Re: UTF-8 failures (surprise!)
From: Enache Adrian <[EMAIL PROTECTED]>
Date: Thu, 30 Jan 2003 10:48:09 +0200
Message-ID: <[EMAIL PROTECTED]>
Fix for half of the failures, with an expanded test.
[ 18602]
Updates to the openbsd hints
Subject: [perl #20606] [no subject]
Date: 29 Jan 2003 18:38:37 -0000
From: "Todd C. Miller" (via RT) <[EMAIL PROTECTED]>
Message-Id: <[EMAIL PROTECTED]>
[ 18599]
Fix a very small memory leak in op_free, by reserving the
case op_seq == (U16)-1 for the compiler backend
Subject: Re: Freeing code
From: "Paul Johnson" <[EMAIL PROTECTED]>
Date: Tue, 28 Jan 2003 14:13:09 +0100 (CET)
Message-ID: <[EMAIL PROTECTED]>
[ 18597]
Subject: Re: [perl #20274] perlbug requires dynamic loading
From: Slaven Rezic <[EMAIL PROTECTED]>
Date: 14 Jan 2003 20:58:54 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 18596]
Introduce the PUSHSUB_DB macro, equivalent to PUSHSUB, but
without the lval context tweak. Used in OP_DBSTATE.
Subject: Re: [PATCH] Re: change #9754: 5 x slowdown for perl -d
From: Dave Mitchell <[EMAIL PROTECTED]>
Date: Sun, 26 Jan 2003 17:42:42 +0000
Message-ID: <[EMAIL PROTECTED]>
[ 18594]
Update the pod list for Plan 9.
[ 18593]
When we copy things out of a hash and increment the
refcount of the shared scalar, we really must protect
that refcount increase with a lock, or else it might not
happen. Fixes segfault when objects would prematurely
be killed.
[ 18588]
Lest people get worried about not having PerlIO.
Affected files ...
... //depot/maint-5.8/perl/XSUB.h#4 integrate
... //depot/maint-5.8/perl/cop.h#3 integrate
... //depot/maint-5.8/perl/ext/Storable/t/restrict.t#3 integrate
... //depot/maint-5.8/perl/ext/Sys/Hostname/Hostname.pm#3 integrate
... //depot/maint-5.8/perl/ext/threads/shared/shared.xs#3 integrate
... //depot/maint-5.8/perl/ext/threads/threads.xs#6 integrate
... //depot/maint-5.8/perl/hints/openbsd.sh#3 integrate
... //depot/maint-5.8/perl/lib/utf8.t#3 integrate
... //depot/maint-5.8/perl/op.c#7 integrate
... //depot/maint-5.8/perl/perlio.c#10 integrate
... //depot/maint-5.8/perl/plan9/mkfile#2 integrate
... //depot/maint-5.8/perl/pod/perlfaq.pod#4 integrate
... //depot/maint-5.8/perl/pod/perlfaq2.pod#4 integrate
... //depot/maint-5.8/perl/pod/perlfaq3.pod#4 integrate
... //depot/maint-5.8/perl/pod/perlfaq4.pod#5 integrate
... //depot/maint-5.8/perl/pod/perlfaq5.pod#5 integrate
... //depot/maint-5.8/perl/pod/perlfaq7.pod#4 integrate
... //depot/maint-5.8/perl/pod/perlfaq8.pod#4 integrate
... //depot/maint-5.8/perl/pod/perlunicode.pod#6 integrate
... //depot/maint-5.8/perl/pod/perluniintro.pod#4 integrate
... //depot/maint-5.8/perl/pp_ctl.c#9 integrate
... //depot/maint-5.8/perl/regexec.c#8 integrate
... //depot/maint-5.8/perl/sv.c#22 integrate
... //depot/maint-5.8/perl/t/op/pat.t#8 integrate
Differences ...
==== //depot/maint-5.8/perl/XSUB.h#4 (text) ====
Index: perl/XSUB.h
--- perl/XSUB.h#3~18347~ Sun Dec 22 22:37:31 2002
+++ perl/XSUB.h Sat Feb 1 12:05:08 2003
@@ -385,32 +385,32 @@
# define stdin PerlSIO_stdin
# define stdout PerlSIO_stdout
# define stderr PerlSIO_stderr
-# define fopen PerlIO_open
-# define fclose PerlIO_close
-# define feof PerlIO_eof
-# define ferror PerlIO_error
-# define fclearerr PerlIO_clearerr
-# define getc PerlIO_getc
-# define fputc(c, f) PerlIO_putc(f,c)
-# define fputs(s, f) PerlIO_puts(f,s)
-# define fflush PerlIO_flush
-# define ungetc(c, f) PerlIO_ungetc((f),(c))
-# define fileno PerlIO_fileno
-# define fdopen PerlIO_fdopen
-# define freopen PerlIO_reopen
-# define fread(b,s,c,f) PerlIO_read((f),(b),(s*c))
-# define fwrite(b,s,c,f) PerlIO_write((f),(b),(s*c))
+# define fopen PerlSIO_fopen
+# define fclose PerlSIO_fclose
+# define feof PerlSIO_feof
+# define ferror PerlSIO_ferror
+# define fclearerr PerlSIO_clearerr
+# define getc PerlSIO_getc
+# define fputc PerlSIO_fputc
+# define fputs PerlSIO_fputs
+# define fflush PerlSIO_fflush
+# define ungetc PerlSIO_ungetc
+# define fileno PerlSIO_fileno
+# define fdopen PerlSIO_fdopen
+# define freopen PerlSIO_freopen
+# define fread PerlSIO_fread
+# define fwrite PerlSIO_fwrite
# define setbuf PerlSIO_setbuf
# define setvbuf PerlSIO_setvbuf
# define setlinebuf PerlSIO_setlinebuf
# define stdoutf PerlSIO_stdoutf
# define vfprintf PerlSIO_vprintf
-# define ftell PerlIO_tell
-# define fseek PerlIO_seek
-# define fgetpos PerlIO_getpos
-# define fsetpos PerlIO_setpos
-# define frewind PerlIO_rewind
-# define tmpfile PerlIO_tmpfile
+# define ftell PerlSIO_ftell
+# define fseek PerlSIO_fseek
+# define fgetpos PerlSIO_fgetpos
+# define fsetpos PerlSIO_fsetpos
+# define frewind PerlSIO_rewind
+# define tmpfile PerlSIO_tmpfile
# define access PerlLIO_access
# define chmod PerlLIO_chmod
# define chsize PerlLIO_chsize
==== //depot/maint-5.8/perl/cop.h#3 (text) ====
Index: perl/cop.h
--- perl/cop.h#2~18080~ Sun Nov 3 21:23:04 2002
+++ perl/cop.h Sat Feb 1 12:05:08 2003
@@ -117,12 +117,22 @@
SV ** oldcurpad;
};
-#define PUSHSUB(cx) \
+/* base for the next two macros. Don't use directly */
+#define PUSHSUB_BASE(cx) \
cx->blk_sub.cv = cv; \
cx->blk_sub.olddepth = CvDEPTH(cv); \
- cx->blk_sub.hasargs = hasargs; \
+ cx->blk_sub.hasargs = hasargs;
+
+#define PUSHSUB(cx) \
+ PUSHSUB_BASE(cx) \
cx->blk_sub.lval = PL_op->op_private & \
(OPpLVAL_INTRO|OPpENTERSUB_INARGS);
+
+/* variant for use by OP_DBSTATE, where op_private holds hint bits */
+#define PUSHSUB_DB(cx) \
+ PUSHSUB_BASE(cx) \
+ cx->blk_sub.lval = 0;
+
#define PUSHFORMAT(cx) \
cx->blk_sub.cv = cv; \
==== //depot/maint-5.8/perl/ext/Storable/t/restrict.t#3 (text) ====
Index: perl/ext/Storable/t/restrict.t
--- perl/ext/Storable/t/restrict.t#2~18082~ Sun Nov 3 21:38:52 2002
+++ perl/ext/Storable/t/restrict.t Sat Feb 1 12:05:08 2003
@@ -16,7 +16,7 @@
exit 0;
}
} else {
- if ($[ < 5.005) {
+ if ($] < 5.005) {
print "1..0 # Skip: No Hash::Util pre 5.005\n";
exit 0;
# And doing this seems on 5.004 seems to create bogus warnings about
==== //depot/maint-5.8/perl/ext/Sys/Hostname/Hostname.pm#3 (text) ====
Index: perl/ext/Sys/Hostname/Hostname.pm
--- perl/ext/Sys/Hostname/Hostname.pm#2~18080~ Sun Nov 3 21:23:04 2002
+++ perl/ext/Sys/Hostname/Hostname.pm Sat Feb 1 12:05:08 2003
@@ -5,17 +5,27 @@
use Carp;
require Exporter;
-use XSLoader ();
require AutoLoader;
our @ISA = qw/ Exporter AutoLoader /;
our @EXPORT = qw/ hostname /;
-our $VERSION = '1.1';
+our $VERSION;
our $host;
-XSLoader::load 'Sys::Hostname', $VERSION;
+BEGIN {
+ $VERSION = '1.1';
+ {
+ local $SIG{__DIE__};
+ eval {
+ require XSLoader;
+ XSLoader::load('Sys::Hostname', $VERSION);
+ };
+ warn $@ if $@;
+ }
+}
+
sub hostname {
@@ -23,7 +33,7 @@
return $host if defined $host;
# method 1' - try to ask the system
- $host = ghname();
+ $host = ghname() if defined &ghname;
return $host if defined $host;
if ($^O eq 'VMS') {
==== //depot/maint-5.8/perl/ext/threads/shared/shared.xs#3 (text) ====
Index: perl/ext/threads/shared/shared.xs
--- perl/ext/threads/shared/shared.xs#2~18424~ Fri Jan 3 19:20:08 2003
+++ perl/ext/threads/shared/shared.xs Sat Feb 1 12:05:08 2003
@@ -672,7 +672,9 @@
MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
name, namlen);
+ ENTER_LOCK;
SvREFCNT_inc(SHAREDSvPTR(shared));
+ LEAVE_LOCK;
nmg->mg_flags |= MGf_DUP;
return 1;
}
==== //depot/maint-5.8/perl/ext/threads/threads.xs#6 (xtext) ====
Index: perl/ext/threads/threads.xs
--- perl/ext/threads/threads.xs#5~18433~ Fri Jan 3 20:49:38 2003
+++ perl/ext/threads/threads.xs Sat Feb 1 12:05:08 2003
@@ -91,7 +91,6 @@
void
Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
{
- PerlInterpreter* destroyperl = NULL;
MUTEX_LOCK(&thread->mutex);
if (!thread->next) {
Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
@@ -123,26 +122,25 @@
#endif
MUTEX_UNLOCK(&create_destruct_mutex);
/* Thread is now disowned */
- if (thread->interp) {
+
+ if(thread->interp) {
dTHXa(thread->interp);
+ ithread* current_thread;
PERL_SET_CONTEXT(thread->interp);
+ PERL_THREAD_GETSPECIFIC(self_key,current_thread);
+ PERL_THREAD_SETSPECIFIC(self_key,thread);
SvREFCNT_dec(thread->params);
thread->params = Nullsv;
- destroyperl = thread->interp;
+ perl_destruct(thread->interp);
+ perl_free(thread->interp);
thread->interp = NULL;
+ PERL_THREAD_SETSPECIFIC(self_key,current_thread);
+
}
MUTEX_UNLOCK(&thread->mutex);
MUTEX_DESTROY(&thread->mutex);
PerlMemShared_free(thread);
- if(destroyperl) {
- ithread* current_thread;
- PERL_THREAD_GETSPECIFIC(self_key,current_thread);
- PERL_THREAD_SETSPECIFIC(self_key,thread);
- perl_destruct(destroyperl);
- perl_free(destroyperl);
- PERL_THREAD_SETSPECIFIC(self_key,current_thread);
- }
PERL_SET_CONTEXT(aTHX);
}
==== //depot/maint-5.8/perl/hints/openbsd.sh#3 (text) ====
Index: perl/hints/openbsd.sh
--- perl/hints/openbsd.sh#2~18286~ Wed Dec 11 06:43:36 2002
+++ perl/hints/openbsd.sh Sat Feb 1 12:05:08 2003
@@ -11,17 +11,20 @@
# OpenBSD has a better malloc than perl...
test "$usemymalloc" || usemymalloc='n'
-# Currently, vfork(2) is not a real win over fork(2) but this will
-# change starting with OpenBSD 2.7.
-usevfork='true'
-
-# setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS versions
-# in 4.4BSD. Configure will find these but they are just emulated
-# and do not have the same semantics as in 4.3BSD.
-d_setregid=$undef
-d_setreuid=$undef
-d_setrgid=$undef
-d_setruid=$undef
+# Currently, vfork(2) is not a real win over fork(2).
+usevfork="$undef"
+
+# In OpenBSD < 3.3, the setre?[ug]id() are emulated using the
+# _POSIX_SAVED_IDS functionality which does not have the same
+# semantics as 4.3BSD. Starting with OpenBSD 3.3, the original
+# semantics have been restored.
+case "$osvers" in
+[0-2].*|3.[0-2])
+ d_setregid=$undef
+ d_setreuid=$undef
+ d_setrgid=$undef
+ d_setruid=$undef
+esac
#
# Not all platforms support dynamic loading...
@@ -32,7 +35,7 @@
#
ARCH=`arch | sed 's/^OpenBSD.//'`
case "${ARCH}-${osvers}" in
-alpha-2.[0-8]|mips-2.[0-8]|powerpc-2.[0-7]|m88k-*|vax-*)
+alpha-2.[0-8]|mips-2.[0-8]|powerpc-2.[0-7]|m88k-*|hppa-*|vax-*)
test -z "$usedl" && usedl=$undef
;;
*)
@@ -85,6 +88,9 @@
m88k)
optimize='-O0'
;;
+hppa)
+ optimize='-O0'
+ ;;
*)
test "$optimize" || optimize='-O2'
;;
@@ -98,11 +104,6 @@
# any openbsd version dependencies with pthreads?
ccflags="-pthread $ccflags"
ldflags="-pthread $ldflags"
- # Add -lpthread. Also change from -lc to -lc_r
- libswanted="$libswanted pthread"
- libswanted=`echo " $libswanted "| sed -e 's/ c / c_r /' -e 's/^ //' -e 's/
$//'`
- # This is strange.
- usevfork="$undef"
esac
EOCBU
==== //depot/maint-5.8/perl/lib/utf8.t#3 (text) ====
Index: perl/lib/utf8.t
--- perl/lib/utf8.t#2~18126~ Sat Nov 9 11:00:47 2002
+++ perl/lib/utf8.t Sat Feb 1 12:05:08 2003
@@ -37,7 +37,7 @@
#
#
-plan tests => 95;
+plan tests => 98;
{
# bug id 20001009.001
@@ -272,7 +272,7 @@
# before the patch, the eval died with an error like:
# "my" variable $strict::VERSION can't be in a package
#
-ok('' eq runperl(prog => <<'CODE'));
+ok('' eq runperl(prog => <<'CODE'), "change #17928");
my $code = qq{ my \$\xe3\x83\x95\xe3\x83\xbc = 5; };
{
use utf8;
@@ -280,3 +280,46 @@
print $@ if $@;
}
CODE
+
+{
+ use utf8;
+ $a = <<'END';
+0 ....... 1 ....... 2 ....... 3 ....... 4 ....... 5 ....... 6 ....... 7 .......
+END
+ my (@i, $s);
+
+ @i = ();
+ push @i, $s = index($a, '6'); # 60
+ push @i, $s = index($a, '.', $s); # next . after 60 is 62
+ push @i, $s = index($a, '5'); # 50
+ push @i, $s = index($a, '.', $s); # next . after 52 is 52
+ push @i, $s = index($a, '7'); # 70
+ push @i, $s = index($a, '.', $s); # next . after 70 is 72
+ push @i, $s = index($a, '4'); # 40
+ push @i, $s = index($a, '.', $s); # next . after 40 is 42
+ is("@i", "60 62 50 52 70 72 40 42", "utf8 heredoc index");
+
+ @i = ();
+ push @i, $s = rindex($a, '6'); # 60
+ push @i, $s = rindex($a, '.', $s); # previous . before 60 is 58
+ push @i, $s = rindex($a, '5'); # 50
+ push @i, $s = rindex($a, '.', $s); # previous . before 52 is 48
+ push @i, $s = rindex($a, '7'); # 70
+ push @i, $s = rindex($a, '.', $s); # previous . before 70 is 68
+ push @i, $s = rindex($a, '4'); # 40
+ push @i, $s = rindex($a, '.', $s); # previous . before 40 is 38
+ is("@i", "60 58 50 48 70 68 40 38", "utf8 heredoc rindex");
+
+ @i = ();
+ push @i, $s = index($a, '6'); # 60
+ push @i, index($a, '.', $s); # next . after 60 is 62
+ push @i, rindex($a, '.', $s); # previous . before 60 is 58
+ push @i, $s = rindex($a, '5'); # 60
+ push @i, index($a, '.', $s); # next . after 50 is 52
+ push @i, rindex($a, '.', $s); # previous . before 50 is 48
+ push @i, $s = index($a, '7', $s); # 70
+ push @i, index($a, '.', $s); # next . after 70 is 72
+ push @i, rindex($a, '.', $s); # previous . before 70 is 68
+ is("@i", "60 62 58 50 52 48 70 72 68", "utf8 heredoc index and rindex");
+}
+
==== //depot/maint-5.8/perl/op.c#7 (text) ====
Index: perl/op.c
--- perl/op.c#6~18383~ Wed Jan 1 09:02:29 2003
+++ perl/op.c Sat Feb 1 12:05:08 2003
@@ -7040,8 +7040,10 @@
for (; o; o = o->op_next) {
if (o->op_seq)
break;
- if (!PL_op_seqmax)
- PL_op_seqmax++;
+ /* The special value -1 is used by the B::C compiler backend to indicate
+ * that an op is statically defined and should not be freed */
+ if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
+ PL_op_seqmax = 1;
PL_op = o;
switch (o->op_type) {
case OP_SETSTATE:
==== //depot/maint-5.8/perl/perlio.c#10 (text) ====
Index: perl/perlio.c
--- perl/perlio.c#9~18576~ Thu Jan 23 05:52:39 2003
+++ perl/perlio.c Sat Feb 1 12:05:08 2003
@@ -666,8 +666,13 @@
} else {
SV *pkgsv = newSVpvn("PerlIO", 6);
SV *layer = newSVpvn(name, len);
- ENTER;
+ CV *cv = get_cv("PerlIO::Layer::NoWarnings", FALSE);
+ ENTER;
SAVEINT(PL_in_load_module);
+ if (cv) {
+ SAVESPTR(PL_warnhook);
+ PL_warnhook = (SV *) cv;
+ }
PL_in_load_module++;
/*
* The two SVs are magically freed by load_module
@@ -770,6 +775,17 @@
return sv;
}
+XS(XS_PerlIO__Layer__NoWarnings)
+{
+ /* This is used as a %SIG{__WARN__} handler to supress warnings
+ during loading of layers.
+ */
+ dXSARGS;
+ if (items)
+ PerlIO_debug("warning:%s\n",SvPV_nolen(ST(0)));
+ XSRETURN(0);
+}
+
XS(XS_PerlIO__Layer__find)
{
dXSARGS;
@@ -1012,6 +1028,7 @@
__FILE__);
#endif
newXS("PerlIO::Layer::find", XS_PerlIO__Layer__find, __FILE__);
+ newXS("PerlIO::Layer::NoWarnings", XS_PerlIO__Layer__NoWarnings, __FILE__);
}
PerlIO_funcs *
@@ -2684,13 +2701,91 @@
return f;
}
+static int
+PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
+{
+ /* XXX this could use PerlIO_canset_fileno() and
+ * PerlIO_set_fileno() support from Configure
+ */
+# if defined(__GLIBC__)
+ /* There may be a better way for GLIBC:
+ - libio.h defines a flag to not close() on cleanup
+ */
+ f->_fileno = -1;
+ return 1;
+# elif defined(__sun__)
+# if defined(_LP64)
+ /* On solaris, if _LP64 is defined, the FILE structure is this:
+ *
+ * struct FILE {
+ * long __pad[16];
+ * };
+ *
+ * It turns out that the fd is stored in the top 32 bits of
+ * file->__pad[4]. The lower 32 bits contain flags. file->pad[5] appears
+ * to contain a pointer or offset into another structure. All the
+ * remaining fields are zero.
+ *
+ * We set the top bits to -1 (0xFFFFFFFF).
+ */
+ f->__pad[4] |= 0xffffffff00000000L;
+ assert(fileno(f) == 0xffffffff);
+# else /* !defined(_LP64) */
+ /* _file is just a unsigned char :-(
+ Not clear why we dup() rather than using -1
+ even if that would be treated as 0xFF - so will
+ a dup fail ...
+ */
+ f->_file = PerlLIO_dup(fileno(f));
+# endif /* defined(_LP64) */
+ return 1;
+# elif defined(__hpux)
+ f->__fileH = 0xff;
+ f->__fileL = 0xff;
+ return 1;
+ /* Next one ->_file seems to be a reasonable fallback, i.e. if
+ your platform does not have special entry try this one.
+ [For OSF only have confirmation for Tru64 (alpha)
+ but assume other OSFs will be similar.]
+ */
+# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
+ f->_file = -1;
+ return 1;
+# elif defined(__FreeBSD__)
+ /* There may be a better way on FreeBSD:
+ - we could insert a dummy func in the _close function entry
+ f->_close = (int (*)(void *)) dummy_close;
+ */
+ f->_file = -1;
+ return 1;
+# elif defined(__CYGWIN__)
+ /* There may be a better way on CYGWIN:
+ - we could insert a dummy func in the _close function entry
+ f->_close = (int (*)(void *)) dummy_close;
+ */
+ f->_file = -1;
+ return 1;
+# elif defined(WIN32)
+# if defined(__BORLANDC__)
+ f->fd = PerlLIO_dup(fileno(f));
+# else
+ f->_file = -1;
+# endif
+ return 1;
+# else
+#if 0
+ /* Sarathy's code did this - we fall back to a dup/dup2 hack
+ (which isn't thread safe) instead
+ */
+# error "Don't know how to set FILE.fileno on your platform"
+#endif
+ return 0;
+# endif
+}
+
IV
PerlIOStdio_close(pTHX_ PerlIO *f)
{
-#ifdef SOCKS5_VERSION_NAME
- int optval;
- Sock_size_t optlen = sizeof(int);
-#endif
FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
if (!stdio) {
errno = EBADF;
@@ -2698,62 +2793,94 @@
}
else {
int fd = fileno(stdio);
- int dupfd = -1;
- IV result;
+ int socksfd = 0;
+ int invalidate = 0;
+ IV result = 0;
+ int saveerr = 0;
+ int dupfd = 0;
+#ifdef SOCKS5_VERSION_NAME
+ /* Socks lib overrides close() but stdio isn't linked to
+ that library (though we are) - so we must call close()
+ on sockets on stdio's behalf.
+ */
+ int optval;
+ Sock_size_t optlen = sizeof(int);
+ if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) {
+ socksfd = 1;
+ invalidate = 1;
+ }
+#endif
if (PerlIOUnix_refcnt_dec(fd) > 0) {
/* File descriptor still in use */
- if (fd < 3) {
- /* For STD* handles don't close the stdio at all */
+ invalidate = 1;
+ socksfd = 0;
+ }
+ if (invalidate) {
+ /* For STD* handles don't close the stdio at all
+ this is because we have shared the FILE * too
+ */
+ if (stdio == stdin) {
+ /* Some stdios are buggy fflush-ing inputs */
+ return 0;
+ }
+ else if (stdio == stdout || stdio == stderr) {
return PerlIO_flush(f);
}
- else {
- /* Tricky - must fclose(stdio) to free memory but not close(fd) */
+ /* Tricky - must fclose(stdio) to free memory but not close(fd)
+ Use Sarathy's trick from maint-5.6 to invalidate the
+ fileno slot of the FILE *
+ */
+ result = PerlIO_flush(f);
+ saveerr = errno;
+ if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) {
dupfd = PerlLIO_dup(fd);
}
- }
- result = (
-#ifdef SOCKS5_VERSION_NAME
- (getsockopt
- (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
- &optlen) <
- 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
-#else
- PerlSIO_fclose(stdio)
-#endif
- );
- if (dupfd >= 0) {
- /* We need to restore fd from the saved copy */
- if (PerlLIO_dup2(dupfd,fd) != fd)
- result = -1;
- if (PerlLIO_close(dupfd) != 0)
- result = -1;
+ }
+ result = PerlSIO_fclose(stdio);
+ /* We treat error from stdio as success if we invalidated
+ errno may NOT be expected EBADF
+ */
+ if (invalidate && result != 0) {
+ errno = saveerr;
+ result = 0;
+ }
+ if (socksfd) {
+ /* in SOCKS case let close() determine return value */
+ result = close(fd);
+ }
+ if (dupfd) {
+ PerlLIO_dup2(dupfd,fd);
+ close(dupfd);
}
return result;
}
-
}
-
-
SSize_t
PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
SSize_t got = 0;
- if (count == 1) {
- STDCHAR *buf = (STDCHAR *) vbuf;
- /*
- * Perl is expecting PerlIO_getc() to fill the buffer Linux's
- * stdio does not do that for fread()
- */
- int ch = PerlSIO_fgetc(s);
- if (ch != EOF) {
- *buf = ch;
- got = 1;
+ for (;;) {
+ if (count == 1) {
+ STDCHAR *buf = (STDCHAR *) vbuf;
+ /*
+ * Perl is expecting PerlIO_getc() to fill the buffer Linux's
+ * stdio does not do that for fread()
+ */
+ int ch = PerlSIO_fgetc(s);
+ if (ch != EOF) {
+ *buf = ch;
+ got = 1;
+ }
}
+ else
+ got = PerlSIO_fread(vbuf, 1, count, s);
+ if (got || errno != EINTR)
+ break;
+ PERL_ASYNC_CHECK();
+ errno = 0; /* just in case */
}
- else
- got = PerlSIO_fread(vbuf, 1, count, s);
return got;
}
@@ -2818,8 +2945,16 @@
SSize_t
PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
- return PerlSIO_fwrite(vbuf, 1, count,
- PerlIOSelf(f, PerlIOStdio)->stdio);
+ SSize_t got;
+ for (;;) {
+ got = PerlSIO_fwrite(vbuf, 1, count,
+ PerlIOSelf(f, PerlIOStdio)->stdio);
+ if (got || errno != EINTR)
+ break;
+ PERL_ASYNC_CHECK();
+ errno = 0; /* just in case */
+ }
+ return got;
}
IV
==== //depot/maint-5.8/perl/plan9/mkfile#2 (text) ====
Index: perl/plan9/mkfile
--- perl/plan9/mkfile#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/plan9/mkfile Sat Feb 1 12:05:08 2003
@@ -20,10 +20,11 @@
installman1dir = /sys/man/1
installman3dir = /sys/man/2
-podnames = perl perlbook perlboot perlbot perldata perldebtut perldiag perldsc
perlform perlfunc perlipc perllol perlmod perlmodlib perlmodinstall perlnewmod perlop
perlopentut perlpod perlrequick perlretut perlref perlreftut perlrun perlsec perlstyle
perlsub perlsyn perltie perltoc perltooc perltoot perltrap perlutil perlvar
+podnames = perl perlbook perlboot perlbot perldata perldebtut perldiag perldsc
+perlform perlfunc perlipc perllexwarn perllol perlmod perlmodlib perlmodinstall
+perlnewmod perlop perlopentut perlpacktut perlpod perlport perlrequick perlretut
+perlref perlreftut perlrequick perlrun perlsec perlstyle perlsub perlsyn perltie
+perltoc perltooc perltoot perltrap perlutil perluniintro perlvar
faqpodnames = perlfaq perlfaq1 perlfaq2 perlfaq3 perlfaq4 perlfaq5 perlfaq6 perlfaq7
perlfaq8 perlfaq9
-advpodnames = perlapi perlapio perlcall perlclib perlcompile perldebguts
perldbmfilter perldebug perldelta perldiag perlebcdic perlembed perlfilter perlfor
perlguts perlhack perlhist perlintern perliol perlnumber perlobj perlre perlthrtut
perltodo perlunicode perlxs perlxs perlxstut
-archpodnames = perlaix perlamiga perlapollo perlbeos perlbs2000 perlce perlcygwin
perldgux perldos perlepoc perlfreebsd perlhpux perlhurd perlirix perlmachten perlmacos
perlmint perlmpeix perlnetware perlos2 perlos390 perlplan9 perlqnx perlsolaris
perltru64 perlvmesa perlvms perlvos perlwin32
+advpodnames = perlapi perlapio perlcall perlclib perlcompile perldebguts
+perldbmfilter perldebug perldelta perldiag perlebcdic perlembed perlfilter perlfork
+perlguts perlhack perlintern perliol perllocale perlnumber perlobj perlothrtut
+perlpodspec perlre perlthrtut perltodo perlunicode perlxs perlxs perlxstut
+archpodnames = perlaix perlamiga perlapollo perlbeos perlbs2000 perlce perlcygwin
+perldgux perldos perlepoc perlfreebsd perlhpux perlhurd perlirix perlmachten
+perlmacos perlmint perlmpeix perlnetware perlos2 perlos390 perlos400 perlplan9
+perlqnx perlsolaris perltru64 perluts perlvmesa perlvms perlvos perlwin32
+histpods = perl5004delta perl5005delta perl561delta perl56delta perl570delta
+perl571delta perl572delta perl573delta perl58delta perlhist
libpods = ${podnames:%=pod/%.pod}
@@ -139,6 +140,7 @@
for (i in $faqpodnames) pod/pod2man pod/$i.pod >
$installman3dir/$i
for (i in $advpodnames) pod/pod2man pod/$i.pod >
$installman3dir/$i
for (i in $archpodnames) pod/pod2man pod/$i.pod >
$installman3dir/$i
+ for (i in $histpodnames) pod/pod2man pod/$i.pod >
+$installman3dir/$i
nuke clean:V:
rm -f *.$O $extensions^.pm config.sh $perllib config.h $perlshr
perlmain.c perl miniperl $archlib/Config.pm $ext_c
==== //depot/maint-5.8/perl/pod/perlfaq.pod#4 (text) ====
Index: perl/pod/perlfaq.pod
--- perl/pod/perlfaq.pod#3~18466~ Thu Jan 9 06:07:25 2003
+++ perl/pod/perlfaq.pod Sat Feb 1 12:05:08 2003
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq - frequently asked questions about Perl ($Date: 2003/01/03 20:00:25 $)
+perlfaq - frequently asked questions about Perl ($Date: 2003/01/26 17:45:46 $)
=head1 DESCRIPTION
@@ -516,7 +516,7 @@
=item *
-Why don't my <<HERE documents work?
+Why don't my E<lt>E<lt>HERE documents work?
=item *
@@ -733,7 +733,7 @@
=item *
-Why do I sometimes get an "Argument list too long" when I use <*>?
+Why do I sometimes get an "Argument list too long" when I use E<lt>*E<gt>?
=item *
@@ -753,7 +753,7 @@
=item *
-Why can't I just open(FH, ">file.lock")?
+Why can't I just open(FH, "E<gt>file.lock")?
=item *
@@ -1012,7 +1012,7 @@
=item *
-Why doesn't "my($foo) = <FILE>;" work right?
+Why doesn't "my($foo) = E<lt>FILEE<gt>;" work right?
=item *
==== //depot/maint-5.8/perl/pod/perlfaq2.pod#4 (text) ====
Index: perl/pod/perlfaq2.pod
--- perl/pod/perlfaq2.pod#3~18466~ Thu Jan 9 06:07:25 2003
+++ perl/pod/perlfaq2.pod Sat Feb 1 12:05:08 2003
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.18 $, $Date: 2002/12/06
07:40:11 $)
+perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.20 $, $Date: 2003/01/26
+17:50:56 $)
=head1 DESCRIPTION
@@ -171,24 +171,33 @@
=head2 What are the Perl newsgroups on Usenet? Where do I post questions?
-The now defunct comp.lang.perl newsgroup has been superseded by the
-following groups:
+Several groups devoted to the Perl language are on Usenet:
comp.lang.perl.announce Moderated announcement group
- comp.lang.perl.misc Very busy group about Perl in general
- comp.lang.perl.moderated Moderated discussion group
+ comp.lang.perl.misc High traffic general Perl discussion
+ comp.lang.perl.moderated Moderated discussion group
comp.lang.perl.modules Use and development of Perl modules
comp.lang.perl.tk Using Tk (and X) from Perl
comp.infosystems.www.authoring.cgi Writing CGI scripts for the Web.
-There is also a Usenet gateway to Perl mailing lists sponsored by perl.org at
-nntp://nntp.perl.org , a web interface to the same lists at
-http://nntp.perl.org/group/ and these lists are also available under the
-C<perl.*> hierarchy at http://groups.google.com . Other groups are listed at
-http://lists.perl.org/ ( also known as http://lists.cpan.org/ ).
-
-A nice place to ask questions is the PerlMonks site, http://www.perlmonks.org/
+Some years ago, comp.lang.perl was divided into those groups, and
+comp.lang.perl itself officially removed. While that group may still
+be found on some news servers, it is unwise to use it, because
+postings there will not appear on news servers which honour the
+official list of group names. Use comp.lang.perl.misc for topics
+which do not have a more-appropriate specific group.
+
+There is also a Usenet gateway to Perl mailing lists sponsored by
+perl.org at nntp://nntp.perl.org , a web interface to the same lists
+at http://nntp.perl.org/group/ and these lists are also available
+under the C<perl.*> hierarchy at http://groups.google.com . Other
+groups are listed at http://lists.perl.org/ ( also known as
+http://lists.cpan.org/ ).
+
+A nice place to ask questions is the PerlMonks site,
+http://www.perlmonks.org/ , or the Perl Beginners mailing list
+http://lists.perl.org/showlist.cgi?name=beginners .
Note that none of the above are supposed to write your code for you:
asking questions about particular problems or general advice is fine,
@@ -230,7 +239,7 @@
by Tom Christiansen and Nathan Torkington,
with Foreword by Larry Wall
ISBN 1-56592-243-3 [1st Edition August 1998]
- http://perl.oreilly.com/cookbook/
+ http://perl.oreilly.com/catalog/cookbook/
If you're already a seasoned programmer, then the Camel Book might
suffice for you to learn Perl from. If you're not, check out the
==== //depot/maint-5.8/perl/pod/perlfaq3.pod#4 (text) ====
Index: perl/pod/perlfaq3.pod
--- perl/pod/perlfaq3.pod#3~18466~ Thu Jan 9 06:07:25 2003
+++ perl/pod/perlfaq3.pod Sat Feb 1 12:05:08 2003
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq3 - Programming Tools ($Revision: 1.31 $, $Date: 2003/01/03 20:10:11 $)
+perlfaq3 - Programming Tools ($Revision: 1.32 $, $Date: 2003/01/26 17:41:53 $)
=head1 DESCRIPTION
@@ -42,17 +42,12 @@
=head2 Is there a Perl shell?
-In general, not yet. There is psh available at
-
- http://www.focusresearch.com/gregor/psh
-
-Which includes the following description:
-
- The Perl Shell is a shell that combines the interactive nature
- of a Unix shell with the power of Perl. The goal is to eventually
- have a full featured shell that behaves as expected for normal
- shell activity. But, the Perl Shell will use Perl syntax and
- functionality for control-flow statements and other things.
+The psh (Perl sh) is currently at version 1.8. The Perl Shell is a
+shell that combines the interactive nature of a Unix shell with the
+power of Perl. The goal is a full featured shell that behaves as
+expected for normal shell activity and uses Perl syntax and
+functionality for control-flow statements and other things.
+You can get psh at http://www.focusresearch.com/gregor/psh/ .
The Shell.pm module (distributed with Perl) makes Perl try commands
which aren't part of the Perl language as shell commands. perlsh
==== //depot/maint-5.8/perl/pod/perlfaq4.pod#5 (text) ====
Index: perl/pod/perlfaq4.pod
--- perl/pod/perlfaq4.pod#4~18466~ Thu Jan 9 06:07:25 2003
+++ perl/pod/perlfaq4.pod Sat Feb 1 12:05:08 2003
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq4 - Data Manipulation ($Revision: 1.39 $, $Date: 2003/01/03 20:06:21 $)
+perlfaq4 - Data Manipulation ($Revision: 1.40 $, $Date: 2003/01/26 17:43:21 $)
=head1 DESCRIPTION
@@ -142,7 +142,7 @@
=item How do I convert from decimal to hexadecimal
-Using sprint:
+Using sprintf:
$hex = sprintf("%X", 3735928559);
@@ -811,9 +811,6 @@
=head2 How do I pad a string with blanks or pad a number with zeroes?
-(This answer contributed by Uri Guttman, with kibitzing from
-Bart Lateur.)
-
In the following examples, C<$pad_len> is the length to which you wish
to pad the string, C<$text> or C<$num> contains the string to be padded,
and C<$pad_char> contains the padding character. You can use a single
@@ -828,13 +825,16 @@
C<$pad_len>.
# Left padding a string with blanks (no truncation):
- $padded = sprintf("%${pad_len}s", $text);
+ $padded = sprintf("%${pad_len}s", $text);
+ $padded = sprintf("%*s", $pad_len, $text); # same thing
# Right padding a string with blanks (no truncation):
- $padded = sprintf("%-${pad_len}s", $text);
+ $padded = sprintf("%-${pad_len}s", $text);
+ $padded = sprintf("%-*s", $pad_len, $text); # same thing
# Left padding a number with 0 (no truncation):
- $padded = sprintf("%0${pad_len}d", $num);
+ $padded = sprintf("%0${pad_len}d", $num);
+ $padded = sprintf("%0*d", $pad_len, $num); # same thing
# Right padding a string with blanks using pack (will truncate):
$padded = pack("A$pad_len",$text);
@@ -958,13 +958,13 @@
print "@lines"; # WRONG - extra blanks
print @lines; # right
-=head2 Why don't my <<HERE documents work?
+=head2 Why don't my E<lt>E<lt>HERE documents work?
Check for these three things:
=over 4
-=item There must be no space after the << part.
+=item There must be no space after the E<lt>E<lt> part.
=item There (probably) should be a semicolon at the end.
@@ -1870,7 +1870,7 @@
Use the Tie::IxHash from CPAN.
use Tie::IxHash;
- tie my %myhash, Tie::IxHash;
+ tie my %myhash, 'Tie::IxHash';
for (my $i=0; $i<20; $i++) {
$myhash{$i} = 2*$i;
}
==== //depot/maint-5.8/perl/pod/perlfaq5.pod#5 (text) ====
Index: perl/pod/perlfaq5.pod
--- perl/pod/perlfaq5.pod#4~18466~ Thu Jan 9 06:07:25 2003
+++ perl/pod/perlfaq5.pod Sat Feb 1 12:05:08 2003
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq5 - Files and Formats ($Revision: 1.27 $, $Date: 2002/12/06 07:40:11 $)
+perlfaq5 - Files and Formats ($Revision: 1.28 $, $Date: 2003/01/26 17:45:46 $)
=head1 DESCRIPTION
@@ -434,7 +434,7 @@
See also the new L<perlopentut> if you have it (new for 5.6).
-=head2 Why do I sometimes get an "Argument list too long" when I use <*>?
+=head2 Why do I sometimes get an "Argument list too long" when I use E<lt>*E<gt>?
The C<< <> >> operator performs a globbing operation (see above).
In Perl versions earlier than v5.6.0, the internal glob() operator forks
@@ -537,7 +537,7 @@
=back
-=head2 Why can't I just open(FH, ">file.lock")?
+=head2 Why can't I just open(FH, "E<gt>file.lock")?
A common bit of code B<NOT TO USE> is this:
==== //depot/maint-5.8/perl/pod/perlfaq7.pod#4 (text) ====
Index: perl/pod/perlfaq7.pod
--- perl/pod/perlfaq7.pod#3~18466~ Thu Jan 9 06:07:25 2003
+++ perl/pod/perlfaq7.pod Sat Feb 1 12:05:08 2003
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq7 - General Perl Language Issues ($Revision: 1.12 $, $Date: 2002/12/06
07:40:11 $)
+perlfaq7 - General Perl Language Issues ($Revision: 1.13 $, $Date: 2003/01/26
+17:45:46 $)
=head1 DESCRIPTION
@@ -519,7 +519,7 @@
are effectively shallowly bound. Consider this just one more reason
not to use them. See the answer to L<"What's a closure?">.
-=head2 Why doesn't "my($foo) = <FILE>;" work right?
+=head2 Why doesn't "my($foo) = E<lt>FILEE<gt>;" work right?
C<my()> and C<local()> give list context to the right hand side
of C<=>. The <FH> read operation, like so many of Perl's
==== //depot/maint-5.8/perl/pod/perlfaq8.pod#4 (text) ====
Index: perl/pod/perlfaq8.pod
--- perl/pod/perlfaq8.pod#3~18466~ Thu Jan 9 06:07:25 2003
+++ perl/pod/perlfaq8.pod Sat Feb 1 12:05:08 2003
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq8 - System Interaction ($Revision: 1.16 $, $Date: 2003/01/03 20:03:57 $)
+perlfaq8 - System Interaction ($Revision: 1.17 $, $Date: 2003/01/26 17:44:04 $)
=head1 DESCRIPTION
@@ -1036,9 +1036,15 @@
=head2 How do I use an SQL database?
-There are a number of excellent interfaces to SQL databases. See the
-DBD::* modules available from http://www.cpan.org/modules/by-module/DBD/ .
-A lot of information on this can be found at http://dbi.perl.org/
+The DBI module provides an abstract interface to most database
+servers and types, including Oracle, DB2, Sybase, mysql, Postgresql,
+ODBC, and flat files. The DBI module accesses each database type
+through a database driver, or DBD. You can see a complete list of
+available drivers on CPAN: http://www.cpan.org/modules/by-module/DBD/ .
+You can read more about DBI on http://dbi.perl.org .
+
+Other modules provide more specific access: Win32::ODBC, Alzabo, iodbc,
+and others found on CPAN Search: http://search.cpan.org .
=head2 How do I make a system() exit on control-C?
==== //depot/maint-5.8/perl/pod/perlunicode.pod#6 (text) ====
Index: perl/pod/perlunicode.pod
--- perl/pod/perlunicode.pod#5~18503~ Thu Jan 16 15:29:57 2003
+++ perl/pod/perlunicode.pod Sat Feb 1 12:05:08 2003
@@ -178,7 +178,7 @@
equal to C<\P{Tamil}>.
Here are the basic Unicode General Category properties, followed by their
-long form. You can use either; C<\p{Lu}> and C<\p{LowercaseLetter}>,
+long form. You can use either; C<\p{Lu}> and C<\p{UppercaseLetter}>,
for instance, are identical.
Short Long
==== //depot/maint-5.8/perl/pod/perluniintro.pod#4 (text) ====
Index: perl/pod/perluniintro.pod
--- perl/pod/perluniintro.pod#3~18503~ Thu Jan 16 15:29:57 2003
+++ perl/pod/perluniintro.pod Sat Feb 1 12:05:08 2003
@@ -435,7 +435,8 @@
explicitly opening also the F<file> for input as UTF-8.
B<NOTE>: the C<:utf8> and C<:encoding> features work only if your
-Perl has been built with the new PerlIO feature.
+Perl has been built with the new PerlIO feature (which is the default
+on most systems).
=head2 Displaying Unicode As Text
==== //depot/maint-5.8/perl/pp_ctl.c#9 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#8~18590~ Sun Jan 26 05:21:03 2003
+++ perl/pp_ctl.c Sat Feb 1 12:05:08 2003
@@ -1578,7 +1578,7 @@
push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB(cx);
+ PUSHSUB_DB(cx);
CvDEPTH(cv)++;
(void)SvREFCNT_inc(cv);
SAVEVPTR(PL_curpad);
==== //depot/maint-5.8/perl/regexec.c#8 (text) ====
Index: perl/regexec.c
--- perl/regexec.c#7~18535~ Mon Jan 20 18:49:55 2003
+++ perl/regexec.c Sat Feb 1 12:05:08 2003
@@ -4077,26 +4077,8 @@
case ANYOF:
if (do_utf8) {
loceol = PL_regeol;
- while (hardcount < max && scan < loceol) {
- bool cont = FALSE;
- if (ANYOF_FLAGS(p) & ANYOF_UNICODE) {
- if (reginclass(p, (U8*)scan, 0, do_utf8))
- cont = TRUE;
- }
- else {
- U8 c = (U8)scan[0];
-
- if (UTF8_IS_INVARIANT(c)) {
- if (ANYOF_BITMAP_TEST(p, c))
- cont = TRUE;
- }
- else {
- if (reginclass(p, (U8*)scan, 0, do_utf8))
- cont = TRUE;
- }
- }
- if (!cont)
- break;
+ while (hardcount < max && scan < loceol &&
+ reginclass(p, (U8*)scan, 0, do_utf8)) {
scan += UTF8SKIP(scan);
hardcount++;
}
==== //depot/maint-5.8/perl/sv.c#22 (text) ====
Index: perl/sv.c
--- perl/sv.c#21~18582~ Sun Jan 26 00:30:37 2003
+++ perl/sv.c Sat Feb 1 12:05:08 2003
@@ -5584,6 +5584,8 @@
U8 *p = s + cache[1];
STRLEN ubackw = 0;
+ cache[1] -= backw;
+
while (backw--) {
p--;
while (UTF8_IS_CONTINUATION(*p))
@@ -5592,7 +5594,6 @@
}
cache[0] -= ubackw;
- cache[1] -= backw;
return;
}
@@ -5965,10 +5966,18 @@
rslen = 1;
}
else if (RsSNARF(PL_rs)) {
+ /* If it is a regular disk file use size from stat() as estimate
+ of amount we are going to read - may result in malloc-ing
+ more memory than we realy need if layers bellow reduce
+ size we read (e.g. CRLF or a gzip layer)
+ */
Stat_t st;
- if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && st.st_size
- && (recsize = st.st_size - PerlIO_tell(fp)))
- goto read_record;
+ if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
+ Off_t offset = PerlIO_tell(fp);
+ if (offset != (Off_t) -1) {
+ (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
+ }
+ }
rsptr = NULL;
rslen = 0;
}
@@ -5978,14 +5987,14 @@
/* Grab the size of the record we're getting */
recsize = SvIV(SvRV(PL_rs));
-
- read_record:
buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
/* Go yank in */
#ifdef VMS
/* VMS wants read instead of fread, because fread doesn't respect */
/* RMS record boundaries. This is not necessarily a good thing to be */
- /* doing, but we've got no other real choice */
+ /* doing, but we've got no other real choice - except avoid stdio
+ as implementation - perhaps write a :vms layer ?
+ */
bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
#else
bytesread = PerlIO_read(fp, buffer, recsize);
@@ -6061,8 +6070,13 @@
/* Here is some breathtakingly efficient cheating */
cnt = PerlIO_get_cnt(fp); /* get count into register */
- if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */
- if (cnt > 80 && (I32)SvLEN(sv) > append) {
+ /* make sure we have the room */
+ if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
+ /* Not room for all of it
+ if we are looking for a separator and room for some
+ */
+ if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
+ /* just process what we have room for */
shortbuffered = cnt - SvLEN(sv) + append + 1;
cnt -= shortbuffered;
}
@@ -6072,7 +6086,7 @@
SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
}
}
- else
+ else
shortbuffered = 0;
bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
ptr = (STDCHAR*)PerlIO_get_ptr(fp);
==== //depot/maint-5.8/perl/t/op/pat.t#8 (xtext) ====
Index: perl/t/op/pat.t
--- perl/t/op/pat.t#7~18450~ Sun Jan 5 20:44:28 2003
+++ perl/t/op/pat.t Sat Feb 1 12:05:08 2003
@@ -6,7 +6,7 @@
$| = 1;
-print "1..968\n";
+print "1..972\n";
BEGIN {
chdir 't' if -d 't';
@@ -3054,5 +3054,11 @@
ok($a !~ /^\C{4}y/, q{don't match \C{4}y});
}
-# last test 968
+$_ = 'aaaaaaaaaa';
+utf8::upgrade($_); chop $_; $\="\n";
+ok(/[^\s]+/, "m/[^\s]/ utf8");
+ok(/[^\d]+/, "m/[^\d]/ utf8");
+ok(($a = $_, $_ =~ s/[^\s]+/./g), "s/[^\s]/ utf8");
+ok(($a = $_, $a =~ s/[^\d]+/./g), "s/[^\s]/ utf8");
+# last test 972
End of Patch.
