summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>1997-04-25 00:00:00 +1200
committerChip Salzenberg <chip@atlantic.net>1997-04-25 00:00:00 +1200
commitfc36a67e8855d031b2a6921819d899eb149eee2d (patch)
tree7e927725470a83d271eae7d78123f60cb86e60df
parent74a7701791a30556a92328b89e5a00414a4ce4a3 (diff)
downloadperl-fc36a67e8855d031b2a6921819d899eb149eee2d.tar.gz
[inseparable changes from match from perl-5.003_97h to perl-5.003_97i]
CORE PORTABILITY Subject: Provide memset() if it's missing From: Chip Salzenberg <chip@perl.com> Files: global.sym perl.h proto.h util.c Subject: Don't tell GCC that warn(), croak(), and die() are printf-lik From: Chip Salzenberg <chip@perl.com> Files: proto.h DOCUMENTATION Subject: FAQ udpate (24-apr-97) Date: Thu, 24 Apr 1997 16:47:23 -0600 (MDT) From: Nathan Torkington <gnat@prometheus.frii.com> Files: pod/perlfaq*.pod private-msgid: 199704242247.QAA07010@prometheus.frii.com OTHER CORE CHANGES Subject: Misc. sv_vcatpvfn() fixes From: Hugo van der Sanden <hv@crypt.compulink.co.uk> Files: gv.c mg.c op.c perl.c pp.c pp_ctl.c sv.c toke.c util.c Subject: Enforce order of sprintf() elements From: Chip Salzenberg <chip@perl.com> Files: sv.c Subject: Guard against long numbers, <<LONG_DELIM, and <long glob> From: Chip Salzenberg <chip@perl.com> Files: global.sym mg.c perl.c pod/perldiag.pod proto.h toke.c util.c Subject: Guard against C<goto> to deeply nested label From: Chip Salzenberg <chip@perl.com> Files: pod/perldiag.pod pp_ctl.c Subject: Guard against overflow in dup2() emulation From: Chip Salzenberg <chip@perl.com> Files: util.c Subject: Win32: Guard against long function names From: Chip Salzenberg <chip@perl.com> Files: win32/win32sck.c Subject: Make mess() always work, by using a non-arena SV From: Chip Salzenberg <chip@perl.com> Files: perl.c util.c Subject: When copying a format line, take only its string value From: Chip Salzenberg <chip@perl.com> Files: sv.c Subject: Fix LEAKTEST numbers From: Chip Salzenberg <chip@perl.com> Files: ext/DynaLoader/dl_vms.xs handy.h os2/os2.c util.c vms/vms.c win32/win32.c win32/win32sck.c
Diffstat
-rw-r--r--Changes122
-rw-r--r--embed.h3
-rw-r--r--ext/DynaLoader/dl_vms.xs2
-rw-r--r--global.sym3
-rw-r--r--gv.c20
-rw-r--r--handy.h6
-rw-r--r--mg.c12
-rw-r--r--op.c6
-rw-r--r--os2/os2.c12
-rw-r--r--patchlevel.h2
-rw-r--r--perl.c93
-rw-r--r--perl.h21
-rw-r--r--pod/perldiag.pod31
-rw-r--r--pod/perlfaq.pod7
-rw-r--r--pod/perlfaq1.pod13
-rw-r--r--pod/perlfaq3.pod8
-rw-r--r--pod/perlfaq4.pod5
-rw-r--r--pod/perlfaq5.pod5
-rw-r--r--pod/perlfaq6.pod32
-rw-r--r--pod/perlfaq7.pod6
-rw-r--r--pod/perlfaq8.pod389
-rw-r--r--pod/perltoc.pod97
-rw-r--r--pp.c2
-rw-r--r--pp_ctl.c40
-rw-r--r--proto.h13
-rw-r--r--sv.c288
-rw-r--r--toke.c65
-rw-r--r--util.c105
-rw-r--r--vms/vms.c44
-rw-r--r--win32/win32.c10
-rw-r--r--win32/win32sck.c9
31 files changed, 1120 insertions, 351 deletions
diff --git a/Changes b/Changes
index 075fa394fc..ab86e2191a 100644
--- a/Changes
+++ b/Changes
@@ -46,6 +46,128 @@ And the Keepers of the Patch Pumpkin:
-----------------
+Version 5.003_97i
+-----------------
+
+This patch eliminates all known sources of buffer overflow! (And the
+crowd goes wild. (Yeah.)) Showstoppers only between here and _98.
+
+ CORE LANGUAGE CHANGES
+
+ (no changes)
+
+ CORE PORTABILITY
+
+ Title: "Provide memset() if it's missing"
+ From: Chip Salzenberg
+ Files: global.sym perl.h proto.h util.c
+
+ Title: "Don't tell GCC that warn(), croak(), and die() are printf-lik
+ From: Chip Salzenberg
+ Files: proto.h
+
+ OTHER CORE CHANGES
+
+ Title: "Misc. sv_vcatpvfn() fixes"
+ From: Hugo, Dale, Nick, Hallvard, Chip
+ Files: gv.c mg.c op.c perl.c pp.c pp_ctl.c sv.c toke.c util.c
+
+ Title: "Enforce order of sprintf() elements"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ Title: "Guard against long numbers, <<LONG_DELIM, and <long glob>"
+ From: Chip Salzenberg
+ Files: global.sym mg.c perl.c pod/perldiag.pod proto.h toke.c util.c
+
+ Title: "Guard against C<goto> to deeply nested label"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod pp_ctl.c
+
+ Title: "Guard against overflow in dup2() emulation"
+ From: Chip Salzenberg
+ Files: util.c
+
+ Title: "Win32: Guard against long function names"
+ From: Chip Salzenberg
+ Files: win32/win32sck.c
+
+ Title: "Make mess() always work, by using a non-arena SV"
+ From: Chip Salzenberg, from idea by Gurusamy Sarathy
+ Files: perl.c util.c
+
+ Title: "Fix scalar leak in pp_prtf()"
+ From: Doug MacEachern
+ Msg-ID: <199704241706.NAA19140@postman.osf.org>
+ Date: Thu, 24 Apr 1997 13:06:21 -0400
+ Files: pp_sys.c
+
+ Title: "When copying a format line, take only its string value"
+ From: Chip Salzenberg
+ Files: sv.c
+
+ Title: "Undo private patch"
+ From: Chip Salzenberg
+ Files: installperl lib/ExtUtils/Install.pm
+
+ Title: "Fix LEAKTEST numbers"
+ From: Chip Salzenberg
+ Files: ext/DynaLoader/dl_vms.xs handy.h os2/os2.c util.c vms/vms.c
+ win32/win32.c win32/win32sck.c
+
+ BUILD PROCESS
+
+ Title: "Cope with a <db.h> that isn't related to DB"
+ From: Jarkko Hietaniemi
+ Msg-ID: <199704241728.UAA09951@alpha.hut.fi>
+ Date: Thu, 24 Apr 1997 20:28:39 +0300 (EET DST)
+ Files: Configure
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Always NUL-terminate opsets"
+ From: Chip Salzenberg
+ Files: ext/Opcode/Opcode.xs
+
+ Title: "Don't core dump if my_inet_aton() get a NULL"
+ From: Chip Salzenberg
+ Files: ext/Socket/Socket.xs
+
+ Title: "Handle symlinks, high permission bits in File::Path"
+ From: Chip Salzenberg
+ Files: lib/File/Path.pm
+
+ Title: "Math::{Complex,Trig} update"
+ From: Gurusamy Sarathy
+ Msg-ID: <199704242221.BAA30363@alpha.hut.fi>
+ Date: Fri, 25 Apr 1997 01:21:44 +0300 (EET DST)
+ Files: lib/Math/Complex.pm lib/Math/Trig.pm pod/roffitall
+ t/lib/complex.t t/lib/trig.t
+
+ TESTS
+
+ (no other changes)
+
+ UTILITIES
+
+ Title: "Fix buffer overflow in a2p"
+ From: Chip Salzenberg
+ Files: x2p/a2py.c
+
+ DOCUMENTATION
+
+ Title: "FAQ udpate (24-apr-97)"
+ From: Nathan Torkington <gnat@prometheus.frii.com>
+ Msg-ID: <199704242247.QAA07010@prometheus.frii.com>
+ Date: Thu, 24 Apr 1997 16:47:23 -0600 (MDT)
+ Files: pod/perlfaq*.pod
+
+ Title: "Document new {,s}printf() behavior"
+ From: Chip Salzenberg
+ Files: pod/perldelta.pod pod/perlfunc.pod
+
+
+-----------------
Version 5.003_97h
-----------------
diff --git a/embed.h b/embed.h
index 474f7e1ac4..7246cf21b2 100644
--- a/embed.h
+++ b/embed.h
@@ -117,7 +117,6 @@
#define convert Perl_convert
#define cop_seqmax Perl_cop_seqmax
#define cos_amg Perl_cos_amg
-#define cpytill Perl_cpytill
#define croak Perl_croak
#define cryptseen Perl_cryptseen
#define cshlen Perl_cshlen
@@ -138,6 +137,7 @@
#define debstack Perl_debstack
#define debstackptrs Perl_debstackptrs
#define dec_amg Perl_dec_amg
+#define delimcpy Perl_delimcpy
#define deprecate Perl_deprecate
#define di Perl_di
#define die Perl_die
@@ -383,6 +383,7 @@
#define my_htonl Perl_my_htonl
#define my_lstat Perl_my_lstat
#define my_memcmp Perl_my_memcmp
+#define my_memset Perl_my_memset
#define my_ntohl Perl_my_ntohl
#define my_pclose Perl_my_pclose
#define my_popen Perl_my_popen
diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs
index 370994b516..0329ebd9cb 100644
--- a/ext/DynaLoader/dl_vms.xs
+++ b/ext/DynaLoader/dl_vms.xs
@@ -249,7 +249,7 @@ dl_load_file(filespec, flags)
specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer);
DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n",
specdsc.dsc$a_pointer));
- New(7901,dlptr,1,struct libref);
+ New(1399,dlptr,1,struct libref);
dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T;
dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S;
sts = sys$filescan(&specdsc,namlst,0);
diff --git a/global.sym b/global.sym
index 781d179c2b..49d6df08a4 100644
--- a/global.sym
+++ b/global.sym
@@ -360,7 +360,6 @@ ck_subr
ck_svconst
ck_trunc
convert
-cpytill
croak
cv_ckproto
cv_clone
@@ -374,6 +373,7 @@ debop
debprofdump
debstack
debstackptrs
+delimcpy
deprecate
die
die_where
@@ -555,6 +555,7 @@ my_failure_exit
my_htonl
my_lstat
my_memcmp
+my_memset
my_ntohl
my_pclose
my_popen
diff --git a/gv.c b/gv.c
index a18304e5f3..6c912a0e9b 100644
--- a/gv.c
+++ b/gv.c
@@ -275,8 +275,8 @@ I32 autoload;
--nsplit;
if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
/* ->SUPER::method should really be looked up in original stash */
- SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash), 0));
- sv_catpvn(tmpstr, "::SUPER", 7);
+ SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER",
+ HvNAME(curcop->cop_stash)));
stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
DEBUG_o( deb("Treating %s as %s::%s\n",
origname, HvNAME(stash), name) );
@@ -1179,13 +1179,11 @@ int flags;
case copy_amg:
{
SV* ref=SvRV(left);
- if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { /* Just to be
- * extra
- * causious,
- * maybe in some
- * additional
- * cases sv_setsv
- * is safe too */
+ if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) {
+ /*
+ * Just to be extra cautious. Maybe in some
+ * additional cases sv_setsv is safe, too.
+ */
SV* newref = newSVsv(ref);
SvOBJECT_on(newref);
SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
@@ -1242,7 +1240,7 @@ int flags;
&& !(flags & AMGf_unary)) {
/* We look for substitution for
* comparison operations and
- * concatendation */
+ * concatenation */
if (method==concat_amg || method==concat_ass_amg
|| method==repeat_amg || method==repeat_ass_amg) {
return NULL; /* Delegate operation to string conversion */
@@ -1298,7 +1296,7 @@ int flags;
if (amtp && amtp->fallback >= AMGfallYES) {
DEBUG_o( deb("%s", SvPVX(msg)) );
} else {
- croak("%S", msg);
+ croak("%_", msg);
}
return NULL;
}
diff --git a/handy.h b/handy.h
index 257c52a2fb..379fab8b04 100644
--- a/handy.h
+++ b/handy.h
@@ -130,6 +130,10 @@ typedef unsigned short U16;
# define U32_MIN PERL_ULONG_MIN
#endif
+#define BIT_DIGITS(N) (((N)*146)/485 + 1) /* log2(10) =~ 146/485 */
+#define TYPE_DIGITS(T) BIT_DIGITS(sizeof(T) * 8)
+#define TYPE_CHARS(T) (TYPE_DIGITS(T) + 2) /* sign, NUL */
+
#define Ctl(ch) ((ch) & 037)
#define strNE(s1,s2) (strcmp(s1,s2))
@@ -277,7 +281,7 @@ typedef U16 line_t;
#define Safefree(d) safexfree((Malloc_t)d)
#define NEWSV(x,len) newSV(x,len)
-#define MAXXCOUNT 1200
+#define MAXXCOUNT 1400
long xcount[MAXXCOUNT];
long lastxcount[MAXXCOUNT];
diff --git a/mg.c b/mg.c
index 7d8cd046f8..cab0e5973e 100644
--- a/mg.c
+++ b/mg.c
@@ -531,18 +531,18 @@ MAGIC *mg;
break;
case '(':
sv_setiv(sv, (IV)gid);
- sv_setpvf(sv, "%vd", (IV)gid);
+ sv_setpvf(sv, "%Vd", (IV)gid);
goto add_groups;
case ')':
sv_setiv(sv, (IV)egid);
- sv_setpvf(sv, "%vd", (IV)egid);
+ sv_setpvf(sv, "%Vd", (IV)egid);
add_groups:
#ifdef HAS_GETGROUPS
{
Groups_t gary[NGROUPS];
i = getgroups(NGROUPS,gary);
while (--i >= 0)
- sv_catpvf(sv, " %vd", (IV)gary[i]);
+ sv_catpvf(sv, " %Vd", (IV)gary[i]);
}
#endif
SvIOK_on(sv); /* what a wonderful hack! */
@@ -627,9 +627,11 @@ MAGIC* mg;
while (s < strend) {
struct stat st;
- s = cpytill(tokenbuf, s, strend, ':', &i);
+ s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf,
+ s, strend, ':', &i);
s++;
- if (*tokenbuf != '/'
+ if (i >= sizeof tokenbuf /* too long -- assume the worst */
+ || *tokenbuf != '/'
|| (Stat(tokenbuf, &st) == 0 && (st.st_mode & 2)) ) {
MgTAINTEDDIR_on(mg);
return 0;
diff --git a/op.c b/op.c
index 747ae0ffcb..cf78f866b5 100644
--- a/op.c
+++ b/op.c
@@ -3153,7 +3153,7 @@ char* p;
gv_efullname3(name = sv_newmortal(), gv, Nullch);
sv_setpv(msg, "Prototype mismatch:");
if (name)
- sv_catpvf(msg, " sub %S", name);
+ sv_catpvf(msg, " sub %_", name);
if (SvPOK(cv))
sv_catpvf(msg, " (%s)", SvPVX(cv));
sv_catpv(msg, " vs ");
@@ -3161,7 +3161,7 @@ char* p;
sv_catpvf(msg, "(%s)", p);
else
sv_catpv(msg, "none");
- warn("%S", msg);
+ warn("%_", msg);
}
}
@@ -3348,7 +3348,7 @@ OP *block;
CV *cv;
HV *hv;
- sv_setpvf(sv, "%S:%ld-%ld",
+ sv_setpvf(sv, "%_:%ld-%ld",
GvSV(curcop->cop_filegv),
(long)subline, (long)curcop->cop_line);
gv_efullname3(tmpstr, gv, Nullch);
diff --git a/os2/os2.c b/os2/os2.c
index 1eca62f8a1..b658ea8690 100644
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -55,7 +55,7 @@ get_sysinfo(ULONG pid, ULONG flags)
char *pbuffer;
ULONG rc, buf_len = QSS_INI_BUFFER;
- New(1022, pbuffer, buf_len, char);
+ New(1322, pbuffer, buf_len, char);
/* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
rc = QuerySysState(flags, pid, pbuffer, buf_len);
while (rc == ERROR_BUFFER_OVERFLOW) {
@@ -208,7 +208,7 @@ register SV **sp;
int flag = P_WAIT, trueflag, err, secondtry = 0;
if (sp > mark) {
- New(401,Argv, sp - mark + 3, char*);
+ New(1301,Argv, sp - mark + 3, char*);
a = Argv;
if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
@@ -321,7 +321,7 @@ int execf;
if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
STRLEN l = strlen(sh_path);
- New(4545, news, strlen(cmd) - 7 + l, char);
+ New(1302, news, strlen(cmd) - 7 + l, char);
strcpy(news, sh_path);
strcpy(news + l, cmd + 7);
cmd = news;
@@ -367,7 +367,7 @@ int execf;
}
}
- New(402,Argv, (s - cmd) / 2 + 2, char*);
+ New(1303,Argv, (s - cmd) / 2 + 2, char*);
Cmd = savepvn(cmd, s-cmd);
a = Argv;
for (s = Cmd; *s;) {
@@ -1149,7 +1149,7 @@ Perl_OS2_init(char **env)
environ = env;
}
if ( (shell = getenv("PERL_SH_DRIVE")) ) {
- New(404, sh_path, strlen(SH_PATH) + 1, char);
+ New(1304, sh_path, strlen(SH_PATH) + 1, char);
strcpy(sh_path, SH_PATH);
sh_path[0] = shell[0];
} else if ( (shell = getenv("PERL_SH_DIR")) ) {
@@ -1157,7 +1157,7 @@ Perl_OS2_init(char **env)
if (shell[l-1] == '/' || shell[l-1] == '\\') {
l--;
}
- New(404, sh_path, l + 8, char);
+ New(1304, sh_path, l + 8, char);
strncpy(sh_path, shell, l);
strcpy(sh_path + l, "/sh.exe");
for (i = 0; i < l; i++) {
diff --git a/patchlevel.h b/patchlevel.h
index e517f7a467..38de8545b3 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -38,7 +38,7 @@
*/
static char *local_patches[] = {
NULL
- ,"Dev97A-H - Eight development patches to 5.003_97"
+ ,"Dev97A-I - Nine development patches to 5.003_97"
,NULL
};
diff --git a/perl.c b/perl.c
index b4d69cb80c..8af7172d16 100644
--- a/perl.c
+++ b/perl.c
@@ -377,11 +377,6 @@ 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 */
@@ -433,9 +428,20 @@ register PerlInterpreter *sv_interp;
if (origfilename)
Safefree(origfilename);
nuke_stacks();
- hints = 0; /* Reset hints. Should hints be per-interpreter ? */
+ hints = 0; /* Reset hints. Should hints be per-interpreter ? */
DEBUG_P(debprofdump());
+
+ /* As the absolutely last thing, free the non-arena SV for mess() */
+
+ if (mess_sv) {
+ /* we know that type >= SVt_PV */
+ SvOOK_off(mess_sv);
+ Safefree(SvPVX(mess_sv));
+ Safefree(SvANY(mess_sv));
+ Safefree(mess_sv);
+ mess_sv = Nullsv;
+ }
}
void
@@ -1614,15 +1620,19 @@ SV *sv;
I32 len;
int retval;
#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
-#define SEARCH_EXTS ".bat", ".cmd", NULL
+# define SEARCH_EXTS ".bat", ".cmd", NULL
+# define MAX_EXT_LEN 4
#endif
#ifdef VMS
# define SEARCH_EXTS ".pl", ".com", NULL
+# define MAX_EXT_LEN 4
#endif
/* additional extensions to try in each dir if scriptname not found */
#ifdef SEARCH_EXTS
char *ext[] = { SEARCH_EXTS };
int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
+#else
+# define MAX_EXT_LEN 0
#endif
#ifdef VMS
@@ -1632,38 +1642,51 @@ SV *sv;
hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
/* The first time through, just add SEARCH_EXTS to whatever we
* already have, so we can check for default file types. */
- while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
- if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
- strcat(tokenbuf,scriptname);
+ while (deftypes ||
+ (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
+ {
+ if (deftypes) {
+ deftypes = 0;
+ *tokenbuf = '\0';
+ }
+ if ((strlen(tokenbuf) + strlen(scriptname)
+ + MAX_EXT_LEN) >= sizeof tokenbuf)
+ continue; /* don't search dir with too-long name */
+ strcat(tokenbuf, scriptname);
#else /* !VMS */
if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
-
bufend = s + strlen(s);
- while (*s) {
-#ifndef DOSISH
- s = cpytill(tokenbuf,s,bufend,':',&len);
+ while (s < bufend) {
+#ifndef atarist
+ s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
+#ifdef DOSISH
+ ';',
#else
-#ifdef atarist
- for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
- tokenbuf[len] = '\0';
-#else
- for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
- tokenbuf[len] = '\0';
-#endif
+ ':',
#endif
- if (*s)
+ &len);
+#else /* atarist */
+ for (len = 0; *s && *s != ',' && *s != ';'; len++, s++) {
+ if (len < sizeof tokenbuf)
+ tokenbuf[len] = *s;
+ }
+ if (len < sizeof tokenbuf)
+ tokenbuf[len] = '\0';
+#endif /* atarist */
+ if (s < bufend)
s++;
-#ifndef DOSISH
- if (len && tokenbuf[len-1] != '/')
-#else
-#ifdef atarist
- if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
-#else
- if (len && tokenbuf[len-1] != '\\')
-#endif
-#endif
- (void)strcat(tokenbuf+len,"/");
- (void)strcat(tokenbuf+len,scriptname);
+ if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
+ continue; /* don't search dir with too-long name */
+ if (len
+#if defined(atarist) && !defined(DOSISH)
+ && tokenbuf[len - 1] != '/'
+#endif
+#if defined(atarist) || defined(DOSISH)
+ && tokenbuf[len - 1] != '\\'
+#endif
+ )
+ tokenbuf[len++] = '/';
+ (void)strcpy(tokenbuf + len, scriptname);
#endif /* !VMS */
#ifdef SEARCH_EXTS
@@ -1743,7 +1766,7 @@ sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*undef[ ]/b\" \
-e \"/^#[ ]*endif/b\" \
-e \"s/^#.*//\" \
- %s | %S -C %S %s",
+ %s | %_ -C %_ %s",
(doextract ? "-e \"1,/^#/d\n\"" : ""),
#else
sv_setpvf(cmd, "\
@@ -1758,7 +1781,7 @@ sed %s -e \"/^[^#]/b\" \
-e '/^#[ ]*undef[ ]/b' \
-e '/^#[ ]*endif/b' \
-e 's/^[ ]*#.*//' \
- %s | %S -C %S %s",
+ %s | %_ -C %_ %s",
#ifdef LOC_SED
LOC_SED,
#else
diff --git a/perl.h b/perl.h
index b807b5d6fd..ac87be0b78 100644
--- a/perl.h
+++ b/perl.h
@@ -304,15 +304,8 @@
extern char *memset _((char*, int, int));
# endif
# endif
-# define memzero(d,l) memset(d,0,l)
#else
-# ifndef memzero
-# ifdef HAS_BZERO
-# define memzero(d,l) bzero(d,l)
-# else
-# define memzero(d,l) my_bzero(d,l)
-# endif
-# endif
+# define memset(d,c,l) my_memset(d,c,l)
#endif /* HAS_MEMSET */
#if !defined(HAS_MEMMOVE) && !defined(memmove)
@@ -346,6 +339,18 @@
# endif
#endif /* HAS_MEMCMP && HAS_SANE_MEMCMP */
+#ifndef memzero
+# ifdef HAS_BZERO
+# define memzero(d,l) bzero(d,l)
+# else
+# ifdef HAS_MEMSET
+# define memzero(d,l) memset(d,0,l)
+# else
+# define memzero(d,l) my_bzero(d,l)
+# endif
+# endif
+#endif
+
#ifndef HAS_BCMP
# ifndef bcmp
# define bcmp(s1,s2,l) memcmp(s1,s2,l)
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index a4a897c64b..5ee141e512 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -890,6 +890,12 @@ times than it has returned. This probably indicates an infinite
recursion, unless you're writing strange benchmark programs, in which
case it indicates something else.
+=item Delimiter for here document is too long
+
+(F) In a here document construct like C<E<lt>E<lt>FOO>, the label
+C<FOO> is too long for Perl to handle. You have to be seriously
+twisted to write code that triggers this error.
+
=item Did you mean &%s instead?
(W) You probably referred to an imported subroutine &FOO as $FOO or some such.
@@ -949,6 +955,13 @@ single form when it must operate on them directly. Either you've
passed an invalid file specification to Perl, or you've found a
case the conversion routines don't handle. Drat.
+=item Excessively long <> operator
+
+(F) The contents of a <> operator may not exceed the maximum size of a
+Perl identifier. If you're just trying to glob a long list of
+filenames, try using the glob() operator, or put the filenames into a
+variable and glob that.
+
=item Execution of %s aborted due to compilation errors
(F) The final summary message when a Perl compilation fails.
@@ -1101,9 +1114,9 @@ is now heavily deprecated.
=item Identifier too long
(F) Perl limits identifiers (names for variables, functions, etc.) to
-252 characters for simple names, somewhat more for compound names (like
-C<$A::B>). You've exceeded Perl's limits. Future versions of Perl are
-likely to eliminate these arbitrary limitations.
+about 250 characters for simple names, and somewhat more for compound
+names (like C<$A::B>). You've exceeded Perl's limits. Future
+versions of Perl are likely to eliminate these arbitrary limitations.
=item Ill-formed logical name |%s| in prime_env_iter
@@ -1581,6 +1594,13 @@ supplied it an uninitialized value. See L<perlform>.
(P) The internal pattern matching routines are out of their gourd.
+=item Number too long
+
+(F) Perl limits the representation of decimal numbers in programs to about
+about 250 characters. You've exceeded that length. Future versions of
+Perl are likely to eliminate this arbitrary limitation. In the meantime,
+try using scientific notation (e.g. "1e6" instead of "1_000_000").
+
=item Odd number of elements in hash list
(S) You specified an odd number of elements to a hash list, which is odd,
@@ -2221,6 +2241,11 @@ or "msg". See L<perlfunc/semctl>, for example.
(W) The filehandle you're writing to got itself closed sometime before now.
Check your logic flow.
+=item Target of goto is too deeply nested
+
+(F) You tried to use C<goto> to reach a label that was too deeply
+nested for Perl to reach. Perl is doing you a favor by refusing.
+
=item tell() on unopened file
(W) You tried to use the tell() function on a filehandle that was either
diff --git a/pod/perlfaq.pod b/pod/perlfaq.pod
index 95a4a5c7f5..2213a0f2f0 100644
--- a/pod/perlfaq.pod
+++ b/pod/perlfaq.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq - frequently asked questions about Perl ($Date: 1997/04/23 18:11:06 $)
+perlfaq - frequently asked questions about Perl ($Date: 1997/04/24 22:46:06 $)
=head1 DESCRIPTION
@@ -124,6 +124,11 @@ in respect of this information or its use.
=over 4
+=item 24/April/97
+
+Style and whitespace changes from Chip, new question on reading one
+character at a time from a terminal using POSIX from Tom.
+
=item 23/April/97
Added http://www.oasis.leo.org/perl/ to L<perlfaq2>. Style fix to
diff --git a/pod/perlfaq1.pod b/pod/perlfaq1.pod
index 6463a98061..6af40ae129 100644
--- a/pod/perlfaq1.pod
+++ b/pod/perlfaq1.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq1 - General Questions About Perl ($Revision: 1.11 $, $Date: 1997/03/19 17:23:09 $)
+perlfaq1 - General Questions About Perl ($Revision: 1.12 $, $Date: 1997/04/24 22:43:34 $)
=head1 DESCRIPTION
@@ -190,11 +190,12 @@ In "standard terminology" a I<program> has been compiled to physical
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 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,
-or a native-code compiler, so it's hard to give a definitive answer here.
+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, or a native-code compiler, so it's hard to give a
+definitive answer here.
=head2 What is a JAPH?
diff --git a/pod/perlfaq3.pod b/pod/perlfaq3.pod
index 7489e98a47..c1818109e4 100644
--- a/pod/perlfaq3.pod
+++ b/pod/perlfaq3.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq3 - Programming Tools ($Revision: 1.21 $, $Date: 1997/04/23 18:04:23 $)
+perlfaq3 - Programming Tools ($Revision: 1.22 $, $Date: 1997/04/24 22:43:42 $)
=head1 DESCRIPTION
@@ -285,9 +285,9 @@ source. Security through obscurity, the name for hiding your bugs
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 de-compile it. You can try using the native-code compiler
+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 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
diff --git a/pod/perlfaq4.pod b/pod/perlfaq4.pod
index 7c57d58d7d..bcf03990bc 100644
--- a/pod/perlfaq4.pod
+++ b/pod/perlfaq4.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq4 - Data Manipulation ($Revision: 1.18 $, $Date: 1997/04/23 18:04:37 $)
+perlfaq4 - Data Manipulation ($Revision: 1.19 $, $Date: 1997/04/24 22:43:57 $)
=head1 DESCRIPTION
@@ -1019,8 +1019,7 @@ Normally, merely accessing a key's value for a nonexistent key does
I<not> cause that key to be forever there. This is different than
awk's behavior.
-=head2 How can I make the Perl equivalent of a C structure/C++ class/hash
-or array of hashes or arrays?
+=head2 How can I make the Perl equivalent of a C structure/C++ class/hash or array of hashes or arrays?
Use references (documented in L<perlref>). Examples of complex data
structures are given in L<perldsc> and L<perllol>. Examples of
diff --git a/pod/perlfaq5.pod b/pod/perlfaq5.pod
index 898864b51a..03d5e6a797 100644
--- a/pod/perlfaq5.pod
+++ b/pod/perlfaq5.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq5 - Files and Formats ($Revision: 1.21 $, $Date: 1997/04/23 18:05:19 $)
+perlfaq5 - Files and Formats ($Revision: 1.22 $, $Date: 1997/04/24 22:44:02 $)
=head1 DESCRIPTION
@@ -451,8 +451,7 @@ over NFS, so this won't work (at least, not every time) over the net.
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?
+=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?
diff --git a/pod/perlfaq6.pod b/pod/perlfaq6.pod
index 1af7948339..d21a11157b 100644
--- a/pod/perlfaq6.pod
+++ b/pod/perlfaq6.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq6 - Regexps ($Revision: 1.16 $, $Date: 1997/03/25 18:16:56 $)
+perlfaq6 - Regexps ($Revision: 1.17 $, $Date: 1997/04/24 22:44:10 $)
=head1 DESCRIPTION
@@ -138,7 +138,8 @@ on matching balanced text.
$/ must be a string, not a regular expression. Awk has to be better
for something. :-)
-Actually, you could do this if you don't mind reading the whole file into
+Actually, you could do this if you don't mind reading the whole file
+into memory:
undef $/;
@records = split /your_pattern/, <FH>;
@@ -325,9 +326,9 @@ playing hot potato.
Use the split function:
while (<>) {
- foreach $word ( split ) {
+ foreach $word ( split ) {
# do something with $word here
- }
+ }
}
Note that this isn't really a word in the English sense; it's just
@@ -360,7 +361,7 @@ in the previous question:
If you wanted to do the same thing for lines, you wouldn't need a
regular expression:
- while (<>) {
+ while (<>) {
$seen{$_}++;
}
while ( ($line, $count) = each %seen ) {
@@ -546,19 +547,20 @@ synonymous. The following set of approaches was offered by Jeffrey
Friedl, whose article in issue #5 of The Perl Journal talks about this
very matter.
-Let's suppose you have some weird Martian encoding where pairs of ASCII
-uppercase letters encode single Martian letters (i.e. the two bytes
-"CV" make a single Martian letter, as do the two bytes "SG", "VS",
-"XX", etc.). Other bytes represent single characters, just like ASCII.
+Let's suppose you have some weird Martian encoding where pairs of
+ASCII uppercase letters encode single Martian letters (i.e. the two
+bytes "CV" make a single Martian letter, as do the two bytes "SG",
+"VS", "XX", etc.). Other bytes represent single characters, just like
+ASCII.
-So, the string of Martian "I am CVSGXX!" uses 12 bytes to encode the nine
-characters 'I', ' ', 'a', 'm', ' ', 'CV', 'SG', 'XX', '!'.
+So, the string of Martian "I am CVSGXX!" uses 12 bytes to encode the
+nine characters 'I', ' ', 'a', 'm', ' ', 'CV', 'SG', 'XX', '!'.
Now, say you want to search for the single character C</GX/>. Perl
-doesn't know about Martian, so it'll find the two bytes "GX" in the
-"I am CVSGXX!" string, even though that character isn't there: it just
-looks like it is because "SG" is next to "XX", but there's no real "GX".
-This is a big problem.
+doesn't know about Martian, so it'll find the two bytes "GX" in the "I
+am CVSGXX!" string, even though that character isn't there: it just
+looks like it is because "SG" is next to "XX", but there's no real
+"GX". This is a big problem.
Here are a few ways, all painful, to deal with it:
diff --git a/pod/perlfaq7.pod b/pod/perlfaq7.pod
index 908fc14e7c..283aa2bb34 100644
--- a/pod/perlfaq7.pod
+++ b/pod/perlfaq7.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq7 - Perl Language Issues ($Revision: 1.16 $, $Date: 1997/03/19 17:25:23 $)
+perlfaq7 - Perl Language Issues ($Revision: 1.18 $, $Date: 1997/04/24 22:44:14 $)
=head1 DESCRIPTION
@@ -169,7 +169,7 @@ own module. Make sure to change the names appropriately.
# if using RCS/CVS, this next line may be preferred,
# but beware two-digit versions.
- $VERSION = do{my@r=q$Revision: 1.16 $=~/\d+/g;sprintf '%d.'.'%02d'x$#r,@r};
+ $VERSION = do{my@r=q$Revision: 1.18 $=~/\d+/g;sprintf '%d.'.'%02d'x$#r,@r};
@ISA = qw(Exporter);
@EXPORT = qw(&func1 &func2 &func3);
@@ -709,6 +709,8 @@ Use embedded POD to discard it:
=end comment text
+ =cut
+
=head1 AUTHOR AND COPYRIGHT
Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
diff --git a/pod/perlfaq8.pod b/pod/perlfaq8.pod
index f559d6a2f2..0c91f1e8de 100644
--- a/pod/perlfaq8.pod
+++ b/pod/perlfaq8.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlfaq8 - System Interaction ($Revision: 1.20 $, $Date: 1997/04/23 18:11:50 $)
+perlfaq8 - System Interaction ($Revision: 1.21 $, $Date: 1997/04/24 22:44:19 $)
=head1 DESCRIPTION
@@ -795,7 +795,394 @@ 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 How do I get one key from the terminal at a time, under POSIX?
+
+ #!/usr/bin/perl -w
+ use strict;
+ $| = 1;
+ for (1..4) {
+ my $got;
+ print "gimme: ";
+ $got = getone();
+ print "--> $got\n";
+ }
+ exit;
+
+ BEGIN {
+ use POSIX qw(:termios_h);
+
+ my ($term, $oterm, $echo, $noecho, $fd_stdin);
+
+ $fd_stdin = fileno(STDIN);
+
+ $term = POSIX::Termios->new();
+ $term->getattr($fd_stdin);
+ $oterm = $term->getlflag();
+
+ $echo = ECHO | ECHOK | ICANON;
+ $noecho = $oterm & ~$echo;
+
+ sub cbreak {
+ $term->setlflag($noecho);
+ $term->setcc(VTIME, 1);
+ $term->setattr($fd_stdin, TCSANOW);
+ }
+
+ sub cooked {
+ $term->setlflag($oterm);
+ $term->setcc(VTIME, 0);
+ $term->setattr($fd_stdin, TCSANOW);
+ }
+
+ sub getone {
+ my $key = '';
+ cbreak();
+ sysread(STDIN, $key, 1);
+ cooked();
+ return $key;
+ }
+
+ }
+ END { cooked() }
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
+ END-of-perlfaq8.pod
+echo x - perlfaq9.pod
+sed 's/^X//' >perlfaq9.pod << 'END-of-perlfaq9.pod'
+=head1 NAME
+
+perlfaq9 - Networking ($Revision: 1.17 $, $Date: 1997/04/24 22:44:29 $)
+
+=head1 DESCRIPTION
+
+This section deals with questions related to networking, the internet,
+and a few on the web.
+
+=head2 My CGI script runs from the command line but not the browser. Can you help me fix it?
+
+Sure, but you probably can't afford our contracting rates :-)
+
+Seriously, if you can demonstrate that you've read the following FAQs
+and that your problem isn't something simple that can be easily
+answered, you'll probably receive a courteous and useful reply to your
+question if you post it on comp.infosystems.www.authoring.cgi (if it's
+something to do with HTTP, HTML, or the CGI protocols). Questions that
+appear to be Perl questions but are really CGI ones that are posted to
+comp.lang.perl.misc may not be so well received.
+
+The useful FAQs are:
+
+ http://www.perl.com/perl/faq/idiots-guide.html
+ http://www3.pair.com/webthing/docs/cgi/faqs/cgifaq.shtml
+ http://www.perl.com/perl/faq/perl-cgi-faq.html
+ http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html
+ http://www.boutell.com/faq/
+
+=head2 How do I remove HTML from a string?
+
+The most correct way (albeit not the fastest) is to use HTML::Parse
+from CPAN (part of the libwww-perl distribution, which is a must-have
+module for all web hackers).
+
+Many folks attempt a simple-minded regular expression approach, like
+C<s/E<lt>.*?E<gt>//g>, but that fails in many cases because the tags
+may continue over line breaks, they may contain quoted angle-brackets,
+or HTML comment may be present. Plus folks forget to convert
+entities, like C<&lt;> for example.
+
+Here's one "simple-minded" approach, that works for most files:
+
+ #!/usr/bin/perl -p0777
+ s/<(?:[^>'"]*|(['"]).*?\1)*>//gs
+
+If you want a more complete solution, see the 3-stage striphtml
+program in
+http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/striphtml.gz
+.
+
+=head2 How do I extract URLs?
+
+A quick but imperfect approach is
+
+ #!/usr/bin/perl -n00
+ # qxurl - tchrist@perl.com
+ print "$2\n" while m{
+ < \s*
+ A \s+ HREF \s* = \s* (["']) (.*?) \1
+ \s* >
+ }gsix;
+
+This version does not adjust relative URLs, understand alternate
+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.
+
+=head2 How do I download a file from the user's machine? How do I open a file on another machine?
+
+In the context of an HTML form, you can use what's known as
+B<multipart/form-data> encoding. The CGI.pm module (available from
+CPAN) supports this in the start_multipart_form() method, which isn't
+the same as the startform() method.
+
+=head2 How do I make a pop-up menu in HTML?
+
+Use the B<E<lt>SELECTE<gt>> and B<E<lt>OPTIONE<gt>> tags. The CGI.pm
+module (available from CPAN) supports this widget, as well as many
+others, including some that it cleverly synthesizes on its own.
+
+=head2 How do I fetch an HTML file?
+
+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:
+
+ $string = "http://altavista.digital.com/cgi-bin/query?pg=q&what=news&fmt=.&q=%2Bcgi-bin+%2Bperl.exe";
+ $string =~ s/%([a-fA-F0-9]{2})/chr(hex($1))/ge;
+
+Encoding is a bit harder, because you can't just blindly change
+all the non-alphanumunder character (C<\W>) into their hex escapes.
+It's important that characters with special meaning like C</> and C<?>
+I<not> be translated. Probably the easiest way to get this right is
+to avoid reinventing the wheel and just use the URI::Escape module,
+which is part of the libwww-perl package (LWP) available from CPAN.
+
+=head2 How do I redirect to another page?
+
+Instead of sending back a C<Content-Type> as the headers of your
+reply, send back a C<Location:> header. Officially this should be a
+C<URI:> header, so the CGI.pm module (available from CPAN) sends back
+both:
+
+ Location: http://www.domain.com/newpage
+ URI: http://www.domain.com/newpage
+
+Note that relative URLs in these headers can cause strange effects
+because of "optimizations" that servers do.
+
+=head2 How do I put a password on my web pages?
+
+That depends. You'll need to read the documentation for your web
+server, or perhaps check some of the other FAQs referenced above.
+
+=head2 How do I edit my .htpasswd and .htgroup files with Perl?
+
+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, 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:
+
+ use HTTPD::UserAdmin ();
+ HTTPD::UserAdmin
+ ->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
+from page 222 of the 2nd edition of "Programming Perl":
+
+ $/ = '';
+ $header = <MSG>;
+ $header =~ s/\n\s+/ /g; # merge continuation lines
+ %head = ( UNIX_FROM_LINE, split /^([-\w]+):\s*/m, $header );
+
+That solution doesn't do well if, for example, you're trying to
+maintain all the Received lines. A more complete approach is to use
+the Mail::Header module from CPAN (part of the MailTools package).
+
+=head2 How do I decode a CGI form?
+
+A lot of people are tempted to code this up themselves, so you've
+probably all seen a lot of code involving C<$ENV{CONTENT_LENGTH}> and
+C<$ENV{QUERY_STRING}>. It's true that this can work, but there are
+also a lot of versions of this floating around that are quite simply
+broken!
+
+Please do not be tempted to reinvent the wheel. Instead, use the
+CGI.pm or CGI_Lite.pm (available from CPAN), or if you're trapped in
+the module-free land of perl1 .. perl4, you might look into cgi-lib.pl
+(available from http://www.bio.cam.ac.uk/web/form.html).
+
+=head2 How do I check a valid email address?
+
+You can't.
+
+Without sending mail to the address and seeing whether it bounces (and
+even then you face the halting problem), you cannot determine whether
+an email address is valid. Even if you apply the email header
+standard, you can have problems, because there are deliverable
+addresses that aren't RFC-822 (the mail header standard) compliant,
+and addresses that aren't deliverable which are compliant.
+
+Many are tempted to try to eliminate many frequently-invalid email
+addresses with a simple regexp, such as
+C</^[\w.-]+\@([\w.-]\.)+\w+$/>. However, this also throws out many
+valid ones, and says nothing about potential deliverability, so is not
+suggested. Instead, see
+http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/ckaddr.gz ,
+which actually checks against the full RFC spec (except for nested
+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
+more. Decoding BASE64 becomes as simple as:
+
+ use MIME::base64;
+ $decoded = decode_base64($encoded);
+
+A more direct approach is to use the unpack() function's "u"
+format after minor transliterations:
+
+ tr#A-Za-z0-9+/##cd; # remove non-base64 chars
+ tr#A-Za-z0-9+/# -_#; # convert to uuencoded format
+ $len = pack("c", 32 + 0.75*length); # compute length byte
+ print unpack("u", $len . $_); # uudecode and print
+
+=head2 How do I return the user's email address?
+
+On systems that support getpwuid, the $E<lt> variable and the
+Sys::Hostname module (which is part of the standard perl distribution),
+you can probably try using something like this:
+
+ use Sys::Hostname;
+ $address = sprintf('%s@%s', getpwuid($<), hostname);
+
+Company policies on email address can mean that this generates addresses
+that the company's email system will not accept, so you should ask for
+users' email addresses when this matters. Furthermore, not all systems
+on which Perl runs are so forthcoming with this information as is Unix.
+
+The Mail::Util module from CPAN (part of the MailTools package) provides a
+mailaddress() function that tries to guess the mail address of the user.
+It makes a more intelligent guess than the code above, using information
+given when the module was installed, but it could still be incorrect.
+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
+(part of the MailFolder package) or the Mail::Internet module from
+CPAN (also part of the MailTools package).
+
+ # sending mail
+ use Mail::Internet;
+ use Mail::Header;
+ # say which mail host to use
+ $ENV{SMTPHOSTS} = 'mail.frii.com';
+ # create headers
+ $header = new Mail::Header;
+ $header->add('From', 'gnat@frii.com');
+ $header->add('Subject', 'Testing');
+ $header->add('To', 'gnat@frii.com');
+ # create body
+ $body = 'This is a test, ignore';
+ # create mail object
+ $mail = new Mail::Internet(undef, Header => $header, Body => \[$body]);
+ # send it
+ $mail->smtpsend or die;
+
+=head2 How do I find out my hostname/domainname/IP address?
+
+A lot of code has historically cavalierly called the C<`hostname`>
+program. While sometimes expedient, this isn't very portable. It's
+one of those tradeoffs of convenience versus portability.
+
+The Sys::Hostname module (part of the standard perl distribution) will
+give you the hostname after which you can find out the IP address
+(assuming you have working DNS) with a gethostbyname() call.
+
+ use Socket;
+ use Sys::Hostname;
+ my $host = hostname();
+ my $addr = inet_ntoa(scalar(gethostbyname($name)) || 'localhost');
+
+Probably the simplest way to learn your DNS domain name is to grok
+it out of /etc/resolv.conf, at least under Unix. Of course, this
+assumes several things about your resolv.conf configuration, including
+that it exists.
+
+(We still need a good DNS domain name-learning method for non-Unix
+systems.)
+
+=head2 How do I fetch a news article or the active newsgroups?
+
+Use the Net::NNTP or News::NNTPClient modules, both available from CPAN.
+This can make tasks like fetching the newsgroup list as simple as:
+
+ perl -MNews::NNTPClient
+ -e 'print News::NNTPClient->new->list("newsgroups")'
+
+=head2 How do I fetch/put an FTP file?
+
+LWP::Simple (available from CPAN) can fetch but not put. Net::FTP (also
+available from CPAN) is more complex but can put as well as fetch.
+
+=head2 How can I do RPC in Perl?
+
+A DCE::RPC module is being developed (but is not yet available), and
+will be released as part of the DCE-Perl package (available from
+CPAN). No ONC::RPC module is known.
+
=head1 AUTHOR AND COPYRIGHT
Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
All rights reserved. See L<perlfaq> for distribution information.
+
+END-of-perlfaq9.pod
+exit
+
diff --git a/pod/perltoc.pod b/pod/perltoc.pod
index a70ed6e74e..b699e7fd30 100644
--- a/pod/perltoc.pod
+++ b/pod/perltoc.pod
@@ -38,8 +38,8 @@ expression enhancements, Innumerable Unbundled Modules, Compilability
=item NOTES
-=head2 perlfaq - frequently asked questions about Perl ($Date: 1997/04/23
-18:11:06 $)
+=head2 perlfaq - frequently asked questions about Perl ($Date: 1997/04/24
+22:46:06 $)
=item DESCRIPTION
@@ -76,11 +76,11 @@ authors
=item Changes
-23/April/97, 25/March/97, 18/March/97, 17/March/97 Version, Initial
-Release: 11/March/97
+24/April/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 $)
+=head2 perlfaq1 - General Questions About Perl ($Revision: 1.12 $, $Date:
+1997/04/24 22:43:34 $)
=item DESCRIPTION
@@ -176,8 +176,8 @@ MacPerl, Perl5-Porters, NTPerl, Perl-Packrats
=item AUTHOR AND COPYRIGHT
-=head2 perlfaq3 - Programming Tools ($Revision: 1.21 $, $Date: 1997/04/23
-18:04:23 $)
+=head2 perlfaq3 - Programming Tools ($Revision: 1.22 $, $Date: 1997/04/24
+22:43:42 $)
=item DESCRIPTION
@@ -251,8 +251,8 @@ mean?
=item AUTHOR AND COPYRIGHT
-=head2 perlfaq4 - Data Manipulation ($Revision: 1.18 $, $Date: 1997/04/23
-18:04:37 $)
+=head2 perlfaq4 - Data Manipulation ($Revision: 1.19 $, $Date: 1997/04/24
+22:43:57 $)
=item DESCRIPTION
@@ -418,8 +418,8 @@ it?
=item Why does passing a subroutine an undefined element in a hash create
it?
-=item How can I make the Perl equivalent of a C structure/C++ class/hash
-or array of hashes or arrays?
+=item How can I make the Perl equivalent of a C structure/C++ class/hash or
+array of hashes or arrays?
=item How can I use a reference as a hash key?
@@ -445,8 +445,8 @@ or array of hashes or arrays?
=item AUTHOR AND COPYRIGHT
-=head2 perlfaq5 - Files and Formats ($Revision: 1.21 $, $Date: 1997/04/23
-18:05:19 $)
+=head2 perlfaq5 - Files and Formats ($Revision: 1.22 $, $Date: 1997/04/24
+22:44:02 $)
=item DESCRIPTION
@@ -488,8 +488,8 @@ filehandles between subroutines? How do I make an array of filehandles?
=item What can't I just open(FH, ">file.lock")?
-=item I still don't get locking. I just want to increment the number
-in the file. How can I do this?
+=item I still don't get locking. I just want to increment the number in
+the file. How can I do this?
=item How do I randomly update a binary file?
@@ -529,7 +529,7 @@ protected files? Isn't this a bug in Perl?
=item AUTHOR AND COPYRIGHT
-=head2 perlfaq6 - Regexps ($Revision: 1.16 $, $Date: 1997/03/25 18:16:56 $)
+=head2 perlfaq6 - Regexps ($Revision: 1.17 $, $Date: 1997/04/24 22:44:10 $)
=item DESCRIPTION
@@ -590,8 +590,8 @@ file?
=item AUTHOR AND COPYRIGHT
-=head2 perlfaq7 - Perl Language Issues ($Revision: 1.16 $, $Date:
-1997/03/19 17:25:23 $)
+=head2 perlfaq7 - Perl Language Issues ($Revision: 1.18 $, $Date:
+1997/04/24 22:44:14 $)
=item DESCRIPTION
@@ -661,8 +661,8 @@ is in scope?
=item AUTHOR AND COPYRIGHT
-=head2 perlfaq8 - System Interaction ($Revision: 1.20 $, $Date: 1997/04/23
-18:11:50 $)
+=head2 perlfaq8 - System Interaction ($Revision: 1.21 $, $Date: 1997/04/24
+22:44:19 $)
=item DESCRIPTION
@@ -771,6 +771,61 @@ search path?
=back
+=item How do I get one key from the terminal at a time, under POSIX?
+
+=item AUTHOR AND COPYRIGHT
+
+=item DESCRIPTION
+
+=over
+
+=item My CGI script runs from the command line but not the browser. Can
+you help me fix it?
+
+=item How do I remove HTML from a string?
+
+=item How do I extract URLs?
+
+=item How do I download a file from the user's machine? How do I open a
+file on another machine?
+
+=item How do I make a pop-up menu in HTML?
+
+=item How do I fetch an HTML file?
+
+=item how do I decode or create those %-encodings on the web?
+
+=item How do I redirect to another page?
+
+=item How do I put a password on my web pages?
+
+=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?
+
+=item How do I check a valid email address?
+
+=item How do I decode a MIME/BASE64 string?
+
+=item How do I return the user's email address?
+
+=item How do I send/read mail?
+
+=item How do I find out my hostname/domainname/IP address?
+
+=item How do I fetch a news article or the active newsgroups?
+
+=item How do I fetch/put an FTP file?
+
+=item How can I do RPC in Perl?
+
+=back
+
=item AUTHOR AND COPYRIGHT
=head2 perlfaq9 - Networking ($Revision: 1.16 $, $Date: 1997/04/23 18:12:06
diff --git a/pp.c b/pp.c
index 68b0991c82..f7f0c412a6 100644
--- a/pp.c
+++ b/pp.c
@@ -3114,7 +3114,7 @@ PP(pp_unpack)
else if (++bytes >= sizeof(UV)) { /* promote to string */
char *t;
- sv = newSVpvf("%0*vu", (int)(sizeof(UV) * 3), auv);
+ sv = newSVpvf("%.*Vu", (int)TYPE_DIGITS(UV), auv);
while (s < strend) {
sv = mul128(sv, *s & 0x7f);
if (!(*s++ & 0x80)) {
diff --git a/pp_ctl.c b/pp_ctl.c
index 1600ed89a3..b05e13fa0c 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -27,7 +27,7 @@
static OP *docatch _((OP *o));
static OP *doeval _((int gimme));
-static OP *dofindlabel _((OP *op, char *label, OP **opstack));
+static OP *dofindlabel _((OP *op, char *label, OP **opstack, OP **oplimit));
static void doparseform _((SV *sv));
static I32 dopoptoeval _((I32 startingblock));
static I32 dopoptolabel _((char *label));
@@ -1545,19 +1545,27 @@ PP(pp_redo)
static OP* lastgotoprobe;
static OP *
-dofindlabel(op,label,opstack)
+dofindlabel(op,label,opstack,oplimit)
OP *op;
char *label;
OP **opstack;
+OP **oplimit;
{
OP *kid;
OP **ops = opstack;
+ static char too_deep[] = "Target of goto is too deeply nested";
+ if (ops >= oplimit)
+ croak(too_deep);
if (op->op_type == OP_LEAVE ||
op->op_type == OP_SCOPE ||
op->op_type == OP_LEAVELOOP ||
op->op_type == OP_LEAVETRY)
- *ops++ = cUNOP->op_first;
+ {
+ *ops++ = cUNOP->op_first;
+ if (ops >= oplimit)
+ croak(too_deep);
+ }
*ops = 0;
if (op->op_flags & OPf_KIDS) {
/* First try all the kids at this level, since that's likeliest. */
@@ -1569,15 +1577,12 @@ OP **opstack;
for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
if (kid == lastgotoprobe)
continue;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
- if (ops > opstack &&
- (ops[-1]->op_type == OP_NEXTSTATE ||
- ops[-1]->op_type == OP_DBSTATE))
- *ops = kid;
- else
- *ops++ = kid;
- }
- if (op = dofindlabel(kid,label,ops))
+ if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
+ (ops == opstack ||
+ (ops[-1]->op_type != OP_NEXTSTATE &&
+ ops[-1]->op_type != OP_DBSTATE)))
+ *ops++ = kid;
+ if (op = dofindlabel(kid, label, ops, oplimit))
return op;
}
}
@@ -1597,7 +1602,8 @@ PP(pp_goto)
OP *retop = 0;
I32 ix;
register CONTEXT *cx;
- OP *enterops[64];
+#define GOTO_DEPTH 64
+ OP *enterops[GOTO_DEPTH];
char *label;
int do_dump = (op->op_type == OP_DUMP);
@@ -1813,7 +1819,8 @@ PP(pp_goto)
gotoprobe = main_root;
break;
}
- retop = dofindlabel(gotoprobe, label, enterops);
+ retop = dofindlabel(gotoprobe, label,
+ enterops, enterops + GOTO_DEPTH);
if (retop)
break;
lastgotoprobe = gotoprobe;
@@ -2211,7 +2218,7 @@ PP(pp_require)
sv_catpv(msg, " (change .h to .ph maybe?)");
if (instr(SvPVX(msg), ".ph "))
sv_catpv(msg, " (did you run h2ph?)");
- DIE("%S", msg);
+ DIE("%_", msg);
}
RETPUSHUNDEF;
@@ -2258,7 +2265,8 @@ PP(pp_entereval)
register CONTEXT *cx;
dPOPss;
I32 gimme = GIMME_V, was = sub_generation;
- char tmpbuf[sizeof(unsigned long) * 3 + 12], *safestr;
+ char tmpbuf[TYPE_DIGITS(long) + 12];
+ char *safestr;
STRLEN len;
OP *ret;
diff --git a/proto.h b/proto.h
index cd45ca8493..732aa3da88 100644
--- a/proto.h
+++ b/proto.h
@@ -43,9 +43,7 @@ I32 my_chsize _((int fd, Off_t length));
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,...))
- __attribute__((format(printf,1,2),noreturn));
+void croak _((const char* pat,...)) __attribute__((noreturn));
void cv_ckproto _((CV* cv, GV* gv, char* p));
CV* cv_clone _((CV* proto));
SV* cv_const_sv _((CV* cv));
@@ -65,8 +63,10 @@ I32 debstackptrs _((void));
void debprofdump _((void));
#endif
I32 debstack _((void));
+char* delimcpy _((char* to, char* toend, char* from, char* fromend,
+ int delim, I32* retlen));
void deprecate _((char* s));
-OP* die _((const char* pat,...)) __attribute__((format(printf,1,2)));
+OP* die _((const char* pat,...));
OP* die_where _((char* message));
void dounwind _((I32 cxix));
bool do_aexec _((SV* really, SV** mark, SV** sp));
@@ -253,6 +253,9 @@ I32 my_lstat _((void));
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
I32 my_memcmp _((char* s1, char* s2, I32 len));
#endif
+#if !defined(HAS_MEMSET)
+void* my_memset _((char* loc, I32 ch, I32 len));
+#endif
I32 my_pclose _((PerlIO* ptr));
PerlIO* my_popen _((char* cmd, char* mode));
void my_setenv _((char* nam, char* val));
@@ -515,7 +518,7 @@ void utilize _((int aver, I32 floor, OP* version, OP* id, OP* arg));
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 warn _((const char* pat,...));
void watch _((char** addr));
I32 whichsig _((char* sig));
int yyerror _((char* s));
diff --git a/sv.c b/sv.c
index 598e7466ec..45fb77f07b 100644
--- a/sv.c
+++ b/sv.c
@@ -170,7 +170,7 @@ U32 flags;
--sv_count; \
} while (0)
-#define uproot_SV(p) \
+#define uproot_SV(p) \
do { \
(p) = sv_root; \
sv_root = (SV*)SvANY(p); \
@@ -1712,7 +1712,7 @@ STRLEN *lp;
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
olderrno = errno; /* some Xenix systems wipe out errno here */
- sv_setpvf(sv, "%vd", SvIVX(sv));
+ sv_setpvf(sv, "%Vd", SvIVX(sv));
errno = olderrno;
s = SvEND(sv);
}
@@ -1887,6 +1887,7 @@ register SV *sstr;
}
break;
case SVt_PV:
+ case SVt_PVFM:
if (dtype < SVt_PV)
sv_upgrade(dstr, SVt_PV);
break;
@@ -3465,7 +3466,7 @@ newSVpvf(const char* pat, ...)
#else
/*VARARGS0*/
SV *
-newSVpvf(sv, pat, va_alist)
+newSVpvf(pat, va_alist)
const char *pat;
va_dcl
#endif
@@ -3482,7 +3483,7 @@ va_dcl
#else
va_start(args);
#endif
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool));
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
return sv;
}
@@ -4107,7 +4108,7 @@ sv_setpvf(sv, pat, va_alist)
#else
va_start(args);
#endif
- sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool));
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
}
@@ -4129,7 +4130,7 @@ sv_catpvf(sv, pat, va_alist)
#else
va_start(args);
#endif
- sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool));
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
}
@@ -4160,20 +4161,31 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
char *p;
char *q;
char *patend;
+ STRLEN origlen;
I32 svix = 0;
/* no matter what, this is a string now */
- (void)SvPV_force(sv, na);
+ (void)SvPV_force(sv, origlen);
- /* special-case "" and "%s" */
+ /* special-case "", "%s", and "%_" */
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;
+ if (patlen == 2 && pat[0] == '%') {
+ switch (pat[1]) {
+ case 's':
+ if (args)
+ sv_catpv(sv, va_arg(*args, char*));
+ else if (svix < svmax)
+ sv_catsv(sv, *svargs);
+ return;
+ case '_':
+ if (args) {
+ sv_catsv(sv, va_arg(*args, SV*));
+ return;
+ }
+ /* See comment on '_' below */
+ break;
+ }
}
patend = (char*)pat + patlen;
@@ -4184,6 +4196,7 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
char plus = 0;
char intsize = 0;
STRLEN width = 0;
+ STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
@@ -4191,8 +4204,8 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
STRLEN esignlen = 0;
char *eptr = Nullch;
- STRLEN elen = 0;
- char ebuf[(sizeof(UV) * 3) * 2 + 16]; /* large enough for "%#.#f" */
+ STRLEN elen = 0;
+ char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
static char *efloatbuf = Nullch;
static STRLEN efloatsize = 0;
@@ -4215,6 +4228,8 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
if (q++ >= patend)
break;
+ /* FLAGS */
+
while (*q) {
switch (*q) {
case ' ':
@@ -4236,62 +4251,74 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
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;
+ default:
+ break;
+ }
+ break;
+ }
- 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;
+ /* WIDTH */
+
+ switch (*q) {
+ 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');
+ break;
+
+ 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++;
+ break;
+ }
+
+ /* PRECISION */
- case '*':
+ if (*q == '.') {
+ q++;
+ if (*q == '*') {
if (args)
i = va_arg(*args, int);
else
i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
- left ^= (i < 0);
- width = (i < 0) ? -i : i;
+ precis = (i < 0) ? 0 : i;
q++;
- continue;
+ }
+ else {
+ precis = 0;
+ while (isDIGIT(*q))
+ precis = precis * 10 + (*q++ - '0');
+ }
+ has_precis = TRUE;
+ }
- 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;
+ /* SIZE */
- default:
+ switch (*q) {
+ case 'l':
+#if 0 /* when quads have better support within Perl */
+ if (*(q + 1) == 'l') {
+ intsize = 'q';
+ q += 2;
break;
}
-
+#endif
+ /* FALL THROUGH */
+ case 'h':
+ case 'V':
+ intsize = *q++;
break;
}
+ /* CONVERSION */
+
switch (c = *q++) {
/* STRINGS */
@@ -4310,22 +4337,25 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
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 *);
+ eptr = va_arg(*args, char*);
elen = strlen(eptr);
}
else if (svix < svmax)
eptr = SvPVx(svargs[svix++], elen);
goto string;
+ case '_':
+ /*
+ * The "%_" hack might have to be changed someday,
+ * if ISO or ANSI decide to use '_' for something.
+ * So we keep it hidden from users' code.
+ */
+ if (!args)
+ goto unknown;
+ eptr = SvPVx(va_arg(*args, SV*), elen);
+
string:
if (has_precis && elen > precis)
elen = precis;
@@ -4333,6 +4363,14 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
/* INTEGERS */
+ case 'p':
+ if (args)
+ uv = (UV)va_arg(*args, void*);
+ else
+ uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
+ base = 16;
+ goto integer;
+
case 'D':
intsize = 'l';
/* FALL THROUGH */
@@ -4343,7 +4381,7 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
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;
+ case 'V': iv = va_arg(*args, IV); break;
}
}
else {
@@ -4352,7 +4390,7 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
case 'h': iv = (short)iv; break;
default: iv = (int)iv; break;
case 'l': iv = (long)iv; break;
- case 'v': break;
+ case 'V': break;
}
}
if (iv >= 0) {
@@ -4367,6 +4405,13 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
base = 10;
goto integer;
+ case 'U':
+ intsize = 'l';
+ /* FALL THROUGH */
+ case 'u':
+ base = 10;
+ goto uns_integer;
+
case 'O':
intsize = 'l';
/* FALL THROUGH */
@@ -4375,14 +4420,8 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
goto uns_integer;
case 'X':
- intsize = 'l';
- /* FALL THROUGH */
case 'x':
base = 16;
- goto uns_integer;
-
- case 'u':
- base = 10;
uns_integer:
if (args) {
@@ -4390,7 +4429,7 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
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;
+ case 'V': uv = va_arg(*args, UV); break;
}
}
else {
@@ -4399,48 +4438,74 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
case 'h': uv = (unsigned short)uv; break;
default: uv = (unsigned)uv; break;
case 'l': uv = (unsigned long)uv; break;
- case 'v': 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':
+ switch (base) {
+ unsigned dig;
+ case 16:
+ p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
+ do {
+ dig = uv & 15;
+ *--eptr = p[dig];
+ } while (uv >>= 4);
+ if (alt) {
esignbuf[esignlen++] = '0';
- esignbuf[esignlen++] = 'x';
- break;
+ esignbuf[esignlen++] = c; /* 'x' or 'X' */
}
+ break;
+ case 8:
+ do {
+ dig = uv & 7;
+ *--eptr = '0' + dig;
+ } while (uv >>= 3);
+ if (alt && *eptr != '0')
+ *--eptr = '0';
+ break;
+ default: /* it had better be ten or less */
+ do {
+ dig = uv % base;
+ *--eptr = '0' + dig;
+ } while (uv /= base);
+ break;
}
elen = (ebuf + sizeof ebuf) - eptr;
- if (has_precis) {
- left = FALSE;
- fill = '0';
- width = esignlen + precis;
- }
+ if (has_precis && precis > elen)
+ zeros = precis - elen;
break;
/* FLOATING POINT */
+ case 'F':
+ c = 'f'; /* maybe %F isn't supported here */
+ /* FALL THROUGH */
case 'e': case 'E':
- case 'f': 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;
+ if (args)
+ nv = va_arg(*args, double);
+ else
+ nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
+
+ need = 0;
+ if (c != 'e' && c != 'E') {
+ i = PERL_INT_MIN;
+ (void)frexp(nv, &i);
+ if (i == PERL_INT_MIN)
+ need = 400; /* busted -- be safe */
+ else if (i > 0)
+ need = BIT_DIGITS(i);
+ }
+ need += has_precis ? precis : 6; /* known default */
+ if (need < width)
+ need = width;
+
need += 20; /* fudge factor */
if (efloatsize < need) {
Safefree(efloatbuf);
@@ -4468,10 +4533,6 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
*--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;
@@ -4489,14 +4550,29 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
break;
+ /* SPECIAL */
+
+ case 'n':
+ i = SvCUR(sv) - origlen;
+ if (args) {
+ int *ip = va_arg(*args, int*);
+ *ip = i;
+ }
+ else if (svix < svmax)
+ sv_setuv(svargs[svix++], (UV)i);
+ continue; /* not "break" */
+
+ /* UNKNOWN */
+
default:
+ unknown:
/* output mangled stuff without comment */
eptr = p;
elen = q - p;
break;
}
- have = esignlen + elen;
+ have = esignlen + zeros + elen;
need = (have > width ? have : width);
gap = need - have;
@@ -4514,6 +4590,10 @@ sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
for (i = 0; i < esignlen; i++)
*p++ = esignbuf[i];
}
+ if (zeros) {
+ for (i = zeros; i; i--)
+ *p++ = '0';
+ }
if (elen) {
memcpy(p, eptr, elen);
p += elen;
diff --git a/toke.c b/toke.c
index 56e2fac1f1..9c4f487e1d 100644
--- a/toke.c
+++ b/toke.c
@@ -50,7 +50,7 @@ static int uni _((I32 f, char *s));
static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
static void restore_rsfp _((void *f));
-static char too_long[] = "Identifier too long";
+static char ident_too_long[] = "Identifier too long";
static char *linestart; /* beg. of most recently read line */
@@ -4332,7 +4332,7 @@ STRLEN *slp;
register char *e = d + destlen - 3; /* two-character token, ending NUL */
for (;;) {
if (d >= e)
- croak(too_long);
+ croak(ident_too_long);
if (isALNUM(*s))
*d++ = *s++;
else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
@@ -4374,14 +4374,14 @@ I32 ck_uni;
if (isDIGIT(*s)) {
while (isDIGIT(*s)) {
if (d >= e)
- croak(too_long);
+ croak(ident_too_long);
*d++ = *s++;
}
}
else {
for (;;) {
if (d >= e)
- croak(too_long);
+ croak(ident_too_long);
if (isALNUM(*s))
*d++ = *s++;
else if (*s == '\'' && isIDFIRST(s[1])) {
@@ -4689,21 +4689,23 @@ register char *s;
SV *tmpstr;
char term;
register char *d;
+ register char *e;
char *peek;
int outer = (rsfp && !lex_inwhat);
s += 2;
d = tokenbuf;
+ e = tokenbuf + sizeof tokenbuf - 1;
if (!outer)
*d++ = '\n';
for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
if (*peek && strchr("`'\"",*peek)) {
s = peek;
term = *s++;
- s = cpytill(d,s,bufend,term,&len);
+ s = delimcpy(d, e, s, bufend, term, &len);
+ d += len;
if (s < bufend)
s++;
- d += len;
}
else {
if (*s == '\\')
@@ -4712,9 +4714,13 @@ register char *s;
term = '"';
if (!isALNUM(*s))
deprecate("bare << to mean <<\"\"");
- while (isALNUM(*s))
- *d++ = *s++;
- } /* assuming tokenbuf won't clobber */
+ for (; isALNUM(*s); s++) {
+ if (d < e)
+ *d++ = *s;
+ }
+ }
+ if (d >= tokenbuf + sizeof tokenbuf - 1)
+ croak("Delimiter for here document is too long");
*d++ = '\n';
*d = '\0';
len = d - tokenbuf;
@@ -4805,15 +4811,17 @@ char *start;
{
register char *s = start;
register char *d;
+ register char *e;
I32 len;
d = tokenbuf;
- s = cpytill(d, s+1, bufend, '>', &len);
- if (s < bufend)
- s++;
- else
+ e = tokenbuf + sizeof tokenbuf;
+ s = delimcpy(d, e, s + 1, bufend, '>', &len);
+ if (len >= sizeof tokenbuf)
+ croak("Excessively long <> operator");
+ if (s >= bufend)
croak("Unterminated <> operator");
-
+ s++;
if (*d == '$' && d[1]) d++;
while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
d++;
@@ -4956,11 +4964,13 @@ char *start;
{
register char *s = start;
register char *d;
+ register char *e;
I32 tryiv;
double value;
SV *sv;
I32 floatit;
char *lastub = 0;
+ static char number_too_long[] = "Number too long";
switch (*s) {
default:
@@ -5022,6 +5032,7 @@ char *start;
case '6': case '7': case '8': case '9': case '.':
decimal:
d = tokenbuf;
+ e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
floatit = FALSE;
while (isDIGIT(*s) || *s == '_') {
if (*s == '_') {
@@ -5029,19 +5040,22 @@ char *start;
warn("Misplaced _ in number");
lastub = ++s;
}
- else
+ else {
+ if (d >= e)
+ croak(number_too_long);
*d++ = *s++;
+ }
}
if (dowarn && lastub && s - lastub != 3)
warn("Misplaced _ in number");
if (*s == '.' && s[1] != '.') {
floatit = TRUE;
*d++ = *s++;
- while (isDIGIT(*s) || *s == '_') {
- if (*s == '_')
- s++;
- else
- *d++ = *s++;
+ for (; isDIGIT(*s) || *s == '_'; s++) {
+ if (d >= e)
+ croak(number_too_long);
+ if (*s != '_')
+ *d++ = *s;
}
}
if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
@@ -5050,8 +5064,11 @@ char *start;
*d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
if (*s == '+' || *s == '-')
*d++ = *s++;
- while (isDIGIT(*s))
+ while (isDIGIT(*s)) {
+ if (d >= e)
+ croak(number_too_long);
*d++ = *s++;
+ }
}
*d = '\0';
sv = NEWSV(92,0);
@@ -5255,7 +5272,7 @@ char *s;
where = SvPVX(where_sv);
}
msg = sv_2mortal(newSVpv(s, 0));
- sv_catpvf(msg, " at %S line %ld, ",
+ sv_catpvf(msg, " at %_ line %ld, ",
GvSV(curcop->cop_filegv), (long)curcop->cop_line);
if (context)
sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
@@ -5268,13 +5285,13 @@ char *s;
multi_end = 0;
}
if (in_eval & 2)
- warn("%S", msg);
+ warn("%_", msg);
else if (in_eval)
sv_catsv(GvSV(errgv), msg);
else
PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
if (++error_count >= 10)
- croak("%S has too many errors.\n", GvSV(curcop->cop_filegv));
+ croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
in_my = 0;
return 0;
}
diff --git a/util.c b/util.c
index 84670ba9c0..e78ad82863 100644
--- a/util.c
+++ b/util.c
@@ -282,28 +282,35 @@ xstat()
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-cpytill(to,from,fromend,delim,retlen)
+delimcpy(to, toend, from, fromend, delim, retlen)
register char *to;
+register char *toend;
register char *from;
register char *fromend;
register int delim;
I32 *retlen;
{
- char *origto = to;
-
- for (; from < fromend; from++,to++) {
+ register I32 tolen;
+ for (tolen = 0; from < fromend; from++, tolen++) {
if (*from == '\\') {
if (from[1] == delim)
from++;
- else if (from[1] == '\\')
- *to++ = *from++;
+ else {
+ if (to < toend)
+ *to++ = *from;
+ tolen++;
+ from++;
+ }
}
- else if (*from == delim)
+ else if (*from == delim) {
+ if (to < toend)
+ *to = '\0';
break;
- *to = *from;
+ }
+ if (to < toend)
+ *to++ = *from;
}
- *to = '\0';
- *retlen = to - origto;
+ *retlen = tolen;
return from;
}
@@ -1071,6 +1078,23 @@ register I32 len;
return newaddr;
}
+/* the SV for form() and mess() is not kept in an arena */
+
+static SV *
+mess_alloc()
+{
+ SV *sv;
+ XPVMG *any;
+
+ /* Create as PVMG now, to avoid any upgrading later */
+ New(905, sv, 1, SV);
+ Newz(905, any, 1, XPVMG);
+ SvFLAGS(sv) = SVt_PVMG;
+ SvANY(sv) = (void*)any;
+ SvREFCNT(sv) = 1 << 30; /* practically infinite */
+ return sv;
+}
+
#ifdef I_STDARG
char *
form(const char* pat, ...)
@@ -1088,18 +1112,11 @@ form(pat, va_alist)
#else
va_start(args);
#endif
- if (mess_sv == &sv_undef) {
- /* All late-destruction message must be short */
- vsprintf(tokenbuf, pat, args);
- }
- else {
- if (!mess_sv)
- mess_sv = NEWSV(905, 0);
- sv_vsetpvfn(mess_sv, pat, strlen(pat), &args,
- Null(SV**), 0, Null(bool));
- }
+ if (!mess_sv)
+ mess_sv = mess_alloc();
+ sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
- return (mess_sv == &sv_undef) ? tokenbuf : SvPVX(mess_sv);
+ return SvPVX(mess_sv);
}
char *
@@ -1110,23 +1127,16 @@ mess(pat, 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);
+ mess_sv = mess_alloc();
sv = mess_sv;
- sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool));
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
if (dirty)
sv_catpv(sv, dgd);
else {
if (curcop->cop_line)
- sv_catpvf(sv, " at %S line %ld",
+ sv_catpvf(sv, " at %_ 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) &&
@@ -1396,7 +1406,7 @@ char *nam, *val;
STRLEN namlen = strlen(nam);
STRLEN vallen = strlen(val ? val : "");
- New(9040, envstr, namlen + vallen + 3, char);
+ New(904, envstr, namlen + vallen + 3, char);
(void)sprintf(envstr,"%s=%s",nam,val);
if (!vallen) {
/* An attempt to delete the entry.
@@ -1452,6 +1462,21 @@ register I32 len;
}
#endif
+#ifndef HAS_MEMSET
+void *
+my_memset(loc,ch,len)
+register char *loc;
+register I32 ch;
+register I32 len;
+{
+ char *retval = loc;
+
+ while (len--)
+ *loc++ = ch;
+ return retval;
+}
+#endif
+
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
char *
my_bzero(loc,len)
@@ -1792,15 +1817,23 @@ int newfd;
close(newfd);
return fcntl(oldfd, F_DUPFD, newfd);
#else
- int fdtmp[256];
+#define DUP2_MAX_FDS 256
+ int fdtmp[DUP2_MAX_FDS];
I32 fdx = 0;
int fd;
if (oldfd == newfd)
return oldfd;
close(newfd);
- while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */
+ /* good enough for low fd's... */
+ while ((fd = dup(oldfd)) != newfd && fd >= 0) {
+ if (fdx >= DUP2_MAX_FDS) {
+ close(fd);
+ fd = -1;
+ break;
+ }
fdtmp[fdx++] = fd;
+ }
while (fdx > 0)
close(fdtmp[--fdx]);
return fd;
@@ -1967,7 +2000,7 @@ int flags;
{
SV *sv;
SV** svp;
- char spid[sizeof(int) * 3 + 1];
+ char spid[TYPE_CHARS(int)];
if (!pid)
return -1;
@@ -2023,7 +2056,7 @@ int pid;
int status;
{
register SV *sv;
- char spid[sizeof(int) * 3 + 1];
+ char spid[TYPE_CHARS(int)];
sprintf(spid, "%d", pid);
sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
diff --git a/vms/vms.c b/vms/vms.c
index e1977fb861..2fd6fc5afa 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -578,7 +578,7 @@ safe_popen(char *cmd, char *mode)
return Nullfp;
}
- New(7001,info,1,struct pipe_details);
+ New(1301,info,1,struct pipe_details);
/* create mailbox */
create_mbx(&chan,&namdsc);
@@ -792,7 +792,7 @@ do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
return NULL;
}
if (!outbuf) {
- if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
+ if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
else outbuf = __rmsexpand_retbuf;
}
if ((isunix = (strchr(filespec,'/') != NULL))) {
@@ -1033,7 +1033,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
}
retlen = dirlen + (addmfd ? 13 : 6);
if (buf) retspec = buf;
- else if (ts) New(7009,retspec,retlen+1,char);
+ else if (ts) New(1309,retspec,retlen+1,char);
else retspec = __fileify_retbuf;
if (addmfd) {
dirlen = lastdir - dir;
@@ -1114,7 +1114,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
/* They provided at least the name; we added the type, if necessary, */
if (buf) retspec = buf; /* in sys$parse() */
- else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
+ else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
else retspec = __fileify_retbuf;
strcpy(retspec,esa);
return retspec;
@@ -1133,7 +1133,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
/* There's more than one directory in the path. Just roll back. */
*cp1 = term;
if (buf) retspec = buf;
- else if (ts) New(7011,retspec,retlen+7,char);
+ else if (ts) New(1311,retspec,retlen+7,char);
else retspec = __fileify_retbuf;
strcpy(retspec,esa);
}
@@ -1148,7 +1148,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
}
retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
if (buf) retspec = buf;
- else if (ts) New(7012,retspec,retlen+16,char);
+ else if (ts) New(1312,retspec,retlen+16,char);
else retspec = __fileify_retbuf;
cp1 = strstr(esa,"][");
dirlen = cp1 - esa;
@@ -1176,7 +1176,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
}
else { /* This is a top-level dir. Add the MFD to the path. */
if (buf) retspec = buf;
- else if (ts) New(7012,retspec,retlen+16,char);
+ else if (ts) New(1312,retspec,retlen+16,char);
else retspec = __fileify_retbuf;
cp1 = esa;
cp2 = retspec;
@@ -1223,7 +1223,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
/* Trap simple rooted lnms, and return lnm:[000000] */
if (!strcmp(trndir+trnlen-2,".]")) {
if (buf) retpath = buf;
- else if (ts) New(7018,retpath,strlen(dir)+10,char);
+ else if (ts) New(1318,retpath,strlen(dir)+10,char);
else retpath = __pathify_retbuf;
strcpy(retpath,dir);
strcat(retpath,":[000000]");
@@ -1263,7 +1263,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
}
}
if (buf) retpath = buf;
- else if (ts) New(7013,retpath,retlen+1,char);
+ else if (ts) New(1313,retpath,retlen+1,char);
else retpath = __pathify_retbuf;
strncpy(retpath,dir,retlen-1);
if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
@@ -1308,7 +1308,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
dir[dirfab.fab$b_fns-1] == '>' ||
dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
if (buf) retpath = buf;
- else if (ts) New(7014,retpath,strlen(dir)+1,char);
+ else if (ts) New(1314,retpath,strlen(dir)+1,char);
else retpath = __pathify_retbuf;
strcpy(retpath,dir);
return retpath;
@@ -1365,7 +1365,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
*(dirnam.nam$l_type + 1) = '\0';
retlen = dirnam.nam$l_type - esa + 2;
if (buf) retpath = buf;
- else if (ts) New(7014,retpath,retlen,char);
+ else if (ts) New(1314,retpath,retlen,char);
else retpath = __pathify_retbuf;
strcpy(retpath,esa);
/* $PARSE may have upcased filespec, so convert output to lower
@@ -1403,7 +1403,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
{ expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
}
}
- New(7015,rslt,retlen+2+2*expand,char);
+ New(1315,rslt,retlen+2+2*expand,char);
}
else rslt = __tounixspec_retbuf;
if (strchr(spec,'/') != NULL) {
@@ -1519,7 +1519,7 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
if (path == NULL) return NULL;
if (buf) rslt = buf;
- else if (ts) New(7016,rslt,strlen(path)+9,char);
+ else if (ts) New(1316,rslt,strlen(path)+9,char);
else rslt = __tovmsspec_retbuf;
if (strpbrk(path,"]:>") ||
(dirend = strrchr(path,'/')) == NULL) {
@@ -1661,7 +1661,7 @@ static char *do_tovmspath(char *path, char *buf, int ts) {
if (buf) return buf;
else if (ts) {
vmslen = strlen(vmsified);
- New(7017,cp,vmslen+1,char);
+ New(1317,cp,vmslen+1,char);
memcpy(cp,vmsified,vmslen);
cp[vmslen] = '\0';
return cp;
@@ -1690,7 +1690,7 @@ static char *do_tounixpath(char *path, char *buf, int ts) {
if (buf) return buf;
else if (ts) {
unixlen = strlen(unixified);
- New(7017,cp,unixlen+1,char);
+ New(1317,cp,unixlen+1,char);
memcpy(cp,unixified,unixlen);
cp[unixlen] = '\0';
return cp;
@@ -1908,7 +1908,7 @@ getredirection(int *ac, char ***av)
* Allocate and fill in the new argument vector, Some Unix's terminate
* the list with an extra null pointer.
*/
- New(7002, argv, item_count+1, char *);
+ New(1302, argv, item_count+1, char *);
*av = argv;
for (j = 0; j < item_count; ++j, list_head = list_head->next)
argv[j] = list_head->value;
@@ -1995,11 +1995,11 @@ static void add_item(struct list_item **head,
{
if (*head == 0)
{
- New(7003,*head,1,struct list_item);
+ New(1303,*head,1,struct list_item);
*tail = *head;
}
else {
- New(7004,(*tail)->next,1,struct list_item);
+ New(1304,(*tail)->next,1,struct list_item);
*tail = (*tail)->next;
}
(*tail)->value = value;
@@ -2053,7 +2053,7 @@ unsigned long int zero = 0, sts;
char *string;
char *c;
- New(7005,string,resultspec.dsc$w_length+1,char);
+ New(1305,string,resultspec.dsc$w_length+1,char);
strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
string[resultspec.dsc$w_length] = '\0';
if (NULL == had_version)
@@ -2403,12 +2403,12 @@ opendir(char *name)
char dir[NAM$C_MAXRSS+1];
/* Get memory for the handle, and the pattern. */
- New(7006,dd,1,DIR);
+ New(1306,dd,1,DIR);
if (do_tovmspath(name,dir,0) == NULL) {
Safefree((char *)dd);
return(NULL);
}
- New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
+ New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
/* Fill in the fields; mainly playing with the descriptor. */
(void)sprintf(dd->pattern, "%s*.*",dir);
@@ -2467,7 +2467,7 @@ collectversions(dd)
/* Add the version wildcard, ignoring the "*.*" put on before */
i = strlen(dd->pattern);
- New(7008,text,i + e->d_namlen + 3,char);
+ New(1308,text,i + e->d_namlen + 3,char);
(void)strcpy(text, dd->pattern);
(void)sprintf(&text[i - 3], "%s;*", e->d_name);
diff --git a/win32/win32.c b/win32/win32.c
index ee50147538..0759df8f21 100644
--- a/win32/win32.c
+++ b/win32/win32.c
@@ -341,7 +341,7 @@ do_aspawn(void* really, void** mark, void** arglast)
SV *sv = (SV*)really;
SV** pSv = (SV**)mark;
- New(1110, argv, (arglast - mark) + 4, char*);
+ New(1310, argv, (arglast - mark) + 4, char*);
if(sv != Nullsv) {
cmd = SvPV(sv, length);
@@ -388,8 +388,8 @@ do_spawn(char *cmd)
/* see if there are shell metacharacters in it */
if(!HasRedirection(cmd)) {
- New(1102,argv, strlen(cmd) / 2 + 2, char*);
- New(1103,cmd2, strlen(cmd) + 1, char);
+ New(1301,argv, strlen(cmd) / 2 + 2, char*);
+ New(1302,cmd2, strlen(cmd) + 1, char);
strcpy(cmd2, cmd);
a = argv;
for (s = cmd2; *s;) {
@@ -473,7 +473,7 @@ opendir(char *filename)
* }
*/
/* Get us a DIR structure */
- Newz(1501, p, 1, DIR);
+ Newz(1303, p, 1, DIR);
if(p == NULL)
return NULL;
@@ -495,7 +495,7 @@ opendir(char *filename)
* the filenames that we find.
*/
idx = strlen(FindData.cFileName)+1;
- New(1502, p->start, idx, char);
+ New(1304, p->start, idx, char);
if(p->start == NULL) {
CROAK("opendir: malloc failed!\n");
}
diff --git a/win32/win32sck.c b/win32/win32sck.c
index 45f7ac1cbf..891438dac9 100644
--- a/win32/win32sck.c
+++ b/win32/win32sck.c
@@ -121,12 +121,9 @@ __declspec(thread) struct servent myservent;
void *
GetAddress(HINSTANCE hInstance, char *lpFunctionName)
{
- char buffer[512];
FARPROC proc = GetProcAddress(hInstance, lpFunctionName);
- if(proc == 0) {
- sprintf(buffer, "Unable to get address of %s in WSock32.dll", lpFunctionName);
- CROAK(buffer);
- }
+ if(proc == 0)
+ CROAK("Unable to get address of %s in WSock32.dll", lpFunctionName);
return proc;
}
@@ -240,7 +237,7 @@ myfdopen(int fd, char *mode)
/*
* If we get here, then fd is actually a socket.
*/
- Newz(1601, fp, 1, FILE);
+ Newz(1310, fp, 1, FILE);
if(fp == NULL) {
errno = ENOMEM;
return NULL;
View Lorry Controller Status