This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from match from perl-5.003_97g to perl-5.003_97h]
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>
Tue, 22 Apr 1997 12:00:00 +0000 (00:00 +1200)
committerChip Salzenberg <chip@atlantic.net>
Tue, 22 Apr 1997 12:00:00 +0000 (00:00 +1200)
 BUILD PROCESS

Subject: Fix up Linux hints for tcsh, and Configure patch
Date: Tue, 22 Apr 1997 11:02:27 -0400 (EDT)
From: Andy Dougherty <doughera@lafcol.lafayette.edu>
Files: Configure hints/linux.sh
Msg-ID: Pine.SOL.3.95q.970422101051.2506C-100000@fractal.lafayette.e

    (applied based on p5p patch as commit 1eb1b1cb9647b817d039bb17afa3e74940b5ef92)

Subject: There is no standard answer to 'Use suidperl?'
From: Chip Salzenberg <chip@perl.com>
Files: hints/bsdos.sh hints/freebsd.sh hints/linux.sh hints/machten_2.sh

 CORE LANGUAGE CHANGES

Subject: Support PRINTF for tied handles
Date: Sun, 20 Apr 1997 18:26:13 -0400
From: Doug MacEachern <dougm@opengroup.org>
Files: pod/perldelta.pod pod/perltie.pod pp_sys.c t/op/misc.t
Msg-ID: 199704202226.SAA08032@postman.osf.org

    (applied based on p5p patch as commit e7c5525577c16ee25e3521e86aca2b5105dba394)

 CORE PORTABILITY

Subject: Fix bitwise shifts and pack('w') on Crays
From: Chip Salzenberg <chip@perl.com>
Files: pp.c

 DOCUMENTATION

Subject: FAQ udpate (23-apr-97)
Date: Wed, 23 Apr 1997 12:22:55 -0600 (MDT)
From: Nathan Torkington <gnat@prometheus.frii.com>
Files: pod/perlfaq*.pod

    private-msgid: 199704231822.MAA05074@prometheus.frii.com

 OTHER CORE CHANGES

Subject: Mondo Cool patch for buffer safety and convenience
From: Chip Salzenberg <chip@perl.com>
Files: XSUB.h doop.c dump.c ext/DynaLoader/dl_dlopen.xs ext/DynaLoader/dl_hpux.xs ext/DynaLoader/dl_next.xs ext/DynaLoader/dlutils.c ext/ODBM_File/ODBM_File.xs global.sym gv.c interp.sym mg.c op.c perl.c perl.h pod/perlguts.pod pp.c pp_ctl.c pp_hot.c pp_sys.c proto.h regcomp.c regexec.c sv.c toke.c util.c

Subject: Problems with glob
Date: Sun, 20 Apr 1997 02:44:32 -0400 (EDT)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: op.c
Msg-ID: 1997Apr20.024432.1941365@hmivax.humgen.upenn.edu

    (applied based on p5p patch as commit a1230b335277820e65b8a9454ab751341204cf4f)

Subject: Fix scalar leak in closures
From: Chip Salzenberg <chip@perl.com>
Files: op.c scope.c

Subject: Refine error messages re: anon subs' prototypes
From: Chip Salzenberg <chip@perl.com>
Files: op.c

Subject: Outermost scope is void, not scalar
From: Chip Salzenberg <chip@perl.com>
Files: pp_ctl.c

52 files changed:
Changes
Configure
MANIFEST
XSUB.h
doop.c
dump.c
embed.h
ext/DynaLoader/dl_dlopen.xs
ext/DynaLoader/dl_hpux.xs
ext/DynaLoader/dl_next.xs
ext/DynaLoader/dlutils.c
ext/ODBM_File/ODBM_File.xs
global.sym
gv.c
hints/bsdos.sh
hints/freebsd.sh
hints/linux.sh
hints/machten_2.sh
installperl
interp.sym
lib/ExtUtils/Install.pm
mg.c
op.c
patchlevel.h
perl.c
perl.h
pod/perldelta.pod
pod/perlfaq.pod
pod/perlfaq1.pod
pod/perlfaq2.pod
pod/perlfaq3.pod
pod/perlfaq4.pod
pod/perlfaq5.pod
pod/perlfaq6.pod
pod/perlfaq7.pod
pod/perlfaq8.pod
pod/perlfaq9.pod
pod/perlguts.pod
pod/perltie.pod
pod/perltoc.pod
pp.c
pp_ctl.c
pp_hot.c
pp_sys.c
proto.h
regcomp.c
regexec.c
scope.c
sv.c
t/op/misc.t
toke.c
util.c

diff --git a/Changes b/Changes
index a1ae3c2..075fa39 100644 (file)
--- a/Changes
+++ b/Changes
@@ -46,6 +46,119 @@ And the Keepers of the Patch Pumpkin:
 
 
 -----------------
+Version 5.003_97h
+-----------------
+
+This patch eliminates almost all possible sources of buffer overflow;
+in particular, there are no more sprintf() bugs.  (!!)  This patch
+also has a few other fixes.  With these changes in place, I can sleep
+at night.  (Because I've stopped hacking.  :-))
+
+ CORE LANGUAGE CHANGES
+
+  Title:  "Support PRINTF for tied handles"
+   From:  Doug MacEachern
+ Msg-ID:  <199704202226.SAA08032@postman.osf.org>
+   Date:  Sun, 20 Apr 1997 18:26:13 -0400
+  Files:  pod/perldelta.pod pod/perltie.pod pp_sys.c t/op/misc.t
+
+ CORE PORTABILITY
+
+  Title:  "Fix bitwise shifts and pack('w') on Crays"
+   From:  Chip Salzenberg
+  Files:  pp.c
+
+  Title:  "Win32 update (two patches)"
+   From:  Gurusamy Sarathy
+  Files:  lib/AutoSplit.pm lib/ExtUtils/MM_Unix.pm win32/config.w32
+          win32/makedef.pl
+
+ OTHER CORE CHANGES
+
+  Title:  "Mondo Cool patch for buffer safety and convenience"
+   From:  Chip Salzenberg
+  Files:  XSUB.h doop.c dump.c ext/DynaLoader/dl_dlopen.xs
+          ext/DynaLoader/dl_hpux.xs ext/DynaLoader/dl_next.xs
+          ext/DynaLoader/dlutils.c ext/ODBM_File/ODBM_File.xs
+          global.sym gv.c interp.sym mg.c op.c perl.c perl.h
+          pod/perlguts.pod pp.c pp_ctl.c pp_hot.c pp_sys.c proto.h
+          regcomp.c regexec.c sv.c toke.c util.c
+
+  Title:  "Problems with glob"
+   From:  Ilya Zakharevich
+ Msg-ID:  <1997Apr20.024432.1941365@hmivax.humgen.upenn.edu>
+   Date:  Sun, 20 Apr 1997 02:44:32 -0400 (EDT)
+  Files:  op.c
+
+  Title:  "Fix scalar leak in closures"
+   From:  Chip Salzenberg
+  Files:  op.c scope.c
+
+  Title:  "Refine error messages re: anon subs' prototypes"
+   From:  Chip Salzenberg
+  Files:  op.c
+
+  Title:  "Outermost scope is void, not scalar"
+   From:  Chip Salzenberg
+  Files:  pp_ctl.c
+
+ BUILD PROCESS
+
+  Title:  "Fix up Linux hints for tcsh, and Configure patch"
+   From:  Andy Dougherty
+ Msg-ID:  <Pine.SOL.3.95q.970422101051.2506C-100000@fractal.lafayette.e
+   Date:  Tue, 22 Apr 1997 11:02:27 -0400 (EDT)
+  Files:  Configure hints/linux.sh
+
+  Title:  "There is no standard answer to 'Use suidperl?'"
+   From:  Chip Salzenberg
+  Files:  hints/bsdos.sh hints/freebsd.sh hints/linux.sh
+          hints/machten_2.sh
+
+ LIBRARY AND EXTENSIONS
+
+  Title:  "Math::Complex update"
+   From:  Jarkko Hietaniemi
+  Files:  lib/Math/Complex.pm t/lib/complex.t
+
+  Title:  "Croak on C<use autouse> without module name"
+   From:  Chip Salzenberg
+  Files:  lib/autouse.pm
+
+  Title:  "Silence warnings on simple C<use ops>"
+   From:  Roderick Schertler
+ Msg-ID:  <pzybafum6k.fsf@eeyore.ibcinc.com>
+   Date:  19 Apr 1997 10:22:43 -0400
+  Files:  ext/Opcode/ops.pm
+
+ TESTS
+
+  Title:  "Don't put leading newline on numeric strings"
+   From:  Andreas Koenig
+ Msg-ID:  <199704230847.KAA22752@anna.in-berlin.de>
+   Date:  Wed, 23 Apr 1997 10:47:00 +0200
+  Files:  t/pragma/constant.t
+
+ UTILITIES
+
+   (no changes)
+
+ DOCUMENTATION
+
+  Title:  "FAQ udpate (23-apr-97)"
+   From:  Nathan Torkington <gnat@prometheus.frii.com>
+ Msg-ID:  <199704231822.MAA05074@prometheus.frii.com>
+   Date:  Wed, 23 Apr 1997 12:22:55 -0600 (MDT)
+  Files:  pod/perlfaq*.pod
+
+  Title:  "Two doublewords less"
+   From:  Jarkko Hietaniemi
+ Msg-ID:  <199704201938.WAA07722@alpha.hut.fi>
+   Date:  Sun, 20 Apr 1997 22:38:13 +0300 (EET DST)
+  Files:  pod/perlrun.pod vms/perlvms.pod
+
+
+-----------------
 Version 5.003_97g
 -----------------
 
index fbe1b31..64dd01c 100755 (executable)
--- a/Configure
+++ b/Configure
@@ -6095,12 +6095,14 @@ eval $setvar
 : get csh whereabouts
 case "$csh" in
 'csh') val="$undef" ;;
-'tcsh')        val="$undef" ;;
 *)     val="$define" ;;
 esac
 set d_csh
 eval $setvar
-full_csh=$csh
+: Respect a hint or command line value for full_csh.
+case "$full_csh" in
+'') full_csh=$csh ;;
+esac
 
 : see if cuserid exists
 set cuserid d_cuserid
index ba759ea..7fc958b 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -346,7 +346,7 @@ lib/File/Compare.pm Emulation of cmp command
 lib/File/Copy.pm       Emulation of cp command
 lib/File/Find.pm       Routines to do a find
 lib/File/Path.pm       Do things like `mkdir -p' and `rm -r'
-lib/File/stat.pm       By-name interface to Perl's built-in stat
+lib/File/stat.pm       By-name interface to Perl's builtin stat
 lib/FileCache.pm       Keep more files open than the system permits
 lib/FileHandle.pm      Backward-compatible front end to IO extension
 lib/FindBin.pm         Find name of currently executing program
@@ -360,10 +360,10 @@ lib/Math/BigInt.pm        An arbitrary precision integer arithmetic package
 lib/Math/Complex.pm    A Complex package
 lib/Math/Trig.pm       A simple interface to complex trigonometry
 lib/Net/Ping.pm                Hello, anybody home?
-lib/Net/hostent.pm     By-name interface to Perl's built-in gethost*
-lib/Net/netent.pm      By-name interface to Perl's built-in getnet*
-lib/Net/protoent.pm    By-name interface to Perl's built-in getproto*
-lib/Net/servent.pm     By-name interface to Perl's built-in getserv*
+lib/Net/hostent.pm     By-name interface to Perl's builtin gethost*
+lib/Net/netent.pm      By-name interface to Perl's builtin getnet*
+lib/Net/protoent.pm    By-name interface to Perl's builtin getproto*
+lib/Net/servent.pm     By-name interface to Perl's builtin getserv*
 lib/Pod/Functions.pm   used by pod/splitpod
 lib/Pod/Html.pm                Convert POD data to HTML
 lib/Pod/Text.pm                Convert POD data to formatted ASCII text
@@ -388,12 +388,12 @@ lib/Tie/RefHash.pm        Base class for tied hashes with references as keys
 lib/Tie/Scalar.pm      Base class for tied scalars
 lib/Tie/SubstrHash.pm  Compact hash for known key, value and table size
 lib/Time/Local.pm      Reverse translation of localtime, gmtime
-lib/Time/gmtime.pm     By-name interface to Perl's built-in gmtime
-lib/Time/localtime.pm  By-name interface to Perl's built-in localtime
+lib/Time/gmtime.pm     By-name interface to Perl's builtin gmtime
+lib/Time/localtime.pm  By-name interface to Perl's builtin localtime
 lib/Time/tm.pm         Internal object for Time::{gm,local}time
 lib/UNIVERSAL.pm       Base class for ALL classes
-lib/User/grent.pm      By-name interface to Perl's built-in getgr*
-lib/User/pwent.pm      By-name interface to Perl's built-in getpw*
+lib/User/grent.pm      By-name interface to Perl's builtin getgr*
+lib/User/pwent.pm      By-name interface to Perl's builtin getpw*
 lib/abbrev.pl          An abbreviation table builder
 lib/assert.pl          assertion and panic with stack trace
 lib/autouse.pm         Load and call a function only when it's used
diff --git a/XSUB.h b/XSUB.h
index d15af1f..65c33c9 100644 (file)
--- a/XSUB.h
+++ b/XSUB.h
 #ifdef XS_VERSION
 # define XS_VERSION_BOOTCHECK \
     STMT_START {                                                       \
-       char vn[255], *module = SvPV(ST(0),na);                         \
+       char *vn = "", *module = SvPV(ST(0),na);                        \
        if (items >= 2)  /* version supplied as bootstrap arg */        \
            Sv = ST(1);                                                 \
        else {                                                          \
-           sprintf(vn,"%s::XS_VERSION", module);                       \
-           Sv = perl_get_sv(vn, FALSE);   /* XXX GV_ADDWARN */         \
-           if (!Sv || !SvOK(Sv)) {                                     \
-               sprintf(vn,"%s::VERSION", module);                      \
-               Sv = perl_get_sv(vn, FALSE);   /* XXX GV_ADDWARN */     \
-           }                                                           \
+           /* XXX GV_ADDWARN */                                        \
+           Sv = perl_get_sv(vn = form("%s::XS_VERSION", module), FALSE); \
+           if (!Sv || !SvOK(Sv))                                       \
+               Sv = perl_get_sv(vn = form("%s::VERSION", module), FALSE); \
        }                                                               \
        if (Sv && (!SvOK(Sv) || strNE(XS_VERSION, SvPV(Sv, na))))       \
-           croak("%s object version %s does not match $%s %s",         \
-                 module, XS_VERSION, vn, SvPV(Sv, na));                \
+           croak("%s object version %s does not match $%s %S",         \
+                 module, XS_VERSION, vn, Sv);                          \
     } STMT_END
 #else
 # define XS_VERSION_BOOTCHECK
diff --git a/doop.c b/doop.c
index 400934d..763b1a9 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -142,217 +142,18 @@ register SV **sp;
 
 void
 do_sprintf(sv,len,sarg)
-register SV *sv;
-register I32 len;
-register SV **sarg;
+SV *sv;
+I32 len;
+SV **sarg;
 {
-    register char *s;
-    register char *t;
-    register char *f;
-    char dotype;
-    char ch;
-    register char *send;
-    register SV *arg;
-    char *xs;
-    I32 xlen;
-    I32 pre;
-    I32 post;
-    double value;
-    STRLEN arglen;
-
-    sv_setpv(sv,"");
-    len--;                     /* don't count pattern string */
-    t = s = SvPV(*sarg, arglen);       /* XXX Don't know t is writeable */
-    send = s + arglen;
-    sarg++;
-    for ( ; ; len--) {
-
-       /*SUPPRESS 560*/
-       if (len <= 0 || !(arg = *sarg++))
-           arg = &sv_no;
-
-       /*SUPPRESS 530*/
-       for ( ; t < send && *t != '%'; t++) ;
-       if (t >= send)
-           break;              /* end of run_format string, ignore extra args */
-       f = t;
-       *buf = '\0';
-       xs = buf;
-       dotype = '\0';
-       pre = post = 0;
-       for (t++; t < send; t++) {
-           switch (*t) {
-           default:
-               ch = *(++t);
-               *t = '\0';
-               (void)sprintf(xs,f);
-               len++, sarg--;
-               xlen = strlen(xs);
-               break;
-           case 'n': case '*':
-               croak("Use of %c in printf format not supported", *t);
-
-           case '0': case '1': case '2': case '3': case '4':
-           case '5': case '6': case '7': case '8': case '9': 
-           case '.': case '#': case '-': case '+': case ' ':
-               continue;
-           case 'l':
-#ifdef HAS_QUAD
-               if (dotype == 'l')
-                   dotype = 'q';
-               else
-#endif
-                   dotype = 'l';
-               continue;
-           case 'h':
-               dotype = 's';
-               continue;
-           case 'c':
-               ch = *(++t);
-               *t = '\0';
-               xlen = SvIV(arg);
-               if (strEQ(f,"%c")) { /* some printfs fail on null chars */
-                   *xs = xlen;
-                   xs[1] = '\0';
-                   xlen = 1;
-               }
-               else {
-                   (void)sprintf(xs,f,xlen);
-                   xlen = strlen(xs);
-               }
-               break;
-           case 'D':
-               dotype = 'l';
-               /* FALL THROUGH */
-           case 'd':
-           case 'i':
-               ch = *(++t);
-               *t = '\0';
-               switch (dotype) {
-#ifdef HAS_QUAD
-               case 'q':
-                   /* perl.h says that if quad is available, IV is quad */
-                   (void)sprintf(xs,f,(Quad_t)SvIV(arg));
-                   break;
-#endif
-               case 'l':
-                   (void)sprintf(xs,f,(long)SvIV(arg));
-                   break;
-               default:
-                   (void)sprintf(xs,f,(int)SvIV(arg));
-                   break;
-               case 's':
-                   (void)sprintf(xs,f,(short)SvIV(arg));
-                   break;
-               }
-               xlen = strlen(xs);
-               break;
-           case 'X': case 'O':
-               dotype = 'l';
-               /* FALL THROUGH */
-           case 'x': case 'o': case 'u':
-               ch = *(++t);
-               *t = '\0';
-               switch (dotype) {
-#ifdef HAS_QUAD
-               case 'q':
-                   /* perl.h says that if quad is available, UV is quad */
-                   (void)sprintf(xs,f,(unsigned Quad_t)SvUV(arg));
-                   break;
-#endif
-               case 'l':
-                   (void)sprintf(xs,f,(unsigned long)SvUV(arg));
-                   break;
-               default:
-                   (void)sprintf(xs,f,(unsigned int)SvUV(arg));
-                   break;
-               case 's':
-                   (void)sprintf(xs,f,(unsigned short)SvUV(arg));
-                   break;
-               }
-               xlen = strlen(xs);
-               break;
-           case 'E': case 'e': case 'f': case 'G': case 'g':
-               ch = *(++t);
-               *t = '\0';
-               (void)sprintf(xs,f,SvNV(arg));
-               xlen = strlen(xs);
-#ifdef LC_NUMERIC
-               /*
-                * User-defined locales may include arbitrary characters.
-                * And, unfortunately, some system may alloc the "C" locale
-                * to be overridden by a malicious user.
-                */
-               if (op->op_type == OP_SPRINTF)
-                   SvTAINTED_on(sv);
-#endif /* LC_NUMERIC */
-               break;
-           case 's':
-               ch = *(++t);
-               *t = '\0';
-               xs = SvPV(arg, arglen);
-               xlen = (I32)arglen;
-               if (strEQ(f,"%s")) {    /* some printfs fail on >128 chars */
-                   break;              /* so handle simple cases */
-               }
-               else if (f[1] == '-') {
-                   char *mp = strchr(f, '.');
-                   I32 min = atoi(f+2);
-
-                   if (mp) {
-                       I32 max = atoi(mp+1);
-
-                       if (xlen > max)
-                           xlen = max;
-                   }
-                   if (xlen < min)
-                       post = min - xlen;
-                   break;
-               }
-               else if (isDIGIT(f[1])) {
-                   char *mp = strchr(f, '.');
-                   I32 min = atoi(f+1);
-
-                   if (mp) {
-                       I32 max = atoi(mp+1);
-
-                       if (xlen > max)
-                           xlen = max;
-                   }
-                   if (xlen < min)
-                       pre = min - xlen;
-                   break;
-               }
-               strcpy(tokenbuf+64,f);  /* sprintf($s,...$s...) */
-               *t = ch;
-               (void)sprintf(buf,tokenbuf+64,xs);
-               xs = buf;
-               xlen = strlen(xs);
-               break;
-           }
-           /* end of switch, copy results */
-           *t = ch;
-           if (xs == buf && xlen >= sizeof(buf)) {     /* Ooops! */
-               PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
-               my_exit(1);
-           }
-           SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
-           sv_catpvn(sv, s, f - s);
-           if (pre) {
-               repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
-               SvCUR(sv) += pre;
-           }
-           sv_catpvn(sv, xs, xlen);
-           if (post) {
-               repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
-               SvCUR(sv) += post;
-           }
-           s = t;
-           break;              /* break from for loop */
-       }
-    }
-    sv_catpvn(sv, s, t - s);
+    STRLEN patlen;
+    char *pat = SvPV(*sarg, patlen);
+    bool do_taint = FALSE;
+
+    sv_vsetpvfn(sv, pat, patlen, Null(va_list*), sarg + 1, len - 1, &do_taint);
     SvSETMAGIC(sv);
+    if (do_taint)
+       SvTAINTED_on(sv);
 }
 
 void
@@ -708,18 +509,15 @@ dARGS
        if (dokeys)
            XPUSHs(hv_iterkeysv(entry));        /* won't clobber stack_sp */
        if (dovalues) {
-           tmpstr = NEWSV(45,0);
+           tmpstr = sv_newmortal();
            PUTBACK;
            sv_setsv(tmpstr,hv_iterval(hv,entry));
+           DEBUG_H(sv_setpvf(tmpstr, "%lu%%%d=%lu",
+                           (unsigned long)HeHASH(entry),
+                           HvMAX(hv)+1,
+                           (unsigned long)(HeHASH(entry) & HvMAX(hv))));
            SPAGAIN;
-           DEBUG_H( {
-                       sprintf(buf,"%lu%%%d=%lu\n",
-                               (unsigned long)HeHASH(entry),
-                               HvMAX(hv)+1,
-                               (unsigned long)(HeHASH(entry) & HvMAX(hv)));
-                       sv_setpv(tmpstr,buf);
-           } )
-           XPUSHs(sv_2mortal(tmpstr));
+           XPUSHs(tmpstr);
        }
        PUTBACK;
     }
diff --git a/dump.c b/dump.c
index e74c8c4..2a45e75 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -103,8 +103,6 @@ void
 dump_op(op)
 register OP *op;
 {
-    SV *tmpsv;
-
     dump("{\n");
     if (op->op_seq)
        PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq);
@@ -130,58 +128,57 @@ register OP *op;
     dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next);
 #endif
     if (op->op_flags) {
-       *buf = '\0';
+       SV *tmpsv = newSVpv("", 0);
        switch (op->op_flags & OPf_WANT) {
        case OPf_WANT_VOID:
-           (void)strcat(buf,"VOID,");
+           sv_catpv(tmpsv, ",VOID");
            break;
        case OPf_WANT_SCALAR:
-           (void)strcat(buf,"SCALAR,");
+           sv_catpv(tmpsv, ",SCALAR");
            break;
        case OPf_WANT_LIST:
-           (void)strcat(buf,"LIST,");
+           sv_catpv(tmpsv, ",LIST");
            break;
        default:
-           (void)strcat(buf,"UNKNOWN,");
+           sv_catpv(tmpsv, ",UNKNOWN");
            break;
        }
        if (op->op_flags & OPf_KIDS)
-           (void)strcat(buf,"KIDS,");
+           sv_catpv(tmpsv, ",KIDS");
        if (op->op_flags & OPf_PARENS)
-           (void)strcat(buf,"PARENS,");
+           sv_catpv(tmpsv, ",PARENS");
        if (op->op_flags & OPf_STACKED)
-           (void)strcat(buf,"STACKED,");
+           sv_catpv(tmpsv, ",STACKED");
        if (op->op_flags & OPf_REF)
-           (void)strcat(buf,"REF,");
+           sv_catpv(tmpsv, ",REF");
        if (op->op_flags & OPf_MOD)
-           (void)strcat(buf,"MOD,");
+           sv_catpv(tmpsv, ",MOD");
        if (op->op_flags & OPf_SPECIAL)
-           (void)strcat(buf,"SPECIAL,");
-       if (*buf)
-           buf[strlen(buf)-1] = '\0';
-       dump("FLAGS = (%s)\n",buf);
+           sv_catpv(tmpsv, ",SPECIAL");
+       dump("FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
+       SvREFCNT_dec(tmpsv);
     }
     if (op->op_private) {
-       *buf = '\0';
+       SV *tmpsv = newSVpv("", 0);
        if (op->op_type == OP_AASSIGN) {
            if (op->op_private & OPpASSIGN_COMMON)
-               (void)strcat(buf,"COMMON,");
+               sv_catpv(tmpsv, ",COMMON");
        }
        else if (op->op_type == OP_SASSIGN) {
            if (op->op_private & OPpASSIGN_BACKWARDS)
-               (void)strcat(buf,"BACKWARDS,");
+               sv_catpv(tmpsv, ",BACKWARDS");
        }
        else if (op->op_type == OP_TRANS) {
            if (op->op_private & OPpTRANS_SQUASH)
-               (void)strcat(buf,"SQUASH,");
+               sv_catpv(tmpsv, ",SQUASH");
            if (op->op_private & OPpTRANS_DELETE)
-               (void)strcat(buf,"DELETE,");
+               sv_catpv(tmpsv, ",DELETE");
            if (op->op_private & OPpTRANS_COMPLEMENT)
-               (void)strcat(buf,"COMPLEMENT,");
+               sv_catpv(tmpsv, ",COMPLEMENT");
        }
        else if (op->op_type == OP_REPEAT) {
            if (op->op_private & OPpREPEAT_DOLIST)
-               (void)strcat(buf,"DOLIST,");
+               sv_catpv(tmpsv, ",DOLIST");
        }
        else if (op->op_type == OP_ENTERSUB ||
                 op->op_type == OP_RV2SV ||
@@ -193,56 +190,55 @@ register OP *op;
        {
            if (op->op_type == OP_ENTERSUB) {
                if (op->op_private & OPpENTERSUB_AMPER)
-                   (void)strcat(buf,"AMPER,");
+                   sv_catpv(tmpsv, ",AMPER");
                if (op->op_private & OPpENTERSUB_DB)
-                   (void)strcat(buf,"DB,");
+                   sv_catpv(tmpsv, ",DB");
            }
            switch (op->op_private & OPpDEREF) {
            case OPpDEREF_SV:
-               (void)strcat(buf, "SV,");
+               sv_catpv(tmpsv, ",SV");
                break;
            case OPpDEREF_AV:
-               (void)strcat(buf, "AV,");
+               sv_catpv(tmpsv, ",AV");
                break;
            case OPpDEREF_HV:
-               (void)strcat(buf, "HV,");
+               sv_catpv(tmpsv, ",HV");
                break;
            }
            if (op->op_type == OP_AELEM || op->op_type == OP_HELEM) {
                if (op->op_private & OPpLVAL_DEFER)
-                   (void)strcat(buf,"LVAL_DEFER,");
+                   sv_catpv(tmpsv, ",LVAL_DEFER");
            }
            else {
                if (op->op_private & HINT_STRICT_REFS)
-                   (void)strcat(buf,"STRICT_REFS,");
+                   sv_catpv(tmpsv, ",STRICT_REFS");
            }
        }
        else if (op->op_type == OP_CONST) {
            if (op->op_private & OPpCONST_BARE)
-               (void)strcat(buf,"BARE,");
+               sv_catpv(tmpsv, ",BARE");
        }
        else if (op->op_type == OP_FLIP) {
            if (op->op_private & OPpFLIP_LINENUM)
-               (void)strcat(buf,"LINENUM,");
+               sv_catpv(tmpsv, ",LINENUM");
        }
        else if (op->op_type == OP_FLOP) {
            if (op->op_private & OPpFLIP_LINENUM)
-               (void)strcat(buf,"LINENUM,");
+               sv_catpv(tmpsv, ",LINENUM");
        }
        if (op->op_flags & OPf_MOD && op->op_private & OPpLVAL_INTRO)
-           (void)strcat(buf,"INTRO,");
-       if (*buf) {
-           buf[strlen(buf)-1] = '\0';
-           dump("PRIVATE = (%s)\n",buf);
-       }
+           sv_catpv(tmpsv, ",INTRO");
+       if (SvCUR(tmpsv))
+           dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1);
+       SvREFCNT_dec(tmpsv);
     }
 
     switch (op->op_type) {
     case OP_GVSV:
     case OP_GV:
        if (cGVOP->op_gv) {
+           SV *tmpsv = NEWSV(0,0);
            ENTER;
-           tmpsv = NEWSV(0,0);
            SAVEFREESV(tmpsv);
            gv_fullname3(tmpsv, cGVOP->op_gv, Nullch);
            dump("GV = %s\n", SvPV(tmpsv, na));
@@ -367,30 +363,29 @@ register PMOP *pm;
        dump("PMf_SHORT = %s\n",SvPEEK(pm->op_pmshort));
     }
     if (pm->op_pmflags) {
-       *buf = '\0';
+       SV *tmpsv = newSVpv("", 0);
        if (pm->op_pmflags & PMf_USED)
-           (void)strcat(buf,"USED,");
+           sv_catpv(tmpsv, ",USED");
        if (pm->op_pmflags & PMf_ONCE)
-           (void)strcat(buf,"ONCE,");
+           sv_catpv(tmpsv, ",ONCE");
        if (pm->op_pmflags & PMf_SCANFIRST)
-           (void)strcat(buf,"SCANFIRST,");
+           sv_catpv(tmpsv, ",SCANFIRST");
        if (pm->op_pmflags & PMf_ALL)
-           (void)strcat(buf,"ALL,");
+           sv_catpv(tmpsv, ",ALL");
        if (pm->op_pmflags & PMf_SKIPWHITE)
-           (void)strcat(buf,"SKIPWHITE,");
+           sv_catpv(tmpsv, ",SKIPWHITE");
        if (pm->op_pmflags & PMf_CONST)
-           (void)strcat(buf,"CONST,");
+           sv_catpv(tmpsv, ",CONST");
        if (pm->op_pmflags & PMf_KEEP)
-           (void)strcat(buf,"KEEP,");
+           sv_catpv(tmpsv, ",KEEP");
        if (pm->op_pmflags & PMf_GLOBAL)
-           (void)strcat(buf,"GLOBAL,");
+           sv_catpv(tmpsv, ",GLOBAL");
        if (pm->op_pmflags & PMf_RUNTIME)
-           (void)strcat(buf,"RUNTIME,");
+           sv_catpv(tmpsv, ",RUNTIME");
        if (pm->op_pmflags & PMf_EVAL)
-           (void)strcat(buf,"EVAL,");
-       if (*buf)
-           buf[strlen(buf)-1] = '\0';
-       dump("PMFLAGS = (%s)\n",buf);
+           sv_catpv(tmpsv, ",EVAL");
+       dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
+       SvREFCNT_dec(tmpsv);
     }
 
     dumplvl--;
diff --git a/embed.h b/embed.h
index a5936c4..474f7e1 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -57,7 +57,6 @@
 #define block_start            Perl_block_start
 #define bool__amg              Perl_bool__amg
 #define bor_amg                        Perl_bor_amg
-#define buf                    Perl_buf
 #define bufend                 Perl_bufend
 #define bufptr                 Perl_bufptr
 #define bxor_amg               Perl_bxor_amg
 #define force_list             Perl_force_list
 #define force_next             Perl_force_next
 #define force_word             Perl_force_word
+#define form                   Perl_form
 #define free_tmps              Perl_free_tmps
 #define freq                   Perl_freq
 #define ge_amg                 Perl_ge_amg
 #define newSViv                        Perl_newSViv
 #define newSVnv                        Perl_newSVnv
 #define newSVpv                        Perl_newSVpv
+#define newSVpvf               Perl_newSVpvf
 #define newSVrv                        Perl_newSVrv
 #define newSVsv                        Perl_newSVsv
 #define newUNOP                        Perl_newUNOP
 #define sv_backoff             Perl_sv_backoff
 #define sv_bless               Perl_sv_bless
 #define sv_catpv               Perl_sv_catpv
+#define sv_catpvf              Perl_sv_catpvf
 #define sv_catpvn              Perl_sv_catpvn
 #define sv_catsv               Perl_sv_catsv
 #define sv_chop                        Perl_sv_chop
 #define sv_setnv               Perl_sv_setnv
 #define sv_setptrobj           Perl_sv_setptrobj
 #define sv_setpv               Perl_sv_setpv
+#define sv_setpvf              Perl_sv_setpvf
 #define sv_setpvn              Perl_sv_setpvn
 #define sv_setref_iv           Perl_sv_setref_iv
 #define sv_setref_nv           Perl_sv_setref_nv
 #define sv_untaint             Perl_sv_untaint
 #define sv_upgrade             Perl_sv_upgrade
 #define sv_usepvn              Perl_sv_usepvn
+#define sv_vcatpvfn            Perl_sv_vcatpvfn
+#define sv_vsetpvfn            Perl_sv_vsetpvfn
 #define sv_yes                 Perl_sv_yes
 #define taint_env              Perl_taint_env
 #define taint_proper           Perl_taint_proper
 #define mainstack              (curinterp->Imainstack)
 #define maxscream              (curinterp->Imaxscream)
 #define maxsysfd               (curinterp->Imaxsysfd)
+#define mess_sv                        (curinterp->Imess_sv)
 #define minus_F                        (curinterp->Iminus_F)
 #define minus_a                        (curinterp->Iminus_a)
 #define minus_c                        (curinterp->Iminus_c)
 #define Imainstack             mainstack
 #define Imaxscream             maxscream
 #define Imaxsysfd              maxsysfd
+#define Imess_sv               mess_sv
 #define Iminus_F               minus_F
 #define Iminus_a               minus_a
 #define Iminus_c               minus_c
 #define mainstack              Perl_mainstack
 #define maxscream              Perl_maxscream
 #define maxsysfd               Perl_maxsysfd
+#define mess_sv                        Perl_mess_sv
 #define minus_F                        Perl_minus_F
 #define minus_a                        Perl_minus_a
 #define minus_c                        Perl_minus_c
index 1c43517..fef4530 100644 (file)
@@ -175,13 +175,14 @@ dl_find_symbol(libhandle, symbolname)
     char *     symbolname
     CODE:
 #ifdef DLSYM_NEEDS_UNDERSCORE
-    char symbolname_buf[1024];
-    symbolname = dl_add_underscore(symbolname, symbolname_buf);
+    symbolname = form("_%s", symbolname);
 #endif
-    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%lx, symbol=%s)\n",
-       (unsigned long) libhandle, symbolname));
+    DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+                            "dl_find_symbol(handle=%lx, symbol=%s)\n",
+                            (unsigned long) libhandle, symbolname));
     RETVAL = dlsym(libhandle, symbolname);
-    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "  symbolref = %lx\n", (unsigned long) RETVAL));
+    DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+                            "  symbolref = %lx\n", (unsigned long) RETVAL));
     ST(0) = sv_newmortal() ;
     if (RETVAL == NULL)
        SaveError("%s",dlerror()) ;
index b5a75fe..fea6284 100644 (file)
@@ -88,11 +88,12 @@ dl_find_symbol(libhandle, symbolname)
     void *symaddr = NULL;
     int status;
 #ifdef __hp9000s300
-    char symbolname_buf[MAXPATHLEN];
-    symbolname = dl_add_underscore(symbolname, symbolname_buf);
+    symbolname = form("_%s", symbolname);
 #endif
-    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n",
-               libhandle, symbolname));
+    DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+                            "dl_find_symbol(handle=%lx, symbol=%s)\n",
+                            (unsigned long) libhandle, symbolname));
+
     ST(0) = sv_newmortal() ;
     errno = 0;
 
index 17b5be5..952c022 100644 (file)
@@ -72,7 +72,7 @@ enum dyldErrorSource
 static void TranslateError
     (const char *path, enum dyldErrorSource type, int number)
 {
-    char errorBuffer[128];
+    char *error;
     unsigned int index;
     static char *OFIErrorStrings[] =
     {
@@ -86,25 +86,22 @@ static void TranslateError
     };
 #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
 
-    if ( dl_last_error ) {
-        safefree(dl_last_error);
-    }
     switch (type)
     {
     case OFImage:
        index = number;
        if (index > NUM_OFI_ERRORS - 1)
            index = NUM_OFI_ERRORS - 1;
-       sprintf(errorBuffer, OFIErrorStrings[index], path, number);
+       error = form(OFIErrorStrings[index], path, number);
        break;
 
     default:
-       sprintf(errorBuffer, "%s(%d): Totally unknown error type %d\n",
-           path, number, type);
+       error = form("%s(%d): Totally unknown error type %d\n",
+                    path, number, type);
        break;
     }
-    dl_last_error = safemalloc(strlen(errorBuffer)+1);
-    strcpy(dl_last_error, errorBuffer);
+    safefree(dl_last_error);
+    dl_last_error = savepv(error);
 }
 
 static char *dlopen(char *path, int mode /* mode is ignored */)
@@ -209,13 +206,10 @@ void *handle;
 char *symbol;
 {
     NXStream   *nxerr = OpenError();
-    char       symbuf[1024];
     unsigned long      symref = 0;
 
-    sprintf(symbuf, "_%s", symbol);
-    if (!rld_lookup(nxerr, symbuf, &symref)) {
+    if (!rld_lookup(nxerr, form("_%s", symbuf), &symref))
        TransferError(nxerr);
-    }
     CloseError(nxerr);
     return (void*) symref;
 }
@@ -265,13 +259,14 @@ dl_find_symbol(libhandle, symbolname)
     char *             symbolname
     CODE:
 #if NS_TARGET_MAJOR >= 4
-    char symbolname_buf[1024];
-    symbolname = dl_add_underscore(symbolname, symbolname_buf);
+    symbolname = form("_%s", symbolname);
 #endif
-    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n",
-           libhandle, symbolname));
+    DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+                            "dl_find_symbol(handle=%lx, symbol=%s)\n",
+                            (unsigned long) libhandle, symbolname));
     RETVAL = dlsym(libhandle, symbolname);
-    DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "  symbolref = %x\n", RETVAL));
+    DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+                            "  symbolref = %lx\n", (unsigned long) RETVAL));
     ST(0) = sv_newmortal() ;
     if (RETVAL == NULL)
        SaveError("%s",dlerror()) ;
index e13427a..5800678 100644 (file)
@@ -82,15 +82,3 @@ SaveError(pat, va_alist)
     DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError));
 }
 
-
-/* prepend underscore to s. write into buf. return buf. */
-static char *
-dl_add_underscore(s, buf)
-char *s;
-char *buf;
-{
-    *buf = '_';
-    (void)strcpy(buf + 1, s);
-    return buf;
-}
-
index 92b443c..d23b318 100644 (file)
@@ -54,9 +54,11 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
        int             mode
        CODE:
        {
-           char tmpbuf[1025];
+           char *tmpbuf;
            if (dbmrefcnt++)
                croak("Old dbm can only open one database");
+           New(0, tmpbuf, strlen(filename) + 5, char);
+           SAVEFREEPV(tmpbuf);
            sprintf(tmpbuf,"%s.dir",filename);
            if (stat(tmpbuf, &statbuf) < 0) {
                if (flags & O_CREAT) {
index 7baefdb..781d179 100644 (file)
@@ -19,7 +19,6 @@ band_amg
 block_type
 bool__amg
 bor_amg
-buf
 bufend
 bufptr
 bxor_amg
@@ -431,6 +430,7 @@ force_ident
 force_list
 force_next
 force_word
+form
 free_tmps
 gen_constant_list
 gp_free
@@ -599,6 +599,7 @@ newSVREF
 newSViv
 newSVnv
 newSVpv
+newSVpvf
 newSVrv
 newSVsv
 newUNOP
@@ -1071,6 +1072,7 @@ sv_2uv
 sv_add_arena
 sv_backoff
 sv_bless
+sv_catpvf
 sv_catpv
 sv_catpvn
 sv_catsv
@@ -1106,6 +1108,7 @@ sv_reftype
 sv_replace
 sv_report_used
 sv_reset
+sv_setpvf
 sv_setiv
 sv_setnv
 sv_setptrobj
@@ -1124,6 +1127,8 @@ sv_unref
 sv_untaint
 sv_upgrade
 sv_usepvn
+sv_vcatpvfn
+sv_vsetpvfn
 taint_env
 taint_proper
 too_few_arguments
diff --git a/gv.c b/gv.c
index 90eee26..a18304e 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -376,23 +376,22 @@ char *name;
 U32 namelen;
 I32 create;
 {
-    char tmpbuf[1203];
+    char smallbuf[256];
+    char *tmpbuf;
     HV *stash;
     GV *tmpgv;
 
-    if (namelen > 1200) {
-       namelen = 1200;
-#ifdef VMS
-       warn("Weird package name \"%s\" truncated", name);
-#else
-       warn("Weird package name \"%.*s...\" truncated", (int)namelen, name);
-#endif
-    }
+    if (namelen + 3 < sizeof smallbuf)
+       tmpbuf = smallbuf;
+    else
+       New(606, tmpbuf, namelen + 3, char);
     Copy(name,tmpbuf,namelen,char);
     tmpbuf[namelen++] = ':';
     tmpbuf[namelen++] = ':';
     tmpbuf[namelen] = '\0';
-    tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
+    tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
+    if (tmpbuf != smallbuf)
+       Safefree(tmpbuf);
     if (!tmpgv)
        return 0;
     if (!GvHV(tmpgv))
@@ -873,8 +872,8 @@ GV *
 newGVgen(pack)
 char *pack;
 {
-    (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++);
-    return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
+    return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++),
+                     TRUE, SVt_PVGV);
 }
 
 /* hopefully this is only called on local symbol table entries */
@@ -1066,16 +1065,13 @@ HV* stash;
     }
 
     for (i = 1; i < NofAMmeth; i++) {
-        cv = 0;
-        cp = AMG_names[i];
-      
-       *buf = '(';                     /* A cookie: "(". */
-       strcpy(buf + 1, cp);
+       SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i]));
        DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
                     cp, HvNAME(stash)) );
-       gv = gv_fetchmeth(stash, buf, strlen(buf), -1); /* no filling stash! */
+       /* don't fill the cache while looking up! */
+       gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+        cv = 0;
         if(gv && (cv = GvCV(gv))) {
-           char *name = buf;
            if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
                && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
                /* GvSV contains the name of the method. */
@@ -1097,7 +1093,6 @@ HV* stash;
                              (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
                              cp, HvNAME(stash));
                }
-               name = SvPVX(GvSV(gv));
                cv = GvCV(gv = ngv);
            }
            DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
@@ -1280,9 +1275,10 @@ int flags;
       } else if (cvp && (cv=cvp[nomethod_amg])) {
        notfound = 1; lr = 1;
       } else {
+       SV *msg;
        if (off==-1) off=method;
-       sprintf(buf,
-               "Operation `%s': no method found,%sargument %s%.256s%s%.256s",
+       msg = sv_2mortal(newSVpvf(
+                     "Operation `%s': no method found,%sargument %s%s%s%s",
                      AMG_names[method + assignshift],
                      (flags & AMGf_unary ? " " : "\n\tleft "),
                      SvAMAGIC(left)? 
@@ -1298,11 +1294,11 @@ int flags;
                         : ",\n\tright argument has no overloaded magic"),
                      SvAMAGIC(right)? 
                        HvNAME(SvSTASH(SvRV(right))):
-                       "");
+                       ""));
        if (amtp && amtp->fallback >= AMGfallYES) {
-         DEBUG_o( deb(buf) );
+         DEBUG_o( deb("%s", SvPVX(msg)) );
        } else {
-         croak(buf);
+         croak("%S", msg);
        }
        return NULL;
       }
@@ -1310,7 +1306,7 @@ int flags;
   }
   if (!notfound) {
     DEBUG_o( deb(
-  "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
+  "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
                 AMG_names[off],
                 method+assignshift==off? "" :
                             " (initially `",
index 29a0691..ef98ace 100644 (file)
@@ -16,7 +16,6 @@ so='o'
 #sig_name='ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CHLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2 '
 signal_t='void'
 d_voidsig='define'
-d_dosuid='define'
 
 # we don't want to use -lnm, since exp() is busted (in 1.1 anyway)
 set `echo X "$libswanted "| sed -e 's/ nm / /'`
index 7ec8751..6ce5fa7 100644 (file)
@@ -59,7 +59,6 @@ case "$osvers" in
 2.0.5*|2.0-built*|2.1*)
        usevfork='true'
        usemymalloc='n'
-       d_dosuid='define'
        d_setregid='define'
        d_setreuid='define'
        d_setegid='undef'
@@ -73,7 +72,6 @@ case "$osvers" in
        usevfork='true'
        usemymalloc='n'
        libswanted=`echo $libswanted | sed 's/ malloc / /'`
-       d_dosuid='define'
        d_setregid='define'
        d_setreuid='define'
        d_setegid='undef'
index 99ab9c8..d458c49 100644 (file)
 
 # No version of Linux supports setuid scripts.
 d_suidsafe='undef'
-#don't force people to install SUID if they don't want to (have said  
-#-Dd_dosuid=undef explicitly on command line) - MIKEDLR
-if [ ! "A$d_dosuid" = "Aundef" ] #do I need to be paranoid here?
-then
-    d_dosuid='define'
-fi
-
 
 # perl goes into the /usr tree.  See the Filesystem Standard
 # available via anonymous FTP at tsx-11.mit.edu in
@@ -175,16 +168,17 @@ fi
 
 if [  ! "`csh -c 'echo $version' 2>/dev/null`"  ] 
 then
-       echo 'Real csh found (might break); looking for tcsh ...'
-       if which tcsh >/dev/null 2>&1
-       then
-               echo 'Found tcsh; will use it for globbing.'
-               csh='tcsh'
-               d_csh='tcsh'
-               full_csh=`which tcsh` # we know this will work now.
-       else
-               echo "Couldn't find tcsh.  BEWARE BROKEN GLOBBING."
-       fi
+    echo 'Real csh found (might break); looking for tcsh ...'
+    # Use ../UU/loc to find tcsh.  (We run in the hints/ directory.)
+    if xxx=`../UU/loc tcsh blurfl $pth`; $test -f "$xxx"; then
+       echo "Found tcsh.  I'll use it for globbing."
+       # We can't change Configure's setting of $csh, due to the way
+       # Configure handles $d_portable and commands found in $loclist.
+       # We can set the value for CSH in config.h by setting full_csh.
+       full_csh=$xxx
+    else
+       echo "Couldn't find tcsh.  BEWARE:  GLOBBING MIGHT BE BROKEN."
+    fi
 else
-       echo 'Your csh is really tcsh.  Good.'
+    echo 'Your csh is really tcsh.  Good.'
 fi
index c406a37..bc7dde4 100644 (file)
@@ -46,9 +46,6 @@ esac
 
 # MachTen doesn't have secure setid scripts
 d_suidsafe='undef'
-case "$d_dosuid" in
-'') d_dosuid='define' ;;
-esac
 
 # groupstype should be gid_t, as near as I can tell, but it only
 # seems to work right when it's int. 
index 07b1e55..9563bda 100755 (executable)
@@ -405,6 +405,9 @@ sub installlib {
 
     $name = "$dir/$name" if $dir ne '';
 
+    # ignore Chip-style patch backups.
+    return if grep(/^P\d+$/, split(m{/+}, $name));
+
     my $installlib = $installprivlib;
     if ($dir =~ /^auto/ ||
          ($name =~ /^(.*)\.(?:pm|pod)$/ && $archpms{$1})) {
index 80ef5b5..753f53d 100644 (file)
@@ -78,6 +78,7 @@ main_start
 mainstack
 maxscream
 maxsysfd
+mess_sv
 minus_F
 minus_a
 minus_c
index 71f553b..89e8671 100644 (file)
@@ -49,6 +49,7 @@ sub install {
        opendir DIR, $source_dir_or_file or next;
        for (readdir DIR) {
            next if $_ eq "." || $_ eq ".." || $_ eq ".exists";
+           next if /^P\d+$/ && -d "$source_dir_or_file/$_"; # no Chip bk's
            if (-w $hash{$source_dir_or_file} || mkpath($hash{$source_dir_or_file})) {
                last;
            } else {
@@ -88,6 +89,7 @@ sub install {
                          $atime,$mtime,$ctime,$blksize,$blocks) = stat;
            return unless -f _;
            return if $_ eq ".exists";
+           return if /\bP\d+\b/;       # no Chip-style backups
            my $targetdir = $MY->catdir($hash{$source},$File::Find::dir);
            my $targetfile = $MY->catfile($targetdir,$_);
 
diff --git a/mg.c b/mg.c
index 1355740..7d8cd04 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -531,27 +531,20 @@ MAGIC *mg;
        break;
     case '(':
        sv_setiv(sv, (IV)gid);
-       s = buf;
-       (void)sprintf(s,"%d",(int)gid);
+       sv_setpvf(sv, "%vd", (IV)gid);
        goto add_groups;
     case ')':
        sv_setiv(sv, (IV)egid);
-       s = buf;
-       (void)sprintf(s,"%d",(int)egid);
+       sv_setpvf(sv, "%vd", (IV)egid);
       add_groups:
-       while (*s) s++;
 #ifdef HAS_GETGROUPS
        {
            Groups_t gary[NGROUPS];
-
            i = getgroups(NGROUPS,gary);
-           while (--i >= 0) {
-               (void)sprintf(s," %d", (int)gary[i]);
-               while (*s) s++;
-           }
+           while (--i >= 0)
+               sv_catpvf(sv, " %vd", (IV)gary[i]);
        }
 #endif
-       sv_setpv(sv,buf);
        SvIOK_on(sv);   /* what a wonderful hack! */
        break;
     case '*':
@@ -769,10 +762,8 @@ MAGIC* mg;
         * access to a known hint bit in a known OP, we can't
         * tell whether HINT_STRICT_REFS is in force or not.
         */
-       if (!strchr(s,':') && !strchr(s,'\'')) {
-           sprintf(tokenbuf, "main::%s",s);
-           sv_setpv(sv,tokenbuf);
-       }
+       if (!strchr(s,':') && !strchr(s,'\''))
+           sv_setpv(sv, form("main::%s", s));
        if (i)
            (void)rsignal(i, sighandler);
        else
diff --git a/op.c b/op.c
index 6a1fa5b..747ae0f 100644 (file)
--- a/op.c
+++ b/op.c
@@ -48,11 +48,11 @@ static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
        CV* startcv, I32 cx_ix));
 
 static char*
-CvNAME(cv)
-CV* cv;
+gv_ename(gv)
+GV* gv;
 {
     SV* tmpsv = sv_newmortal();
-    gv_efullname3(tmpsv, CvGV(cv), Nullch);
+    gv_efullname3(tmpsv, gv, Nullch);
     return SvPV(tmpsv,na);
 }
 
@@ -60,9 +60,8 @@ static OP *
 no_fh_allowed(op)
 OP *op;
 {
-    sprintf(tokenbuf,"Missing comma after first argument to %s function",
-       op_desc[op->op_type]);
-    yyerror(tokenbuf);
+    yyerror(form("Missing comma after first argument to %s function",
+                op_desc[op->op_type]));
     return op;
 }
 
@@ -71,8 +70,7 @@ too_few_arguments(op, name)
 OP* op;
 char* name;
 {
-    sprintf(tokenbuf,"Not enough arguments for %s", name);
-    yyerror(tokenbuf);
+    yyerror(form("Not enough arguments for %s", name));
     return op;
 }
 
@@ -81,8 +79,7 @@ too_many_arguments(op, name)
 OP *op;
 char* name;
 {
-    sprintf(tokenbuf,"Too many arguments for %s", name);
-    yyerror(tokenbuf);
+    yyerror(form("Too many arguments for %s", name));
     return op;
 }
 
@@ -93,9 +90,8 @@ char *t;
 char *name;
 OP *kid;
 {
-    sprintf(tokenbuf, "Type of arg %d to %s must be %s (not %s)",
-       (int) n, name, t, op_desc[kid->op_type]);
-    yyerror(tokenbuf);
+    yyerror(form("Type of arg %d to %s must be %s (not %s)",
+                (int)n, name, t, op_desc[kid->op_type]));
     return op;
 }
 
@@ -105,8 +101,7 @@ OP *op;
 {
     int type = op->op_type;
     if (type != OP_AELEM && type != OP_HELEM) {
-       sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]);
-       yyerror(tokenbuf);
+       yyerror(form("Can't use subscript on %s", op_desc[type]));
        if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV)
            warn("(Did you mean $ or @ instead of %c?)\n",
                 type == OP_ENTERSUB ? '&' : '%');
@@ -123,8 +118,11 @@ char *name;
     SV *sv;
 
     if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) {
-       if (!isPRINT(name[1]))
-           sprintf(name+1, "^%c", toCTRL(name[1])); /* XXX tokenbuf, really */
+       if (!isPRINT(name[1])) {
+           name[3] = '\0';
+           name[2] = toCTRL(name[1]);
+           name[1] = '^';
+       }
        croak("Can't use global %s in \"my\"",name);
     }
     if (AvFILL(comppad_name) >= 0) {
@@ -1016,10 +1014,9 @@ I32 type;
        /* grep, foreach, subcalls, refgen */
        if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
            break;
-       sprintf(tokenbuf, "Can't modify %s in %s",
-           op_desc[op->op_type],
-           type ? op_desc[type] : "local");
-       yyerror(tokenbuf);
+       yyerror(form("Can't modify %s in %s",
+                    op_desc[op->op_type],
+                    type ? op_desc[type] : "local"));
        return op;
 
     case OP_PREINC:
@@ -1321,8 +1318,7 @@ OP *op;
             type != OP_PADHV &&
             type != OP_PUSHMARK)
     {
-       sprintf(tokenbuf, "Can't declare %s in my", op_desc[op->op_type]);
-       yyerror(tokenbuf);
+       yyerror(form("Can't declare %s in my", op_desc[op->op_type]));
        return op;
     }
     op->op_flags |= OPf_MOD;
@@ -2945,8 +2941,16 @@ CV *cv;
            I32 i = AvFILL(CvPADLIST(cv));
            while (i >= 0) {
                SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
-               if (svp)
-                   SvREFCNT_dec(*svp);
+               SV* sv = svp ? *svp : Nullsv;
+               if (!sv)
+                   continue;
+               if (sv == (SV*)comppad_name)
+                   comppad_name = Nullav;
+               else if (sv == (SV*)comppad) {
+                   comppad = Nullav;
+                   curpad = Null(SV**);
+               }
+               SvREFCNT_dec(sv);
            }
            SvREFCNT_dec((SV*)CvPADLIST(cv));
        }
@@ -3022,6 +3026,7 @@ CV* outside;
     ENTER;
     SAVESPTR(curpad);
     SAVESPTR(comppad);
+    SAVESPTR(comppad_name);
     SAVESPTR(compcv);
 
     cv = compcv = (CV*)NEWSV(1104,0);
@@ -3041,11 +3046,15 @@ CV* outside;
     if (SvPOK(proto))
        sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
 
+    comppad_name = newAV();
+    for (ix = fname; ix >= 0; ix--)
+       av_store(comppad_name, ix, SvREFCNT_inc(pname[ix]));
+
     comppad = newAV();
 
     comppadlist = newAV();
     AvREAL_off(comppadlist);
-    av_store(comppadlist, 0, SvREFCNT_inc((SV*)protopad_name));
+    av_store(comppadlist, 0, (SV*)comppad_name);
     av_store(comppadlist, 1, (SV*)comppad);
     CvPADLIST(cv) = comppadlist;
     av_fill(comppad, AvFILL(protopad));
@@ -3137,26 +3146,22 @@ GV* gv;
 char* p;
 {
     if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) {
-       char* buf;
+       SV* msg = sv_newmortal();
        SV* name = Nullsv;
 
        if (gv)
-           gv_efullname3(name = NEWSV(606, 40), gv, Nullch);
-       New(607, buf, ((name ? SvCUR(name) : 0)
-                      + (SvPOK(cv) ? SvCUR(cv) : 0)
-                      + (p ? strlen(p) : 0)
-                      + 60), char);
-       strcpy(buf, "Prototype mismatch:");
-       if (name) {
-           sprintf(buf + strlen(buf), " sub %s", SvPVX(name));
-           SvREFCNT_dec(name);
-       }
+           gv_efullname3(name = sv_newmortal(), gv, Nullch);
+       sv_setpv(msg, "Prototype mismatch:");
+       if (name)
+           sv_catpvf(msg, " sub %S", name);
        if (SvPOK(cv))
-           sprintf(buf + strlen(buf), " (%s)", SvPVX(cv));
-       strcat(buf, " vs ");
-       sprintf(buf + strlen(buf), p ? "(%s)" : "none", p);
-       warn("%s", buf);
-       Safefree(buf);
+           sv_catpvf(msg, " (%s)", SvPVX(cv));
+       sv_catpv(msg, " vs ");
+       if (p)
+           sv_catpvf(msg, "(%s)", p);
+       else
+           sv_catpv(msg, "none");
+       warn("%S", msg);
     }
 }
 
@@ -3337,18 +3342,15 @@ OP *block;
        char *s;
 
        if (perldb && curstash != debstash) {
-           SV *sv;
+           SV *sv = NEWSV(0,0);
            SV *tmpstr = sv_newmortal();
            static GV *db_postponed;
            CV *cv;
            HV *hv;
 
-           sprintf(buf, "%s:%ld",
-                   SvPVX(GvSV(curcop->cop_filegv)), (long)subline);
-           sv = newSVpv(buf,0);
-           sv_catpv(sv,"-");
-           sprintf(buf,"%ld",(long)curcop->cop_line);
-           sv_catpv(sv,buf);
+           sv_setpvf(sv, "%S:%ld-%ld",
+                   GvSV(curcop->cop_filegv),
+                   (long)subline, (long)curcop->cop_line);
            gv_efullname3(tmpstr, gv, Nullch);
            hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
            if (!db_postponed) {
@@ -4088,8 +4090,14 @@ OP *op;
     GV *gv = gv_fetchpv("glob", FALSE, SVt_PVCV);
 
     if (gv && GvIMPORTED_CV(gv)) {
+       static int glob_index;
+
+       append_elem(OP_GLOB, op,
+                   newSVOP(OP_CONST, 0, newSViv(glob_index++)));
        op->op_type = OP_LIST;
        op->op_ppaddr = ppaddr[OP_LIST];
+       ((LISTOP*)op)->op_first->op_type = OP_PUSHMARK;
+       ((LISTOP*)op)->op_first->op_ppaddr = ppaddr[OP_PUSHMARK];
        op = newUNOP(OP_ENTERSUB, OPf_STACKED,
                     append_elem(OP_LIST, op, 
                                 scalar(newUNOP(OP_RV2CV, 0,
@@ -4476,6 +4484,7 @@ OP *op;
     OP *cvop;
     char *proto = 0;
     CV *cv = 0;
+    GV *namegv = 0;
     int optional = 0;
     I32 arg = 0;
 
@@ -4487,8 +4496,10 @@ OP *op;
        tmpop = (SVOP*)((UNOP*)cvop)->op_first;
        if (tmpop->op_type == OP_GV) {
            cv = GvCVu(tmpop->op_sv);
-           if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER))
-               proto = SvPV((SV*)cv,na);
+           if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER)) {
+               namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv);
+               proto = SvPV((SV*)cv, na);
+           }
        }
     }
     op->op_private |= (hints & HINT_STRICT_REFS);
@@ -4498,7 +4509,7 @@ OP *op;
        if (proto) {
            switch (*proto) {
            case '\0':
-               return too_many_arguments(op, CvNAME(cv));
+               return too_many_arguments(op, gv_ename(namegv));
            case ';':
                optional = 1;
                proto++;
@@ -4517,7 +4528,7 @@ OP *op;
                proto++;
                arg++;
                if (o->op_type != OP_REFGEN && o->op_type != OP_UNDEF)
-                   bad_type(arg, "block", CvNAME(cv), o);
+                   bad_type(arg, "block", gv_ename(namegv), o);
                break;
            case '*':
                proto++;
@@ -4538,23 +4549,23 @@ OP *op;
                switch (*proto++) {
                case '*':
                    if (o->op_type != OP_RV2GV)
-                       bad_type(arg, "symbol", CvNAME(cv), o);
+                       bad_type(arg, "symbol", gv_ename(namegv), o);
                    goto wrapref;
                case '&':
                    if (o->op_type != OP_RV2CV)
-                       bad_type(arg, "sub", CvNAME(cv), o);
+                       bad_type(arg, "sub", gv_ename(namegv), o);
                    goto wrapref;
                case '$':
                    if (o->op_type != OP_RV2SV && o->op_type != OP_PADSV)
-                       bad_type(arg, "scalar", CvNAME(cv), o);
+                       bad_type(arg, "scalar", gv_ename(namegv), o);
                    goto wrapref;
                case '@':
                    if (o->op_type != OP_RV2AV && o->op_type != OP_PADAV)
-                       bad_type(arg, "array", CvNAME(cv), o);
+                       bad_type(arg, "array", gv_ename(namegv), o);
                    goto wrapref;
                case '%':
                    if (o->op_type != OP_RV2HV && o->op_type != OP_PADHV)
-                       bad_type(arg, "hash", CvNAME(cv), o);
+                       bad_type(arg, "hash", gv_ename(namegv), o);
                  wrapref:
                    {
                        OP* kid = o;
@@ -4573,7 +4584,7 @@ OP *op;
            default:
              oops:
                croak("Malformed prototype for %s: %s",
-                       CvNAME(cv),SvPV((SV*)cv,na));
+                       gv_ename(namegv), SvPV((SV*)cv, na));
            }
        }
        else
@@ -4583,7 +4594,7 @@ OP *op;
        o = o->op_sibling;
     }
     if (proto && !optional && *proto == '$')
-       return too_few_arguments(op, CvNAME(cv));
+       return too_few_arguments(op, gv_ename(namegv));
     return op;
 }
 
index a75fc48..e517f7a 100644 (file)
  */
 static char    *local_patches[] = {
        NULL
-       ,"Dev97A - First development patch to 5.003_97"
-       ,"Dev97B - Second development patch to 5.003_97"
-       ,"Dev97C - Third development patch to 5.003_97"
-       ,"Dev97D - Fourth development patch to 5.003_97"
-       ,"Dev97E - Fifth development patch to 5.003_97"
-       ,"Dev97F - Sixth development patch to 5.003_97"
-       ,"Dev97G - Seventh development patch to 5.003_97"
+       ,"Dev97A-H - Eight development patches to 5.003_97"
        ,NULL
 };
 
diff --git a/perl.c b/perl.c
index e4767d5..b4d69cb 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -59,6 +59,7 @@ dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
     dlmax       = 128;         \
     laststatval = -1;          \
     laststype   = OP_STAT;     \
+    mess_sv     = Nullsv;      \
   } STMT_END
 
 static void find_beginning _((void));
@@ -376,6 +377,11 @@ register PerlInterpreter *sv_interp;
                 (long)cxstack_ix + 1);
     }
 
+
+    /* Without SVs, messages must be primitive. */
+    SvREFCNT_dec(mess_sv);
+    mess_sv = &sv_undef;
+
     /* Now absolutely destruct everything, somehow or other, loops or no. */
     last_sv_count = 0;
     SvFLAGS(strtab) |= SVTYPEMASK;             /* don't clean out strtab now */
@@ -629,40 +635,35 @@ setuid perl scripts securely.\n");
                sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 #endif
 #if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
-               strcpy(buf,"\"  Compile-time options:");
+               sv_catpv(Sv,"\"  Compile-time options:");
 #  ifdef DEBUGGING
-               strcat(buf," DEBUGGING");
+               sv_catpv(Sv," DEBUGGING");
 #  endif
 #  ifdef NO_EMBED
-               strcat(buf," NO_EMBED");
+               sv_catpv(Sv," NO_EMBED");
 #  endif
 #  ifdef MULTIPLICITY
-               strcat(buf," MULTIPLICITY");
+               sv_catpv(Sv," MULTIPLICITY");
 #  endif
-               strcat(buf,"\\n\",");
-               sv_catpv(Sv,buf);
+               sv_catpv(Sv,"\\n\",");
 #endif
 #if defined(LOCAL_PATCH_COUNT)
                if (LOCAL_PATCH_COUNT > 0) {
                    int i;
                    sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
                    for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
-                       if (localpatches[i]) {
-                           sprintf(buf,"\"  \\t%s\\n\",",localpatches[i]);
-                           sv_catpv(Sv,buf);
-                       }
+                       if (localpatches[i])
+                           sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
                    }
                }
 #endif
-               sprintf(buf,"\"  Built under %s\\n\"",OSNAME);
-               sv_catpv(Sv,buf);
+               sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
 #ifdef __DATE__
 #  ifdef __TIME__
-               sprintf(buf,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
+               sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
 #  else
-               sprintf(buf,",\"  Compiled on %s\\n\"",__DATE__);
+               sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
 #  endif
-               sv_catpv(Sv,buf);
 #endif
                sv_catpv(Sv, "; \
 $\"=\"\\n    \"; \
@@ -1341,9 +1342,8 @@ char *s;
        forbid_setid("-d");
        s++;
        if (*s == ':' || *s == '=')  {
-           sprintf(buf, "use Devel::%s;", ++s);
+           my_setenv("PERL5DB", form("use Devel::%s;", ++s));
            s += strlen(s);
-           my_setenv("PERL5DB",buf);
        }
        if (!perldb) {
            perldb = TRUE;
@@ -1539,15 +1539,20 @@ void
 my_unexec()
 {
 #ifdef UNEXEC
+    SV*    prog;
+    SV*    file;
     int    status;
     extern int etext;
 
-    sprintf (buf, "%s.perldump", origfilename);
-    sprintf (tokenbuf, "%s/perl", BIN_EXP);
+    prog = newSVpv(BIN_EXP);
+    sv_catpv(prog, "/perl");
+    file = newSVpv(origfilename);
+    sv_catpv(file, ".perldump");
 
-    status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
+    status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
     if (status)
-       PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf);
+       PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
+                     SvPVX(prog), SvPVX(file));
     exit(status);
 #else
 #  ifdef VMS
@@ -1714,16 +1719,19 @@ SV *sv;
 #endif
     }
     else if (preprocess) {
-       char *cpp = CPPSTDIN;
+       char *cpp_cfg = CPPSTDIN;
+       SV *cpp = NEWSV(0,0);
+       SV *cmd = NEWSV(0,0);
+
+       if (strEQ(cpp_cfg, "cppstdin"))
+           sv_catpvf(cpp, "%s/", BIN_EXP);
+       sv_catpv(cpp, cpp_cfg);
 
-       if (strEQ(cpp,"cppstdin"))
-           sprintf(tokenbuf, "%s/%s", BIN_EXP, cpp);
-       else
-           sprintf(tokenbuf, "%s", cpp);
        sv_catpv(sv,"-I");
        sv_catpv(sv,PRIVLIB_EXP);
+
 #ifdef MSDOS
-       (void)sprintf(buf, "\
+       sv_setpvf(cmd, "\
 sed %s -e \"/^[^#]/b\" \
  -e \"/^#[     ]*include[      ]/b\" \
  -e \"/^#[     ]*define[       ]/b\" \
@@ -1735,10 +1743,10 @@ sed %s -e \"/^[^#]/b\" \
  -e \"/^#[     ]*undef[        ]/b\" \
  -e \"/^#[     ]*endif/b\" \
  -e \"s/^#.*//\" \
- %s | %s -C %s %s",
+ %s | %S -C %S %s",
          (doextract ? "-e \"1,/^#/d\n\"" : ""),
 #else
-       (void)sprintf(buf, "\
+       sv_setpvf(cmd, "\
 %s %s -e '/^[^#]/b' \
  -e '/^#[      ]*include[      ]/b' \
  -e '/^#[      ]*define[       ]/b' \
@@ -1750,7 +1758,7 @@ sed %s -e \"/^[^#]/b\" \
  -e '/^#[      ]*undef[        ]/b' \
  -e '/^#[      ]*endif/b' \
  -e 's/^[      ]*#.*//' \
- %s | %s -C %s %s",
+ %s | %S -C %S %s",
 #ifdef LOC_SED
          LOC_SED,
 #else
@@ -1758,7 +1766,7 @@ sed %s -e \"/^[^#]/b\" \
 #endif
          (doextract ? "-e '1,/^#/d\n'" : ""),
 #endif
-         scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
+         scriptname, cpp, sv, CPPMINUS);
        doextract = FALSE;
 #ifdef IAMSUID                         /* actually, this is caught earlier */
        if (euid != uid && !euid) {     /* if running suidperl */
@@ -1779,7 +1787,9 @@ sed %s -e \"/^[^#]/b\" \
                croak("Can't do seteuid!\n");
        }
 #endif /* IAMSUID */
-       rsfp = my_popen(buf,"r");
+       rsfp = my_popen(SvPVX(cmd), "r");
+       SvREFCNT_dec(cmd);
+       SvREFCNT_dec(cpp);
     }
     else if (!*scriptname) {
        forbid_setid("program input from stdin");
@@ -1800,8 +1810,8 @@ sed %s -e \"/^[^#]/b\" \
 #ifndef IAMSUID                /* in case script is not readable before setuid */
        if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
          statbuf.st_mode & (S_ISUID|S_ISGID)) {
-           (void)sprintf(buf, "%s/sperl%s", BIN_EXP, patchlevel);
-           execv(buf, origargv);       /* try again */
+           /* try again */
+           execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
            croak("Can't do setuid\n");
        }
 #endif
@@ -1948,8 +1958,8 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
        if (euid) {     /* oops, we're not the setuid root perl */
            (void)PerlIO_close(rsfp);
 #ifndef IAMSUID
-           (void)sprintf(buf, "%s/sperl%s", BIN_EXP, patchlevel);
-           execv(buf, origargv);       /* try again */
+           /* try again */
+           execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
 #endif
            croak("Can't do setuid\n");
        }
@@ -2026,15 +2036,12 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
     if (!origargv[which])
        croak("Permission denied");
-    (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
-    origargv[which] = buf;
-
+    origargv[which] = savepv(form("/dev/fd/%d/%s",
+                                 PerlIO_fileno(rsfp), origargv[which]));
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);      /* ensure no close-on-exec */
 #endif
-
-    (void)sprintf(tokenbuf, "%s/perl%s", BIN_EXP, patchlevel);
-    execv(tokenbuf, origargv); /* try again */
+    execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);   /* try again */
     croak("Can't do setuid\n");
 #endif /* IAMSUID */
 #else /* !DOSUID */
diff --git a/perl.h b/perl.h
index 64561f0..b807b5d 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1354,7 +1354,6 @@ EXT SV ** curpad;
 /* temp space */
 EXT SV *       Sv;
 EXT XPV *      Xpv;
-EXT char       buf[2048];      /* should be longer than PATH_MAX */
 EXT char       tokenbuf[256];
 EXT struct stat        statbuf;
 #ifdef HAS_TIMES
@@ -1879,6 +1878,7 @@ IEXT bool Ipreambled;
 IEXT AV *      Ipreambleav;
 IEXT int       Ilaststatval IINIT(-1);
 IEXT I32       Ilaststype IINIT(OP_STAT);
+IEXT SV *      Imess_sv;
 
 #undef IEXT
 #undef IINIT
index 0613412..70d2216 100644 (file)
@@ -490,6 +490,19 @@ the print function.
        return print join( $, => map {uc} @_), $\;
     }
 
+=item PRINTF this, LIST
+
+This method will be triggered every time the tied handle is printed to
+with the C<printf()> function.
+Beyond its self reference it also expects the format and list that was
+passed to the printf function.
+
+    sub PRINTF {
+        shift;
+         my $fmt = shift;
+        print sprintf($fmt, @_)."\n";
+    }
+
 =item READ this LIST
 
 This method will be called when the handle is read from via the C<read>
@@ -717,16 +730,16 @@ alphabetically:
     FindBin.pm           Find path of currently executing program
 
     Class/Struct.pm      Declare struct-like datatypes as Perl classes
-    File/stat.pm         By-name interface to Perl's built-in stat
-    Net/hostent.pm       By-name interface to Perl's built-in gethost*
-    Net/netent.pm        By-name interface to Perl's built-in getnet*
-    Net/protoent.pm      By-name interface to Perl's built-in getproto*
-    Net/servent.pm       By-name interface to Perl's built-in getserv*
-    Time/gmtime.pm       By-name interface to Perl's built-in gmtime
-    Time/localtime.pm    By-name interface to Perl's built-in localtime
+    File/stat.pm         By-name interface to Perl's builtin stat
+    Net/hostent.pm       By-name interface to Perl's builtin gethost*
+    Net/netent.pm        By-name interface to Perl's builtin getnet*
+    Net/protoent.pm      By-name interface to Perl's builtin getproto*
+    Net/servent.pm       By-name interface to Perl's builtin getserv*
+    Time/gmtime.pm       By-name interface to Perl's builtin gmtime
+    Time/localtime.pm    By-name interface to Perl's builtin localtime
     Time/tm.pm           Internal object for Time::{gm,local}time
-    User/grent.pm        By-name interface to Perl's built-in getgr*
-    User/pwent.pm        By-name interface to Perl's built-in getpw*
+    User/grent.pm        By-name interface to Perl's builtin getgr*
+    User/pwent.pm        By-name interface to Perl's builtin getpw*
 
     Tie/RefHash.pm       Base class for tied hashes with references as keys
 
index 99aeae9..95a4a5c 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq - frequently asked questions about Perl ($Date: 1997/03/25 18:20:48 $)
+perlfaq - frequently asked questions about Perl ($Date: 1997/04/23 18:11:06 $)
 
 =head1 DESCRIPTION
 
@@ -64,8 +64,8 @@ at http://www.perl.com/perl/faq/ .
 =head2 How to contribute to this document
 
 You may mail corrections, additions, and suggestions to
-perlfaq-suggestions@perl.com.  Mail sent to the old perlfaq alias will
-merely cause the FAQ to be sent to you.
+perlfaq-suggestions@perl.com .  Mail sent to the old perlfaq alias
+will merely cause the FAQ to be sent to you.
 
 =head2 What will happen if you mail your Perl programming problems to the authors
 
@@ -124,6 +124,20 @@ in respect of this information or its use.
 
 =over 4
 
+=item 23/April/97
+
+Added http://www.oasis.leo.org/perl/ to L<perlfaq2>.  Style fix to
+L<perlfaq3>.  Added floating point precision, fixed complex number
+arithmetic, cross-references, caveat for Text::Wrap, alternative
+answer for initial capitalizing, fixed incorrect regexp, added example
+of Tie::IxHash to L<perlfaq4>.  Added example of passing and storing
+filehandles, added commify to L<perlfaq5>.  Restored variable suicide,
+and added mass commenting to L<perlfaq7>.  Added Net::Telnet, fixed
+backticks, added reader/writer pair to telnet question, added FindBin,
+grouped module questions together in L<perlfaq8>.  Expanded caveats
+for the simple URL extractor, gave LWP example, added CGI security
+question, expanded on the email address answer in L<perlfaq9>.
+
 =item 25/March/97
 
 Added more info to the binary distribution section of L<perlfaq2>.
@@ -131,7 +145,7 @@ Added Net::Telnet to L<perlfaq6>.  Fixed typos in L<perlfaq8>.  Added
 mail sending example to L<perlfaq9>.  Added Merlyn's columns to
 L<perlfaq2>.
 
-=item 18/March/97 
+=item 18/March/97
 
 Added the DATE to the NAME section, indicating which sections have
 changed.
index 99d4b35..6463a98 100644 (file)
@@ -168,7 +168,7 @@ notice that perl is not itself written in Perl.
 The new native-code compiler for Perl may reduce the limitations given
 in the previous statement to some degree, but understand that Perl
 remains fundamentally a dynamically typed language, and not a
-statically typed one.  You certainly won't be chastised if you don't
+statically typed one.  You certainly won't be chastized if you don't
 trust nuclear-plant or brain-surgery monitoring code to it.  And
 Larry will sleep easier, too -- Wall Street programs not
 withstanding. :-)
@@ -187,10 +187,10 @@ ok, while "awk and Perl" and "Python and perl" do not.
 It doesn't matter.
 
 In "standard terminology" a I<program> has been compiled to physical
-machine code once, and can then be run multiple times, whereas a
+machine code once, and can then be be run multiple times, whereas a
 I<script> must be translated by a program each time it's used.  Perl
 programs, however, are usually neither strictly compiled nor strictly
-interpreted.  They can be compiled to a bytecode form (something of a Perl
+interpreted.  They can be compiled to a byte code form (something of a Perl
 virtual machine) or to completely different languages, like C or assembly
 language.  You can't tell just by looking whether the source is destined
 for a pure interpreter, a parse-tree interpreter, a byte code interpreter,
index 95d542d..8a954da 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.15 $, $Date: 1997/03/25 18:15:48 $)
+perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.16 $, $Date: 1997/04/23 18:04:09 $)
 
 =head1 DESCRIPTION
 
@@ -62,7 +62,7 @@ eventually live on, and then type C<make install>.  Most other
 approaches are doomed to failure.
 
 One simple way to check that things are in the right place is to print out
-the hardcoded @INC which perl is looking for.
+the hard-coded @INC which perl is looking for.
 
        perl -e 'print join("\n",@INC)'
 
@@ -76,7 +76,7 @@ module/library directory?">.
 =head2 I grabbed the sources and tried to compile but gdbm/dynamic loading/malloc/linking/... failed.  How do I make it work?
 
 Read the F<INSTALL> file, which is part of the source distribution.
-It describes in detail how to cope with most idiosyncrasies that the
+It describes in detail how to cope with most idiosyncracies that the
 Configure script can't work around for any given system or
 architecture.
 
@@ -84,7 +84,7 @@ architecture.
 
 CPAN stands for Comprehensive Perl Archive Network, a huge archive
 replicated on dozens of machines all over the world.  CPAN contains
-source code, nonnative ports, documentation, scripts, and many
+source code, non-native ports, documentation, scripts, and many
 third-party modules and extensions, designed for everything from
 commercial database interfaces to keyboard/screen control to web
 walking and CGI scripts.  The master machine for CPAN is
@@ -191,7 +191,7 @@ before you buy!
 What follows is a list of the books that the FAQ authors found personally
 useful.  Your mileage may (but, we hope, probably won't) vary.
 
-If you're already a hardcore systems programmer, then the Camel Book
+If you're already a hard-core systems programmer, then the Camel Book
 just might suffice for you to learn Perl from.  But if you're not,
 check out the "Llama Book".  It currently doesn't cover perl5, but the
 2nd edition is nearly done and should be out by summer 97:
@@ -260,6 +260,9 @@ following list is I<not> the complete list of CPAN mirrors.
   http://www.cs.ruu.nl/pub/PERL/CPAN/
   ftp://ftp.cs.colorado.edu/pub/perl/CPAN/
 
+http:/www.oasis.leo.org/perl/ has, amongst other things, source to
+versions 1 through 5 of Perl.
+
 =head2 What mailing lists are there for perl?
 
 Most of the major modules (tk, CGI, libwww-perl) have their own
@@ -279,7 +282,7 @@ There is a mailing list for discussing Macintosh Perl.  Contact
 "mac-perl-request@iis.ee.ethz.ch".
 
 Also see Matthias Neeracher's (the creator and maintainer of MacPerl)
-web page at http://www.iis.ee.ethz.ch/~neeri/macintosh/perl.html for
+webpage at http://www.iis.ee.ethz.ch/~neeri/macintosh/perl.html for
 many links to interesting MacPerl sites, and the applications/MPW
 tools, precompiled.
 
@@ -405,19 +408,19 @@ If you are reporting a bug in the perl interpreter or the modules
 shipped with perl, use the perlbug program in the perl distribution or
 email your report to perlbug@perl.com.
 
-If you are posting a bug with a nonstandard port (see the answer to
+If you are posting a bug with a non-standard port (see the answer to
 "What platforms is Perl available for?"), a binary distribution, or a
-nonstandard module (such as Tk, CGI, etc), then please see the
+non-standard module (such as Tk, CGI, etc), then please see the
 documentation that came with it to determine the correct place to post
 bugs.
 
-Read the perlbug manpage (perl5.004 or later) for more information.
+Read the perlbug man page (perl5.004 or later) for more information.
 
 =head2 What is perl.com?  perl.org?  The Perl Institute?
 
 perl.org is the official vehicle for The Perl Institute.  The motto of
 TPI is "helping people help Perl help people" (or something like
-that).  It's a nonprofit organization supporting development,
+that).  It's a non-profit organization supporting development,
 documentation, and dissemination of perl.  Current directors of TPI
 include Larry Wall, Tom Christiansen, and Randal Schwartz, whom you
 may have heard of somewhere else around here.
@@ -425,8 +428,8 @@ may have heard of somewhere else around here.
 The perl.com domain is Tom Christiansen's domain.  He created it as a
 public service long before perl.org came about.  It's the original PBS
 of the Perl world, a clearinghouse for information about all things
-Perlian, accepting no paid advertisements, glossy GIFs, or (gasp!)
-Java applets on its pages.
+Perlian, accepting no paid advertisements, glossy gifs, or (gasp!)
+java applets on its pages.
 
 =head2 How do I learn about object-oriented Perl programming?
 
index e6bfd3d..7489e98 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq3 - Programming Tools ($Revision: 1.20 $, $Date: 1997/03/19 17:23:43 $)
+perlfaq3 - Programming Tools ($Revision: 1.21 $, $Date: 1997/04/23 18:04:23 $)
 
 =head1 DESCRIPTION
 
@@ -11,7 +11,7 @@ and programming support.
 
 Have you looked at CPAN (see L<perlfaq2>)?  The chances are that
 someone has already written a module that can solve your problem.
-Have you read the appropriate manpages?  Here's a brief index:
+Have you read the appropriate man pages?  Here's a brief index:
 
        Objects         perlref, perlmod, perlobj, perltie
        Data Structures perlref, perllol, perldsc
@@ -22,12 +22,12 @@ Have you read the appropriate manpages?  Here's a brief index:
        Various         http://www.perl.com/CPAN/doc/FMTEYEWTK/index.html
                        (not a man-page but still useful)
 
-L<perltoc> provides a crude table of contents for the perl manpage set.
+L<perltoc> provides a crude table of contents for the perl man page set.
 
 =head2 How can I use Perl interactively?
 
 The typical approach uses the Perl debugger, described in the
-perldebug(1) manpage, on an "empty" program, like this:
+perldebug(1) man page, on an "empty" program, like this:
 
     perl -de 42
 
@@ -235,7 +235,7 @@ use in other parts of your program.  (NB: my() variables also execute
 about 10% faster than globals.)  A global variable, of course, never
 goes out of scope, so you can't get its space automatically reclaimed,
 although undef()ing and/or delete()ing it will achieve the same effect.
-In general, memory allocation and deallocation isn't something you can
+In general, memory allocation and de-allocation isn't something you can
 or should be worrying about much in Perl, but even this capability
 (preallocation of data types) is in the works.
 
@@ -244,15 +244,15 @@ or should be worrying about much in Perl, but even this capability
 Beyond the normal measures described to make general Perl programs
 faster or smaller, a CGI program has additional issues.  It may be run
 several times per second.  Given that each time it runs it will need
-to be recompiled and will often allocate a megabyte or more of system
+to be re-compiled and will often allocate a megabyte or more of system
 memory, this can be a killer.  Compiling into C B<isn't going to help
-you> because the process startup overhead is where the bottleneck is.
+you> because the process start-up overhead is where the bottleneck is.
 
 There are at least two popular ways to avoid this overhead.  One
 solution involves running the Apache HTTP server (available from
 http://www.apache.org/) with either of the mod_perl or mod_fastcgi
 plugin modules.  With mod_perl and the Apache::* modules (from CPAN),
-httpd will run with an embedded Perl interpreter which precompiles
+httpd will run with an embedded Perl interpreter which pre-compiles
 your script and then executes it within the same address space without
 forking.  The Apache extension also gives Perl access to the internal
 server API, so modules written in Perl can do just about anything a
@@ -287,7 +287,7 @@ instead of fixing them, is little security indeed.
 You can try using encryption via source filters (Filter::* from CPAN).
 But crackers might be able to decrypt it.  You can try using the
 byte code compiler and interpreter described below, but crackers might
-be able to decompile it.  You can try using the native-code compiler
+be able to de-compile it.  You can try using the native-code compiler
 described below, but crackers might be able to disassemble it.  These
 pose varying degrees of difficulty to people wanting to get at your
 code, but none can definitively conceal it (this is true of every
@@ -306,7 +306,7 @@ you want to be sure your licence's wording will stand up in court.
 Malcolm Beattie has written a multifunction backend compiler,
 available from CPAN, that can do both these things.  It is as of
 Feb-1997 in late alpha release, which means it's fun to play with if
-you're a programmer but not really for people looking for turnkey
+you're a programmer but not really for people looking for turn-key
 solutions.
 
 I<Please> understand that merely compiling into C does not in and of
@@ -334,14 +334,14 @@ you link your main perl binary with this, it will make it miniscule.
 For example, on one author's system, /usr/bin/perl is only 11k in
 size!
 
-=head2 How can I get '#!perl' to work on [MS-DOS,Windows NT,...]?
+=head2 How can I get '#!perl' to work on [MS-DOS,NT,...]?
 
 For OS/2 just use
 
     extproc perl -S -your_switches
 
 as the first line in C<*.cmd> file (C<-S> due to a bug in cmd.exe's
-`extproc' handling).  For MS-DOS one should first invent a corresponding
+`extproc' handling).  For DOS one should first invent a corresponding
 batch file, and codify it in C<ALTERNATIVE_SHEBANG> (see the
 F<INSTALL> file in the source distribution for more information).
 
@@ -351,7 +351,7 @@ interpreter.  If you install another port, or (eventually) build your
 own Win95/NT Perl using WinGCC, then you'll have to modify the
 Registry yourself.
 
-Macintosh perl scripts will have the appropriate Creator and
+Macintosh perl scripts will have the the appropriate Creator and
 Type, so that double-clicking them will invoke the perl application.
 
 I<IMPORTANT!>: Whatever you do, PLEASE don't get frustrated, and just
@@ -385,7 +385,7 @@ Yes.  Read L<perlrun> for more information.  Some examples follow.
 
 Ok, the last one was actually an obfuscated perl entry. :-)
 
-=head2 Why don't perl one-liners work on my MS-DOS/Macintosh/VMS system?
+=head2 Why don't perl one-liners work on my DOS/Mac/VMS system?
 
 The problem is usually that the command interpreters on those systems
 have rather different ideas about quoting than the Unix shells under
@@ -398,10 +398,10 @@ For example:
     # Unix
     perl -e 'print "Hello world\n"'
 
-    # MS-DOS, etc.
+    # DOS, etc.
     perl -e "print \"Hello world\n\""
 
-    # Macintosh
+    # Mac
     print "Hello world\n"
      (then Run "Myscript" or Shift-Command-R)
 
@@ -409,15 +409,15 @@ For example:
     perl -e "print ""Hello world\n"""
 
 The problem is that none of this is reliable: it depends on the command
-interpreter.  Under Unix, the first two often work. Under MS-DOS, it's
+interpreter.  Under Unix, the first two often work. Under DOS, it's
 entirely possible neither works.  If 4DOS was the command shell, I'd
 probably have better luck like this:
 
   perl -e "print <Ctrl-x>"Hello world\n<Ctrl-x>""
 
-Under the Macintosh, it depends which environment you are using.  The MacPerl
+Under the Mac, it depends which environment you are using.  The MacPerl
 shell, or MPW, is much like Unix shells in its support for several
-quoting variants, except that it makes free use of the Macintosh's non-ASCII
+quoting variants, except that it makes free use of the Mac's non-ASCII
 characters as control characters.
 
 I'm afraid that there is no general solution to all of this.  It is a
@@ -470,7 +470,7 @@ my C program, what am I doing wrong?
 
 Download the ExtUtils::Embed kit from CPAN and run `make test'.  If
 the tests pass, read the pods again and again and again.  If they
-fail, see L<perlbug> and send a bug report with the output of
+fail, see L<perlbug> and send a bugreport with the output of
 C<make test TEST_VERBOSE=1> along with C<perl -V>.
 
 =head2 When I tried to run my script, I got this message. What does it
@@ -501,3 +501,4 @@ information, see L<ExtUtils::MakeMaker>.
 
 Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
 All rights reserved.  See L<perlfaq> for distribution information.
+
index d3a7e8c..7c57d58 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq4 - Data Manipulation ($Revision: 1.17 $, $Date: 1997/03/25 18:16:24 $)
+perlfaq4 - Data Manipulation ($Revision: 1.18 $, $Date: 1997/04/23 18:04:37 $)
 
 =head1 DESCRIPTION
 
@@ -10,6 +10,34 @@ data issues.
 
 =head1 Data: Numbers
 
+=head2 Why am I getting long decimals (eg, 19.9499999999999) instead of the numbers I should be getting (eg, 19.95)?
+
+Internally, your computer represents floating-point numbers in binary.
+Floating-point numbers read in from a file, or appearing as literals
+in your program, are converted from their decimal floating-point
+representation (eg, 19.95) to the internal binary representation.
+
+However, 19.95 can't be precisely represented as a binary
+floating-point number, just like 1/3 can't be exactly represented as a
+decimal floating-point number.  The computer's binary representation
+of 19.95, therefore, isn't exactly 19.95.
+
+When a floating-point number gets printed, the binary floating-point
+representation is converted back to decimal.  These decimal numbers
+are displayed in either the format you specify with printf(), or the
+current output format for numbers (see L<perlvar/"$#"> if you use
+print.  C<$#> has a different default value in Perl5 than it did in
+Perl4.  Changing C<$#> yourself is deprecated.
+
+This affects B<all> computer languages that represent decimal
+floating-point numbers in binary, not just Perl.  Perl provides
+arbitrary-precision decimal numbers with the Math::BigFloat module
+(part of the standard Perl distribution), but mathematical operations
+are consequently slower.
+
+To get rid of the superfluous digits, just use a format (eg,
+C<printf("%.2f", 19.95)>) to get the required precision.
+
 =head2 Why isn't my octal data interpreted correctly?
 
 Perl only understands octal and hex numbers as such when they occur
@@ -36,10 +64,12 @@ The POSIX module (part of the standard perl distribution) implements
 ceil(), floor(), and a number of other mathematical and trigonometric
 functions.
 
-The Math::Complex module (part of the standard perl distribution)
-defines a number of mathematical functions that can also work on real
-numbers.  It's not as efficient as the POSIX library, but the POSIX
-library can't work with complex numbers.
+In 5.000 to 5.003 Perls, trigonometry was done in the Math::Complex
+module.  With 5.004, the Math::Trig module (part of the standard perl
+distribution) implements the trigonometric functions. Internally it
+uses the Math::Complex module and some functions can break out from
+the real axis into the complex plane, for example the inverse sine of
+2.
 
 Rounding in financial applications can have serious implications, and
 the rounding method used should be specified precisely.  In these
@@ -199,6 +229,9 @@ arbitrary expressions:
 
     print "That yields ${\($n + 5)} widgets\n";
 
+See also "How can I expand variables in text strings?" in this section
+of the FAQ.
+
 =head2 How do I find matching/nesting anything?
 
 This isn't something that can be tackled in one regular expression, no
@@ -234,6 +267,9 @@ Use Text::Wrap (part of the standard perl distribution):
     use Text::Wrap;
     print wrap("\t", '  ', @paragraphs);
 
+The paragraphs you give to Text::Wrap may not contain embedded
+newlines.  Text::Wrap doesn't justify the lines (flush-right).
+
 =head2 How can I access/change the first N letters of a string?
 
 There are many ways.  If you just want to grab a copy, use
@@ -271,7 +307,7 @@ C<tr///> function like so:
 
     $string = "ThisXlineXhasXsomeXx'sXinXit":
     $count = ($string =~ tr/X//);
-    print "There are $count X characters in the string";
+    print "There are $count X charcters in the string";
 
 This is fine if you are just looking for a single character.  However,
 if you are trying to count multiple character substrings within a
@@ -289,6 +325,18 @@ To make the first letter of each word upper case:
 
         $line =~ s/\b(\w)/\U$1/g;
 
+This has the strange effect of turning "C<don't do it>" into "C<Don'T
+Do It>".  Sometimes you might want this, instead (Suggested by Brian
+Foy E<lt>comdog@computerdog.comE<gt>):
+
+    $string =~ s/ (
+                 (^\w)    #at the beginning of the line
+                   |      # or
+                 (\s\w)   #preceded by whitespace
+                   )
+                /\U$1/xg;
+    $string =~ /([\w']+)/\u\L$1/g;
+
 To make the whole line upper case:
 
         $line = uc($line);
@@ -321,6 +369,11 @@ suggests (assuming your string is contained in $text):
      }gx;
      push(@new, undef) if substr($text,-1,1) eq ',';
 
+If you want to represent quotation marks inside a
+quotation-mark-delimited field, escape them with backslashes (eg,
+C<"like \"this\"").  Unescaping them is a task addressed earlier in
+this section.
+
 Alternatively, the Text::ParseWords module (part of the standard perl
 distribution) lets you say:
 
@@ -368,6 +421,9 @@ substitution:
 Which is bizarre enough that you'll probably actually need an EEG
 afterwards. :-)
 
+See also "How do I expand function calls in a string?" in this section
+of the FAQ.
+
 =head2 What's wrong with always quoting "$vars"?
 
 The problem is that those double-quotes force stringification,
@@ -668,7 +724,7 @@ that's come to be known as the Schwartzian Transform:
 
     @sorted = map  { $_->[0] }
              sort { $a->[1] cmp $b->[1] }
-             map  { [ $_, uc((/\d+\s*(\S+) )[0] ] } @data;
+             map  { [ $_, uc((/\d+\s*(\S+)/ )[0] ] } @data;
 
 If you need to sort on several fields, the following paradigm is useful.
 
@@ -900,7 +956,7 @@ they end up doing is not what they do with ordinary hashes.
 Using C<keys %hash> in a scalar context returns the number of keys in
 the hash I<and> resets the iterator associated with the hash.  You may
 need to do this if you use C<last> to exit a loop early so that when you
-reenter it, the hash iterator has been reset.
+re-enter it, the hash iterator has been reset.
 
 =head2 How can I get the unique keys from two hashes?
 
@@ -938,6 +994,14 @@ it on top of either DB_File or GDBM_File.
 
 Use the Tie::IxHash from CPAN.
 
+    use Tie::IxHash;
+    tie(%myhash, Tie::IxHash);
+    for ($i=0; $i<20; $i++) {
+        $myhash{$i} = 2*$i;
+    }
+    @keys = keys %myhash;
+    # @keys = (0,1,2,3,...)
+
 =head2 Why does passing a subroutine an undefined element in a hash create it?
 
 If you say something like:
@@ -1035,3 +1099,4 @@ Get the Business::CreditCard module from CPAN.
 
 Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
 All rights reserved.  See L<perlfaq> for distribution information.
+
index 1c694f0..898864b 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq5 - Files and Formats ($Revision: 1.20 $, $Date: 1997/03/19 17:24:51 $)
+perlfaq5 - Files and Formats ($Revision: 1.21 $, $Date: 1997/04/23 18:05:19 $)
 
 =head1 DESCRIPTION
 
@@ -106,7 +106,7 @@ the changes you want, then copy that over the original.
     rename($new, $old)         or die "can't rename $new to $old: $!";
 
 Perl can do this sort of thing for you automatically with the C<-i>
-command line switch or the closely-related C<$^I> variable (see
+command-line switch or the closely-related C<$^I> variable (see
 L<perlrun> for more details).  Note that
 C<-i> may require a suffix on some non-Unix systems; see the
 platform-specific documentation that came with your port.
@@ -231,6 +231,36 @@ Internally, Perl believes filehandles to be of class IO::Handle.  You
 may use that module directly if you'd like (see L<IO::Handle>), or
 one of its more specific derived classes.
 
+Once you have IO::File or FileHandle objects, you can pass them
+between subroutines or store them in hashes as you would any other
+scalar values:
+
+    use FileHandle;
+
+    # Storing filehandles in a hash and array
+    foreach $filename (@names) {
+        my $fh = new FileHandle($filename)             or die;
+        $file{$filename} = $fh;
+        push(@files, $fh);
+    }
+
+    # Using the filehandles in the array
+    foreach $file (@files) {
+       print $file "Testing\n";
+    }
+
+    # You have to do the { } ugliness when you're specifying the
+    # filehandle by anything other than a simple scalar variable.
+    print { $files[2] } "Testing\n";
+
+    # Passing filehandles to subroutines
+    sub debug {
+       my $filehandle = shift;
+       printf $filehandle "DEBUG: ", @_;
+    }
+
+    debug($fh, "Testing\n");
+
 =head2 How can I set up a footer format to be used with write()?
 
 There's no builtin way to do this, but L<perlform> has a couple of
@@ -262,6 +292,18 @@ You can't just:
 because you have to put the comma in and then recalculate your
 position.
 
+Alternatively, this commifies all numbers in a line regardless of
+whether they have decimal portions, are preceded by + or -, or
+whatever:
+
+    # from Andrew Johnson <ajohnson@gpu.srv.ualberta.ca>
+    sub commify {
+       my $input = shift;
+        $input = reverse $input;
+        $input =~ s<(\d\d\d)(?=\d)(?!\d*\.)><$1,>g;
+        return reverse $input;
+    }
+
 =head2 How can I translate tildes (~) in a filename?
 
 Use the E<lt>E<gt> (glob()) operator, documented in L<perlfunc>.  This
@@ -406,13 +448,13 @@ atomic test-and-set instruction.   In theory, this "ought" to work:
 
 except that lamentably, file creation (and deletion) is not atomic
 over NFS, so this won't work (at least, not every time) over the net.
-Various schemes involving link() have been suggested, but these tend
-to involve busy-wait, which is also subdesirable.
+Various schemes involving involving link() have been suggested, but
+these tend to involve busy-wait, which is also subdesirable.
 
 =head2 I still don't get locking.  I just want to increment the number
 in the file.  How can I do this?
 
-Didn't anyone ever tell you web page hit counters were useless?
+Didn't anyone ever tell you web-page hit counters were useless?
 
 Anyway, this is what to do:
 
@@ -426,7 +468,7 @@ Anyway, this is what to do:
     # DO NOT UNLOCK THIS UNTIL YOU CLOSE
     close FH                                    or die "can't close numfile: $!";
 
-Here's a much better web page hit counter:
+Here's a much better web-page hit counter:
 
     $hits = int( (time() - 850_000_000) / rand(1_000) );
 
@@ -455,14 +497,14 @@ like this:
 Locking and error checking are left as an exercise for the reader.
 Don't forget them, or you'll be quite sorry.
 
-Don't forget to set binmode() under MS-DOS-like platforms when operating
+Don't forget to set binmode() under DOS-like platforms when operating
 on files that have anything other than straight text in them.  See the
 docs on open() and on binmode() for more details.
 
 =head2 How do I get a file's timestamp in perl?
 
 If you want to retrieve the time at which the file was last read,
-written, or had its metadata (owner, etc) changed, you use the B<-M>,
+written, or had its meta-data (owner, etc) changed, you use the B<-M>,
 B<-A>, or B<-C> filetest operations as documented in L<perlfunc>.  These
 retrieve the age of the file (measured against the start-time of your
 program) in days as a floating point number.  To retrieve the "raw"
@@ -602,7 +644,7 @@ The Term::ReadKey module from CPAN may be easier to use:
     printf "\nYou said %s, char number %03d\n",
         $key, ord $key;
 
-For MS-DOS systems, Dan Carson <dbc@tc.fluke.COM> reports the following:
+For DOS systems, Dan Carson <dbc@tc.fluke.COM> reports the following:
 
 To put the PC in "raw" mode, use ioctl with some magic numbers gleaned
 from msdos.c (Perl source file) and Ralf Brown's interrupt list (comes
@@ -737,17 +779,17 @@ to, you may be able to do this:
     $rc = syscall(&SYS_close, $fd + 0);  # must force numeric
     die "can't sysclose $fd: $!" unless $rc == -1;
 
-=head2 Why can't I use "C:\temp\foo" in MS-DOS paths?  What doesn't `C:\temp\foo.exe` work?
+=head2 Why can't I use "C:\temp\foo" in DOS paths?  What doesn't `C:\temp\foo.exe` work?
 
 Whoops!  You just put a tab and a formfeed into that filename!
 Remember that within double quoted strings ("like\this"), the
 backslash is an escape character.  The full list of these is in
 L<perlop/Quote and Quote-like Operators>.  Unsurprisingly, you don't
 have a file called "c:(tab)emp(formfeed)oo" or
-"c:(tab)emp(formfeed)oo.exe" on your MS-DOS filesystem.
+"c:(tab)emp(formfeed)oo.exe" on your DOS filesystem.
 
 Either single-quote your strings, or (preferably) use forward slashes.
-Since all MS-DOS and Windows versions since something like MS-DOS 2.0 or so
+Since all DOS and Windows versions since something like MS-DOS 2.0 or so
 have treated C</> and C<\> the same in a path, you might as well use the
 one that doesn't clash with Perl -- or the POSIX shell, ANSI C and C++,
 awk, Tcl, Java, or Python, just to mention a few.
@@ -755,7 +797,7 @@ awk, Tcl, Java, or Python, just to mention a few.
 =head2 Why doesn't glob("*.*") get all the files?
 
 Because even on non-Unix ports, Perl's glob function follows standard
-Unix globbing semantics.  You'll need C<glob("*")> to get all (nonhidden)
+Unix globbing semantics.  You'll need C<glob("*")> to get all (non-hidden)
 files.
 
 =head2 Why does Perl let me delete read-only files?  Why does C<-i> clobber protected files?  Isn't this a bug in Perl?
@@ -786,3 +828,4 @@ file in.
 
 Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
 All rights reserved.  See L<perlfaq> for distribution information.
+
index 1cec15c..1af7948 100644 (file)
@@ -240,7 +240,7 @@ Without the \Q, the regexp would also spuriously match "di".
 
 =head2 What is C</o> really for?
 
-Using a variable in a regular expression match forces a reevaluation
+Using a variable in a regular expression match forces a re-evaluation
 (and perhaps recompilation) each time through.  The C</o> modifier
 locks in the regexp the first time it's used.  This always happens in a
 constant regular expression, and in fact, the pattern was compiled
@@ -520,7 +520,7 @@ But then you lose the vertical alignment of the regular expressions.
 
 While it's true that Perl's regular expressions resemble the DFAs
 (deterministic finite automata) of the egrep(1) program, they are in
-fact implemented as NFAs (nondeterministic finite automata) to allow
+fact implemented as NFAs (non-deterministic finite automata) to allow
 backtracking and backreferencing.  And they aren't POSIX-style either,
 because those guarantee worst-case behavior for all cases.  (It seems
 that some people prefer guarantees of consistency, even when what's
@@ -590,7 +590,7 @@ katakana (in Shift-JIS or EUC encoding) is available from CPAN as
 
 =for Tom make it so
 
-There are many double (and multi) byte encodings commonly used these
+There are many double- (and multi-) byte encodings commonly used these
 days.  Some versions of these have 1-, 2-, 3-, and 4-byte characters,
 all mixed.
 
@@ -598,3 +598,4 @@ all mixed.
 
 Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
 All rights reserved.  See L<perlfaq> for distribution information.
+
index a1d60f8..908fc14 100644 (file)
@@ -298,6 +298,26 @@ E<lt>STDINE<gt>'>, there would have been no way for the hypothetical
 timeout() function to access the lexical variable $line back in its
 caller's scope.
 
+=head2 What is variable suicide and how can I prevent it?
+
+Variable suicide is when you (temporarily or permanently) lose the
+value of a variable.  It is caused by scoping through my() and local()
+interacting with either closures or aliased foreach() interator
+variables and subroutine arguments.  It used to be easy to
+inadvertently lose a variable's value this way, but now it's much
+harder.  Take this code:
+
+    my $f = "foo";
+    sub T {
+      while ($i++ < 3) { my $f = $f; $f .= "bar"; print $f, "\n" }
+    }
+    T;
+    print "Finally $f\n";
+
+The $f that has "bar" added to it three times should be a new C<$f>
+(C<my $f> should create a new local variable each time through the
+loop).  It isn't, however.  This is a bug, and will be fixed.
+
 =head2 How can I pass/return a {Function, FileHandle, Array, Hash, Method, Regexp}?
 
 With the exception of regexps, you need to pass references to these
@@ -339,9 +359,9 @@ IO::File modules, both part of the standard Perl distribution.
 
 To pass regexps around, you'll need to either use one of the highly
 experimental regular expression modules from CPAN (Nick Ing-Simmons's
-Regexp or Ilya Zakharevich's Devel::Regexp), pass around strings and
-use an exception-trapping eval, or else be very, very clever.  Here's
-an example of how to pass in a string to be regexp compared:
+Regexp or Ilya Zakharevich's Devel::Regexp), pass around strings
+and use an exception-trapping eval, or else be be very, very clever.
+Here's an example of how to pass in a string to be regexp compared:
 
     sub compare($$) {
         my ($val1, $regexp) = @_;
@@ -539,7 +559,7 @@ Why do you want to do that? :-)
 If you want to override a predefined function, such as open(),
 then you'll have to import the new definition from a different
 module.  See L<perlsub/"Overriding Builtin Functions">.  There's
-also an example in L<perltoot/"Class::Struct">.
+also an example in L<perltoot/"Class::Template">.
 
 If you want to overload a Perl operator, such as C<+> or C<**>,
 then you'll want to use the C<use overload> pragma, documented
@@ -576,7 +596,7 @@ how best to do this, so he left it out, even though it's been on the
 wish list since perl1.
 
 Here's a simple example of a switch based on pattern matching.  We'll
-do a multiway conditional based on the type of reference stored in
+do a multi-way conditional based on the type of reference stored in
 $whatchamacallit:
 
     SWITCH:
@@ -669,6 +689,26 @@ not necessarily the same as the one in which you were compiled):
        warn "called me from a $class object";
     }
 
+=head2 How can I comment out a large block of perl code?
+
+Use embedded POD to discard it:
+
+    # program is here
+
+    =for nobody
+    This paragraph is commented out
+
+    # program continues
+
+    =begin comment text
+
+    all of this stuff
+
+    here will be ignored
+    by everyone
+
+    =end comment text
+
 =head1 AUTHOR AND COPYRIGHT
 
 Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
index 831b1b4..f559d6a 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq8 - System Interaction ($Revision: 1.17 $, $Date: 1997/03/25 18:17:12 $)
+perlfaq8 - System Interaction ($Revision: 1.20 $, $Date: 1997/04/23 18:11:50 $)
 
 =head1 DESCRIPTION
 
@@ -10,7 +10,7 @@ control over the user-interface (keyboard, screen and pointing
 devices), and most anything else not related to data manipulation.
 
 Read the FAQs and documentation specific to the port of perl to your
-operating system (eg, L<perlvms>, F<REAMDE.os2>, ...).  These should
+operating system (eg, L<perlvms>, L<perlplan9>, ...).  These should
 contain more detailed information on the vagaries of your perl.
 
 =head2 How do I find out which operating system I'm running under?
@@ -104,7 +104,7 @@ give the numeric values you want directly, using octal ("\015"), hex
 
 Even though with normal text files, a "\n" will do the trick, there is
 still no unified scheme for terminating a line that is portable
-between Unix, MS-DOS/Windows, and Macintosh, except to terminate I<ALL> line
+between Unix, DOS/Win, and Macintosh, except to terminate I<ALL> line
 ends with "\015\012", and strip what you don't need from the output.
 This applies especially to socket I/O and autoflushing, discussed
 next.
@@ -208,7 +208,7 @@ You don't actually "trap" a control character.  Instead, that
 character generates a signal, which you then trap.  Signals are
 documented in L<perlipc/"Signals"> and chapter 6 of the Camel.
 
-Be warned that very few C libraries are reentrant.  Therefore, if you
+Be warned that very few C libraries are re-entrant.  Therefore, if you
 attempt to print() in a handler that got invoked during another stdio
 operation your internal structures will likely be in an
 inconsistent state, and your program will dump core.  You can
@@ -230,7 +230,7 @@ For example:
 However, because syscalls restart by default, you'll find that if
 you're in a "slow" call, such as E<lt>FHE<gt>, read(), connect(), or
 wait(), that the only way to terminate them is by "longjumping" out;
-that is, by raising an exception.  See the timeout handler for a
+that is, by raising an exception.  See the time-out handler for a
 blocking flock() in L<perlipc/"Signals"> or chapter 6 of the Camel.
 
 =head2 How do I modify the shadow password file on a Unix system?
@@ -311,7 +311,7 @@ END blocks you should also use
 
 Perl's exception-handling mechanism is its eval() operator.  You can
 use eval() as setjmp and die() as longjmp.  For details of this, see
-the section on signals, especially the timeout handler for a blocking
+the section on signals, especially the time-out handler for a blocking
 flock() in L<perlipc/"Signals"> and chapter 6 of the Camel.
 
 If exception handling is all you're interested in, try the
@@ -352,7 +352,7 @@ Simple files like F<errno.h>, F<syscall.h>, and F<socket.h> were fine,
 but the hard ones like F<ioctl.h> nearly always need to hand-edited.
 Here's how to install the *.ph files:
 
-    1.  become superuser
+    1.  become super-user
     2.  cd /usr/include
     3.  h2ph *.h */*.h
 
@@ -381,14 +381,14 @@ documentation, though (see L<IPC::Open2>).
 
 =head2 Why can't I get the output of a command with system()?
 
-You're confusing the purpose of system() and backticks ('').  system()
-runs a command and returns exit status information (as a 16 bit value
--- the low 8 bits are the signal the process died from, if any, and
-the high 8 bits are the actual exit value).  Backticks ('') run a
+You're confusing the purpose of system() and backticks (``).  system()
+runs a command and returns exit status information (as a 16 bit value:
+the low 8 bits are the signal the process died from, if any, and
+the high 8 bits are the actual exit value).  Backticks (``) run a
 command and return what it sent to STDOUT.
 
-    $status = system("mail-users");
-    $output = `ls`;
+    $exit_status   = system("mail-users");
+    $output_string = `ls`;
 
 =head2 How can I capture STDERR from an external command?
 
@@ -552,14 +552,32 @@ Things that are awkward to do in the shell are easy to do in Perl, and
 this very awkwardness is what would make a shell->perl converter
 nigh-on impossible to write.  By rewriting it, you'll think about what
 you're really trying to do, and hopefully will escape the shell's
-pipeline data stream paradigm, which while convenient for some matters,
+pipeline datastream paradigm, which while convenient for some matters,
 causes many inefficiencies.
 
 =head2 Can I use perl to run a telnet or ftp session?
 
-Try the Net::FTP and TCP::Client modules (available from CPAN).
-http://www.perl.com/CPAN/scripts/netstuff/telnet.emul.shar will also
-help for emulating the telnet protocol.
+Try the Net::FTP, TCP::Client, and Net::Telnet modules (available from
+CPAN).  http://www.perl.com/CPAN/scripts/netstuff/telnet.emul.shar
+will also help for emulating the telnet protocol, but Net::Telnet is
+quite probably easier to use..
+
+If all you want to do is pretend to be telnet but don't need
+the initial telnet handshaking, then the standard dual-process
+approach will suffice:
+
+    use IO::Socket;            # new in 5.004
+    $handle = IO::Socket::INET->new('www.perl.com:80')
+           || die "can't connect to port 80 on www.perl.com: $!";
+    $handle->autoflush(1);
+    if (fork()) {              # XXX: undef means failure
+       select($handle);
+       print while <STDIN>;    # everything from stdin to socket
+    } else {
+       print while <$handle>;  # everything from socket to stdout
+    }
+    close $handle;
+    exit;
 
 =head2 How can I write expect in Perl?
 
@@ -619,7 +637,7 @@ module for other solutions.
 
 =item *
 
-Open /dev/tty and use the TIOCNOTTY ioctl on it.  See L<tty(4)>
+Open /dev/tty and use the the TIOCNOTTY ioctl on it.  See L<tty(4)>
 for details.
 
 =item *
@@ -643,20 +661,6 @@ Background yourself like this:
 
 See the F<eg/nih> script (part of the perl source distribution).
 
-=head2 How do I keep my own module/library directory?
-
-When you build modules, use the PREFIX option when generating
-Makefiles:
-
-    perl Makefile.PL PREFIX=/u/mydir/perl
-
-then either set the PERL5LIB environment variable before you run
-scripts that use the modules/libraries (see L<perlrun>) or say
-
-    use lib '/u/mydir/perl';
-
-See Perl's L<lib> for more information.
-
 =head2 How do I find out if I'm running interactively or not?
 
 Good question.  Sometimes C<-t STDIN> and C<-t STDOUT> can give clues,
@@ -754,7 +758,42 @@ If your version of perl is compiled without dynamic loading, then you
 just need to replace step 3 (B<make>) with B<make perl> and you will
 get a new F<perl> binary with your extension linked in.
 
-See L<ExtUtils::MakeMaker> for more details on building extensions.
+See L<ExtUtils::MakeMaker> for more details on building extensions,
+the question "How do I keep my own module/library directory?"
+
+=head2 How do I keep my own module/library directory?
+
+When you build modules, use the PREFIX option when generating
+Makefiles:
+
+    perl Makefile.PL PREFIX=/u/mydir/perl
+
+then either set the PERL5LIB environment variable before you run
+scripts that use the modules/libraries (see L<perlrun>) or say
+
+    use lib '/u/mydir/perl';
+
+See Perl's L<lib> for more information.
+
+=head2 How do I add the directory my program lives in to the module/library search path?
+
+    use FindBin;
+    use lib "$FindBin:Bin";
+    use your_own_modules;
+
+=head2 How do I add a directory to my include path at runtime?
+
+Here are the suggested ways of modifying your include path:
+
+    the PERLLIB environment variable
+    the PERL5LIB environment variable
+    the perl -Idir commpand line flag
+    the use lib pragma, as in
+        use lib "$ENV{HOME}/myown_perllib";
+
+The latter is particularly useful because it knows about machine
+dependent architectures.  The lib.pm pragmatic module was first
+included with the 5.002 release of Perl.
 
 =head1 AUTHOR AND COPYRIGHT
 
index 9e6355f..f4f4759 100644 (file)
@@ -1,6 +1,6 @@
 =head1 NAME
 
-perlfaq9 - Networking ($Revision: 1.15 $, $Date: 1997/03/25 18:17:20 $)
+perlfaq9 - Networking ($Revision: 1.16 $, $Date: 1997/04/23 18:12:06 $)
 
 =head1 DESCRIPTION
 
@@ -62,9 +62,10 @@ A quick but imperfect approach is
     }gsix;
 
 This version does not adjust relative URLs, understand alternate
-bases, deal with HTML comments, or accept URLs themselves as
-arguments.  It also runs about 100x faster than a more "complete"
-solution using the LWP suite of modules, such as the
+bases, deal with HTML comments, deal with HREF and NAME attributes in
+the same tag, or accept URLs themselves as arguments.  It also runs
+about 100x faster than a more "complete" solution using the LWP suite
+of modules, such as the
 http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/xurl.gz
 program.
 
@@ -83,14 +84,30 @@ others, including some that it cleverly synthesizes on its own.
 
 =head2 How do I fetch an HTML file?
 
-Use the LWP::Simple module available from CPAN, part of the excellent
-libwww-perl (LWP) package.  On the other hand, and if you have the
-lynx text-based HTML browser installed on your system, this isn't too
-bad:
+One approach, if you have the lynx text-based HTML browser installed
+on your system, is this:
 
     $html_code = `lynx -source $url`;
     $text_data = `lynx -dump $url`;
 
+The libwww-perl (LWP) modules from CPAN provide a more powerful way to
+do this.  They work through proxies, and don't require lynx:
+
+    # print HTML from a URL
+    use LWP::Simple;
+    getprint "http://www.sn.no/libwww-perl/";
+
+    # print ASCII from HTML from a URL
+    use LWP::Simple;
+    use HTML::Parse;
+    use HTML::FormatText;
+    my ($html, $ascii);
+    $html = get("http://www.perl.com/");
+    defined $html
+        or die "Can't fetch HTML from http://www.perl.com/";
+    $ascii = HTML::FormatText->new->format(parse_html($html));
+    print $ascii;
+
 =head2 how do I decode or create those %-encodings on the web?
 
 Here's an example of decoding:
@@ -127,7 +144,7 @@ server, or perhaps check some of the other FAQs referenced above.
 
 The HTTPD::UserAdmin and HTTPD::GroupAdmin modules provide a
 consistent OO interface to these files, regardless of how they're
-stored.  Databases may be text, dbm, Berkeley DB or any database with a
+stored.  Databases may be text, dbm, Berkley DB or any database with a
 DBI compatible driver.  HTTPD::UserAdmin supports files used by the
 `Basic' and `Digest' authentication schemes.  Here's an example:
 
@@ -136,6 +153,19 @@ DBI compatible driver.  HTTPD::UserAdmin supports files used by the
          ->new(DB => "/foo/.htpasswd")
          ->add($username => $password);
 
+=head2 How do I make sure users can't enter values into a form that cause my CGI script to do bad things?
+
+Read the CGI security FAQ, at
+http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html, and the
+Perl/CGI FAQ at
+http://www.perl.com/CPAN/doc/FAQs/cgi/perl-cgi-faq.html.
+
+In brief: use tainting (see L<perlsec>), which makes sure that data
+from outside your script (eg, CGI parameters) are never used in
+C<eval> or C<system> calls.  In addition to tainting, never use the
+single-argument form of system() or exec().  Instead, supply the
+command and arguments as a list, which prevents shell globbing.
+
 =head2 How do I parse an email header?
 
 For a quick-and-dirty solution, try this solution derived
@@ -185,6 +215,12 @@ comments), looks for addresses you may not wish to accept email to
 (say, Bill Clinton or your postmaster), and then makes sure that the
 hostname given can be looked up in DNS.  It's not fast, but it works.
 
+Here's an alternative strategy used by many CGI script authors: Check
+the email address with a simple regexp (such as the one above).  If
+the regexp matched the address, accept the address.  If the regexp
+didn't match the address, request confirmation from the user that the
+email address they entered was correct.
+
 =head2 How do I decode a MIME/BASE64 string?
 
 The MIME-tools package (available from CPAN) handles this and a lot
@@ -224,8 +260,8 @@ Again, the best way is often just to ask the user.
 =head2 How do I send/read mail?
 
 Sending mail: the Mail::Mailer module from CPAN (part of the MailTools
-package) is Unix-centric, while Mail::Internet uses Net::SMTP which is
-not Unix-centric.  Reading mail: use the Mail::Folder module from CPAN
+package) is UNIX-centric, while Mail::Internet uses Net::SMTP which is
+not UNIX-centric.  Reading mail: use the Mail::Folder module from CPAN
 (part of the MailFolder package) or the Mail::Internet module from
 CPAN (also part of the MailTools package).
 
@@ -292,3 +328,4 @@ CPAN).  No ONC::RPC module is known.
 
 Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
 All rights reserved.  See L<perlfaq> for distribution information.
+
index 7b4e4c7..de71460 100644 (file)
@@ -34,19 +34,21 @@ An SV can be created and loaded with one command.  There are four types of
 values that can be loaded: an integer value (IV), a double (NV), a string,
 (PV), and another scalar (SV).
 
-The four routines are:
+The five routines are:
 
     SV*  newSViv(IV);
     SV*  newSVnv(double);
     SV*  newSVpv(char*, int);
+    SV*  newSVpvf(const char*, ...);
     SV*  newSVsv(SV*);
 
-To change the value of an *already-existing* SV, there are five routines:
+To change the value of an *already-existing* SV, there are six routines:
 
     void  sv_setiv(SV*, IV);
     void  sv_setnv(SV*, double);
-    void  sv_setpvn(SV*, char*, int)
     void  sv_setpv(SV*, char*);
+    void  sv_setpvn(SV*, char*, int)
+    void  sv_setpvf(SV*, const char*, ...);
     void  sv_setsv(SV*, SV*);
 
 Notice that you can choose to specify the length of the string to be
@@ -54,7 +56,8 @@ assigned by using C<sv_setpvn> or C<newSVpv>, or you may allow Perl to
 calculate the length by using C<sv_setpv> or by specifying 0 as the second
 argument to C<newSVpv>.  Be warned, though, that Perl will determine the
 string's length by using C<strlen>, which depends on the string terminating
-with a NUL character.
+with a NUL character.  The arguments of C<sv_setpvf> are processed like
+C<sprintf>, and the formatted output becomes the value.
 
 All SVs that will contain strings should, but need not, be terminated
 with a NUL character.  If it is not NUL-terminated there is a risk of
@@ -119,13 +122,15 @@ you can use the following functions:
 
     void  sv_catpv(SV*, char*);
     void  sv_catpvn(SV*, char*, int);
+    void  sv_catpvf(SV*, const char*, ...);
     void  sv_catsv(SV*, SV*);
 
 The first function calculates the length of the string to be appended by
 using C<strlen>.  In the second, you specify the length of the string
-yourself.  The third function extends the string stored in the first SV
-with the string stored in the second SV.  It also forces the second SV to
-be interpreted as a string.
+yourself.  The third function processes its arguments like C<sprintf> and
+appends the formatted output.  The fourth function extends the string
+stored in the first SV with the string stored in the second SV.  It also
+forces the second SV to be interpreted as a string.
 
 If you know the name of a scalar variable, you can get a pointer to its SV
 by using the following:
@@ -2236,6 +2241,13 @@ C<len> indicates number of bytes to copy.
 
        void    sv_catpvn _((SV* sv, char* ptr, STRLEN len));
 
+=item sv_catpvf
+
+Processes its arguments like C<sprintf> and appends the formatted output
+to an SV.
+
+       void    sv_catpvf _((SV* sv, const char* pat, ...));
+
 =item sv_catsv
 
 Concatenates the string from SV C<ssv> onto the end of the string in SV
@@ -2615,6 +2627,13 @@ bytes to be copied.
 
        void    sv_setpvn _((SV* sv, char* ptr, STRLEN len));
 
+=item sv_setpvf
+
+Processes its arguments like C<sprintf> and sets an SV to the formatted
+output.
+
+       void    sv_setpvf _((SV* sv, const char* pat, ...));
+
 =item sv_setref_iv
 
 Copies an integer into a new SV, optionally blessing the SV.  The C<rv>
index 847340d..ccc1156 100644 (file)
@@ -611,7 +611,7 @@ use the each() function to iterate over such.  Example:
 This is partially implemented now.
 
 A class implementing a tied filehandle should define the following
-methods: TIEHANDLE, at least one of PRINT, READLINE, GETC, or READ,
+methods: TIEHANDLE, at least one of PRINT, PRINTF, READLINE, GETC, or READ,
 and possibly DESTROY.
 
 It is especially useful when perl is embedded in some other program,
@@ -634,12 +634,26 @@ hold some internal information.
 
 =item PRINT this, LIST
 
-This method will be triggered every time the tied handle is printed to.
+This method will be triggered every time the tied handle is printed to
+with the C<print()> function.
 Beyond its self reference it also expects the list that was passed to
 the print function.
 
     sub PRINT { $r = shift; $$r++; print join($,,map(uc($_),@_)),$\ }
 
+=item PRINTF this, LIST
+
+This method will be triggered every time the tied handle is printed to
+with the C<printf()> function.
+Beyond its self reference it also expects the format and list that was
+passed to the printf function.
+
+    sub PRINTF {
+        shift;
+        my $fmt = shift;
+        print sprintf($fmt, @_)."\n";
+    }
+
 =item READ this LIST
 
 This method will be called when the handle is read from via the C<read>
@@ -832,4 +846,4 @@ source code to MLDBM.
 
 Tom Christiansen
 
-TIEHANDLE by Sven Verdoolaege <F<skimo@dns.ufsia.ac.be>>
+TIEHANDLE by Sven Verdoolaege <F<skimo@dns.ufsia.ac.be>> and Doug MacEachern <F<dougm@osf.org>>
index 388a672..a70ed6e 100644 (file)
@@ -38,8 +38,8 @@ expression enhancements, Innumerable Unbundled Modules, Compilability
 
 =item NOTES
 
-=head2 perlfaq - frequently asked questions about Perl ($Date: 1997/03/25
-18:20:48 $)
+=head2 perlfaq - frequently asked questions about Perl ($Date: 1997/04/23
+18:11:06 $)
 
 =item DESCRIPTION
 
@@ -76,7 +76,8 @@ authors
 
 =item Changes
 
-25/March/97, 18/March/97, 17/March/97 Version, Initial Release: 11/March/97
+23/April/97, 25/March/97, 18/March/97, 17/March/97 Version, Initial
+Release: 11/March/97
 
 =head2 perlfaq1 - General Questions About Perl ($Revision: 1.11 $, $Date:
 1997/03/19 17:23:09 $)
@@ -119,8 +120,8 @@ Scheme, or Tcl?
 
 =item AUTHOR AND COPYRIGHT
 
-=head2 perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.15 $,
-$Date: 1997/03/25 18:15:48 $)
+=head2 perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.16 $,
+$Date: 1997/04/23 18:04:09 $)
 
 =item DESCRIPTION
 
@@ -175,8 +176,8 @@ MacPerl, Perl5-Porters, NTPerl, Perl-Packrats
 
 =item AUTHOR AND COPYRIGHT
 
-=head2 perlfaq3 - Programming Tools ($Revision: 1.20 $, $Date: 1997/03/19
-17:23:43 $)
+=head2 perlfaq3 - Programming Tools ($Revision: 1.21 $, $Date: 1997/04/23
+18:04:23 $)
 
 =item DESCRIPTION
 
@@ -226,11 +227,11 @@ MacPerl, Perl5-Porters, NTPerl, Perl-Packrats
 
 =item How can I compile my Perl program into byte code or C?
 
-=item How can I get '#!perl' to work on [MS-DOS,Windows NT,...]?
+=item How can I get '#!perl' to work on [MS-DOS,NT,...]?
 
 =item Can I write useful perl programs on the command line?
 
-=item Why don't perl one-liners work on my MS-DOS/Macintosh/VMS system?
+=item Why don't perl one-liners work on my DOS/Mac/VMS system?
 
 =item Where can I learn about CGI or Web programming in Perl?
 
@@ -250,8 +251,8 @@ mean?
 
 =item AUTHOR AND COPYRIGHT
 
-=head2 perlfaq4 - Data Manipulation ($Revision: 1.17 $, $Date: 1997/03/25
-18:16:24 $)
+=head2 perlfaq4 - Data Manipulation ($Revision: 1.18 $, $Date: 1997/04/23
+18:04:37 $)
 
 =item DESCRIPTION
 
@@ -259,6 +260,9 @@ mean?
 
 =over
 
+=item Why am I getting long decimals (eg, 19.9499999999999) instead of the
+numbers I should be getting (eg, 19.95)?
+
 =item Why isn't my octal data interpreted correctly?
 
 =item Does perl have a round function? What about ceil() and floor()?
@@ -441,8 +445,8 @@ or array of hashes or arrays?
 
 =item AUTHOR AND COPYRIGHT
 
-=head2 perlfaq5 - Files and Formats ($Revision: 1.20 $, $Date: 1997/03/19
-17:24:51 $)
+=head2 perlfaq5 - Files and Formats ($Revision: 1.21 $, $Date: 1997/04/23
+18:05:19 $)
 
 =item DESCRIPTION
 
@@ -511,7 +515,7 @@ in the file.  How can I do this?
 
 =item How do I close a file descriptor by number?
 
-=item Why can't I use "C:\temp\foo" in MS-DOS paths?  What doesn't
+=item Why can't I use "C:\temp\foo" in DOS paths?  What doesn't
 `C:\temp\foo.exe` work?
 
 =item Why doesn't glob("*.*") get all the files?
@@ -619,6 +623,8 @@ commas?
 
 =item What's a closure?
 
+=item What is variable suicide and how can I prevent it?
+
 =item How can I pass/return a {Function, FileHandle, Array, Hash, Method,
 Regexp}?
 
@@ -649,12 +655,14 @@ is in scope?
 
 =item How can I find out my current package?
 
+=item How can I comment out a large block of perl code?
+
 =back
 
 =item AUTHOR AND COPYRIGHT
 
-=head2 perlfaq8 - System Interaction ($Revision: 1.17 $, $Date: 1997/03/25
-18:17:12 $)
+=head2 perlfaq8 - System Interaction ($Revision: 1.20 $, $Date: 1997/04/23
+18:11:50 $)
 
 =item DESCRIPTION
 
@@ -738,8 +746,6 @@ complete?
 
 =item How do I make my program run with sh and csh?
 
-=item How do I keep my own module/library directory?
-
 =item How do I find out if I'm running interactively or not?
 
 =item How do I timeout a slow event?
@@ -756,11 +762,18 @@ complete?
 
 =item How do I install a CPAN module?
 
+=item How do I keep my own module/library directory?
+
+=item How do I add the directory my program lives in to the module/library
+search path?
+
+=item How do I add a directory to my include path at runtime?
+
 =back
 
 =item AUTHOR AND COPYRIGHT
 
-=head2 perlfaq9 - Networking ($Revision: 1.15 $, $Date: 1997/03/25 18:17:20
+=head2 perlfaq9 - Networking ($Revision: 1.16 $, $Date: 1997/04/23 18:12:06
 $)
 
 =item DESCRIPTION
@@ -789,6 +802,9 @@ file on another machine?
 
 =item How do I edit my .htpasswd and .htgroup files with Perl?
 
+=item How do I make sure users can't enter values into a form that cause my
+CGI script to do bad things?
+
 =item How do I parse an email header?
 
 =item How do I decode a CGI form?
@@ -871,8 +887,8 @@ isa(CLASS), can(METHOD), VERSION( [NEED] )
 
 =item TIEHANDLE now supported
 
-TIEHANDLE classname, LIST, PRINT this, LIST, READ this LIST, READLINE this,
-GETC this, DESTROY this
+TIEHANDLE classname, LIST, PRINT this, LIST, PRINTF this, LIST, READ this
+LIST, READLINE this, GETC this, DESTROY this
 
 =item Malloc enhancements
 
@@ -1774,8 +1790,8 @@ this, NEXTKEY this, lastkey, DESTROY this
 
 =item Tying FileHandles
 
-TIEHANDLE classname, LIST, PRINT this, LIST, READ this LIST, READLINE this,
-GETC this, DESTROY this
+TIEHANDLE classname, LIST, PRINT this, LIST, PRINTF this, LIST, READ this
+LIST, READLINE this, GETC this, DESTROY this
 
 =item The C<untie> Gotcha
 
@@ -2346,21 +2362,22 @@ perl_require_pv, perl_run, POPi, POPl, POPp, POPn, POPs, PUSHMARK, PUSHi,
 PUSHn, PUSHp, PUSHs, PUTBACK, Renew, Renewc, RETVAL, safefree, safemalloc,
 saferealloc, savepv, savepvn, SAVETMPS, SP, SPAGAIN, ST, strEQ, strGE,
 strGT, strLE, strLT, strNE, strnEQ, strnNE, sv_2mortal, sv_bless, sv_catpv,
-sv_catpvn, sv_catsv, sv_cmp, sv_cmp, SvCUR, SvCUR_set, sv_dec, sv_dec,
-SvEND, sv_eq, SvGROW, sv_grow, sv_inc, SvIOK, SvIOK_off, SvIOK_on,
+sv_catpvn, sv_catpvf, sv_catsv, sv_cmp, sv_cmp, SvCUR, SvCUR_set, sv_dec,
+sv_dec, SvEND, sv_eq, SvGROW, sv_grow, sv_inc, SvIOK, SvIOK_off, SvIOK_on,
 SvIOK_only, SvIOK_only, SvIOKp, sv_isa, SvIV, sv_isobject, SvIVX, SvLEN,
 sv_len, sv_len, sv_magic, sv_mortalcopy, SvOK, sv_newmortal, sv_no, SvNIOK,
 SvNIOK_off, SvNIOKp, SvNOK, SvNOK_off, SvNOK_on, SvNOK_only, SvNOK_only,
 SvNOKp, SvNV, SvNVX, SvPOK, SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only,
 SvPOKp, SvPV, SvPVX, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK,
 SvROK_off, SvROK_on, SvRV, sv_setiv, sv_setnv, sv_setpv, sv_setpvn,
-sv_setref_iv, sv_setref_nv, sv_setref_pv, sv_setref_pvn, sv_setsv, SvSTASH,
-SVt_IV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG, SVt_NV, SvTRUE,
-SvTYPE, svtype, SvUPGRADE, sv_upgrade, sv_undef, sv_unref, sv_usepvn,
-sv_yes, THIS, toLOWER, toUPPER, warn, XPUSHi, XPUSHn, XPUSHp, XPUSHs, XS,
-XSRETURN, XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO, XSRETURN_NV,
-XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNV, XST_mNO,
-XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK, Zero
+sv_setpvf, sv_setref_iv, sv_setref_nv, sv_setref_pv, sv_setref_pvn,
+sv_setsv, SvSTASH, SVt_IV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG,
+SVt_NV, SvTRUE, SvTYPE, svtype, SvUPGRADE, sv_upgrade, sv_undef, sv_unref,
+sv_usepvn, sv_yes, THIS, toLOWER, toUPPER, warn, XPUSHi, XPUSHn, XPUSHp,
+XPUSHs, XS, XSRETURN, XSRETURN_EMPTY, XSRETURN_IV, XSRETURN_NO,
+XSRETURN_NV, XSRETURN_PV, XSRETURN_UNDEF, XSRETURN_YES, XST_mIV, XST_mNV,
+XST_mNO, XST_mPV, XST_mUNDEF, XST_mYES, XS_VERSION, XS_VERSION_BOOTCHECK,
+Zero
 
 =item EDITOR
 
diff --git a/pp.c b/pp.c
index 6423e27..68b0991 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -36,9 +36,9 @@ typedef unsigned UBW;
  * in a double without loss; that is, it has no 32-bit type.
  */
 #if BYTEORDER > 0xFFFF && defined(_CRAY) && !defined(_CRAYMPP)
-#  define BWBITS  32
-#  define BWMASK  ((1 << BWBITS) - 1)
-#  define BWSIGN  (1 << (BWBITS - 1))
+#  define BW_BITS  32
+#  define BW_MASK  ((1 << BW_BITS) - 1)
+#  define BW_SIGN  (1 << (BW_BITS - 1))
 #  define BWi(i)  (((i) & BW_SIGN) ? ((i) | ~BW_MASK) : ((i) & BW_MASK))
 #  define BWu(u)  ((u) & BW_MASK)
 #else
@@ -150,11 +150,9 @@ PP(pp_padhv)
     }
     else if (gimme == G_SCALAR) {
        SV* sv = sv_newmortal();
-       if (HvFILL((HV*)TARG)) {
-           sprintf(buf, "%ld/%ld",
-                   (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG)+1);
-           sv_setpv(sv, buf);
-       }
+       if (HvFILL((HV*)TARG))
+           sv_setpvf(sv, "%ld/%ld",
+                     (long)HvFILL((HV*)TARG), (long)HvMAX((HV*)TARG) + 1);
        else
            sv_setiv(sv, 0);
        SETs(sv);
@@ -863,7 +861,7 @@ PP(pp_left_shift)
       IBW shift = POPi;
       if (op->op_private & HINT_INTEGER) {
        IBW i = TOPi;
-       i <<= shift;
+       i = BWi(i) << shift;
        SETi(BWi(i));
       }
       else {
@@ -882,7 +880,7 @@ PP(pp_right_shift)
       IBW shift = POPi;
       if (op->op_private & HINT_INTEGER) {
        IBW i = TOPi;
-       i >>= shift;
+       i = BWi(i) >> shift;
        SETi(BWi(i));
       }
       else {
@@ -3114,12 +3112,9 @@ PP(pp_unpack)
                        auv = 0;
                    }
                    else if (++bytes >= sizeof(UV)) {   /* promote to string */
-                       char decn[sizeof(UV) * 3 + 1];
                        char *t;
 
-                       (void) sprintf(decn, "%0*ld",
-                                      (int)sizeof(decn) - 1, auv);
-                       sv = newSVpv(decn, 0);
+                       sv = newSVpvf("%0*vu", (int)(sizeof(UV) * 3), auv);
                        while (s < strend) {
                            sv = mul128(sv, *s & 0x7f);
                            if (!(*s++ & 0x80)) {
@@ -3716,7 +3711,14 @@ PP(pp_pack)
                if (adouble < 0)
                    croak("Cannot compress negative numbers");
 
-               if (adouble <= UV_MAX) {
+               if (
+#ifdef BW_BITS
+                   adouble <= BW_MASK
+#else
+                   adouble <= UV_MAX
+#endif
+                   )
+               {
                    char   buf[1 + sizeof(UV)];
                    char  *in = buf + sizeof(buf);
                    UV     auv = U_V(adouble);;
index 371e037..1600ed8 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -822,7 +822,7 @@ block_gimme()
 
     cxix = dopoptosub(cxstack_ix);
     if (cxix < 0)
-       return G_SCALAR;
+       return G_VOID;
 
     switch (cxstack[cxix].blk_gimme) {
     case G_VOID:
@@ -2130,7 +2130,8 @@ PP(pp_require)
     register CONTEXT *cx;
     SV *sv;
     char *name;
-    char *tmpname;
+    char *tryname;
+    SV *namesv = Nullsv;
     SV** svp;
     I32 gimme = G_SCALAR;
     PerlIO *tryrsfp = 0;
@@ -2154,61 +2155,63 @@ PP(pp_require)
 
     /* prepare to compile file */
 
-    tmpname = savepv(name);
-    if (*tmpname == '/' ||
-       (*tmpname == '.' && 
-           (tmpname[1] == '/' ||
-            (tmpname[1] == '.' && tmpname[2] == '/')))
+    if (*name == '/' ||
+       (*name == '.' && 
+           (name[1] == '/' ||
+            (name[1] == '.' && name[2] == '/')))
 #ifdef DOSISH
-      || (tmpname[0] && tmpname[1] == ':')
+      || (name[0] && name[1] == ':')
 #endif
 #ifdef VMS
-       || (strchr(tmpname,':')  || ((*tmpname == '[' || *tmpname == '<') &&
-           (isALNUM(tmpname[1]) || strchr("$-_]>",tmpname[1]))))
+       || (strchr(name,':')  || ((*name == '[' || *name == '<') &&
+           (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
 #endif
     )
     {
-       tryrsfp = PerlIO_open(tmpname,"r");
+       tryname = name;
+       tryrsfp = PerlIO_open(name,"r");
     }
     else {
        AV *ar = GvAVn(incgv);
        I32 i;
 #ifdef VMS
-       char unixified[256];
-       if (tounixspec_ts(tmpname,unixified) != NULL)
-         for (i = 0; i <= AvFILL(ar); i++) {
-           if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
-               continue;
-           strcat(buf,unixified);
+       char *unixname;
+       if ((unixname = tounixspec(name, Nullch)) != Nullch)
+#endif
+       {
+           namesv = NEWSV(806, 0);
+           for (i = 0; i <= AvFILL(ar); i++) {
+               char *dir = SvPVx(*av_fetch(ar, i, TRUE), na);
+#ifdef VMS
+               char *unixdir;
+               if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
+                   continue;
+               sv_setpv(namesv, unixdir);
+               sv_catpv(namesv, unixname);
 #else
-       for (i = 0; i <= AvFILL(ar); i++) {
-           (void)sprintf(buf, "%s/%s",
-               SvPVx(*av_fetch(ar, i, TRUE), na), name);
+               sv_setpvf(namesv, "%s/%s", dir, name);
 #endif
-           tryrsfp = PerlIO_open(buf, "r");
-           if (tryrsfp) {
-               char *s = buf;
-
-               if (*s == '.' && s[1] == '/')
-                   s += 2;
-               Safefree(tmpname);
-               tmpname = savepv(s);
-               break;
+               tryname = SvPVX(namesv);
+               tryrsfp = PerlIO_open(tryname, "r");
+               if (tryrsfp) {
+                   if (tryname[0] == '.' && tryname[1] == '/')
+                       tryname += 2;
+                   break;
+               }
            }
        }
     }
     SAVESPTR(compiling.cop_filegv);
-    compiling.cop_filegv = gv_fetchfile(tmpname);
-    Safefree(tmpname);
-    tmpname = Nullch;
+    compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
+    SvREFCNT_dec(namesv);
     if (!tryrsfp) {
        if (op->op_type == OP_REQUIRE) {
-           sprintf(tokenbuf,"Can't locate %s in @INC", name);
-           if (instr(tokenbuf,".h "))
-               strcat(tokenbuf," (change .h to .ph maybe?)");
-           if (instr(tokenbuf,".ph "))
-               strcat(tokenbuf," (did you run h2ph?)");
-           DIE("%s",tokenbuf);
+           SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
+           if (instr(SvPVX(msg), ".h "))
+               sv_catpv(msg, " (change .h to .ph maybe?)");
+           if (instr(SvPVX(msg), ".ph "))
+               sv_catpv(msg, " (did you run h2ph?)");
+           DIE("%S", msg);
        }
 
        RETPUSHUNDEF;
@@ -2255,7 +2258,7 @@ PP(pp_entereval)
     register CONTEXT *cx;
     dPOPss;
     I32 gimme = GIMME_V, was = sub_generation;
-    char tmpbuf[32], *safestr;
+    char tmpbuf[sizeof(unsigned long) * 3 + 12], *safestr;
     STRLEN len;
     OP *ret;
 
index 7cc8655..8a301e5 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -564,10 +564,9 @@ PP(pp_rv2hv)
     }
     else {
        dTARGET;
-       if (HvFILL(hv)) {
-           sprintf(buf, "%ld/%ld", (long)HvFILL(hv), (long)HvMAX(hv)+1);
-           sv_setpv(TARG, buf);
-       }
+       if (HvFILL(hv))
+           sv_setpvf(TARG, "%ld/%ld",
+                     (long)HvFILL(hv), (long)HvMAX(hv) + 1);
        else
            sv_setiv(TARG, 0);
        SETTARG;
index 6d18ac9..9d14089 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -154,6 +154,13 @@ static int dooneliner _((char *cmd, char *filename));
 
 #endif /* no flock() */
 
+#ifndef MAXPATHLEN
+#  ifdef PATH_MAX
+#    define MAXPATHLEN PATH_MAX
+#  else
+#    define MAXPATHLEN 1024
+#  endif
+#endif
 
 #define ZBTLEN 10
 static char zero_but_true[ZBTLEN + 1] = "0 but true";
@@ -171,7 +178,7 @@ PP(pp_backtick)
     fp = my_popen(tmps, "r");
     if (fp) {
        if (gimme == G_VOID) {
-           while (PerlIO_read(fp, buf, sizeof buf) > 0)
+           while (PerlIO_read(fp, tokenbuf, sizeof tokenbuf) > 0)
                /*SUPPRESS 530*/
                ;
        }
@@ -971,16 +978,16 @@ PP(pp_leavewrite)
        CV *cv;
        if (!IoTOP_GV(io)) {
            GV *topgv;
-           char tmpbuf[256];
+           SV *topname;
 
            if (!IoTOP_NAME(io)) {
                if (!IoFMT_NAME(io))
                    IoFMT_NAME(io) = savepv(GvNAME(gv));
-               sprintf(tmpbuf, "%s_TOP", IoFMT_NAME(io));
-               topgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVFM);
+               topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
+               topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
                if ((topgv && GvFORM(topgv)) ||
                  !gv_fetchpv("top",FALSE,SVt_PVFM))
-                   IoTOP_NAME(io) = savepv(tmpbuf);
+                   IoTOP_NAME(io) = savepv(SvPVX(topname));
                else
                    IoTOP_NAME(io) = savepv("top");
            }
@@ -1072,11 +1079,33 @@ PP(pp_prtf)
     IO *io;
     PerlIO *fp;
     SV *sv = NEWSV(0,0);
+    MAGIC *mg;
 
     if (op->op_flags & OPf_STACKED)
        gv = (GV*)*++MARK;
     else
        gv = defoutgv;
+
+    if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+       if (MARK == ORIGMARK) {
+           EXTEND(SP, 1);
+           ++MARK;
+           Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
+           ++SP;
+       }
+       PUSHMARK(MARK - 1);
+       *MARK = mg->mg_obj;
+       PUTBACK;
+       ENTER;
+       perl_call_method("PRINTF", G_SCALAR);
+       LEAVE;
+       SPAGAIN;
+       MARK = ORIGMARK + 1;
+       *MARK = *SP;
+       SP = MARK;
+       RETURN;
+    }
+
     if (!(io = GvIO(gv))) {
        if (dowarn) {
            gv_fullname3(sv, gv, Nullch);
@@ -1201,11 +1230,12 @@ PP(pp_sysread)
        goto say_undef;
 #ifdef HAS_SOCKET
     if (op->op_type == OP_RECV) {
-       bufsize = sizeof buf;
+       char namebuf[MAXPATHLEN];
+       bufsize = sizeof namebuf;
        buffer = SvGROW(bufsv, length+1);
        /* 'offset' means 'flags' here */
        length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
-           (struct sockaddr *)buf, &bufsize);
+                         (struct sockaddr *)namebuf, &bufsize);
        if (length < 0)
            RETPUSHUNDEF;
        SvCUR_set(bufsv, length);
@@ -1216,7 +1246,7 @@ PP(pp_sysread)
        if (!(IoFLAGS(io) & IOf_UNTAINT))
            SvTAINTED_on(bufsv);
        SP = ORIGMARK;
-       sv_setpvn(TARG, buf, bufsize);
+       sv_setpvn(TARG, namebuf, bufsize);
        PUSHs(TARG);
        RETURN;
     }
@@ -1240,9 +1270,10 @@ PP(pp_sysread)
     else
 #ifdef HAS_SOCKET__bad_code_maybe
     if (IoTYPE(io) == 's') {
-       bufsize = sizeof buf;
+       char namebuf[MAXPATHLEN];
+       bufsize = sizeof namebuf;
        length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
-           (struct sockaddr *)buf, &bufsize);
+                         (struct sockaddr *)namebuf, &bufsize);
     }
     else
 #endif
@@ -2631,7 +2662,9 @@ PP(pp_readlink)
     dSP; dTARGET;
 #ifdef HAS_SYMLINK
     char *tmps;
+    char buf[MAXPATHLEN];
     int len;
+
     tmps = POPp;
     len = readlink(tmps, buf, sizeof buf);
     EXTEND(SP, 1);
@@ -3304,18 +3337,18 @@ PP(pp_gmtime)
     EXTEND_MORTAL(9);
     if (GIMME != G_ARRAY) {
        dTARGET;
-       char mybuf[30];
+       SV *tsv;
        if (!tmbuf)
            RETPUSHUNDEF;
-       sprintf(mybuf, "%s %s %2d %02d:%02d:%02d %d",
-           dayname[tmbuf->tm_wday],
-           monname[tmbuf->tm_mon],
-           tmbuf->tm_mday,
-           tmbuf->tm_hour,
-           tmbuf->tm_min,
-           tmbuf->tm_sec,
-           tmbuf->tm_year + 1900);
-       PUSHp(mybuf, strlen(mybuf));
+       tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
+                      dayname[tmbuf->tm_wday],
+                      monname[tmbuf->tm_mon],
+                      tmbuf->tm_mday,
+                      tmbuf->tm_hour,
+                      tmbuf->tm_min,
+                      tmbuf->tm_sec,
+                      tmbuf->tm_year + 1900);
+       PUSHs(sv_2mortal(tsv));
     }
     else if (tmbuf) {
        PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
diff --git a/proto.h b/proto.h
index c2f1ef4..cd45ca8 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -40,8 +40,8 @@ U32   cast_ulong _((double f));
 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
 I32    my_chsize _((int fd, Off_t length));
 #endif
-OP *   ck_gvconst _((OP * o));
-OP *   ck_retarget _((OP *op));
+OP*    ck_gvconst _((OP*  o));
+OP*    ck_retarget _((OP* op));
 OP*    convert _((I32 optype, I32 flags, OP* op));
 char*  cpytill _((char* to, char* from, char* fromend, int delim, I32* retlen));
 void   croak _((const char* pat,...))
@@ -53,9 +53,9 @@ void  cv_undef _((CV* cv));
 #ifdef DEBUGGING
 void   cx_dump _((CONTEXT* cs));
 #endif
-SV *   filter_add _((filter_t funcp, SV *datasv));
+SV*    filter_add _((filter_t funcp, SV* datasv));
 void   filter_del _((filter_t funcp));
-I32    filter_read _((int idx, SV *buffer, int maxlen));
+I32    filter_read _((int idx, SVbuffer, int maxlen));
 I32    cxinc _((void));
 void   deb _((const char* pat,...)) __attribute__((format(printf,1,2)));
 void   deb_growlevel _((void));
@@ -89,7 +89,7 @@ bool  do_open _((GV* gv, char* name, I32 len,
                   int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp));
 void   do_pipe _((SV* sv, GV* rgv, GV* wgv));
 bool   do_print _((SV* sv, PerlIO* fp));
-OP *   do_readline _((void));
+OP   do_readline _((void));
 I32    do_chomp _((SV* sv));
 bool   do_seek _((GV* gv, long pos, int whence));
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
@@ -120,7 +120,8 @@ void        dump_sub _((GV* gv));
 void   fbm_compile _((SV* sv));
 char*  fbm_instr _((unsigned char* big, unsigned char* bigend, SV* littlesv));
 OP*    force_list _((OP* arg));
-OP*    fold_constants _((OP * arg));
+OP*    fold_constants _((OP* arg));
+char*  form _((const char* pat, ...));
 void   free_tmps _((void));
 OP*    gen_constant_list _((OP* op));
 void   gp_free _((GV* gv));
@@ -139,7 +140,7 @@ GV* gv_fetchmethod_autoload _((HV* stash, char* name, I32 autoload));
 GV*    gv_fetchpv _((char* name, I32 add, I32 sv_type));
 void   gv_fullname _((SV* sv, GV* gv));
 void   gv_fullname3 _((SV* sv, GV* gv, char* prefix));
-void   gv_init _((GV *gv, HV *stash, char *name, STRLEN len, int multi));
+void   gv_init _((GV* gv, HV* stash, char* name, STRLEN len, int multi));
 HV*    gv_stashpv _((char* name, I32 create));
 HV*    gv_stashpvn _((char* name, U32 namelen, I32 create));
 HV*    gv_stashsv _((SV* sv, I32 create));
@@ -175,7 +176,7 @@ OP* jmaybe _((OP* arg));
 I32    keyword _((char* d, I32 len));
 void   leave_scope _((I32 base));
 void   lex_end _((void));
-void   lex_start _((SV *line));
+void   lex_start _((SVline));
 OP*    linklist _((OP* op));
 OP*    list _((OP* o));
 OP*    listkids _((OP* o));
@@ -226,11 +227,11 @@ void      magicname _((char* sym, char* name, I32 namlen));
 int    main _((int argc, char** argv, char** env));
 void   markstack_grow _((void));
 #ifdef USE_LOCALE_COLLATE
-char*  mem_collxfrm _((const char *s, STRLEN len, STRLEN *xlen));
+char*  mem_collxfrm _((const char* s, STRLEN len, STRLEN* xlen));
 #endif
 char*  mess _((const char* pat, va_list* args));
 int    mg_clear _((SV* sv));
-int    mg_copy _((SV *, SV *, char *, I32));
+int    mg_copy _((SV* , SV* , char* , I32));
 MAGIC* mg_find _((SV* sv, int type));
 int    mg_free _((SV* sv));
 int    mg_get _((SV* sv));
@@ -239,7 +240,7 @@ void        mg_magical _((SV* sv));
 int    mg_set _((SV* sv));
 OP*    mod _((OP* op, I32 type));
 char*  moreswitches _((char* s));
-OP *   my _(( OP *));
+OP*    my _((OP* op));
 #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
 char*  my_bcopy _((char* from, char* to, I32 len));
 #endif
@@ -279,16 +280,16 @@ OP*       newRANGE _((I32 flags, OP* left, OP* right));
 OP*    newSLICEOP _((I32 flags, OP* subscript, OP* list));
 OP*    newSTATEOP _((I32 flags, char* label, OP* o));
 CV*    newSUB _((I32 floor, OP* op, OP* proto, OP* block));
-CV*    newXS _((char *name, void (*subaddr)(CV* cv), char *filename));
+CV*    newXS _((char* name, void (*subaddr)(CV* cv), char* filename));
 #ifdef DEPRECATED
-CV*    newXSUB _((char *name, I32 ix, I32 (*subaddr)(int,int,int), char *filename));
+CV*    newXSUB _((char* name, I32 ix, I32 (*subaddr)(int,int,int), char* filename));
 #endif
 AV*    newAV _((void));
 OP*    newAVREF _((OP* o));
 OP*    newBINOP _((I32 type, I32 flags, OP* first, OP* last));
 OP*    newCVREF _((I32 flags, OP* o));
 OP*    newGVOP _((I32 type, I32 flags, GV* gv));
-GV*    newGVgen _((char *pack));
+GV*    newGVgen _((charpack));
 OP*    newGVREF _((I32 type, OP* o));
 OP*    newHVREF _((OP* o));
 HV*    newHV _((void));
@@ -307,13 +308,14 @@ OP*       newSVOP _((I32 type, I32 flags, SV* sv));
 SV*    newSViv _((IV i));
 SV*    newSVnv _((double n));
 SV*    newSVpv _((char* s, STRLEN len));
+SV*    newSVpvf _((const char* pat, ...));
 SV*    newSVrv _((SV* rv, char* classname));
 SV*    newSVsv _((SV* old));
 OP*    newUNOP _((I32 type, I32 flags, OP* first));
-OP *   newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, OP* expr, OP* block, OP* cont));
+OP   newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, OP* expr, OP* block, OP* cont));
 PerlIO*        nextargv _((GV* gv));
 char*  ninstr _((char* big, char* bigend, char* little, char* lend));
-OP *   oopsCV _((OP* o));
+OP   oopsCV _((OP* o));
 void   op_free _((OP* arg));
 void   package _((OP* op));
 PADOFFSET      pad_alloc _((I32 optype, U32 tmptype));
@@ -343,9 +345,9 @@ HV* perl_get_hv _((char* name, I32 create));
 CV*    perl_get_cv _((char* name, I32 create));
 int    perl_init_i18nl10n _((int printwarn));
 int    perl_init_i18nl14n _((int printwarn));
-void   perl_new_collate _((char *newcoll));
-void   perl_new_ctype _((char *newctype));
-void   perl_new_numeric _((char *newcoll));
+void   perl_new_collate _((charnewcoll));
+void   perl_new_ctype _((charnewctype));
+void   perl_new_numeric _((charnewcoll));
 void   perl_set_numeric_local _((void));
 void   perl_set_numeric_standard _((void));
 int    perl_parse _((PerlInterpreter* sv_interp, void(*xsinit)(void), int argc, char** argv, char** env));
@@ -368,7 +370,7 @@ void        regdump _((regexp* r));
 I32    pregexec _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, I32 safebase));
 void   pregfree _((struct regexp* r));
 char*  regnext _((char* p));
-char*  regprop _((char* op));
+void   regprop _((SV* sv, char* op));
 void   repeatcpy _((char* to, char* from, I32 len, I32 count));
 char*  rninstr _((char* big, char* bigend, char* little, char* lend));
 Sighandler_t rsignal _((int, Sighandler_t));
@@ -401,10 +403,10 @@ void      save_int _((int* intp));
 void   save_item _((SV* item));
 void   save_iv _((IV* iv));
 void   save_list _((SV** sarg, I32 maxsarg));
-void   save_long _((long *longp));
+void   save_long _((longlongp));
 void   save_nogv _((GV* gv));
 SV*    save_scalar _((GV* gv));
-void   save_pptr _((char **pptr));
+void   save_pptr _((char** pptr));
 void   save_sptr _((SV** sptr));
 SV*    save_svref _((SV** sptr));
 OP*    sawparens _((OP* o));
@@ -420,7 +422,7 @@ char*       screaminstr _((SV* bigsv, SV* littlesv));
 #ifndef VMS
 I32    setenv_getix _((char* nam));
 #endif
-void   setdefout _((GV *gv));
+void   setdefout _((GVgv));
 char*  sharepvn _((char* sv, I32 len, U32 hash));
 HEK*   share_hek _((char* sv, I32 len, U32 hash));
 Signal_t sighandler _((int sig));
@@ -438,6 +440,7 @@ UV  sv_2uv _((SV* sv));
 void   sv_add_arena _((char* ptr, U32 size, U32 flags));
 int    sv_backoff _((SV* sv));
 SV*    sv_bless _((SV* sv, HV* stash));
+void   sv_catpvf _((SV* sv, const char* pat, ...));
 void   sv_catpv _((SV* sv, char* ptr));
 void   sv_catpvn _((SV* sv, char* ptr, STRLEN len));
 void   sv_catsv _((SV* dsv, SV* ssv));
@@ -471,19 +474,20 @@ void      sv_magic _((SV* sv, SV* obj, int how, char* name, I32 namlen));
 SV*    sv_mortalcopy _((SV* oldsv));
 SV*    sv_newmortal _((void));
 SV*    sv_newref _((SV* sv));
-char * sv_peek _((SV* sv));
-char * sv_pvn_force _((SV* sv, STRLEN* lp));
+char sv_peek _((SV* sv));
+char sv_pvn_force _((SV* sv, STRLEN* lp));
 char*  sv_reftype _((SV* sv, int ob));
 void   sv_replace _((SV* sv, SV* nsv));
 void   sv_report_used _((void));
 void   sv_reset _((char* s, HV* stash));
+void   sv_setpvf _((SV* sv, const char* pat, ...));
 void   sv_setiv _((SV* sv, IV num));
 void   sv_setuv _((SV* sv, UV num));
 void   sv_setnv _((SV* sv, double num));
-SV*    sv_setref_iv _((SV *rv, char *classname, IV iv));
-SV*    sv_setref_nv _((SV *rv, char *classname, double nv));
-SV*    sv_setref_pv _((SV *rv, char *classname, void* pv));
-SV*    sv_setref_pvn _((SV *rv, char *classname, char* pv, I32 n));
+SV*    sv_setref_iv _((SV* rv, char* classname, IV iv));
+SV*    sv_setref_nv _((SV* rv, char* classname, double nv));
+SV*    sv_setref_pv _((SV* rv, char* classname, void* pv));
+SV*    sv_setref_pvn _((SV* rv, char* classname, char* pv, I32 n));
 void   sv_setpv _((SV* sv, const char* ptr));
 void   sv_setpvn _((SV* sv, const char* ptr, STRLEN len));
 void   sv_setsv _((SV* dsv, SV* ssv));
@@ -494,6 +498,12 @@ void       sv_unref _((SV* sv));
 void   sv_untaint _((SV* sv));
 bool   sv_upgrade _((SV* sv, U32 mt));
 void   sv_usepvn _((SV* sv, char* ptr, STRLEN len));
+void   sv_vcatpvfn _((SV* sv, const char* pat, STRLEN patlen,
+                      va_list* args, SV** svargs, I32 svmax,
+                      bool *used_locale));
+void   sv_vsetpvfn _((SV* sv, const char* pat, STRLEN patlen,
+                      va_list* args, SV** svargs, I32 svmax,
+                      bool *used_locale));
 void   taint_env _((void));
 void   taint_proper _((const char* f, char* s));
 #ifdef UNLINK_ALL_VERSIONS
@@ -506,7 +516,7 @@ void        vivify_defelem _((SV* sv));
 void   vivify_ref _((SV* sv, U32 to_what));
 I32    wait4pid _((int pid, int* statusp, int flags));
 void   warn _((const char* pat,...)) __attribute__((format(printf,1,2)));
-void   watch _((char **addr));
+void   watch _((char** addr));
 I32    whichsig _((char* sig));
 int    yyerror _((char* s));
 int    yylex _((void));
index 5dad7d7..9b0d4fc 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -1523,7 +1523,7 @@ regexp *r;
     register char *s;
     register char op = EXACT;  /* Arbitrary non-END op. */
     register char *next;
-
+    SV *sv = sv_newmortal();
 
     s = r->program + 1;
     while (op != END) {        /* While that wasn't END last time... */
@@ -1532,7 +1532,9 @@ regexp *r;
            s++;
 #endif
        op = OP(s);
-       PerlIO_printf(Perl_debug_log, "%2d%s", s-r->program, regprop(s));       /* Where, what. */
+       /* where, what */
+       regprop(sv, s);
+       PerlIO_printf(Perl_debug_log, "%2d%s", s - r->program, SvPVX(sv));
        next = regnext(s);
        s += regarglen[(U8)op];
        if (next == NULL)               /* Next ptr. */
@@ -1561,8 +1563,10 @@ regexp *r;
     /* Header fields of interest. */
     if (r->regstart)
        PerlIO_printf(Perl_debug_log, "start `%s' ", SvPVX(r->regstart));
-    if (r->regstclass)
-       PerlIO_printf(Perl_debug_log, "stclass `%s' ", regprop(r->regstclass));
+    if (r->regstclass) {
+       regprop(sv, r->regstclass);
+       PerlIO_printf(Perl_debug_log, "stclass `%s' ", SvPVX(sv));
+    }
     if (r->reganch & ROPT_ANCH) {
        PerlIO_printf(Perl_debug_log, "anchored");
        if (r->reganch & ROPT_ANCH_BOL)
@@ -1585,14 +1589,14 @@ regexp *r;
 /*
 - regprop - printable representation of opcode
 */
-char *
-regprop(op)
+void
+regprop(sv, op)
+SV *sv;
 char *op;
 {
     register char *p = 0;
 
-    (void) strcpy(buf, ":");
-
+    sv_setpv(sv, ":");
     switch (OP(op)) {
     case BOL:
        p = "BOL";
@@ -1655,23 +1659,19 @@ char *op;
        p = "NBOUNDL";
        break;
     case CURLY:
-       (void)sprintf(buf+strlen(buf), "CURLY {%d,%d}", ARG1(op),ARG2(op));
-       p = NULL;
+       sv_catpvf(sv, "CURLY {%d,%d}", ARG1(op), ARG2(op));
        break;
     case CURLYX:
-       (void)sprintf(buf+strlen(buf), "CURLYX {%d,%d}", ARG1(op),ARG2(op));
-       p = NULL;
+       sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(op), ARG2(op));
        break;
     case REF:
-       (void)sprintf(buf+strlen(buf), "REF%d", ARG1(op));
-       p = NULL;
+       sv_catpvf(sv, "REF%d", ARG1(op));
        break;
     case OPEN:
-       (void)sprintf(buf+strlen(buf), "OPEN%d", ARG1(op));
-       p = NULL;
+       sv_catpvf(sv, "OPEN%d", ARG1(op));
        break;
     case CLOSE:
-       (void)sprintf(buf+strlen(buf), "CLOSE%d", ARG1(op));
+       sv_catpvf(sv, "CLOSE%d", ARG1(op));
        p = NULL;
        break;
     case STAR:
@@ -1731,9 +1731,8 @@ char *op;
     default:
        FAIL("corrupted regexp opcode");
     }
-    if (p != NULL)
-       (void) strcat(buf, p);
-    return(buf);
+    if (p)
+       sv_catpv(sv, p);
 }
 #endif /* DEBUGGING */
 
index 658239a..630b130 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -634,8 +634,11 @@ char *prog;
 #define sayNO goto no
 #define saySAME(x) if (x) goto yes; else goto no
        if (regnarrate) {
-           PerlIO_printf(Perl_debug_log, "%*s%2d%-8.8s\t<%.10s>\n", regindent*2, "",
-               scan - regprogram, regprop(scan), locinput);
+           SV *prop = sv_newmortal();
+           regprop(prop, scan);
+           PerlIO_printf(Perl_debug_log, "%*s%2d%-8.8s\t<%.10s>\n",
+                         regindent*2, "", scan - regprogram,
+                         SvPVX(prop), locinput);
        }
 #else
 #define sayYES return 1
diff --git a/scope.c b/scope.c
index 9cf8b1a..f7835b7 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -525,7 +525,8 @@ I32 base;
            break;
        case SAVEt_FREEOP:
            ptr = SSPOPPTR;
-           curpad = AvARRAY(comppad);
+           if (comppad)
+               curpad = AvARRAY(comppad);
            op_free((OP*)ptr);
            break;
        case SAVEt_FREEPV:
diff --git a/sv.c b/sv.c
index 33b72ff..598e746 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -885,28 +885,29 @@ char *
 sv_peek(sv)
 register SV *sv;
 {
-    char *t = tokenbuf;
+    SV *t = sv_newmortal();
+    STRLEN prevlen;
     int unref = 0;
 
   retry:
     if (!sv) {
-       strcpy(t, "VOID");
+       sv_catpv(t, "VOID");
        goto finish;
     }
     else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
-       strcpy(t, "WILD");
+       sv_catpv(t, "WILD");
        goto finish;
     }
     else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) {
        if (sv == &sv_undef) {
-           strcpy(t, "SV_UNDEF");
+           sv_catpv(t, "SV_UNDEF");
            if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
                                 SVs_GMG|SVs_SMG|SVs_RMG)) &&
                SvREADONLY(sv))
                goto finish;
        }
        else if (sv == &sv_no) {
-           strcpy(t, "SV_NO");
+           sv_catpv(t, "SV_NO");
            if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
                                 SVs_GMG|SVs_SMG|SVs_RMG)) &&
                !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
@@ -916,7 +917,7 @@ register SV *sv;
                goto finish;
        }
        else {
-           strcpy(t, "SV_YES");
+           sv_catpv(t, "SV_YES");
            if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
                                 SVs_GMG|SVs_SMG|SVs_RMG)) &&
                !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
@@ -926,17 +927,18 @@ register SV *sv;
                SvNVX(sv) == 1.0)
                goto finish;
        }
-       t += strlen(t);
-       *t++ = ':';
+       sv_catpv(t, ":");
     }
     else if (SvREFCNT(sv) == 0) {
-       *t++ = '(';
+       sv_catpv(t, "(");
        unref++;
     }
     if (SvROK(sv)) {
-       *t++ = '\\';
-       if (t - tokenbuf + unref > 10) {
-           strcpy(tokenbuf + unref + 3,"...");
+       sv_catpv(t, "\\");
+       if (SvCUR(t) + unref > 10) {
+           SvCUR(t) = unref + 3;
+           *SvEND(t) = '\0';
+           sv_catpv(t, "...");
            goto finish;
        }
        sv = (SV*)SvRV(sv);
@@ -944,88 +946,85 @@ register SV *sv;
     }
     switch (SvTYPE(sv)) {
     default:
-       strcpy(t,"FREED");
+       sv_catpv(t, "FREED");
        goto finish;
 
     case SVt_NULL:
-       strcpy(t,"UNDEF");
+       sv_catpv(t, "UNDEF");
        return tokenbuf;
     case SVt_IV:
-       strcpy(t,"IV");
+       sv_catpv(t, "IV");
        break;
     case SVt_NV:
-       strcpy(t,"NV");
+       sv_catpv(t, "NV");
        break;
     case SVt_RV:
-       strcpy(t,"RV");
+       sv_catpv(t, "RV");
        break;
     case SVt_PV:
-       strcpy(t,"PV");
+       sv_catpv(t, "PV");
        break;
     case SVt_PVIV:
-       strcpy(t,"PVIV");
+       sv_catpv(t, "PVIV");
        break;
     case SVt_PVNV:
-       strcpy(t,"PVNV");
+       sv_catpv(t, "PVNV");
        break;
     case SVt_PVMG:
-       strcpy(t,"PVMG");
+       sv_catpv(t, "PVMG");
        break;
     case SVt_PVLV:
-       strcpy(t,"PVLV");
+       sv_catpv(t, "PVLV");
        break;
     case SVt_PVAV:
-       strcpy(t,"AV");
+       sv_catpv(t, "AV");
        break;
     case SVt_PVHV:
-       strcpy(t,"HV");
+       sv_catpv(t, "HV");
        break;
     case SVt_PVCV:
        if (CvGV(sv))
-           sprintf(t, "CV(%s)", GvNAME(CvGV(sv)));
+           sv_catpvf(t, "CV(%s)", GvNAME(CvGV(sv)));
        else
-           strcpy(t, "CV()");
+           sv_catpv(t, "CV()");
        goto finish;
     case SVt_PVGV:
-       strcpy(t,"GV");
+       sv_catpv(t, "GV");
        break;
     case SVt_PVBM:
-       strcpy(t,"BM");
+       sv_catpv(t, "BM");
        break;
     case SVt_PVFM:
-       strcpy(t,"FM");
+       sv_catpv(t, "FM");
        break;
     case SVt_PVIO:
-       strcpy(t,"IO");
+       sv_catpv(t, "IO");
        break;
     }
-    t += strlen(t);
 
     if (SvPOKp(sv)) {
        if (!SvPVX(sv))
-           strcpy(t, "(null)");
+           sv_catpv(t, "(null)");
        if (SvOOK(sv))
-           sprintf(t,"(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv));
+           sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv));
        else
-           sprintf(t,"(\"%.127s\")",SvPVX(sv));
+           sv_catpvf(t, "(\"%.127s\")",SvPVX(sv));
     }
     else if (SvNOKp(sv)) {
        SET_NUMERIC_STANDARD();
-       sprintf(t,"(%g)",SvNVX(sv));
+       sv_catpvf(t, "(%g)",SvNVX(sv));
     }
     else if (SvIOKp(sv))
-       sprintf(t,"(%ld)",(long)SvIVX(sv));
+       sv_catpvf(t, "(%ld)",(long)SvIVX(sv));
     else
-       strcpy(t,"()");
+       sv_catpv(t, "()");
     
   finish:
     if (unref) {
-       t += strlen(t);
        while (unref--)
-           *t++ = ')';
-       *t = '\0';
+           sv_catpv(t, ")");
     }
-    return tokenbuf;
+    return SvPV(t, na);
 }
 #endif
 
@@ -1592,6 +1591,7 @@ STRLEN *lp;
 {
     register char *s;
     int olderrno;
+    SV *tsv;
 
     if (!sv) {
        *lp = 0;
@@ -1605,11 +1605,13 @@ STRLEN *lp;
        }
        if (SvIOKp(sv)) {
            (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
+           tsv = Nullsv;
            goto tokensave;
        }
        if (SvNOKp(sv)) {
            SET_NUMERIC_STANDARD();
            Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
+           tsv = Nullsv;
            goto tokensave;
        }
         if (!SvROK(sv)) {
@@ -1649,11 +1651,12 @@ STRLEN *lp;
                case SVt_PVIO:  s = "IO";                       break;
                default:        s = "UNKNOWN";                  break;
                }
+               tsv = NEWSV(0,0);
                if (SvOBJECT(sv))
-                   sprintf(tokenbuf, "%s=%s(0x%lx)",
-                               HvNAME(SvSTASH(sv)), s, (unsigned long)sv);
+                   sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
                else
-                   sprintf(tokenbuf, "%s(0x%lx)", s, (unsigned long)sv);
+                   sv_setpv(tsv, s);
+               sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
                goto tokensaveref;
            }
            *lp = strlen(s);
@@ -1663,10 +1666,12 @@ STRLEN *lp;
            if (SvNOKp(sv)) {
                SET_NUMERIC_STANDARD();
                Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
+               tsv = Nullsv;
                goto tokensave;
            }
            if (SvIOKp(sv)) {
                (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
+               tsv = Nullsv;
                goto tokensave;
            }
            if (dowarn)
@@ -1700,18 +1705,16 @@ STRLEN *lp;
        while (*s) s++;
 #ifdef hcx
        if (s[-1] == '.')
-           s--;
+           *--s = '\0';
 #endif
     }
     else if (SvIOKp(sv)) {
        if (SvTYPE(sv) < SVt_PVIV)
            sv_upgrade(sv, SVt_PVIV);
-       SvGROW(sv, 11);
-       s = SvPVX(sv);
        olderrno = errno;       /* some Xenix systems wipe out errno here */
-       (void)sprintf(s,"%ld",(long)SvIVX(sv));
+       sv_setpvf(sv, "%vd", SvIVX(sv));
        errno = olderrno;
-       while (*s) s++;
+       s = SvEND(sv);
     }
     else {
        if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
@@ -1719,7 +1722,6 @@ STRLEN *lp;
        *lp = 0;
        return "";
     }
-    *s = '\0';
     *lp = s - SvPVX(sv);
     SvCUR_set(sv, *lp);
     SvPOK_on(sv);
@@ -1731,23 +1733,36 @@ STRLEN *lp;
        /* Sneaky stuff here */
 
       tokensaveref:
-       sv = sv_newmortal();
-       *lp = strlen(tokenbuf);
-       sv_setpvn(sv, tokenbuf, *lp);
-       return SvPVX(sv);
+       if (!tsv)
+           tsv = newSVpv(tokenbuf, 0);
+       sv_2mortal(tsv);
+       *lp = SvCUR(tsv);
+       return SvPVX(tsv);
     }
     else {
        STRLEN len;
-       
+       char *t;
+
+       if (tsv) {
+           sv_2mortal(tsv);
+           t = SvPVX(tsv);
+           len = SvCUR(tsv);
+       }
+       else {
+           t = tokenbuf;
+           len = strlen(tokenbuf);
+       }
 #ifdef FIXNEGATIVEZERO
-       if (*tokenbuf == '-' && tokenbuf[1] == '0' && !tokenbuf[2])
-           strcpy(tokenbuf,"0");
+       if (len == 2 && t[0] == '-' && t[1] == '0') {
+           t = "0";
+           len = 1;
+       }
 #endif
        (void)SvUPGRADE(sv, SVt_PV);
-       len = *lp = strlen(tokenbuf);
+       *lp = len;
        s = SvGROW(sv, len + 1);
        SvCUR_set(sv, len);
-       (void)strcpy(s, tokenbuf);
+       (void)strcpy(s, t);
        SvPOKp_on(sv);
        return s;
     }
@@ -3444,6 +3459,35 @@ STRLEN len;
     return sv;
 }
 
+#ifdef I_STDARG
+SV *
+newSVpvf(const char* pat, ...)
+#else
+/*VARARGS0*/
+SV *
+newSVpvf(sv, pat, va_alist)
+const char *pat;
+va_dcl
+#endif
+{
+    register SV *sv;
+    va_list args;
+
+    new_SV(sv);
+    SvANY(sv) = 0;
+    SvREFCNT(sv) = 1;
+    SvFLAGS(sv) = 0;
+#ifdef I_STDARG
+    va_start(args, pat);
+#else
+    va_start(args);
+#endif
+    sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool));
+    va_end(args);
+    return sv;
+}
+
+
 SV *
 newSVnv(n)
 double n;
@@ -3595,6 +3639,40 @@ HV *stash;
     }
 }
 
+IO*
+sv_2io(sv)
+SV *sv;
+{
+    IO* io;
+    GV* gv;
+
+    switch (SvTYPE(sv)) {
+    case SVt_PVIO:
+       io = (IO*)sv;
+       break;
+    case SVt_PVGV:
+       gv = (GV*)sv;
+       io = GvIO(gv);
+       if (!io)
+           croak("Bad filehandle: %s", GvNAME(gv));
+       break;
+    default:
+       if (!SvOK(sv))
+           croak(no_usym, "filehandle");
+       if (SvROK(sv))
+           return sv_2io(SvRV(sv));
+       gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO);
+       if (gv)
+           io = GvIO(gv);
+       else
+           io = 0;
+       if (!io)
+           croak("Bad filehandle: %s", SvPV(sv,na));
+       break;
+    }
+    return io;
+}
+
 CV *
 sv_2cv(sv, st, gvp, lref)
 SV *sv;
@@ -3981,40 +4059,6 @@ SV* sv;
        sv_2mortal(rv);         /* Schedule for freeing later */
 }
 
-IO*
-sv_2io(sv)
-SV *sv;
-{
-    IO* io;
-    GV* gv;
-
-    switch (SvTYPE(sv)) {
-    case SVt_PVIO:
-       io = (IO*)sv;
-       break;
-    case SVt_PVGV:
-       gv = (GV*)sv;
-       io = GvIO(gv);
-       if (!io)
-           croak("Bad filehandle: %s", GvNAME(gv));
-       break;
-    default:
-       if (!SvOK(sv))
-           croak(no_usym, "filehandle");
-       if (SvROK(sv))
-           return sv_2io(SvRV(sv));
-       gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO);
-       if (gv)
-           io = GvIO(gv);
-       else
-           io = 0;
-       if (!io)
-           croak("Bad filehandle: %s", SvPV(sv,na));
-       break;
-    }
-    return io;
-}
-
 void
 sv_taint(sv)
 SV *sv;
@@ -4045,13 +4089,451 @@ SV *sv;
     return FALSE;
 }
 
+#ifdef I_STDARG
+void
+sv_setpvf(SV *sv, const char* pat, ...)
+#else
+/*VARARGS0*/
+void
+sv_setpvf(sv, pat, va_alist)
+    SV *sv;
+    const char *pat;
+    va_dcl
+#endif
+{
+    va_list args;
+#ifdef I_STDARG
+    va_start(args, pat);
+#else
+    va_start(args);
+#endif
+    sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool));
+    va_end(args);
+}
+
+#ifdef I_STDARG
+void
+sv_catpvf(SV *sv, const char* pat, ...)
+#else
+/*VARARGS0*/
+void
+sv_catpvf(sv, pat, va_alist)
+    SV *sv;
+    const char *pat;
+    va_dcl
+#endif
+{
+    va_list args;
+#ifdef I_STDARG
+    va_start(args, pat);
+#else
+    va_start(args);
+#endif
+    sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool));
+    va_end(args);
+}
+
+void
+sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
+    SV *sv;
+    const char *pat;
+    STRLEN patlen;
+    va_list *args;
+    SV **svargs;
+    I32 svmax;
+    bool *used_locale;
+{
+    sv_setpvn(sv, "", 0);
+    sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
+}
+
+void
+sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
+    SV *sv;
+    const char *pat;
+    STRLEN patlen;
+    va_list *args;
+    SV **svargs;
+    I32 svmax;
+    bool *used_locale;
+{
+    char *p;
+    char *q;
+    char *patend;
+    I32 svix = 0;
+
+    /* no matter what, this is a string now */
+    (void)SvPV_force(sv, na);
+
+    /* special-case "" and "%s" */
+    if (patlen == 0)
+       return;
+    if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
+       if (args)
+           sv_catpv(sv, va_arg(*args, char *));
+       else if (svix < svmax)
+           sv_catsv(sv, *svargs);
+       return;
+    }
+
+    patend = (char*)pat + patlen;
+    for (p = (char*)pat; p < patend; p = q) {
+       bool alt = FALSE;
+       bool left = FALSE;
+       char fill = ' ';
+       char plus = 0;
+       char intsize = 0;
+       STRLEN width = 0;
+       bool has_precis = FALSE;
+       STRLEN precis = 0;
+
+       char esignbuf[4];
+       STRLEN esignlen = 0;
+
+       char *eptr = Nullch;
+        STRLEN elen = 0;
+       char ebuf[(sizeof(UV) * 3) * 2 + 16]; /* large enough for "%#.#f" */
+
+       static char *efloatbuf = Nullch;
+       static STRLEN efloatsize = 0;
+
+       char c;
+       int i;
+       unsigned base;
+       IV iv;
+       UV uv;
+       double nv;
+       STRLEN have;
+       STRLEN need;
+       STRLEN gap;
+
+       for (q = p; q < patend && *q != '%'; ++q) ;
+       if (q > p) {
+           sv_catpvn(sv, p, q - p);
+           p = q;
+       }
+       if (q++ >= patend)
+           break;
+
+       while (*q) {
+           switch (*q) {
+           case ' ':
+           case '+':
+               plus = *q++;
+               continue;
+
+           case '-':
+               left = TRUE;
+               q++;
+               continue;
+
+           case '0':
+               fill = *q++;
+               continue;
+
+           case '#':
+               alt = TRUE;
+               q++;
+               continue;
+
+           case 'l':
+#if 0  /* when quads have better support within Perl */
+               if (intsize == 'l') {
+                   intsize = 'q';
+                   q++;
+                   continue;
+               }
+#endif
+               /* FALL THROUGH */
+           case 'h':
+           case 'v':
+               intsize = *q++;
+               continue;
+
+           case '1': case '2': case '3':
+           case '4': case '5': case '6':
+           case '7': case '8': case '9':
+               width = 0;
+               while (isDIGIT(*q))
+                   width = width * 10 + (*q++ - '0');
+               continue;
+
+           case '*':
+               if (args)
+                   i = va_arg(*args, int);
+               else
+                   i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+               left ^= (i < 0);
+               width = (i < 0) ? -i : i;
+               q++;
+               continue;
+
+           case '.':
+               q++;
+               if (*q == '*') {
+                   if (args)
+                       precis = va_arg(*args, int);
+                   else
+                       precis = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
+                   q++;
+               }
+               else {
+                   precis = 0;
+                   while (isDIGIT(*q))
+                       precis = precis * 10 + (*q++ - '0');
+               }
+               has_precis = TRUE;
+               continue;
+
+           default:
+               break;
+           }
+
+           break;
+       }
+
+       switch (c = *q++) {
+
+           /* STRINGS */
+
+       case '%':
+           eptr = q - 1;
+           elen = 1;
+           goto string;
+
+       case 'c':
+           if (args)
+               c = va_arg(*args, int);
+           else
+               c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+           eptr = &c;
+           elen = 1;
+           goto string;
+
+       case 'S':
+           if (args) {
+               eptr = SvPVx(va_arg(*args, SV *), elen);
+               goto string;
+           }
+           /* FALL THROUGH */
+
+       case 's':
+           if (args) {
+               eptr = va_arg(*args, char *);
+               elen = strlen(eptr);
+           }
+           else if (svix < svmax)
+               eptr = SvPVx(svargs[svix++], elen);
+           goto string;
+
+       string:
+           if (has_precis && elen > precis)
+               elen = precis;
+           break;
+
+           /* INTEGERS */
+
+       case 'D':
+           intsize = 'l';
+           /* FALL THROUGH */
+       case 'd':
+       case 'i':
+           if (args) {
+               switch (intsize) {
+               case 'h':       iv = (short)va_arg(*args, int); break;
+               default:        iv = va_arg(*args, int); break;
+               case 'l':       iv = va_arg(*args, long); break;
+               case 'v':       iv = va_arg(*args, IV); break;
+               }
+           }
+           else {
+               iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
+               switch (intsize) {
+               case 'h':       iv = (short)iv; break;
+               default:        iv = (int)iv; break;
+               case 'l':       iv = (long)iv; break;
+               case 'v':       break;
+               }
+           }
+           if (iv >= 0) {
+               uv = iv;
+               if (plus)
+                   esignbuf[esignlen++] = plus;
+           }
+           else {
+               uv = -iv;
+               esignbuf[esignlen++] = '-';
+           }
+           base = 10;
+           goto integer;
+
+       case 'O':
+           intsize = 'l';
+           /* FALL THROUGH */
+       case 'o':
+           base = 8;
+           goto uns_integer;
+
+       case 'X':
+           intsize = 'l';
+           /* FALL THROUGH */
+       case 'x':
+           base = 16;
+           goto uns_integer;
+
+       case 'u':
+           base = 10;
+
+       uns_integer:
+           if (args) {
+               switch (intsize) {
+               case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
+               default:   uv = va_arg(*args, unsigned); break;
+               case 'l':  uv = va_arg(*args, unsigned long); break;
+               case 'v':  uv = va_arg(*args, UV); break;
+               }
+           }
+           else {
+               uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
+               switch (intsize) {
+               case 'h':       uv = (unsigned short)uv; break;
+               default:        uv = (unsigned)uv; break;
+               case 'l':       uv = (unsigned long)uv; break;
+               case 'v':       break;
+               }
+           }
+
+       integer:
+           p = "0123456789abcdef";
+           eptr = ebuf + sizeof ebuf;
+           do {
+               unsigned dig = uv % base;
+               *--eptr = p[dig];
+           } while (uv /= base);
+           if (alt) {
+               switch (c) {
+               case 'o':
+                   if (*eptr != 0)
+                       esignbuf[esignlen++] = '0';
+                   break;
+               case 'x':
+                   esignbuf[esignlen++] = '0';
+                   esignbuf[esignlen++] = 'x';
+                   break;
+               }
+           }
+           elen = (ebuf + sizeof ebuf) - eptr;
+           if (has_precis) {
+               left = FALSE;
+               fill = '0';
+               width = esignlen + precis;
+           }
+           break;
+
+           /* FLOATING POINT */
+
+       case 'e': case 'E':
+       case 'f': case 'F':
+       case 'g': case 'G':
+
+           /* This is evil, but floating point is even more evil */
+
+           need = width;
+           if (has_precis && need < precis)
+               need = precis;
+           need += 20; /* fudge factor */
+           if (efloatsize < need) {
+               Safefree(efloatbuf);
+               efloatsize = need + 20; /* more fudge */
+               New(906, efloatbuf, efloatsize, char);
+           }
+
+           eptr = ebuf + sizeof ebuf;
+           *--eptr = '\0';
+           *--eptr = c;
+           if (has_precis) {
+               base = precis;
+               do { *--eptr = '0' + (base % 10); } while (base /= 10);
+               *--eptr = '.';
+           }
+           if (width) {
+               base = width;
+               do { *--eptr = '0' + (base % 10); } while (base /= 10);
+           }
+           if (fill == '0')
+               *--eptr = fill;
+           if (plus)
+               *--eptr = plus;
+           if (alt)
+               *--eptr = '#';
+           *--eptr = '%';
+
+           if (args)
+               nv = va_arg(*args, double);
+           else
+               nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
+           (void)sprintf(efloatbuf, eptr, nv);
+
+           eptr = efloatbuf;
+           elen = strlen(efloatbuf);
+
+#ifdef LC_NUMERIC
+           /*
+            * User-defined locales may include arbitrary characters.
+            * And, unfortunately, some system may alloc the "C" locale
+            * to be overridden by a malicious user.
+            */
+           if (used_locale)
+               *used_locale = TRUE;
+#endif /* LC_NUMERIC */
+
+           break;
+
+       default:
+           /* output mangled stuff without comment */
+           eptr = p;
+           elen = q - p;
+           break;
+       }
+
+       have = esignlen + elen;
+       need = (have > width ? have : width);
+       gap = need - have;
+
+       SvGROW(sv, SvLEN(sv) + need);
+       p = SvEND(sv);
+       if (esignlen && fill == '0') {
+           for (i = 0; i < esignlen; i++)
+               *p++ = esignbuf[i];
+       }
+       if (gap && !left) {
+           memset(p, fill, gap);
+           p += gap;
+       }
+       if (esignlen && fill != '0') {
+           for (i = 0; i < esignlen; i++)
+               *p++ = esignbuf[i];
+       }
+       if (elen) {
+           memcpy(p, eptr, elen);
+           p += elen;
+       }
+       if (gap && left) {
+           memset(p, ' ', gap);
+           p += gap;
+       }
+       *p = '\0';
+       SvCUR(sv) = p - SvPVX(sv);
+    }
+}
+
 #ifdef DEBUGGING
 void
 sv_dump(sv)
 SV* sv;
 {
-    char tmpbuf[1024];
-    char *d = tmpbuf;
+    SV *d = sv_newmortal();
+    char *s;
     U32 flags;
     U32 type;
 
@@ -4063,126 +4545,122 @@ SV* sv;
     flags = SvFLAGS(sv);
     type = SvTYPE(sv);
 
-    sprintf(d, "(0x%lx)\n  REFCNT = %ld\n  FLAGS = (",
-       (unsigned long)SvANY(sv), (long)SvREFCNT(sv));
-    d += strlen(d);
-    if (flags & SVs_PADBUSY)   strcat(d, "PADBUSY,");
-    if (flags & SVs_PADTMP)    strcat(d, "PADTMP,");
-    if (flags & SVs_PADMY)     strcat(d, "PADMY,");
-    if (flags & SVs_TEMP)      strcat(d, "TEMP,");
-    if (flags & SVs_OBJECT)    strcat(d, "OBJECT,");
-    if (flags & SVs_GMG)       strcat(d, "GMG,");
-    if (flags & SVs_SMG)       strcat(d, "SMG,");
-    if (flags & SVs_RMG)       strcat(d, "RMG,");
-    d += strlen(d);
-
-    if (flags & SVf_IOK)       strcat(d, "IOK,");
-    if (flags & SVf_NOK)       strcat(d, "NOK,");
-    if (flags & SVf_POK)       strcat(d, "POK,");
-    if (flags & SVf_ROK)       strcat(d, "ROK,");
-    if (flags & SVf_OOK)       strcat(d, "OOK,");
-    if (flags & SVf_FAKE)      strcat(d, "FAKE,");
-    if (flags & SVf_READONLY)  strcat(d, "READONLY,");
-    d += strlen(d);
+    sv_setpvf(d, "(0x%lx)\n  REFCNT = %ld\n  FLAGS = (",
+             (unsigned long)SvANY(sv), (long)SvREFCNT(sv));
+    if (flags & SVs_PADBUSY)   sv_catpv(d, "PADBUSY,");
+    if (flags & SVs_PADTMP)    sv_catpv(d, "PADTMP,");
+    if (flags & SVs_PADMY)     sv_catpv(d, "PADMY,");
+    if (flags & SVs_TEMP)      sv_catpv(d, "TEMP,");
+    if (flags & SVs_OBJECT)    sv_catpv(d, "OBJECT,");
+    if (flags & SVs_GMG)       sv_catpv(d, "GMG,");
+    if (flags & SVs_SMG)       sv_catpv(d, "SMG,");
+    if (flags & SVs_RMG)       sv_catpv(d, "RMG,");
+
+    if (flags & SVf_IOK)       sv_catpv(d, "IOK,");
+    if (flags & SVf_NOK)       sv_catpv(d, "NOK,");
+    if (flags & SVf_POK)       sv_catpv(d, "POK,");
+    if (flags & SVf_ROK)       sv_catpv(d, "ROK,");
+    if (flags & SVf_OOK)       sv_catpv(d, "OOK,");
+    if (flags & SVf_FAKE)      sv_catpv(d, "FAKE,");
+    if (flags & SVf_READONLY)  sv_catpv(d, "READONLY,");
 
 #ifdef OVERLOAD
-    if (flags & SVf_AMAGIC)    strcat(d, "OVERLOAD,");
+    if (flags & SVf_AMAGIC)    sv_catpv(d, "OVERLOAD,");
 #endif /* OVERLOAD */
-    if (flags & SVp_IOK)       strcat(d, "pIOK,");
-    if (flags & SVp_NOK)       strcat(d, "pNOK,");
-    if (flags & SVp_POK)       strcat(d, "pPOK,");
-    if (flags & SVp_SCREAM)    strcat(d, "SCREAM,");
+    if (flags & SVp_IOK)       sv_catpv(d, "pIOK,");
+    if (flags & SVp_NOK)       sv_catpv(d, "pNOK,");
+    if (flags & SVp_POK)       sv_catpv(d, "pPOK,");
+    if (flags & SVp_SCREAM)    sv_catpv(d, "SCREAM,");
 
     switch (type) {
     case SVt_PVCV:
     case SVt_PVFM:
-      if (CvANON(sv))          strcat(d, "ANON,");
-      if (CvUNIQUE(sv))                strcat(d, "UNIQUE,");
-      if (CvCLONE(sv))         strcat(d, "CLONE,");
-      if (CvCLONED(sv))                strcat(d, "CLONED,");
-      if (CvNODEBUG(sv))       strcat(d, "NODEBUG,");
-      break;
+       if (CvANON(sv))         sv_catpv(d, "ANON,");
+       if (CvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
+       if (CvCLONE(sv))        sv_catpv(d, "CLONE,");
+       if (CvCLONED(sv))       sv_catpv(d, "CLONED,");
+       if (CvNODEBUG(sv))      sv_catpv(d, "NODEBUG,");
+       break;
     case SVt_PVHV:
-      if (HvSHAREKEYS(sv))     strcat(d, "SHAREKEYS,");
-      if (HvLAZYDEL(sv))       strcat(d, "LAZYDEL,");
-      break;
+       if (HvSHAREKEYS(sv))    sv_catpv(d, "SHAREKEYS,");
+       if (HvLAZYDEL(sv))      sv_catpv(d, "LAZYDEL,");
+       break;
     case SVt_PVGV:
-      if (GvINTRO(sv))         strcat(d, "INTRO,");
-      if (GvMULTI(sv))         strcat(d, "MULTI,");
-      if (GvASSUMECV(sv))      strcat(d, "ASSUMECV,");
-      if (GvIMPORTED(sv)) {
-         strcat(d, "IMPORT");
-         if (GvIMPORTED(sv) == GVf_IMPORTED)
-             strcat(d, "ALL,");
-         else {
-             strcat(d, "(");
-             if (GvIMPORTED_SV(sv))    strcat(d, " SV");
-             if (GvIMPORTED_AV(sv))    strcat(d, " AV");
-             if (GvIMPORTED_HV(sv))    strcat(d, " HV");
-             if (GvIMPORTED_CV(sv))    strcat(d, " CV");
-             strcat(d, " ),");
-         }
-      }
+       if (GvINTRO(sv))        sv_catpv(d, "INTRO,");
+       if (GvMULTI(sv))        sv_catpv(d, "MULTI,");
+       if (GvASSUMECV(sv))     sv_catpv(d, "ASSUMECV,");
+       if (GvIMPORTED(sv)) {
+           sv_catpv(d, "IMPORT");
+           if (GvIMPORTED(sv) == GVf_IMPORTED)
+               sv_catpv(d, "ALL,");
+           else {
+               sv_catpv(d, "(");
+               if (GvIMPORTED_SV(sv))  sv_catpv(d, " SV");
+               if (GvIMPORTED_AV(sv))  sv_catpv(d, " AV");
+               if (GvIMPORTED_HV(sv))  sv_catpv(d, " HV");
+               if (GvIMPORTED_CV(sv))  sv_catpv(d, " CV");
+               sv_catpv(d, " ),");
+           }
+       }
     }
 
-    d += strlen(d);
-    if (d[-1] == ',')
-       d--;
-    *d++ = ')';
-    *d = '\0';
+    if (*(SvEND(d) - 1) == ',')
+       SvPVX(d)[--SvCUR(d)] = '\0';
+    sv_catpv(d, ")");
+    s = SvPVX(d);
 
     PerlIO_printf(Perl_debug_log, "SV = ");
     switch (type) {
     case SVt_NULL:
-       PerlIO_printf(Perl_debug_log, "NULL%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "NULL%s\n", s);
        return;
     case SVt_IV:
-       PerlIO_printf(Perl_debug_log, "IV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "IV%s\n", s);
        break;
     case SVt_NV:
-       PerlIO_printf(Perl_debug_log, "NV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "NV%s\n", s);
        break;
     case SVt_RV:
-       PerlIO_printf(Perl_debug_log, "RV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "RV%s\n", s);
        break;
     case SVt_PV:
-       PerlIO_printf(Perl_debug_log, "PV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PV%s\n", s);
        break;
     case SVt_PVIV:
-       PerlIO_printf(Perl_debug_log, "PVIV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVIV%s\n", s);
        break;
     case SVt_PVNV:
-       PerlIO_printf(Perl_debug_log, "PVNV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVNV%s\n", s);
        break;
     case SVt_PVBM:
-       PerlIO_printf(Perl_debug_log, "PVBM%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVBM%s\n", s);
        break;
     case SVt_PVMG:
-       PerlIO_printf(Perl_debug_log, "PVMG%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVMG%s\n", s);
        break;
     case SVt_PVLV:
-       PerlIO_printf(Perl_debug_log, "PVLV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVLV%s\n", s);
        break;
     case SVt_PVAV:
-       PerlIO_printf(Perl_debug_log, "PVAV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVAV%s\n", s);
        break;
     case SVt_PVHV:
-       PerlIO_printf(Perl_debug_log, "PVHV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVHV%s\n", s);
        break;
     case SVt_PVCV:
-       PerlIO_printf(Perl_debug_log, "PVCV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVCV%s\n", s);
        break;
     case SVt_PVGV:
-       PerlIO_printf(Perl_debug_log, "PVGV%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVGV%s\n", s);
        break;
     case SVt_PVFM:
-       PerlIO_printf(Perl_debug_log, "PVFM%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVFM%s\n", s);
        break;
     case SVt_PVIO:
-       PerlIO_printf(Perl_debug_log, "PVIO%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "PVIO%s\n", s);
        break;
     default:
-       PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", tmpbuf);
+       PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", s);
        return;
     }
     if (type >= SVt_PVIV || type == SVt_IV)
@@ -4227,14 +4705,12 @@ SV* sv;
        PerlIO_printf(Perl_debug_log, "  MAX = %ld\n", (long)AvMAX(sv));
        PerlIO_printf(Perl_debug_log, "  ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
        flags = AvFLAGS(sv);
-       d = tmpbuf;
-       *d = '\0';
-       if (flags & AVf_REAL)   strcat(d, "REAL,");
-       if (flags & AVf_REIFY)  strcat(d, "REIFY,");
-       if (flags & AVf_REUSED) strcat(d, "REUSED,");
-       if (*d)
-           d[strlen(d)-1] = '\0';
-       PerlIO_printf(Perl_debug_log, "  FLAGS = (%s)\n", d);
+       sv_setpv(d, "");
+       if (flags & AVf_REAL)   sv_catpv(d, ",REAL");
+       if (flags & AVf_REIFY)  sv_catpv(d, ",REIFY");
+       if (flags & AVf_REUSED) sv_catpv(d, ",REUSED");
+       PerlIO_printf(Perl_debug_log, "  FLAGS = (%s)\n",
+                     SvCUR(d) ? SvPVX(d) + 1 : "");
        break;
     case SVt_PVHV:
        PerlIO_printf(Perl_debug_log, "  ARRAY = 0x%lx\n",(long)HvARRAY(sv));
index 1a5afe5..660049b 100755 (executable)
@@ -196,6 +196,11 @@ BEGIN failed--compilation aborted at - line 1.
         shift;
         print join(' ', reverse @_)."\n";
     }
+    sub PRINTF {
+        shift;
+         my $fmt = shift;
+        print sprintf($fmt, @_)."\n";
+    }
     sub TIEHANDLE {
         bless {}, shift;
     }
@@ -226,12 +231,14 @@ BEGIN failed--compilation aborted at - line 1.
     $len = 10; $offset = 1;
     read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed";
     getc(FOO) eq "a" or die "foo->GETC failed";
+    printf "%s is number %d\n", "Perl", 1;
 }
 EXPECT
 This is a reversed sentence.
 -- Out of inspiration --
 foo->can(READ)(string 10 1)
 Don't GETC, Get Perl
+Perl is number 1
 and destroyed as well
 ########
 my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
diff --git a/toke.c b/toke.c
index c24c45c..56e2fac 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -163,13 +163,9 @@ char *s;
 {
     char *oldbp = bufptr;
     bool is_first = (oldbufptr == linestart);
-    char *msg;
 
     bufptr = s;
-    New(890, msg, strlen(what) + 40, char);
-    sprintf(msg, "%s found where operator expected", what);
-    yywarn(msg);
-    Safefree(msg);
+    yywarn(form("%s found where operator expected", what));
     if (is_first)
        warn("\t(Missing semicolon on previous line?)\n");
     else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
@@ -1272,12 +1268,9 @@ yylex()
        /* Force them to make up their mind on "@foo". */
        if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
            GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
-           if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) {
-               char tmpbuf[1024];
-               sprintf(tmpbuf, "In string, %s now must be written as \\%s",
-                       tokenbuf, tokenbuf);
-               yyerror(tmpbuf);
-           }
+           if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
+               yyerror(form("In string, %s now must be written as \\%s",
+                            tokenbuf, tokenbuf));
        }
 
        yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
@@ -1506,28 +1499,23 @@ yylex()
                    if (gv)
                        GvIMPORTED_AV_on(gv);
                    if (minus_F) {
-                       char *tmpbuf1;
-                       New(201, tmpbuf1, strlen(splitstr) * 2 + 20, char);
                        if (strchr("/'\"", *splitstr)
                              && strchr(splitstr + 1, *splitstr))
-                           sprintf(tmpbuf1, "@F=split(%s);", splitstr);
+                           sv_catpvf(linestr, "@F=split(%s);", splitstr);
                        else {
                            char delim;
                            s = "'~#\200\1'"; /* surely one char is unused...*/
                            while (s[1] && strchr(splitstr, *s))  s++;
                            delim = *s;
-                           sprintf(tmpbuf1, "@F=split(%s%c",
-                                   "q" + (delim == '\''), delim);
-                           d = tmpbuf1 + strlen(tmpbuf1);
-                           for (s = splitstr; *s; ) {
+                           sv_catpvf(linestr, "@F=split(%s%c",
+                                     "q" + (delim == '\''), delim);
+                           for (s = splitstr; *s; s++) {
                                if (*s == '\\')
-                                   *d++ = '\\';
-                               *d++ = *s++;
+                                   sv_catpvn(linestr, "\\", 1);
+                               sv_catpvn(linestr, s, 1);
                            }
-                           sprintf(d, "%c);", delim);
+                           sv_catpvf(linestr, "%c);", delim);
                        }
-                       sv_catpv(linestr,tmpbuf1);
-                       Safefree(tmpbuf1);
                    }
                    else
                        sv_catpv(linestr,"@F=split(' ');");
@@ -2618,13 +2606,14 @@ yylex()
                /* Not a method, so call it a subroutine (if defined) */
 
                if (gv && GvCVu(gv)) {
-                   CV* cv = GvCV(gv);
+                   CV* cv;
                    if (lastchar == '-')
                        warn("Ambiguous use of -%s resolved as -&%s()",
                                tokenbuf, tokenbuf);
                    last_lop = oldbufptr;
                    last_lop_op = OP_ENTERSUB;
                    /* Check for a constant sub */
+                   cv = GvCV(gv);
                    if ((sv = cv_const_sv(cv))) {
                  its_constant:
                        SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
@@ -2689,12 +2678,13 @@ yylex()
            }
 
        case KEY___FILE__:
+           yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+                                       newSVsv(GvSV(curcop->cop_filegv)));
+           TERM(THING);
+
        case KEY___LINE__:
-           if (tokenbuf[2] == 'L')
-               (void)sprintf(tokenbuf,"%ld",(long)curcop->cop_line);
-           else
-               strcpy(tokenbuf, SvPVX(GvSV(curcop->cop_filegv)));
-           yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
+           yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+                                   newSVpvf("%ld", (long)curcop->cop_line));
            TERM(THING);
 
        case KEY___PACKAGE__:
@@ -2710,12 +2700,10 @@ yylex()
 
            /*SUPPRESS 560*/
            if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
-               char dname[256];
                char *pname = "main";
                if (tokenbuf[2] == 'D')
                    pname = HvNAME(curstash ? curstash : defstash);
-               sprintf(dname,"%s::DATA", pname);
-               gv = gv_fetchpv(dname,TRUE, SVt_PVIO);
+               gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
                GvMULTI_on(gv);
                if (!GvIO(gv))
                    GvIOp(gv) = newIO();
@@ -5224,10 +5212,10 @@ int
 yyerror(s)
 char *s;
 {
-    char wbuf[40];
     char *where = NULL;
     char *context = NULL;
     int contlen = -1;
+    SV *msg;
 
     if (!yychar || (yychar == ';' && !rsfp))
        where = "at EOF";
@@ -5256,35 +5244,37 @@ char *s;
        else
            where = "within string";
     }
-    else if (yychar < 32)
-       (void)sprintf(where = wbuf, "next char ^%c", toCTRL(yychar));
-    else if (isPRINT_LC(yychar))
-       (void)sprintf(where = wbuf, "next char %c", yychar);
-    else
-       (void)sprintf(where = wbuf, "next char \\%03o", yychar & 255);
-    if (contlen == -1)
-       contlen = strlen(where);
-    (void)sprintf(buf, "%s at %s line %d, ",
-                 s, SvPVX(GvSV(curcop->cop_filegv)), curcop->cop_line);
+    else {
+       SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
+       if (yychar < 32)
+           sv_catpvf(where_sv, "^%c", toCTRL(yychar));
+       else if (isPRINT_LC(yychar))
+           sv_catpvf(where_sv, "%c", yychar);
+       else
+           sv_catpvf(where_sv, "\\%03o", yychar & 255);
+       where = SvPVX(where_sv);
+    }
+    msg = sv_2mortal(newSVpv(s, 0));
+    sv_catpvf(msg, " at %S line %ld, ",
+             GvSV(curcop->cop_filegv), (long)curcop->cop_line);
     if (context)
-       (void)sprintf(buf+strlen(buf), "near \"%.*s\"\n", contlen, context);
+       sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
     else
-       (void)sprintf(buf+strlen(buf), "%s\n", where);
+       sv_catpvf(msg, "%s\n", where);
     if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
-       sprintf(buf+strlen(buf),
+       sv_catpvf(msg,
        "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
                (int)multi_open,(int)multi_close,(long)multi_start);
         multi_end = 0;
     }
     if (in_eval & 2)
-       warn("%s",buf);
+       warn("%S", msg);
     else if (in_eval)
-       sv_catpv(GvSV(errgv),buf);
+       sv_catsv(GvSV(errgv), msg);
     else
-       PerlIO_printf(PerlIO_stderr(), "%s",buf);
+       PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
     if (++error_count >= 10)
-       croak("%s has too many errors.\n",
-       SvPVX(GvSV(curcop->cop_filegv)));
+       croak("%S has too many errors.\n", GvSV(curcop->cop_filegv));
     in_my = 0;
     return 0;
 }
diff --git a/util.c b/util.c
index fbed244..84670ba 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1073,77 +1073,73 @@ register I32 len;
 
 #ifdef I_STDARG
 char *
-mess(const char *pat, va_list *args)
+form(const char* pat, ...)
 #else
 /*VARARGS0*/
 char *
-mess(pat, args)
+form(pat, va_alist)
     const char *pat;
-    va_list *args;
+    va_dcl
 #endif
 {
-    char *s;
-    char *s_start;
-    SV *tmpstr;
-    I32 usermess;
-#ifndef HAS_VPRINTF
-#ifdef USE_CHAR_VSPRINTF
-    char *vsprintf();
+    va_list args;
+#ifdef I_STDARG
+    va_start(args, pat);
 #else
-    I32 vsprintf();
-#endif
+    va_start(args);
 #endif
-
-    s = s_start = buf;
-    usermess = strEQ(pat, "%s");
-    if (usermess) {
-       tmpstr = sv_newmortal();
-       sv_setpv(tmpstr, va_arg(*args, char *));
-       *s++ = SvCUR(tmpstr) ? SvPVX(tmpstr)[SvCUR(tmpstr)-1] : ' ';
+    if (mess_sv == &sv_undef) {
+       /* All late-destruction message must be short */
+       vsprintf(tokenbuf, pat, args);
     }
     else {
-       (void) vsprintf(s,pat,*args);
-       s += strlen(s);
+       if (!mess_sv)
+           mess_sv = NEWSV(905, 0);
+       sv_vsetpvfn(mess_sv, pat, strlen(pat), &args,
+                   Null(SV**), 0, Null(bool));
     }
-    va_end(*args);
+    va_end(args);
+    return (mess_sv == &sv_undef) ? tokenbuf : SvPVX(mess_sv);
+}
 
-    if (!(s > s_start && s[-1] == '\n')) {
+char *
+mess(pat, args)
+    const char *pat;
+    va_list *args;
+{
+    SV *sv;
+    static char dgd[] = " during global destruction.\n";
+
+    if (mess_sv == &sv_undef) {
+       /* All late-destruction message must be short */
+       vsprintf(tokenbuf, pat, *args);
+       if (!tokenbuf[0] && tokenbuf[strlen(tokenbuf) - 1] != '\n')
+           strcat(tokenbuf, dgd);
+       return tokenbuf;
+    }
+    if (!mess_sv)
+       mess_sv = NEWSV(905, 0);
+    sv = mess_sv;
+    sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool));
+    if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
        if (dirty)
-           strcpy(s, " during global destruction.\n");
+           sv_catpv(sv, dgd);
        else {
-           if (curcop->cop_line) {
-               (void)sprintf(s," at %s line %ld",
-                 SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
-               s += strlen(s);
-           }
+           if (curcop->cop_line)
+               sv_catpvf(sv, " at %S line %ld",
+                         GvSV(curcop->cop_filegv), (long)curcop->cop_line);
            if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
                bool line_mode = (RsSIMPLE(rs) &&
                                  SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
-               (void)sprintf(s,", <%s> %s %ld",
-                 last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
-                 line_mode ? "line" : "chunk", 
-                 (long)IoLINES(GvIOp(last_in_gv)));
-               s += strlen(s);
+               sv_catpvf(sv, ", <%s> %s %ld",
+                         last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
+                         line_mode ? "line" : "chunk", 
+                         (long)IoLINES(GvIOp(last_in_gv)));
            }
-           (void)strcpy(s,".\n");
-           s += 2;
+           sv_catpv(sv, ".\n");
        }
-       if (usermess)
-           sv_catpv(tmpstr,buf+1);
     }
-
-    if (s - s_start >= sizeof(buf)) {  /* Ooops! */
-       if (usermess)
-           PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
-       else
-           PerlIO_puts(PerlIO_stderr(), buf);
-       PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n");
-       my_exit(1);
-    }
-    if (usermess)
-       return SvPVX(tmpstr);
-    else
-       return buf;
+    return SvPVX(sv);
 }
 
 #ifdef I_STDARG
@@ -1971,7 +1967,7 @@ int flags;
 {
     SV *sv;
     SV** svp;
-    char spid[16];
+    char spid[sizeof(int) * 3 + 1];
 
     if (!pid)
        return -1;
@@ -2027,7 +2023,7 @@ int pid;
 int status;
 {
     register SV *sv;
-    char spid[16];
+    char spid[sizeof(int) * 3 + 1];
 
     sprintf(spid, "%d", pid);
     sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
@@ -2165,10 +2161,7 @@ char *b;
     char *fb = strrchr(b,'/');
     struct stat tmpstatbuf1;
     struct stat tmpstatbuf2;
-#ifndef MAXPATHLEN
-#define MAXPATHLEN 1024
-#endif
-    char tmpbuf[MAXPATHLEN+1];
+    SV *tmpsv = sv_newmortal();
 
     if (fa)
        fa++;
@@ -2181,16 +2174,16 @@ char *b;
     if (strNE(a,b))
        return FALSE;
     if (fa == a)
-       strcpy(tmpbuf,".");
+       sv_setpv(tmpsv, ".");
     else
-       strncpy(tmpbuf, a, fa - a);
-    if (Stat(tmpbuf, &tmpstatbuf1) < 0)
+       sv_setpvn(tmpsv, a, fa - a);
+    if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
        return FALSE;
     if (fb == b)
-       strcpy(tmpbuf,".");
+       sv_setpv(tmpsv, ".");
     else
-       strncpy(tmpbuf, b, fb - b);
-    if (Stat(tmpbuf, &tmpstatbuf2) < 0)
+       sv_setpvn(tmpsv, b, fb - b);
+    if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
        return FALSE;
     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
           tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;