perl5 in C++ (was Re: Creature Freep)
by John Tobey other posts by this author
Jun 25 2000 3:24PM messages near this date
the perl6-porters list
|
ANSI Perl: NO F* WAY !!!
On Sat, 24 Oct 1998, "Felix S. Gallo" <fsg@[...].com> wrote:
> Chip writes:
> >According to Felix S. Gallo:
> >> 1. Describe the goal. I don't believe Perl can be usefully rewritten in
> >> C++ [*] before the next Perl conference in any case [...]
> >
> >Yes, that's the target.
> >> [*] as if
> >We shall see. (Were I a betting man I'd clean up. :-))
>
> Never bet against a British pedant -- I can always win by redefining
> usefully. For my current claim, I think 'usefully' means that it's written
> in C++ style; Perl is right now written in C++ if you make a few
> minor changes.
Below are those minor changes (with gratuitous Linux dependencies),
for anyone wishing to play around.
I'm interested in Joel Spolsky's article,
<URL:http://joel.editthispage.com/stories/storyReader$47> , on not
rewriting big programs from scratch.
Apologies for straying from the path. :-)
-John
This is not a proper patch and requires care and feeding. Here is how
I apply it, more or less:
cd perl-5.6.0
chmod u+w hints/linux.sh
echo timetype=time_t > > hints/linux.sh
./Configure -ds
!patch -p0 < patchfile
make all test
Then do stuff like this until it's Perl 6:
inline NV& sv::NVX () { return ((XPVNV*)sv_any)-> xnv_nv; }
#define SvNVX(sv) ((sv)-> NVX())
--- gv.h~ Sun Feb 6 14:32:59 2000
+++ gv.h Sun Jun 25 11:17:29 2000
@@ -19,7 +19,7 @@
U32 gp_cvgen; /* generational validity of cached gv_cv */
U32 gp_flags; /* XXX unused */
line_t gp_line; /* line first declared at (for -w) */
- char * gp_file; /* file first declared in (for -w) */
+ const char *gp_file; /* file first declared in (for -w) */
};
#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
--- gv.c~ Tue Mar 21 00:28:10 2000
+++ gv.c Sun Jun 25 01:22:20 2000
@@ -982,7 +982,7 @@
gv_check(hv); /* nested package */
}
else if (isALPHA(*HeKEY(entry))) {
- char *file;
+ const char *file;
gv = (GV*)HeVAL(entry);
if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
continue;
--- mg.c~ Fri Mar 17 20:24:04 2000
+++ mg.c Sun Jun 25 11:54:19 2000
@@ -21,6 +21,10 @@
# include <unistd.h>
#endif
+#ifdef I_GRP
+# include <grp.h>
+#endif
+
#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
# ifndef NGROUPS
# define NGROUPS 32
@@ -688,9 +692,7 @@
break;
case '~':
s = IoFMT_NAME(GvIOp(PL_defoutgv));
- if (!s)
- s = GvENAME(PL_defoutgv);
- sv_setpv(sv,s);
+ sv_setpv(sv,s ? s : GvENAME(PL_defoutgv));
break;
#ifndef lint
case '=':
--- pp_hot.c~ Fri Mar 17 22:11:42 2000
+++ pp_hot.c Sun Jun 25 10:10:29 2000
@@ -836,60 +836,52 @@
}
if (PL_delaymagic & ~DM_DELAY) {
if (PL_delaymagic & DM_UID) {
-#ifdef HAS_SETRESUID
- (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
-#else
-# ifdef HAS_SETREUID
+#ifdef HAS_SETREUID
(void)setreuid(PL_uid,PL_euid);
-# else
-# ifdef HAS_SETRUID
+#else
+# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
(void)setruid(PL_uid);
PL_delaymagic &= ~DM_RUID;
}
-# endif /* HAS_SETRUID */
-# ifdef HAS_SETEUID
+# endif /* HAS_SETRUID */
+# ifdef HAS_SETEUID
if ((PL_delaymagic & DM_UID) == DM_EUID) {
(void)seteuid(PL_uid);
PL_delaymagic &= ~DM_EUID;
}
-# endif /* HAS_SETEUID */
+# endif /* HAS_SETEUID */
if (PL_delaymagic & DM_UID) {
if (PL_uid != PL_euid)
DIE(aTHX_ "No setreuid available");
(void)PerlProc_setuid(PL_uid);
}
-# endif /* HAS_SETREUID */
-#endif /* HAS_SETRESUID */
+#endif /* HAS_SETREUID */
PL_uid = PerlProc_getuid();
PL_euid = PerlProc_geteuid();
}
if (PL_delaymagic & DM_GID) {
-#ifdef HAS_SETRESGID
- (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
-#else
-# ifdef HAS_SETREGID
+#ifdef HAS_SETREGID
(void)setregid(PL_gid,PL_egid);
-# else
-# ifdef HAS_SETRGID
+#else
+# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
(void)setrgid(PL_gid);
PL_delaymagic &= ~DM_RGID;
}
-# endif /* HAS_SETRGID */
-# ifdef HAS_SETEGID
+# endif /* HAS_SETRGID */
+# ifdef HAS_SETEGID
if ((PL_delaymagic & DM_GID) == DM_EGID) {
(void)setegid(PL_gid);
PL_delaymagic &= ~DM_EGID;
}
-# endif /* HAS_SETEGID */
+# endif /* HAS_SETEGID */
if (PL_delaymagic & DM_GID) {
if (PL_gid != PL_egid)
DIE(aTHX_ "No setregid available");
(void)PerlProc_setgid(PL_gid);
}
-# endif /* HAS_SETREGID */
-#endif /* HAS_SETRESGID */
+#endif /* HAS_SETREGID */
PL_gid = PerlProc_getgid();
PL_egid = PerlProc_getegid();
}
--- sv.c~ Wed Mar 22 21:44:37 2000
+++ sv.c Sun Jun 25 11:55:29 2000
@@ -15,6 +15,11 @@
#define PERL_IN_SV_C
#include "perl.h"
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+
#define FCALL *f
#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
@@ -2540,7 +2545,7 @@
if (dtype <= SVt_PVGV) {
glob_assign:
if (dtype != SVt_PVGV) {
- char *name = GvNAME(sstr);
+ const char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
sv_upgrade(dstr, SVt_PVGV);
sv_magic(dstr, dstr, '*', name, len);
--- pp_sys.c~ Sun Mar 19 02:18:10 2000
+++ pp_sys.c Sun Jun 25 12:53:08 2000
@@ -36,10 +36,16 @@
#endif
#ifdef HAS_SYSCALL
-#ifdef __cplusplus
+#ifdef __cplusplus
+#ifndef __GLIBC__
+/* XXX Who put this here? Is someone compiling Perl with a C++ compiler
+ on a system that has syscall and doesn't declare it in a header file?
+ Really?? This breaks g++ on Linux because syscall returns long.
+ Hence my GNU Libc exclusion. -jtobey */
extern "C" int syscall(unsigned long,...);
#endif
#endif
+#endif
#ifdef I_SYS_WAIT
# include <sys/wait.h>
@@ -3971,7 +3977,13 @@
#ifdef HAS_GETPRIORITY
who = POPi;
which = TOPi;
+#if defined(__GLIBC__) && defined(__cplusplus)
+ /* XXX GNU Libc documents `which' as int but declares it as enum
+ __priority_which in <sys/resource.h> , so let's not take chances. */
+ SETi( ((int (*)(int, int))getpriority)(which, who) );
+#else
SETi( getpriority(which, who) );
+#endif
RETURN;
#else
DIE(aTHX_ PL_no_func, "getpriority()");
@@ -3989,7 +4001,13 @@
who = POPi;
which = TOPi;
TAINT_PROPER("setpriority");
+#if defined(__GLIBC__) && defined(__cplusplus)
+ /* XXX GNU Libc documents `which' as int but declares it as enum
+ __priority_which in <sys/resource.h> , so let's not take chances. */
+ SETi( ((int (*)(int, int, int))setpriority)(which, who, niceval) > = 0 );
+#else
SETi( setpriority(which, who, niceval) > = 0 );
+#endif
RETURN;
#else
DIE(aTHX_ PL_no_func, "setpriority()");
--- sv.h~ Thu Mar 9 12:40:40 2000
+++ sv.h Sun Jun 25 11:49:08 2000
@@ -290,7 +290,7 @@
HV* xmg_stash; /* class package */
GP* xgv_gp;
- char* xgv_name;
+ const char* xgv_name;
STRLEN xgv_namelen;
HV* xgv_stash;
U8 xgv_flags;
--- op.c~ Tue Mar 21 00:06:34 2000
+++ op.c Sun Jun 25 11:51:36 2000
@@ -5498,7 +5498,7 @@
/* is this op a FH constructor? */
if (is_handle_constructor(o,numargs)) {
- char *name = Nullch;
+ const char *name = Nullch;
STRLEN len;
flags = 0;
--- ext/DB_File/DB_File.xs~ Tue Feb 15 00:42:40 2000
+++ ext/DB_File/DB_File.xs Sun Jun 25 12:38:45 2000
@@ -140,6 +140,10 @@
#include <fcntl.h>
+#ifdef __cplusplus
+extern "C" void __getBerkeleyDBInfo();
+#endif
+
/* #define TRACE */
#define DBM_FILTERING
@@ -380,7 +384,7 @@
#endif /* DBM_FILTERING */
-#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (void*)""), s)
+#define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? (const char*)d : ""), s)
#define OutputValue(arg, name) { if (RETVAL == 0) { @@ -507,8 +511,8 @@
PUSHMARK(SP) ;
EXTEND(SP,2) ;
- PUSHs(sv_2mortal(newSVpvn(data1,key1-> size)));
- PUSHs(sv_2mortal(newSVpvn(data2,key2-> size)));
+ PUSHs(sv_2mortal(newSVpvn((const char *)data1,key1-> size)));
+ PUSHs(sv_2mortal(newSVpvn((const char *)data2,key2-> size)));
PUTBACK ;
count = perl_call_sv(CurrentDB-> compare, G_SCALAR);
@@ -563,8 +567,8 @@
PUSHMARK(SP) ;
EXTEND(SP,2) ;
- PUSHs(sv_2mortal(newSVpvn(data1,key1-> size)));
- PUSHs(sv_2mortal(newSVpvn(data2,key2-> size)));
+ PUSHs(sv_2mortal(newSVpvn((const char *)data1,key1-> size)));
+ PUSHs(sv_2mortal(newSVpvn((const char *)data2,key2-> size)));
PUTBACK ;
count = perl_call_sv(CurrentDB-> prefix, G_SCALAR);
@@ -768,7 +772,6 @@
SV ** svp;
HV * action ;
DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
- void * openinfo = NULL ;
INFO * info = &RETVAL-> info ;
STRLEN n_a;
@@ -808,7 +811,6 @@
croak("DB_File can only tie an associative array to a DB_HASH database") ;
RETVAL-> type = DB_HASH ;
- openinfo = (void*)info ;
svp = hv_fetch(action, "hash", 4, FALSE);
@@ -843,7 +845,6 @@
croak("DB_File can only tie an associative array to a DB_BTREE database");
RETVAL-> type = DB_BTREE ;
- openinfo = (void*)info ;
svp = hv_fetch(action, "compare", 7, FALSE);
if (svp && SvOK(*svp))
@@ -892,7 +893,6 @@
croak("DB_File can only tie an array to a DB_RECNO database");
RETVAL-> type = DB_RECNO ;
- openinfo = (void *)info ;
info-> db_RE_flags = 0 ;
@@ -1011,7 +1011,7 @@
Flags |= DB_TRUNCATE ;
#endif
- status = db_open(name, RETVAL-> type, Flags, mode, NULL, openinfo, &RETVAL->dbp) ;
+ status = db_open(name, RETVAL-> type, Flags, mode, NULL, info, &RETVAL->dbp) ;
if (status == 0)
#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
status = (RETVAL-> dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ;
@@ -1027,9 +1027,9 @@
#else
#if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2
- RETVAL-> dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ;
+ RETVAL-> dbp = __db185_open(name, flags, mode, RETVAL->type, info) ;
#else
- RETVAL-> dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
+ RETVAL-> dbp = dbopen(name, flags, mode, RETVAL->type, info) ;
#endif /* DB_LIBRARY_COMPATIBILITY_API */
#endif
--- ext/DB_File/version.c~ Sun Jan 23 08:15:45 2000
+++ ext/DB_File/version.c Sun Jun 25 12:34:01 2000
@@ -25,7 +25,7 @@
#include <db.h>
-void
+EXTERN_C void
__getBerkeleyDBInfo()
{
SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ;
--- ext/B/B.xs~ Thu Feb 24 20:49:18 2000
+++ ext/B/B.xs Sun Jun 25 11:23:20 2000
@@ -1054,7 +1054,7 @@
GvLINE(gv)
B::GV gv
-char *
+const char *
GvFILE(gv)
B::GV gv
--- ext/B/typemap~ Thu Oct 28 17:35:07 1999
+++ ext/B/typemap Sun Jun 25 11:18:38 2000
@@ -31,6 +31,7 @@
SSize_t T_IV
STRLEN T_IV
PADOFFSET T_UV
+const char * T_PV
INPUT
T_OP_OBJ
--- config.sh.orig Sun Jun 25 13:43:19 2000
+++ config.sh Sun Jun 25 13:49:12 2000
@@ -52,7 +52,7 @@
c=''
castflags='0'
cat='cat'
-cc='cc'
+cc='g++'
cccdlflags='-fpic'
ccdlflags='-rdynamic'
ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS
=64'
@@ -76,8 +76,8 @@
cppflags='-fno-strict-aliasing -I/usr/local/include'
cpplast='-'
cppminus='-'
-cpprun='cc -E'
-cppstdin='cc -E'
+cpprun='g++ -E'
+cppstdin='g++ -E'
cppsymbols='_FILE_OFFSET_BITS=64 __GNUC_MINOR__=95 _LARGEFILE_SOURCE=1 _POSIX_C_SOURCE=199
506 _POSIX_SOURCE=1 __STDC__=1 __i386=1 __i386__=1 __linux=1 __linux__=1 __unix=1 __unix__=1
'
crosscompile='undef'
cryptlib=''
@@ -383,7 +383,7 @@
dlsrc='dl_dlopen.xs'
doublesize='8'
drand01='drand48()'
-dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob GDBM_
File IO IPC/SysV ODBM_File Opcode POSIX SDBM_File Socket Sys/Hostname Sys/Syslog attrs re'
+dynamic_ext='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob GDBM_
File IO IPC/SysV Opcode POSIX SDBM_File Socket Sys/Hostname Sys/Syslog attrs re'
eagain='EAGAIN'
ebcdic='undef'
echo='echo'
@@ -392,7 +392,7 @@
eunicefix=':'
exe_ext=''
expr='expr'
-extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob GDBM_F
ile IO IPC/SysV ODBM_File Opcode POSIX SDBM_File Socket Sys/Hostname Sys/Syslog attrs re Err
no'
+extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob GDBM_F
ile IO IPC/SysV Opcode POSIX SDBM_File Socket Sys/Hostname Sys/Syslog attrs re Errno'
fflushNULL='define'
fflushall='undef'
find=''
@@ -532,7 +532,7 @@
known_extensions='B ByteLoader DB_File Data/Dumper Devel/DProf Devel/Peek Fcntl File/Glob
GDBM_File IO IPC/SysV NDBM_File ODBM_File Opcode POSIX SDBM_File Socket Sys/Hostname Sys/Sys
log Thread attrs re'
ksh=''
large=''
-ld='cc'
+ld='g++'
lddlflags='-shared -L/usr/local/lib'
ldflags=' -L/usr/local/lib'
ldlibpthname='LD_LIBRARY_PATH'
--- ext/Devel/DProf/DProf.xs~ Fri Feb 4 11:43:02 2000
+++ ext/Devel/DProf/DProf.xs Sun Jun 25 11:59:02 2000
@@ -3,6 +3,11 @@
#include "perl.h"
#include "XSUB.h"
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+
/* For older Perls */
#ifndef dTHR
# define dTHR int dummy_thr
@@ -60,7 +65,7 @@
clock_t tms_utime; /* cpu time spent in user space */
clock_t tms_stime; /* cpu time spent in system */
clock_t realtime; /* elapsed real time, in ticks */
- char *name;
+ const char *name;
U32 id;
opcode ptype;
};
@@ -210,7 +215,7 @@
}
static void
-prof_dumps(pTHX_ U32 id, char *pname, char *gname)
+prof_dumps(pTHX_ U32 id, const char *pname, const char *gname)
{
PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
}
@@ -241,8 +246,8 @@
}
else if (ptype == OP_GV) {
U32 id = g_profstack[base++].id;
- char *pname = g_profstack[base++].name;
- char *gname = g_profstack[base++].name;
+ const char *pname = g_profstack[base++].name;
+ const char *gname = g_profstack[base++].name;
prof_dumps(aTHX_ id, pname, gname);
}
@@ -318,7 +323,8 @@
{
SV **svp;
- char *gname, *pname;
+ const char *gname;
+ const char *pname;
CV *cv;
cv = INT2PTR(CV*,SvIVX(Sub));
--- ext/File/Glob/bsd_glob.c~ Thu Mar 2 12:53:17 2000
+++ ext/File/Glob/bsd_glob.c Sun Jun 25 12:08:02 2000
@@ -63,6 +63,11 @@
#include <perl.h>
#include <XSUB.h>
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+#include <unistd.h>
+#endif
+
#include "bsd_glob.h"
#ifdef I_PWD
# include <pwd.h>
@@ -637,6 +642,12 @@
/* NOTREACHED */
}
+#ifdef __cplusplus
+typedef Direntry_t *(*readdirfunc_t)(DIR*);
+#else
+typedef Direntry_t *(*readdirfunc_t)();
+#endif
+
static int
glob3(Char *pathbuf, Char *pathend, Char *pattern,
Char *restpattern, glob_t *pglob)
@@ -646,14 +657,7 @@
int err;
int nocase;
char buf[MAXPATHLEN];
-
- /*
- * The readdirfunc declaration can't be prototyped, because it is
- * assigned, below, to two functions which are prototyped in glob.h
- * and dirent.h as taking pointers to differently typed opaque
- * structures.
- */
- Direntry_t *(*readdirfunc)();
+ readdirfunc_t readdirfunc;
*pathend = BG_EOS;
errno = 0;
@@ -689,9 +693,9 @@
/* Search directory for matching names. */
if (pglob-> gl_flags & GLOB_ALTDIRFUNC)
- readdirfunc = pglob-> gl_readdir;
+ readdirfunc = (readdirfunc_t)pglob-> gl_readdir;
else
- readdirfunc = my_readdir;
+ readdirfunc = (readdirfunc_t)my_readdir;
while ((dp = (*readdirfunc)(dirp))) {
register U8 *sc;
register Char *dc;
@@ -859,7 +863,7 @@
g_Ctoc(str, buf);
if (pglob-> gl_flags & GLOB_ALTDIRFUNC)
- return((*pglob-> gl_opendir)(buf));
+ return((DIR*)(*pglob-> gl_opendir)(buf));
else
return(PerlDir_open(buf));
}
--
John Tobey, late nite hacker <jtobey@[...].org>
\\\ ///
]]] With enough bugs, all eyes are shallow. [[[
/// \\
|
