--- /dev/null
+: basic variables
+package=perl
+baserev=4.1
+patchbranch=1
+mydiff='diff -c'
+maintname='Larry Wall'
+maintloc='lwall@netlabs.com'
+ftpsite=''
+orgname='NetLabs, Inc.'
+newsgroups='comp.lang.perl'
+recipients=''
+ftpdir=''
+
+: derivative variables--do not change
+revbranch="$baserev.$patchbranch"
+packver='1'
--- /dev/null
+Article 38050 of comp.sys.amiga.programmer:
+Newsgroups: comp.sys.amiga.programmer
+Path: netlabs!news.cerf.net!usc!howland.reston.ans.net!pipex!uunet!majipoor.cygnus.com!fnf
+From: fnf@cygnus.com (Fred Fish)
+Subject: Re: FreshFish-dec93 CD; broken perl thereon
+Message-ID: <CKBuwv.7qF@cygnus.com>
+Organization: Cygnus Support, Mountain View, CA
+References: <1994Jan20.095600.8371@philips.oz.au> <D> <bruce.0r61@zuhause.mn.org>
+Date: Fri, 28 Jan 1994 06:48:29 GMT
+Lines: 129
+
+In article <bruce.0r61@zuhause.mn.org>,
+Bruce Albrecht <bruce@zuhause.MN.ORG> wrote:
+>In article <1994Jan20.095600.8371@philips.oz.au> gduncan@philips.oz.au (Gary Duncan) writes:
+>Me too. I don't have the December Fresh Fish, so I can't comment on it,
+>but I have been wondering what it will take to do a fresh port of it anyway.
+
+The diffs that I applied to the base FSF distribution are:
+
+diff -rc perl-4.036-fsf/Configure perl-4.036-amiga/Configure
+*** perl-4.036-fsf/Configure Mon Feb 8 20:37:48 1993
+--- perl-4.036-amiga/Configure Mon Sep 27 21:46:16 1993
+***************
+*** 4023,4029 ****
+ eval $ans;;
+ esac
+ chmod +x doSH
+! ./doSH
+
+ if $contains '^depend:' [Mm]akefile >/dev/null 2>&1; then
+ dflt=n
+--- 4023,4029 ----
+ eval $ans;;
+ esac
+ chmod +x doSH
+! sh doSH
+
+ if $contains '^depend:' [Mm]akefile >/dev/null 2>&1; then
+ dflt=n
+diff -rc perl-4.036-fsf/Makefile.SH perl-4.036-amiga/Makefile.SH
+*** perl-4.036-fsf/Makefile.SH Mon Feb 8 20:35:21 1993
+--- perl-4.036-amiga/Makefile.SH Tue Sep 28 07:16:24 1993
+***************
+*** 349,355 ****
+
+ test: perl
+ - cd t && chmod +x TEST */*.t
+! - cd t && (rm -f perl; $(SLN) ../perl perl) && ./perl TEST </dev/tty
+
+ clist:
+ echo $(c) | tr ' ' '\012' >.clist
+--- 349,355 ----
+
+ test: perl
+ - cd t && chmod +x TEST */*.t
+! - cd t && (rm -f perl; $(SLN) ../perl perl) && ./perl TEST
+
+ clist:
+ echo $(c) | tr ' ' '\012' >.clist
+***************
+*** 373,376 ****
+ ln Makefile ../Makefile
+ ;;
+ esac
+! rm -f makefile
+--- 373,377 ----
+ ln Makefile ../Makefile
+ ;;
+ esac
+! #rm -f makefile (AmigaDOS is case-independent)
+!
+diff -rc perl-4.036-fsf/makedepend.SH perl-4.036-amiga/makedepend.SH
+*** perl-4.036-fsf/makedepend.SH Mon Feb 8 20:36:27 1993
+--- perl-4.036-amiga/makedepend.SH Mon Sep 27 22:06:33 1993
+***************
+*** 63,71 ****
+ $cat /dev/null >.deptmp
+ $rm -f *.c.c c/*.c.c
+ if test -f Makefile; then
+! cp Makefile makefile
+ fi
+! mf=makefile
+ if test -f $mf; then
+ defrule=`<$mf sed -n \
+ -e '/^\.c\.o:.*;/{' \
+--- 63,71 ----
+ $cat /dev/null >.deptmp
+ $rm -f *.c.c c/*.c.c
+ if test -f Makefile; then
+! cp Makefile Makefile.bak
+ fi
+! mf=Makefile
+ if test -f $mf; then
+ defrule=`<$mf sed -n \
+ -e '/^\.c\.o:.*;/{' \
+diff -rc perl-4.036-fsf/perl.h perl-4.036-amiga/perl.h
+*** perl-4.036-fsf/perl.h Mon Feb 8 20:36:01 1993
+--- perl-4.036-amiga/perl.h Mon Sep 27 22:06:19 1993
+***************
+*** 79,85 ****
+--- 79,87 ----
+ */
+ #define HAS_ALARM
+ #define HAS_CHOWN
++ #ifndef amigados
+ #define HAS_CHROOT
++ #endif
+ #define HAS_FORK
+ #define HAS_GETLOGIN
+ #define HAS_GETPPID
+***************
+*** 93,99 ****
+--- 95,103 ----
+ * password and group functions in general. All Unix systems do.
+ */
+ #define HAS_GROUP
++ #ifndef amigados
+ #define HAS_PASSWD
++ #endif
+
+ #endif /* !MSDOS */
+
+diff -rc perl-4.036-fsf/x2p/Makefile.SH perl-4.036-amiga/x2p/Makefile.SH
+*** perl-4.036-fsf/x2p/Makefile.SH Mon Feb 8 20:36:33 1993
+--- perl-4.036-amiga/x2p/Makefile.SH Mon Sep 27 22:07:15 1993
+***************
+*** 157,160 ****
+ ln Makefile ../Makefile
+ ;;
+ esac
+! rm -f makefile
+--- 157,160 ----
+ ln Makefile ../Makefile
+ ;;
+ esac
+! #rm -f makefile
+
+
+
+
+
+
--- /dev/null
+#!./perl
+$foo = GOOD;
+{
+ local(*foo) = \$bar;
+ $bar = BAR;
+ print $foo;
+}
+print $foo;
--- /dev/null
+Article 18849 of comp.lang.perl:
+Path: netlabs!news.cerf.net!usc!howland.reston.ans.net!xlink.net!zib-berlin.de!zrz.TU-Berlin.DE!w204zrz!koen1830
+From: koen1830@w204zrz.zrz.tu-berlin.de (Andreas Koenig)
+Newsgroups: comp.lang.perl
+Subject: Bug in find2perl
+Date: 14 Feb 1994 09:43:16 GMT
+Organization: mal franz, mal anna
+Lines: 22
+Message-ID: <2jnh3k$hcv@brachio.zrz.TU-Berlin.DE>
+Reply-To: k@franz.ww.TU-Berlin.DE
+NNTP-Posting-Host: w204zrz.zrz.tu-berlin.de
+Cc:
+
+Hi all,
+
+I've encountered a bug in find2perl when used with the -prune Option.
+As there have been some bugreports recently, *and* also because there
+has to be fixed an incompatibility with perl5, I don't try to offer a
+fix, sorry. The bug comes and goes like this (verified for SUN and
+NeXT):
+
+%/usr/bin/find foo -print
+foo
+foo/bar
+foo/bar/baz
+%/usr/bin/find foo -prune -print
+foo
+%perl /usr/local/bin/find2perl foo -prune -print | perl
+foo
+foo/bar
+%perl5a5 /usr/local/bin/find2perl foo -prune -print | perl5a5
+Final $ should be \$ or $name at /usr/local/bin/find2perl line 553, at end of string
+syntax error at /usr/local/bin/find2perl line 553, near ""^$tmp$""
+Execution of /usr/local/bin/find2perl aborted due to compilation errors.
+
+
+
+++ /dev/null
-print( STDOUT "hello\n" )
+++ /dev/null
-Article 433 of comp.os.386bsd.apps:
-Path: netlabs!news.cerf.net!usc!howland.reston.ans.net!spool.mu.edu!bloom-beacon.mit.edu!ai-lab!life.ai.mit.edu!mycroft
-From: mycroft@trinity.gnu.ai.mit.edu (Charles Hannum)
-Newsgroups: comp.os.386bsd.apps
-Subject: Re: Perl-4.036?
-Date: 06 Sep 1993 19:01:10 GMT
-Organization: MIT Artificial Intelligence Lab
-Lines: 9
-Message-ID: <MYCROFT.93Sep6150110@trinity.gnu.ai.mit.edu>
-References: <26fptu$1q1@terminator.rs.itd.umich.edu> <26fve4$ivf@homer.cs.mcgill.ca>
-NNTP-Posting-Host: trinity.gnu.ai.mit.edu
-In-reply-to: storm@cs.mcgill.ca's message of 6 Sep 1993 18:27:16 GMT
-
-
- Perl 4.036 comipled without a single hitch under NetBSD 0.9 last
- week. It failed the db test, but I suspect that is due to the new
- db stuff under NetBSD and the like...
-
-Yes. The perl test seems to expect the database to be put in
-`foo.pag' and `foo.dir', which isn't the case any more. I suspect
-lwall will fix this soon.
-
-
-
+++ /dev/null
-shift->[0]
New functions include: abs(), chr(), uc(), ucfirst(), lc(), lcfirst()
+ require with a bare word now does an immediate require at compile time.
+ So "require POSIX" is equivalent to "BEGIN { require 'POSIX.pm' }".
+
+ require with a number checks to see that the version of Perl that is
+ currently running is at least that number.
+
+ Dynamic loading of external modules is now supported.
+
+ There is a new quote form qw//, which is equivalent to split(' ', q//).
+
+ Assignment of a reference to a glob value now just replaces the
+ single element of the glob corresponding to the reference type:
+ *foo = \$bar, *foo = \&bletch;
+
+ Filehandle methods are now supported:
+ output_autoflush STDOUT 1;
+
+ There is now an "English" module that provides human readable translations
+ for cryptic variable names.
+
+ Autoload stubs can now call the replacement subroutine with goto &realsub.
+
+ Subroutines can be defined lazily in any package by declaring an AUTOLOAD
+ routine, which will be called if a non-existent subroutine is called in
+ that package.
+
Incompatibilities
-----------------
@ now always interpolates an array in double-quotish strings. Some programs
Symbols starting with _ are no longer forced into package main, except
for $_ itself (and @_, etc.).
- Double-quoted strings may no longer end with an unescaped $.
+ Double-quoted strings may no longer end with an unescaped $ or @.
+
+ Negative array subscripts now count from the end of the array.
+
+ The comma operator in a scalar context is now guaranteed to give a
+ scalar context to its arguments.
#define nextkey(db,key) dbm_nextkey(db)
static int
-XS_NDBM_File_dbm_new(ix, sp, items)
+XS_NDBM_File_dbm_new(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 4 || items > 4) {
+ if (items != 4) {
croak("Usage: NDBM_File::new(dbtype, filename, flags, mode)");
}
{
NDBM_File RETVAL;
RETVAL = dbm_new(dbtype, filename, flags, mode);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setptrobj(ST(0), RETVAL, "NDBM_File");
}
- return sp;
+ return ax;
}
static int
-XS_NDBM_File_dbm_DESTROY(ix, sp, items)
+XS_NDBM_File_dbm_DESTROY(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 1 || items > 1) {
+ if (items != 1) {
croak("Usage: NDBM_File::DESTROY(db)");
}
{
NDBM_File db;
- if (sv_isa(ST(1), "NDBM_File"))
- db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ if (SvROK(ST(1)))
+ db = (NDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- croak("db is not of type NDBM_File");
+ croak("db is not a reference");
dbm_close(db);
}
- return sp;
+ return ax;
}
static int
-XS_NDBM_File_dbm_fetch(ix, sp, items)
+XS_NDBM_File_dbm_fetch(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 2 || items > 2) {
+ if (items != 2) {
croak("Usage: NDBM_File::fetch(db, key)");
}
{
datum RETVAL;
if (sv_isa(ST(1), "NDBM_File"))
- db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (NDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type NDBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
RETVAL = dbm_fetch(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
}
- return sp;
+ return ax;
}
static int
-XS_NDBM_File_dbm_store(ix, sp, items)
+XS_NDBM_File_dbm_store(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
if (items < 3 || items > 4) {
int RETVAL;
if (sv_isa(ST(1), "NDBM_File"))
- db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (NDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type NDBM_File");
}
RETVAL = dbm_store(db, key, value, flags);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
- return sp;
+ return ax;
}
static int
-XS_NDBM_File_dbm_delete(ix, sp, items)
+XS_NDBM_File_dbm_delete(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 2 || items > 2) {
+ if (items != 2) {
croak("Usage: NDBM_File::delete(db, key)");
}
{
int RETVAL;
if (sv_isa(ST(1), "NDBM_File"))
- db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (NDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type NDBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
RETVAL = dbm_delete(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
- return sp;
+ return ax;
}
static int
-XS_NDBM_File_dbm_firstkey(ix, sp, items)
+XS_NDBM_File_dbm_firstkey(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 1 || items > 1) {
+ if (items != 1) {
croak("Usage: NDBM_File::firstkey(db)");
}
{
datum RETVAL;
if (sv_isa(ST(1), "NDBM_File"))
- db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (NDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type NDBM_File");
RETVAL = dbm_firstkey(db);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
}
- return sp;
+ return ax;
}
static int
-XS_NDBM_File_nextkey(ix, sp, items)
+XS_NDBM_File_nextkey(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 2 || items > 2) {
+ if (items != 2) {
croak("Usage: NDBM_File::nextkey(db, key)");
}
{
datum RETVAL;
if (sv_isa(ST(1), "NDBM_File"))
- db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (NDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type NDBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
RETVAL = nextkey(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
}
- return sp;
+ return ax;
}
static int
-XS_NDBM_File_dbm_error(ix, sp, items)
+XS_NDBM_File_dbm_error(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 1 || items > 1) {
+ if (items != 1) {
croak("Usage: NDBM_File::error(db)");
}
{
int RETVAL;
if (sv_isa(ST(1), "NDBM_File"))
- db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (NDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type NDBM_File");
RETVAL = dbm_error(db);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
- return sp;
+ return ax;
}
static int
-XS_NDBM_File_dbm_clearerr(ix, sp, items)
+XS_NDBM_File_dbm_clearerr(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 1 || items > 1) {
+ if (items != 1) {
croak("Usage: NDBM_File::clearerr(db)");
}
{
int RETVAL;
if (sv_isa(ST(1), "NDBM_File"))
- db = (NDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (NDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type NDBM_File");
RETVAL = dbm_clearerr(db);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
- return sp;
+ return ax;
}
-int init_NDBM_File(ix,sp,items)
+int boot_NDBM_File(ix,ax,items)
int ix;
-int sp;
+int ax;
int items;
{
char* file = __FILE__;
#define DBM_REPLACE 0
static int
-XS_ODBM_File_odbm_new(ix, sp, items)
+XS_ODBM_File_odbm_new(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 4 || items > 4) {
+ if (items != 4) {
croak("Usage: ODBM_File::new(dbtype, filename, flags, mode)");
}
{
sv_setptrobj(ST(0), RETVAL, "ODBM_File");
}
}
- return sp;
+ return ax;
}
static int
-XS_ODBM_File_DESTROY(ix, sp, items)
+XS_ODBM_File_DESTROY(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 1 || items > 1) {
+ if (items != 1) {
croak("Usage: ODBM_File::DESTROY(db)");
}
{
ODBM_File db;
- if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ if (SvROK(ST(1)))
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- croak("db is not of type ODBM_File");
+ croak("db is not a reference");
dbmrefcnt--;
dbmclose();
}
- return sp;
+ return ax;
}
static int
-XS_ODBM_File_odbm_fetch(ix, sp, items)
+XS_ODBM_File_odbm_fetch(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 2 || items > 2) {
+ if (items != 2) {
croak("Usage: ODBM_File::fetch(db, key)");
}
{
datum RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type ODBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
RETVAL = odbm_fetch(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
}
- return sp;
+ return ax;
}
static int
-XS_ODBM_File_odbm_store(ix, sp, items)
+XS_ODBM_File_odbm_store(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
if (items < 3 || items > 4) {
int RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type ODBM_File");
}
RETVAL = odbm_store(db, key, value, flags);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
- return sp;
+ return ax;
}
static int
-XS_ODBM_File_odbm_delete(ix, sp, items)
+XS_ODBM_File_odbm_delete(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 2 || items > 2) {
+ if (items != 2) {
croak("Usage: ODBM_File::delete(db, key)");
}
{
int RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type ODBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
RETVAL = odbm_delete(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
- return sp;
+ return ax;
}
static int
-XS_ODBM_File_odbm_firstkey(ix, sp, items)
+XS_ODBM_File_odbm_firstkey(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 1 || items > 1) {
+ if (items != 1) {
croak("Usage: ODBM_File::firstkey(db)");
}
{
datum RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type ODBM_File");
RETVAL = odbm_firstkey(db);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
}
- return sp;
+ return ax;
}
static int
-XS_ODBM_File_odbm_nextkey(ix, sp, items)
+XS_ODBM_File_odbm_nextkey(ix, ax, items)
register int ix;
-register int sp;
+register int ax;
register int items;
{
- if (items < 2 || items > 2) {
+ if (items != 2) {
croak("Usage: ODBM_File::nextkey(db, key)");
}
{
datum RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
croak("db is not of type ODBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
RETVAL = odbm_nextkey(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
}
- return sp;
+ return ax;
}
-int init_ODBM_File(ix,sp,items)
+int boot_ODBM_File(ix,ax,items)
int ix;
-int sp;
+int ax;
int items;
{
char* file = __FILE__;
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <sys/utsname.h>
+
+#define HAS_UNAME
+
+#ifndef HAS_GETPGRP
+#define getpgrp(a,b) not_here("getpgrp")
+#endif
+#ifndef HAS_NICE
+#define nice(a) not_here("nice")
+#endif
+#ifndef HAS_READLINK
+#define readlink(a,b,c) not_here("readlink")
+#endif
+#ifndef HAS_SETPGID
+#define setpgid(a,b) not_here("setpgid")
+#endif
+#ifndef HAS_SETPGRP
+#define setpgrp(a,b) not_here("setpgrp")
+#endif
+#ifndef HAS_SETSID
+#define setsid() not_here("setsid")
+#endif
+#ifndef HAS_SYMLINK
+#define symlink(a,b) not_here("symlink")
+#endif
+#ifndef HAS_TCGETPGRP
+#define tcgetpgrp(a) not_here("tcgetpgrp")
+#endif
+#ifndef HAS_TCSETPGRP
+#define tcsetpgrp(a,b) not_here("tcsetpgrp")
+#endif
+#ifndef HAS_TIMES
+#define times(a) not_here("times")
+#endif
+#ifndef HAS_UNAME
+#define uname(a) not_here("uname")
+#endif
+#ifndef HAS_WAITPID
+#define waitpid(a,b,c) not_here("waitpid")
+#endif
+
+static int
+not_here(s)
+char *s;
+{
+ croak("POSIX::%s not implemented on this architecture", s);
+ return -1;
+}
+
+static int
+XS_POSIX__exit(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 1) {
+ croak("Usage: POSIX::_exit(status)");
+ }
+ {
+ int status = (int)SvIV(ST(1));
+
+ _exit(status);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_chdir(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 1) {
+ croak("Usage: POSIX::chdir(path)");
+ }
+ {
+ char * path = SvPV(ST(1),na);
+ int RETVAL;
+
+ RETVAL = chdir(path);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_chmod(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 2) {
+ croak("Usage: POSIX::chmod(path, mode)");
+ }
+ {
+ char * path = SvPV(ST(1),na);
+ mode_t mode = (int)SvIV(ST(2));
+ int RETVAL;
+
+ RETVAL = chmod(path, mode);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_close(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 1) {
+ croak("Usage: POSIX::close(fd)");
+ }
+ {
+ int fd = (int)SvIV(ST(1));
+ int RETVAL;
+
+ RETVAL = close(fd);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_dup(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 1) {
+ croak("Usage: POSIX::dup(fd)");
+ }
+ {
+ int fd = (int)SvIV(ST(1));
+ int RETVAL;
+
+ RETVAL = dup(fd);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_dup2(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 2) {
+ croak("Usage: POSIX::dup2(fd1, fd2)");
+ }
+ {
+ int fd1 = (int)SvIV(ST(1));
+ int fd2 = (int)SvIV(ST(2));
+ int RETVAL;
+
+ RETVAL = dup2(fd1, fd2);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_fdopen(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 2) {
+ croak("Usage: POSIX::fdopen(fd, type)");
+ }
+ {
+ int fd = (int)SvIV(ST(1));
+ char * type = SvPV(ST(2),na);
+ FILE * RETVAL;
+
+ RETVAL = fdopen(fd, type);
+ ST(0) = sv_newmortal();
+ sv_setnv(ST(0), (double)(unsigned long)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_fstat(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 2) {
+ croak("Usage: POSIX::fstat(fd, buf)");
+ }
+ {
+ int fd = (int)SvIV(ST(1));
+ struct stat * buf = (struct stat*)sv_grow(ST(2),sizeof(struct stat));
+ int RETVAL;
+
+ RETVAL = fstat(fd, buf);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ SvCUR(ST(2)) = sizeof(struct stat);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_getpgrp(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 1) {
+ croak("Usage: POSIX::getpgrp(pid)");
+ }
+ {
+ int pid = (int)SvIV(ST(1));
+ int RETVAL;
+
+ RETVAL = getpgrp(pid);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_link(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::link()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = link();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_lseek(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::lseek()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = lseek();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_lstat(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::lstat()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = lstat();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_mkdir(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::mkdir()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = mkdir();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_nice(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 1) {
+ croak("Usage: POSIX::nice(incr)");
+ }
+ {
+ int incr = (int)SvIV(ST(1));
+ int RETVAL;
+
+ RETVAL = nice(incr);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_open(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::open()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = open();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_pipe(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::pipe()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = pipe();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_read(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::read()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = read();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_readlink(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 3) {
+ croak("Usage: POSIX::readlink(path, buf, bufsiz)");
+ }
+ {
+ char * path = SvPV(ST(1),na);
+ char * buf = sv_grow(ST(2), SvIV(ST(3)));
+ int bufsiz = (int)SvIV(ST(3));
+ int RETVAL;
+
+ RETVAL = readlink(path, buf, bufsiz);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_rename(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::rename()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = rename();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_rmdir(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::rmdir()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = rmdir();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_setgid(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::setgid()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = setgid();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_setpgid(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 2) {
+ croak("Usage: POSIX::setpgid(pid, pgid)");
+ }
+ {
+ pid_t pid = (int)SvIV(ST(1));
+ pid_t pgid = (int)SvIV(ST(2));
+ int RETVAL;
+
+ RETVAL = setpgid(pid, pgid);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_setpgrp(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 2) {
+ croak("Usage: POSIX::setpgrp(pid, pgrp)");
+ }
+ {
+ int pid = (int)SvIV(ST(1));
+ int pgrp = (int)SvIV(ST(2));
+ int RETVAL;
+
+ RETVAL = setpgrp(pid, pgrp);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_setsid(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::setsid()");
+ }
+ {
+ pid_t RETVAL;
+
+ RETVAL = setsid();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_setuid(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::setuid()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = setuid();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_stat(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::stat()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = stat();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_symlink(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::symlink()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = symlink();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_system(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::system()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = system();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_tcgetpgrp(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 1) {
+ croak("Usage: POSIX::tcgetpgrp(fd)");
+ }
+ {
+ int fd = (int)SvIV(ST(1));
+ pid_t RETVAL;
+
+ RETVAL = tcgetpgrp(fd);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_tcsetpgrp(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 2) {
+ croak("Usage: POSIX::tcsetpgrp(fd, pgrp_id)");
+ }
+ {
+ int fd = (int)SvIV(ST(1));
+ pid_t pgrp_id = (int)SvIV(ST(2));
+ int RETVAL;
+
+ RETVAL = tcsetpgrp(fd, pgrp_id);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_times(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 1) {
+ croak("Usage: POSIX::times(tms)");
+ }
+ {
+ struct tms * tms = (struct tms*)sv_grow(ST(1), sizeof(struct tms));
+ int RETVAL;
+
+ RETVAL = times(tms);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ SvCUR(ST(1)) = sizeof(struct tms);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_umask(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::umask()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = umask();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_uname(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::uname()");
+ }
+ {
+ int RETVAL;
+ dSP;
+ struct utsname utsname;
+ sp--;
+ if (uname(&utsname) >= 0) {
+ EXTEND(sp, 5);
+ PUSHs(sv_2mortal(newSVpv(utsname.sysname, 0)));
+ PUSHs(sv_2mortal(newSVpv(utsname.nodename, 0)));
+ PUSHs(sv_2mortal(newSVpv(utsname.release, 0)));
+ PUSHs(sv_2mortal(newSVpv(utsname.version, 0)));
+ PUSHs(sv_2mortal(newSVpv(utsname.machine, 0)));
+ }
+ return sp - stack_base;
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_unlink(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::unlink()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = unlink();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_utime(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::utime()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = utime();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_wait(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::wait()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = wait();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_waitpid(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 3) {
+ croak("Usage: POSIX::waitpid(pid, statusp, options)");
+ }
+ {
+ int pid = (int)SvIV(ST(1));
+ int statusp = (int)SvIV(ST(2));
+ int options = (int)SvIV(ST(3));
+ int RETVAL;
+
+ RETVAL = waitpid(pid, &statusp, options);
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ sv_setiv(ST(2), (I32)statusp);
+ }
+ return ax;
+}
+
+static int
+XS_POSIX_write(ix, ax, items)
+register int ix;
+register int ax;
+register int items;
+{
+ if (items != 0) {
+ croak("Usage: POSIX::write()");
+ }
+ {
+ int RETVAL;
+
+ RETVAL = write();
+ ST(0) = sv_newmortal();
+ sv_setiv(ST(0), (I32)RETVAL);
+ }
+ return ax;
+}
+
+int boot_POSIX(ix,ax,items)
+int ix;
+int ax;
+int items;
+{
+ char* file = __FILE__;
+
+ newXSUB("POSIX::_exit", 0, XS_POSIX__exit, file);
+ newXSUB("POSIX::chdir", 0, XS_POSIX_chdir, file);
+ newXSUB("POSIX::chmod", 0, XS_POSIX_chmod, file);
+ newXSUB("POSIX::close", 0, XS_POSIX_close, file);
+ newXSUB("POSIX::dup", 0, XS_POSIX_dup, file);
+ newXSUB("POSIX::dup2", 0, XS_POSIX_dup2, file);
+ newXSUB("POSIX::fdopen", 0, XS_POSIX_fdopen, file);
+ newXSUB("POSIX::fstat", 0, XS_POSIX_fstat, file);
+ newXSUB("POSIX::getpgrp", 0, XS_POSIX_getpgrp, file);
+ newXSUB("POSIX::link", 0, XS_POSIX_link, file);
+ newXSUB("POSIX::lseek", 0, XS_POSIX_lseek, file);
+ newXSUB("POSIX::lstat", 0, XS_POSIX_lstat, file);
+ newXSUB("POSIX::mkdir", 0, XS_POSIX_mkdir, file);
+ newXSUB("POSIX::nice", 0, XS_POSIX_nice, file);
+ newXSUB("POSIX::open", 0, XS_POSIX_open, file);
+ newXSUB("POSIX::pipe", 0, XS_POSIX_pipe, file);
+ newXSUB("POSIX::read", 0, XS_POSIX_read, file);
+ newXSUB("POSIX::readlink", 0, XS_POSIX_readlink, file);
+ newXSUB("POSIX::rename", 0, XS_POSIX_rename, file);
+ newXSUB("POSIX::rmdir", 0, XS_POSIX_rmdir, file);
+ newXSUB("POSIX::setgid", 0, XS_POSIX_setgid, file);
+ newXSUB("POSIX::setpgid", 0, XS_POSIX_setpgid, file);
+ newXSUB("POSIX::setpgrp", 0, XS_POSIX_setpgrp, file);
+ newXSUB("POSIX::setsid", 0, XS_POSIX_setsid, file);
+ newXSUB("POSIX::setuid", 0, XS_POSIX_setuid, file);
+ newXSUB("POSIX::stat", 0, XS_POSIX_stat, file);
+ newXSUB("POSIX::symlink", 0, XS_POSIX_symlink, file);
+ newXSUB("POSIX::system", 0, XS_POSIX_system, file);
+ newXSUB("POSIX::tcgetpgrp", 0, XS_POSIX_tcgetpgrp, file);
+ newXSUB("POSIX::tcsetpgrp", 0, XS_POSIX_tcsetpgrp, file);
+ newXSUB("POSIX::times", 0, XS_POSIX_times, file);
+ newXSUB("POSIX::umask", 0, XS_POSIX_umask, file);
+ newXSUB("POSIX::uname", 0, XS_POSIX_uname, file);
+ newXSUB("POSIX::unlink", 0, XS_POSIX_unlink, file);
+ newXSUB("POSIX::utime", 0, XS_POSIX_utime, file);
+ newXSUB("POSIX::wait", 0, XS_POSIX_wait, file);
+ newXSUB("POSIX::waitpid", 0, XS_POSIX_waitpid, file);
+ newXSUB("POSIX::write", 0, XS_POSIX_write, file);
+}
--- /dev/null
+#!/usr/local/bin/perl5
+#
+# This document is in the public domain.
+#
+# The purpose is to document by example some of the new Perl5 features.
+# It also functions as a mini test suite; you can extracted the
+# expected output using:
+# perl -ne 'm/.*prints ``(.*)..$/ && print $1,"\n";'
+# There are a couple of places that print out internal address so it's
+# not perfect yet, those should be fixed.
+#
+# Thanks to the following for their input:
+# Johan.Vromans@NL.net
+# Daniel Faken <absinthe@viva.chem.washington.edu>
+# Tom Christiansen <tchrist@wraeththu.cs.colorado.edu>
+# Dean Roehrich <roehrich@ferrari.cray.com>
+# Larry Wall <lwall@netlabs.com>
+#
+# TODO when I get perl5a6 to play with
+# *foo = \&func; # replaces only function (etc)
+# AUTOLOAD { ...; } # called if method not found
+# goto &func; # goto's a function
+# require FOOBAR; # loads FOOBAR.pm
+# @ISA
+#
+# import()/@EXPORT/etc
+
+# my
+ # static scoping
+ sub samp1 { print $z,"\n"; }
+ sub samp2 { my($z) = "world"; &samp1; }
+ $z = "hello"; &samp2; # prints ``hello''
+
+# package;
+ # for catching non-local variable references
+ sub samp3 {
+ my $x = shift; # local() would work also
+ package; # empty package
+ $main::count += $x; # this is ok.
+ # $y = 1; # compile time error
+ }
+
+# =>
+ # works like comma (,); use for key/value pairs
+ # sometimes used to disambiguate the final expression in a block
+ # might someday supply warnings if you get out of sync
+ %foo = ( abc => foo );
+ print $foo{abc},"\n"; # prints ``foo''
+
+# ::
+ # works like tick (') (use of ' is deprecated in perl5)
+ print $main::foo{abc},"\n"; # prints ``foo''
+
+# bless ref;
+ # Bless takes a reference and returns an "object"
+ $oref = bless \$scalar;
+
+# ->
+ # dereferences an "object"
+ $x = { def => bar }; # $x is ref to anonymous hash
+ print $x->{def},"\n"; # prints ``bar''
+
+ # method derefs must be bless'ed
+ {
+ package sample;
+ sub samp4 { my($this) = shift; print $this->{def},"\n"; }
+ sub samp5 { print "samp5: @_\n"; }
+ $main::y = bless $main::x; # $x is ref, $y is "object"
+ }
+ $y->samp4(); # prints ``bar''
+
+ # indirect object calls
+ samp5 $y arglist; # prints ``samp5: sample=HASH(0xa85e0) arglist''
+
+ # static method calls (often used for constructors, see below)
+ samp5 sample arglist; # prints ``samp5: sample arglist''
+
+# function calls without &
+ sub samp6 { print "look ma\n"; }
+ samp6; # prints ``look ma''
+
+# ref
+ # returns "object" type
+ {
+ package OBJ1;
+ $x = bless \$y; # returns "object" $x in "class" OBJ1
+ print ref $x,"\n"; # prints ``OBJ1''
+ }
+
+ # and non-references return undef.
+ $z = 1;
+ print "non-ref\n" if !defined(ref $z); # prints ``non-ref''
+
+ # ref's to "builtins" return type
+ print ref \$ascalar,"\n"; # prints ``SCALAR''
+ print ref \@array,"\n"; # prints ``ARRAY''
+ print ref \%hash,"\n"; # prints ``HASH''
+ sub func { print shift,"\n"; }
+ print ref \&func,"\n"; # prints ``CODE''
+ print ref \\$scalar,"\n"; # prints ``REF''
+
+# tie
+ # bind a variable to a package with magic functions:
+ # new, fetch, store, delete, firstkey, nextkey (XXX: others???)
+ # Usage: tie variable, PackageName, ARGLIST
+ {
+ package TIEPACK;
+ sub new { print "NEW: @_\n"; my($class, $x) = @_; bless \$x }
+ sub fetch { print "fetch @_\n"; my($this) = @_; ${$this} }
+ sub store { print "store @_\n"; my($this, $x) = @_; ${$this} = $x }
+ sub DESTROY { print "DESTROY @_\n" }
+ }
+ tie $h, TIEPACK, "black_tie"; # prints ``NEW: TIEPACK black_tie''
+ print $h, "\n"; # prints ``fetch TIEPACK=SCALAR(0x882a0)''
+ # prints ``black_tie''
+ $h = 'bar'; # prints ``store TIEPACK=SCALAR(0x882a0) bar''
+ untie $h; # DESTROY (XXX: broken in perl5a5???)
+
+# References and Anonymous data-structures
+ $sref = \$scalar; # $$sref is scalar
+ $aref = \@array; # @$aref is array
+ $href = \%hash; # %$href is hash table
+ $fref = \&func; # &$fref is function
+ $refref = \$fref; # ref to ref to function
+ &$$refref("call the function"); # prints ``call the function''
+
+ %hash = ( abc => foo ); # hash (just like perl4)
+ print $hash{abc},"\n"; # prints ``foo''
+ $ref = { abc => bar }; # reference to anon hash
+ print $ref->{abc},"\n"; # prints ``bar''
+
+ @ary = ( 0, 1, 2 ); # array (just like perl4)
+ print $ary[1],"\n"; # prints ``1''
+ $ref = [ 3, 4, 5 ]; # reference to anon array
+ print $ref->[1],"\n"; # prints ``4''
+
+# Nested data-structures
+ @foo = ( 0, { name => foobar }, 2, 3 ); # $#foo == 3
+ $aref = [ 0, { name => foobar }, 2, 3 ]; # ref to anon array
+ $href = { # ref to hash of arrays
+ John => [ Mary, Pat, Blanch ],
+ Paul => [ Sally, Jill, Jane ],
+ Mark => [ Ann, Bob, Dawn ],
+ };
+ print $href->{Paul}->[0], "\n"; # prints ``Sally''
+ print $href->{Paul}[0],"\n"; # shorthand version, prints ``Sally''
+
+# Multiple Inheritence (get rich quick :-)
+ {
+ package OBJ2; sub abc { print "abc\n"; }
+ package OBJ3; sub def { print "def\n"; }
+ package OBJ4; @ISA = ("OBJ2", "OBJ3");
+ $x = bless { foo => bar };
+ $x->abc; # prints ``abc''
+ $x->def; # prints ``def''
+ }
+
+# Packages, Classes, Objects, Methods, Constructors, Destructors, etc.
+ # XXX: I'll add more explinations/samples about the above here
+ {
+ package OBJ5;
+ sub new { print "NEW: @_\n"; my($x) = "empty"; bless \$x }
+ sub DESTROY { print "DESTROY\n" }
+ sub output { my($this) = shift; print "value = $$this\n"; }
+ }
+ # Constructors are often written as static method calls:
+ $x = new OBJ5; # prints ``NEW: OBJ5''
+ $x->output; # prints ``value = empty''
+ # The destructor is responsible for calling any base class destructors.
+ undef $x;
SDBM_File RETVAL;
RETVAL = sdbm_new(dbtype, filename, flags, mode);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setptrobj(ST(0), RETVAL, "SDBM_File");
}
return sp;
{
SDBM_File db;
- if (sv_isa(ST(1), "SDBM_File"))
+ if (SvROK(ST(1)))
db = (SDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- croak("db is not of type SDBM_File");
+ croak("db is not a reference");
sdbm_close(db);
}
return sp;
key.dptr = SvPV(ST(2), key.dsize);;
RETVAL = sdbm_fetch(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
}
return sp;
}
RETVAL = sdbm_store(db, key, value, flags);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
return sp;
key.dptr = SvPV(ST(2), key.dsize);;
RETVAL = sdbm_delete(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
return sp;
croak("db is not of type SDBM_File");
RETVAL = sdbm_firstkey(db);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
}
return sp;
key.dptr = SvPV(ST(2), key.dsize);;
RETVAL = nextkey(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
}
return sp;
croak("db is not of type SDBM_File");
RETVAL = sdbm_error(db);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
return sp;
croak("db is not of type SDBM_File");
RETVAL = sdbm_clearerr(db);
- ST(0) = sv_mortalcopy(&sv_undef);
+ ST(0) = sv_newmortal();
sv_setiv(ST(0), (I32)RETVAL);
}
return sp;
}
-int init_SDBM_File(ix,sp,items)
+int boot_SDBM_File(ix,sp,items)
int ix;
int sp;
int items;
+++ /dev/null
-Article 1475 of comp.lang.tcl:
-Path: netlabs!news!usc!cs.utexas.edu!sun-barr!ames!agate!sprite.Berkeley.EDU!ouster
-From: ouster@sprite.Berkeley.EDU (John Ousterhout)
-Newsgroups: comp.lang.tcl
-Subject: Planning for Tcl 7.0
-Message-ID: <1avu22INN5ao@agate.berkeley.edu>
-Date: 8 Oct 92 00:06:26 GMT
-Organization: U.C. Berkeley Sprite Project
-Lines: 156
-NNTP-Posting-Host: tyranny.berkeley.edu
-
-
-For the last year I've made only small changes to Tcl while focussing
-on the canvas and text widgets for Tk. I'm now making plans to catch
-up on a bunch of much-needed bug fixes and enhancements to Tcl. Some
-of the changes I'm considering are not backwards-compatible. The
-purpose of this message is to let know know what changes I'm considering
-for Tcl 7.0 and to solicit feedback. I'm particularly interested in
-comments on the changes that are incompatible: I'll probably drop
-the changes for which I get lots of negative feedback and not much
-positive feedback. If there are other changes that you think are
-important but aren't contained on this list, let me know and I may add
-them.
-
-Incompatible changes:
----------------------
-
-The changes listed below are likely to require changes to existing
-scripts and/or C code. Each change includes an explanation of why the
-change might be useful. I'd like to know whether or not you think the change
-is useful enough to justify the incompatibility.
-
-1. Eliminate the "|" option in the "open" command. Instead, add a
-"popen" command that does the same thing. Rationale: in the current
-implementation you can't open a file whose name begins with "|".
-Also, I think the "popen" command would be more logical.
-
-2. Eliminate the Tcl_WaitPids procedure and use the waitpid POSIX call
-instead. Also change the wait code to periodically poll for dead
-child processes so that zombie processes don't get left around forever.
-Rationale: the current code tends to leave zombies around in some
-situations. Switching to waitpid should solve this problem in a
-relatively portable fashion. The only incompatibility will be for
-C procedures that call Tcl_WaitPids; they'll have to switch to call
-waitpid instead. I'll provide a compatibility version of waitpid for
-use on systems that don't have it yet.
-
-3. Clean up backslash processing in several ways:
- - Change backslash-newline to eat up all the whitespace following the
- newline and replace the sequence with a single whitespace character.
- Right now it only eats up the newline character and replaces it
- with an empty string. Rationale: this would be more consistent
- with other programs that process backslash-newline sequences.
- - Eliminate the sequences \Mxx, \Cxxx, and \e.
- Rationale: these sequences are left around from ancient times.
- They're not particular compatible with any other program. I
- should have removed them in Tcl 6.0 but didn't. They did get
- removed from the documentation, however, so no-one should be
- using them (?).
- - Change \x (where x is not one of the characters that gets special
- backslash treatment) to expand to x, not \x.
- Rationale: the current behavior is inconsistent with all other
- programs I know of that handle backslashes, and I think it's
- confusing.
- - Change "format" so it doesn't do an additional layer of backslash
- processing on its format string.
- Rationale: I don't know why it currently behaves as it does, and
- I think it's confusing.
-
-4. Change "regsub" so that when no match occurs it sets the result
-variable to the original string, rather than leaving it unmodified.
-Rationale: the current behavior results in extra tests of the regsub
-result that could sometimes be avoided with the proposed new behavior.
-I doubt that there's much code that will break with the change (this
-would have to be code that depends on the result variable *not* being
-modified).
-
-5. Change the name "UNIX" in the "errorCode" variable to "POSIX".
-Rationale: I suspect that I'm eventually going to get a call from the
-USL lawyers on this one if I don't change it. Better to change it now
-in an orderly fashion so I don't have change it hastily in the future.
-
-6. Change glob to return only the names of existing files.
-Rationale: at present "glob */foo" expands * and generates a result
-without checking to see if each directory has a "foo" file in it. This
-makes the current behavior incompatible with csh, for example. One
-question is whether constructs like "glob {a,b}.c" should also check for
-the existence of each of the files. At present they don't (i.e. a.c and
-b.c will be returned even if they don't exist), but neither does csh. My
-inclination is to make the behavior match csh (names containing *?[] are
-checked for existence, others aren't). I'd be interested to hear
-opinions on this one: check all names for existence, check only names
-including *?[] (for csh compatibility), or keep it as it is?
-
-7. Change "gets" so it returns 1 for success and 0 for failure. At present
-it returns the line length for success and -1 for failure.
-Rationale: this would allow slightly simple Tcl scripts: you could just
-say
- while [gets $f line] {...}
-instead of
- while {[gets $f line] >= 0} {...}
-I'm not really convinced that this one is important enough to justify the
-incompatibility, so it won't take much negative feedback to kill it.
-
-Other changes:
---------------
-
-The changes listed below shouldn't introduce substantial compatibility
-problems. Of course, any change can potentially cause scripts to stop
-working (e.g. almost any change will break the test suite), but very
-few if any people should be affected by these changes.
-
-8. Implement Tcl_CreateExternVar() procedure along lines proposed by
-Andreas Stolcke to tie a C variable to a Tcl variable with automatic
-updates between them.
-
-9. Changes to exec:
- - Allow redirection to an existing file descriptor in "exec",
- with a mechanism like >&1 or >& stdout.
- - Allow file names immediately after ">" and "<" without
- intervening spaces.
-
-10. Changes related to files:
- - Fix Scott Bolte bug (closing stdin and stdout).
- - Move TclGetOpenFile and OpenFile stuff to tcl.h so that they're
- accessible to applications.
- - Extend access modes in open to include the complete set of POSIX
- access modes (such as O_EXCL and O_NONBLOCK).
-
-11. Re-instate Tcl_WatchInterp to notify application when an interpreter
-is deleted.
-
-12. Add "elseif" mechanism to "if" command for chaining "else {if ..."
-constructs more cleanly. Require exact matches on "then" and "else"
-keywords.
-
-13. Remove UNIX system call declarations from tclUnix.h. Use them from
-unistd.h instead, and provide a default version of unistd.h for systems
-that don't have one.
-
-14. Changes in the expr command, mostly following suggestions made by
-George Howlett a long time ago:
- - Increase precision of floating-point results.
- - Make floating-point numbers always print with a point.
- - Add transcendental functions like sin and exp.
- - Add explicit integer and floating conversion operations.
- - Don't promote large integers to floating-point automatically.
- - Allow multiple arguments to expr command.
-
-15. Extend lsort to allow alternate sorting mechanisms, like numeric,
-or client-supplied.
-
-16. Allow alternate pattern-matching forms (e.g. exact or regexp) for
-lsearch and case.
-
-17. Add XPG/3 positional argument specifiers to format (code contributed
-by Mark Diekhans).
-
-18. Change "file readlink" to return an error on systems that don't
-support it rather than removing the option entirely.
-
-19. Add a mechanism for scheduling a Tcl command to be executed when the
-interpreter reaches a clean point. This is needed for things like
-signal support.
-
-20. Change upvar so that you can refer to an element of an array as
-well as a whole array.
-
-
-Must-have external packages
- POSIX
- X/Motif/whatever
+Modules
+ POSIX (in progress)
+ X/Motif/Tk etc.
+
+Tie Modules
+ VecArray Implement array using vec()
+ SubstrArray Implement array using substr()
+ VirtualArray Implement array using a file
+ ShiftSplice Defines shift et al in terms of splice method
Bugs
- BEGIN { require 'perldb.pl' }
Make yyparse recursion longjmp() proof.
- perl -c shell_script bug
- fix the need for double ^D on $x
- STDOUT->print("howdy\n");
- %ENV not there
Make "delete $array{$key} while ($key) = each %array" safe
- using unpack(P,$ref) shouldn't unref the ref
- binary function is missing
- wrong line reported for runtime elsif condition error
- unreference variable warnings busted (but don't warn on $seen{$key}++)
+ Wrong line reported for runtime elsif condition error
Regexp extensions
/m for multiline
/f for fixed variable interpolation?
Rewrite regexp parser for better integrated optimization
-Nice to have
+Would be nice to have
Profiler
pack "(stuff)*"
lexperl
Bundled perl preprocessor
- FILEHANDLE methods
Make $[ compile-time instead of run-time
+ Use posix calls internally where possible
+ const variables
+ gettimeofday
+ bytecompiler
+ format BOTTOM
+ willcall()
+ -iprefix.
+ All ARGV input should act like <>
+ Multiple levels of warning
+
+Pragmas ("assume" maybe?)
+ integer, float
+ nodebug, debug
+ autocroak?
Optimizations
- Make specialized allocators
Optimize switch statements
Optimize foreach on array
Optimize foreach (1..1000000)
Cache hash value?
Optimize away @_ where possible
sfio?
+ "one pass" global destruction
Need to think more about
- ref in list context
- When does split() go to @_?
- Figure out BEGIN { ... @ARGV ... }
- Implement eval once? (Unnecessary with cache?)
- Detect inconsistent linkage when using -DDEBUGGING?
+ ref function in list context
Populate %SIG at startup if appropriate
- Multiple levels of warning
+ write HANDLE [formats].
Vague possibilities
- readonly variables
sub mysplice(@, $, $, ...)
data prettyprint function? (or is it, as I suspect, a lib routine?)
Nested destructors
make tr/// return histogram in list context?
undef wantarray in void context
- goto &replacement_routine
- filehandle references
Loop control on do{} et al
Explicit switch statements
perl to C translator
built-in globbing
compile to real threaded code
structured types
+ paren counting in tokener to queue remote expectations
-#define ST(s) stack_base[sp + s]
+#define ST(s) stack_base[ax + s]
{
SV *sv;
- if (SvMAGICAL(av)) {
+ if (SvRMAGICAL(av)) {
if (mg_find((SV*)av,'P')) {
if (key < 0)
return 0;
- sv = sv_2mortal(NEWSV(61,0));
+ sv = sv_newmortal();
mg_copy((SV*)av, sv, 0, key);
if (!lval) {
mg_get((SV*)sv);
if (AvREAL(av))
sv = NEWSV(5,0);
else
- sv = sv_mortalcopy(&sv_undef);
+ sv = sv_newmortal();
return av_store(av,key,sv);
}
}
return 0;
}
- if (SvMAGICAL(av)) {
+ if (SvRMAGICAL(av)) {
if (mg_find((SV*)av,'P')) {
mg_copy((SV*)av, val, 0, key);
return 0;
if (AvFILL(av) < key) {
while (++AvFILL(av) < key) {
if (ary[AvFILL(av)] != Nullsv) {
- sv_free(ary[AvFILL(av)]);
+ SvREFCNT_dec(ary[AvFILL(av)]);
ary[AvFILL(av)] = Nullsv;
}
}
}
if (ary[key])
- sv_free(ary[key]);
+ SvREFCNT_dec(ary[key]);
}
ary[key] = val;
- if (SvMAGICAL(av)) {
+ if (SvSMAGICAL(av)) {
MAGIC* mg = SvMAGIC(av);
sv_magic(val, (SV*)av, tolower(mg->mg_type), 0, key);
mg_set((SV*)av);
SvPVX(av) = (char*)(AvARRAY(av) - key);
}
for (key = 0; key <= AvMAX(av); key++)
- sv_free(AvARRAY(av)[key]);
+ SvREFCNT_dec(AvARRAY(av)[key]);
AvFILL(av) = -1;
Zero(AvARRAY(av), AvMAX(av)+1, SV*);
}
}
if (AvREAL(av)) {
for (key = 0; key <= AvMAX(av); key++)
- sv_free(AvARRAY(av)[key]);
+ SvREFCNT_dec(AvARRAY(av)[key]);
}
Safefree(AvALLOC(av));
AvALLOC(av) = 0;
return Nullsv;
retval = AvARRAY(av)[AvFILL(av)];
AvARRAY(av)[AvFILL(av)--] = Nullsv;
- if (SvMAGICAL(av))
+ if (SvSMAGICAL(av))
mg_set((SV*)av);
return retval;
}
SvPVX(av) = (char*)(AvARRAY(av) + 1);
AvMAX(av)--;
AvFILL(av)--;
- if (SvMAGICAL(av))
+ if (SvSMAGICAL(av))
mg_set((SV*)av);
return retval;
}
fill = -1;
if (fill <= AvMAX(av)) {
AvFILL(av) = fill;
- if (SvMAGICAL(av))
+ if (SvSMAGICAL(av))
mg_set((SV*)av);
}
else {
--- /dev/null
+#!./perl
+
+require POSIX; import POSIX;
+
+print &getpid, "\n";
+
+@uname = &uname;
+print "@uname\n";
--- /dev/null
+#!./perl
+
+print "";
+@c = caller;
+print "@c";
+__END__
+
+require POSIX; import POSIX getpid;
+
+print &getpid, "\n";
--- /dev/null
+#!./perl
+
+sub fib
+{
+ ($_[0] < 2) ? $_[0] : &fib($_[0]-1) + &fib($_[0]-2);
+}
+
+sub myruntime
+{
+ local(@t) = times; # in seconds
+ $t[0] + $t[1];
+}
+
+$x = (shift || 20);
+print "Starting fib($x)\n";
+$before = &myruntime;
+$y = &fib($x);
+$after = &myruntime;
+printf("Done. Result $y in %g cpu seconds.\n", $after-$before);
+
: or customize here
case "$file" in
- array) ;;
- cmd) ;;
- cons) ;;
- consarg) ;;
- doarg) ;;
- doio) ;;
- dolist) ;;
- dump) ;;
- eval) ;;
- form) ;;
- hash) ;;
- malloc) ;;
- perl) ;;
- perly) ;;
- regcomp) ;;
- regexec) ;;
- stab) ;;
- str) ;;
- toke) ;;
- usersub) ;;
- util) ;;
- tarray) ;;
- tcmd) ;;
- tcons) ;;
- tconsarg) ;;
- tdoarg) ;;
- tdoio) ;;
- tdolist) ;;
- tdump) ;;
- teval) ;;
- tform) ;;
- thash) ;;
- tmalloc) ;;
- tperl) ;;
- tperly) ;;
- tregcomp) ;;
- tregexec) ;;
- tstab) ;;
- tstr) ;;
- ttoke) ;;
- tusersub) ;;
- tutil) ;;
+ SDBM*) ccflags="$ccflags -pic";;
*) ;;
esac
--- /dev/null
+#!./perl
+
+@ARGV = "./config.sh";
+
+undef $/;
+$_ = <>;
+s:^#!/bin/sh\n::;
+s/'undef'/undef/g;
+s/\n(\w+)=/;\n\$Config{'$1'} = /g;
+s/;\n\$Config/\n\$Config/;
+
+open STDOUT, ">lib/Config.pm"
+ or die "Can't open lib/Config.pm: $!\n";
+$myver = sprintf("%.3f", $]);
+print <<"ENDOFBEG";
+package Config;
+require Exporter;
+\@ISA = (Exporter);
+\@EXPORT = qw(%Config);
+
+\$] == $myver or die sprintf
+ "Perl lib version ($myver) doesn't match executable version (%.3f)\\n", \$];
+
+ENDOFBEG
+
+print $_;
+
GV * dfoutgv;
AV * savearray;
AV * argarray;
- AV * comppad;
U16 olddepth;
U8 hasargs;
};
#define PUSHSUB(cx) \
cx->blk_sub.cv = cv; \
- cx->blk_sub.gv = gv; \
cx->blk_sub.olddepth = CvDEPTH(cv); \
cx->blk_sub.hasargs = hasargs;
#define POPSUB(cx) \
if (cx->blk_sub.hasargs) { /* put back old @_ */ \
- av_free(cx->blk_sub.argarray); \
GvAV(defgv) = cx->blk_sub.savearray; \
} \
- if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \
- if (CvDELETED(cx->blk_sub.cv)) \
- sv_free((SV*)cx->blk_sub.cv); \
+ if (cx->blk_sub.cv) { \
+ if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \
+ if (CvDELETED(cx->blk_sub.cv)) \
+ SvREFCNT_dec((SV*)cx->blk_sub.cv); \
+ } \
}
#define POPFORMAT(cx) \
OP * old_eval_root;
};
-#define PUSHEVAL(cx,n) \
+#define PUSHEVAL(cx,n,fgv) \
cx->blk_eval.old_in_eval = in_eval; \
cx->blk_eval.old_op_type = op->op_type; \
cx->blk_eval.old_name = n; \
#define blk_loop cx_u.cx_blk.blk_u.blku_loop
/* Enter a block. */
-#define PUSHBLOCK(cx,t,s) CXINC, cx = &cxstack[cxstack_ix], \
+#define PUSHBLOCK(cx,t,sp) CXINC, cx = &cxstack[cxstack_ix], \
cx->cx_type = t, \
- cx->blk_oldsp = s - stack_base, \
+ cx->blk_oldsp = sp - stack_base, \
cx->blk_oldcop = curcop, \
cx->blk_oldmarksp = markstack_ptr - markstack, \
cx->blk_oldscopesp = scopestack_ix, \
cx->blk_oldretsp = retstack_ix, \
cx->blk_oldpm = curpm, \
cx->blk_gimme = gimme; \
- if (debug & 4) \
- fprintf(stderr,"Entering block %d, type %d\n", \
- cxstack_ix, t);
+ DEBUG_l( fprintf(stderr,"Entering block %d, type %s\n", \
+ cxstack_ix, block_type[t]); )
/* Exit a block (RETURN and LAST). */
#define POPBLOCK(cx) cx = &cxstack[cxstack_ix--], \
retstack_ix = cx->blk_oldretsp, \
curpm = cx->blk_oldpm, \
gimme = cx->blk_gimme; \
- if (debug & 4) \
- fprintf(stderr,"Leaving block %d, type %d\n", \
- cxstack_ix+1,cx->cx_type);
+ DEBUG_l( fprintf(stderr,"Leaving block %d, type %s\n", \
+ cxstack_ix+1,block_type[cx->cx_type]); )
/* Continue a block elsewhere (NEXT and REDO). */
#define TOPBLOCK(cx) cx = &cxstack[cxstack_ix], \
OP * xcv_root;
I32 (*xcv_usersub)();
I32 xcv_userindex;
+ GV * xcv_gv;
GV * xcv_filegv;
long xcv_depth; /* >= 2 indicates recursive call */
AV * xcv_padlist;
#define CvROOT(sv) ((XPVCV*)SvANY(sv))->xcv_root
#define CvUSERSUB(sv) ((XPVCV*)SvANY(sv))->xcv_usersub
#define CvUSERINDEX(sv) ((XPVCV*)SvANY(sv))->xcv_userindex
+#define CvGV(sv) ((XPVCV*)SvANY(sv))->xcv_gv
#define CvFILEGV(sv) ((XPVCV*)SvANY(sv))->xcv_filegv
#define CvDEPTH(sv) ((XPVCV*)SvANY(sv))->xcv_depth
#define CvPADLIST(sv) ((XPVCV*)SvANY(sv))->xcv_padlist
#include "EXTERN.h"
#include "perl.h"
-#ifdef I_VARARGS
-# include <varargs.h>
+#ifdef STANDARD_C
+# include <stdarg.h>
+#else
+# ifdef I_VARARGS
+# include <varargs.h>
+# endif
#endif
void deb_growlevel();
-# ifndef I_VARARGS
+#if !defined(STANDARD_C) && !defined(I_VARARGS)
+
+/*
+ * Fallback on the old hackers way of doing varargs
+ */
+
/*VARARGS1*/
-void deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
-char *pat;
+void
+deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
+ char *pat;
{
register I32 i;
- fprintf(stderr,"%-4ld",(long)curop->cop_line);
+ fprintf(stderr,"(%s:%ld)\t",
+ SvPVX(GvSV(curcop->cop_filegv)),(long)curcop->cop_line);
for (i=0; i<dlevel; i++)
fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
fprintf(stderr,pat,a1,a2,a3,a4,a5,a6,a7,a8);
}
+
+#else /* !defined(STANDARD_C) && !defined(I_VARARGS) */
+
+# ifdef STANDARD_C
+void
+deb(char *pat, ...)
# else
/*VARARGS1*/
-#ifdef __STDC__
-void deb(char *pat,...)
-#else
-void deb(va_alist)
-va_dcl
-#endif
+void
+deb(pat, va_alist)
+ char *pat;
+ va_dcl
+# endif
{
va_list args;
- char *pat;
register I32 i;
- va_start(args);
- fprintf(stderr,"%-4ld",(long)curcop->cop_line);
+ fprintf(stderr,"(%s:%ld)\t",
+ SvPVX(GvSV(curcop->cop_filegv)),(long)curcop->cop_line);
for (i=0; i<dlevel; i++)
fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
- pat = va_arg(args, char *);
+# if STANDARD_C
+ va_start(args, pat);
+# else
+ va_start(args);
+# endif
(void) vfprintf(stderr,pat,args);
va_end( args );
}
-# endif
+#endif /* !defined(STANDARD_C) && !defined(I_VARARGS) */
void
deb_growlevel()
--- /dev/null
+#include <dlfcn.h>
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+static int
+XS_DynamicLoader_bootstrap(ix, sp, items)
+register int ix;
+register int sp;
+register int items;
+{
+ if (items < 1 || items > 1) {
+ croak("Usage: DynamicLoader::bootstrap(package)");
+ }
+ {
+ char* package = SvPV(ST(1),na);
+ void* obj = 0;
+ int (*bootproc)();
+ char tmpbuf[1024];
+ char tmpbuf2[128];
+ AV *av = GvAVn(incgv);
+ I32 i;
+
+ for (i = 0; i <= AvFILL(av); i++) {
+ (void)sprintf(tmpbuf, "%s/auto/%s/%s.so",
+ SvPVx(*av_fetch(av, i, TRUE), na), package, package);
+ if (obj = dlopen(tmpbuf,1))
+ break;
+ }
+ if (!obj)
+ croak("Can't find loadable object for package %s in @INC", package);
+
+ sprintf(tmpbuf2, "boot_%s", package);
+ bootproc = (int (*)())dlsym(obj, tmpbuf2);
+ if (!bootproc)
+ croak("Shared object %s contains no %s function", tmpbuf, tmpbuf2);
+ bootproc();
+
+ ST(0) = sv_mortalcopy(&sv_yes);
+ }
+ return sp;
+}
+
+int
+boot_DynamicLoader(ix,sp,items)
+int ix;
+int sp;
+int items;
+{
+ char* file = __FILE__;
+
+ newXSUB("DynamicLoader::bootstrap", 0, XS_DynamicLoader_bootstrap, file);
+}
FILE *saveofp = Nullfp;
char savetype = ' ';
+ SAVEFREEPV(myname);
mode[0] = mode[1] = mode[2] = '\0';
name = myname;
forkprocess = 1; /* assume true if no fork */
name[--len] = '\0';
if (!io)
io = GvIO(gv) = newIO();
- else if (io->ifp) {
- fd = fileno(io->ifp);
- if (io->type == '-')
+ else if (IoIFP(io)) {
+ fd = fileno(IoIFP(io));
+ if (IoTYPE(io) == '-')
result = 0;
else if (fd <= maxsysfd) {
- saveifp = io->ifp;
- saveofp = io->ofp;
- savetype = io->type;
+ saveifp = IoIFP(io);
+ saveofp = IoOFP(io);
+ savetype = IoTYPE(io);
result = 0;
}
- else if (io->type == '|')
- result = my_pclose(io->ifp);
- else if (io->ifp != io->ofp) {
- if (io->ofp) {
- result = fclose(io->ofp);
- fclose(io->ifp); /* clear stdio, fd already closed */
+ else if (IoTYPE(io) == '|')
+ result = my_pclose(IoIFP(io));
+ else if (IoIFP(io) != IoOFP(io)) {
+ if (IoOFP(io)) {
+ result = fclose(IoOFP(io));
+ fclose(IoIFP(io)); /* clear stdio, fd already closed */
}
else
- result = fclose(io->ifp);
+ result = fclose(IoIFP(io));
}
else
- result = fclose(io->ifp);
+ result = fclose(IoIFP(io));
if (result == EOF && fd > maxsysfd)
fprintf(stderr,"Warning: unable to close filehandle %s properly.\n",
GvENAME(gv));
- io->ofp = io->ifp = Nullfp;
+ IoOFP(io) = IoIFP(io) = Nullfp;
}
if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
mode[1] = *name++;
else {
mode[1] = '\0';
}
- io->type = *name;
+ IoTYPE(io) = *name;
if (*name == '|') {
/*SUPPRESS 530*/
for (name++; isSPACE(*name); name++) ;
TAINT_PROPER("open");
name++;
if (*name == '>') {
- mode[0] = io->type = 'a';
+ mode[0] = IoTYPE(io) = 'a';
name++;
}
else
#endif
goto say_false;
}
- if (GvIO(gv) && GvIO(gv)->ifp) {
- fd = fileno(GvIO(gv)->ifp);
- if (GvIO(gv)->type == 's')
- io->type = 's';
+ if (GvIO(gv) && IoIFP(GvIO(gv))) {
+ fd = fileno(IoIFP(GvIO(gv)));
+ if (IoTYPE(GvIO(gv)) == 's')
+ IoTYPE(io) = 's';
}
else
fd = -1;
name++;
if (strEQ(name,"-")) {
fp = stdout;
- io->type = '-';
+ IoTYPE(io) = '-';
}
else {
fp = fopen(name,mode);
goto duplicity;
if (strEQ(name,"-")) {
fp = stdin;
- io->type = '-';
+ IoTYPE(io) = '-';
}
else
fp = fopen(name,mode);
TAINT_ENV();
TAINT_PROPER("piped open");
fp = my_popen(name,"r");
- io->type = '|';
+ IoTYPE(io) = '|';
}
else {
- io->type = '<';
+ IoTYPE(io) = '<';
/*SUPPRESS 530*/
for (; isSPACE(*name); name++) ;
if (strEQ(name,"-")) {
fp = stdin;
- io->type = '-';
+ IoTYPE(io) = '-';
}
else
fp = fopen(name,"r");
}
}
if (!fp) {
- if (dowarn && io->type == '<' && strchr(name, '\n'))
+ if (dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
warn(warn_nl, "open");
- Safefree(myname);
goto say_false;
}
- Safefree(myname);
- if (io->type &&
- io->type != '|' && io->type != '-') {
+ if (IoTYPE(io) &&
+ IoTYPE(io) != '|' && IoTYPE(io) != '-') {
if (fstat(fileno(fp),&statbuf) < 0) {
(void)fclose(fp);
goto say_false;
}
if (S_ISSOCK(statbuf.st_mode))
- io->type = 's'; /* in case a socket was passed in to us */
+ IoTYPE(io) = 's'; /* in case a socket was passed in to us */
#ifdef HAS_SOCKET
else if (
#ifdef S_IFMT
I32 buflen = sizeof tokenbuf;
if (getsockname(fileno(fp), tokenbuf, &buflen) >= 0
|| errno != ENOTSOCK)
- io->type = 's'; /* some OS's return 0 on fstat()ed socket */
+ IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */
/* but some return 0 for streams too, sigh */
}
#endif
fd = fileno(fp);
fcntl(fd,FFt_SETFD,fd > maxsysfd);
#endif
- io->ifp = fp;
+ IoIFP(io) = fp;
if (writing) {
- if (io->type == 's'
- || (io->type == '>' && S_ISCHR(statbuf.st_mode)) ) {
- if (!(io->ofp = fdopen(fileno(fp),"w"))) {
+ if (IoTYPE(io) == 's'
+ || (IoTYPE(io) == '>' && S_ISCHR(statbuf.st_mode)) ) {
+ if (!(IoOFP(io) = fdopen(fileno(fp),"w"))) {
fclose(fp);
- io->ifp = Nullfp;
+ IoIFP(io) = Nullfp;
goto say_false;
}
}
else
- io->ofp = fp;
+ IoOFP(io) = fp;
}
return TRUE;
say_false:
- io->ifp = saveifp;
- io->ofp = saveofp;
- io->type = savetype;
+ IoIFP(io) = saveifp;
+ IoOFP(io) = saveofp;
+ IoTYPE(io) = savetype;
return FALSE;
}
if (!argvoutgv)
argvoutgv = gv_fetchpv("ARGVOUT",TRUE);
if (filemode & (S_ISUID|S_ISGID)) {
- fflush(GvIO(argvoutgv)->ifp); /* chmod must follow last write */
+ fflush(IoIFP(GvIO(argvoutgv))); /* chmod must follow last write */
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#else
while (av_len(GvAV(gv)) >= 0) {
STRLEN len;
sv = av_shift(GvAV(gv));
+ SAVEFREESV(sv);
sv_setsv(GvSV(gv),sv);
SvSETMAGIC(GvSV(gv));
oldname = SvPVx(GvSV(gv), len);
if (inplace) {
TAINT_PROPER("inplace open");
if (strEQ(oldname,"-")) {
- sv_free(sv);
defoutgv = gv_fetchpv("STDOUT",TRUE);
- return GvIO(gv)->ifp;
+ return IoIFP(GvIO(gv));
}
#ifndef FLEXFILENAMES
filedev = statbuf.st_dev;
warn("Can't do inplace edit: %s is not a regular file",
oldname );
do_close(gv,FALSE);
- sv_free(sv);
continue;
}
if (*inplace) {
warn("Can't do inplace edit: %s > 14 characters",
SvPVX(sv) );
do_close(gv,FALSE);
- sv_free(sv);
continue;
}
#endif
warn("Can't rename %s to %s: %s, skipping file",
oldname, SvPVX(sv), strerror(errno) );
do_close(gv,FALSE);
- sv_free(sv);
continue;
}
#else
warn("Can't rename %s to %s: %s, skipping file",
oldname, SvPVX(sv), strerror(errno) );
do_close(gv,FALSE);
- sv_free(sv);
continue;
}
(void)UNLINK(oldname);
warn("Can't rename %s to %s: %s, skipping file",
oldname, SvPVX(sv), strerror(errno) );
do_close(gv,FALSE);
- sv_free(sv);
continue;
}
#else
warn("Can't do inplace edit on %s: %s",
oldname, strerror(errno) );
do_close(gv,FALSE);
- sv_free(sv);
continue;
}
defoutgv = argvoutgv;
- lastfd = fileno(GvIO(argvoutgv)->ifp);
+ lastfd = fileno(IoIFP(GvIO(argvoutgv)));
(void)fstat(lastfd,&statbuf);
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#endif
}
}
- sv_free(sv);
- return GvIO(gv)->ifp;
+ return IoIFP(GvIO(gv));
}
else
fprintf(stderr,"Can't open %s: %s\n",SvPV(sv, na), strerror(errno));
- sv_free(sv);
}
if (inplace) {
(void)do_close(argvoutgv,FALSE);
if (!rstio)
rstio = GvIO(rgv) = newIO();
- else if (rstio->ifp)
+ else if (IoIFP(rstio))
do_close(rgv,FALSE);
if (!wstio)
wstio = GvIO(wgv) = newIO();
- else if (wstio->ifp)
+ else if (IoIFP(wstio))
do_close(wgv,FALSE);
if (pipe(fd) < 0)
goto badexit;
- rstio->ifp = fdopen(fd[0], "r");
- wstio->ofp = fdopen(fd[1], "w");
- wstio->ifp = wstio->ofp;
- rstio->type = '<';
- wstio->type = '>';
- if (!rstio->ifp || !wstio->ofp) {
- if (rstio->ifp) fclose(rstio->ifp);
+ IoIFP(rstio) = fdopen(fd[0], "r");
+ IoOFP(wstio) = fdopen(fd[1], "w");
+ IoIFP(wstio) = IoOFP(wstio);
+ IoTYPE(rstio) = '<';
+ IoTYPE(wstio) = '>';
+ if (!IoIFP(rstio) || !IoOFP(wstio)) {
+ if (IoIFP(rstio)) fclose(IoIFP(rstio));
else close(fd[0]);
- if (wstio->ofp) fclose(wstio->ofp);
+ if (IoOFP(wstio)) fclose(IoOFP(wstio));
else close(fd[1]);
goto badexit;
}
#endif
bool
+#ifndef STANDARD_C
do_close(gv,explicit)
GV *gv;
bool explicit;
+#else
+do_close(GV *gv, bool explicit)
+#endif /* STANDARD_C */
{
bool retval = FALSE;
register IO *io;
warn("Close on unopened file <%s>",GvENAME(gv));
return FALSE;
}
- if (io->ifp) {
- if (io->type == '|') {
- status = my_pclose(io->ifp);
+ if (IoIFP(io)) {
+ if (IoTYPE(io) == '|') {
+ status = my_pclose(IoIFP(io));
retval = (status == 0);
statusvalue = (unsigned short)status & 0xffff;
}
- else if (io->type == '-')
+ else if (IoTYPE(io) == '-')
retval = TRUE;
else {
- if (io->ofp && io->ofp != io->ifp) { /* a socket */
- retval = (fclose(io->ofp) != EOF);
- fclose(io->ifp); /* clear stdio, fd already closed */
+ if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */
+ retval = (fclose(IoOFP(io)) != EOF);
+ fclose(IoIFP(io)); /* clear stdio, fd already closed */
}
else
- retval = (fclose(io->ifp) != EOF);
+ retval = (fclose(IoIFP(io)) != EOF);
}
- io->ofp = io->ifp = Nullfp;
+ IoOFP(io) = IoIFP(io) = Nullfp;
}
if (explicit) {
- io->lines = 0;
- io->page = 0;
- io->lines_left = io->page_len;
+ IoLINES(io) = 0;
+ IoPAGE(io) = 0;
+ IoLINES_LEFT(io) = IoPAGE_LEN(io);
}
- io->type = ' ';
+ IoTYPE(io) = ' ';
return retval;
}
if (!io)
return TRUE;
- while (io->ifp) {
+ while (IoIFP(io)) {
#ifdef STDSTDIO /* (the code works without this) */
- if (io->ifp->_cnt > 0) /* cheat a little, since */
+ if (IoIFP(io)->_cnt > 0) /* cheat a little, since */
return FALSE; /* this is the most usual case */
#endif
- ch = getc(io->ifp);
+ ch = getc(IoIFP(io));
if (ch != EOF) {
- (void)ungetc(ch, io->ifp);
+ (void)ungetc(ch, IoIFP(io));
return FALSE;
}
#ifdef STDSTDIO
- if (io->ifp->_cnt < -1)
- io->ifp->_cnt = -1;
+ if (IoIFP(io)->_cnt < -1)
+ IoIFP(io)->_cnt = -1;
#endif
- if (gv == argvgv) { /* not necessarily a real EOF yet? */
+ if (op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
if (!nextargv(argvgv)) /* get another fp handy */
return TRUE;
}
goto phooey;
io = GvIO(gv);
- if (!io || !io->ifp)
+ if (!io || !IoIFP(io))
goto phooey;
#ifdef ULTRIX_STDIO_BOTCH
- if (feof(io->ifp))
- (void)fseek (io->ifp, 0L, 2); /* ultrix 1.2 workaround */
+ if (feof(IoIFP(io)))
+ (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
#endif
- return ftell(io->ifp);
+ return ftell(IoIFP(io));
phooey:
if (dowarn)
goto nuts;
io = GvIO(gv);
- if (!io || !io->ifp)
+ if (!io || !IoIFP(io))
goto nuts;
#ifdef ULTRIX_STDIO_BOTCH
- if (feof(io->ifp))
- (void)fseek (io->ifp, 0L, 2); /* ultrix 1.2 workaround */
+ if (feof(IoIFP(io)))
+ (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
#endif
- return fseek(io->ifp, pos, whence) >= 0;
+ return fseek(IoIFP(io), pos, whence) >= 0;
nuts:
if (dowarn)
register char *s;
I32 retval;
- if (!gv || !argstr || !(io = GvIO(gv)) || !io->ifp) {
+ if (!gv || !argstr || !(io = GvIO(gv)) || !IoIFP(io)) {
errno = EBADF; /* well, sort of... */
return -1;
}
#ifndef lint
if (optype == OP_IOCTL)
- retval = ioctl(fileno(io->ifp), func, s);
+ retval = ioctl(fileno(IoIFP(io)), func, s);
else
#ifdef DOSISH
croak("fcntl is not implemented");
#else
#ifdef HAS_FCNTL
- retval = fcntl(fileno(io->ifp), func, s);
+ retval = fcntl(fileno(IoIFP(io)), func, s);
#else
croak("fcntl is not implemented");
#endif
if (!sv)
return TRUE;
if (ofmt) {
- if (SvMAGICAL(sv))
+ if (SvGMAGICAL(sv))
mg_get(sv);
if (SvIOK(sv) && SvIVX(sv) != 0) {
fprintf(fp, ofmt, (double)SvIVX(sv));
}
switch (SvTYPE(sv)) {
case SVt_NULL:
+ if (dowarn)
+ warn(warn_uninit);
return TRUE;
case SVt_IV:
- if (SvMAGICAL(sv))
+ if (SvGMAGICAL(sv))
mg_get(sv);
fprintf(fp, "%d", SvIVX(sv));
return !ferror(fp);
if (op->op_flags & OPf_SPECIAL) {
EXTEND(sp,1);
io = GvIO(cGVOP->op_gv);
- if (io && io->ifp) {
+ if (io && IoIFP(io)) {
statgv = cGVOP->op_gv;
sv_setpv(statname,"");
laststype = OP_STAT;
- return (laststatval = fstat(fileno(io->ifp), &statcache));
+ return (laststatval = fstat(fileno(IoIFP(io)), &statcache));
}
else {
if (cGVOP->op_gv == defgv)
}
if (items-- > 0) {
- char *s = SvPV(*mark, tmplen);
- sv_setpvn(sv, s, tmplen);
+ char *s;
+
+ if (*mark) {
+ s = SvPV(*mark, tmplen);
+ sv_setpvn(sv, s, tmplen);
+ }
+ else
+ sv_setpv(sv, "");
mark++;
}
else
SV *targ = LvTARG(sv);
register I32 offset;
register I32 size;
- register unsigned char *s = (unsigned char*)SvPVX(targ);
- register unsigned long lval = U_L(SvNV(sv));
+ register unsigned char *s;
+ register unsigned long lval;
I32 mask;
+ if (!targ)
+ return;
+ s = (unsigned char*)SvPVX(targ);
+ lval = U_L(SvNV(sv));
offset = LvTARGOFF(sv);
size = LvTARGLEN(sv);
if (size < 8) {
if (GIMME != G_ARRAY) {
dTARGET;
- if (!SvMAGICAL(hv) || !mg_find((SV*)hv,'P'))
+ if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
i = HvKEYS(hv);
else {
i = 0;
U32 i;
HE *entry;
+ if (!HvARRAY(stash))
+ return;
for (i = 0; i <= HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
GV *gv = (GV*)entry->hent_val;
dump_sub(gv)
GV* gv;
{
- SV *sv = sv_mortalcopy(&sv_undef);
+ SV *sv = sv_newmortal();
if (GvCV(gv)) {
gv_fullname(sv,gv);
dump("\nSUB %s = ", SvPVX(sv));
else
fprintf(stderr, "DONE\n");
dumplvl++;
- if (op->op_targ)
- dump("TARG = %d\n", op->op_targ);
+ if (op->op_targ) {
+ if (op->op_type == OP_NULL)
+ dump(" (was %s)\n", op_name[op->op_targ]);
+ else
+ dump("TARG = %d\n", op->op_targ);
+ }
#ifdef NOTDEF
dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next);
#endif
case OP_GVSV:
case OP_GV:
if (cGVOP->op_gv) {
+ ENTER;
tmpsv = NEWSV(0,0);
+ SAVEFREESV(tmpsv);
gv_fullname(tmpsv,cGVOP->op_gv);
dump("GV = %s\n", SvPV(tmpsv, na));
- sv_free(tmpsv);
+ LEAVE;
}
else
dump("GV = NULL\n");
fprintf(stderr,"{}\n");
return;
}
- sv = sv_mortalcopy(&sv_undef);
+ sv = sv_newmortal();
dumplvl++;
fprintf(stderr,"{\n");
gv_fullname(sv,gv);
-/* This file is derived from global.var and interp.var */
+/* This file is derived from global.sym and interp.sym */
/* (Doing namespace management portably in C is really gross.) */
#ifdef EMBED
/* globals we need to hide from the world */
-#define No PERLNo
-#define Sv PERLSv
-#define Xpv PERLXpv
-#define Yes PERLYes
-#define additem PERLadditem
-#define an PERLan
-#define buf PERLbuf
-#define bufend PERLbufend
-#define bufptr PERLbufptr
-#define check PERLcheck
-#define coeff PERLcoeff
-#define compiling PERLcompiling
-#define comppad PERLcomppad
-#define comppadname PERLcomppadname
-#define comppadnamefill PERLcomppadnamefill
-#define cop_seqmax PERLcop_seqmax
-#define cryptseen PERLcryptseen
-#define cshlen PERLcshlen
-#define cshname PERLcshname
-#define curinterp PERLcurinterp
-#define curpad PERLcurpad
-#define dc PERLdc
-#define di PERLdi
-#define ds PERLds
-#define egid PERLegid
-#define error_count PERLerror_count
-#define euid PERLeuid
-#define evstr PERLevstr
-#define expect PERLexpect
-#define expectterm PERLexpectterm
-#define fold PERLfold
-#define freq PERLfreq
-#define gid PERLgid
-#define hexdigit PERLhexdigit
-#define in_format PERLin_format
-#define in_my PERLin_my
-#define know_next PERLknow_next
-#define last_lop PERLlast_lop
-#define last_uni PERLlast_uni
-#define linestr PERLlinestr
-#define markstack PERLmarkstack
-#define markstack_max PERLmarkstack_max
-#define markstack_ptr PERLmarkstack_ptr
-#define multi_close PERLmulti_close
-#define multi_end PERLmulti_end
-#define multi_open PERLmulti_open
-#define multi_start PERLmulti_start
-#define na PERLna
-#define needblockscope PERLneedblockscope
-#define nexttype PERLnexttype
-#define nextval PERLnextval
-#define no_aelem PERLno_aelem
-#define no_dir_func PERLno_dir_func
-#define no_func PERLno_func
-#define no_helem PERLno_helem
-#define no_mem PERLno_mem
-#define no_modify PERLno_modify
-#define no_security PERLno_security
-#define no_sock_func PERLno_sock_func
-#define no_usym PERLno_usym
-#define nointrp PERLnointrp
-#define nomem PERLnomem
-#define nomemok PERLnomemok
-#define oldbufptr PERLoldbufptr
-#define oldoldbufptr PERLoldoldbufptr
-#define op PERLop
-#define op_name PERLop_name
-#define op_seqmax PERLop_seqmax
-#define opargs PERLopargs
-#define origalen PERLorigalen
-#define origenviron PERLorigenviron
-#define padix PERLpadix
-#define patleave PERLpatleave
-#define ppaddr PERLppaddr
-#define rcsid PERLrcsid
-#define reall_srchlen PERLreall_srchlen
-#define regarglen PERLregarglen
-#define regbol PERLregbol
-#define regcode PERLregcode
-#define regdummy PERLregdummy
-#define regendp PERLregendp
-#define regeol PERLregeol
-#define regfold PERLregfold
-#define reginput PERLreginput
-#define reglastparen PERLreglastparen
-#define regmyendp PERLregmyendp
-#define regmyp_size PERLregmyp_size
-#define regmystartp PERLregmystartp
-#define regnarrate PERLregnarrate
-#define regnpar PERLregnpar
-#define regparse PERLregparse
-#define regprecomp PERLregprecomp
-#define regprev PERLregprev
-#define regsawback PERLregsawback
-#define regsawbracket PERLregsawbracket
-#define regsize PERLregsize
-#define regstartp PERLregstartp
-#define regtill PERLregtill
-#define regxend PERLregxend
-#define retstack PERLretstack
-#define retstack_ix PERLretstack_ix
-#define retstack_max PERLretstack_max
-#define rsfp PERLrsfp
-#define savestack PERLsavestack
-#define savestack_ix PERLsavestack_ix
-#define savestack_max PERLsavestack_max
-#define saw_return PERLsaw_return
-#define scopestack PERLscopestack
-#define scopestack_ix PERLscopestack_ix
-#define scopestack_max PERLscopestack_max
-#define scrgv PERLscrgv
-#define sig_name PERLsig_name
-#define simple PERLsimple
-#define stack_base PERLstack_base
-#define stack_max PERLstack_max
-#define stack_sp PERLstack_sp
-#define statbuf PERLstatbuf
-#define sub_generation PERLsub_generation
-#define subline PERLsubline
-#define subname PERLsubname
-#define sv_no PERLsv_no
-#define sv_undef PERLsv_undef
-#define sv_yes PERLsv_yes
-#define thisexpr PERLthisexpr
-#define timesbuf PERLtimesbuf
-#define tokenbuf PERLtokenbuf
-#define uid PERLuid
-#define varies PERLvaries
-#define vert PERLvert
-#define vtbl_arylen PERLvtbl_arylen
-#define vtbl_bm PERLvtbl_bm
-#define vtbl_dbline PERLvtbl_dbline
-#define vtbl_env PERLvtbl_env
-#define vtbl_envelem PERLvtbl_envelem
-#define vtbl_glob PERLvtbl_glob
-#define vtbl_isa PERLvtbl_isa
-#define vtbl_isaelem PERLvtbl_isaelem
-#define vtbl_mglob PERLvtbl_mglob
-#define vtbl_pack PERLvtbl_pack
-#define vtbl_packelem PERLvtbl_packelem
-#define vtbl_sig PERLvtbl_sig
-#define vtbl_sigelem PERLvtbl_sigelem
-#define vtbl_substr PERLvtbl_substr
-#define vtbl_sv PERLvtbl_sv
-#define vtbl_taint PERLvtbl_taint
-#define vtbl_uvar PERLvtbl_uvar
-#define vtbl_vec PERLvtbl_vec
-#define warn_nl PERLwarn_nl
-#define warn_nosemi PERLwarn_nosemi
-#define warn_reserved PERLwarn_reserved
-#define watchaddr PERLwatchaddr
-#define watchok PERLwatchok
-#define yychar PERLyychar
-#define yycheck PERLyycheck
-#define yydebug PERLyydebug
-#define yydefred PERLyydefred
-#define yydgoto PERLyydgoto
-#define yyerrflag PERLyyerrflag
-#define yygindex PERLyygindex
-#define yylen PERLyylen
-#define yylhs PERLyylhs
-#define yylval PERLyylval
-#define yyname PERLyyname
-#define yynerrs PERLyynerrs
-#define yyrindex PERLyyrindex
-#define yyrule PERLyyrule
-#define yysindex PERLyysindex
-#define yytable PERLyytable
-#define yyval PERLyyval
-#define append_elem PERLappend_elem
-#define append_list PERLappend_list
-#define apply PERLapply
-#define av_clear PERLav_clear
-#define av_fake PERLav_fake
-#define av_fetch PERLav_fetch
-#define av_fill PERLav_fill
-#define av_free PERLav_free
-#define av_len PERLav_len
-#define av_make PERLav_make
-#define av_pop PERLav_pop
-#define av_popnulls PERLav_popnulls
-#define av_push PERLav_push
-#define av_shift PERLav_shift
-#define av_store PERLav_store
-#define av_undef PERLav_undef
-#define av_unshift PERLav_unshift
-#define bind_match PERLbind_match
-#define block_head PERLblock_head
-#define calllist PERLcalllist
-#define cando PERLcando
-#define check_uni PERLcheck_uni
-#define checkcomma PERLcheckcomma
-#define ck_aelem PERLck_aelem
-#define ck_chop PERLck_chop
-#define ck_concat PERLck_concat
-#define ck_eof PERLck_eof
-#define ck_eval PERLck_eval
-#define ck_exec PERLck_exec
-#define ck_formline PERLck_formline
-#define ck_ftst PERLck_ftst
-#define ck_fun PERLck_fun
-#define ck_glob PERLck_glob
-#define ck_grep PERLck_grep
-#define ck_gvconst PERLck_gvconst
-#define ck_index PERLck_index
-#define ck_lengthconst PERLck_lengthconst
-#define ck_lfun PERLck_lfun
-#define ck_listiob PERLck_listiob
-#define ck_match PERLck_match
-#define ck_null PERLck_null
-#define ck_repeat PERLck_repeat
-#define ck_retarget PERLck_retarget
-#define ck_rvconst PERLck_rvconst
-#define ck_select PERLck_select
-#define ck_shift PERLck_shift
-#define ck_sort PERLck_sort
-#define ck_split PERLck_split
-#define ck_subr PERLck_subr
-#define ck_trunc PERLck_trunc
-#define convert PERLconvert
-#define cpy7bit PERLcpy7bit
-#define cpytill PERLcpytill
-#define croak PERLcroak
-#define cv_clear PERLcv_clear
-#define cxinc PERLcxinc
-#define deb PERLdeb
-#define deb_growlevel PERLdeb_growlevel
-#define debop PERLdebop
-#define debstack PERLdebstack
-#define debstackptrs PERLdebstackptrs
-#define die PERLdie
-#define die_where PERLdie_where
-#define do_aexec PERLdo_aexec
-#define do_chop PERLdo_chop
-#define do_close PERLdo_close
-#define do_ctl PERLdo_ctl
-#define do_eof PERLdo_eof
-#define do_exec PERLdo_exec
-#define do_execfree PERLdo_execfree
-#define do_ipcctl PERLdo_ipcctl
-#define do_ipcget PERLdo_ipcget
-#define do_join PERLdo_join
-#define do_kv PERLdo_kv
-#define do_msgrcv PERLdo_msgrcv
-#define do_msgsnd PERLdo_msgsnd
-#define do_open PERLdo_open
-#define do_pipe PERLdo_pipe
-#define do_print PERLdo_print
-#define do_readline PERLdo_readline
-#define do_seek PERLdo_seek
-#define do_semop PERLdo_semop
-#define do_shmio PERLdo_shmio
-#define do_sprintf PERLdo_sprintf
-#define do_tell PERLdo_tell
-#define do_trans PERLdo_trans
-#define do_vecset PERLdo_vecset
-#define do_vop PERLdo_vop
-#define doeval PERLdoeval
-#define dofindlabel PERLdofindlabel
-#define dopoptoeval PERLdopoptoeval
-#define dump_all PERLdump_all
-#define dump_eval PERLdump_eval
-#define dump_gv PERLdump_gv
-#define dump_op PERLdump_op
-#define dump_packsubs PERLdump_packsubs
-#define dump_pm PERLdump_pm
-#define dump_sub PERLdump_sub
-#define fbm_compile PERLfbm_compile
-#define fbm_instr PERLfbm_instr
-#define fetch_gv PERLfetch_gv
-#define fetch_io PERLfetch_io
-#define fetch_stash PERLfetch_stash
-#define fold_constants PERLfold_constants
-#define force_ident PERLforce_ident
-#define force_next PERLforce_next
-#define force_word PERLforce_word
-#define free_tmps PERLfree_tmps
-#define gen_constant_list PERLgen_constant_list
-#define getgimme PERLgetgimme
-#define gp_free PERLgp_free
-#define gp_ref PERLgp_ref
-#define gv_AVadd PERLgv_AVadd
-#define gv_HVadd PERLgv_HVadd
-#define gv_check PERLgv_check
-#define gv_efullname PERLgv_efullname
-#define gv_fetchfile PERLgv_fetchfile
-#define gv_fetchmeth PERLgv_fetchmeth
-#define gv_fetchmethod PERLgv_fetchmethod
-#define gv_fetchpv PERLgv_fetchpv
-#define gv_fullname PERLgv_fullname
-#define gv_init PERLgv_init
-#define he_delayfree PERLhe_delayfree
-#define he_free PERLhe_free
-#define hoistmust PERLhoistmust
-#define hv_clear PERLhv_clear
-#define hv_delete PERLhv_delete
-#define hv_fetch PERLhv_fetch
-#define hv_free PERLhv_free
-#define hv_iterinit PERLhv_iterinit
-#define hv_iterkey PERLhv_iterkey
-#define hv_iternext PERLhv_iternext
-#define hv_iterval PERLhv_iterval
-#define hv_magic PERLhv_magic
-#define hv_store PERLhv_store
-#define hv_undef PERLhv_undef
-#define ibcmp PERLibcmp
-#define ingroup PERLingroup
-#define instr PERLinstr
-#define intuit_more PERLintuit_more
-#define invert PERLinvert
-#define jmaybe PERLjmaybe
-#define keyword PERLkeyword
-#define leave_scope PERLleave_scope
-#define lex_end PERLlex_end
-#define lex_start PERLlex_start
-#define linklist PERLlinklist
-#define list PERLlist
-#define listkids PERLlistkids
-#define localize PERLlocalize
-#define looks_like_number PERLlooks_like_number
-#define magic_clearpack PERLmagic_clearpack
-#define magic_get PERLmagic_get
-#define magic_getarylen PERLmagic_getarylen
-#define magic_getglob PERLmagic_getglob
-#define magic_getpack PERLmagic_getpack
-#define magic_gettaint PERLmagic_gettaint
-#define magic_getuvar PERLmagic_getuvar
-#define magic_len PERLmagic_len
-#define magic_nextpack PERLmagic_nextpack
-#define magic_set PERLmagic_set
-#define magic_setarylen PERLmagic_setarylen
-#define magic_setbm PERLmagic_setbm
-#define magic_setdbline PERLmagic_setdbline
-#define magic_setenv PERLmagic_setenv
-#define magic_setglob PERLmagic_setglob
-#define magic_setisa PERLmagic_setisa
-#define magic_setmglob PERLmagic_setmglob
-#define magic_setpack PERLmagic_setpack
-#define magic_setsig PERLmagic_setsig
-#define magic_setsubstr PERLmagic_setsubstr
-#define magic_settaint PERLmagic_settaint
-#define magic_setuvar PERLmagic_setuvar
-#define magic_setvec PERLmagic_setvec
-#define magicname PERLmagicname
-#define mess PERLmess
-#define mg_clear PERLmg_clear
-#define mg_copy PERLmg_copy
-#define mg_find PERLmg_find
-#define mg_free PERLmg_free
-#define mg_get PERLmg_get
-#define mg_len PERLmg_len
-#define mg_set PERLmg_set
-#define mod PERLmod
-#define modkids PERLmodkids
-#define moreswitches PERLmoreswitches
-#define my PERLmy
-#define my_exit PERLmy_exit
-#define my_lstat PERLmy_lstat
-#define my_pclose PERLmy_pclose
-#define my_popen PERLmy_popen
-#define my_setenv PERLmy_setenv
-#define my_stat PERLmy_stat
-#define my_unexec PERLmy_unexec
-#define newANONHASH PERLnewANONHASH
-#define newANONLIST PERLnewANONLIST
-#define newASSIGNOP PERLnewASSIGNOP
-#define newAV PERLnewAV
-#define newAVREF PERLnewAVREF
-#define newBINOP PERLnewBINOP
-#define newCONDOP PERLnewCONDOP
-#define newCVOP PERLnewCVOP
-#define newCVREF PERLnewCVREF
-#define newFORM PERLnewFORM
-#define newFOROP PERLnewFOROP
-#define newGVOP PERLnewGVOP
-#define newGVREF PERLnewGVREF
-#define newGVgen PERLnewGVgen
-#define newHV PERLnewHV
-#define newHVREF PERLnewHVREF
-#define newIO PERLnewIO
-#define newLISTOP PERLnewLISTOP
-#define newLOGOP PERLnewLOGOP
-#define newLOOPOP PERLnewLOOPOP
-#define newMETHOD PERLnewMETHOD
-#define newNULLLIST PERLnewNULLLIST
-#define newOP PERLnewOP
-#define newPMOP PERLnewPMOP
-#define newPVOP PERLnewPVOP
-#define newRANGE PERLnewRANGE
-#define newSLICEOP PERLnewSLICEOP
-#define newSTATEOP PERLnewSTATEOP
-#define newSUB PERLnewSUB
-#define newSV PERLnewSV
-#define newSVOP PERLnewSVOP
-#define newSVREF PERLnewSVREF
-#define newSViv PERLnewSViv
-#define newSVnv PERLnewSVnv
-#define newSVpv PERLnewSVpv
-#define newSVsv PERLnewSVsv
-#define newUNOP PERLnewUNOP
-#define newWHILEOP PERLnewWHILEOP
-#define newXSUB PERLnewXSUB
-#define nextargv PERLnextargv
-#define ninstr PERLninstr
-#define no_fh_allowed PERLno_fh_allowed
-#define no_op PERLno_op
-#define nsavestr PERLnsavestr
-#define oopsAV PERLoopsAV
-#define oopsCV PERLoopsCV
-#define oopsHV PERLoopsHV
-#define op_free PERLop_free
-#define package PERLpackage
-#define pad_alloc PERLpad_alloc
-#define pad_allocmy PERLpad_allocmy
-#define pad_findmy PERLpad_findmy
-#define pad_free PERLpad_free
-#define pad_leavemy PERLpad_leavemy
-#define pad_reset PERLpad_reset
-#define pad_sv PERLpad_sv
-#define pad_swipe PERLpad_swipe
-#define peep PERLpeep
-#define pidgone PERLpidgone
-#define pmruntime PERLpmruntime
-#define pmtrans PERLpmtrans
-#define pop_return PERLpop_return
-#define pop_scope PERLpop_scope
-#define pp_aassign PERLpp_aassign
-#define pp_accept PERLpp_accept
-#define pp_add PERLpp_add
-#define pp_aelem PERLpp_aelem
-#define pp_aelemfast PERLpp_aelemfast
-#define pp_alarm PERLpp_alarm
-#define pp_and PERLpp_and
-#define pp_andassign PERLpp_andassign
-#define pp_anonhash PERLpp_anonhash
-#define pp_anonlist PERLpp_anonlist
-#define pp_aslice PERLpp_aslice
-#define pp_atan2 PERLpp_atan2
-#define pp_av2arylen PERLpp_av2arylen
-#define pp_backtick PERLpp_backtick
-#define pp_bind PERLpp_bind
-#define pp_binmode PERLpp_binmode
-#define pp_bit_and PERLpp_bit_and
-#define pp_bit_or PERLpp_bit_or
-#define pp_bless PERLpp_bless
-#define pp_caller PERLpp_caller
-#define pp_chdir PERLpp_chdir
-#define pp_chmod PERLpp_chmod
-#define pp_chop PERLpp_chop
-#define pp_chown PERLpp_chown
-#define pp_chroot PERLpp_chroot
-#define pp_close PERLpp_close
-#define pp_closedir PERLpp_closedir
-#define pp_complement PERLpp_complement
-#define pp_concat PERLpp_concat
-#define pp_cond_expr PERLpp_cond_expr
-#define pp_connect PERLpp_connect
-#define pp_const PERLpp_const
-#define pp_cos PERLpp_cos
-#define pp_crypt PERLpp_crypt
-#define pp_cswitch PERLpp_cswitch
-#define pp_dbmclose PERLpp_dbmclose
-#define pp_dbmopen PERLpp_dbmopen
-#define pp_dbstate PERLpp_dbstate
-#define pp_defined PERLpp_defined
-#define pp_delete PERLpp_delete
-#define pp_die PERLpp_die
-#define pp_divide PERLpp_divide
-#define pp_dofile PERLpp_dofile
-#define pp_done PERLpp_done
-#define pp_dump PERLpp_dump
-#define pp_each PERLpp_each
-#define pp_egrent PERLpp_egrent
-#define pp_ehostent PERLpp_ehostent
-#define pp_enetent PERLpp_enetent
-#define pp_enter PERLpp_enter
-#define pp_entereval PERLpp_entereval
-#define pp_enteriter PERLpp_enteriter
-#define pp_enterloop PERLpp_enterloop
-#define pp_entersubr PERLpp_entersubr
-#define pp_entertry PERLpp_entertry
-#define pp_enterwrite PERLpp_enterwrite
-#define pp_eof PERLpp_eof
-#define pp_eprotoent PERLpp_eprotoent
-#define pp_epwent PERLpp_epwent
-#define pp_eq PERLpp_eq
-#define pp_eservent PERLpp_eservent
-#define pp_evalonce PERLpp_evalonce
-#define pp_exec PERLpp_exec
-#define pp_exit PERLpp_exit
-#define pp_exp PERLpp_exp
-#define pp_fcntl PERLpp_fcntl
-#define pp_fileno PERLpp_fileno
-#define pp_flip PERLpp_flip
-#define pp_flock PERLpp_flock
-#define pp_flop PERLpp_flop
-#define pp_fork PERLpp_fork
-#define pp_formline PERLpp_formline
-#define pp_ftatime PERLpp_ftatime
-#define pp_ftbinary PERLpp_ftbinary
-#define pp_ftblk PERLpp_ftblk
-#define pp_ftchr PERLpp_ftchr
-#define pp_ftctime PERLpp_ftctime
-#define pp_ftdir PERLpp_ftdir
-#define pp_fteexec PERLpp_fteexec
-#define pp_fteowned PERLpp_fteowned
-#define pp_fteread PERLpp_fteread
-#define pp_ftewrite PERLpp_ftewrite
-#define pp_ftfile PERLpp_ftfile
-#define pp_ftis PERLpp_ftis
-#define pp_ftlink PERLpp_ftlink
-#define pp_ftmtime PERLpp_ftmtime
-#define pp_ftpipe PERLpp_ftpipe
-#define pp_ftrexec PERLpp_ftrexec
-#define pp_ftrowned PERLpp_ftrowned
-#define pp_ftrread PERLpp_ftrread
-#define pp_ftrwrite PERLpp_ftrwrite
-#define pp_ftsgid PERLpp_ftsgid
-#define pp_ftsize PERLpp_ftsize
-#define pp_ftsock PERLpp_ftsock
-#define pp_ftsuid PERLpp_ftsuid
-#define pp_ftsvtx PERLpp_ftsvtx
-#define pp_fttext PERLpp_fttext
-#define pp_fttty PERLpp_fttty
-#define pp_ftzero PERLpp_ftzero
-#define pp_ge PERLpp_ge
-#define pp_getc PERLpp_getc
-#define pp_getlogin PERLpp_getlogin
-#define pp_getpeername PERLpp_getpeername
-#define pp_getpgrp PERLpp_getpgrp
-#define pp_getppid PERLpp_getppid
-#define pp_getpriority PERLpp_getpriority
-#define pp_getsockname PERLpp_getsockname
-#define pp_ggrent PERLpp_ggrent
-#define pp_ggrgid PERLpp_ggrgid
-#define pp_ggrnam PERLpp_ggrnam
-#define pp_ghbyaddr PERLpp_ghbyaddr
-#define pp_ghbyname PERLpp_ghbyname
-#define pp_ghostent PERLpp_ghostent
-#define pp_glob PERLpp_glob
-#define pp_gmtime PERLpp_gmtime
-#define pp_gnbyaddr PERLpp_gnbyaddr
-#define pp_gnbyname PERLpp_gnbyname
-#define pp_gnetent PERLpp_gnetent
-#define pp_goto PERLpp_goto
-#define pp_gpbyname PERLpp_gpbyname
-#define pp_gpbynumber PERLpp_gpbynumber
-#define pp_gprotoent PERLpp_gprotoent
-#define pp_gpwent PERLpp_gpwent
-#define pp_gpwnam PERLpp_gpwnam
-#define pp_gpwuid PERLpp_gpwuid
-#define pp_grepstart PERLpp_grepstart
-#define pp_grepwhile PERLpp_grepwhile
-#define pp_gsbyname PERLpp_gsbyname
-#define pp_gsbyport PERLpp_gsbyport
-#define pp_gservent PERLpp_gservent
-#define pp_gsockopt PERLpp_gsockopt
-#define pp_gt PERLpp_gt
-#define pp_gv PERLpp_gv
-#define pp_gvsv PERLpp_gvsv
-#define pp_helem PERLpp_helem
-#define pp_hex PERLpp_hex
-#define pp_hslice PERLpp_hslice
-#define pp_index PERLpp_index
-#define pp_indread PERLpp_indread
-#define pp_int PERLpp_int
-#define pp_intadd PERLpp_intadd
-#define pp_interp PERLpp_interp
-#define pp_ioctl PERLpp_ioctl
-#define pp_iter PERLpp_iter
-#define pp_join PERLpp_join
-#define pp_keys PERLpp_keys
-#define pp_kill PERLpp_kill
-#define pp_last PERLpp_last
-#define pp_lc PERLpp_lc
-#define pp_lcfirst PERLpp_lcfirst
-#define pp_le PERLpp_le
-#define pp_leave PERLpp_leave
-#define pp_leaveeval PERLpp_leaveeval
-#define pp_leaveloop PERLpp_leaveloop
-#define pp_leavesubr PERLpp_leavesubr
-#define pp_leavetry PERLpp_leavetry
-#define pp_leavewrite PERLpp_leavewrite
-#define pp_left_shift PERLpp_left_shift
-#define pp_length PERLpp_length
-#define pp_lineseq PERLpp_lineseq
-#define pp_link PERLpp_link
-#define pp_list PERLpp_list
-#define pp_listen PERLpp_listen
-#define pp_localtime PERLpp_localtime
-#define pp_log PERLpp_log
-#define pp_lslice PERLpp_lslice
-#define pp_lstat PERLpp_lstat
-#define pp_lt PERLpp_lt
-#define pp_match PERLpp_match
-#define pp_method PERLpp_method
-#define pp_mkdir PERLpp_mkdir
-#define pp_modulo PERLpp_modulo
-#define pp_msgctl PERLpp_msgctl
-#define pp_msgget PERLpp_msgget
-#define pp_msgrcv PERLpp_msgrcv
-#define pp_msgsnd PERLpp_msgsnd
-#define pp_multiply PERLpp_multiply
-#define pp_ncmp PERLpp_ncmp
-#define pp_ne PERLpp_ne
-#define pp_negate PERLpp_negate
-#define pp_next PERLpp_next
-#define pp_nextstate PERLpp_nextstate
-#define pp_not PERLpp_not
-#define pp_nswitch PERLpp_nswitch
-#define pp_null PERLpp_null
-#define pp_oct PERLpp_oct
-#define pp_open PERLpp_open
-#define pp_open_dir PERLpp_open_dir
-#define pp_or PERLpp_or
-#define pp_orassign PERLpp_orassign
-#define pp_ord PERLpp_ord
-#define pp_pack PERLpp_pack
-#define pp_padav PERLpp_padav
-#define pp_padhv PERLpp_padhv
-#define pp_padsv PERLpp_padsv
-#define pp_pipe_op PERLpp_pipe_op
-#define pp_pop PERLpp_pop
-#define pp_postdec PERLpp_postdec
-#define pp_postinc PERLpp_postinc
-#define pp_pow PERLpp_pow
-#define pp_predec PERLpp_predec
-#define pp_preinc PERLpp_preinc
-#define pp_print PERLpp_print
-#define pp_prtf PERLpp_prtf
-#define pp_push PERLpp_push
-#define pp_pushmark PERLpp_pushmark
-#define pp_pushre PERLpp_pushre
-#define pp_rand PERLpp_rand
-#define pp_range PERLpp_range
-#define pp_rcatline PERLpp_rcatline
-#define pp_read PERLpp_read
-#define pp_readdir PERLpp_readdir
-#define pp_readline PERLpp_readline
-#define pp_readlink PERLpp_readlink
-#define pp_recv PERLpp_recv
-#define pp_redo PERLpp_redo
-#define pp_ref PERLpp_ref
-#define pp_refgen PERLpp_refgen
-#define pp_regcmaybe PERLpp_regcmaybe
-#define pp_regcomp PERLpp_regcomp
-#define pp_rename PERLpp_rename
-#define pp_repeat PERLpp_repeat
-#define pp_require PERLpp_require
-#define pp_reset PERLpp_reset
-#define pp_return PERLpp_return
-#define pp_reverse PERLpp_reverse
-#define pp_rewinddir PERLpp_rewinddir
-#define pp_right_shift PERLpp_right_shift
-#define pp_rindex PERLpp_rindex
-#define pp_rmdir PERLpp_rmdir
-#define pp_rv2av PERLpp_rv2av
-#define pp_rv2cv PERLpp_rv2cv
-#define pp_rv2gv PERLpp_rv2gv
-#define pp_rv2hv PERLpp_rv2hv
-#define pp_rv2sv PERLpp_rv2sv
-#define pp_sassign PERLpp_sassign
-#define pp_scalar PERLpp_scalar
-#define pp_schop PERLpp_schop
-#define pp_scmp PERLpp_scmp
-#define pp_scope PERLpp_scope
-#define pp_seek PERLpp_seek
-#define pp_seekdir PERLpp_seekdir
-#define pp_select PERLpp_select
-#define pp_semctl PERLpp_semctl
-#define pp_semget PERLpp_semget
-#define pp_semop PERLpp_semop
-#define pp_send PERLpp_send
-#define pp_seq PERLpp_seq
-#define pp_setpgrp PERLpp_setpgrp
-#define pp_setpriority PERLpp_setpriority
-#define pp_sge PERLpp_sge
-#define pp_sgrent PERLpp_sgrent
-#define pp_sgt PERLpp_sgt
-#define pp_shift PERLpp_shift
-#define pp_shmctl PERLpp_shmctl
-#define pp_shmget PERLpp_shmget
-#define pp_shmread PERLpp_shmread
-#define pp_shmwrite PERLpp_shmwrite
-#define pp_shostent PERLpp_shostent
-#define pp_shutdown PERLpp_shutdown
-#define pp_sin PERLpp_sin
-#define pp_sle PERLpp_sle
-#define pp_sleep PERLpp_sleep
-#define pp_slt PERLpp_slt
-#define pp_sne PERLpp_sne
-#define pp_snetent PERLpp_snetent
-#define pp_socket PERLpp_socket
-#define pp_sockpair PERLpp_sockpair
-#define pp_sort PERLpp_sort
-#define pp_splice PERLpp_splice
-#define pp_split PERLpp_split
-#define pp_sprintf PERLpp_sprintf
-#define pp_sprotoent PERLpp_sprotoent
-#define pp_spwent PERLpp_spwent
-#define pp_sqrt PERLpp_sqrt
-#define pp_srand PERLpp_srand
-#define pp_sselect PERLpp_sselect
-#define pp_sservent PERLpp_sservent
-#define pp_ssockopt PERLpp_ssockopt
-#define pp_stat PERLpp_stat
-#define pp_stub PERLpp_stub
-#define pp_study PERLpp_study
-#define pp_subst PERLpp_subst
-#define pp_substcont PERLpp_substcont
-#define pp_substr PERLpp_substr
-#define pp_subtract PERLpp_subtract
-#define pp_sv2len PERLpp_sv2len
-#define pp_symlink PERLpp_symlink
-#define pp_syscall PERLpp_syscall
-#define pp_sysread PERLpp_sysread
-#define pp_system PERLpp_system
-#define pp_syswrite PERLpp_syswrite
-#define pp_tell PERLpp_tell
-#define pp_telldir PERLpp_telldir
-#define pp_tie PERLpp_tie
-#define pp_time PERLpp_time
-#define pp_tms PERLpp_tms
-#define pp_trans PERLpp_trans
-#define pp_truncate PERLpp_truncate
-#define pp_uc PERLpp_uc
-#define pp_ucfirst PERLpp_ucfirst
-#define pp_umask PERLpp_umask
-#define pp_undef PERLpp_undef
-#define pp_unlink PERLpp_unlink
-#define pp_unpack PERLpp_unpack
-#define pp_unshift PERLpp_unshift
-#define pp_unstack PERLpp_unstack
-#define pp_untie PERLpp_untie
-#define pp_utime PERLpp_utime
-#define pp_values PERLpp_values
-#define pp_vec PERLpp_vec
-#define pp_wait PERLpp_wait
-#define pp_waitpid PERLpp_waitpid
-#define pp_wantarray PERLpp_wantarray
-#define pp_warn PERLpp_warn
-#define pp_xor PERLpp_xor
-#define prepend_elem PERLprepend_elem
-#define push_return PERLpush_return
-#define push_scope PERLpush_scope
-#define pv_grow PERLpv_grow
-#define q PERLq
-#define ref PERLref
-#define refkids PERLrefkids
-#define regcomp PERLregcomp
-#define regdump PERLregdump
-#define regexec PERLregexec
-#define regfree PERLregfree
-#define regnext PERLregnext
-#define regprop PERLregprop
-#define repeatcpy PERLrepeatcpy
-#define rninstr PERLrninstr
-#define run PERLrun
-#define save_I32 PERLsave_I32
-#define save_aptr PERLsave_aptr
-#define save_ary PERLsave_ary
-#define save_hash PERLsave_hash
-#define save_hptr PERLsave_hptr
-#define save_int PERLsave_int
-#define save_item PERLsave_item
-#define save_list PERLsave_list
-#define save_nogv PERLsave_nogv
-#define save_scalar PERLsave_scalar
-#define save_sptr PERLsave_sptr
-#define save_svref PERLsave_svref
-#define savestack_grow PERLsavestack_grow
-#define savestr PERLsavestr
-#define sawparens PERLsawparens
-#define scalar PERLscalar
-#define scalarkids PERLscalarkids
-#define scalarseq PERLscalarseq
-#define scalarvoid PERLscalarvoid
-#define scan_const PERLscan_const
-#define scan_formline PERLscan_formline
-#define scan_heredoc PERLscan_heredoc
-#define scan_hex PERLscan_hex
-#define scan_ident PERLscan_ident
-#define scan_inputsymbol PERLscan_inputsymbol
-#define scan_num PERLscan_num
-#define scan_oct PERLscan_oct
-#define scan_pat PERLscan_pat
-#define scan_prefix PERLscan_prefix
-#define scan_str PERLscan_str
-#define scan_subst PERLscan_subst
-#define scan_trans PERLscan_trans
-#define scan_word PERLscan_word
-#define scope PERLscope
-#define screaminstr PERLscreaminstr
-#define setenv_getix PERLsetenv_getix
-#define skipspace PERLskipspace
-#define sublex_done PERLsublex_done
-#define sublex_start PERLsublex_start
-#define sv_2bool PERLsv_2bool
-#define sv_2cv PERLsv_2cv
-#define sv_2iv PERLsv_2iv
-#define sv_2mortal PERLsv_2mortal
-#define sv_2nv PERLsv_2nv
-#define sv_2pv PERLsv_2pv
-#define sv_backoff PERLsv_backoff
-#define sv_catpv PERLsv_catpv
-#define sv_catpvn PERLsv_catpvn
-#define sv_catsv PERLsv_catsv
-#define sv_chop PERLsv_chop
-#define sv_clear PERLsv_clear
-#define sv_cmp PERLsv_cmp
-#define sv_dec PERLsv_dec
-#define sv_eq PERLsv_eq
-#define sv_free PERLsv_free
-#define sv_gets PERLsv_gets
-#define sv_grow PERLsv_grow
-#define sv_inc PERLsv_inc
-#define sv_insert PERLsv_insert
-#define sv_isa PERLsv_isa
-#define sv_len PERLsv_len
-#define sv_magic PERLsv_magic
-#define sv_mortalcopy PERLsv_mortalcopy
-#define sv_peek PERLsv_peek
-#define sv_ref PERLsv_ref
-#define sv_replace PERLsv_replace
-#define sv_reset PERLsv_reset
-#define sv_setiv PERLsv_setiv
-#define sv_setnv PERLsv_setnv
-#define sv_setptrobj PERLsv_setptrobj
-#define sv_setpv PERLsv_setpv
-#define sv_setpvn PERLsv_setpvn
-#define sv_setsv PERLsv_setsv
-#define sv_unmagic PERLsv_unmagic
-#define sv_upgrade PERLsv_upgrade
-#define sv_usepvn PERLsv_usepvn
-#define taint_env PERLtaint_env
-#define taint_not PERLtaint_not
-#define taint_proper PERLtaint_proper
-#define too_few_arguments PERLtoo_few_arguments
-#define too_many_arguments PERLtoo_many_arguments
-#define wait4pid PERLwait4pid
-#define warn PERLwarn
-#define watch PERLwatch
-#define whichsig PERLwhichsig
-#define yyerror PERLyyerror
-#define yylex PERLyylex
-#define yyparse PERLyyparse
+#define No perl_No
+#define Sv perl_Sv
+#define Xpv perl_Xpv
+#define Yes perl_Yes
+#define additem perl_additem
+#define an perl_an
+#define buf perl_buf
+#define bufend perl_bufend
+#define bufptr perl_bufptr
+#define check perl_check
+#define coeff perl_coeff
+#define compiling perl_compiling
+#define comppad perl_comppad
+#define comppad_name perl_comppad_name
+#define comppad_name_fill perl_comppad_name_fill
+#define cop_seqmax perl_cop_seqmax
+#define cryptseen perl_cryptseen
+#define cshlen perl_cshlen
+#define cshname perl_cshname
+#define curinterp perl_curinterp
+#define curpad perl_curpad
+#define dc perl_dc
+#define di perl_di
+#define ds perl_ds
+#define egid perl_egid
+#define error_count perl_error_count
+#define euid perl_euid
+#define evalseq perl_evalseq
+#define evstr perl_evstr
+#define expect perl_expect
+#define expectterm perl_expectterm
+#define fold perl_fold
+#define freq perl_freq
+#define gid perl_gid
+#define hexdigit perl_hexdigit
+#define in_format perl_in_format
+#define in_my perl_in_my
+#define know_next perl_know_next
+#define last_lop perl_last_lop
+#define last_lop_op perl_last_lop_op
+#define last_uni perl_last_uni
+#define linestr perl_linestr
+#define markstack perl_markstack
+#define markstack_max perl_markstack_max
+#define markstack_ptr perl_markstack_ptr
+#define max_intro_pending perl_max_intro_pending
+#define min_intro_pending perl_min_intro_pending
+#define multi_close perl_multi_close
+#define multi_end perl_multi_end
+#define multi_open perl_multi_open
+#define multi_start perl_multi_start
+#define na perl_na
+#define needblockscope perl_needblockscope
+#define nexttype perl_nexttype
+#define nextval perl_nextval
+#define no_aelem perl_no_aelem
+#define no_dir_func perl_no_dir_func
+#define no_func perl_no_func
+#define no_helem perl_no_helem
+#define no_mem perl_no_mem
+#define no_modify perl_no_modify
+#define no_security perl_no_security
+#define no_sock_func perl_no_sock_func
+#define no_usym perl_no_usym
+#define nointrp perl_nointrp
+#define nomem perl_nomem
+#define nomemok perl_nomemok
+#define oldbufptr perl_oldbufptr
+#define oldoldbufptr perl_oldoldbufptr
+#define op perl_op
+#define op_name perl_op_name
+#define op_seqmax perl_op_seqmax
+#define opargs perl_opargs
+#define origalen perl_origalen
+#define origenviron perl_origenviron
+#define padix perl_padix
+#define patleave perl_patleave
+#define ppaddr perl_ppaddr
+#define rcsid perl_rcsid
+#define reall_srchlen perl_reall_srchlen
+#define regarglen perl_regarglen
+#define regbol perl_regbol
+#define regcode perl_regcode
+#define regdummy perl_regdummy
+#define regendp perl_regendp
+#define regeol perl_regeol
+#define regfold perl_regfold
+#define reginput perl_reginput
+#define reglastparen perl_reglastparen
+#define regmyendp perl_regmyendp
+#define regmyp_size perl_regmyp_size
+#define regmystartp perl_regmystartp
+#define regnarrate perl_regnarrate
+#define regnpar perl_regnpar
+#define regparse perl_regparse
+#define regprecomp perl_regprecomp
+#define regprev perl_regprev
+#define regsawback perl_regsawback
+#define regsawbracket perl_regsawbracket
+#define regsize perl_regsize
+#define regstartp perl_regstartp
+#define regtill perl_regtill
+#define regxend perl_regxend
+#define retstack perl_retstack
+#define retstack_ix perl_retstack_ix
+#define retstack_max perl_retstack_max
+#define rsfp perl_rsfp
+#define savestack perl_savestack
+#define savestack_ix perl_savestack_ix
+#define savestack_max perl_savestack_max
+#define saw_return perl_saw_return
+#define scopestack perl_scopestack
+#define scopestack_ix perl_scopestack_ix
+#define scopestack_max perl_scopestack_max
+#define scrgv perl_scrgv
+#define sig_name perl_sig_name
+#define simple perl_simple
+#define stack_base perl_stack_base
+#define stack_max perl_stack_max
+#define stack_sp perl_stack_sp
+#define statbuf perl_statbuf
+#define sub_generation perl_sub_generation
+#define subline perl_subline
+#define subname perl_subname
+#define sv_no perl_sv_no
+#define sv_undef perl_sv_undef
+#define sv_yes perl_sv_yes
+#define thisexpr perl_thisexpr
+#define timesbuf perl_timesbuf
+#define tokenbuf perl_tokenbuf
+#define uid perl_uid
+#define varies perl_varies
+#define vert perl_vert
+#define vtbl_arylen perl_vtbl_arylen
+#define vtbl_bm perl_vtbl_bm
+#define vtbl_dbline perl_vtbl_dbline
+#define vtbl_env perl_vtbl_env
+#define vtbl_envelem perl_vtbl_envelem
+#define vtbl_glob perl_vtbl_glob
+#define vtbl_isa perl_vtbl_isa
+#define vtbl_isaelem perl_vtbl_isaelem
+#define vtbl_mglob perl_vtbl_mglob
+#define vtbl_pack perl_vtbl_pack
+#define vtbl_packelem perl_vtbl_packelem
+#define vtbl_sig perl_vtbl_sig
+#define vtbl_sigelem perl_vtbl_sigelem
+#define vtbl_substr perl_vtbl_substr
+#define vtbl_sv perl_vtbl_sv
+#define vtbl_taint perl_vtbl_taint
+#define vtbl_uvar perl_vtbl_uvar
+#define vtbl_vec perl_vtbl_vec
+#define warn_nl perl_warn_nl
+#define warn_nosemi perl_warn_nosemi
+#define warn_reserved perl_warn_reserved
+#define watchaddr perl_watchaddr
+#define watchok perl_watchok
+#define yychar perl_yychar
+#define yycheck perl_yycheck
+#define yydebug perl_yydebug
+#define yydefred perl_yydefred
+#define yydgoto perl_yydgoto
+#define yyerrflag perl_yyerrflag
+#define yygindex perl_yygindex
+#define yylen perl_yylen
+#define yylhs perl_yylhs
+#define yylval perl_yylval
+#define yyname perl_yyname
+#define yynerrs perl_yynerrs
+#define yyrindex perl_yyrindex
+#define yyrule perl_yyrule
+#define yysindex perl_yysindex
+#define yytable perl_yytable
+#define yyval perl_yyval
+#define append_elem perl_append_elem
+#define append_list perl_append_list
+#define apply perl_apply
+#define av_clear perl_av_clear
+#define av_fake perl_av_fake
+#define av_fetch perl_av_fetch
+#define av_fill perl_av_fill
+#define av_free perl_av_free
+#define av_len perl_av_len
+#define av_make perl_av_make
+#define av_pop perl_av_pop
+#define av_popnulls perl_av_popnulls
+#define av_push perl_av_push
+#define av_shift perl_av_shift
+#define av_store perl_av_store
+#define av_undef perl_av_undef
+#define av_unshift perl_av_unshift
+#define bind_match perl_bind_match
+#define block_head perl_block_head
+#define calllist perl_calllist
+#define cando perl_cando
+#define check_uni perl_check_uni
+#define checkcomma perl_checkcomma
+#define ck_aelem perl_ck_aelem
+#define ck_chop perl_ck_chop
+#define ck_concat perl_ck_concat
+#define ck_eof perl_ck_eof
+#define ck_eval perl_ck_eval
+#define ck_exec perl_ck_exec
+#define ck_formline perl_ck_formline
+#define ck_ftst perl_ck_ftst
+#define ck_fun perl_ck_fun
+#define ck_glob perl_ck_glob
+#define ck_grep perl_ck_grep
+#define ck_gvconst perl_ck_gvconst
+#define ck_index perl_ck_index
+#define ck_lengthconst perl_ck_lengthconst
+#define ck_lfun perl_ck_lfun
+#define ck_listiob perl_ck_listiob
+#define ck_match perl_ck_match
+#define ck_null perl_ck_null
+#define ck_repeat perl_ck_repeat
+#define ck_retarget perl_ck_retarget
+#define ck_rvconst perl_ck_rvconst
+#define ck_select perl_ck_select
+#define ck_shift perl_ck_shift
+#define ck_sort perl_ck_sort
+#define ck_split perl_ck_split
+#define ck_subr perl_ck_subr
+#define ck_trunc perl_ck_trunc
+#define convert perl_convert
+#define cpy7bit perl_cpy7bit
+#define cpytill perl_cpytill
+#define croak perl_croak
+#define cv_clear perl_cv_clear
+#define cxinc perl_cxinc
+#define deb perl_deb
+#define deb_growlevel perl_deb_growlevel
+#define debop perl_debop
+#define debstack perl_debstack
+#define debstackptrs perl_debstackptrs
+#define die perl_die
+#define die_where perl_die_where
+#define do_aexec perl_do_aexec
+#define do_chop perl_do_chop
+#define do_close perl_do_close
+#define do_ctl perl_do_ctl
+#define do_eof perl_do_eof
+#define do_exec perl_do_exec
+#define do_execfree perl_do_execfree
+#define do_ipcctl perl_do_ipcctl
+#define do_ipcget perl_do_ipcget
+#define do_join perl_do_join
+#define do_kv perl_do_kv
+#define do_msgrcv perl_do_msgrcv
+#define do_msgsnd perl_do_msgsnd
+#define do_open perl_do_open
+#define do_pipe perl_do_pipe
+#define do_print perl_do_print
+#define do_readline perl_do_readline
+#define do_seek perl_do_seek
+#define do_semop perl_do_semop
+#define do_shmio perl_do_shmio
+#define do_sprintf perl_do_sprintf
+#define do_tell perl_do_tell
+#define do_trans perl_do_trans
+#define do_vecset perl_do_vecset
+#define do_vop perl_do_vop
+#define doeval perl_doeval
+#define dofindlabel perl_dofindlabel
+#define dopoptoeval perl_dopoptoeval
+#define dump_all perl_dump_all
+#define dump_eval perl_dump_eval
+#define dump_gv perl_dump_gv
+#define dump_op perl_dump_op
+#define dump_packsubs perl_dump_packsubs
+#define dump_pm perl_dump_pm
+#define dump_sub perl_dump_sub
+#define fbm_compile perl_fbm_compile
+#define fbm_instr perl_fbm_instr
+#define fetch_gv perl_fetch_gv
+#define fetch_io perl_fetch_io
+#define fetch_stash perl_fetch_stash
+#define fold_constants perl_fold_constants
+#define force_ident perl_force_ident
+#define force_next perl_force_next
+#define force_word perl_force_word
+#define free_tmps perl_free_tmps
+#define gen_constant_list perl_gen_constant_list
+#define getgimme perl_getgimme
+#define gp_free perl_gp_free
+#define gp_ref perl_gp_ref
+#define gv_AVadd perl_gv_AVadd
+#define gv_HVadd perl_gv_HVadd
+#define gv_check perl_gv_check
+#define gv_efullname perl_gv_efullname
+#define gv_fetchfile perl_gv_fetchfile
+#define gv_fetchmeth perl_gv_fetchmeth
+#define gv_fetchmethod perl_gv_fetchmethod
+#define gv_fetchpv perl_gv_fetchpv
+#define gv_fullname perl_gv_fullname
+#define gv_init perl_gv_init
+#define he_delayfree perl_he_delayfree
+#define he_free perl_he_free
+#define hoistmust perl_hoistmust
+#define hv_clear perl_hv_clear
+#define hv_delete perl_hv_delete
+#define hv_fetch perl_hv_fetch
+#define hv_free perl_hv_free
+#define hv_iterinit perl_hv_iterinit
+#define hv_iterkey perl_hv_iterkey
+#define hv_iternext perl_hv_iternext
+#define hv_iterval perl_hv_iterval
+#define hv_magic perl_hv_magic
+#define hv_store perl_hv_store
+#define hv_undef perl_hv_undef
+#define ibcmp perl_ibcmp
+#define ingroup perl_ingroup
+#define instr perl_instr
+#define intuit_more perl_intuit_more
+#define invert perl_invert
+#define jmaybe perl_jmaybe
+#define keyword perl_keyword
+#define leave_scope perl_leave_scope
+#define lex_end perl_lex_end
+#define lex_start perl_lex_start
+#define linklist perl_linklist
+#define list perl_list
+#define listkids perl_listkids
+#define localize perl_localize
+#define looks_like_number perl_looks_like_number
+#define magic_clearpack perl_magic_clearpack
+#define magic_get perl_magic_get
+#define magic_getarylen perl_magic_getarylen
+#define magic_getglob perl_magic_getglob
+#define magic_getpack perl_magic_getpack
+#define magic_gettaint perl_magic_gettaint
+#define magic_getuvar perl_magic_getuvar
+#define magic_len perl_magic_len
+#define magic_nextpack perl_magic_nextpack
+#define magic_set perl_magic_set
+#define magic_setarylen perl_magic_setarylen
+#define magic_setbm perl_magic_setbm
+#define magic_setdbline perl_magic_setdbline
+#define magic_setenv perl_magic_setenv
+#define magic_setglob perl_magic_setglob
+#define magic_setisa perl_magic_setisa
+#define magic_setmglob perl_magic_setmglob
+#define magic_setpack perl_magic_setpack
+#define magic_setsig perl_magic_setsig
+#define magic_setsubstr perl_magic_setsubstr
+#define magic_settaint perl_magic_settaint
+#define magic_setuvar perl_magic_setuvar
+#define magic_setvec perl_magic_setvec
+#define magicname perl_magicname
+#define mess perl_mess
+#define mg_clear perl_mg_clear
+#define mg_copy perl_mg_copy
+#define mg_find perl_mg_find
+#define mg_free perl_mg_free
+#define mg_get perl_mg_get
+#define mg_len perl_mg_len
+#define mg_magical perl_mg_magical
+#define mg_set perl_mg_set
+#define mod perl_mod
+#define modkids perl_modkids
+#define moreswitches perl_moreswitches
+#define my perl_my
+#define my_exit perl_my_exit
+#define my_lstat perl_my_lstat
+#define my_pclose perl_my_pclose
+#define my_popen perl_my_popen
+#define my_setenv perl_my_setenv
+#define my_stat perl_my_stat
+#define my_unexec perl_my_unexec
+#define newANONHASH perl_newANONHASH
+#define newANONLIST perl_newANONLIST
+#define newASSIGNOP perl_newASSIGNOP
+#define newAV perl_newAV
+#define newAVREF perl_newAVREF
+#define newBINOP perl_newBINOP
+#define newCONDOP perl_newCONDOP
+#define newCVOP perl_newCVOP
+#define newCVREF perl_newCVREF
+#define newFORM perl_newFORM
+#define newFOROP perl_newFOROP
+#define newGVOP perl_newGVOP
+#define newGVREF perl_newGVREF
+#define newGVgen perl_newGVgen
+#define newHV perl_newHV
+#define newHVREF perl_newHVREF
+#define newIO perl_newIO
+#define newLISTOP perl_newLISTOP
+#define newLOGOP perl_newLOGOP
+#define newLOOPEX perl_newLOOPEX
+#define newLOOPOP perl_newLOOPOP
+#define newMETHOD perl_newMETHOD
+#define newNULLLIST perl_newNULLLIST
+#define newOP perl_newOP
+#define newPMOP perl_newPMOP
+#define newPVOP perl_newPVOP
+#define newRANGE perl_newRANGE
+#define newSLICEOP perl_newSLICEOP
+#define newSTATEOP perl_newSTATEOP
+#define newSUB perl_newSUB
+#define newSV perl_newSV
+#define newSVOP perl_newSVOP
+#define newSVREF perl_newSVREF
+#define newSViv perl_newSViv
+#define newSVnv perl_newSVnv
+#define newSVpv perl_newSVpv
+#define newSVsv perl_newSVsv
+#define newUNOP perl_newUNOP
+#define newWHILEOP perl_newWHILEOP
+#define newXSUB perl_newXSUB
+#define nextargv perl_nextargv
+#define ninstr perl_ninstr
+#define no_fh_allowed perl_no_fh_allowed
+#define no_op perl_no_op
+#define nsavestr perl_nsavestr
+#define oopsAV perl_oopsAV
+#define oopsCV perl_oopsCV
+#define oopsHV perl_oopsHV
+#define op_free perl_op_free
+#define package perl_package
+#define pad_alloc perl_pad_alloc
+#define pad_allocmy perl_pad_allocmy
+#define pad_findmy perl_pad_findmy
+#define pad_free perl_pad_free
+#define pad_leavemy perl_pad_leavemy
+#define pad_reset perl_pad_reset
+#define pad_sv perl_pad_sv
+#define pad_swipe perl_pad_swipe
+#define peep perl_peep
+#define pidgone perl_pidgone
+#define pmruntime perl_pmruntime
+#define pmtrans perl_pmtrans
+#define pop_return perl_pop_return
+#define pop_scope perl_pop_scope
+#define pp_aassign perl_pp_aassign
+#define pp_accept perl_pp_accept
+#define pp_add perl_pp_add
+#define pp_aelem perl_pp_aelem
+#define pp_aelemfast perl_pp_aelemfast
+#define pp_alarm perl_pp_alarm
+#define pp_and perl_pp_and
+#define pp_andassign perl_pp_andassign
+#define pp_anonhash perl_pp_anonhash
+#define pp_anonlist perl_pp_anonlist
+#define pp_aslice perl_pp_aslice
+#define pp_atan2 perl_pp_atan2
+#define pp_av2arylen perl_pp_av2arylen
+#define pp_backtick perl_pp_backtick
+#define pp_bind perl_pp_bind
+#define pp_binmode perl_pp_binmode
+#define pp_bit_and perl_pp_bit_and
+#define pp_bit_or perl_pp_bit_or
+#define pp_bless perl_pp_bless
+#define pp_caller perl_pp_caller
+#define pp_chdir perl_pp_chdir
+#define pp_chmod perl_pp_chmod
+#define pp_chop perl_pp_chop
+#define pp_chown perl_pp_chown
+#define pp_chroot perl_pp_chroot
+#define pp_close perl_pp_close
+#define pp_closedir perl_pp_closedir
+#define pp_complement perl_pp_complement
+#define pp_concat perl_pp_concat
+#define pp_cond_expr perl_pp_cond_expr
+#define pp_connect perl_pp_connect
+#define pp_const perl_pp_const
+#define pp_cos perl_pp_cos
+#define pp_crypt perl_pp_crypt
+#define pp_cswitch perl_pp_cswitch
+#define pp_dbmclose perl_pp_dbmclose
+#define pp_dbmopen perl_pp_dbmopen
+#define pp_dbstate perl_pp_dbstate
+#define pp_defined perl_pp_defined
+#define pp_delete perl_pp_delete
+#define pp_die perl_pp_die
+#define pp_divide perl_pp_divide
+#define pp_dofile perl_pp_dofile
+#define pp_done perl_pp_done
+#define pp_dump perl_pp_dump
+#define pp_each perl_pp_each
+#define pp_egrent perl_pp_egrent
+#define pp_ehostent perl_pp_ehostent
+#define pp_enetent perl_pp_enetent
+#define pp_enter perl_pp_enter
+#define pp_entereval perl_pp_entereval
+#define pp_enteriter perl_pp_enteriter
+#define pp_enterloop perl_pp_enterloop
+#define pp_entersubr perl_pp_entersubr
+#define pp_entertry perl_pp_entertry
+#define pp_enterwrite perl_pp_enterwrite
+#define pp_eof perl_pp_eof
+#define pp_eprotoent perl_pp_eprotoent
+#define pp_epwent perl_pp_epwent
+#define pp_eq perl_pp_eq
+#define pp_eservent perl_pp_eservent
+#define pp_evalonce perl_pp_evalonce
+#define pp_exec perl_pp_exec
+#define pp_exit perl_pp_exit
+#define pp_exp perl_pp_exp
+#define pp_fcntl perl_pp_fcntl
+#define pp_fileno perl_pp_fileno
+#define pp_flip perl_pp_flip
+#define pp_flock perl_pp_flock
+#define pp_flop perl_pp_flop
+#define pp_fork perl_pp_fork
+#define pp_formline perl_pp_formline
+#define pp_ftatime perl_pp_ftatime
+#define pp_ftbinary perl_pp_ftbinary
+#define pp_ftblk perl_pp_ftblk
+#define pp_ftchr perl_pp_ftchr
+#define pp_ftctime perl_pp_ftctime
+#define pp_ftdir perl_pp_ftdir
+#define pp_fteexec perl_pp_fteexec
+#define pp_fteowned perl_pp_fteowned
+#define pp_fteread perl_pp_fteread
+#define pp_ftewrite perl_pp_ftewrite
+#define pp_ftfile perl_pp_ftfile
+#define pp_ftis perl_pp_ftis
+#define pp_ftlink perl_pp_ftlink
+#define pp_ftmtime perl_pp_ftmtime
+#define pp_ftpipe perl_pp_ftpipe
+#define pp_ftrexec perl_pp_ftrexec
+#define pp_ftrowned perl_pp_ftrowned
+#define pp_ftrread perl_pp_ftrread
+#define pp_ftrwrite perl_pp_ftrwrite
+#define pp_ftsgid perl_pp_ftsgid
+#define pp_ftsize perl_pp_ftsize
+#define pp_ftsock perl_pp_ftsock
+#define pp_ftsuid perl_pp_ftsuid
+#define pp_ftsvtx perl_pp_ftsvtx
+#define pp_fttext perl_pp_fttext
+#define pp_fttty perl_pp_fttty
+#define pp_ftzero perl_pp_ftzero
+#define pp_ge perl_pp_ge
+#define pp_getc perl_pp_getc
+#define pp_getlogin perl_pp_getlogin
+#define pp_getpeername perl_pp_getpeername
+#define pp_getpgrp perl_pp_getpgrp
+#define pp_getppid perl_pp_getppid
+#define pp_getpriority perl_pp_getpriority
+#define pp_getsockname perl_pp_getsockname
+#define pp_ggrent perl_pp_ggrent
+#define pp_ggrgid perl_pp_ggrgid
+#define pp_ggrnam perl_pp_ggrnam
+#define pp_ghbyaddr perl_pp_ghbyaddr
+#define pp_ghbyname perl_pp_ghbyname
+#define pp_ghostent perl_pp_ghostent
+#define pp_glob perl_pp_glob
+#define pp_gmtime perl_pp_gmtime
+#define pp_gnbyaddr perl_pp_gnbyaddr
+#define pp_gnbyname perl_pp_gnbyname
+#define pp_gnetent perl_pp_gnetent
+#define pp_goto perl_pp_goto
+#define pp_gpbyname perl_pp_gpbyname
+#define pp_gpbynumber perl_pp_gpbynumber
+#define pp_gprotoent perl_pp_gprotoent
+#define pp_gpwent perl_pp_gpwent
+#define pp_gpwnam perl_pp_gpwnam
+#define pp_gpwuid perl_pp_gpwuid
+#define pp_grepstart perl_pp_grepstart
+#define pp_grepwhile perl_pp_grepwhile
+#define pp_gsbyname perl_pp_gsbyname
+#define pp_gsbyport perl_pp_gsbyport
+#define pp_gservent perl_pp_gservent
+#define pp_gsockopt perl_pp_gsockopt
+#define pp_gt perl_pp_gt
+#define pp_gv perl_pp_gv
+#define pp_gvsv perl_pp_gvsv
+#define pp_helem perl_pp_helem
+#define pp_hex perl_pp_hex
+#define pp_hslice perl_pp_hslice
+#define pp_index perl_pp_index
+#define pp_indread perl_pp_indread
+#define pp_int perl_pp_int
+#define pp_intadd perl_pp_intadd
+#define pp_interp perl_pp_interp
+#define pp_ioctl perl_pp_ioctl
+#define pp_iter perl_pp_iter
+#define pp_join perl_pp_join
+#define pp_keys perl_pp_keys
+#define pp_kill perl_pp_kill
+#define pp_last perl_pp_last
+#define pp_lc perl_pp_lc
+#define pp_lcfirst perl_pp_lcfirst
+#define pp_le perl_pp_le
+#define pp_leave perl_pp_leave
+#define pp_leaveeval perl_pp_leaveeval
+#define pp_leaveloop perl_pp_leaveloop
+#define pp_leavesubr perl_pp_leavesubr
+#define pp_leavetry perl_pp_leavetry
+#define pp_leavewrite perl_pp_leavewrite
+#define pp_left_shift perl_pp_left_shift
+#define pp_length perl_pp_length
+#define pp_lineseq perl_pp_lineseq
+#define pp_link perl_pp_link
+#define pp_list perl_pp_list
+#define pp_listen perl_pp_listen
+#define pp_localtime perl_pp_localtime
+#define pp_log perl_pp_log
+#define pp_lslice perl_pp_lslice
+#define pp_lstat perl_pp_lstat
+#define pp_lt perl_pp_lt
+#define pp_match perl_pp_match
+#define pp_method perl_pp_method
+#define pp_mkdir perl_pp_mkdir
+#define pp_modulo perl_pp_modulo
+#define pp_msgctl perl_pp_msgctl
+#define pp_msgget perl_pp_msgget
+#define pp_msgrcv perl_pp_msgrcv
+#define pp_msgsnd perl_pp_msgsnd
+#define pp_multiply perl_pp_multiply
+#define pp_ncmp perl_pp_ncmp
+#define pp_ne perl_pp_ne
+#define pp_negate perl_pp_negate
+#define pp_next perl_pp_next
+#define pp_nextstate perl_pp_nextstate
+#define pp_not perl_pp_not
+#define pp_nswitch perl_pp_nswitch
+#define pp_null perl_pp_null
+#define pp_oct perl_pp_oct
+#define pp_open perl_pp_open
+#define pp_open_dir perl_pp_open_dir
+#define pp_or perl_pp_or
+#define pp_orassign perl_pp_orassign
+#define pp_ord perl_pp_ord
+#define pp_pack perl_pp_pack
+#define pp_padav perl_pp_padav
+#define pp_padhv perl_pp_padhv
+#define pp_padsv perl_pp_padsv
+#define pp_pipe_op perl_pp_pipe_op
+#define pp_pop perl_pp_pop
+#define pp_postdec perl_pp_postdec
+#define pp_postinc perl_pp_postinc
+#define pp_pow perl_pp_pow
+#define pp_predec perl_pp_predec
+#define pp_preinc perl_pp_preinc
+#define pp_print perl_pp_print
+#define pp_prtf perl_pp_prtf
+#define pp_push perl_pp_push
+#define pp_pushmark perl_pp_pushmark
+#define pp_pushre perl_pp_pushre
+#define pp_rand perl_pp_rand
+#define pp_range perl_pp_range
+#define pp_rcatline perl_pp_rcatline
+#define pp_read perl_pp_read
+#define pp_readdir perl_pp_readdir
+#define pp_readline perl_pp_readline
+#define pp_readlink perl_pp_readlink
+#define pp_recv perl_pp_recv
+#define pp_redo perl_pp_redo
+#define pp_ref perl_pp_ref
+#define pp_refgen perl_pp_refgen
+#define pp_regcmaybe perl_pp_regcmaybe
+#define pp_regcomp perl_pp_regcomp
+#define pp_rename perl_pp_rename
+#define pp_repeat perl_pp_repeat
+#define pp_require perl_pp_require
+#define pp_reset perl_pp_reset
+#define pp_return perl_pp_return
+#define pp_reverse perl_pp_reverse
+#define pp_rewinddir perl_pp_rewinddir
+#define pp_right_shift perl_pp_right_shift
+#define pp_rindex perl_pp_rindex
+#define pp_rmdir perl_pp_rmdir
+#define pp_rv2av perl_pp_rv2av
+#define pp_rv2cv perl_pp_rv2cv
+#define pp_rv2gv perl_pp_rv2gv
+#define pp_rv2hv perl_pp_rv2hv
+#define pp_rv2sv perl_pp_rv2sv
+#define pp_sassign perl_pp_sassign
+#define pp_scalar perl_pp_scalar
+#define pp_schop perl_pp_schop
+#define pp_scmp perl_pp_scmp
+#define pp_scope perl_pp_scope
+#define pp_seek perl_pp_seek
+#define pp_seekdir perl_pp_seekdir
+#define pp_select perl_pp_select
+#define pp_semctl perl_pp_semctl
+#define pp_semget perl_pp_semget
+#define pp_semop perl_pp_semop
+#define pp_send perl_pp_send
+#define pp_seq perl_pp_seq
+#define pp_setpgrp perl_pp_setpgrp
+#define pp_setpriority perl_pp_setpriority
+#define pp_sge perl_pp_sge
+#define pp_sgrent perl_pp_sgrent
+#define pp_sgt perl_pp_sgt
+#define pp_shift perl_pp_shift
+#define pp_shmctl perl_pp_shmctl
+#define pp_shmget perl_pp_shmget
+#define pp_shmread perl_pp_shmread
+#define pp_shmwrite perl_pp_shmwrite
+#define pp_shostent perl_pp_shostent
+#define pp_shutdown perl_pp_shutdown
+#define pp_sin perl_pp_sin
+#define pp_sle perl_pp_sle
+#define pp_sleep perl_pp_sleep
+#define pp_slt perl_pp_slt
+#define pp_sne perl_pp_sne
+#define pp_snetent perl_pp_snetent
+#define pp_socket perl_pp_socket
+#define pp_sockpair perl_pp_sockpair
+#define pp_sort perl_pp_sort
+#define pp_splice perl_pp_splice
+#define pp_split perl_pp_split
+#define pp_sprintf perl_pp_sprintf
+#define pp_sprotoent perl_pp_sprotoent
+#define pp_spwent perl_pp_spwent
+#define pp_sqrt perl_pp_sqrt
+#define pp_srand perl_pp_srand
+#define pp_sselect perl_pp_sselect
+#define pp_sservent perl_pp_sservent
+#define pp_ssockopt perl_pp_ssockopt
+#define pp_stat perl_pp_stat
+#define pp_stub perl_pp_stub
+#define pp_study perl_pp_study
+#define pp_subst perl_pp_subst
+#define pp_substcont perl_pp_substcont
+#define pp_substr perl_pp_substr
+#define pp_subtract perl_pp_subtract
+#define pp_sv2len perl_pp_sv2len
+#define pp_symlink perl_pp_symlink
+#define pp_syscall perl_pp_syscall
+#define pp_sysread perl_pp_sysread
+#define pp_system perl_pp_system
+#define pp_syswrite perl_pp_syswrite
+#define pp_tell perl_pp_tell
+#define pp_telldir perl_pp_telldir
+#define pp_tie perl_pp_tie
+#define pp_time perl_pp_time
+#define pp_tms perl_pp_tms
+#define pp_trans perl_pp_trans
+#define pp_truncate perl_pp_truncate
+#define pp_uc perl_pp_uc
+#define pp_ucfirst perl_pp_ucfirst
+#define pp_umask perl_pp_umask
+#define pp_undef perl_pp_undef
+#define pp_unlink perl_pp_unlink
+#define pp_unpack perl_pp_unpack
+#define pp_unshift perl_pp_unshift
+#define pp_unstack perl_pp_unstack
+#define pp_untie perl_pp_untie
+#define pp_utime perl_pp_utime
+#define pp_values perl_pp_values
+#define pp_vec perl_pp_vec
+#define pp_wait perl_pp_wait
+#define pp_waitpid perl_pp_waitpid
+#define pp_wantarray perl_pp_wantarray
+#define pp_warn perl_pp_warn
+#define pp_xor perl_pp_xor
+#define prepend_elem perl_prepend_elem
+#define push_return perl_push_return
+#define push_scope perl_push_scope
+#define q perl_q
+#define ref perl_ref
+#define refkids perl_refkids
+#define regcomp perl_regcomp
+#define regdump perl_regdump
+#define regexec perl_regexec
+#define regfree perl_regfree
+#define regnext perl_regnext
+#define regprop perl_regprop
+#define repeatcpy perl_repeatcpy
+#define rninstr perl_rninstr
+#define run perl_run
+#define save_I32 perl_save_I32
+#define save_aptr perl_save_aptr
+#define save_ary perl_save_ary
+#define save_clearsv perl_save_clearsv
+#define save_delete perl_save_delete
+#define save_freeop perl_save_freeop
+#define save_freepv perl_save_freepv
+#define save_freesv perl_save_freesv
+#define save_hash perl_save_hash
+#define save_hptr perl_save_hptr
+#define save_int perl_save_int
+#define save_item perl_save_item
+#define save_list perl_save_list
+#define save_nogv perl_save_nogv
+#define save_scalar perl_save_scalar
+#define save_sptr perl_save_sptr
+#define save_svref perl_save_svref
+#define savestack_grow perl_savestack_grow
+#define savestr perl_savestr
+#define sawparens perl_sawparens
+#define scalar perl_scalar
+#define scalarkids perl_scalarkids
+#define scalarseq perl_scalarseq
+#define scalarvoid perl_scalarvoid
+#define scan_const perl_scan_const
+#define scan_formline perl_scan_formline
+#define scan_heredoc perl_scan_heredoc
+#define scan_hex perl_scan_hex
+#define scan_ident perl_scan_ident
+#define scan_inputsymbol perl_scan_inputsymbol
+#define scan_num perl_scan_num
+#define scan_oct perl_scan_oct
+#define scan_pat perl_scan_pat
+#define scan_prefix perl_scan_prefix
+#define scan_str perl_scan_str
+#define scan_subst perl_scan_subst
+#define scan_trans perl_scan_trans
+#define scan_word perl_scan_word
+#define scope perl_scope
+#define screaminstr perl_screaminstr
+#define setenv_getix perl_setenv_getix
+#define skipspace perl_skipspace
+#define start_subparse perl_start_subparse
+#define sublex_done perl_sublex_done
+#define sublex_start perl_sublex_start
+#define sv_2bool perl_sv_2bool
+#define sv_2cv perl_sv_2cv
+#define sv_2iv perl_sv_2iv
+#define sv_2mortal perl_sv_2mortal
+#define sv_2nv perl_sv_2nv
+#define sv_2pv perl_sv_2pv
+#define sv_backoff perl_sv_backoff
+#define sv_catpv perl_sv_catpv
+#define sv_catpvn perl_sv_catpvn
+#define sv_catsv perl_sv_catsv
+#define sv_chop perl_sv_chop
+#define sv_clean_all perl_sv_clean_all
+#define sv_clean_magic perl_sv_clean_magic
+#define sv_clean_refs perl_sv_clean_refs
+#define sv_clear perl_sv_clear
+#define sv_cmp perl_sv_cmp
+#define sv_dec perl_sv_dec
+#define sv_dump perl_sv_dump
+#define sv_eq perl_sv_eq
+#define sv_free perl_sv_free
+#define sv_gets perl_sv_gets
+#define sv_grow perl_sv_grow
+#define sv_inc perl_sv_inc
+#define sv_insert perl_sv_insert
+#define sv_isa perl_sv_isa
+#define sv_len perl_sv_len
+#define sv_magic perl_sv_magic
+#define sv_mortalcopy perl_sv_mortalcopy
+#define sv_newmortal perl_sv_newmortal
+#define sv_peek perl_sv_peek
+#define sv_ref perl_sv_ref
+#define sv_replace perl_sv_replace
+#define sv_report_used perl_sv_report_used
+#define sv_reset perl_sv_reset
+#define sv_setiv perl_sv_setiv
+#define sv_setnv perl_sv_setnv
+#define sv_setptrobj perl_sv_setptrobj
+#define sv_setpv perl_sv_setpv
+#define sv_setpvn perl_sv_setpvn
+#define sv_setsv perl_sv_setsv
+#define sv_unmagic perl_sv_unmagic
+#define sv_upgrade perl_sv_upgrade
+#define sv_usepvn perl_sv_usepvn
+#define taint_env perl_taint_env
+#define taint_not perl_taint_not
+#define taint_proper perl_taint_proper
+#define too_few_arguments perl_too_few_arguments
+#define too_many_arguments perl_too_many_arguments
+#define wait4pid perl_wait4pid
+#define warn perl_warn
+#define watch perl_watch
+#define whichsig perl_whichsig
+#define xiv_root perl_xiv_root
+#define xnv_root perl_xnv_root
+#define xpv_root perl_xpv_root
+#define xrv_root perl_xrv_root
+#define yyerror perl_yyerror
+#define yyerror perl_yyerror
+#define yylex perl_yylex
+#define yyparse perl_yyparse
+#define yywarn perl_yywarn
-#endif /* EMBEDDED */
+#endif /* EMBED */
-/* Put interpreter specific variables into a struct? */
+/* Put interpreter specific symbols into a struct? */
#ifdef MULTIPLICITY
#define forkprocess (curinterp->Iforkprocess)
#define formfeed (curinterp->Iformfeed)
#define formtarget (curinterp->Iformtarget)
-#define freestrroot (curinterp->Ifreestrroot)
#define gensym (curinterp->Igensym)
#define in_eval (curinterp->Iin_eval)
#define incgv (curinterp->Iincgv)
#define statusvalue (curinterp->Istatusvalue)
#define stdingv (curinterp->Istdingv)
#define strchop (curinterp->Istrchop)
+#define sv_count (curinterp->Isv_count)
+#define sv_rvcount (curinterp->Isv_rvcount)
+#define sv_root (curinterp->Isv_root)
+#define sv_arenaroot (curinterp->Isv_arenaroot)
#define tainted (curinterp->Itainted)
#define tainting (curinterp->Itainting)
#define tmps_floor (curinterp->Itmps_floor)
#define toptarget (curinterp->Itoptarget)
#define unsafe (curinterp->Iunsafe)
-#else /* not multiple, so translate interpreter variables the other way... */
+#else /* not multiple, so translate interpreter symbols the other way... */
#define IArgv Argv
#define ICmd Cmd
#define Iforkprocess forkprocess
#define Iformfeed formfeed
#define Iformtarget formtarget
-#define Ifreestrroot freestrroot
#define Igensym gensym
#define Iin_eval in_eval
#define Iincgv incgv
#define Istatusvalue statusvalue
#define Istdingv stdingv
#define Istrchop strchop
+#define Isv_count sv_count
+#define Isv_rvcount sv_rvcount
+#define Isv_root sv_root
+#define Isv_arenaroot sv_arenaroot
#define Itainted tainted
#define Itainting tainting
#define Itmps_floor tmps_floor
#define Itoptarget toptarget
#define Iunsafe unsafe
-#endif /* MULTIPLE_INTERPRETERS */
+#endif /* MULTIPLICITY */
#!/bin/sh
cat <<'END' >embed.h
-/* This file is derived from global.var and interp.var */
+/* This file is derived from global.sym and interp.sym */
/* (Doing namespace management portably in C is really gross.) */
/* globals we need to hide from the world */
END
-sed <global.var >>embed.h \
+sed <global.sym >>embed.h \
-e 's/[ ]*#.*//' \
-e '/^[ ]*$/d' \
- -e 's/\(.*\)/#define \1 PERL\1/' \
+ -e 's/\(.*\)/#define \1 perl_\1/' \
-e 's/\(................ \) /\1/'
cat <<'END' >> embed.h
-#endif /* EMBEDDED */
+#endif /* EMBED */
-/* Put interpreter specific variables into a struct? */
+/* Put interpreter specific symbols into a struct? */
#ifdef MULTIPLICITY
END
-sed <interp.var >>embed.h \
+sed <interp.sym >>embed.h \
-e 's/[ ]*#.*//' \
-e '/^[ ]*$/d' \
-e 's/\(.*\)/#define \1 (curinterp->I\1)/' \
cat <<'END' >> embed.h
-#else /* not multiple, so translate interpreter variables the other way... */
+#else /* not multiple, so translate interpreter symbols the other way... */
END
-sed <interp.var >>embed.h \
+sed <interp.sym >>embed.h \
-e 's/[ ]*#.*//' \
-e '/^[ ]*$/d' \
-e 's/\(.*\)/#define I\1 \1/' \
cat <<'END' >> embed.h
-#endif /* MULTIPLE_INTERPRETERS */
+#endif /* MULTIPLICITY */
END
+++ /dev/null
-/* $RCSfile: eval.c,v $$Revision: 4.1 $$Date: 92/08/07 18:20:29 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: eval.c,v $
- * Revision 4.1 92/08/07 18:20:29 lwall
- *
- * Revision 4.0.1.4 92/06/08 13:20:20 lwall
- * patch20: added explicit time_t support
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: added Atari ST portability
- * patch20: new warning for use of x with non-numeric right operand
- * patch20: modulus with highest bit in left operand set didn't always work
- * patch20: dbmclose(%array) didn't work
- * patch20: added ... as variant on ..
- * patch20: O_PIPE conflicted with Atari
- *
- * Revision 4.0.1.3 91/11/05 17:15:21 lwall
- * patch11: prepared for ctype implementations that don't define isascii()
- * patch11: various portability fixes
- * patch11: added sort {} LIST
- * patch11: added eval {}
- * patch11: sysread() in socket was substituting recv()
- * patch11: a last statement outside any block caused occasional core dumps
- * patch11: missing arguments caused core dump in -D8 code
- * patch11: eval 'stuff' now optimized to eval {stuff}
- *
- * Revision 4.0.1.2 91/06/07 11:07:23 lwall
- * patch4: new copyright notice
- * patch4: length($`), length($&), length($') now optimized to avoid string copy
- * patch4: assignment wasn't correctly de-tainting the assigned variable.
- * patch4: default top-of-form format is now FILEHANDLE_TOP
- * patch4: added $^P variable to control calling of perldb routines
- * patch4: taintchecks could improperly modify parent in vfork()
- * patch4: many, many itty-bitty portability fixes
- *
- * Revision 4.0.1.1 91/04/11 17:43:48 lwall
- * patch1: fixed failed fork to return undef as documented
- * patch1: reduced maximum branch distance in eval.c
- *
- * Revision 4.0 91/03/20 01:16:48 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-extern int (*ppaddr[])();
-extern int mark[];
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
-#include <signal.h>
-#endif
-
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef MSDOS
-/* I_FCNTL *MUST* not be defined for MS-DOS and OS/2
- but fcntl.h is required for O_BINARY */
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
-#ifdef I_VFORK
-# include <vfork.h>
-#endif
-
-double sin(), cos(), atan2(), pow();
-
-char *getlogin();
-
-int
-eval(arg,gimme,sp)
-register ARG *arg;
-int gimme;
-register int sp;
-{
- register STR *str;
- register int anum;
- register int optype;
- register STR **st;
- int maxarg;
- double value;
- register char *tmps;
- char *tmps2;
- int argflags;
- int argtype;
- union argptr argptr;
- int arglast[8]; /* highest sp for arg--valid only for non-O_LIST args */
- unsigned long tmpulong;
- long tmplong;
- time_t when;
- STRLEN tmplen;
- FILE *fp;
- STR *tmpstr;
- FCMD *form;
- STAB *stab;
- STAB *stab2;
- STIO *stio;
- ARRAY *ary;
- int old_rslen;
- int old_rschar;
- VOIDRET (*ihand)(); /* place to save signal during system() */
- VOIDRET (*qhand)(); /* place to save signal during system() */
- bool assigning = FALSE;
- int mymarkbase = savestack->ary_fill;
-
- if (!arg)
- goto say_undef;
- optype = arg->arg_type;
- maxarg = arg->arg_len;
- arglast[0] = sp;
- str = arg->arg_ptr.arg_str;
- if (sp + maxarg > stack->ary_max)
- astore(stack, sp + maxarg, Nullstr);
- st = stack->ary_array;
-
-#ifdef DEBUGGING
- if (debug) {
- if (debug & 8) {
- deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg);
- }
- debname[dlevel] = opname[optype][0];
- debdelim[dlevel] = ':';
- if (++dlevel >= dlmax)
- grow_dlevel();
- }
-#endif
-
- if (mark[optype]) {
- saveint(&markbase);
- markbase = mymarkbase;
- saveint(&stack_mark);
- stack_mark = sp;
- }
- for (anum = 1; anum <= maxarg; anum++) {
- argflags = arg[anum].arg_flags;
- argtype = arg[anum].arg_type;
- argptr = arg[anum].arg_ptr;
- re_eval:
- switch (argtype) {
- default:
- if (!ppaddr[optype] || optype == O_SUBR || optype == O_DBSUBR) {
- st[++sp] = &str_undef;
- }
-#ifdef DEBUGGING
- tmps = "NULL";
-#endif
- break;
- case A_EXPR:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "EXPR";
- deb("%d.EXPR =>\n",anum);
- }
-#endif
- sp = eval(argptr.arg_arg,
- (argflags & AF_ARYOK) ? G_ARRAY : G_SCALAR, sp);
- if (sp + (maxarg - anum) > stack->ary_max)
- astore(stack, sp + (maxarg - anum), Nullstr);
- st = stack->ary_array; /* possibly reallocated */
- break;
- case A_CMD:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "CMD";
- deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd);
- }
-#endif
- sp = cmd_exec(argptr.arg_cmd, gimme, sp);
- if (sp + (maxarg - anum) > stack->ary_max)
- astore(stack, sp + (maxarg - anum), Nullstr);
- st = stack->ary_array; /* possibly reallocated */
- break;
- case A_LARYSTAB:
- ++sp;
- switch (optype) {
- case O_ITEM2: argtype = 2; break;
- case O_ITEM3: argtype = 3; break;
- default: argtype = anum; break;
- }
- str = afetch(stab_array(argptr.arg_stab),
- arg[argtype].arg_len - arybase, TRUE);
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
- arg[argtype].arg_len);
- tmps = buf;
- }
-#endif
- goto do_crement;
- case A_ARYSTAB:
- switch (optype) {
- case O_ITEM2: argtype = 2; break;
- case O_ITEM3: argtype = 3; break;
- default: argtype = anum; break;
- }
- st[++sp] = afetch(stab_array(argptr.arg_stab),
- arg[argtype].arg_len - arybase, FALSE);
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
- arg[argtype].arg_len);
- tmps = buf;
- }
-#endif
- break;
- case A_STAR:
- stab = argptr.arg_stab;
- st[++sp] = (STR*)stab;
- if (!stab_xarray(stab))
- aadd(stab);
- if (!stab_xhash(stab))
- hadd(stab);
- if (!stab_io(stab))
- stab_io(stab) = stio_new();
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"STAR *%s -> *%s",
- stab_name(argptr.arg_stab), stab_ename(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_LSTAR:
- str = st[++sp] = (STR*)argptr.arg_stab;
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LSTAR *%s -> *%s",
- stab_name(argptr.arg_stab), stab_ename(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_STAB:
- st[++sp] = STAB_STR(argptr.arg_stab);
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_LENSTAB:
- str_numset(str, (double)STAB_LEN(argptr.arg_stab));
- st[++sp] = str;
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LENSTAB $%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_LEXPR:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "LEXPR";
- deb("%d.LEXPR =>\n",anum);
- }
-#endif
- if (argflags & AF_ARYOK) {
- sp = eval(argptr.arg_arg, G_ARRAY, sp);
- if (sp + (maxarg - anum) > stack->ary_max)
- astore(stack, sp + (maxarg - anum), Nullstr);
- st = stack->ary_array; /* possibly reallocated */
- }
- else {
- sp = eval(argptr.arg_arg, G_SCALAR, sp);
- st = stack->ary_array; /* possibly reallocated */
- str = st[sp];
- goto do_crement;
- }
- break;
- case A_LVAL:
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LVAL $%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- ++sp;
- str = STAB_STR(argptr.arg_stab);
- if (!str)
- fatal("panic: A_LVAL");
- do_crement:
- assigning = TRUE;
- if (argflags & AF_PRE) {
- if (argflags & AF_UP)
- str_inc(str);
- else
- str_dec(str);
- STABSET(str);
- st[sp] = str;
- str = arg->arg_ptr.arg_str;
- }
- else if (argflags & AF_POST) {
- st[sp] = str_mortal(str);
- if (argflags & AF_UP)
- str_inc(str);
- else
- str_dec(str);
- STABSET(str);
- str = arg->arg_ptr.arg_str;
- }
- else
- st[sp] = str;
- break;
- case A_LARYLEN:
- ++sp;
- stab = argptr.arg_stab;
- str = stab_array(argptr.arg_stab)->ary_magic;
- if (optype != O_SASSIGN || argflags & (AF_PRE|AF_POST))
- str_numset(str,(double)(stab_array(stab)->ary_fill+arybase));
-#ifdef DEBUGGING
- tmps = "LARYLEN";
-#endif
- if (!str)
- fatal("panic: A_LEXPR");
- goto do_crement;
- case A_ARYLEN:
- stab = argptr.arg_stab;
- st[++sp] = stab_array(stab)->ary_magic;
- str_numset(st[sp],(double)(stab_array(stab)->ary_fill+arybase));
-#ifdef DEBUGGING
- tmps = "ARYLEN";
-#endif
- break;
- case A_SINGLE:
- st[++sp] = argptr.arg_str;
-#ifdef DEBUGGING
- tmps = "SINGLE";
-#endif
- break;
- case A_DOUBLE:
- (void) interp(str,argptr.arg_str,sp);
- st = stack->ary_array;
- st[++sp] = str;
-#ifdef DEBUGGING
- tmps = "DOUBLE";
-#endif
- break;
- case A_BACKTICK:
- tmps = str_get(interp(str,argptr.arg_str,sp));
- st = stack->ary_array;
-#ifdef TAINT
- TAINT_PROPER("``");
-#endif
- fp = mypopen(tmps,"r");
- str_set(str,"");
- if (fp) {
- if (gimme == G_SCALAR) {
- while (str_gets(str,fp,str->str_cur) != Nullch)
- /*SUPPRESS 530*/
- ;
- }
- else {
- for (;;) {
- if (++sp > stack->ary_max) {
- astore(stack, sp, Nullstr);
- st = stack->ary_array;
- }
- str = st[sp] = Str_new(56,80);
- if (str_gets(str,fp,0) == Nullch) {
- sp--;
- break;
- }
- if (str->str_len - str->str_cur > 20) {
- str->str_len = str->str_cur+1;
- Renew(str->str_ptr, str->str_len, char);
- }
- str_2mortal(str);
- }
- }
- statusvalue = mypclose(fp);
- }
- else
- statusvalue = -1;
-
- if (gimme == G_SCALAR)
- st[++sp] = str;
-#ifdef DEBUGGING
- tmps = "BACK";
-#endif
- break;
- case A_WANTARRAY:
- {
- if (curcsv->wantarray == G_ARRAY)
- st[++sp] = &str_yes;
- else
- st[++sp] = &str_no;
- }
-#ifdef DEBUGGING
- tmps = "WANTARRAY";
-#endif
- break;
- case A_INDREAD:
- last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE);
- old_rschar = rschar;
- old_rslen = rslen;
- goto do_read;
- case A_GLOB:
- argflags |= AF_POST; /* enable newline chopping */
- last_in_stab = argptr.arg_stab;
- old_rschar = rschar;
- old_rslen = rslen;
- rslen = 1;
-#ifdef DOSISH
- rschar = 0;
-#else
-#ifdef CSH
- rschar = 0;
-#else
- rschar = '\n';
-#endif /* !CSH */
-#endif /* !MSDOS */
- goto do_read;
- case A_READ:
- last_in_stab = argptr.arg_stab;
- old_rschar = rschar;
- old_rslen = rslen;
- do_read:
- if (anum > 1) /* assign to scalar */
- gimme = G_SCALAR; /* force context to scalar */
- if (gimme == G_ARRAY)
- str = Str_new(57,0);
- ++sp;
- fp = Nullfp;
- if (stab_io(last_in_stab)) {
- fp = stab_io(last_in_stab)->ifp;
- if (!fp) {
- if (stab_io(last_in_stab)->flags & IOF_ARGV) {
- if (stab_io(last_in_stab)->flags & IOF_START) {
- stab_io(last_in_stab)->flags &= ~IOF_START;
- stab_io(last_in_stab)->lines = 0;
- if (alen(stab_array(last_in_stab)) < 0) {
- tmpstr = str_make("-",1); /* assume stdin */
- (void)apush(stab_array(last_in_stab), tmpstr);
- }
- }
- fp = nextargv(last_in_stab);
- if (!fp) { /* Note: fp != stab_io(last_in_stab)->ifp */
- (void)do_close(last_in_stab,FALSE); /* now it does*/
- stab_io(last_in_stab)->flags |= IOF_START;
- }
- }
- else if (argtype == A_GLOB) {
- (void) interp(str,stab_val(last_in_stab),sp);
- st = stack->ary_array;
- tmpstr = Str_new(55,0);
-#ifdef DOSISH
- str_set(tmpstr, "perlglob ");
- str_scat(tmpstr,str);
- str_cat(tmpstr," |");
-#else
-#ifdef CSH
- str_nset(tmpstr,cshname,cshlen);
- str_cat(tmpstr," -cf 'set nonomatch; glob ");
- str_scat(tmpstr,str);
- str_cat(tmpstr,"'|");
-#else
- str_set(tmpstr, "echo ");
- str_scat(tmpstr,str);
- str_cat(tmpstr,
- "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
-#endif /* !CSH */
-#endif /* !MSDOS */
- (void)do_open(last_in_stab,tmpstr->str_ptr,
- tmpstr->str_cur);
- fp = stab_io(last_in_stab)->ifp;
- str_free(tmpstr);
- }
- }
- }
- if (!fp && dowarn)
- warn("Read on closed filehandle <%s>",stab_ename(last_in_stab));
- tmplen = str->str_len; /* remember if already alloced */
- if (!tmplen)
- Str_Grow(str,80); /* try short-buffering it */
- keepgoing:
- if (!fp)
- st[sp] = &str_undef;
- else if (!str_gets(str,fp, optype == O_RCAT ? str->str_cur : 0)) {
- clearerr(fp);
- if (stab_io(last_in_stab)->flags & IOF_ARGV) {
- fp = nextargv(last_in_stab);
- if (fp)
- goto keepgoing;
- (void)do_close(last_in_stab,FALSE);
- stab_io(last_in_stab)->flags |= IOF_START;
- }
- else if (argflags & AF_POST) {
- (void)do_close(last_in_stab,FALSE);
- }
- st[sp] = &str_undef;
- rschar = old_rschar;
- rslen = old_rslen;
- if (gimme == G_ARRAY) {
- --sp;
- str_2mortal(str);
- goto array_return;
- }
- break;
- }
- else {
- stab_io(last_in_stab)->lines++;
- st[sp] = str;
-#ifdef TAINT
- str->str_tainted = 1; /* Anything from the outside world...*/
-#endif
- if (argflags & AF_POST) {
- if (str->str_cur > 0)
- str->str_cur--;
- if (str->str_ptr[str->str_cur] == rschar)
- str->str_ptr[str->str_cur] = '\0';
- else
- str->str_cur++;
- for (tmps = str->str_ptr; *tmps; tmps++)
- if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
- index("$&*(){}[]'\";\\|?<>~`",*tmps))
- break;
- if (*tmps && stat(str->str_ptr,&statbuf) < 0)
- goto keepgoing; /* unmatched wildcard? */
- }
- if (gimme == G_ARRAY) {
- if (str->str_len - str->str_cur > 20) {
- str->str_len = str->str_cur+1;
- Renew(str->str_ptr, str->str_len, char);
- }
- str_2mortal(str);
- if (++sp > stack->ary_max) {
- astore(stack, sp, Nullstr);
- st = stack->ary_array;
- }
- str = Str_new(58,80);
- goto keepgoing;
- }
- else if (!tmplen && str->str_len - str->str_cur > 80) {
- /* try to reclaim a bit of scalar space on 1st alloc */
- if (str->str_cur < 60)
- str->str_len = 80;
- else
- str->str_len = str->str_cur+40; /* allow some slop */
- Renew(str->str_ptr, str->str_len, char);
- }
- }
- rschar = old_rschar;
- rslen = old_rslen;
-#ifdef DEBUGGING
- tmps = "READ";
-#endif
- break;
- }
-#ifdef DEBUGGING
- if (debug & 8) {
- if (strEQ(tmps, "NULL"))
- deb("%d.%s\n",anum,tmps);
- else
- deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp]));
- }
-#endif
- if (anum < 8)
- arglast[anum] = sp;
- }
-
- if (ppaddr[optype]) {
- int status;
-
- /* pretend like we've been maintaining stack_* all along */
- stack_ary = stack->ary_array;
- stack_sp = stack_ary + sp;
- if (mark[optype] && stack_mark != arglast[0])
- warn("Inconsistent stack mark %d != %d", stack_mark, arglast[0]);
- stack_max = stack_ary + stack->ary_max;
-
- status = (*ppaddr[optype])(str, arg, gimme);
-
- if (savestack->ary_fill > mymarkbase) {
- warn("Inconsistent stack base");
- restorelist(mymarkbase);
- }
- sp = stack_sp - stack_ary;
- if (sp < arglast[0])
- warn("TOO MANY POPS");
- st += arglast[0];
- goto array_return;
- }
-
- st += arglast[0];
-
-#ifdef SMALLSWITCHES
- if (optype < O_CHOWN)
-#endif
- switch (optype) {
- case O_RCAT:
- STABSET(str);
- break;
- case O_ITEM:
- if (gimme == G_ARRAY)
- goto array_return;
- /* FALL THROUGH */
- case O_SCALAR:
- STR_SSET(str,st[1]);
- STABSET(str);
- break;
- case O_ITEM2:
- if (gimme == G_ARRAY)
- goto array_return;
- --anum;
- STR_SSET(str,st[arglast[anum]-arglast[0]]);
- STABSET(str);
- break;
- case O_ITEM3:
- if (gimme == G_ARRAY)
- goto array_return;
- --anum;
- STR_SSET(str,st[arglast[anum]-arglast[0]]);
- STABSET(str);
- break;
- case O_CONCAT:
- STR_SSET(str,st[1]);
- str_scat(str,st[2]);
- STABSET(str);
- break;
- case O_REPEAT:
- if (gimme == G_ARRAY && arg[1].arg_flags & AF_ARYOK) {
- sp = do_repeatary(arglast);
- goto array_return;
- }
- STR_SSET(str,st[1]);
- anum = (int)str_gnum(st[2]);
- if (anum >= 1) {
- tmpstr = Str_new(50, 0);
- tmps = str_get(str);
- str_nset(tmpstr,tmps,str->str_cur);
- tmps = str_get(tmpstr); /* force to be string */
- STR_GROW(str, (anum * str->str_cur) + 1);
- repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum);
- str->str_cur *= anum;
- str->str_ptr[str->str_cur] = '\0';
- str->str_nok = 0;
- str_free(tmpstr);
- }
- else {
- if (dowarn && st[2]->str_pok && !looks_like_number(st[2]))
- warn("Right operand of x is not numeric");
- str_sset(str,&str_no);
- }
- STABSET(str);
- break;
- case O_MATCH:
- sp = do_match(str,arg,
- gimme,arglast);
- if (gimme == G_ARRAY)
- goto array_return;
- STABSET(str);
- break;
- case O_NMATCH:
- sp = do_match(str,arg,
- G_SCALAR,arglast);
- str_sset(str, str_true(str) ? &str_no : &str_yes);
- STABSET(str);
- break;
- case O_SUBST:
- sp = do_subst(str,arg,arglast[0]);
- goto array_return;
- case O_NSUBST:
- sp = do_subst(str,arg,arglast[0]);
- str = arg->arg_ptr.arg_str;
- str_set(str, str_true(str) ? No : Yes);
- goto array_return;
- case O_ASSIGN:
- if (arg[1].arg_flags & AF_ARYOK) {
- if (arg->arg_len == 1) {
- arg->arg_type = O_LOCAL;
- goto local;
- }
- else {
- arg->arg_type = O_AASSIGN;
- goto aassign;
- }
- }
- else {
- arg->arg_type = O_SASSIGN;
- goto sassign;
- }
- case O_LOCAL:
- local:
- arglast[2] = arglast[1]; /* push a null array */
- /* FALL THROUGH */
- case O_AASSIGN:
- aassign:
- sp = do_assign(arg,
- gimme,arglast);
- goto array_return;
- case O_SASSIGN:
- sassign:
-#ifdef TAINT
- if (tainted && !st[2]->str_tainted)
- tainted = 0;
-#endif
- STR_SSET(str, st[2]);
- STABSET(str);
- break;
- case O_CHOP:
- st -= arglast[0];
- str = arg->arg_ptr.arg_str;
- for (sp = arglast[0] + 1; sp <= arglast[1]; sp++)
- do_chop(str,st[sp]);
- st += arglast[0];
- break;
- case O_DEFINED:
- if (arg[1].arg_type & A_DONT) {
- sp = do_defined(str,arg,
- gimme,arglast);
- goto array_return;
- }
- else if (str->str_pok || str->str_nok)
- goto say_yes;
- goto say_no;
- case O_UNDEF:
- if (arg[1].arg_type & A_DONT) {
- sp = do_undef(str,arg,
- gimme,arglast);
- goto array_return;
- }
- else if (str != stab_val(defstab)) {
- if (str->str_len) {
- if (str->str_state == SS_INCR)
- Str_Grow(str,0);
- Safefree(str->str_ptr);
- str->str_ptr = Nullch;
- str->str_len = 0;
- }
- str->str_pok = str->str_nok = 0;
- STABSET(str);
- }
- goto say_undef;
- case O_STUDY:
- sp = do_study(str,arg,
- gimme,arglast);
- goto array_return;
- case O_POW:
- value = str_gnum(st[1]);
- value = pow(value,str_gnum(st[2]));
- goto donumset;
- case O_MULTIPLY:
- value = str_gnum(st[1]);
- value *= str_gnum(st[2]);
- goto donumset;
- case O_DIVIDE:
- if ((value = str_gnum(st[2])) == 0.0)
- fatal("Illegal division by zero");
-#ifdef SLOPPYDIVIDE
- /* insure that 20./5. == 4. */
- {
- double x;
- int k;
- x = str_gnum(st[1]);
- if ((double)(int)x == x &&
- (double)(int)value == value &&
- (k = (int)x/(int)value)*(int)value == (int)x) {
- value = k;
- } else {
- value = x/value;
- }
- }
-#else
- value = str_gnum(st[1]) / value;
-#endif
- goto donumset;
- case O_MODULO:
- tmpulong = (unsigned long) str_gnum(st[2]);
- if (tmpulong == 0L)
- fatal("Illegal modulus zero");
-#ifndef lint
- value = str_gnum(st[1]);
- if (value >= 0.0)
- value = (double)(((unsigned long)value) % tmpulong);
- else {
- tmplong = (long)value;
- value = (double)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
- }
-#endif
- goto donumset;
- case O_ADD:
- value = str_gnum(st[1]);
- value += str_gnum(st[2]);
- goto donumset;
- case O_SUBTRACT:
- value = str_gnum(st[1]);
- value -= str_gnum(st[2]);
- goto donumset;
- case O_LEFT_SHIFT:
- value = str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
-#ifndef lint
- value = (double)(U_L(value) << anum);
-#endif
- goto donumset;
- case O_RIGHT_SHIFT:
- value = str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
-#ifndef lint
- value = (double)(U_L(value) >> anum);
-#endif
- goto donumset;
- case O_LT:
- value = str_gnum(st[1]);
- value = (value < str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_GT:
- value = str_gnum(st[1]);
- value = (value > str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_LE:
- value = str_gnum(st[1]);
- value = (value <= str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_GE:
- value = str_gnum(st[1]);
- value = (value >= str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_EQ:
- if (dowarn) {
- if ((!st[1]->str_nok && !looks_like_number(st[1])) ||
- (!st[2]->str_nok && !looks_like_number(st[2])) )
- warn("Possible use of == on string value");
- }
- value = str_gnum(st[1]);
- value = (value == str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_NE:
- value = str_gnum(st[1]);
- value = (value != str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_NCMP:
- value = str_gnum(st[1]);
- value -= str_gnum(st[2]);
- if (value > 0.0)
- value = 1.0;
- else if (value < 0.0)
- value = -1.0;
- goto donumset;
- case O_BIT_AND:
- if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
- value = str_gnum(st[1]);
-#ifndef lint
- value = (double)(U_L(value) & U_L(str_gnum(st[2])));
-#endif
- goto donumset;
- }
- else
- do_vop(optype,str,st[1],st[2]);
- break;
- case O_XOR:
- if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
- value = str_gnum(st[1]);
-#ifndef lint
- value = (double)(U_L(value) ^ U_L(str_gnum(st[2])));
-#endif
- goto donumset;
- }
- else
- do_vop(optype,str,st[1],st[2]);
- break;
- case O_BIT_OR:
- if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
- value = str_gnum(st[1]);
-#ifndef lint
- value = (double)(U_L(value) | U_L(str_gnum(st[2])));
-#endif
- goto donumset;
- }
- else
- do_vop(optype,str,st[1],st[2]);
- break;
-/* use register in evaluating str_true() */
- case O_AND:
- if (str_true(st[1])) {
- anum = 2;
- optype = O_ITEM2;
- argflags = arg[anum].arg_flags;
- if (gimme == G_ARRAY)
- argflags |= AF_ARYOK;
- argtype = arg[anum].arg_type & A_MASK;
- argptr = arg[anum].arg_ptr;
- maxarg = anum = 1;
- sp = arglast[0];
- st -= sp;
- goto re_eval;
- }
- else {
- if (assigning) {
- str_sset(str, st[1]);
- STABSET(str);
- }
- else
- str = st[1];
- break;
- }
- case O_OR:
- if (str_true(st[1])) {
- if (assigning) {
- str_sset(str, st[1]);
- STABSET(str);
- }
- else
- str = st[1];
- break;
- }
- else {
- anum = 2;
- optype = O_ITEM2;
- argflags = arg[anum].arg_flags;
- if (gimme == G_ARRAY)
- argflags |= AF_ARYOK;
- argtype = arg[anum].arg_type & A_MASK;
- argptr = arg[anum].arg_ptr;
- maxarg = anum = 1;
- sp = arglast[0];
- st -= sp;
- goto re_eval;
- }
- case O_COND_EXPR:
- anum = (str_true(st[1]) ? 2 : 3);
- optype = (anum == 2 ? O_ITEM2 : O_ITEM3);
- argflags = arg[anum].arg_flags;
- if (gimme == G_ARRAY)
- argflags |= AF_ARYOK;
- argtype = arg[anum].arg_type & A_MASK;
- argptr = arg[anum].arg_ptr;
- maxarg = anum = 1;
- sp = arglast[0];
- st -= sp;
- goto re_eval;
- case O_COMMA:
- if (gimme == G_ARRAY)
- goto array_return;
- str = st[2];
- break;
- case O_NEGATE:
- value = -str_gnum(st[1]);
- goto donumset;
- case O_NOT:
-#ifdef NOTNOT
- { char xxx = str_true(st[1]); value = (double) !xxx; }
-#else
- value = (double) !str_true(st[1]);
-#endif
- goto donumset;
- case O_COMPLEMENT:
- if (!sawvec || st[1]->str_nok) {
-#ifndef lint
- value = (double) ~U_L(str_gnum(st[1]));
-#endif
- goto donumset;
- }
- else {
- STR_SSET(str,st[1]);
- tmps = str_get(str);
- for (anum = str->str_cur; anum; anum--, tmps++)
- *tmps = ~*tmps;
- }
- break;
- case O_SELECT:
- stab_efullname(str,defoutstab);
- if (maxarg > 0) {
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- defoutstab = arg[1].arg_ptr.arg_stab;
- else
- defoutstab = stabent(str_get(st[1]),TRUE);
- if (!stab_io(defoutstab))
- stab_io(defoutstab) = stio_new();
- curoutstab = defoutstab;
- }
- STABSET(str);
- break;
- case O_WRITE:
- if (maxarg == 0)
- stab = defoutstab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD) {
- if (!(stab = arg[1].arg_ptr.arg_stab))
- stab = defoutstab;
- }
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab_io(stab)) {
- str_set(str, No);
- STABSET(str);
- break;
- }
- curoutstab = stab;
- fp = stab_io(stab)->ofp;
- if (stab_io(stab)->fmt_stab)
- form = stab_form(stab_io(stab)->fmt_stab);
- else
- form = stab_form(stab);
- if (!form || !fp) {
- if (dowarn) {
- if (form)
- warn("No format for filehandle");
- else {
- if (stab_io(stab)->ifp)
- warn("Filehandle only opened for input");
- else
- warn("Write on closed filehandle");
- }
- }
- str_set(str, No);
- STABSET(str);
- break;
- }
- format(&outrec,form,sp);
- do_write(&outrec,stab,sp);
- if (stab_io(stab)->flags & IOF_FLUSH)
- (void)fflush(fp);
- str_set(str, Yes);
- STABSET(str);
- break;
- case O_DBMOPEN:
-#ifdef SOME_DBM
- anum = arg[1].arg_type & A_MASK;
- if (anum == A_WORD || anum == A_STAB)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (st[3]->str_nok || st[3]->str_pok)
- anum = (int)str_gnum(st[3]);
- else
- anum = -1;
- value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum);
- goto donumset;
-#else
- fatal("No dbm or ndbm on this machine");
-#endif
- case O_DBMCLOSE:
-#ifdef SOME_DBM
- anum = arg[1].arg_type & A_MASK;
- if (anum == A_WORD || anum == A_STAB)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- hdbmclose(stab_hash(stab));
- goto say_yes;
-#else
- fatal("No dbm or ndbm on this machine");
-#endif
- case O_OPEN:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- tmps = str_get(st[2]);
- if (do_open(stab,tmps,st[2]->str_cur)) {
- value = (double)forkprocess;
- stab_io(stab)->lines = 0;
- goto donumset;
- }
- else if (forkprocess == 0) /* we are a new child */
- goto say_zero;
- else
- goto say_undef;
- /* break; */
- case O_TRANS:
- value = (double) do_trans(str,arg);
- str = arg->arg_ptr.arg_str;
- goto donumset;
- case O_NTRANS:
- str_set(arg->arg_ptr.arg_str, do_trans(str,arg) == 0 ? Yes : No);
- str = arg->arg_ptr.arg_str;
- break;
- case O_CLOSE:
- if (maxarg == 0)
- stab = defoutstab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- str_set(str, do_close(stab,TRUE) ? Yes : No );
- STABSET(str);
- break;
- case O_EACH:
- sp = do_each(str,stab_hash(arg[1].arg_ptr.arg_stab),
- gimme,arglast);
- goto array_return;
- case O_VALUES:
- case O_KEYS:
- sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype,
- gimme,arglast);
- goto array_return;
- case O_LARRAY:
- str->str_nok = str->str_pok = 0;
- str->str_u.str_stab = arg[1].arg_ptr.arg_stab;
- str->str_state = SS_ARY;
- break;
- case O_ARRAY:
- ary = stab_array(arg[1].arg_ptr.arg_stab);
- maxarg = ary->ary_fill + 1;
- if (gimme == G_ARRAY) { /* array wanted */
- sp = arglast[0];
- st -= sp;
- if (maxarg > 0 && sp + maxarg > stack->ary_max) {
- astore(stack,sp + maxarg, Nullstr);
- st = stack->ary_array;
- }
- st += sp;
- Copy(ary->ary_array, &st[1], maxarg, STR*);
- sp += maxarg;
- goto array_return;
- }
- else {
- value = (double)maxarg;
- goto donumset;
- }
- case O_AELEM:
- anum = ((int)str_gnum(st[2])) - arybase;
- str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,FALSE);
- break;
- case O_DELETE:
- tmpstab = arg[1].arg_ptr.arg_stab;
- tmps = str_get(st[2]);
- str = hdelete(stab_hash(tmpstab),tmps,st[2]->str_cur);
- if (tmpstab == envstab)
- my_setenv(tmps,Nullch);
- if (!str)
- goto say_undef;
- break;
- case O_LHASH:
- str->str_nok = str->str_pok = 0;
- str->str_u.str_stab = arg[1].arg_ptr.arg_stab;
- str->str_state = SS_HASH;
- break;
- case O_HASH:
- if (gimme == G_ARRAY) { /* array wanted */
- sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype,
- gimme,arglast);
- goto array_return;
- }
- else {
- tmpstab = arg[1].arg_ptr.arg_stab;
- if (!stab_hash(tmpstab)->tbl_fill)
- goto say_zero;
- sprintf(buf,"%d/%d",stab_hash(tmpstab)->tbl_fill,
- stab_hash(tmpstab)->tbl_max+1);
- str_set(str,buf);
- }
- break;
- case O_HELEM:
- tmpstab = arg[1].arg_ptr.arg_stab;
- tmps = str_get(st[2]);
- str = hfetch(stab_hash(tmpstab),tmps,st[2]->str_cur,FALSE);
- break;
- case O_LAELEM:
- anum = ((int)str_gnum(st[2])) - arybase;
- str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,TRUE);
- if (!str || str == &str_undef)
- fatal("Assignment to non-creatable value, subscript %d",anum);
- break;
- case O_LHELEM:
- tmpstab = arg[1].arg_ptr.arg_stab;
- tmps = str_get(st[2]);
- anum = st[2]->str_cur;
- str = hfetch(stab_hash(tmpstab),tmps,anum,TRUE);
- if (!str || str == &str_undef)
- fatal("Assignment to non-creatable value, subscript \"%s\"",tmps);
- if (tmpstab == envstab) /* heavy wizardry going on here */
- str_magic(str, tmpstab, 'E', tmps, anum); /* str is now magic */
- /* he threw the brick up into the air */
- else if (tmpstab == sigstab)
- str_magic(str, tmpstab, 'S', tmps, anum);
-#ifdef SOME_DBM
- else if (stab_hash(tmpstab)->tbl_dbm)
- str_magic(str, tmpstab, 'D', tmps, anum);
-#endif
- else if (tmpstab == DBline)
- str_magic(str, tmpstab, 'L', tmps, anum);
- break;
- case O_LSLICE:
- anum = 2;
- argtype = FALSE;
- goto do_slice_already;
- case O_ASLICE:
- anum = 1;
- argtype = FALSE;
- goto do_slice_already;
- case O_HSLICE:
- anum = 0;
- argtype = FALSE;
- goto do_slice_already;
- case O_LASLICE:
- anum = 1;
- argtype = TRUE;
- goto do_slice_already;
- case O_LHSLICE:
- anum = 0;
- argtype = TRUE;
- do_slice_already:
- sp = do_slice(arg[1].arg_ptr.arg_stab,str,anum,argtype,
- gimme,arglast);
- goto array_return;
- case O_SPLICE:
- sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),gimme,arglast);
- goto array_return;
- case O_PUSH:
- if (arglast[2] - arglast[1] != 1)
- str = do_push(stab_array(arg[1].arg_ptr.arg_stab),arglast);
- else {
- str = Str_new(51,0); /* must copy the STR */
- str_sset(str,st[2]);
- (void)apush(stab_array(arg[1].arg_ptr.arg_stab),str);
- }
- break;
- case O_POP:
- str = apop(ary = stab_array(arg[1].arg_ptr.arg_stab));
- goto staticalization;
- case O_SHIFT:
- str = ashift(ary = stab_array(arg[1].arg_ptr.arg_stab));
- staticalization:
- if (!str)
- goto say_undef;
- if (ary->ary_flags & ARF_REAL)
- (void)str_2mortal(str);
- break;
- case O_UNPACK:
- sp = do_unpack(str,gimme,arglast);
- goto array_return;
- case O_SPLIT:
- value = str_gnum(st[3]);
- sp = do_split(str, arg[2].arg_ptr.arg_spat, (int)value,
- gimme,arglast);
- goto array_return;
- case O_LENGTH:
- if (maxarg < 1)
- value = (double)str_len(stab_val(defstab));
- else
- value = (double)str_len(st[1]);
- goto donumset;
- case O_SPRINTF:
- do_sprintf(str, sp-arglast[0], st+1);
- break;
- case O_SUBSTR:
- anum = ((int)str_gnum(st[2])) - arybase; /* anum=where to start*/
- tmps = str_get(st[1]); /* force conversion to string */
- /*SUPPRESS 560*/
- if (argtype = (str == st[1]))
- str = arg->arg_ptr.arg_str;
- if (anum < 0)
- anum += st[1]->str_cur + arybase;
- if (anum < 0 || anum > st[1]->str_cur)
- str_nset(str,"",0);
- else {
- optype = maxarg < 3 ? st[1]->str_cur : (int)str_gnum(st[3]);
- if (optype < 0)
- optype = 0;
- tmps += anum;
- anum = st[1]->str_cur - anum; /* anum=how many bytes left*/
- if (anum > optype)
- anum = optype;
- str_nset(str, tmps, anum);
- if (argtype) { /* it's an lvalue! */
- Lstring *lstr = (Lstring*)str;
-
- str->str_magic = st[1];
- st[1]->str_rare = 's';
- lstr->lstr_offset = tmps - str_get(st[1]);
- lstr->lstr_len = anum;
- }
- }
- break;
- case O_PACK:
- /*SUPPRESS 701*/
- (void)do_pack(str,arglast);
- break;
- case O_GREP:
- sp = do_grep(arg,str,gimme,arglast);
- goto array_return;
- case O_JOIN:
- do_join(str,arglast);
- break;
- case O_SLT:
- tmps = str_get(st[1]);
- value = (double) (str_cmp(st[1],st[2]) < 0);
- goto donumset;
- case O_SGT:
- tmps = str_get(st[1]);
- value = (double) (str_cmp(st[1],st[2]) > 0);
- goto donumset;
- case O_SLE:
- tmps = str_get(st[1]);
- value = (double) (str_cmp(st[1],st[2]) <= 0);
- goto donumset;
- case O_SGE:
- tmps = str_get(st[1]);
- value = (double) (str_cmp(st[1],st[2]) >= 0);
- goto donumset;
- case O_SEQ:
- tmps = str_get(st[1]);
- value = (double) str_eq(st[1],st[2]);
- goto donumset;
- case O_SNE:
- tmps = str_get(st[1]);
- value = (double) !str_eq(st[1],st[2]);
- goto donumset;
- case O_SCMP:
- tmps = str_get(st[1]);
- value = (double) str_cmp(st[1],st[2]);
- goto donumset;
- case O_SUBR:
- sp = do_subr(arg,gimme,arglast);
- st = stack->ary_array + arglast[0]; /* maybe realloced */
- goto array_return;
- case O_DBSUBR:
- sp = do_subr(arg,gimme,arglast);
- st = stack->ary_array + arglast[0]; /* maybe realloced */
- goto array_return;
- case O_CALLER:
- sp = do_caller(arg,maxarg,gimme,arglast);
- st = stack->ary_array + arglast[0]; /* maybe realloced */
- goto array_return;
- case O_SORT:
- sp = do_sort(str,arg,
- gimme,arglast);
- goto array_return;
- case O_REVERSE:
- if (gimme == G_ARRAY)
- sp = do_reverse(arglast);
- else
- sp = do_sreverse(str, arglast);
- goto array_return;
- case O_WARN:
- if (arglast[2] - arglast[1] != 1) {
- do_join(str,arglast);
- tmps = str_get(str);
- }
- else {
- str = st[2];
- tmps = str_get(st[2]);
- }
- if (!tmps || !*tmps)
- tmps = "Warning: something's wrong";
- warn("%s",tmps);
- goto say_yes;
- case O_DIE:
- if (arglast[2] - arglast[1] != 1) {
- do_join(str,arglast);
- tmps = str_get(str);
- }
- else {
- str = st[2];
- tmps = str_get(st[2]);
- }
- if (!tmps || !*tmps)
- tmps = "Died";
- fatal("%s",tmps);
- goto say_zero;
- case O_PRTF:
- case O_PRINT:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab)
- stab = defoutstab;
- if (!stab_io(stab)) {
- if (dowarn)
- warn("Filehandle never opened");
- goto say_zero;
- }
- if (!(fp = stab_io(stab)->ofp)) {
- if (dowarn) {
- if (stab_io(stab)->ifp)
- warn("Filehandle opened only for input");
- else
- warn("Print on closed filehandle");
- }
- goto say_zero;
- }
- else {
- if (optype == O_PRTF || arglast[2] - arglast[1] != 1)
- value = (double)do_aprint(arg,fp,arglast);
- else {
- value = (double)do_print(st[2],fp);
- if (orslen && optype == O_PRINT)
- if (fwrite(ors, 1, orslen, fp) == 0)
- goto say_zero;
- }
- if (stab_io(stab)->flags & IOF_FLUSH)
- if (fflush(fp) == EOF)
- goto say_zero;
- }
- goto donumset;
- case O_CHDIR:
- if (maxarg < 1)
- tmps = Nullch;
- else
- tmps = str_get(st[1]);
- if (!tmps || !*tmps) {
- tmpstr = hfetch(stab_hash(envstab),"HOME",4,FALSE);
- tmps = str_get(tmpstr);
- }
- if (!tmps || !*tmps) {
- tmpstr = hfetch(stab_hash(envstab),"LOGDIR",6,FALSE);
- tmps = str_get(tmpstr);
- }
-#ifdef TAINT
- TAINT_PROPER("chdir");
-#endif
- value = (double)(chdir(tmps) >= 0);
- goto donumset;
- case O_EXIT:
- if (maxarg < 1)
- anum = 0;
- else
- anum = (int)str_gnum(st[1]);
- my_exit(anum);
- goto say_zero;
- case O_RESET:
- if (maxarg < 1)
- tmps = "";
- else
- tmps = str_get(st[1]);
- str_reset(tmps,curcmd->c_stash);
- value = 1.0;
- goto donumset;
- case O_LIST:
- if (gimme == G_ARRAY)
- goto array_return;
- if (maxarg > 0)
- str = st[sp - arglast[0]]; /* unwanted list, return last item */
- else
- str = &str_undef;
- break;
- case O_EOF:
- if (maxarg <= 0)
- stab = last_in_stab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- str_set(str, do_eof(stab) ? Yes : No);
- STABSET(str);
- break;
- case O_GETC:
- if (maxarg <= 0)
- stab = stdinstab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab)
- stab = argvstab;
- if (!stab || do_eof(stab)) /* make sure we have fp with something */
- goto say_undef;
- else {
-#ifdef TAINT
- tainted = 1;
-#endif
- str_set(str," ");
- *str->str_ptr = getc(stab_io(stab)->ifp); /* should never be EOF */
- }
- STABSET(str);
- break;
- case O_TELL:
- if (maxarg <= 0)
- stab = last_in_stab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_tell(stab);
-#else
- (void)do_tell(stab);
-#endif
- goto donumset;
- case O_RECV:
- case O_READ:
- case O_SYSREAD:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- tmps = str_get(st[2]);
- anum = (int)str_gnum(st[3]);
- errno = 0;
- maxarg = sp - arglast[0];
- if (maxarg > 4)
- warn("Too many args on read");
- if (maxarg == 4)
- maxarg = (int)str_gnum(st[4]);
- else
- maxarg = 0;
- if (!stab_io(stab) || !stab_io(stab)->ifp)
- goto say_undef;
-#ifdef HAS_SOCKET
- if (optype == O_RECV) {
- argtype = sizeof buf;
- STR_GROW(st[2], anum+1), (tmps = str_get(st[2])); /* sneaky */
- anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, maxarg,
- buf, &argtype);
- if (anum >= 0) {
- st[2]->str_cur = anum;
- st[2]->str_ptr[anum] = '\0';
- str_nset(str,buf,argtype);
- }
- else
- str_sset(str,&str_undef);
- break;
- }
-#else
- if (optype == O_RECV)
- goto badsock;
-#endif
- STR_GROW(st[2], anum+maxarg+1), (tmps = str_get(st[2])); /* sneaky */
- if (optype == O_SYSREAD) {
- anum = read(fileno(stab_io(stab)->ifp), tmps+maxarg, anum);
- }
- else
-#ifdef HAS_SOCKET
- if (stab_io(stab)->type == 's') {
- argtype = sizeof buf;
- anum = recvfrom(fileno(stab_io(stab)->ifp), tmps+maxarg, anum, 0,
- buf, &argtype);
- }
- else
-#endif
- anum = fread(tmps+maxarg, 1, anum, stab_io(stab)->ifp);
- if (anum < 0)
- goto say_undef;
- st[2]->str_cur = anum+maxarg;
- st[2]->str_ptr[anum+maxarg] = '\0';
- value = (double)anum;
- goto donumset;
- case O_SYSWRITE:
- case O_SEND:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- tmps = str_get(st[2]);
- anum = (int)str_gnum(st[3]);
- errno = 0;
- stio = stab_io(stab);
- maxarg = sp - arglast[0];
- if (!stio || !stio->ifp) {
- anum = -1;
- if (dowarn) {
- if (optype == O_SYSWRITE)
- warn("Syswrite on closed filehandle");
- else
- warn("Send on closed socket");
- }
- }
- else if (optype == O_SYSWRITE) {
- if (maxarg > 4)
- warn("Too many args on syswrite");
- if (maxarg == 4)
- optype = (int)str_gnum(st[4]);
- else
- optype = 0;
- anum = write(fileno(stab_io(stab)->ifp), tmps+optype, anum);
- }
-#ifdef HAS_SOCKET
- else if (maxarg >= 4) {
- if (maxarg > 4)
- warn("Too many args on send");
- tmps2 = str_get(st[4]);
- anum = sendto(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur,
- anum, tmps2, st[4]->str_cur);
- }
- else
- anum = send(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, anum);
-#else
- else
- goto badsock;
-#endif
- if (anum < 0)
- goto say_undef;
- value = (double)anum;
- goto donumset;
- case O_SEEK:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- value = str_gnum(st[2]);
- str_set(str, do_seek(stab,
- (long)value, (int)str_gnum(st[3]) ) ? Yes : No);
- STABSET(str);
- break;
- case O_RETURN:
- tmps = "_SUB_"; /* just fake up a "last _SUB_" */
- optype = O_LAST;
- if (curcsv && curcsv->wantarray == G_ARRAY) {
- lastretstr = Nullstr;
- lastspbase = arglast[1];
- lastsize = arglast[2] - arglast[1];
- }
- else
- lastretstr = str_mortal(st[arglast[2] - arglast[0]]);
- goto dopop;
- case O_REDO:
- case O_NEXT:
- case O_LAST:
- tmps = Nullch;
- if (maxarg > 0) {
- tmps = str_get(arg[1].arg_ptr.arg_str);
- dopop:
- while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label ||
- strNE(tmps,loop_stack[loop_ptr].loop_label) )) {
-#ifdef DEBUGGING
- if (debug & 4) {
- deb("(Skipping label #%d %s)\n",loop_ptr,
- loop_stack[loop_ptr].loop_label);
- }
-#endif
- loop_ptr--;
- }
-#ifdef DEBUGGING
- if (debug & 4) {
- deb("(Found label #%d %s)\n",loop_ptr,
- loop_stack[loop_ptr].loop_label);
- }
-#endif
- }
- if (loop_ptr < 0) {
- if (tmps && strEQ(tmps, "_SUB_"))
- fatal("Can't return outside a subroutine");
- fatal("Bad label: %s", maxarg > 0 ? tmps : "<null>");
- }
- if (!lastretstr && optype == O_LAST && lastsize) {
- st -= arglast[0];
- st += lastspbase + 1;
- optype = loop_stack[loop_ptr].loop_sp - lastspbase; /* negative */
- if (optype) {
- for (anum = lastsize; anum > 0; anum--,st++)
- st[optype] = str_mortal(st[0]);
- }
- longjmp(loop_stack[loop_ptr].loop_env, O_LAST);
- }
- longjmp(loop_stack[loop_ptr].loop_env, optype);
- case O_DUMP:
- case O_GOTO:/* shudder */
- goto_targ = str_get(arg[1].arg_ptr.arg_str);
- if (!*goto_targ)
- goto_targ = Nullch; /* just restart from top */
- if (optype == O_DUMP) {
- do_undump = TRUE;
- my_unexec();
- }
- longjmp(top_env, 1);
- case O_INDEX:
- tmps = str_get(st[1]);
- if (maxarg < 3)
- anum = 0;
- else {
- anum = (int) str_gnum(st[3]) - arybase;
- if (anum < 0)
- anum = 0;
- else if (anum > st[1]->str_cur)
- anum = st[1]->str_cur;
- }
-#ifndef lint
- if (!(tmps2 = fbminstr((unsigned char*)tmps + anum,
- (unsigned char*)tmps + st[1]->str_cur, st[2])))
-#else
- if (tmps2 = fbminstr(Null(unsigned char*),Null(unsigned char*),Nullstr))
-#endif
- value = (double)(-1 + arybase);
- else
- value = (double)(tmps2 - tmps + arybase);
- goto donumset;
- case O_RINDEX:
- tmps = str_get(st[1]);
- tmps2 = str_get(st[2]);
- if (maxarg < 3)
- anum = st[1]->str_cur;
- else {
- anum = (int) str_gnum(st[3]) - arybase + st[2]->str_cur;
- if (anum < 0)
- anum = 0;
- else if (anum > st[1]->str_cur)
- anum = st[1]->str_cur;
- }
-#ifndef lint
- if (!(tmps2 = rninstr(tmps, tmps + anum,
- tmps2, tmps2 + st[2]->str_cur)))
-#else
- if (tmps2 = rninstr(Nullch,Nullch,Nullch,Nullch))
-#endif
- value = (double)(-1 + arybase);
- else
- value = (double)(tmps2 - tmps + arybase);
- goto donumset;
- case O_TIME:
-#ifndef lint
- value = (double) time(Null(long*));
-#endif
- goto donumset;
- case O_TMS:
- sp = do_tms(str,gimme,arglast);
- goto array_return;
- case O_LOCALTIME:
- if (maxarg < 1)
- (void)time(&when);
- else
- when = (time_t)str_gnum(st[1]);
- sp = do_time(str,localtime(&when),
- gimme,arglast);
- goto array_return;
- case O_GMTIME:
- if (maxarg < 1)
- (void)time(&when);
- else
- when = (time_t)str_gnum(st[1]);
- sp = do_time(str,gmtime(&when),
- gimme,arglast);
- goto array_return;
- case O_TRUNCATE:
- sp = do_truncate(str,arg,
- gimme,arglast);
- goto array_return;
- case O_LSTAT:
- case O_STAT:
- sp = do_stat(str,arg,
- gimme,arglast);
- goto array_return;
- case O_CRYPT:
-#ifdef HAS_CRYPT
- tmps = str_get(st[1]);
-#ifdef FCRYPT
- str_set(str,fcrypt(tmps,str_get(st[2])));
-#else
- str_set(str,crypt(tmps,str_get(st[2])));
-#endif
-#else
- fatal(
- "The crypt() function is unimplemented due to excessive paranoia.");
-#endif
- break;
- case O_ATAN2:
- value = str_gnum(st[1]);
- value = atan2(value,str_gnum(st[2]));
- goto donumset;
- case O_SIN:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- value = sin(value);
- goto donumset;
- case O_COS:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- value = cos(value);
- goto donumset;
- case O_RAND:
- if (maxarg < 1)
- value = 1.0;
- else
- value = str_gnum(st[1]);
- if (value == 0.0)
- value = 1.0;
-#if RANDBITS == 31
- value = rand() * value / 2147483648.0;
-#else
-#if RANDBITS == 16
- value = rand() * value / 65536.0;
-#else
-#if RANDBITS == 15
- value = rand() * value / 32768.0;
-#else
- value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
-#endif
-#endif
-#endif
- goto donumset;
- case O_SRAND:
- if (maxarg < 1) {
- (void)time(&when);
- anum = when;
- }
- else
- anum = (int)str_gnum(st[1]);
- (void)srand(anum);
- goto say_yes;
- case O_EXP:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- value = exp(value);
- goto donumset;
- case O_LOG:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- if (value <= 0.0)
- fatal("Can't take log of %g\n", value);
- value = log(value);
- goto donumset;
- case O_SQRT:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- if (value < 0.0)
- fatal("Can't take sqrt of %g\n", value);
- value = sqrt(value);
- goto donumset;
- case O_INT:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- if (value >= 0.0)
- (void)modf(value,&value);
- else {
- (void)modf(-value,&value);
- value = -value;
- }
- goto donumset;
- case O_ORD:
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
-#ifndef I286
- value = (double) (*tmps & 255);
-#else
- anum = (int) *tmps;
- value = (double) (anum & 255);
-#endif
- goto donumset;
- case O_ALARM:
-#ifdef HAS_ALARM
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
- if (!tmps)
- tmps = "0";
- anum = alarm((unsigned int)atoi(tmps));
- if (anum < 0)
- goto say_undef;
- value = (double)anum;
- goto donumset;
-#else
- fatal("Unsupported function alarm");
- break;
-#endif
- case O_SLEEP:
- if (maxarg < 1)
- tmps = Nullch;
- else
- tmps = str_get(st[1]);
- (void)time(&when);
- if (!tmps || !*tmps)
- sleep((32767<<16)+32767);
- else
- sleep((unsigned int)atoi(tmps));
-#ifndef lint
- value = (double)when;
- (void)time(&when);
- value = ((double)when) - value;
-#endif
- goto donumset;
- case O_RANGE:
- sp = do_range(gimme,arglast);
- goto array_return;
- case O_F_OR_R:
- if (gimme == G_ARRAY) { /* it's a range */
- /* can we optimize to constant array? */
- if ((arg[1].arg_type & A_MASK) == A_SINGLE &&
- (arg[2].arg_type & A_MASK) == A_SINGLE) {
- st[2] = arg[2].arg_ptr.arg_str;
- sp = do_range(gimme,arglast);
- st = stack->ary_array;
- maxarg = sp - arglast[0];
- str_free(arg[1].arg_ptr.arg_str);
- arg[1].arg_ptr.arg_str = Nullstr;
- str_free(arg[2].arg_ptr.arg_str);
- arg[2].arg_ptr.arg_str = Nullstr;
- arg->arg_type = O_ARRAY;
- arg[1].arg_type = A_STAB|A_DONT;
- arg->arg_len = 1;
- stab = arg[1].arg_ptr.arg_stab = aadd(genstab());
- ary = stab_array(stab);
- afill(ary,maxarg - 1);
- anum = maxarg;
- st += arglast[0]+1;
- while (maxarg-- > 0)
- ary->ary_array[maxarg] = str_smake(st[maxarg]);
- st -= arglast[0]+1;
- goto array_return;
- }
- arg->arg_type = optype = O_RANGE;
- maxarg = arg->arg_len = 2;
- anum = 2;
- arg[anum].arg_flags &= ~AF_ARYOK;
- argflags = arg[anum].arg_flags;
- argtype = arg[anum].arg_type & A_MASK;
- arg[anum].arg_type = argtype;
- argptr = arg[anum].arg_ptr;
- sp = arglast[0];
- st -= sp;
- sp++;
- goto re_eval;
- }
- arg->arg_type = O_FLIP;
- /* FALL THROUGH */
- case O_FLIP:
- if ((arg[1].arg_type & A_MASK) == A_SINGLE ?
- last_in_stab && (int)str_gnum(st[1]) == stab_io(last_in_stab)->lines
- :
- str_true(st[1]) ) {
- arg[2].arg_type &= ~A_DONT;
- arg[1].arg_type |= A_DONT;
- arg->arg_type = optype = O_FLOP;
- if (arg->arg_flags & AF_COMMON) {
- str_numset(str,0.0);
- anum = 2;
- argflags = arg[2].arg_flags;
- argtype = arg[2].arg_type & A_MASK;
- argptr = arg[2].arg_ptr;
- sp = arglast[0];
- st -= sp++;
- goto re_eval;
- }
- else {
- str_numset(str,1.0);
- break;
- }
- }
- str_set(str,"");
- break;
- case O_FLOP:
- str_inc(str);
- if ((arg[2].arg_type & A_MASK) == A_SINGLE ?
- last_in_stab && (int)str_gnum(st[2]) == stab_io(last_in_stab)->lines
- :
- str_true(st[2]) ) {
- arg->arg_type = O_FLIP;
- arg[1].arg_type &= ~A_DONT;
- arg[2].arg_type |= A_DONT;
- str_cat(str,"E0");
- }
- break;
- case O_FORK:
-#ifdef HAS_FORK
- anum = fork();
- if (anum < 0)
- goto say_undef;
- if (!anum) {
- /*SUPPRESS 560*/
- if (tmpstab = stabent("$",allstabs))
- str_numset(STAB_STR(tmpstab),(double)getpid());
- hclear(pidstatus, FALSE); /* no kids, so don't wait for 'em */
- }
- value = (double)anum;
- goto donumset;
-#else
- fatal("Unsupported function fork");
- break;
-#endif
- case O_WAIT:
-#ifdef HAS_WAIT
-#ifndef lint
- anum = wait(&argflags);
- if (anum > 0)
- pidgone(anum,argflags);
- value = (double)anum;
-#endif
- statusvalue = (unsigned short)argflags;
- goto donumset;
-#else
- fatal("Unsupported function wait");
- break;
-#endif
- case O_WAITPID:
-#ifdef HAS_WAIT
-#ifndef lint
- anum = (int)str_gnum(st[1]);
- optype = (int)str_gnum(st[2]);
- anum = wait4pid(anum, &argflags,optype);
- value = (double)anum;
-#endif
- statusvalue = (unsigned short)argflags;
- goto donumset;
-#else
- fatal("Unsupported function wait");
- break;
-#endif
- case O_SYSTEM:
-#ifdef HAS_FORK
-#ifdef TAINT
- if (arglast[2] - arglast[1] == 1) {
- taintenv();
- tainted |= st[2]->str_tainted;
- TAINT_PROPER("system");
- }
-#endif
- while ((anum = vfork()) == -1) {
- if (errno != EAGAIN) {
- value = -1.0;
- goto donumset;
- }
- sleep(5);
- }
- if (anum > 0) {
-#ifndef lint
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
- argtype = wait4pid(anum, &argflags, 0);
-#else
- ihand = qhand = 0;
-#endif
- (void)signal(SIGINT, ihand);
- (void)signal(SIGQUIT, qhand);
- statusvalue = (unsigned short)argflags;
- if (argtype < 0)
- value = -1.0;
- else {
- value = (double)((unsigned int)argflags & 0xffff);
- }
- do_execfree(); /* free any memory child malloced on vfork */
- goto donumset;
- }
- if ((arg[1].arg_type & A_MASK) == A_STAB)
- value = (double)do_aexec(st[1],arglast);
- else if (arglast[2] - arglast[1] != 1)
- value = (double)do_aexec(Nullstr,arglast);
- else {
- value = (double)do_exec(str_get(str_mortal(st[2])));
- }
- _exit(-1);
-#else /* ! FORK */
- if ((arg[1].arg_type & A_MASK) == A_STAB)
- value = (double)do_aspawn(st[1],arglast);
- else if (arglast[2] - arglast[1] != 1)
- value = (double)do_aspawn(Nullstr,arglast);
- else {
- value = (double)do_spawn(str_get(str_mortal(st[2])));
- }
- goto donumset;
-#endif /* FORK */
- case O_EXEC_OP:
- if ((arg[1].arg_type & A_MASK) == A_STAB)
- value = (double)do_aexec(st[1],arglast);
- else if (arglast[2] - arglast[1] != 1)
- value = (double)do_aexec(Nullstr,arglast);
- else {
-#ifdef TAINT
- taintenv();
- tainted |= st[2]->str_tainted;
- TAINT_PROPER("exec");
-#endif
- value = (double)do_exec(str_get(str_mortal(st[2])));
- }
- goto donumset;
- case O_HEX:
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
- value = (double)scanhex(tmps, 99, &argtype);
- goto donumset;
-
- case O_OCT:
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
- while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
- tmps++;
- if (*tmps == 'x')
- value = (double)scanhex(++tmps, 99, &argtype);
- else
- value = (double)scanoct(tmps, 99, &argtype);
- goto donumset;
-
-/* These common exits are hidden here in the middle of the switches for the
- benefit of those machines with limited branch addressing. Sigh. */
-
-array_return:
-#ifdef DEBUGGING
- if (debug) {
- dlevel--;
- if (debug & 8) {
- anum = sp - arglast[0];
- switch (anum) {
- case 0:
- deb("%s RETURNS ()\n",opname[optype]);
- break;
- case 1:
- deb("%s RETURNS (\"%s\")\n",opname[optype],
- st[1] ? str_get(st[1]) : "");
- break;
- default:
- tmps = st[1] ? str_get(st[1]) : "";
- deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\")\n",opname[optype],
- anum,tmps,anum==2?"":"...,",
- st[anum] ? str_get(st[anum]) : "");
- break;
- }
- }
- }
-#endif
- stack_ary = stack->ary_array;
- stack_max = stack_ary + stack->ary_max;
- stack_sp = stack_ary + sp;
- return sp;
-
-say_yes:
- str = &str_yes;
- goto normal_return;
-
-say_no:
- str = &str_no;
- goto normal_return;
-
-say_undef:
- str = &str_undef;
- goto normal_return;
-
-say_zero:
- value = 0.0;
- /* FALL THROUGH */
-
-donumset:
- str_numset(str,value);
- STABSET(str);
- st[1] = str;
-#ifdef DEBUGGING
- if (debug) {
- dlevel--;
- if (debug & 8)
- deb("%s RETURNS \"%f\"\n",opname[optype],value);
- }
-#endif
- stack_ary = stack->ary_array;
- stack_max = stack_ary + stack->ary_max;
- stack_sp = stack_ary + arglast[0] + 1;
- return arglast[0] + 1;
-#ifdef SMALLSWITCHES
- }
- else
- switch (optype) {
-#endif
- case O_CHOWN:
-#ifdef HAS_CHOWN
- value = (double)apply(optype,arglast);
- goto donumset;
-#else
- fatal("Unsupported function chown");
- break;
-#endif
- case O_KILL:
-#ifdef HAS_KILL
- value = (double)apply(optype,arglast);
- goto donumset;
-#else
- fatal("Unsupported function kill");
- break;
-#endif
- case O_UNLINK:
- case O_CHMOD:
- case O_UTIME:
- value = (double)apply(optype,arglast);
- goto donumset;
- case O_UMASK:
-#ifdef HAS_UMASK
- if (maxarg < 1) {
- anum = umask(0);
- (void)umask(anum);
- }
- else
- anum = umask((int)str_gnum(st[1]));
- value = (double)anum;
-#ifdef TAINT
- TAINT_PROPER("umask");
-#endif
- goto donumset;
-#else
- fatal("Unsupported function umask");
- break;
-#endif
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- case O_MSGGET:
- case O_SHMGET:
- case O_SEMGET:
- if ((anum = do_ipcget(optype, arglast)) == -1)
- goto say_undef;
- value = (double)anum;
- goto donumset;
- case O_MSGCTL:
- case O_SHMCTL:
- case O_SEMCTL:
- anum = do_ipcctl(optype, arglast);
- if (anum == -1)
- goto say_undef;
- if (anum != 0) {
- value = (double)anum;
- goto donumset;
- }
- str_set(str,"0 but true");
- STABSET(str);
- break;
- case O_MSGSND:
- value = (double)(do_msgsnd(arglast) >= 0);
- goto donumset;
- case O_MSGRCV:
- value = (double)(do_msgrcv(arglast) >= 0);
- goto donumset;
- case O_SEMOP:
- value = (double)(do_semop(arglast) >= 0);
- goto donumset;
- case O_SHMREAD:
- case O_SHMWRITE:
- value = (double)(do_shmio(optype, arglast) >= 0);
- goto donumset;
-#else /* not SYSVIPC */
- case O_MSGGET:
- case O_MSGCTL:
- case O_MSGSND:
- case O_MSGRCV:
- case O_SEMGET:
- case O_SEMCTL:
- case O_SEMOP:
- case O_SHMGET:
- case O_SHMCTL:
- case O_SHMREAD:
- case O_SHMWRITE:
- fatal("System V IPC is not implemented on this machine");
-#endif /* not SYSVIPC */
- case O_RENAME:
- tmps = str_get(st[1]);
- tmps2 = str_get(st[2]);
-#ifdef TAINT
- TAINT_PROPER("rename");
-#endif
-#ifdef HAS_RENAME
- value = (double)(rename(tmps,tmps2) >= 0);
-#else
- if (same_dirent(tmps2, tmps)) /* can always rename to same name */
- anum = 1;
- else {
- if (euid || stat(tmps2,&statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
- (void)UNLINK(tmps2);
- if (!(anum = link(tmps,tmps2)))
- anum = UNLINK(tmps);
- }
- value = (double)(anum >= 0);
-#endif
- goto donumset;
- case O_LINK:
-#ifdef HAS_LINK
- tmps = str_get(st[1]);
- tmps2 = str_get(st[2]);
-#ifdef TAINT
- TAINT_PROPER("link");
-#endif
- value = (double)(link(tmps,tmps2) >= 0);
- goto donumset;
-#else
- fatal("Unsupported function link");
- break;
-#endif
- case O_MKDIR:
- tmps = str_get(st[1]);
- anum = (int)str_gnum(st[2]);
-#ifdef TAINT
- TAINT_PROPER("mkdir");
-#endif
-#ifdef HAS_MKDIR
- value = (double)(mkdir(tmps,anum) >= 0);
- goto donumset;
-#else
- (void)strcpy(buf,"mkdir ");
-#endif
-#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
- one_liner:
- for (tmps2 = buf+6; *tmps; ) {
- *tmps2++ = '\\';
- *tmps2++ = *tmps++;
- }
- (void)strcpy(tmps2," 2>&1");
- rsfp = mypopen(buf,"r");
- if (rsfp) {
- *buf = '\0';
- tmps2 = fgets(buf,sizeof buf,rsfp);
- (void)mypclose(rsfp);
- if (tmps2 != Nullch) {
- for (errno = 1; errno < sys_nerr; errno++) {
- if (instr(buf,sys_errlist[errno])) /* you don't see this */
- goto say_zero;
- }
- errno = 0;
-#ifndef EACCES
-#define EACCES EPERM
-#endif
- if (instr(buf,"cannot make"))
- errno = EEXIST;
- else if (instr(buf,"existing file"))
- errno = EEXIST;
- else if (instr(buf,"ile exists"))
- errno = EEXIST;
- else if (instr(buf,"non-exist"))
- errno = ENOENT;
- else if (instr(buf,"does not exist"))
- errno = ENOENT;
- else if (instr(buf,"not empty"))
- errno = EBUSY;
- else if (instr(buf,"cannot access"))
- errno = EACCES;
- else
- errno = EPERM;
- goto say_zero;
- }
- else { /* some mkdirs return no failure indication */
- tmps = str_get(st[1]);
- anum = (stat(tmps,&statbuf) >= 0);
- if (optype == O_RMDIR)
- anum = !anum;
- if (anum)
- errno = 0;
- else
- errno = EACCES; /* a guess */
- value = (double)anum;
- }
- goto donumset;
- }
- else
- goto say_zero;
-#endif
- case O_RMDIR:
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
-#ifdef TAINT
- TAINT_PROPER("rmdir");
-#endif
-#ifdef HAS_RMDIR
- value = (double)(rmdir(tmps) >= 0);
- goto donumset;
-#else
- (void)strcpy(buf,"rmdir ");
- goto one_liner; /* see above in HAS_MKDIR */
-#endif
- case O_GETPPID:
-#ifdef HAS_GETPPID
- value = (double)getppid();
- goto donumset;
-#else
- fatal("Unsupported function getppid");
- break;
-#endif
- case O_GETPGRP:
-#ifdef HAS_GETPGRP
- if (maxarg < 1)
- anum = 0;
- else
- anum = (int)str_gnum(st[1]);
-#ifdef _POSIX_SOURCE
- if (anum != 0)
- fatal("POSIX getpgrp can't take an argument");
- value = (double)getpgrp();
-#else
- value = (double)getpgrp(anum);
-#endif
- goto donumset;
-#else
- fatal("The getpgrp() function is unimplemented on this machine");
- break;
-#endif
- case O_SETPGRP:
-#ifdef HAS_SETPGRP
- argtype = (int)str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
-#ifdef TAINT
- TAINT_PROPER("setpgrp");
-#endif
- value = (double)(setpgrp(argtype,anum) >= 0);
- goto donumset;
-#else
- fatal("The setpgrp() function is unimplemented on this machine");
- break;
-#endif
- case O_GETPRIORITY:
-#ifdef HAS_GETPRIORITY
- argtype = (int)str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
- value = (double)getpriority(argtype,anum);
- goto donumset;
-#else
- fatal("The getpriority() function is unimplemented on this machine");
- break;
-#endif
- case O_SETPRIORITY:
-#ifdef HAS_SETPRIORITY
- argtype = (int)str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
- optype = (int)str_gnum(st[3]);
-#ifdef TAINT
- TAINT_PROPER("setpriority");
-#endif
- value = (double)(setpriority(argtype,anum,optype) >= 0);
- goto donumset;
-#else
- fatal("The setpriority() function is unimplemented on this machine");
- break;
-#endif
- case O_CHROOT:
-#ifdef HAS_CHROOT
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
-#ifdef TAINT
- TAINT_PROPER("chroot");
-#endif
- value = (double)(chroot(tmps) >= 0);
- goto donumset;
-#else
- fatal("Unsupported function chroot");
- break;
-#endif
- case O_FCNTL:
- case O_IOCTL:
- if (maxarg <= 0)
- stab = last_in_stab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- argtype = U_I(str_gnum(st[2]));
-#ifdef TAINT
- TAINT_PROPER("ioctl");
-#endif
- anum = do_ctl(optype,stab,argtype,st[3]);
- if (anum == -1)
- goto say_undef;
- if (anum != 0) {
- value = (double)anum;
- goto donumset;
- }
- str_set(str,"0 but true");
- STABSET(str);
- break;
- case O_FLOCK:
-#ifdef HAS_FLOCK
- if (maxarg <= 0)
- stab = last_in_stab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (stab && stab_io(stab))
- fp = stab_io(stab)->ifp;
- else
- fp = Nullfp;
- if (fp) {
- argtype = (int)str_gnum(st[2]);
- value = (double)(flock(fileno(fp),argtype) >= 0);
- }
- else
- value = 0;
- goto donumset;
-#else
- fatal("The flock() function is unimplemented on this machine");
- break;
-#endif
- case O_UNSHIFT:
- ary = stab_array(arg[1].arg_ptr.arg_stab);
- if (arglast[2] - arglast[1] != 1)
- do_unshift(ary,arglast);
- else {
- STR *tmpstr = Str_new(52,0); /* must copy the STR */
- str_sset(tmpstr,st[2]);
- aunshift(ary,1);
- (void)astore(ary,0,tmpstr);
- }
- value = (double)(ary->ary_fill + 1);
- goto donumset;
-
- case O_TRY:
- sp = do_try(arg[1].arg_ptr.arg_cmd,
- gimme,arglast);
- goto array_return;
-
- case O_EVALONCE:
- sp = do_eval(st[1], O_EVAL, curcmd->c_stash, TRUE,
- gimme,arglast);
- if (eval_root) {
- str_free(arg[1].arg_ptr.arg_str);
- arg[1].arg_ptr.arg_cmd = eval_root;
- arg[1].arg_type = (A_CMD|A_DONT);
- arg[0].arg_type = O_TRY;
- }
- goto array_return;
-
- case O_REQUIRE:
- case O_DOFILE:
- case O_EVAL:
- if (maxarg < 1)
- tmpstr = stab_val(defstab);
- else
- tmpstr =
- (arg[1].arg_type & A_MASK) != A_NULL ? st[1] : stab_val(defstab);
-#ifdef TAINT
- tainted |= tmpstr->str_tainted;
- TAINT_PROPER("eval");
-#endif
- sp = do_eval(tmpstr, optype, curcmd->c_stash, FALSE,
- gimme,arglast);
- goto array_return;
-
- case O_FTRREAD:
- argtype = 0;
- anum = S_IRUSR;
- goto check_perm;
- case O_FTRWRITE:
- argtype = 0;
- anum = S_IWUSR;
- goto check_perm;
- case O_FTREXEC:
- argtype = 0;
- anum = S_IXUSR;
- goto check_perm;
- case O_FTEREAD:
- argtype = 1;
- anum = S_IRUSR;
- goto check_perm;
- case O_FTEWRITE:
- argtype = 1;
- anum = S_IWUSR;
- goto check_perm;
- case O_FTEEXEC:
- argtype = 1;
- anum = S_IXUSR;
- check_perm:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (cando(anum,argtype,&statcache))
- goto say_yes;
- goto say_no;
-
- case O_FTIS:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- goto say_yes;
- case O_FTEOWNED:
- case O_FTROWNED:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (statcache.st_uid == (optype == O_FTEOWNED ? euid : uid) )
- goto say_yes;
- goto say_no;
- case O_FTZERO:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (!statcache.st_size)
- goto say_yes;
- goto say_no;
- case O_FTSIZE:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- value = (double)statcache.st_size;
- goto donumset;
-
- case O_FTMTIME:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- value = (double)(basetime - statcache.st_mtime) / 86400.0;
- goto donumset;
- case O_FTATIME:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- value = (double)(basetime - statcache.st_atime) / 86400.0;
- goto donumset;
- case O_FTCTIME:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- value = (double)(basetime - statcache.st_ctime) / 86400.0;
- goto donumset;
-
- case O_FTSOCK:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISSOCK(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTCHR:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISCHR(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTBLK:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISBLK(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTFILE:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISREG(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTDIR:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISDIR(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTPIPE:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISFIFO(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTLINK:
- if (mylstat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISLNK(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_SYMLINK:
-#ifdef HAS_SYMLINK
- tmps = str_get(st[1]);
- tmps2 = str_get(st[2]);
-#ifdef TAINT
- TAINT_PROPER("symlink");
-#endif
- value = (double)(symlink(tmps,tmps2) >= 0);
- goto donumset;
-#else
- fatal("Unsupported function symlink");
-#endif
- case O_READLINK:
-#ifdef HAS_SYMLINK
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
- anum = readlink(tmps,buf,sizeof buf);
- if (anum < 0)
- goto say_undef;
- str_nset(str,buf,anum);
- break;
-#else
- goto say_undef; /* just pretend it's a normal file */
-#endif
- case O_FTSUID:
-#ifdef S_ISUID
- anum = S_ISUID;
- goto check_xid;
-#else
- goto say_no;
-#endif
- case O_FTSGID:
-#ifdef S_ISGID
- anum = S_ISGID;
- goto check_xid;
-#else
- goto say_no;
-#endif
- case O_FTSVTX:
-#ifdef S_ISVTX
- anum = S_ISVTX;
-#else
- goto say_no;
-#endif
- check_xid:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (statcache.st_mode & anum)
- goto say_yes;
- goto say_no;
- case O_FTTTY:
- if (arg[1].arg_type & A_DONT) {
- stab = arg[1].arg_ptr.arg_stab;
- tmps = "";
- }
- else
- stab = stabent(tmps = str_get(st[1]),FALSE);
- if (stab && stab_io(stab) && stab_io(stab)->ifp)
- anum = fileno(stab_io(stab)->ifp);
- else if (isDIGIT(*tmps))
- anum = atoi(tmps);
- else
- goto say_undef;
- if (isatty(anum))
- goto say_yes;
- goto say_no;
- case O_FTTEXT:
- case O_FTBINARY:
- str = do_fttext(arg,st[1]);
- break;
-#ifdef HAS_SOCKET
- case O_SOCKET:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_socket(stab,arglast);
-#else
- (void)do_socket(stab,arglast);
-#endif
- goto donumset;
- case O_BIND:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_bind(stab,arglast);
-#else
- (void)do_bind(stab,arglast);
-#endif
- goto donumset;
- case O_CONNECT:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_connect(stab,arglast);
-#else
- (void)do_connect(stab,arglast);
-#endif
- goto donumset;
- case O_LISTEN:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_listen(stab,arglast);
-#else
- (void)do_listen(stab,arglast);
-#endif
- goto donumset;
- case O_ACCEPT:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if ((arg[2].arg_type & A_MASK) == A_WORD)
- stab2 = arg[2].arg_ptr.arg_stab;
- else
- stab2 = stabent(str_get(st[2]),TRUE);
- do_accept(str,stab,stab2);
- STABSET(str);
- break;
- case O_GHBYNAME:
- if (maxarg < 1)
- goto say_undef;
- case O_GHBYADDR:
- case O_GHOSTENT:
- sp = do_ghent(optype,
- gimme,arglast);
- goto array_return;
- case O_GNBYNAME:
- if (maxarg < 1)
- goto say_undef;
- case O_GNBYADDR:
- case O_GNETENT:
- sp = do_gnent(optype,
- gimme,arglast);
- goto array_return;
- case O_GPBYNAME:
- if (maxarg < 1)
- goto say_undef;
- case O_GPBYNUMBER:
- case O_GPROTOENT:
- sp = do_gpent(optype,
- gimme,arglast);
- goto array_return;
- case O_GSBYNAME:
- if (maxarg < 1)
- goto say_undef;
- case O_GSBYPORT:
- case O_GSERVENT:
- sp = do_gsent(optype,
- gimme,arglast);
- goto array_return;
- case O_SHOSTENT:
- value = (double) sethostent((int)str_gnum(st[1]));
- goto donumset;
- case O_SNETENT:
- value = (double) setnetent((int)str_gnum(st[1]));
- goto donumset;
- case O_SPROTOENT:
- value = (double) setprotoent((int)str_gnum(st[1]));
- goto donumset;
- case O_SSERVENT:
- value = (double) setservent((int)str_gnum(st[1]));
- goto donumset;
- case O_EHOSTENT:
- value = (double) endhostent();
- goto donumset;
- case O_ENETENT:
- value = (double) endnetent();
- goto donumset;
- case O_EPROTOENT:
- value = (double) endprotoent();
- goto donumset;
- case O_ESERVENT:
- value = (double) endservent();
- goto donumset;
- case O_SOCKPAIR:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if ((arg[2].arg_type & A_MASK) == A_WORD)
- stab2 = arg[2].arg_ptr.arg_stab;
- else
- stab2 = stabent(str_get(st[2]),TRUE);
-#ifndef lint
- value = (double)do_spair(stab,stab2,arglast);
-#else
- (void)do_spair(stab,stab2,arglast);
-#endif
- goto donumset;
- case O_SHUTDOWN:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_shutdown(stab,arglast);
-#else
- (void)do_shutdown(stab,arglast);
-#endif
- goto donumset;
- case O_GSOCKOPT:
- case O_SSOCKOPT:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- sp = do_sopt(optype,stab,arglast);
- goto array_return;
- case O_GETSOCKNAME:
- case O_GETPEERNAME:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab)
- goto say_undef;
- sp = do_getsockname(optype,stab,arglast);
- goto array_return;
-
-#else /* HAS_SOCKET not defined */
- case O_SOCKET:
- case O_BIND:
- case O_CONNECT:
- case O_LISTEN:
- case O_ACCEPT:
- case O_SOCKPAIR:
- case O_GHBYNAME:
- case O_GHBYADDR:
- case O_GHOSTENT:
- case O_GNBYNAME:
- case O_GNBYADDR:
- case O_GNETENT:
- case O_GPBYNAME:
- case O_GPBYNUMBER:
- case O_GPROTOENT:
- case O_GSBYNAME:
- case O_GSBYPORT:
- case O_GSERVENT:
- case O_SHOSTENT:
- case O_SNETENT:
- case O_SPROTOENT:
- case O_SSERVENT:
- case O_EHOSTENT:
- case O_ENETENT:
- case O_EPROTOENT:
- case O_ESERVENT:
- case O_SHUTDOWN:
- case O_GSOCKOPT:
- case O_SSOCKOPT:
- case O_GETSOCKNAME:
- case O_GETPEERNAME:
- badsock:
- fatal("Unsupported socket function");
-#endif /* HAS_SOCKET */
- case O_SSELECT:
-#ifdef HAS_SELECT
- sp = do_select(gimme,arglast);
- goto array_return;
-#else
- fatal("select not implemented");
-#endif
- case O_FILENO:
- if (maxarg < 1)
- goto say_undef;
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp))
- goto say_undef;
- value = fileno(fp);
- goto donumset;
- case O_BINMODE:
- if (maxarg < 1)
- goto say_undef;
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp))
- goto say_undef;
-#ifdef DOSISH
-#ifdef atarist
- if(fflush(fp))
- str_set(str, No);
- else
- {
- fp->_flag |= _IOBIN;
- str_set(str, Yes);
- }
-#else
- str_set(str, (setmode(fileno(fp), O_BINARY) != -1) ? Yes : No);
-#endif
-#else
- str_set(str, Yes);
-#endif
- STABSET(str);
- break;
- case O_VEC:
- sp = do_vec(str == st[1], arg->arg_ptr.arg_str, arglast);
- goto array_return;
- case O_GPWNAM:
- case O_GPWUID:
- case O_GPWENT:
-#ifdef HAS_PASSWD
- sp = do_gpwent(optype,
- gimme,arglast);
- goto array_return;
- case O_SPWENT:
- value = (double) setpwent();
- goto donumset;
- case O_EPWENT:
- value = (double) endpwent();
- goto donumset;
-#else
- case O_EPWENT:
- case O_SPWENT:
- fatal("Unsupported password function");
- break;
-#endif
- case O_GGRNAM:
- case O_GGRGID:
- case O_GGRENT:
-#ifdef HAS_GROUP
- sp = do_ggrent(optype,
- gimme,arglast);
- goto array_return;
- case O_SGRENT:
- value = (double) setgrent();
- goto donumset;
- case O_EGRENT:
- value = (double) endgrent();
- goto donumset;
-#else
- case O_EGRENT:
- case O_SGRENT:
- fatal("Unsupported group function");
- break;
-#endif
- case O_GETLOGIN:
-#ifdef HAS_GETLOGIN
- if (!(tmps = getlogin()))
- goto say_undef;
- str_set(str,tmps);
-#else
- fatal("Unsupported function getlogin");
-#endif
- break;
- case O_OPEN_DIR:
- case O_READDIR:
- case O_TELLDIR:
- case O_SEEKDIR:
- case O_REWINDDIR:
- case O_CLOSEDIR:
- if (maxarg < 1)
- goto say_undef;
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab)
- goto say_undef;
- sp = do_dirop(optype,stab,gimme,arglast);
- goto array_return;
- case O_SYSCALL:
- value = (double)do_syscall(arglast);
- goto donumset;
- case O_PIPE_OP:
-#ifdef HAS_PIPE
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if ((arg[2].arg_type & A_MASK) == A_WORD)
- stab2 = arg[2].arg_ptr.arg_stab;
- else
- stab2 = stabent(str_get(st[2]),TRUE);
- do_pipe(str,stab,stab2);
- STABSET(str);
-#else
- fatal("Unsupported function pipe");
-#endif
- break;
- }
-
- normal_return:
- st[1] = str;
-#ifdef DEBUGGING
- if (debug) {
- dlevel--;
- if (debug & 8)
- deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str));
- }
-#endif
- stack_ary = stack->ary_array;
- stack_max = stack_ary + stack->ary_max;
- stack_sp = stack_ary + arglast[0] + 1;
- return arglast[0] + 1;
-}
register int items;
{
if (items < 5 || items > 6) {
- fatal("Usage: GDBM_File::new(dbtype, name, block_size, read_write, mode, fatal_func = (FATALFUNC)fatal)");
+ croak("Usage: GDBM_File::new(dbtype, name, block_size, read_write, mode, fatal_func = (FATALFUNC)croak)");
}
{
char * dbtype = SvPV(ST(1),na);
GDBM_File RETVAL;
if (items < 6)
- fatal_func = (FATALFUNC)fatal;
+ fatal_func = (FATALFUNC)croak;
else {
fatal_func = (FATALFUNC)SvPV(ST(6),na);
}
register int items;
{
if (items < 4 || items > 5) {
- fatal("Usage: GDBM_File::open(name, block_size, read_write, mode, fatal_func = (FATALFUNC)fatal)");
+ croak("Usage: GDBM_File::open(name, block_size, read_write, mode, fatal_func = (FATALFUNC)croak)");
}
{
char * name = SvPV(ST(1),na);
GDBM_File RETVAL;
if (items < 5)
- fatal_func = (FATALFUNC)fatal;
+ fatal_func = (FATALFUNC)croak;
else {
fatal_func = (FATALFUNC)SvPV(ST(5),na);
}
register int items;
{
if (items < 1 || items > 1) {
- fatal("Usage: GDBM_File::close(db)");
+ croak("Usage: GDBM_File::close(db)");
}
{
GDBM_File db;
if (sv_isa(ST(1), "GDBM_File"))
- db = (GDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type GDBM_File");
+ croak("db is not of type GDBM_File");
gdbm_close(db);
}
register int items;
{
if (items < 1 || items > 1) {
- fatal("Usage: GDBM_File::DESTROY(db)");
+ croak("Usage: GDBM_File::DESTROY(db)");
}
{
GDBM_File db;
if (sv_isa(ST(1), "GDBM_File"))
- db = (GDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type GDBM_File");
+ croak("db is not of type GDBM_File");
gdbm_close(db);
}
return sp;
register int items;
{
if (items < 2 || items > 2) {
- fatal("Usage: GDBM_File::fetch(db, key)");
+ croak("Usage: GDBM_File::fetch(db, key)");
}
{
GDBM_File db;
gdatum RETVAL;
if (sv_isa(ST(1), "GDBM_File"))
- db = (GDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type GDBM_File");
+ croak("db is not of type GDBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
register int items;
{
if (items < 3 || items > 4) {
- fatal("Usage: GDBM_File::store(db, key, value, flags = GDBM_REPLACE)");
+ croak("Usage: GDBM_File::store(db, key, value, flags = GDBM_REPLACE)");
}
{
GDBM_File db;
int RETVAL;
if (sv_isa(ST(1), "GDBM_File"))
- db = (GDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type GDBM_File");
+ croak("db is not of type GDBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
register int items;
{
if (items < 2 || items > 2) {
- fatal("Usage: GDBM_File::delete(db, key)");
+ croak("Usage: GDBM_File::delete(db, key)");
}
{
GDBM_File db;
int RETVAL;
if (sv_isa(ST(1), "GDBM_File"))
- db = (GDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type GDBM_File");
+ croak("db is not of type GDBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
register int items;
{
if (items < 1 || items > 1) {
- fatal("Usage: GDBM_File::firstkey(db)");
+ croak("Usage: GDBM_File::firstkey(db)");
}
{
GDBM_File db;
gdatum RETVAL;
if (sv_isa(ST(1), "GDBM_File"))
- db = (GDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type GDBM_File");
+ croak("db is not of type GDBM_File");
RETVAL = gdbm_firstkey(db);
ST(0) = sv_mortalcopy(&sv_undef);
register int items;
{
if (items < 2 || items > 2) {
- fatal("Usage: GDBM_File::nextkey(db, key)");
+ croak("Usage: GDBM_File::nextkey(db, key)");
}
{
GDBM_File db;
gdatum RETVAL;
if (sv_isa(ST(1), "GDBM_File"))
- db = (GDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type GDBM_File");
+ croak("db is not of type GDBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
register int items;
{
if (items < 1 || items > 1) {
- fatal("Usage: GDBM_File::reorganize(db)");
+ croak("Usage: GDBM_File::reorganize(db)");
}
{
GDBM_File db;
int RETVAL;
if (sv_isa(ST(1), "GDBM_File"))
- db = (GDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (GDBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type GDBM_File");
+ croak("db is not of type GDBM_File");
RETVAL = gdbm_reorganize(db);
ST(0) = sv_mortalcopy(&sv_undef);
return sp;
}
-int init_GDBM_File(ix,sp,items)
+int boot_GDBM_File(ix,sp,items)
int ix;
int sp;
int items;
all: NDBM_File.c ODBM_File.c GDBM_File.c SDBM_File.c
NDBM_File.c: NDBM_File.xs
- ../xsubpp ../typemap NDBM_File.xs >NDBM_File.c
+ ../xsubpp NDBM_File.xs >NDBM_File.c
SDBM_File.c: SDBM_File.xs
- ../xsubpp ../typemap SDBM_File.xs >SDBM_File.c
+ ../xsubpp SDBM_File.xs >SDBM_File.c
+
+SDBM_File.o: SDBM_File.c
+ cc -g -I../.. -pic -c SDBM_File.c
+
+SDBM_File.so: SDBM_File.o sdbm/libsdbm.a
+ ld -o SDBM_File.so SDBM_File.o sdbm/libsdbm.a
ODBM_File.c: ODBM_File.xs
- ../xsubpp ../typemap ODBM_File.xs >ODBM_File.c
+ ../xsubpp ODBM_File.xs >ODBM_File.c
GDBM_File.c: GDBM_File.xs
- ../xsubpp ../typemap GDBM_File.xs >GDBM_File.c
+ ../xsubpp GDBM_File.xs >GDBM_File.c
register int items;
{
if (items < 4 || items > 4) {
- fatal("Usage: ODBM_File::new(dbtype, filename, flags, mode)");
+ croak("Usage: ODBM_File::new(dbtype, filename, flags, mode)");
}
{
char * dbtype = SvPV(ST(1),na);
{
char tmpbuf[1025];
if (dbmrefcnt++)
- fatal("Old dbm can only open one database");
+ croak("Old dbm can only open one database");
sprintf(tmpbuf,"%s.dir",filename);
if (stat(tmpbuf, &statbuf) < 0) {
if (flags & O_CREAT) {
if (mode < 0 || close(creat(tmpbuf,mode)) < 0)
- fatal("ODBM_File: Can't create %s", filename);
+ croak("ODBM_File: Can't create %s", filename);
sprintf(tmpbuf,"%s.pag",filename);
if (close(creat(tmpbuf,mode)) < 0)
- fatal("ODBM_File: Can't create %s", filename);
+ croak("ODBM_File: Can't create %s", filename);
}
else
- fatal("ODBM_FILE: Can't open %s", filename);
+ croak("ODBM_FILE: Can't open %s", filename);
}
RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
ST(0) = sv_mortalcopy(&sv_undef);
register int items;
{
if (items < 1 || items > 1) {
- fatal("Usage: ODBM_File::DESTROY(db)");
+ croak("Usage: ODBM_File::DESTROY(db)");
}
{
ODBM_File db;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type ODBM_File");
+ croak("db is not of type ODBM_File");
dbmrefcnt--;
dbmclose();
}
register int items;
{
if (items < 2 || items > 2) {
- fatal("Usage: ODBM_File::fetch(db, key)");
+ croak("Usage: ODBM_File::fetch(db, key)");
}
{
ODBM_File db;
datum RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type ODBM_File");
+ croak("db is not of type ODBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
register int items;
{
if (items < 3 || items > 4) {
- fatal("Usage: ODBM_File::store(db, key, value, flags = DBM_REPLACE)");
+ croak("Usage: ODBM_File::store(db, key, value, flags = DBM_REPLACE)");
}
{
ODBM_File db;
int RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type ODBM_File");
+ croak("db is not of type ODBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
register int items;
{
if (items < 2 || items > 2) {
- fatal("Usage: ODBM_File::delete(db, key)");
+ croak("Usage: ODBM_File::delete(db, key)");
}
{
ODBM_File db;
int RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type ODBM_File");
+ croak("db is not of type ODBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
register int items;
{
if (items < 1 || items > 1) {
- fatal("Usage: ODBM_File::firstkey(db)");
+ croak("Usage: ODBM_File::firstkey(db)");
}
{
ODBM_File db;
datum RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type ODBM_File");
+ croak("db is not of type ODBM_File");
RETVAL = odbm_firstkey(db);
ST(0) = sv_mortalcopy(&sv_undef);
register int items;
{
if (items < 2 || items > 2) {
- fatal("Usage: ODBM_File::nextkey(db, key)");
+ croak("Usage: ODBM_File::nextkey(db, key)");
}
{
ODBM_File db;
datum RETVAL;
if (sv_isa(ST(1), "ODBM_File"))
- db = (ODBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
+ db = (ODBM_File)(unsigned long)SvNV((SV*)SvRV(ST(1)));
else
- fatal("db is not of type ODBM_File");
+ croak("db is not of type ODBM_File");
key.dptr = SvPV(ST(2), key.dsize);;
return sp;
}
-int init_ODBM_File(ix,sp,items)
+int boot_ODBM_File(ix,sp,items)
int ix;
int sp;
int items;
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include "ext/dbm/sdbm/sdbm.h"
-
-typedef DBM* SDBM_File;
-#define sdbm_new(dbtype,filename,flags,mode) sdbm_open(filename,flags,mode)
-
-static int
-XS_SDBM_File_sdbm_new(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-{
- if (items < 4 || items > 4) {
- fatal("Usage: SDBM_File::new(dbtype, filename, flags, mode)");
- }
- {
- char * dbtype = SvPV(ST(1),na);
- char * filename = SvPV(ST(2),na);
- int flags = (int)SvIV(ST(3));
- int mode = (int)SvIV(ST(4));
- SDBM_File RETVAL;
-
- RETVAL = sdbm_new(dbtype, filename, flags, mode);
- ST(0) = sv_mortalcopy(&sv_undef);
- sv_setptrobj(ST(0), RETVAL, "SDBM_File");
- }
- return sp;
-}
-
-static int
-XS_SDBM_File_sdbm_DESTROY(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-{
- if (items < 1 || items > 1) {
- fatal("Usage: SDBM_File::DESTROY(db)");
- }
- {
- SDBM_File db;
-
- if (sv_isa(ST(1), "SDBM_File"))
- db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
- else
- fatal("db is not of type SDBM_File");
- sdbm_close(db);
- }
- return sp;
-}
-
-static int
-XS_SDBM_File_sdbm_fetch(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-{
- if (items < 2 || items > 2) {
- fatal("Usage: SDBM_File::fetch(db, key)");
- }
- {
- SDBM_File db;
- datum key;
- datum RETVAL;
-
- if (sv_isa(ST(1), "SDBM_File"))
- db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
- else
- fatal("db is not of type SDBM_File");
-
- key.dptr = SvPV(ST(2), key.dsize);;
-
- RETVAL = sdbm_fetch(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
- sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
- }
- return sp;
-}
-
-static int
-XS_SDBM_File_sdbm_store(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-{
- if (items < 3 || items > 4) {
- fatal("Usage: SDBM_File::store(db, key, value, flags = DBM_REPLACE)");
- }
- {
- SDBM_File db;
- datum key;
- datum value;
- int flags;
- int RETVAL;
-
- if (sv_isa(ST(1), "SDBM_File"))
- db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
- else
- fatal("db is not of type SDBM_File");
-
- key.dptr = SvPV(ST(2), key.dsize);;
-
- value.dptr = SvPV(ST(3), value.dsize);;
-
- if (items < 4)
- flags = DBM_REPLACE;
- else {
- flags = (int)SvIV(ST(4));
- }
-
- RETVAL = sdbm_store(db, key, value, flags);
- ST(0) = sv_mortalcopy(&sv_undef);
- sv_setiv(ST(0), (I32)RETVAL);
- }
- return sp;
-}
-
-static int
-XS_SDBM_File_sdbm_delete(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-{
- if (items < 2 || items > 2) {
- fatal("Usage: SDBM_File::delete(db, key)");
- }
- {
- SDBM_File db;
- datum key;
- int RETVAL;
-
- if (sv_isa(ST(1), "SDBM_File"))
- db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
- else
- fatal("db is not of type SDBM_File");
-
- key.dptr = SvPV(ST(2), key.dsize);;
-
- RETVAL = sdbm_delete(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
- sv_setiv(ST(0), (I32)RETVAL);
- }
- return sp;
-}
-
-static int
-XS_SDBM_File_sdbm_firstkey(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-{
- if (items < 1 || items > 1) {
- fatal("Usage: SDBM_File::firstkey(db)");
- }
- {
- SDBM_File db;
- datum RETVAL;
-
- if (sv_isa(ST(1), "SDBM_File"))
- db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
- else
- fatal("db is not of type SDBM_File");
-
- RETVAL = sdbm_firstkey(db);
- ST(0) = sv_mortalcopy(&sv_undef);
- sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
- }
- return sp;
-}
-
-static int
-XS_SDBM_File_sdbm_nextkey(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-{
- if (items < 2 || items > 2) {
- fatal("Usage: SDBM_File::nextkey(db, key)");
- }
- {
- SDBM_File db;
- datum key;
- datum RETVAL;
-
- if (sv_isa(ST(1), "SDBM_File"))
- db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
- else
- fatal("db is not of type SDBM_File");
-
- key.dptr = SvPV(ST(2), key.dsize);;
-
- RETVAL = sdbm_nextkey(db, key);
- ST(0) = sv_mortalcopy(&sv_undef);
- sv_setpvn(ST(0), RETVAL.dptr, RETVAL.dsize);
- }
- return sp;
-}
-
-static int
-XS_SDBM_File_sdbm_error(ix, sp, items)
-register int ix;
-register int sp;
-register int items;
-{
- if (items < 1 || items > 1) {
- fatal("Usage: SDBM_File::error(db)");
- }
- {
- SDBM_File db;
- int RETVAL;
-
- if (sv_isa(ST(1), "SDBM_File"))
- db = (SDBM_File)(unsigned long)SvNV((SV*)SvANY(ST(1)));
- else
- fatal("db is not of type SDBM_File");
-
- RETVAL = sdbm_error(db);
- ST(0) = sv_mortalcopy(&sv_undef);
https://perl5.git.perl.org / perl5.git / commitdiff