-----------------
+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
-----------------
: 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
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
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
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
#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
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
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;
}
dump_op(op)
register OP *op;
{
- SV *tmpsv;
-
dump("{\n");
if (op->op_seq)
PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq);
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 ||
{
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));
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--;
#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
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()) ;
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;
static void TranslateError
(const char *path, enum dyldErrorSource type, int number)
{
- char errorBuffer[128];
+ char *error;
unsigned int index;
static char *OFIErrorStrings[] =
{
};
#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 */)
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;
}
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()) ;
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;
-}
-
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) {
block_type
bool__amg
bor_amg
-buf
bufend
bufptr
bxor_amg
force_list
force_next
force_word
+form
free_tmps
gen_constant_list
gp_free
newSViv
newSVnv
newSVpv
+newSVpvf
newSVrv
newSVsv
newUNOP
sv_add_arena
sv_backoff
sv_bless
+sv_catpvf
sv_catpv
sv_catpvn
sv_catsv
sv_replace
sv_report_used
sv_reset
+sv_setpvf
sv_setiv
sv_setnv
sv_setptrobj
sv_untaint
sv_upgrade
sv_usepvn
+sv_vcatpvfn
+sv_vsetpvfn
taint_env
taint_proper
too_few_arguments
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))
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 */
}
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. */
(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",
} 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)?
: ",\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;
}
}
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 `",
#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 / /'`
2.0.5*|2.0-built*|2.1*)
usevfork='true'
usemymalloc='n'
- d_dosuid='define'
d_setregid='define'
d_setreuid='define'
d_setegid='undef'
usevfork='true'
usemymalloc='n'
libswanted=`echo $libswanted | sed 's/ malloc / /'`
- d_dosuid='define'
d_setregid='define'
d_setreuid='define'
d_setegid='undef'
# 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
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
# 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.
$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})) {
mainstack
maxscream
maxsysfd
+mess_sv
minus_F
minus_a
minus_c
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 {
$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,$_);
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 '*':
* 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
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);
}
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;
}
OP* op;
char* name;
{
- sprintf(tokenbuf,"Not enough arguments for %s", name);
- yyerror(tokenbuf);
+ yyerror(form("Not enough arguments for %s", name));
return op;
}
OP *op;
char* name;
{
- sprintf(tokenbuf,"Too many arguments for %s", name);
- yyerror(tokenbuf);
+ yyerror(form("Too many arguments for %s", name));
return op;
}
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;
}
{
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 ? '&' : '%');
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) {
/* 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:
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;
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));
}
ENTER;
SAVESPTR(curpad);
SAVESPTR(comppad);
+ SAVESPTR(comppad_name);
SAVESPTR(compcv);
cv = compcv = (CV*)NEWSV(1104,0);
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));
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);
}
}
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) {
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,
OP *cvop;
char *proto = 0;
CV *cv = 0;
+ GV *namegv = 0;
int optional = 0;
I32 arg = 0;
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);
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++;
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++;
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;
default:
oops:
croak("Malformed prototype for %s: %s",
- CvNAME(cv),SvPV((SV*)cv,na));
+ gv_ename(namegv), SvPV((SV*)cv, na));
}
}
else
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;
}
*/
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
};
dlmax = 128; \
laststatval = -1; \
laststype = OP_STAT; \
+ mess_sv = Nullsv; \
} STMT_END
static void find_beginning _((void));
(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 */
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 \"; \
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;
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
#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\" \
-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' \
-e '/^#[ ]*undef[ ]/b' \
-e '/^#[ ]*endif/b' \
-e 's/^[ ]*#.*//' \
- %s | %s -C %s %s",
+ %s | %S -C %S %s",
#ifdef LOC_SED
LOC_SED,
#else
#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 */
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");
#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
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");
}
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 */
/* 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
IEXT AV * Ipreambleav;
IEXT int Ilaststatval IINIT(-1);
IEXT I32 Ilaststype IINIT(OP_STAT);
+IEXT SV * Imess_sv;
#undef IEXT
#undef IINIT
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>
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
=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
=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
=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>.
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.
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. :-)
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,
=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
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)'
=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.
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
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:
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
"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.
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.
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?
=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
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
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
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.
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
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
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
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).
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
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
# 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)
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
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
Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
All rights reserved. See L<perlfaq> for distribution information.
+
=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
=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
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
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
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
$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
$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);
}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:
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,
@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.
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?
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:
Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
All rights reserved. See L<perlfaq> for distribution information.
+
=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
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.
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
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
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:
# 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) );
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"
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
$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.
=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?
Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
All rights reserved. See L<perlfaq> for distribution information.
+
=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
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
=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.
Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
All rights reserved. See L<perlfaq> for distribution information.
+
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
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) = @_;
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
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:
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.
=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
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?
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.
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
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?
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
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
=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?
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?
=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 *
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,
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
=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
}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.
=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:
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:
->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
(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
=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).
Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
All rights reserved. See L<perlfaq> for distribution information.
+
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
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
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:
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
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>
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,
=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>
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>>
=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
=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 $)
=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
=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
=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?
=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
=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()?
=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
=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?
=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}?
=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
=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?
=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
=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 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
=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
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
* 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
}
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);
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
IBW i = TOPi;
- i <<= shift;
+ i = BWi(i) << shift;
SETi(BWi(i));
}
else {
IBW shift = POPi;
if (op->op_private & HINT_INTEGER) {
IBW i = TOPi;
- i >>= shift;
+ i = BWi(i) >> shift;
SETi(BWi(i));
}
else {
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)) {
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);;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
- return G_SCALAR;
+ return G_VOID;
switch (cxstack[cxix].blk_gimme) {
case G_VOID:
register CONTEXT *cx;
SV *sv;
char *name;
- char *tmpname;
+ char *tryname;
+ SV *namesv = Nullsv;
SV** svp;
I32 gimme = G_SCALAR;
PerlIO *tryrsfp = 0;
/* 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;
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;
}
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;
#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";
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*/
;
}
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");
}
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);
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);
if (!(IoFLAGS(io) & IOf_UNTAINT))
SvTAINTED_on(bufsv);
SP = ORIGMARK;
- sv_setpvn(TARG, buf, bufsize);
+ sv_setpvn(TARG, namebuf, bufsize);
PUSHs(TARG);
RETURN;
}
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
dSP; dTARGET;
#ifdef HAS_SYMLINK
char *tmps;
+ char buf[MAXPATHLEN];
int len;
+
tmps = POPp;
len = readlink(tmps, buf, sizeof buf);
EXTEND(SP, 1);
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)));
#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,...))
#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, SV* buffer, int maxlen));
I32 cxinc _((void));
void deb _((const char* pat,...)) __attribute__((format(printf,1,2)));
void deb_growlevel _((void));
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)
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));
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));
I32 keyword _((char* d, I32 len));
void leave_scope _((I32 base));
void lex_end _((void));
-void lex_start _((SV *line));
+void lex_start _((SV* line));
OP* linklist _((OP* op));
OP* list _((OP* o));
OP* listkids _((OP* o));
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));
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
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 _((char* pack));
OP* newGVREF _((I32 type, OP* o));
OP* newHVREF _((OP* o));
HV* newHV _((void));
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));
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 _((char* newcoll));
+void perl_new_ctype _((char* newctype));
+void perl_new_numeric _((char* newcoll));
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));
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));
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 _((long* longp));
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));
#ifndef VMS
I32 setenv_getix _((char* nam));
#endif
-void setdefout _((GV *gv));
+void setdefout _((GV* gv));
char* sharepvn _((char* sv, I32 len, U32 hash));
HEK* share_hek _((char* sv, I32 len, U32 hash));
Signal_t sighandler _((int sig));
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));
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));
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
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));
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... */
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. */
/* 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)
/*
- 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";
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:
default:
FAIL("corrupted regexp opcode");
}
- if (p != NULL)
- (void) strcat(buf, p);
- return(buf);
+ if (p)
+ sv_catpv(sv, p);
}
#endif /* DEBUGGING */
#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
break;
case SAVEt_FREEOP:
ptr = SSPOPPTR;
- curpad = AvARRAY(comppad);
+ if (comppad)
+ curpad = AvARRAY(comppad);
op_free((OP*)ptr);
break;
case SAVEt_FREEPV:
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|
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|
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);
}
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
{
register char *s;
int olderrno;
+ SV *tsv;
if (!sv) {
*lp = 0;
}
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)) {
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);
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)
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))
*lp = 0;
return "";
}
- *s = '\0';
*lp = s - SvPVX(sv);
SvCUR_set(sv, *lp);
SvPOK_on(sv);
/* 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;
}
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;
}
}
+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;
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;
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;
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)
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));
shift;
print join(' ', reverse @_)."\n";
}
+ sub PRINTF {
+ shift;
+ my $fmt = shift;
+ print sprintf($fmt, @_)."\n";
+ }
sub TIEHANDLE {
bless {}, shift;
}
$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"
{
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)) {
/* 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));
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(' ');");
/* 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);
}
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__:
/*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();
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";
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;
}
#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
{
SV *sv;
SV** svp;
- char spid[16];
+ char spid[sizeof(int) * 3 + 1];
if (!pid)
return -1;
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);
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++;
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;
projects / p5sagit/p5-mst-13.2.git / commitdiff