diff options
138 files changed, 9107 insertions, 2545 deletions
@@ -7,6 +7,47 @@ site, in the .../src/5.0 directory for full version releases, or in the .../src/5/0/unsupported directory for sub-version releases.) +---------------- +Version 5.003_02 +---------------- +o Visible Changes to Core Functionality + - Redefining constant subs, or changing sub's prototype now give warnings. + - Fixes for ++/-- of values close to max/min size of an integer + - Warning for un-qualified bareword as handler in $SIG{}. + - UNIVERSAL::isa can now be called as static method. + +o Changes in Core Internals + - PerlIO abstraction added. + Perl core and standard extensions no longer assume ANSI C's stdio is IO + mechanism, Default Configure mode is still to use stdio via set of C macros. + Alternate modes are to use stdio via one perlio.c module, or + to use sfio if available. + + - Several bug fixs from perl5-porters + - Make sources non-ANSI C correct again. + - SUPER in gv.c + - Last of shared-hash-key patches + - eval '(0,1..3)'; # --> SegFault + - coredumps after simple subsitutes. + - Correction to UNIVERSAL::VERSION docs. + - Fixed io_udp test. + - Fixed another abuse of malloc'ed memory. + - Enabled DEBUGING_MSTATS whenever perl's malloc() is used. + - Reverted to default of not hiding perl's malloc (if used). + +o Changes in the Standard Library and Utilities + - Fixed MakeMaker for static SDBM and builing in a link tree. + - Upgraded to IO-1.09, and includes latest (still experimental) IO::Select. + - Documentation/test tweak to DB_File + - h2xs upgrade to allow use C::Scan module + +o Changes in OS-specific and Build-time Support + - Attempted to re-created 5.003_01's NeXT support with metaconfig units. + - Updated MANIFEST + - make minitest now depends on lib/Config.pm, as some of tests require it. + - Included latest plan9 sub-directory + - Applied OS/2 patches. + - Typo patch for VMS. ---------------- Version 5.003_01 @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.8 1995/07/25 13:40:02 ram Exp $ # -# Generated on Wed Feb 21 14:26:18 EST 1996 [metaconfig 3.0 PL60] +# Generated on Thu Aug 8 17:48:02 BST 1996 [metaconfig 3.0 PL60] cat >/tmp/c1$$ <<EOF ARGGGHHHH!!!!! @@ -226,12 +226,12 @@ baserev='' bin='' binexp='' installbin='' +bin_sh='' byteorder='' cc='' gccversion='' ccflags='' cppflags='' -mab='' ldflags='' lkflags='' locincpth='' @@ -323,6 +323,7 @@ d_open3='' d_fpathconf='' d_pathconf='' d_pause='' +d_perlstdio='' d_pipe='' d_poll='' d_portable='' @@ -356,6 +357,7 @@ d_setreuid='' d_setrgid='' d_setruid='' d_setsid='' +d_sfio='' d_shm='' d_shmat='' d_shmatprototype='' @@ -459,6 +461,7 @@ d_pwcomment='' d_pwexpire='' d_pwquota='' i_pwd='' +i_sfio='' i_stddef='' i_stdlib='' i_string='' @@ -486,6 +489,7 @@ i_time='' timeincl='' i_unistd='' i_utime='' +i_values='' i_stdarg='' i_varargs='' i_varhdr='' @@ -500,6 +504,7 @@ xlibpth='' libs='' lns='' lseektype='' +mab='' d_mymalloc='' freetype='' mallocobj='' @@ -542,6 +547,7 @@ package='' spackage='' pager='' patchlevel='' +subversion='' perladmin='' perlpath='' prefix='' @@ -572,7 +578,6 @@ ssizetype='' startperl='' startsh='' stdchar='' -subversion='' sysman='' uidtype='' nm_opt='' @@ -678,6 +683,7 @@ usesafe=true exe_ext='' : Extra object files, if any, needed on this platform. archobjs='' +bin_sh='/bin/sh' : Possible local include directories to search. : Set locincpth to "" in a hint file to defeat local include searches. locincpth="/usr/local/include /opt/local/include /usr/gnu/include" @@ -703,11 +709,12 @@ glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/shlib" : machines, like the mips. Usually, it should be empty. plibpth='' +mab='' : full support for void wanted by default defvoidused=15 : List of libraries we want. -libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl' +libswanted='sfio net socket inet nsl nm ndbm gdbm dbm db malloc dl' libswanted="$libswanted dld ld sun m c cposix posix ndir dir crypt" libswanted="$libswanted ucb bsd BSD PW x" : We probably want to search /usr/shlib before most other libraries. @@ -717,8 +724,79 @@ glibpth="/usr/shlib $glibpth" : Do not use vfork unless overridden by a hint file. usevfork=false +: see if sh knows # comments +echo " " +echo "Checking your sh to see if it knows about # comments..." >&4 +if `sh -c '#' >/dev/null 2>&1`; then + echo "Your sh handles # comments correctly." + shsharp=true + spitshell=cat + echo " " + echo "Okay, let's see if #! works on this system..." + xcat=/bin/cat + test -f $xcat || xcat=/usr/bin/cat + echo "#!$xcat" >try + $eunicefix try + chmod +x try + ./try > today + if test -s today; then + echo "It does." + sharpbang='#!' + else + echo "#! $xcat" > try + $eunicefix try + chmod +x try + ./try > today + if test -s today; then + echo "It does." + sharpbang='#! ' + else + echo "It's just a comment." + sharpbang=': use ' + fi + fi +else + echo "Your sh doesn't grok # comments--I will strip them later on." + shsharp=false + cd .. + echo "exec grep -v '^[ ]*#'" >spitshell + chmod +x spitshell + $eunicefix spitshell + spitshell=`pwd`/spitshell + cd UU + echo "I presume that if # doesn't work, #! won't work either!" + sharpbang=': use ' +fi +rm -f try today + +: figure out how to guarantee sh startup +echo " " +echo "Checking out how to guarantee sh startup..." >&4 +case "$SYSTYPE" in +*bsd*|sys5*) startsh=$sharpbang"/$SYSTYPE/bin/sh";; +*) startsh=$sharpbang'/bin/sh';; +esac +echo "Let's see if '$startsh' works..." +cat >try <<EOSS +$startsh +set abc +test "$?abc" != 1 +EOSS + +chmod +x try +$eunicefix try +if ./try; then + echo "Yup, it does." +else +echo "Nope. You may have to fix up the shell scripts to make sure sh runs them." +fi +rm -f try + : script used to extract .SH files with variable substitutions -cat >extract <<'EOS' +cat >extract <<EOS +$startsh +EOS +cat >>extract <<'EOS' CONFIG=true echo "Doing variable substitutions on .SH files..." if test -f MANIFEST; then @@ -1014,7 +1092,7 @@ THIS PACKAGE SEEMS TO BE INCOMPLETE. You have the option of continuing the configuration process, despite the distinct possibility that your kit is damaged, by typing 'y'es. If you do, don't blame me if something goes wrong. I advise you to type 'n'o -and contact the author (doughera@lafcol.lafayette.edu). +and contact the author (lwall@sems.com). EOM echo $n "Continue? [n] $c" >&4 @@ -1155,7 +1233,10 @@ EOF : general instructions needman=true firsttime=true -user=`( (logname) 2>/dev/null || whoami) 2>&1` +user=`(logname) 2>/dev/null` +case "$user" in "") + user=`whoami 2>&1` ;; +esac if $contains "^$user\$" ../.config/instruct >/dev/null 2>&1; then firsttime=false echo " " @@ -1211,7 +1292,7 @@ Much effort has been expended to ensure that this shell script will run on any Unix system. If despite that it blows up on yours, your best bet is to edit Configure and run it again. If you can't run Configure for some reason, you'll have to generate a config.sh file by hand. Whatever problems you -have, let me (doughera@lafcol.lafayette.edu) know how I blew it. +have, let me (lwall@sems.com) know how I blew it. This installation script affects things in two ways: @@ -1232,74 +1313,6 @@ EOH esac fi -: see if sh knows # comments -echo " " -echo "Checking your sh to see if it knows about # comments..." >&4 -if `sh -c '#' >/dev/null 2>&1`; then - echo "Your sh handles # comments correctly." - shsharp=true - spitshell=cat - echo " " - echo "Okay, let's see if #! works on this system..." - xcat=/bin/cat - test -f $xcat || xcat=/usr/bin/cat - echo "#!$xcat" >try - $eunicefix try - chmod +x try - ./try > today - if test -s today; then - echo "It does." - sharpbang='#!' - else - echo "#! $xcat" > try - $eunicefix try - chmod +x try - ./try > today - if test -s today; then - echo "It does." - sharpbang='#! ' - else - echo "It's just a comment." - sharpbang=': use ' - fi - fi -else - echo "Your sh doesn't grok # comments--I will strip them later on." - shsharp=false - cd .. - echo "exec grep -v '^[ ]*#'" >spitshell - chmod +x spitshell - $eunicefix spitshell - spitshell=`pwd`/spitshell - cd UU - echo "I presume that if # doesn't work, #! won't work either!" - sharpbang=': use ' -fi -rm -f try today - -: figure out how to guarantee sh startup -echo " " -echo "Checking out how to guarantee sh startup..." >&4 -case "$SYSTYPE" in -*bsd*|sys5*) startsh=$sharpbang"/$SYSTYPE/bin/sh";; -*) startsh=$sharpbang'/bin/sh';; -esac -echo "Let's see if '$startsh' works..." -cat >try <<EOSS -$startsh -set abc -test "$?abc" != 1 -EOSS - -chmod +x try -$eunicefix try -if ./try; then - echo "Yup, it does." -else -echo "Nope. You may have to fix up the shell scripts to make sure sh runs them." -fi -rm -f try - : find out where common programs are echo " " echo "Locating common programs..." >&4 @@ -1555,7 +1568,7 @@ EOM cd hints; ls -C *.sh | $sed 's/\.sh/ /g' >&4 dflt='' : Half the following guesses are probably wrong... If you have better - : tests or hints, please send them to doughera@lafcol.lafayette.edu + : tests or hints, please send them to lwall@sems.com : The metaconfig authors would also appreciate a copy... $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix @@ -1628,6 +1641,9 @@ EOM dgux) osname=dgux osvers="$3" ;; + dynixptx*) osname=dynixptx + osvers="$3" + ;; freebsd) osname=freebsd osvers="$3" ;; genix) osname=genix ;; @@ -1898,6 +1914,8 @@ case "$ans" in none) osname='' ;; *) osname=`echo "$ans" | $sed -e 's/[ ][ ]*/_/g' | ./tr '[A-Z]' '[a-z]'`;; esac + + : who configured the system cf_time=`$date 2>&1` (logname > .temp) >/dev/null 2>&1 @@ -2308,13 +2326,13 @@ baserev=5.0 echo " " echo "Getting the current patchlevel..." >&4 if $test -r ../patchlevel.h;then - patchlevel=`awk '/PATCHLEVEL/ {print $3}' < ../patchlevel.h` - subversion=`awk '/SUBVERSION/ {print $3}' < ../patchlevel.h` + patchlevel=`awk '/PATCHLEVEL/ {print $3}' ../patchlevel.h` + subversion=`awk '/SUBVERSION/ {print $3}' ../patchlevel.h` else patchlevel=0 subversion=0 fi -echo "(You have $package $baserev PL$patchlevel sub$subversion.)" +echo "(You have $package $baserev patchlevel $patchlevel subversion $subversion.)" : set the prefixup variable, to restore leading tilda escape prefixup='case "$prefixexp" in @@ -2328,14 +2346,13 @@ eval $prefixit case "$archlib" in '') case "$privlib" in - '') - dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib` + '') dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib` set dflt eval $prefixup ;; *) version=`LC_ALL=C;export LC_ALL;\ - echo $baserev $patchlevel $subversion | \ - $awk '{print $1 + $2/1000.0 + $3/100000.0}'` + echo $baserev $patchlevel $subversion | \ + $awk '{print $1 + $2/1000.0 + $3/100000.0}'` dflt="$privlib/$archname/$version" ;; esac @@ -2551,6 +2568,7 @@ EOM fi else echo "I don't think setuid scripts are secure (no /dev/fd directory)." >&4 + echo "(That's for file descriptors, not floppy disks.)" val="$undef" fi set d_suidsafe @@ -2693,12 +2711,13 @@ if $test ! -d "$dflt/auto"; then fi cat <<EOM -In 5.001, Perl stored architecture-dependent library files in a library +In 5.001, Perl stored architecture-dependent library files in a directory with a name such as $privlib/$archname, and this directory contained files from the standard extensions and files from any additional extensions you might have added. Starting with version 5.002, all the architecture-dependent standard extensions -will go into $archlib, +will go into a version-specific directory such as +$archlib, while locally-added extensions will go into $sitearch. @@ -2720,6 +2739,34 @@ esac set d_oldarchlib eval $setvar + +case "$usestdio" in +false) dflt='n';; +*) dflt='y';; +esac +echo "$package can now use alternate file IO mechanisms to ANSI stdio." +echo "However these are experimental and may cause problems with some" +echo "extension modules" +rp="Use stdio as with previous versions?" +. ./myread +case "$ans" in +y|Y) + echo "Ok, doing things the stdio way" + val="$define" + ;; +*) + val="$undef" + ;; +esac +set d_perlstdio +eval $setvar +case "$d_perlstdio" in +$define) usestdio='true';; +*) usestdio='false';; +esac + + + : determine where public executables go echo " " set dflt bin bin @@ -3860,7 +3907,7 @@ case "$optimize" in esac $cat <<EOH -Some C compilers have problems with their optimizers, by default, $package +Some C compilers have problems with their optimizers. By default, $package compiles with the -O flag to use the optimizer. Alternately, you might want to use the symbolic debugger, which uses the -g flag (on traditional Unix systems). Either flag can be specified here. To use neither flag, specify @@ -4624,10 +4671,6 @@ $cat >try.c <<'EOP' #endif main() { char buf[64]; - /* This test must come first. <AlanBurlison@unn.unisys.com> */ - Gconvert(0.1, 8, 0, buf); - if (buf[0] != '.' || buf[1] != '1' || buf[2] != '\0') - exit(1); Gconvert(1.0, 8, 0, buf); if (buf[0] != '1' || buf[1] != '\0') exit(1); @@ -5653,8 +5696,9 @@ main() exit(0); } EOM + : Call the object file tmp-dyna.o in case dlext=o. if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && - mv dyna.o tmp-dyna.o > /dev/null 2>&1 && + mv dyna.o tmp-dyna.o > /dev/null 2>&1 && $ld $lddlflags -o dyna.$dlext tmp-dyna.o > /dev/null 2>&1 && $cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then xxx=`./fred` @@ -6549,6 +6593,57 @@ eval $inlibc set setsid d_setsid eval $inlibc +: see if sfio.h is available +set sfio.h i_sfio +eval $inhdr + + +: see if sfio is available +case "$i_sfio" in +$define) + val='' + set sfreserve val + eval $inlibc + ;; +*) + val="$undef" + ;; +esac +case "$val" in +$define) + case "$usesfio" in + true) dflt='y';; + *) dflt='n';; + esac + echo "$package can use sfio library, but this is experimental." + rp="You seem to have sfio available, do you want to try using it?" + . ./myread + case "$ans" in + y|Y) + ;; + *) + echo "Ok, avoiding sfio this time" + val="$undef" + ;; + esac + ;; +*) + case "$usesfio" in + false) ;; + *) + echo "Sorry cannot find sfio on this machine" + ;; + esac + ;; +esac +set d_sfio +eval $setvar +case "$d_sfio" in +$define) usesfio='true';; +*) usesfio='false';; +esac + + : see if shmctl exists set shmctl d_shmctl eval $inlibc @@ -6633,12 +6728,11 @@ fi set sigaction d_sigaction eval $inlibc - : see if sigsetjmp exists echo " " case "$d_sigsetjmp" in '') - $cat >set.c <<EOP + $cat >set.c <<'EOP' #include <setjmp.h> sigjmp_buf env; int set = 1; @@ -6651,25 +6745,26 @@ main() exit(1); } EOP - if $cc $ccflags $ldflags set.c -o set $libs >/dev/null 2>&1; then + if $cc $ccflags $ldflags -o set set.c $libs > /dev/null 2>&1 ; then if ./set >/dev/null 2>&1; then echo "POSIX sigsetjmp found." >&4 val="$define" else - $cat <<EOM + $cat >&4 <<EOM Uh-Oh! You have POSIX sigsetjmp and siglongjmp, but they do not work properly!! +I'll ignore them. EOM val="$undef" fi else - echo "Sigsetjmp not found." >&4 + echo "sigsetjmp not found." >&4 val="$undef" fi ;; *) val="$d_sigsetjmp" case "$d_sigsetjmp" in $define) echo "POSIX sigsetjmp found." >&4;; - $undef) echo "Sigsetjmp not found." >&4;; + $undef) echo "sigsetjmp not found." >&4;; esac ;; esac @@ -7462,9 +7557,9 @@ case "$voidflags" in '') $cat >try.c <<'EOCP' #if TRY & 1 -void main() { +void sub() { #else -main() { +sub() { #endif extern void moo(); /* function returning void */ void (*goo)(); /* ptr to func returning void */ @@ -7482,8 +7577,9 @@ main() { #endif exit(0); } +main() { sub(); } EOCP - if $cc -c -DTRY=$defvoidused try.c >.out 2>&1 ; then + if $cc $ccflags -c -DTRY=$defvoidused try.c >.out 2>&1 ; then voidflags=$defvoidused echo "It appears to support void to the level $package wants ($defvoidused)." if $contains warning .out >/dev/null 2>&1; then @@ -7492,16 +7588,16 @@ EOCP fi else echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 - if $cc -c -DTRY=1 try.c >/dev/null 2>&1 ; then + if $cc $ccflags -c -DTRY=1 try.c >/dev/null 2>&1; then echo "It supports 1..." - if $cc -c -DTRY=3 try.c >/dev/null 2>&1 ; then + if $cc $ccflags -c -DTRY=3 try.c >/dev/null 2>&1; then echo "It also supports 2..." - if $cc -c -DTRY=7 try.c >/dev/null 2>&1 ; then + if $cc $ccflags -c -DTRY=7 try.c >/dev/null 2>&1; then voidflags=7 echo "And it supports 4 but not 8 definitely." else echo "It doesn't support 4..." - if $cc -c -DTRY=11 try.c >/dev/null 2>&1 ; then + if $cc $ccflags -c -DTRY=11 try.c >/dev/null 2>&1; then voidflags=11 echo "But it supports 8." else @@ -7511,11 +7607,11 @@ echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 fi else echo "It does not support 2..." - if $cc -c -DTRY=13 try.c >/dev/null 2>&1 ; then + if $cc $ccflags -c -DTRY=13 try.c >/dev/null 2>&1; then voidflags=13 echo "But it supports 4 and 8." else - if $cc -c -DTRY=5 try.c >/dev/null 2>&1 ; then + if $cc $ccflags -c -DTRY=5 try.c >/dev/null 2>&1; then voidflags=5 echo "And it supports 4 but has not heard about 8." else @@ -8004,13 +8100,59 @@ $cat > signal.c <<'EOP' #include <sys/types.h> #include <signal.h> int main() { -#ifdef NSIG -printf("NSIG %d\n", NSIG); -#else -#ifdef _NSIG -printf("NSIG %d\n", _NSIG); + +/* Strange style to avoid deeply-nested #if/#else/#endif */ +#ifndef NSIG +# ifdef _NSIG +# define NSIG (_NSIG) +# endif +#endif + +#ifndef NSIG +# ifdef SIGMAX +# define NSIG (SIGMAX+1) +# endif +#endif + +#ifndef NSIG +# ifdef SIG_MAX +# define NSIG (SIG_MAX+1) +# endif +#endif + +#ifndef NSIG +# ifdef MAXSIG +# define NSIG (MAXSIG+1) +# endif #endif + +#ifndef NSIG +# ifdef MAX_SIG +# define NSIG (MAX_SIG+1) +# endif +#endif + +#ifndef NSIG +# ifdef SIGARRAYSIZE +# define NSIG (SIGARRAYSIZE+1) /* Not sure of the +1 */ +# endif +#endif + +#ifndef NSIG +# ifdef _sys_nsig +# define NSIG (_sys_nsig) /* Solaris 2.5 */ +# endif +#endif + +/* Default to some arbitrary number that's big enough to get most + of the common signals. +*/ +#ifndef NSIG +# define NSIG 50 #endif + +printf("NSIG %d\n", NSIG); + EOP echo $xxx | $tr ' ' '\012' | $sort | $uniq | $awk ' { @@ -8138,14 +8280,16 @@ main() printf("int\n"); else printf("long\n"); + exit(0); } EOM echo " " -if $cc $ccflags $ldflags -o ssize ssize.c $libs > /dev/null 2>&1 ; then +if $cc $ccflags $ldflags -o ssize ssize.c $libs > /dev/null 2>&1 && + ./ssize > /dev/null 2>&1 ; then ssizetype=`./ssize` echo "I'll be using $ssizetype for functions returning a byte count." >&4 else - echo "(I can't compile the test program--please enlighten me!)" + echo "(I can't compile and run the test program--please enlighten me!)" $cat <<EOM I need a type that is the same size as $sizetype, but is guaranteed to @@ -8684,6 +8828,10 @@ eval $inhdr set utime.h i_utime eval $inhdr +: see if this is a values.h system +set values.h i_values +eval $inhdr + : see if this is a vfork system case "$d_vfork" in "$define") @@ -8951,6 +9099,7 @@ awk='$awk' baserev='$baserev' bash='$bash' bin='$bin' +bin_sh='$bin_sh' binexp='$binexp' bison='$bison' byacc='$byacc' @@ -9064,6 +9213,7 @@ d_oldsock='$d_oldsock' d_open3='$d_open3' d_pathconf='$d_pathconf' d_pause='$d_pause' +d_perlstdio='$d_perlstdio' d_phostname='$d_phostname' d_pipe='$d_pipe' d_poll='$d_poll' @@ -9102,6 +9252,7 @@ d_setreuid='$d_setreuid' d_setrgid='$d_setrgid' d_setruid='$d_setruid' d_setsid='$d_setsid' +d_sfio='$d_sfio' d_shm='$d_shm' d_shmat='$d_shmat' d_shmatprototype='$d_shmatprototype' @@ -9209,6 +9360,7 @@ i_neterrno='$i_neterrno' i_niin='$i_niin' i_pwd='$i_pwd' i_rpcsvcdbm='$i_rpcsvcdbm' +i_sfio='$i_sfio' i_sgtty='$i_sgtty' i_stdarg='$i_stdarg' i_stddef='$i_stddef' @@ -9234,6 +9386,7 @@ i_termios='$i_termios' i_time='$i_time' i_unistd='$i_unistd' i_utime='$i_utime' +i_values='$i_values' i_varargs='$i_varargs' i_varhdr='$i_varhdr' i_vfork='$i_vfork' @@ -1,80 +1,80 @@ -Artistic The "Artistic License" -Changes Differences from previous versions. -Changes.Conf Recent changes in the Configure & build process -configure Crude emulation of GNU configure -Configure Portability tool -Copying The GNU General Public License -EXTERN.h Included before foreign .h files -INSTALL Detailed installation instructions. -INTERN.h Included before domestic .h files -MANIFEST This list of files -Makefile.SH A script that generates Makefile -README The Instructions -README.os2 Notes about OS/2 port -README.plan9 Notes about Plan9 port -README.vms Notes about VMS port -Todo The Wishlist -XSUB.h Include file for extension subroutines -av.c Array value code -av.h Array value header -cflags.SH A script that emits C compilation flags per file -config_H Sample config.h -config_h.SH Produces config.h -configpm Produces lib/Config.pm -cop.h Control operator header -cv.h Code value header -deb.c Debugging routines -doio.c I/O operations -doop.c Support code for various operations -dosish.h Some defines for MS/DOSish machines -dump.c Debugging output -eg/ADB An adb wrapper to put in your crash dir -eg/README Intro to example perl scripts -eg/changes A program to list recently changed files -eg/client A sample client -eg/down A program to do things to subdirectories -eg/dus A program to do du -s on non-mounted dirs -eg/findcp A find wrapper that implements a -cp switch -eg/findtar A find wrapper that pumps out a tar file -eg/g/gcp A program to do a global rcp -eg/g/gcp.man Manual page for gcp -eg/g/ged A program to do a global edit -eg/g/ghosts A sample /etc/ghosts file -eg/g/gsh A program to do a global rsh -eg/g/gsh.man Manual page for gsh -eg/muck A program to find missing make dependencies -eg/muck.man Manual page for muck -eg/myrup A program to find lightly loaded machines -eg/nih Script to insert #! workaround -eg/relink A program to change symbolic links -eg/rename A program to rename files -eg/rmfrom A program to feed doomed filenames to -eg/scan/scan_df Scan for filesystem anomalies -eg/scan/scan_last Scan for login anomalies -eg/scan/scan_messages Scan for console message anomalies -eg/scan/scan_passwd Scan for passwd file anomalies -eg/scan/scan_ps Scan for process anomalies -eg/scan/scan_sudo Scan for sudo anomalies -eg/scan/scan_suid Scan for setuid anomalies -eg/scan/scanner An anomaly reporter -eg/server A sample server -eg/shmkill A program to remove unused shared memory -eg/sysvipc/README Intro to Sys V IPC examples -eg/sysvipc/ipcmsg Example of SYS V IPC message queues -eg/sysvipc/ipcsem Example of Sys V IPC semaphores -eg/sysvipc/ipcshm Example of Sys V IPC shared memory -eg/travesty A program to print travesties of its input text -eg/unuc Un-uppercases an all-uppercase text -eg/uudecode A version of uudecode -eg/van/empty A program to empty the trashcan -eg/van/unvanish A program to undo what vanish does -eg/van/vanexp A program to expire vanished files -eg/van/vanish A program to put files in a trashcan -eg/who A sample who program -eg/wrapsuid A setuid script wrapper generator -emacs/cperl-mode.el An alternate perl-mode -embed.h Maps symbols to safer names -embed.pl Produces embed.h +Artistic The "Artistic License" +Changes Differences from previous versions. +Changes.Conf Recent changes in the Configure & build process +Configure Portability tool +Copying The GNU General Public License +EXTERN.h Included before foreign .h files +INSTALL Detailed installation instructions. +INTERN.h Included before domestic .h files +MANIFEST This list of files +Makefile.SH A script that generates Makefile +README The Instructions +README.os2 Notes about OS/2 port +README.plan9 Notes about Plan9 port +README.vms Notes about VMS port +Todo The Wishlist +XSUB.h Include file for extension subroutines +av.c Array value code +av.h Array value header +cflags.SH A script that emits C compilation flags per file +config_H Sample config.h +config_h.SH Produces config.h +configpm Produces lib/Config.pm +configure Crude emulation of GNU configure +cop.h Control operator header +cv.h Code value header +deb.c Debugging routines +doio.c I/O operations +doop.c Support code for various operations +dosish.h Some defines for MS/DOSish machines +dump.c Debugging output +eg/ADB An adb wrapper to put in your crash dir +eg/README Intro to example perl scripts +eg/changes A program to list recently changed files +eg/client A sample client +eg/down A program to do things to subdirectories +eg/dus A program to do du -s on non-mounted dirs +eg/findcp A find wrapper that implements a -cp switch +eg/findtar A find wrapper that pumps out a tar file +eg/g/gcp A program to do a global rcp +eg/g/gcp.man Manual page for gcp +eg/g/ged A program to do a global edit +eg/g/ghosts A sample /etc/ghosts file +eg/g/gsh A program to do a global rsh +eg/g/gsh.man Manual page for gsh +eg/muck A program to find missing make dependencies +eg/muck.man Manual page for muck +eg/myrup A program to find lightly loaded machines +eg/nih Script to insert #! workaround +eg/relink A program to change symbolic links +eg/rename A program to rename files +eg/rmfrom A program to feed doomed filenames to +eg/scan/scan_df Scan for filesystem anomalies +eg/scan/scan_last Scan for login anomalies +eg/scan/scan_messages Scan for console message anomalies +eg/scan/scan_passwd Scan for passwd file anomalies +eg/scan/scan_ps Scan for process anomalies +eg/scan/scan_sudo Scan for sudo anomalies +eg/scan/scan_suid Scan for setuid anomalies +eg/scan/scanner An anomaly reporter +eg/server A sample server +eg/shmkill A program to remove unused shared memory +eg/sysvipc/README Intro to Sys V IPC examples +eg/sysvipc/ipcmsg Example of SYS V IPC message queues +eg/sysvipc/ipcsem Example of Sys V IPC semaphores +eg/sysvipc/ipcshm Example of Sys V IPC shared memory +eg/travesty A program to print travesties of its input text +eg/unuc Un-uppercases an all-uppercase text +eg/uudecode A version of uudecode +eg/van/empty A program to empty the trashcan +eg/van/unvanish A program to undo what vanish does +eg/van/vanexp A program to expire vanished files +eg/van/vanish A program to put files in a trashcan +eg/who A sample who program +eg/wrapsuid A setuid script wrapper generator +emacs/cperl-mode.el An alternate perl-mode +embed.h Maps symbols to safer names +embed.pl Produces embed.h ext/DB_File/DB_File.pm Berkeley DB extension Perl module ext/DB_File/DB_File.xs Berkeley DB extension external subroutines ext/DB_File/DB_File_BS Berkeley DB extension mkbootstrap fodder @@ -89,7 +89,7 @@ ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation ext/DynaLoader/dl_hpux.xs HP-UX implementation ext/DynaLoader/dl_next.xs Next implementation ext/DynaLoader/dl_none.xs Stub implementation -ext/DynaLoader/dl_os2.xs OS/2 (non-a.out) implementation +ext/DynaLoader/dl_os2.xs OS/2 implementation ext/DynaLoader/dl_vms.xs VMS implementation ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files ext/Fcntl/Fcntl.pm Fcntl extension Perl module @@ -125,153 +125,153 @@ ext/ODBM_File/hints/sco.pl Hint for ODBM_File for named architecture ext/ODBM_File/hints/solaris.pl Hint for ODBM_File for named architecture ext/ODBM_File/hints/svr4.pl Hint for ODBM_File for named architecture ext/ODBM_File/typemap ODBM extension interface types +ext/Opcode/Makefile.PL Opcode extension makefile writer ext/Opcode/Opcode.pm Opcode extension Perl module ext/Opcode/Opcode.xs Opcode extension external subroutines ext/Opcode/Safe.pm Safe extension Perl module ext/Opcode/ops.pm "Pragma" form of Opcode extension Perl module -ext/Opcode/Makefile.PL Opcode extension makefile writer ext/POSIX/Makefile.PL POSIX extension makefile writer ext/POSIX/POSIX.pm POSIX extension Perl module ext/POSIX/POSIX.pod POSIX extension documentation ext/POSIX/POSIX.xs POSIX extension external subroutines +ext/POSIX/mkposixman.pl ??????? ext/POSIX/typemap POSIX extension interface types ext/SDBM_File/Makefile.PL SDBM extension makefile writer ext/SDBM_File/SDBM_File.pm SDBM extension Perl module ext/SDBM_File/SDBM_File.xs SDBM extension external subroutines -ext/SDBM_File/sdbm/CHANGES SDBM kit -ext/SDBM_File/sdbm/COMPARE SDBM kit -ext/SDBM_File/sdbm/Makefile.PL SDBM kit -ext/SDBM_File/sdbm/README SDBM kit -ext/SDBM_File/sdbm/README.too SDBM kit -ext/SDBM_File/sdbm/biblio SDBM kit -ext/SDBM_File/sdbm/dba.c SDBM kit -ext/SDBM_File/sdbm/dbd.c SDBM kit -ext/SDBM_File/sdbm/dbe.1 SDBM kit -ext/SDBM_File/sdbm/dbe.c SDBM kit -ext/SDBM_File/sdbm/dbm.c SDBM kit -ext/SDBM_File/sdbm/dbm.h SDBM kit -ext/SDBM_File/sdbm/dbu.c SDBM kit -ext/SDBM_File/sdbm/grind SDBM kit -ext/SDBM_File/sdbm/hash.c SDBM kit +ext/SDBM_File/sdbm/CHANGES SDBM kit +ext/SDBM_File/sdbm/COMPARE SDBM kit +ext/SDBM_File/sdbm/Makefile.PL SDBM kit +ext/SDBM_File/sdbm/README SDBM kit +ext/SDBM_File/sdbm/README.too SDBM kit +ext/SDBM_File/sdbm/biblio SDBM kit +ext/SDBM_File/sdbm/dba.c SDBM kit +ext/SDBM_File/sdbm/dbd.c SDBM kit +ext/SDBM_File/sdbm/dbe.1 SDBM kit +ext/SDBM_File/sdbm/dbe.c SDBM kit +ext/SDBM_File/sdbm/dbm.c SDBM kit +ext/SDBM_File/sdbm/dbm.h SDBM kit +ext/SDBM_File/sdbm/dbu.c SDBM kit +ext/SDBM_File/sdbm/grind SDBM kit +ext/SDBM_File/sdbm/hash.c SDBM kit ext/SDBM_File/sdbm/linux.patches SDBM kit ext/SDBM_File/sdbm/makefile.sdbm SDBM kit -ext/SDBM_File/sdbm/pair.c SDBM kit -ext/SDBM_File/sdbm/pair.h SDBM kit -ext/SDBM_File/sdbm/readme.ms SDBM kit -ext/SDBM_File/sdbm/sdbm.3 SDBM kit -ext/SDBM_File/sdbm/sdbm.c SDBM kit -ext/SDBM_File/sdbm/sdbm.h SDBM kit -ext/SDBM_File/sdbm/tune.h SDBM kit -ext/SDBM_File/sdbm/util.c SDBM kit +ext/SDBM_File/sdbm/pair.c SDBM kit +ext/SDBM_File/sdbm/pair.h SDBM kit +ext/SDBM_File/sdbm/readme.ms SDBM kit +ext/SDBM_File/sdbm/sdbm.3 SDBM kit +ext/SDBM_File/sdbm/sdbm.c SDBM kit +ext/SDBM_File/sdbm/sdbm.h SDBM kit +ext/SDBM_File/sdbm/tune.h SDBM kit +ext/SDBM_File/sdbm/util.c SDBM kit ext/SDBM_File/typemap SDBM extension interface types -ext/Socket/Makefile.PL Socket extension makefile writer -ext/Socket/Socket.pm Socket extension Perl module -ext/Socket/Socket.xs Socket extension external subroutines -ext/util/extliblist Used by extension Makefile.PL to make lib lists -ext/util/make_ext Used by Makefile to execute extension Makefiles -ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info -form.h Public declarations for the above -global.sym Symbols that need hiding when embedded -globals.c File to declare global symbols (for shared library) -gv.c Glob value code -gv.h Glob value header -h2pl/README How to turn .ph files into .pl files -h2pl/cbreak.pl cbreak routines using .ph -h2pl/cbreak2.pl cbreak routines using .pl -h2pl/eg/sizeof.ph Sample sizeof array initialization -h2pl/eg/sys/errno.pl Sample translated errno.pl -h2pl/eg/sys/ioctl.pl Sample translated ioctl.pl -h2pl/eg/sysexits.pl Sample translated sysexits.pl -h2pl/getioctlsizes Program to extract types from ioctl.h -h2pl/mksizes Program to make %sizeof array -h2pl/mkvars Program to make .pl from .ph files -h2pl/tcbreak cbreak test routine using .ph -h2pl/tcbreak2 cbreak test routine using .pl -handy.h Handy definitions -hints/3b1.sh Hints for named architecture -hints/3b1cc Hints for named architecture -hints/README.hints Notes about hints. -hints/aix.sh Hints for named architecture -hints/altos486.sh Hints for named architecture -hints/apollo.sh Hints for named architecture -hints/aux.sh Hints for named architecture -hints/bsdos.sh Hints for named architecture -hints/convexos.sh Hints for named architecture -hints/cxux.sh Hints for named architecture -hints/dec_osf.sh Hints for named architecture -hints/dgux.sh Hints for named architecture -hints/dnix.sh Hints for named architecture -hints/dynix.sh Hints for named architecture -hints/dynixptx.sh Hints for named architecture -hints/epix.sh Hints for named architecture -hints/esix4.sh Hints for named architecture -hints/fps.sh Hints for named architecture -hints/freebsd.sh Hints for named architecture -hints/genix.sh Hints for named architecture -hints/greenhills.sh Hints for named architecture -hints/hpux.sh Hints for named architecture -hints/i386.sh Hints for named architecture -hints/irix_4.sh Hints for named architecture -hints/irix_5.sh Hints for named architecture -hints/irix_6.sh Hints for named architecture -hints/irix_6_2.sh Hints for named architecture -hints/isc.sh Hints for named architecture -hints/isc_2.sh Hints for named architecture -hints/linux.sh Hints for named architecture -hints/machten.sh Hints for named architecture -hints/machten_2.sh Hints for named architecture -hints/mips.sh Hints for named architecture -hints/mpc.sh Hints for named architecture -hints/mpeix.sh Hints for named architecture -hints/ncr_tower.sh Hints for named architecture -hints/netbsd.sh Hints for named architecture -hints/next_3.sh Hints for named architecture -hints/next_3_0.sh Hints for named architecture -hints/next_3_2.sh Hints for named architecture -hints/next_3_3.sh Hints for named architecture -hints/next_4.sh Hints for named architecture -hints/opus.sh Hints for named architecture -hints/os2.sh Hints for named architecture -hints/powerux.sh Hints for named architecture -hints/sco.sh Hints for named architecture -hints/sco_2_3_0.sh Hints for named architecture -hints/sco_2_3_1.sh Hints for named architecture -hints/sco_2_3_2.sh Hints for named architecture -hints/sco_2_3_3.sh Hints for named architecture -hints/sco_2_3_4.sh Hints for named architecture -hints/solaris_2.sh Hints for named architecture -hints/stellar.sh Hints for named architecture -hints/sunos_4_0.sh Hints for named architecture -hints/sunos_4_1.sh Hints for named architecture -hints/svr4.sh Hints for named architecture -hints/ti1500.sh Hints for named architecture -hints/titanos.sh Hints for named architecture -hints/ultrix_4.sh Hints for named architecture -hints/unicos.sh Hints for named architecture -hints/unisysdynix.sh Hints for named architecture -hints/utekv.sh Hints for named architecture -hints/uts.sh Hints for named architecture -hv.c Hash value code -hv.h Hash value header -installman Perl script to install man pages for pods. -installperl Perl script to do "make install" dirty work -interp.sym Interpreter specific symbols to hide in a struct -keywords.h The keyword numbers -keywords.pl Program to write keywords.h -lib/AnyDBM_File.pm Perl module to emulate dbmopen -lib/AutoLoader.pm Autoloader base class -lib/AutoSplit.pm A module to split up autoload functions -lib/Benchmark.pm A module to time pieces of code and such -lib/Carp.pm Error message base class -lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) -lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm -lib/DirHandle.pm like FileHandle only for directories -lib/English.pm Readable aliases for short variables -lib/Env.pm Map environment into ordinary variables -lib/Exporter.pm Exporter base class -lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs -lib/ExtUtils/Install.pm Handles 'make install' on extensions -lib/ExtUtils/Liblist.pm Locates libraries +ext/Socket/Makefile.PL Socket extension makefile writer +ext/Socket/Socket.pm Socket extension Perl module +ext/Socket/Socket.xs Socket extension external subroutines +ext/util/extliblist Used by extension Makefile.PL to make lib lists +ext/util/make_ext Used by Makefile to execute extension Makefiles +ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info +form.h Public declarations for the above +global.sym Symbols that need hiding when embedded +globals.c File to declare global symbols (for shared library) +gv.c Glob value code +gv.h Glob value header +h2pl/README How to turn .ph files into .pl files +h2pl/cbreak.pl cbreak routines using .ph +h2pl/cbreak2.pl cbreak routines using .pl +h2pl/eg/sizeof.ph Sample sizeof array initialization +h2pl/eg/sys/errno.pl Sample translated errno.pl +h2pl/eg/sys/ioctl.pl Sample translated ioctl.pl +h2pl/eg/sysexits.pl Sample translated sysexits.pl +h2pl/getioctlsizes Program to extract types from ioctl.h +h2pl/mksizes Program to make %sizeof array +h2pl/mkvars Program to make .pl from .ph files +h2pl/tcbreak cbreak test routine using .ph +h2pl/tcbreak2 cbreak test routine using .pl +handy.h Handy definitions +hints/3b1.sh Hints for named architecture +hints/3b1cc Hints for named architecture +hints/README.NeXT Notes about NeXT hints. +hints/README.hints Notes about hints. +hints/aix.sh Hints for named architecture +hints/altos486.sh Hints for named architecture +hints/apollo.sh Hints for named architecture +hints/aux.sh Hints for named architecture +hints/bsdos.sh Hints for named architecture +hints/convexos.sh Hints for named architecture +hints/cxux.sh Hints for named architecture +hints/dec_osf.sh Hints for named architecture +hints/dgux.sh Hints for named architecture +hints/dnix.sh Hints for named architecture +hints/dynix.sh Hints for named architecture +hints/dynixptx.sh Hints for named architecture +hints/epix.sh Hints for named architecture +hints/esix4.sh Hints for named architecture +hints/fps.sh Hints for named architecture +hints/freebsd.sh Hints for named architecture +hints/genix.sh Hints for named architecture +hints/greenhills.sh Hints for named architecture +hints/hpux.sh Hints for named architecture +hints/i386.sh Hints for named architecture +hints/irix_4.sh Hints for named architecture +hints/irix_5.sh Hints for named architecture +hints/irix_6.sh Hints for named architecture +hints/irix_6_2.sh Hints for named architecture +hints/isc.sh Hints for named architecture +hints/isc_2.sh Hints for named architecture +hints/linux.sh Hints for named architecture +hints/machten.sh Hints for named architecture +hints/machten_2.sh Hints for named architecture +hints/mips.sh Hints for named architecture +hints/mpc.sh Hints for named architecture +hints/mpeix.sh Hints for named architecture +hints/ncr_tower.sh Hints for named architecture +hints/netbsd.sh Hints for named architecture +hints/next_3.sh Hints for named architecture +hints/next_3_0.sh Hints for named architecture +hints/next_4.sh Hints for named architecture +hints/opus.sh Hints for named architecture +hints/os2.sh Hints for named architecture +hints/powerux.sh Hints for named architecture +hints/sco.sh Hints for named architecture +hints/sco_2_3_0.sh Hints for named architecture +hints/sco_2_3_1.sh Hints for named architecture +hints/sco_2_3_2.sh Hints for named architecture +hints/sco_2_3_3.sh Hints for named architecture +hints/sco_2_3_4.sh Hints for named architecture +hints/solaris_2.sh Hints for named architecture +hints/stellar.sh Hints for named architecture +hints/sunos_4_0.sh Hints for named architecture +hints/sunos_4_1.sh Hints for named architecture +hints/svr4.sh Hints for named architecture +hints/ti1500.sh Hints for named architecture +hints/titanos.sh Hints for named architecture +hints/ultrix_4.sh Hints for named architecture +hints/unicos.sh Hints for named architecture +hints/unisysdynix.sh Hints for named architecture +hints/utekv.sh Hints for named architecture +hints/uts.sh Hints for named architecture +hv.c Hash value code +hv.h Hash value header +installman Perl script to install man pages for pods. +installperl Perl script to do "make install" dirty work +interp.sym Interpreter specific symbols to hide in a struct +keywords.h The keyword numbers +keywords.pl Program to write keywords.h +lib/AnyDBM_File.pm Perl module to emulate dbmopen +lib/AutoLoader.pm Autoloader base class +lib/AutoSplit.pm A module to split up autoload functions +lib/Benchmark.pm A module to time pieces of code and such +lib/Carp.pm Error message base class +lib/Cwd.pm Various cwd routines (getcwd, fastcwd, chdir) +lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm +lib/DirHandle.pm like FileHandle only for directories +lib/English.pm Readable aliases for short variables +lib/Env.pm Map environment into ordinary variables +lib/Exporter.pm Exporter base class +lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs +lib/ExtUtils/Install.pm Handles 'make install' on extensions +lib/ExtUtils/Liblist.pm Locates libraries lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2 lib/ExtUtils/MM_Unix.pm MakeMaker base class for Unix lib/ExtUtils/MM_VMS.pm MakeMaker methods for VMS. @@ -279,366 +279,409 @@ lib/ExtUtils/MakeMaker.pm Write Makefiles for extensions lib/ExtUtils/Manifest.pm Utilities to write MANIFEST files lib/ExtUtils/Mkbootstrap.pm Writes a bootstrap file (see MakeMaker) lib/ExtUtils/Mksymlists.pm Writes a linker options file for extensions -lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension +lib/ExtUtils/testlib.pm Fixes up @INC to use just-built extension lib/ExtUtils/typemap Extension interface types lib/ExtUtils/xsubpp External subroutine preprocessor -lib/Fatal.pm Make do-or-die equivalents of functions -lib/File/Basename.pm A module to emulate the basename program -lib/File/CheckTree.pm Perl module supporting wholesale file mode validation -lib/File/Copy.pm Emulation of cp command -lib/File/Find.pm Routines to do a find -lib/File/Path.pm A module to do things like `mkdir -p' and `rm -r' -lib/FileCache.pm Keep more files open than the system permits -lib/FindBin.pm Find name of currently executing program -lib/Getopt/Long.pm A module to fetch command options (GetOptions) -lib/Getopt/Std.pm A module to fetch command options (getopt, getopts) -lib/I18N/Collate.pm Routines to do strxfrm-based collation -lib/IPC/Open2.pm Open a two-ended pipe -lib/IPC/Open3.pm Open a three-ended pipe! -lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package -lib/Math/BigInt.pm An arbitrary precision integer arithmetic package -lib/Math/Complex.pm A Complex package -lib/Net/Ping.pm Ping methods -lib/Pod/Functions.pm used by pod/splitpod -lib/Pod/Text.pm Convert POD data to formatted ASCII text -lib/Search/Dict.pm A module to do binary search on dictionaries -lib/SelectSaver.pm A module to enforce proper select scoping -lib/SelfLoader.pm A module to load functions only on demand. -lib/Shell.pm A module to make AUTOLOADed system() calls -lib/Symbol.pm Symbol table manipulation routines -lib/Sys/Hostname.pm Hostname methods -lib/Sys/Syslog.pm Perl module supporting syslogging -lib/Term/Cap.pm Perl module supporting termcap usage -lib/Term/Complete.pm A command completion subroutine -lib/Term/ReadLine.pm Stub readline library -lib/Test/Harness.pm A test harness -lib/Text/Abbrev.pm An abbreviation table builder -lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter -lib/Text/Soundex.pm Perl module to implement Soundex -lib/Text/Tabs.pm Do expand and unexpand -lib/Text/Wrap.pm Paragraph formatter -lib/Tie/Hash.pm Base class for tied hashes -lib/Tie/Scalar.pm Base class for tied scalars -lib/Tie/SubstrHash.pm Compact hash for known key, value and table size -lib/Time/Local.pm Reverse translation of localtime, gmtime -lib/abbrev.pl An abbreviation table builder -lib/assert.pl assertion and panic with stack trace -lib/bigfloat.pl An arbitrary precision floating point package -lib/bigint.pl An arbitrary precision integer arithmetic package -lib/bigrat.pl An arbitrary precision rational arithmetic package -lib/cacheout.pl Manages output filehandles when you need too many -lib/chat2.inter A chat2 with interaction -lib/chat2.pl Randal's famous expect-ish routines -lib/complete.pl A command completion subroutine -lib/ctime.pl A ctime workalike -lib/diagnostics.pm Print verbose diagnostics -lib/dotsh.pl Code to "dot" in a shell script -lib/dumpvar.pl A variable dumper -lib/exceptions.pl catch and throw routines -lib/fastcwd.pl a faster but more dangerous getcwd -lib/find.pl A find emulator--used by find2perl -lib/finddepth.pl A depth-first find emulator--used by find2perl -lib/flush.pl Routines to do single flush -lib/ftp.pl FTP code -lib/getcwd.pl A getcwd() emulator -lib/getopt.pl Perl library supporting option parsing -lib/getopts.pl Perl library supporting option parsing -lib/hostname.pl Old hostname code -lib/importenv.pl Perl routine to get environment into variables -lib/integer.pm For "use integer" -lib/less.pm For "use less" -lib/lib.pm For "use lib" -lib/look.pl A "look" equivalent -lib/newgetopt.pl A perl library supporting long option parsing -lib/open2.pl Open a two-ended pipe -lib/open3.pl Open a three-ended pipe -lib/overload.pm Module for overloading perl operators. -lib/perl5db.pl Perl debugging routines -lib/pwd.pl Routines to keep track of PWD environment variable -lib/shellwords.pl Perl library to split into words with shell quoting -lib/sigtrap.pm For trapping an abort and giving traceback -lib/splain Standalone program to print verbose diagnostics. -lib/stat.pl Perl library supporting stat function -lib/strict.pm For "use strict" -lib/subs.pm Declare overriding subs -lib/syslog.pl Perl library supporting syslogging -lib/tainted.pl Old code for tainting -lib/termcap.pl Perl library supporting termcap usage -lib/timelocal.pl Perl library supporting inverse of localtime, gmtime -lib/validate.pl Perl library supporting wholesale file mode validation -lib/vars.pm Declare pseudo-imported global variables -makeaperl.SH perl script that produces a new perl binary -makedepend.SH Precursor to makedepend -makedir.SH Precursor to makedir -malloc.c A version of malloc you might not want -mg.c Magic code -mg.h Magic header -minimod.pl Writes lib/ExtUtils/Miniperl.pm -miniperlmain.c Basic perl w/o dynamic loading or extensions -mv-if-diff Script to mv a file if it changed -myconfig Prints summary of the current configuration -op.c Opcode syntax tree code -op.h Opcode syntax tree header -opcode.h Automatically generated opcode header -opcode.pl Opcode header generatore -os2/diff.configure Patches to Configure -os2/dl_os2.c Addon for dl_open -os2/dlfcn.h Addon for dl_open -os2/Makefile.SHs Shared library generation for OS/2 -os2/POSIX.mkfifo POSIX.xs patch. -os2/README.old previous OS/2 port info, partially relevant. -os2/notes Notes for perl maintainer -os2/os2.c Additional code for OS/2 -os2/os2ish.h Header for OS/2 -os2/perl2cmd.pl Corrects installed binaries under OS/2 -patchlevel.h The current patch level of perl -perl.c main() -perl.h Global declarations -perl_exp.SH Creates list of exported symbols for AIX. -perlsh A poor man's perl shell -perly.c A byacc'ed perly.y -perly.c.diff Fixup perly.c to allow recursion -perly.fixer A program to remove yacc stack limitations -perly.h The header file for perly.c -perly.y Yacc grammar for perl -plan9/aperl Shell to make Perl error messages Acme-friendly -plan9/arpa/inet.h Plan9 port: replacement C header file -plan9/buildinfo Plan9 port: configuration information -plan9/config.plan9 Plan9 port: config.h template -plan9/exclude Plan9 port: tests to skip -plan9/fndvers Plan9 port: update Perl version in config.plan9 -plan9/genconfig.pl Plan9 port: generate config.sh -plan9/mkfile Plan9 port: Mk driver for build -plan9/myconfig.plan9 Plan9 port: script to print config summary -plan9/perlplan9.doc Plan9 port: Plan9-specific formatted documentation -plan9/perlplan9.pod Plan9 port: Plan9-specific pod documentation -plan9/plan9.c Plan9 port: Plan9-specific C routines -plan9/plan9ish.h Plan9 port: Plan9-specific C header file -plan9/setup.rc Plan9 port: script for easy build+install -pod/Makefile Make pods into something else -pod/buildtoc generate perltoc.pod -pod/perl.pod Top level perl man page -pod/perlbook.pod Book info -pod/perlbot.pod Object-oriented Bag o' Tricks -pod/perlcall.pod Callback info -pod/perldata.pod Data structure info -pod/perldebug.pod Debugger info -pod/perldiag.pod Diagnostic info -pod/perldsc.pod Data Structures Cookbook -pod/perlembed.pod Embedding info -pod/perlform.pod Format info -pod/perlfunc.pod Function info -pod/perlguts.pod Internals info -pod/perlipc.pod IPC info -pod/perllol.pod How to use lists of lists. -pod/perlmod.pod Module info -pod/perlobj.pod Object info -pod/perlop.pod Operator info -pod/perlovl.pod Overloading info -pod/perlpod.pod Pod info -pod/perlre.pod Regular expression info -pod/perlref.pod References info -pod/perlrun.pod Execution info -pod/perlsec.pod Security info -pod/perlstyle.pod Style info -pod/perlsub.pod Subroutine info -pod/perlsyn.pod Syntax info -pod/perltie.pod Tieing an object class into a simple variable -pod/perltoc.pod Table of Contents info -pod/perltrap.pod Trap info -pod/perlvar.pod Variable info -pod/perlxs.pod XS api info -pod/perlxstut.pod XS tutorial -pod/pod2html.PL Precursor for translator to turn pod into HTML -pod/pod2latex.PL Precursor for translator to turn pod into LaTeX -pod/pod2man.PL Precursor for translator to turn pod into manpage -pod/pod2text.PL Precursor for translator to turn pod into text -pod/roffitall troff the whole man page set -pod/splitman Splits perlfunc into multiple man pages -pod/splitpod Splits perlfunc into multiple pod pages -pp.c Push/Pop code -pp.h Push/Pop code defs -pp_ctl.c Push/Pop code for control flow -pp_hot.c Push/Pop code for heavily used opcodes -pp_sys.c Push/Pop code for system interaction -proto.h Prototypes -regcomp.c Regular expression compiler -regcomp.h Private declarations for above -regexec.c Regular expression evaluator -regexp.h Public declarations for the above -run.c The interpreter loop -scope.c Scope entry and exit code -scope.h Scope entry and exit header -sv.c Scalar value code -sv.h Scalar value header -t/README Instructions for regression tests -t/TEST The regression tester -t/base/cond.t See if conditionals work -t/base/if.t See if if works -t/base/lex.t See if lexical items work -t/base/pat.t See if pattern matching works -t/base/term.t See if various terms work -t/cmd/elsif.t See if else-if works -t/cmd/for.t See if for loops work -t/cmd/mod.t See if statement modifiers work -t/cmd/subval.t See if subroutine values work -t/cmd/switch.t See if switch optimizations work -t/cmd/while.t See if while loops work -t/comp/cmdopt.t See if command optimization works -t/comp/cpp.aux main file for cpp.t -t/comp/cpp.t See if C preprocessor works -t/comp/decl.t See if declarations work -t/comp/multiline.t See if multiline strings work -t/comp/package.t See if packages work -t/comp/script.t See if script invokation works -t/comp/term.t See if more terms work -t/harness Finer diagnostics from test suite -t/io/argv.t See if ARGV stuff works -t/io/dup.t See if >& works right -t/io/fs.t See if directory manipulations work -t/io/inplace.t See if inplace editing works -t/io/pipe.t See if secure pipes work -t/io/print.t See if print commands work -t/io/tell.t See if file seeking works -t/lib/anydbm.t See if AnyDBM_File works -t/lib/bigint.t See if bigint.pl works -t/lib/bigintpm.t See if BigInt.pm works -t/lib/db-btree.t See if DB_File works -t/lib/db-hash.t See if DB_File works -t/lib/db-recno.t See if DB_File works -t/lib/dirhand.t See if DirHandle works -t/lib/english.t See if English works -t/lib/filehand.t See if FileHandle works -t/lib/io_dup.t See if dup()-related methods from IO work -t/lib/io_pipe.t See if pipe()-related methods from IO work -t/lib/io_sock.t See if INET socket-related methods from IO work -t/lib/io_tell.t See if seek()/tell()-related methods from IO work -t/lib/io_udp.t See if UDP socket-related methods from IO work -t/lib/io_xs.t See if XSUB methods from IO work -t/lib/gdbm.t See if GDBM_File works -t/lib/ndbm.t See if NDBM_File works -t/lib/odbm.t See if ODBM_File works -t/lib/opcode.t See if Opcode works -t/lib/ops.t See if Opcode works -t/lib/posix.t See if POSIX works -t/lib/safe1.t See if Safe works -t/lib/safe2.t See if Safe works -t/lib/sdbm.t See if SDBM_File works -t/lib/socket.t See if Socket works -t/lib/soundex.t See if Soundex works -t/op/append.t See if . works -t/op/array.t See if array operations work -t/op/auto.t See if autoincrement et all work -t/op/chop.t See if chop works -t/op/cond.t See if conditional expressions work -t/op/delete.t See if delete works -t/op/do.t See if subroutines work -t/op/each.t See if associative iterators work -t/op/eval.t See if eval operator works -t/op/exec.t See if exec and system work -t/op/exp.t See if math functions work -t/op/flip.t See if range operator works -t/op/fork.t See if fork works -t/op/glob.t See if <*> works -t/op/goto.t See if goto works -t/op/groups.t See if $( works -t/op/index.t See if index works -t/op/int.t See if int works -t/op/join.t See if join works -t/op/list.t See if array lists work -t/op/local.t See if local works -t/op/magic.t See if magic variables work -t/op/misc.t See if miscellaneous bugs have been fixed -t/op/mkdir.t See if mkdir works -t/op/my.t See if lexical scoping works -t/op/oct.t See if oct and hex work -t/op/ord.t See if ord works -t/op/overload.t See if operator overload works -t/op/pack.t See if pack and unpack work -t/op/pat.t See if esoteric patterns work -t/op/push.t See if push and pop work -t/op/quotemeta.t See if quotemeta works -t/op/rand.t See if rand works -t/op/range.t See if .. works -t/op/re_tests Input file for op.regexp -t/op/read.t See if read() works -t/op/readdir.t See if readdir() works -t/op/ref.t See if refs and objects work -t/op/regexp.t See if regular expressions work -t/op/repeat.t See if x operator works -t/op/sleep.t See if sleep works -t/op/sort.t See if sort works -t/op/split.t See if split works -t/op/sprintf.t See if sprintf works -t/op/stat.t See if stat works -t/op/study.t See if study works -t/op/subst.t See if substitution works -t/op/substr.t See if substr works -t/op/tie.t See if tie/untie functions work -t/op/time.t See if time functions work -t/op/undef.t See if undef works -t/op/unshift.t See if unshift works -t/op/vec.t See if vectors work -t/op/write.t See if write works -t/re_tests Regular expressions for regexp.t -taint.c Tainting code -toke.c The tokener -universal.c The default UNIVERSAL package methods -unixish.h Defines that are assumed on Unix -util.c Utility routines -util.h Public declarations for the above -utils/Makefile Extract the utility scripts. -utils/c2ph.PL program to translate dbx stabs to perl -utils/h2ph.PL A thing to turn C .h files into perl .ph files -utils/h2xs.PL Program to make .xs files from C header files -utils/perlbug.PL A simple tool to submit a bug report -utils/perldoc.PL A simple tool to find & display perl's documentation -utils/pl2pm.PL A pl to pm translator -vms/Makefile VMS port -vms/config.vms default config.h for VMS -vms/descrip.mms MM[SK] description file for build -vms/ext/Filespec.pm VMS-Unix file syntax interconversion +lib/Fatal.pm Make do-or-die equivalents of functions +lib/File/Basename.pm A module to emulate the basename program +lib/File/CheckTree.pm Perl module supporting wholesale file mode validation +lib/File/Copy.pm Emulation of cp command +lib/File/Find.pm Routines to do a find +lib/File/Path.pm A module to do things like `mkdir -p' and `rm -r' +lib/FileCache.pm Keep more files open than the system permits +lib/FindBin.pm Find name of currently executing program +lib/Getopt/Long.pm A module to fetch command options (GetOptions) +lib/Getopt/Std.pm A module to fetch command options (getopt, getopts) +lib/I18N/Collate.pm Routines to do strxfrm-based collation +lib/IPC/Open2.pm Open a two-ended pipe +lib/IPC/Open3.pm Open a three-ended pipe! +lib/Math/BigFloat.pm An arbitrary precision floating-point arithmetic package +lib/Math/BigInt.pm An arbitrary precision integer arithmetic package +lib/Math/Complex.pm A Complex package +lib/Net/Ping.pm Ping methods +lib/Pod/Functions.pm used by pod/splitpod +lib/Pod/Text.pm Convert POD data to formatted ASCII text +lib/Search/Dict.pm A module to do binary search on dictionaries +lib/SelectSaver.pm A module to enforce proper select scoping +lib/SelfLoader.pm A module to load functions only on demand. +lib/Shell.pm A module to make AUTOLOADed system() calls +lib/Symbol.pm Symbol table manipulation routines +lib/Sys/Hostname.pm Hostname methods +lib/Sys/Syslog.pm Perl module supporting syslogging +lib/Term/Cap.pm Perl module supporting termcap usage +lib/Term/Complete.pm A command completion subroutine +lib/Term/ReadLine.pm Stub readline library +lib/Test/Harness.pm A test harness +lib/Text/Abbrev.pm An abbreviation table builder +lib/Text/ParseWords.pm Perl module to split words on arbitrary delimiter +lib/Text/Soundex.pm Perl module to implement Soundex +lib/Text/Tabs.pm Do expand and unexpand +lib/Text/Wrap.pm Paragraph formatter +lib/Tie/Hash.pm Base class for tied hashes +lib/Tie/Scalar.pm Base class for tied scalars +lib/Tie/SubstrHash.pm Compact hash for known key, value and table size +lib/Time/Local.pm Reverse translation of localtime, gmtime +lib/abbrev.pl An abbreviation table builder +lib/assert.pl assertion and panic with stack trace +lib/bigfloat.pl An arbitrary precision floating point package +lib/bigint.pl An arbitrary precision integer arithmetic package +lib/bigrat.pl An arbitrary precision rational arithmetic package +lib/cacheout.pl Manages output filehandles when you need too many +lib/chat2.inter A chat2 with interaction +lib/chat2.pl Randal's famous expect-ish routines +lib/complete.pl A command completion subroutine +lib/ctime.pl A ctime workalike +lib/diagnostics.pm Print verbose diagnostics +lib/dotsh.pl Code to "dot" in a shell script +lib/dumpvar.pl A variable dumper +lib/exceptions.pl catch and throw routines +lib/fastcwd.pl a faster but more dangerous getcwd +lib/find.pl A find emulator--used by find2perl +lib/finddepth.pl A depth-first find emulator--used by find2perl +lib/flush.pl Routines to do single flush +lib/ftp.pl FTP code +lib/getcwd.pl A getcwd() emulator +lib/getopt.pl Perl library supporting option parsing +lib/getopts.pl Perl library supporting option parsing +lib/hostname.pl Old hostname code +lib/importenv.pl Perl routine to get environment into variables +lib/integer.pm For "use integer" +lib/less.pm For "use less" +lib/lib.pm For "use lib" +lib/look.pl A "look" equivalent +lib/newgetopt.pl A perl library supporting long option parsing +lib/open2.pl Open a two-ended pipe +lib/open3.pl Open a three-ended pipe +lib/overload.pm Module for overloading perl operators. +lib/perl5db.pl Perl debugging routines +lib/pwd.pl Routines to keep track of PWD environment variable +lib/shellwords.pl Perl library to split into words with shell quoting +lib/sigtrap.pm For trapping an abort and giving traceback +lib/splain Standalone program to print verbose diagnostics. +lib/stat.pl Perl library supporting stat function +lib/strict.pm For "use strict" +lib/subs.pm Declare overriding subs +lib/syslog.pl Perl library supporting syslogging +lib/tainted.pl Old code for tainting +lib/termcap.pl Perl library supporting termcap usage +lib/timelocal.pl Perl library supporting inverse of localtime, gmtime +lib/validate.pl Perl library supporting wholesale file mode validation +lib/vars.pm Declare pseudo-imported global variables +makeaperl.SH perl script that produces a new perl binary +makedepend.SH Precursor to makedepend +makedir.SH Precursor to makedir +malloc.c A version of malloc you might not want +mg.c Magic code +mg.h Magic header +minimod.pl Writes lib/ExtUtils/Miniperl.pm +miniperlmain.c Basic perl w/o dynamic loading or extensions +mv-if-diff Script to mv a file if it changed +myconfig Prints summary of the current configuration +nostdio.h Cause compile error on stdio calls +op.c Opcode syntax tree code +op.h Opcode syntax tree header +opcode.h Automatically generated opcode header +opcode.pl Opcode header generatore +os2/Makefile.SHs Shared library generation for OS/2 +os2/OS2/ExtAttr/Changes EA access module +os2/OS2/ExtAttr/ExtAttr.pm EA access module +os2/OS2/ExtAttr/ExtAttr.xs EA access module +os2/OS2/ExtAttr/MANIFEST EA access module +os2/OS2/ExtAttr/Makefile.PL EA access module +os2/OS2/ExtAttr/myea.h EA access module +os2/OS2/ExtAttr/t/os2_ea.t EA access module +os2/OS2/ExtAttr/typemap EA access module +os2/OS2/PrfDB/Changes System database access module +os2/OS2/PrfDB/MANIFEST System database access module +os2/OS2/PrfDB/Makefile.PL System database access module +os2/OS2/PrfDB/PrfDB.pm System database access module +os2/OS2/PrfDB/PrfDB.xs System database access module +os2/OS2/PrfDB/t/os2_prfdb.t System database access module +os2/OS2/PrfDB/typemap System database access module +os2/OS2/Process/MANIFEST system() constants in a module +os2/OS2/Process/Makefile.PL system() constants in a module +os2/OS2/Process/Process.pm system() constants in a module +os2/OS2/Process/Process.xs system() constants in a module +os2/OS2/REXX/Changes DLL access module +os2/OS2/REXX/MANIFEST DLL access module +os2/OS2/REXX/Makefile.PL DLL access module +os2/OS2/REXX/REXX.pm DLL access module +os2/OS2/REXX/REXX.xs DLL access module +os2/OS2/REXX/t/rx_cmprt.t DLL access module +os2/OS2/REXX/t/rx_dllld.t DLL access module +os2/OS2/REXX/t/rx_objcall.t DLL access module +os2/OS2/REXX/t/rx_sql.test DLL access module +os2/OS2/REXX/t/rx_tiesql.test DLL access module +os2/OS2/REXX/t/rx_tievar.t DLL access module +os2/OS2/REXX/t/rx_tieydb.t DLL access module +os2/OS2/REXX/t/rx_varset.t DLL access module +os2/OS2/REXX/t/rx_vrexx.t DLL access module +os2/POSIX.mkfifo POSIX.xs patch. +os2/README OS/2 port info +os2/diff.configure Patches to Configure +os2/dl_os2.c Addon for dl_open +os2/dlfcn.h Addon for dl_open +os2/notes Notes about OS/2 +os2/os2.c Additional code for OS/2 +os2/os2ish.h Header for OS/2 +os2/perl2cmd.pl Corrects installed binaries under OS/2 +patchlevel.h The current patch level of perl +perl.c main() +perl.h Global declarations +perl_exp.SH Creates list of exported symbols for AIX. +perlio.c C code for PerlIO abstraction. +perlio.h Interface to PerlIO abstraction. +perlsh A poor man's perl shell +perlsfio.h Prototype sfio mapping for PerlIO +perlsdio.h Fake stdio using perlio +perly.c A byacc'ed perly.y +perly.c.diff Fixup perly.c to allow recursion +perly.fixer A program to remove yacc stack limitations +perly.h The header file for perly.c +perly.y Yacc grammar for perl +plan9/aperl Shell to make Perl error messages Acme-friendly +plan9/arpa/inet.h Plan9 port: replacement C header file +plan9/buildinfo Plan9 port: configuration information +plan9/config.plan9 Plan9 port: config.h template +plan9/exclude Plan9 port: tests to skip +plan9/fndvers Plan9 port: update Perl version in config.plan9 +plan9/genconfig.pl Plan9 port: generate config.sh +plan9/mkfile Plan9 port: Mk driver for build +plan9/myconfig.plan9 Plan9 port: script to print config summary +plan9/perlplan9.doc Plan9 port: Plan9-specific formatted documentation +plan9/perlplan9.pod Plan9 port: Plan9-specific pod documentation +plan9/plan9.c Plan9 port: Plan9-specific C routines +plan9/plan9ish.h Plan9 port: Plan9-specific C header file +plan9/setup.rc Plan9 port: script for easy build+install +plan9/versnum ???? +pod/Makefile Make pods into something else +pod/Makefile.PL Maybe generate above Makefile ?? +pod/buildtoc generate perltoc.pod +pod/perl.pod Top level perl man page +pod/perlapio.pod IO API info +pod/perlbook.pod Book info +pod/perlbot.pod Object-oriented Bag o' Tricks +pod/perlcall.pod Callback info +pod/perldata.pod Data structure info +pod/perldebug.pod Debugger info +pod/perldiag.pod Diagnostic info +pod/perldsc.pod Data Structures Cookbook +pod/perlembed.pod Embedding info +pod/perlform.pod Format info +pod/perlfunc.pod Function info +pod/perlguts.pod Internals info +pod/perlipc.pod IPC info +pod/perllol.pod How to use lists of lists. +pod/perlmod.pod Module info +pod/perlobj.pod Object info +pod/perlop.pod Operator info +pod/perlovl.pod Overloading info +pod/perlpod.pod Pod info +pod/perlre.pod Regular expression info +pod/perlref.pod References info +pod/perlrun.pod Execution info +pod/perlsec.pod Security info +pod/perlstyle.pod Style info +pod/perlsub.pod Subroutine info +pod/perlsyn.pod Syntax info +pod/perltie.pod Tieing an object class into a simple variable +pod/perltoc.pod Table of Contents info +pod/perltrap.pod Trap info +pod/perlvar.pod Variable info +pod/perlxs.pod XS api info +pod/perlxstut.pod XS tutorial +pod/pod2html.PL Precursor for translator to turn pod into HTML +pod/pod2latex.PL Precursor for translator to turn pod into LaTeX +pod/pod2man.PL Precursor for translator to turn pod into manpage +pod/pod2text.PL Precursor for translator to turn pod into text +pod/roffitall troff the whole man page set +pod/splitman Splits perlfunc into multiple man pages +pod/splitpod Splits perlfunc into multiple pod pages +pp.c Push/Pop code +pp.h Push/Pop code defs +pp_ctl.c Push/Pop code for control flow +pp_hot.c Push/Pop code for heavily used opcodes +pp_sys.c Push/Pop code for system interaction +proto.h Prototypes +regcomp.c Regular expression compiler +regcomp.h Private declarations for above +regexec.c Regular expression evaluator +regexp.h Public declarations for the above +run.c The interpreter loop +scope.c Scope entry and exit code +scope.h Scope entry and exit header +sv.c Scalar value code +sv.h Scalar value header +t/README Instructions for regression tests +t/TEST The regression tester +t/base/cond.t See if conditionals work +t/base/if.t See if if works +t/base/lex.t See if lexical items work +t/base/pat.t See if pattern matching works +t/base/term.t See if various terms work +t/cmd/elsif.t See if else-if works +t/cmd/for.t See if for loops work +t/cmd/mod.t See if statement modifiers work +t/cmd/subval.t See if subroutine values work +t/cmd/switch.t See if switch optimizations work +t/cmd/while.t See if while loops work +t/comp/cmdopt.t See if command optimization works +t/comp/cpp.aux main file for cpp.t +t/comp/cpp.t See if C preprocessor works +t/comp/decl.t See if declarations work +t/comp/multiline.t See if multiline strings work +t/comp/package.t See if packages work +t/comp/redef.t See if we get correct warnings on redefined subs +t/comp/script.t See if script invokation works +t/comp/term.t See if more terms work +t/harness Finer diagnostics from test suite +t/io/argv.t See if ARGV stuff works +t/io/dup.t See if >& works right +t/io/fs.t See if directory manipulations work +t/io/inplace.t See if inplace editing works +t/io/pipe.t See if secure pipes work +t/io/print.t See if print commands work +t/io/tell.t See if file seeking works +t/lib/anydbm.t See if AnyDBM_File works +t/lib/bigint.t See if bigint.pl works +t/lib/bigintpm.t See if BigInt.pm works +t/lib/db-btree.t See if DB_File works +t/lib/db-hash.t See if DB_File works +t/lib/db-recno.t See if DB_File works +t/lib/dirhand.t See if DirHandle works +t/lib/english.t See if English works +t/lib/filehand.t See if FileHandle works +t/lib/gdbm.t See if GDBM_File works +t/lib/io_dup.t See if dup()-related methods from IO work +t/lib/io_pipe.t See if pipe()-related methods from IO work +t/lib/io_sock.t See if INET socket-related methods from IO work +t/lib/io_tell.t See if seek()/tell()-related methods from IO work +t/lib/io_udp.t See if UDP socket-related methods from IO work +t/lib/io_xs.t See if XSUB methods from IO work +t/lib/ndbm.t See if NDBM_File works +t/lib/odbm.t See if ODBM_File works +t/lib/opcode.t See if Opcode works +t/lib/ops.t See if Opcode works +t/lib/posix.t See if POSIX works +t/lib/safe1.t See if Safe works +t/lib/safe2.t See if Safe works +t/lib/sdbm.t See if SDBM_File works +t/lib/socket.t See if Socket works +t/lib/soundex.t See if Soundex works +t/op/append.t See if . works +t/op/array.t See if array operations work +t/op/auto.t See if autoincrement et all work +t/op/chop.t See if chop works +t/op/cond.t See if conditional expressions work +t/op/delete.t See if delete works +t/op/do.t See if subroutines work +t/op/each.t See if associative iterators work +t/op/eval.t See if eval operator works +t/op/exec.t See if exec and system work +t/op/exp.t See if math functions work +t/op/flip.t See if range operator works +t/op/fork.t See if fork works +t/op/glob.t See if <*> works +t/op/goto.t See if goto works +t/op/groups.t See if $( works +t/op/inc.t See if inc/dec of integers near 32 bit limit work +t/op/index.t See if index works +t/op/int.t See if int works +t/op/join.t See if join works +t/op/list.t See if array lists work +t/op/local.t See if local works +t/op/magic.t See if magic variables work +t/op/misc.t See if miscellaneous bugs have been fixed +t/op/mkdir.t See if mkdir works +t/op/my.t See if lexical scoping works +t/op/oct.t See if oct and hex work +t/op/ord.t See if ord works +t/op/overload.t See if operator overload works +t/op/pack.t See if pack and unpack work +t/op/pat.t See if esoteric patterns work +t/op/push.t See if push and pop work +t/op/quotemeta.t See if quotemeta works +t/op/rand.t See if rand works +t/op/range.t See if .. works +t/op/re_tests Input file for op.regexp +t/op/read.t See if read() works +t/op/readdir.t See if readdir() works +t/op/ref.t See if refs and objects work +t/op/regexp.t See if regular expressions work +t/op/repeat.t See if x operator works +t/op/sleep.t See if sleep works +t/op/sort.t See if sort works +t/op/split.t See if split works +t/op/sprintf.t See if sprintf works +t/op/stat.t See if stat works +t/op/study.t See if study works +t/op/subst.t See if substitution works +t/op/substr.t See if substr works +t/op/tie.t See if tie/untie functions work +t/op/time.t See if time functions work +t/op/undef.t See if undef works +t/op/unshift.t See if unshift works +t/op/vec.t See if vectors work +t/op/write.t See if write works +t/re_tests Regular expressions for regexp.t +taint.c Tainting code +toke.c The tokener +universal.c The default UNIVERSAL package methods +unixish.h Defines that are assumed on Unix +util.c Utility routines +util.h Public declarations for the above +utils/Makefile Extract the utility scripts. +utils/c2ph.PL program to translate dbx stabs to perl +utils/h2ph.PL A thing to turn C .h files into perl .ph files +utils/h2xs.PL Program to make .xs files from C header files +utils/perlbug.PL A simple tool to submit a bug report +utils/perldoc.PL A simple tool to find & display perl's documentation +utils/pl2pm.PL A pl to pm translator +vms/Makefile VMS port +vms/config.vms default config.h for VMS +vms/descrip.mms MM[SK] description file for build +vms/ext/Filespec.pm VMS-Unix file syntax interconversion vms/ext/Stdio/0README.txt ReadMe file for VMS::Stdio vms/ext/Stdio/Makefile.PL MakeMaker driver for VMS::Stdio -vms/ext/Stdio/Stdio.pm VMS options to stdio routines -vms/ext/Stdio/Stdio.xs VMS options to stdio routines -vms/ext/Stdio/test.pl regression tests for VMS::Stdio -vms/ext/filespec.t See if VMS::Filespec funtions work -vms/fndvers.com parse Perl version from patchlevel.h -vms/gen_shrfls.pl generate options files and glue for shareable image -vms/genconfig.pl retcon config.sh from config.h -vms/genopt.com hack to write options files in case of broken makes -vms/make_command.com record MM[SK] command used to build Perl -vms/mms2make.pl convert descrip.mms to make syntax -vms/myconfig.com record local configuration info for bug report -vms/perlvms.pod VMS-specific additions to Perl documentation -vms/perly_c.vms perly.c with fixed declarations for global syms -vms/perly_h.vms perly.h with fixed declarations for global syms -vms/sockadapt.c glue for SockshShr socket support -vms/sockadapt.h glue for SockshShr socket support -vms/test.com DCL driver for regression tests -vms/vms.c VMS-specific C code for Perl core -vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms -vms/vmsish.h VMS-specific C header for Perl core -vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions -writemain.SH Generate perlmain.c from miniperlmain.c+extensions -x2p/EXTERN.h Same as above -x2p/INTERN.h Same as above -x2p/Makefile.SH Precursor to Makefile -x2p/a2p.c Output of a2p.y run through byacc -x2p/a2p.h Global declarations -x2p/a2p.man Manual page for awk to perl translator -x2p/a2p.y A yacc grammer for awk -x2p/a2py.c Awk compiler, sort of -x2p/cflags.SH A script that emits C compilation flags per file -x2p/find2perl.PL A find to perl translator -x2p/handy.h Handy definitions -x2p/hash.c Associative arrays again -x2p/hash.h Public declarations for the above -x2p/s2p.PL Sed to perl translator -x2p/s2p.man Manual page for sed to perl translator -x2p/str.c String handling package -x2p/str.h Public declarations for the above -x2p/util.c Utility routines -x2p/util.h Public declarations for the above -x2p/walk.c Parse tree walker +vms/ext/Stdio/Stdio.pm VMS options to stdio routines +vms/ext/Stdio/Stdio.xs VMS options to stdio routines +vms/ext/Stdio/test.pl regression tests for VMS::Stdio +vms/ext/filespec.t See if VMS::Filespec funtions work +vms/fndvers.com parse Perl version from patchlevel.h +vms/gen_shrfls.pl generate options files and glue for shareable image +vms/genconfig.pl retcon config.sh from config.h +vms/genopt.com hack to write options files in case of broken makes +vms/make_command.com record MM[SK] command used to build Perl +vms/mms2make.pl convert descrip.mms to make syntax +vms/myconfig.com record local configuration info for bug report +vms/perlvms.pod VMS-specific additions to Perl documentation +vms/perly_c.vms perly.c with fixed declarations for global syms +vms/perly_h.vms perly.h with fixed declarations for global syms +vms/sockadapt.c glue for SockshShr socket support +vms/sockadapt.h glue for SockshShr socket support +vms/test.com DCL driver for regression tests +vms/vms.c VMS-specific C code for Perl core +vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms +vms/vmsish.h VMS-specific C header for Perl core +vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions +writemain.SH Generate perlmain.c from miniperlmain.c+extensions +x2p/EXTERN.h Same as above +x2p/INTERN.h Same as above +x2p/Makefile.SH Precursor to Makefile +x2p/a2p.c Output of a2p.y run through byacc +x2p/a2p.h Global declarations +x2p/a2p.man Manual page for awk to perl translator +x2p/a2p.y A yacc grammer for awk +x2p/a2py.c Awk compiler, sort of +x2p/cflags.SH A script that emits C compilation flags per file +x2p/find2perl.PL A find to perl translator +x2p/handy.h Handy definitions +x2p/hash.c Associative arrays again +x2p/hash.h Public declarations for the above +x2p/s2p.PL Sed to perl translator +x2p/s2p.man Manual page for sed to perl translator +x2p/str.c String handling package +x2p/str.h Public declarations for the above +x2p/util.c Utility routines +x2p/util.h Public declarations for the above +x2p/walk.c Parse tree walker diff --git a/Makefile.SH b/Makefile.SH index 29723737c7..f69f58aeeb 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -43,7 +43,13 @@ case "$d_shrplib" in # NeXT uses $patchlevel to set the current version of the dynamic # library produced later. And the Major release number in the name plibsuf=.5.$so - fi;; + fi + if test "$osname" = "os2" ; then + d_shrplib=custom; + shrpenv= + plibsuf=$plibext + fi + ;; *) plibsuf=$lib_ext pldlflags="";; esac @@ -173,18 +179,18 @@ addedbyconf = UU $(shextract) $(plextract) pstruct h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h -h4 = regexp.h scope.h sv.h unixish.h util.h +h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h h = $(h1) $(h2) $(h3) $(h4) c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c -c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c globals.c +c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c globals.c perlio.c c = $(c1) $(c2) $(c3) miniperlmain.c perlmain.c obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT) -obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) +obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS) @@ -251,13 +257,13 @@ ext.libs: $(static_ext) -@test -f ext.libs || touch ext.libs perl: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs - $(SHRPENV) $(CC) $(LARGE) $(MAB) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + $(SHRPENV) $(CC) $(LARGE) $(MAB) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(perllib) `cat ext.libs` $(libs) pureperl: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs - purify $(CC) $(LARGE) $(MAB) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + purify $(CC) $(LARGE) $(MAB) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(perllib) `cat ext.libs` $(libs) quantperl: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs - quantify $(CC) $(LARGE) $(MAB) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs) + quantify $(CC) $(LARGE) $(MAB) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(perllib) `cat ext.libs` $(libs) $(perllib): $& perl$(OBJ_EXT) $(obj) !NO!SUBS! @@ -272,13 +278,11 @@ $spitshell >>Makefile <<'!NO!SUBS!' else $spitshell >>Makefile <<!GROK!THIS! version=$patchlevel; \\ + libtool -dynamic -undefined warning -framework System \\ + -compatibility_version 1 -current_version \$\$version \\ + -prebind -seg1addr 0x27000000 -install_name \$(shrpdir)/\$@ \\ + -o \$@ perl.o \$(obj) !GROK!THIS! -$spitshell >>Makefile <<'!NO!SUBS!' - libtool -dynamic -undefined warning -framework System \ - -compatibility_version 1 -current_version $$version \ - -prebind -seg1addr 0x27000000 -install_name $(shrpdir)/$@ \ - -o $@ perl.o $(obj) -!NO!SUBS! fi ;; custom) @@ -368,7 +372,7 @@ run_byacc: FORCE @ echo 'Expect' 130 shift/reduce and 1 reduce/reduce conflict $(BYACC) -d perly.y sh $(shellflags) ./perly.fixer y.tab.c perly.c - sed -e s/stderr/Perl_debug_log/g perly.c >perly.tmp && mv perly.tmp perly.c + sed -e 's/fprintf *( *stderr *,/PerlIO_printf(Perl_debug_log,/g' perly.c >perly.tmp && mv perly.tmp perly.c mv y.tab.h perly.h echo 'extern YYSTYPE yylval;' >>perly.h - perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms @@ -483,7 +487,7 @@ makedepend: makedepend.SH config.sh test: miniperl perl preplibrary $(dynamic_ext) - cd t && (rm -f perl$(EXE_EXT); $(LNS) ../perl$(EXE_EXT) perl$(EXE_EXT)) && ./perl TEST </dev/tty -minitest: miniperl +minitest: miniperl lib/Config.pm - cd t && (rm -f perl$(EXE_EXT); $(LNS) ../miniperl$(EXE_EXT) perl$(EXE_EXT)) \ && ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t </dev/tty @@ -499,6 +503,15 @@ shlist: $(sh) pllist: $(pl) echo $(pl) | tr ' ' '\012' >.pllist +Makefile: Makefile.SH ./config.sh + $(SHELL) Makefile.SH + +distcheck : FORCE + perl '-MExtUtils::Manifest=&fullcheck' -e 'fullcheck()' + +manifest : + perl '-MExtUtils::Manifest=&mkmanifest' -e 'mkmanifest()' + # AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE # If this runs make out of memory, delete /usr/include lines. !NO!SUBS! @@ -123,8 +123,8 @@ for file do optimize="$optdebug" fi - echo "$cc -c $ccflags $optimize $perltype $large $split" - eval "$also "'"$cc -c $ccflags $optimize $perltype $large $split"' + echo "$cc -c -DPERL_CORE $ccflags $optimize $perltype $large $split" + eval "$also "'"$cc -DPERL_CORE -c $ccflags $optimize $perltype $large $split"' . $TOP/config.sh diff --git a/config_h.SH b/config_h.SH index 331a722fb4..2b7694f2b5 100755 --- a/config_h.SH +++ b/config_h.SH @@ -1,4 +1,3 @@ -#! /bin/sh case $CONFIG in '') if test -f config.sh; then TOP=.; @@ -12,18 +11,10 @@ case $CONFIG in . $TOP/config.sh ;; esac - -case "$bin_sh" in -'') - bin_sh='/bin/sh' - ;; -esac - case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac echo "Extracting config.h (with variable substitutions)" -rm -f config.h sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' /* * This file was produced by running the config_h.SH script, which @@ -34,7 +25,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' * that running config_h.SH again will wipe out any changes you've made. * For a more permanent change edit config.sh and rerun config_h.SH. * - * \$Id: config_h.SH,v 1.2 1996/07/05 23:49:13 gerti Exp $ + * \$Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $ */ /* Configuration time: $cf_time @@ -1301,16 +1292,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define Size_t $sizetype /* length paramater for string functions */ -/* SSize_t: - * This symbol holds the type used by functions that return - * a count of bytes or an error condition. It must be a signed type. - * It is usually ssize_t, but may be long or int, etc. - * It may be necessary to include <sys/types.h> or <unistd.h> - * to get any typedef'ed information. - * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). - */ -#define SSize_t $ssizetype /* signed count of bytes */ - /* STDCHAR: * This symbol is defined to be the type of char used in stdio.h. * It has the values "unsigned char" or "char". @@ -1335,33 +1316,36 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define LOC_SED "$full_sed" /**/ +/* OSNAME: + * This symbol contains the name of the operating system, as determined + * by Configure. You shouldn't rely on it too much; the specific + * feature tests from Configure are generally more reliable. + */ +#define OSNAME "$osname" /**/ + /* ARCHLIB_EXP: * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ #$d_archlib ARCHLIB_EXP "$archlibexp" /**/ -/* OSNAME: - * This symbol contains the name of the operating system, as determined - * by Configure. +/* BIN_SH: + * Pathname to /bin/sh equivalent */ -#define OSNAME "$osname" /**/ - +#define BIN_SH "$bin_sh" /**/ /* BYTEORDER: * This symbol hold the hexadecimal constant defined in byteorder, * i.e. 0x1234 or 0x4321, etc... */ #ifndef NeXT #define BYTEORDER 0x$byteorder /* large digits for MSB */ -#else /* NeXT */ - -#ifdef __BIG_ENDIAN__ -#define BYTEORDER 0x4321 -#else /* __LITTLE_ENDIAN__ */ +#else /* NeXT */ +#ifdef __LITTLE_ENDIAN__ #define BYTEORDER 0x1234 +#else /* __BIG_ENDIAN__ */ +#define BYTEORDER 0x4321 #endif /* ENDIAN CHECK */ - -#endif /* !NeXT */ +#endif /* NeXT */ /* CSH: * This symbol, if defined, indicates that the C-shell exists. @@ -1414,26 +1398,40 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define Gconvert(x,n,t,b) $d_Gconvert +/* PERLIO_IS_STDIO: + * This symbol, if defined, indicates that stdio should + * be used in a fully backward compatible manner. + */ +#$d_perlstdio PERLIO_IS_STDIO /**/ + +/* USE_SFIO: + * This symbol, if defined, indicates that sfio should + * be used. + */ +#$d_sfio USE_SFIO /**/ + /* Sigjmp_buf: - * This is the buffer type to be used with Sigsetjmp and Siglongjmp. + * This is the buffer type to be used with Sigsetjmp and Siglongjmp. */ /* Sigsetjmp: - * This macro is used in the same way as sigsetjmp(), but will invoke - * traditional setjmp() if sigsetjmp isn't available. + * This macro is used in the same way as sigsetjmp(), but will invoke + * traditional setjmp() if sigsetjmp isn't available. + * See HAS_SIGSETJMP. */ /* Siglongjmp: - * This macro is used in the same way as siglongjmp(), but will invoke - * traditional longjmp() if siglongjmp isn't available. + * This macro is used in the same way as siglongjmp(), but will invoke + * traditional longjmp() if siglongjmp isn't available. + * See HAS_SIGSETJMP. */ #$d_sigsetjmp HAS_SIGSETJMP /**/ #ifdef HAS_SIGSETJMP #define Sigjmp_buf sigjmp_buf -#define Sigsetjmp(buf,save_mask) sigsetjmp(buf,save_mask) -#define Siglongjmp(buf,retval) siglongjmp(buf,retval) +#define Sigsetjmp(buf,save_mask) sigsetjmp((buf),(save_mask)) +#define Siglongjmp(buf,retval) siglongjmp((buf),(retval)) #else #define Sigjmp_buf jmp_buf -#define Sigsetjmp(buf,save_mask) setjmp(buf) -#define Siglongjmp(buf,retval) longjmp(buf,retval) +#define Sigsetjmp(buf,save_mask) setjmp((buf)) +#define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_DYNAMIC_LOADING: @@ -1459,12 +1457,20 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #$i_locale I_LOCALE /**/ +/* I_SFIO: + * This symbol, if defined, indicates to the C program that it should + * include <sfio.h>. + */ +#$i_sfio I_SFIO /**/ + /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include <sys/stat.h>. */ #$i_sysstat I_SYS_STAT /**/ +#$i_values I_LIMITS /**/ + /* I_STDARG: * This symbol, if defined, indicates that <stdarg.h> exists and should * be included. @@ -1580,6 +1586,16 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define SITELIB_EXP "$sitelibexp" /**/ +/* SSize_t: + * This symbol holds the type used by functions that return + * a count of bytes or an error condition. It must be a signed type. + * It is usually ssize_t, but may be long or int, etc. + * It may be necessary to include <sys/types.h> or <unistd.h> + * to get any typedef'ed information. + * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t). + */ +#define SSize_t $ssizetype /* signed count of bytes */ + /* STARTPERL: * This variable contains the string to put in front of a perl * script to make sure (one hopes) that it runs with perl and not @@ -1587,11 +1603,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' */ #define STARTPERL "$startperl" /**/ -/* BIN_SH: - * This variable contains the path to the shell. - */ -#define BIN_SH "$bin_sh" /**/ - /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this * compiler. What various bits mean: @@ -147,7 +147,7 @@ struct block { cx->blk_oldretsp = retstack_ix, \ cx->blk_oldpm = curpm, \ cx->blk_gimme = gimme; \ - DEBUG_l( fprintf(stderr,"Entering block %ld, type %s\n", \ + DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Entering block %ld, type %s\n", \ (long)cxstack_ix, block_type[t]); ) /* Exit a block (RETURN and LAST). */ @@ -159,7 +159,7 @@ struct block { retstack_ix = cx->blk_oldretsp, \ pm = cx->blk_oldpm, \ gimme = cx->blk_gimme; \ - DEBUG_l( fprintf(stderr,"Leaving block %ld, type %s\n", \ + DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Leaving block %ld, type %s\n", \ (long)cxstack_ix+1,block_type[cx->cx_type]); ) /* Continue a block elsewhere (NEXT and REDO). */ @@ -30,12 +30,12 @@ deb(pat,a1,a2,a3,a4,a5,a6,a7,a8) register I32 i; GV* gv = curcop->cop_filegv; - fprintf(Perl_debug_log,"(%s:%ld)\t", + PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>", (long)curcop->cop_line); for (i=0; i<dlevel; i++) - fprintf(Perl_debug_log,"%c%c ",debname[i],debdelim[i]); - fprintf(Perl_debug_log,pat,a1,a2,a3,a4,a5,a6,a7,a8); + PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]); + PerlIO_printf(Perl_debug_log, pat,a1,a2,a3,a4,a5,a6,a7,a8); } #else /* !defined(I_STDARG) && !defined(I_VARARGS) */ @@ -55,18 +55,18 @@ deb(pat, va_alist) register I32 i; GV* gv = curcop->cop_filegv; - fprintf(Perl_debug_log,"(%s:%ld)\t", + PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>", (long)curcop->cop_line); for (i=0; i<dlevel; i++) - fprintf(Perl_debug_log,"%c%c ",debname[i],debdelim[i]); + PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]); # ifdef I_STDARG va_start(args, pat); # else va_start(args); # endif - (void) vfprintf(Perl_debug_log,pat,args); + (void) PerlIO_vprintf(Perl_debug_log,pat,args); va_end( args ); } #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ @@ -82,11 +82,11 @@ deb_growlevel() I32 debstackptrs() { - fprintf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n", + PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n", (unsigned long)curstack, (unsigned long)stack_base, (long)*markstack_ptr, (long)(stack_sp-stack_base), (long)(stack_max-stack_base)); - fprintf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n", + PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n", (unsigned long)mainstack, (unsigned long)AvARRAY(curstack), (long)mainstack, (long)AvFILL(curstack), (long)AvMAX(curstack)); return 0; @@ -106,25 +106,25 @@ debstack() if (*markscan >= i) break; - fprintf(Perl_debug_log, i ? " => ... " : " => "); + PerlIO_printf(Perl_debug_log, i ? " => ... " : " => "); if (stack_base[0] != &sv_undef || stack_sp < stack_base) - fprintf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); + PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); do { ++i; if (markscan <= markstack_ptr && *markscan < i) { do { ++markscan; - putc('*', Perl_debug_log); + PerlIO_putc(Perl_debug_log, '*'); } while (markscan <= markstack_ptr && *markscan < i); - fprintf(Perl_debug_log, " "); + PerlIO_printf(Perl_debug_log, " "); } if (i > top) break; - fprintf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); + PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); } while (1); - fprintf(Perl_debug_log, "\n"); + PerlIO_printf(Perl_debug_log, "\n"); return 0; } #else @@ -60,21 +60,21 @@ register char *name; I32 len; int as_raw; int rawmode, rawperm; -FILE *supplied_fp; +PerlIO *supplied_fp; { register IO *io = GvIOn(gv); - FILE *saveifp = Nullfp; - FILE *saveofp = Nullfp; + PerlIO *saveifp = Nullfp; + PerlIO *saveofp = Nullfp; char savetype = ' '; int writing = 0; - FILE *fp; + PerlIO *fp; int fd; int result; forkprocess = 1; /* assume true if no fork */ if (IoIFP(io)) { - fd = fileno(IoIFP(io)); + fd = PerlIO_fileno(IoIFP(io)); if (IoTYPE(io) == '-') result = 0; else if (fd <= maxsysfd) { @@ -87,16 +87,16 @@ FILE *supplied_fp; 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 */ + result = PerlIO_close(IoOFP(io)); + PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ } else - result = fclose(IoIFP(io)); + result = PerlIO_close(IoIFP(io)); } else - result = fclose(IoIFP(io)); + result = PerlIO_close(IoIFP(io)); if (result == EOF && fd > maxsysfd) - fprintf(stderr,"Warning: unable to close filehandle %s properly.\n", + PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n", GvENAME(gv)); IoOFP(io) = IoIFP(io) = Nullfp; } @@ -109,7 +109,7 @@ FILE *supplied_fp; if (fd == -1) fp = NULL; else { - fp = fdopen(fd, ((result == 0) ? "r" + fp = PerlIO_fdopen(fd, ((result == 0) ? "r" : (result == 1) ? "w" : "r+")); if (!fp) @@ -183,7 +183,7 @@ FILE *supplied_fp; goto say_false; } if (IoIFP(thatio)) { - fd = fileno(IoIFP(thatio)); + fd = PerlIO_fileno(IoIFP(thatio)); if (IoTYPE(thatio) == 's') IoTYPE(io) = 's'; } @@ -192,7 +192,7 @@ FILE *supplied_fp; } if (dodup) fd = dup(fd); - if (!(fp = fdopen(fd,mode))) { + if (!(fp = PerlIO_fdopen(fd,mode))) { if (dodup) close(fd); } @@ -202,11 +202,11 @@ FILE *supplied_fp; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; if (strEQ(name,"-")) { - fp = stdout; + fp = PerlIO_stdout(); IoTYPE(io) = '-'; } else { - fp = fopen(name,mode); + fp = PerlIO_open(name,mode); } } } @@ -217,11 +217,11 @@ FILE *supplied_fp; if (*name == '&') goto duplicity; if (strEQ(name,"-")) { - fp = stdin; + fp = PerlIO_stdin(); IoTYPE(io) = '-'; } else - fp = fopen(name,mode); + fp = PerlIO_open(name,mode); } else if (name[len-1] == '|') { name[--len] = '\0'; @@ -240,11 +240,11 @@ FILE *supplied_fp; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; if (strEQ(name,"-")) { - fp = stdin; + fp = PerlIO_stdin(); IoTYPE(io) = '-'; } else - fp = fopen(name,"r"); + fp = PerlIO_open(name,"r"); } } if (!fp) { @@ -254,8 +254,8 @@ FILE *supplied_fp; } if (IoTYPE(io) && IoTYPE(io) != '|' && IoTYPE(io) != '-') { - if (Fstat(fileno(fp),&statbuf) < 0) { - (void)fclose(fp); + if (Fstat(PerlIO_fileno(fp),&statbuf) < 0) { + (void)PerlIO_close(fp); goto say_false; } if (S_ISSOCK(statbuf.st_mode)) @@ -269,7 +269,7 @@ FILE *supplied_fp; #endif ) { int buflen = sizeof tokenbuf; - if (getsockname(fileno(fp), (struct sockaddr *)tokenbuf, &buflen) >= 0 + if (getsockname(PerlIO_fileno(fp), (struct sockaddr *)tokenbuf, &buflen) >= 0 || errno != ENOTSOCK) IoTYPE(io) = 's'; /* some OS's return 0 on fstat()ed socket */ /* but some return 0 for streams too, sigh */ @@ -277,43 +277,43 @@ FILE *supplied_fp; #endif } if (saveifp) { /* must use old fp? */ - fd = fileno(saveifp); + fd = PerlIO_fileno(saveifp); if (saveofp) { - Fflush(saveofp); /* emulate fclose() */ + PerlIO_flush(saveofp); /* emulate PerlIO_close() */ if (saveofp != saveifp) { /* was a socket? */ - fclose(saveofp); + PerlIO_close(saveofp); if (fd > 2) Safefree(saveofp); } } - if (fd != fileno(fp)) { + if (fd != PerlIO_fileno(fp)) { int pid; SV *sv; - dup2(fileno(fp), fd); - sv = *av_fetch(fdpid,fileno(fp),TRUE); + dup2(PerlIO_fileno(fp), fd); + sv = *av_fetch(fdpid,PerlIO_fileno(fp),TRUE); (void)SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); SvIVX(sv) = 0; sv = *av_fetch(fdpid,fd,TRUE); (void)SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; - fclose(fp); + PerlIO_close(fp); } fp = saveifp; - clearerr(fp); + PerlIO_clearerr(fp); } #if defined(HAS_FCNTL) && defined(F_SETFD) - fd = fileno(fp); + fd = PerlIO_fileno(fp); fcntl(fd,F_SETFD,fd > maxsysfd); #endif IoIFP(io) = fp; if (writing) { if (IoTYPE(io) == 's' || (IoTYPE(io) == '>' && S_ISCHR(statbuf.st_mode)) ) { - if (!(IoOFP(io) = fdopen(fileno(fp),"w"))) { - fclose(fp); + if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) { + PerlIO_close(fp); IoIFP(io) = Nullfp; goto say_false; } @@ -330,7 +330,7 @@ say_false: return FALSE; } -FILE * +PerlIO * nextargv(gv) register GV *gv; { @@ -345,7 +345,7 @@ register GV *gv; if (!argvoutgv) argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO); if (filemode & (S_ISUID|S_ISGID)) { - Fflush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */ + PerlIO_flush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */ #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); #else @@ -444,7 +444,7 @@ register GV *gv; continue; } setdefout(argvoutgv); - lastfd = fileno(IoIFP(GvIOp(argvoutgv))); + lastfd = PerlIO_fileno(IoIFP(GvIOp(argvoutgv))); (void)Fstat(lastfd,&statbuf); #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); @@ -464,7 +464,7 @@ register GV *gv; return IoIFP(GvIOp(gv)); } else - fprintf(stderr,"Can't open %s: %s\n",SvPV(sv, na), Strerror(errno)); + PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",SvPV(sv, na), Strerror(errno)); } if (inplace) { (void)do_close(argvoutgv,FALSE); @@ -499,15 +499,15 @@ GV *wgv; if (pipe(fd) < 0) goto badexit; - IoIFP(rstio) = fdopen(fd[0], "r"); - IoOFP(wstio) = fdopen(fd[1], "w"); + IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); + IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = '<'; IoTYPE(wstio) = '>'; if (!IoIFP(rstio) || !IoOFP(wstio)) { - if (IoIFP(rstio)) fclose(IoIFP(rstio)); + if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio)); else close(fd[0]); - if (IoOFP(wstio)) fclose(IoOFP(wstio)); + if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio)); else close(fd[1]); goto badexit; } @@ -573,11 +573,11 @@ IO* io; retval = TRUE; else { if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ - retval = (fclose(IoOFP(io)) != EOF); - fclose(IoIFP(io)); /* clear stdio, fd already closed */ + retval = (PerlIO_close(IoOFP(io)) != EOF); + PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ } else - retval = (fclose(IoIFP(io)) != EOF); + retval = (PerlIO_close(IoIFP(io)) != EOF); } IoOFP(io) = IoIFP(io) = Nullfp; } @@ -599,20 +599,20 @@ GV *gv; while (IoIFP(io)) { -#ifdef USE_STDIO_PTR /* (the code works without this) */ - if (FILE_cnt(IoIFP(io)) > 0) /* cheat a little, since */ - return FALSE; /* this is the most usual case */ -#endif + if (PerlIO_has_cntptr(IoIFP(io))) { /* (the code works without this) */ + if (PerlIO_get_cnt(IoIFP(io)) > 0) /* cheat a little, since */ + return FALSE; /* this is the most usual case */ + } - ch = getc(IoIFP(io)); + ch = PerlIO_getc(IoIFP(io)); if (ch != EOF) { - (void)ungetc(ch, IoIFP(io)); + (void)PerlIO_ungetc(IoIFP(io),ch); return FALSE; } -#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) - if (FILE_cnt(IoIFP(io)) < -1) - FILE_cnt(IoIFP(io)) = -1; -#endif + if (PerlIO_has_cntptr(IoIFP(io)) && PerlIO_canset_cnt(IoIFP(io))) { + if (PerlIO_get_cnt(IoIFP(io)) < -1) + PerlIO_set_cnt(IoIFP(io),-1); + } if (op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ if (!nextargv(argvgv)) /* get another fp handy */ return TRUE; @@ -637,11 +637,11 @@ GV *gv; goto phooey; #ifdef ULTRIX_STDIO_BOTCH - if (feof(IoIFP(io))) - (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ + if (PerlIO_eof(IoIFP(io))) + (void)PerlIO_seek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ #endif - return ftell(IoIFP(io)); + return PerlIO_tell(IoIFP(io)); phooey: if (dowarn) @@ -666,11 +666,11 @@ int whence; goto nuts; #ifdef ULTRIX_STDIO_BOTCH - if (feof(IoIFP(io))) - (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ + if (PerlIO_eof(IoIFP(io))) + (void)PerlIO_seek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ #endif - return fseek(IoIFP(io), pos, whence) >= 0; + return PerlIO_seek(IoIFP(io), pos, whence) >= 0; nuts: if (dowarn) @@ -784,7 +784,7 @@ SV *sv; bool do_print(sv,fp) register SV *sv; -FILE *fp; +PerlIO *fp; { register char *tmps; STRLEN len; @@ -796,13 +796,13 @@ FILE *fp; if (SvGMAGICAL(sv)) mg_get(sv); if (SvIOK(sv) && SvIVX(sv) != 0) { - fprintf(fp, ofmt, (double)SvIVX(sv)); - return !ferror(fp); + PerlIO_printf(fp, ofmt, (double)SvIVX(sv)); + return !PerlIO_error(fp); } if ( (SvNOK(sv) && SvNVX(sv) != 0.0) || (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) { - fprintf(fp, ofmt, SvNVX(sv)); - return !ferror(fp); + PerlIO_printf(fp, ofmt, SvNVX(sv)); + return !PerlIO_error(fp); } } switch (SvTYPE(sv)) { @@ -814,17 +814,17 @@ FILE *fp; if (SvIOK(sv)) { if (SvGMAGICAL(sv)) mg_get(sv); - fprintf(fp, "%ld", (long)SvIVX(sv)); - return !ferror(fp); + PerlIO_printf(fp, "%ld", (long)SvIVX(sv)); + return !PerlIO_error(fp); } /* FALL THROUGH */ default: tmps = SvPV(sv, len); break; } - if (len && (fwrite1(tmps,1,len,fp) == 0 || ferror(fp))) + if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp))) return FALSE; - return TRUE; + return !PerlIO_error(fp); } I32 @@ -844,7 +844,7 @@ dARGS statgv = tmpgv; sv_setpv(statname,""); laststype = OP_STAT; - return (laststatval = Fstat(fileno(IoIFP(io)), &statcache)); + return (laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache)); } else { if (tmpgv == defgv) @@ -955,6 +955,8 @@ do_execfree() } } +#ifndef OS2 + bool do_exec(cmd) char *cmd; @@ -1044,6 +1046,8 @@ char *cmd; return FALSE; } +#endif + I32 apply(type,mark,sp) I32 type; @@ -320,7 +320,7 @@ register SV **sarg; /* end of switch, copy results */ *t = ch; if (xs == buf && xlen >= sizeof(buf)) { /* Ooops! */ - fputs("panic: sprintf overflow - memory corrupted!\n",stderr); + PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n"); my_exit(1); } SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post); @@ -25,25 +25,13 @@ dump_all() #ifdef I_STDARG static void dump(char *pat, ...); #else -# if defined(I_VARARGS) -/*VARARGS0*/ -static void -dump(pat, va_alist) - char *pat; - va_dcl -# else static void dump(); -# endif #endif void dump_all() { -#ifdef HAS_SETLINEBUF - setlinebuf(Perl_debug_log); -#else - setvbuf(Perl_debug_log, Nullch, _IOLBF, 0); -#endif + PerlIO_setlinebuf(Perl_debug_log); if (main_root) dump_op(main_root); dump_packsubs(defstash); @@ -119,18 +107,18 @@ register OP *op; dump("{\n"); if (op->op_seq) - fprintf(Perl_debug_log, "%-4d", op->op_seq); + PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq); else - fprintf(Perl_debug_log, " "); + PerlIO_printf(Perl_debug_log, " "); dump("TYPE = %s ===> ", op_name[op->op_type]); if (op->op_next) { if (op->op_seq) - fprintf(Perl_debug_log, "%d\n", op->op_next->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", op->op_next->op_seq); else - fprintf(Perl_debug_log, "(%d)\n", op->op_next->op_seq); + PerlIO_printf(Perl_debug_log, "(%d)\n", op->op_next->op_seq); } else - fprintf(Perl_debug_log, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); dumplvl++; if (op->op_targ) { if (op->op_type == OP_NULL) @@ -255,31 +243,31 @@ register OP *op; case OP_ENTERLOOP: dump("REDO ===> "); if (cLOOP->op_redoop) - fprintf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq); else - fprintf(Perl_debug_log, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); dump("NEXT ===> "); if (cLOOP->op_nextop) - fprintf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq); else - fprintf(Perl_debug_log, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); dump("LAST ===> "); if (cLOOP->op_lastop) - fprintf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq); else - fprintf(Perl_debug_log, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_COND_EXPR: dump("TRUE ===> "); if (cCONDOP->op_true) - fprintf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq); else - fprintf(Perl_debug_log, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); dump("FALSE ===> "); if (cCONDOP->op_false) - fprintf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq); else - fprintf(Perl_debug_log, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_MAPWHILE: case OP_GREPWHILE: @@ -287,9 +275,9 @@ register OP *op; case OP_AND: dump("OTHER ===> "); if (cLOGOP->op_other) - fprintf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq); + PerlIO_printf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq); else - fprintf(Perl_debug_log, "DONE\n"); + PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_PUSHRE: case OP_MATCH: @@ -315,12 +303,12 @@ register GV *gv; SV *sv; if (!gv) { - fprintf(Perl_debug_log,"{}\n"); + PerlIO_printf(Perl_debug_log, "{}\n"); return; } sv = sv_newmortal(); dumplvl++; - fprintf(Perl_debug_log,"{\n"); + PerlIO_printf(Perl_debug_log, "{\n"); gv_fullname(sv,gv); dump("GV_NAME = %s", SvPVX(sv)); if (gv != GvEGV(gv)) { @@ -400,8 +388,8 @@ long arg2, arg3, arg4, arg5; I32 i; for (i = dumplvl*4; i; i--) - (void)putc(' ',Perl_debug_log); - fprintf(Perl_debug_log,arg1, arg2, arg3, arg4, arg5); + (void)PerlIO_putc(Perl_debug_log,' '); + PerlIO_printf(Perl_debug_log, arg1, arg2, arg3, arg4, arg5); } #else @@ -419,9 +407,6 @@ dump(pat,va_alist) { I32 i; va_list args; -#ifndef HAS_VPRINTF - int vfprintf(); -#endif #ifdef I_STDARG va_start(args, pat); @@ -429,8 +414,8 @@ dump(pat,va_alist) va_start(args); #endif for (i = dumplvl*4; i; i--) - (void)putc(' ',stderr); - vfprintf(Perl_debug_log,pat,args); + (void)PerlIO_putc(Perl_debug_log,' '); + PerlIO_vprintf(Perl_debug_log,pat,args); va_end(args); } #endif @@ -56,11 +56,14 @@ #define curcopdb Perl_curcopdb #define curinterp Perl_curinterp #define curpad Perl_curpad +#define cv_const_sv Perl_cv_const_sv #define dc Perl_dc +#define debug Perl_debug #define dec_amg Perl_dec_amg #define di Perl_di #define div_amg Perl_div_amg #define div_ass_amg Perl_div_ass_amg +#define do_undump Perl_do_undump #define ds Perl_ds #define egid Perl_egid #define envgv Perl_envgv @@ -519,7 +522,7 @@ #define my Perl_my #define my_bcopy Perl_my_bcopy #define my_bzero Perl_my_bzero -#define my_chsize Perl_my_chsize +#define my_chsize Perl_my_chsize #define my_exit Perl_my_exit #define my_htonl Perl_my_htonl #define my_lstat Perl_my_lstat @@ -1099,9 +1102,9 @@ /* Undefine symbols that were defined by EMBED. Somewhat ugly */ #undef curcop +#undef curcopdb #undef envgv #undef siggv -#undef stack #undef tainting #define Argv (curinterp->IArgv) @@ -1137,7 +1140,6 @@ #define debdelim (curinterp->Idebdelim) #define debname (curinterp->Idebname) #define debstash (curinterp->Idebstash) -#define debug (curinterp->Idebug) #define defgv (curinterp->Idefgv) #define defoutgv (curinterp->Idefoutgv) #define defstash (curinterp->Idefstash) @@ -1146,7 +1148,6 @@ #define dirty (curinterp->Idirty) #define dlevel (curinterp->Idlevel) #define dlmax (curinterp->Idlmax) -#define do_undump (curinterp->Ido_undump) #define doextract (curinterp->Idoextract) #define doswitches (curinterp->Idoswitches) #define dowarn (curinterp->Idowarn) @@ -1292,7 +1293,6 @@ #define Idebdelim debdelim #define Idebname debname #define Idebstash debstash -#define Idebug debug #define Idefgv defgv #define Idefoutgv defoutgv #define Idefstash defstash @@ -1301,7 +1301,6 @@ #define Idirty dirty #define Idlevel dlevel #define Idlmax dlmax -#define Ido_undump do_undump #define Idoextract doextract #define Idoswitches doswitches #define Idowarn dowarn @@ -30,7 +30,8 @@ open(GL, "<global.sym") || die "Can't open global.sym: $!\n"; while(<GL>) { s/[ \t]*#.*//; # Delete comments. next unless /\S/; - s/(.*)/#define $1\t\tPerl_$1/; + s/^\s*(\S+).*$/#define $1\t\tPerl_$1/; + $global{$1} = 1; s/(................\t)\t/$1/; print EM $_; } @@ -47,19 +48,25 @@ print EM <<'END'; /* Undefine symbols that were defined by EMBED. Somewhat ugly */ -#undef curcop -#undef envgv -#undef siggv -#undef stack -#undef tainting - END + +open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; +while (<INT>) { + s/[ \t]*#.*//; # Delete comments. + next unless /\S/; + s/^\s*(\S*).*$/#undef $1/; + print EM $_ if (exists $global{$1}); +} +close(INT) || warn "Can't close interp.sym: $!\n"; + +print EM "\n"; + open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; while (<INT>) { s/[ \t]*#.*//; # Delete comments. next unless /\S/; - s/(.*)/#define $1\t\t(curinterp->I$1)/; + s/^\s*(\S+).*$/#define $1\t\t(curinterp->I$1)/; s/(................\t)\t/$1/; print EM $_; } @@ -75,7 +82,7 @@ open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n"; while (<INT>) { s/[ \t]*#.*//; # Delete comments. next unless /\S/; - s/(.*)/#define I$1\t\t$1/; + s/^\s*(\S+).*$/#define I$1\t\t$1/; s/(................\t)\t/$1/; print EM $_; } diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm index 0fff53845d..61cd138b89 100644 --- a/ext/DB_File/DB_File.pm +++ b/ext/DB_File/DB_File.pm @@ -273,18 +273,14 @@ DB_File - Perl5 access to Berkeley DB [$X =] tie %hash, 'DB_File', [$filename, $flags, $mode, $DB_HASH] ; [$X =] tie %hash, 'DB_File', $filename, $flags, $mode, $DB_BTREE ; [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ; - - [$X =] tie %hash, DB_File, $filename [, $flags, $mode, $DB_HASH ] ; - [$X =] tie %hash, DB_File, $filename, $flags, $mode, $DB_BTREE ; - [$X =] tie @array, DB_File, $filename, $flags, $mode, $DB_RECNO ; - + $status = $X->del($key [, $flags]) ; $status = $X->put($key, $value [, $flags]) ; $status = $X->get($key, $value [, $flags]) ; - $status = $X->seq($key, $value , $flags) ; + $status = $X->seq($key, $value, $flags) ; $status = $X->sync([$flags]) ; $status = $X->fd ; - + $count = $X->get_dup($key) ; @list = $X->get_dup($key) ; %list = $X->get_dup($key, 1) ; @@ -321,11 +317,6 @@ applications, is built into Berkeley DB. If you do need to use your own hashing algorithm it is possible to write your own in Perl and have B<DB_File> use it instead. -When opening an existing database, you may omit the final three arguments -to C<tie>; they default to O_RDWR, 0644, and $DB_HASH. If you're -creating a new file, you need to specify at least the C<$flags> -argument, which must include O_CREAT. - =item B<DB_BTREE> The btree format allows arbitrary key/value pairs to be stored in a diff --git a/ext/DynaLoader/Makefile.PL b/ext/DynaLoader/Makefile.PL index 5ccdc68a0e..9323935880 100644 --- a/ext/DynaLoader/Makefile.PL +++ b/ext/DynaLoader/Makefile.PL @@ -3,7 +3,7 @@ use ExtUtils::MakeMaker; WriteMakefile( NAME => 'DynaLoader', LINKTYPE => 'static', - DEFINE => '-DLIBC="$(LIBC)"', + DEFINE => '-DPERL_CORE -DLIBC="$(LIBC)"', MAN3PODS => ' ', # Pods will be built by installman. SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs index f8bace1314..68831ed8b0 100644 --- a/ext/DynaLoader/dl_aix.xs +++ b/ext/DynaLoader/dl_aix.xs @@ -527,9 +527,9 @@ void * dl_load_file(filename) char * filename CODE: - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, 1) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -542,10 +542,10 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -567,7 +567,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/ext/DynaLoader/dl_dld.xs b/ext/DynaLoader/dl_dld.xs index a0028a1f7a..d2f2f7f53d 100644 --- a/ext/DynaLoader/dl_dld.xs +++ b/ext/DynaLoader/dl_dld.xs @@ -62,7 +62,7 @@ dl_private_init() if (dlderr) { char *msg = dld_strerror(dlderr); SaveError("dld_init(%s) failed: %s", origargv[0], msg); - DLDEBUG(1,fprintf(stderr,"%s", LastError)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "%s", LastError)); } #ifdef __linux__ } @@ -83,12 +83,12 @@ dl_load_file(filename) int dlderr,x,max; GV *gv; RETVAL = filename; - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s)\n", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s)\n", filename)); max = AvFILL(dl_require_symbols); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_require_symbols, x, 0)); - DLDEBUG(1,fprintf(stderr, "dld_create_ref(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_create_ref(%s)\n", sym)); if (dlderr = dld_create_reference(sym)) { SaveError("dld_create_reference(%s): %s", sym, dld_strerror(dlderr)); @@ -96,7 +96,7 @@ dl_load_file(filename) } } - DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", filename)); if (dlderr = dld_link(filename)) { SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); goto haverror; @@ -105,13 +105,13 @@ dl_load_file(filename) max = AvFILL(dl_resolve_using); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0)); - DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", sym)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dld_link(%s)\n", sym)); if (dlderr = dld_link(sym)) { SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } - DLDEBUG(2,fprintf(stderr,"libref=%s\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL)); haverror: ST(0) = sv_newmortal() ; if (dlderr == 0) @@ -123,11 +123,11 @@ dl_find_symbol(libhandle, symbolname) void * libhandle char * symbolname CODE: - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = (void *)dld_get_func(symbolname); /* if RETVAL==NULL we should try looking for a non-function symbol */ - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; @@ -157,7 +157,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/ext/DynaLoader/dl_dlopen.xs b/ext/DynaLoader/dl_dlopen.xs index a2a68162b2..5dfe5c160f 100644 --- a/ext/DynaLoader/dl_dlopen.xs +++ b/ext/DynaLoader/dl_dlopen.xs @@ -151,9 +151,9 @@ dl_load_file(filename) if (dl_nonlazy) mode = RTLD_NOW; #endif - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -170,10 +170,10 @@ dl_find_symbol(libhandle, symbolname) char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -195,7 +195,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs index 0e146830ef..975d26d779 100644 --- a/ext/DynaLoader/dl_hpux.xs +++ b/ext/DynaLoader/dl_hpux.xs @@ -52,17 +52,17 @@ dl_load_file(filename) max = AvFILL(dl_resolve_using); for (i = 0; i <= max; i++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); - DLDEBUG(1,fprintf(stderr, "dl_load_file(%s) (dependent)\n", sym)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym)); obj = shl_load(sym, bind_type | BIND_NOSTART, 0L); if (obj == NULL) { goto end; } } - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s): ", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); obj = shl_load(filename, bind_type | BIND_NOSTART, 0L); - DLDEBUG(2,fprintf(stderr," libref=%x\n", obj)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); end: ST(0) = sv_newmortal() ; if (obj == NULL) @@ -83,17 +83,17 @@ dl_find_symbol(libhandle, symbolname) char symbolname_buf[MAXPATHLEN]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); ST(0) = sv_newmortal() ; errno = 0; status = shl_findsym(&obj, symbolname, TYPE_PROCEDURE, &symaddr); - DLDEBUG(2,fprintf(stderr," symbolref(PROCEDURE) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(PROCEDURE) = %x\n", symaddr)); if (status == -1 && errno == 0) { /* try TYPE_DATA instead */ status = shl_findsym(&obj, symbolname, TYPE_DATA, &symaddr); - DLDEBUG(2,fprintf(stderr," symbolref(DATA) = %x\n", symaddr)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(DATA) = %x\n", symaddr)); } if (status == -1) { @@ -117,7 +117,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs index 9e98d562e0..3e908ff02a 100644 --- a/ext/DynaLoader/dl_next.xs +++ b/ext/DynaLoader/dl_next.xs @@ -245,9 +245,9 @@ dl_load_file(filename) char * filename CODE: int mode = 1; - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -264,10 +264,10 @@ dl_find_symbol(libhandle, symbolname) char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -289,7 +289,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/ext/DynaLoader/dl_os2.xs b/ext/DynaLoader/dl_os2.xs index 2c72be23ed..3042a002b2 100644 --- a/ext/DynaLoader/dl_os2.xs +++ b/ext/DynaLoader/dl_os2.xs @@ -126,9 +126,9 @@ dl_load_file(filename) #ifdef RTLD_LAZY mode = RTLD_LAZY; /* Solaris 2 */ #endif - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; - DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -145,10 +145,10 @@ dl_find_symbol(libhandle, symbolname) char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif - DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); - DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; @@ -173,7 +173,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs index 3f46ffc940..a646e116ab 100644 --- a/ext/DynaLoader/dl_vms.xs +++ b/ext/DynaLoader/dl_vms.xs @@ -126,7 +126,7 @@ findsym_handler(void *sig, void *mech) myvec[0] = args = usig[0] > 10 ? 9 : usig[0] - 1; while (--args) myvec[args] = usig[args]; _ckvmssts(sys$putmsg(myvec,copy_errmsg,0,0)); - DLDEBUG(2,fprintf(stderr,"findsym_handler: received\n\t%s\n",LastError)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "findsym_handler: received\n\t%s\n",LastError)); return SS$_CONTINUE; } @@ -177,11 +177,11 @@ dl_expandspec(filespec) dlfab.fab$b_fns = strlen(vmsspec); dlfab.fab$l_dna = 0; dlfab.fab$b_dns = 0; - DLDEBUG(1,fprintf(stderr,"dl_expand_filespec(%s):\n",vmsspec)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_expand_filespec(%s):\n",vmsspec)); /* On the first pass, just parse the specification string */ dlnam.nam$b_nop = NAM$M_SYNCHK; sts = sys$parse(&dlfab); - DLDEBUG(2,fprintf(stderr,"\tSYNCHK sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tSYNCHK sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; @@ -194,7 +194,7 @@ dl_expandspec(filespec) dlnam.nam$b_type + dlnam.nam$b_ver); deflen += dlnam.nam$b_type + dlnam.nam$b_ver; memcpy(vmsspec,dlnam.nam$l_name,dlnam.nam$b_name); - DLDEBUG(2,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsplit filespec: name = %.*s, default = %.*s\n", dlnam.nam$b_name,vmsspec,deflen,defspec)); /* . . . and go back to expand it */ dlnam.nam$b_nop = 0; @@ -202,7 +202,7 @@ dl_expandspec(filespec) dlfab.fab$b_dns = deflen; dlfab.fab$b_fns = dlnam.nam$b_name; sts = sys$parse(&dlfab); - DLDEBUG(2,fprintf(stderr,"\tname/default sys$parse = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tname/default sys$parse = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; @@ -210,14 +210,14 @@ dl_expandspec(filespec) else { /* Now find the actual file */ sts = sys$search(&dlfab); - DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$search = %d\n",sts)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; } else { ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl)); - DLDEBUG(1,fprintf(stderr,"\tresult = \\%.*s\\\n", + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "\tresult = \\%.*s\\\n", dlnam.nam$b_rsl,dlnam.nam$l_rsa)); } } @@ -242,16 +242,16 @@ dl_load_file(filespec) vmssts sts, failed = 0; void (*entry)(); - DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec)); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n",filespec)); specdsc.dsc$a_pointer = tovmsspec(filespec,vmsspec); specdsc.dsc$w_length = strlen(specdsc.dsc$a_pointer); - DLDEBUG(2,fprintf(stderr,"\tVMS-ified filespec is %s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n", specdsc.dsc$a_pointer)); New(7901,dlptr,1,struct libref); dlptr->name.dsc$b_dtype = dlptr->defspec.dsc$b_dtype = DSC$K_DTYPE_T; dlptr->name.dsc$b_class = dlptr->defspec.dsc$b_class = DSC$K_CLASS_S; sts = sys$filescan(&specdsc,namlst,0); - DLDEBUG(2,fprintf(stderr,"\tsys$filescan: returns %d, name is %.*s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tsys$filescan: returns %d, name is %.*s\n", sts,namlst[0].len,namlst[0].string)); if (!(sts & 1)) { failed = 1; @@ -267,21 +267,21 @@ dl_load_file(filespec) memcpy(dlptr->defspec.dsc$a_pointer + deflen, namlst[0].string + namlst[0].len, dlptr->defspec.dsc$w_length - deflen); - DLDEBUG(2,fprintf(stderr,"\tlibref = name: %s, defspec: %.*s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlibref = name: %s, defspec: %.*s\n", dlptr->name.dsc$a_pointer, dlptr->defspec.dsc$w_length, dlptr->defspec.dsc$a_pointer)); if (!(reqSVhndl = av_fetch(dl_require_symbols,0,FALSE)) || !(reqSV = *reqSVhndl)) { - DLDEBUG(2,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n")); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t@dl_require_symbols empty, returning untested libref\n")); } else { symdsc.dsc$w_length = SvCUR(reqSV); symdsc.dsc$a_pointer = SvPVX(reqSV); - DLDEBUG(2,fprintf(stderr,"\t$dl_require_symbols[0] = %.*s\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\t$dl_require_symbols[0] = %.*s\n", symdsc.dsc$w_length, symdsc.dsc$a_pointer)); sts = my_find_image_symbol(&(dlptr->name),&symdsc, &entry,&(dlptr->defspec)); - DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); if (!(sts&1)) { failed = 1; dl_set_error(sts,0); @@ -311,13 +311,13 @@ dl_find_symbol(librefptr,symname) void (*entry)(); vmssts sts; - DLDEBUG(1,fprintf(stderr,"dl_find_dymbol(%.*s,%.*s):\n", + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_find_dymbol(%.*s,%.*s):\n", thislib.name.dsc$w_length, thislib.name.dsc$a_pointer, symdsc.dsc$w_length,symdsc.dsc$a_pointer)); sts = my_find_image_symbol(&(thislib.name),&symdsc, &entry,&(thislib.defspec)); - DLDEBUG(2,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts)); - DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tentry point is %d\n", (unsigned long int) entry)); if (!(sts & 1)) { /* error message already saved by findsym_handler */ @@ -339,7 +339,7 @@ dl_install_xsub(perl_name, symref, filename="$Package") void * symref char * filename CODE: - DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); diff --git a/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c index 07ea3325b6..599dd37ea5 100644 --- a/ext/DynaLoader/dlutils.c +++ b/ext/DynaLoader/dlutils.c @@ -35,7 +35,7 @@ dl_generic_private_init() /* called by dl_*.xs dl_private_init() */ if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) dl_nonlazy = atoi(perl_dl_nonlazy); if (dl_nonlazy) - DLDEBUG(1,fprintf(stderr,"DynaLoader bind mode is 'non-lazy'\n")); + DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "DynaLoader bind mode is 'non-lazy'\n")); #ifdef DL_LOADONCEONLY if (!dl_loaded_files) dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ @@ -79,7 +79,7 @@ SaveError(pat, va_alist) /* Copy message into LastError (including terminating null char) */ strncpy(LastError, message, len) ; - DLDEBUG(2,fprintf(stderr,"DynaLoader: stored error msg '%s'\n",LastError)); + DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError)); } diff --git a/ext/FileHandle/FileHandle.xs b/ext/FileHandle/FileHandle.xs index 8b1c60eb25..413b312d4e 100644 --- a/ext/FileHandle/FileHandle.xs +++ b/ext/FileHandle/FileHandle.xs @@ -1,10 +1,11 @@ #include "EXTERN.h" +#define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" typedef int SysRet; -typedef FILE * InputStream; -typedef FILE * OutputStream; +typedef PerlIO * InputStream; +typedef PerlIO * OutputStream; static int not_here(s) @@ -64,35 +65,27 @@ SV * fgetpos(handle) InputStream handle CODE: -#ifdef HAS_FGETPOS if (handle) { Fpos_t pos; - fgetpos(handle, &pos); + PerlIO_getpos(handle, &pos); ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); } else { ST(0) = &sv_undef; errno = EINVAL; } -#else - ST(0) = (SV *) not_here("fgetpos"); -#endif SysRet fsetpos(handle, pos) InputStream handle SV * pos CODE: -#ifdef HAS_FSETPOS if (handle) - RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos)); + RETVAL = PerlIO_setpos(handle, (Fpos_t*)SvPVX(pos)); else { RETVAL = -1; errno = EINVAL; } -#else - RETVAL = (SysRet) not_here("fsetpos"); -#endif OUTPUT: RETVAL @@ -102,7 +95,7 @@ ungetc(handle, c) int c CODE: if (handle) - RETVAL = ungetc(c, handle); + RETVAL = PerlIO_ungetc(handle, c); else { RETVAL = -1; errno = EINVAL; @@ -114,7 +107,7 @@ OutputStream new_tmpfile(packname = "FileHandle") char * packname CODE: - RETVAL = tmpfile(); + RETVAL = PerlIO_tmpfile(); OUTPUT: RETVAL @@ -123,7 +116,7 @@ ferror(handle) InputStream handle CODE: if (handle) - RETVAL = ferror(handle); + RETVAL = PerlIO_error(handle); else { RETVAL = -1; errno = EINVAL; @@ -136,7 +129,7 @@ fflush(handle) OutputStream handle CODE: if (handle) - RETVAL = Fflush(handle); + RETVAL = PerlIO_flush(handle); else { RETVAL = -1; errno = EINVAL; @@ -149,9 +142,12 @@ setbuf(handle, buf) OutputStream handle char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; CODE: +#ifdef PERLIO_IS_STDIO if (handle) setbuf(handle, buf); - +#else + not_here("setbuf"); +#endif SysRet @@ -161,6 +157,7 @@ setvbuf(handle, buf, type, size) int type int size CODE: +#ifdef PERLIO_IS_STDIO #ifdef _IOFBF /* Should be HAS_SETVBUF once Configure tests for that */ if (handle) RETVAL = setvbuf(handle, buf, type, size); @@ -171,6 +168,9 @@ setvbuf(handle, buf, type, size) #else RETVAL = (SysRet) not_here("setvbuf"); #endif /* _IOFBF */ +#else + RETVAL = (SysRet) not_here("setvbuf"); +#endif OUTPUT: RETVAL diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs index 9dc09b2e01..82dce85cb1 100644 --- a/ext/IO/IO.xs +++ b/ext/IO/IO.xs @@ -1,13 +1,18 @@ #include "EXTERN.h" +#define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" + #ifdef I_UNISTD # include <unistd.h> #endif +#ifdef I_FCNTL +# include <fcntl.h> +#endif typedef int SysRet; -typedef FILE * InputStream; -typedef FILE * OutputStream; +typedef PerlIO * InputStream; +typedef PerlIO * OutputStream; static int not_here(s) @@ -62,12 +67,6 @@ IV *pval; #else return FALSE; #endif - if (strEQ(name, "SEEK_EOF")) -#ifdef SEEK_EOF - { *pval = SEEK_EOF; return TRUE; } -#else - return FALSE; -#endif break; } @@ -81,35 +80,27 @@ SV * fgetpos(handle) InputStream handle CODE: -#ifdef HAS_FGETPOS if (handle) { Fpos_t pos; - fgetpos(handle, &pos); + PerlIO_getpos(handle, &pos); ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); } else { ST(0) = &sv_undef; errno = EINVAL; } -#else - ST(0) = (SV *) not_here("IO::Seekable::fgetpos"); -#endif SysRet fsetpos(handle, pos) InputStream handle SV * pos CODE: -#ifdef HAS_FSETPOS if (handle) - RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos)); + RETVAL = PerlIO_setpos(handle, (Fpos_t*)SvPVX(pos)); else { RETVAL = -1; errno = EINVAL; } -#else - RETVAL = (SysRet) not_here("IO::Seekable::fsetpos"); -#endif OUTPUT: RETVAL @@ -119,7 +110,7 @@ OutputStream new_tmpfile(packname = "IO::File") char * packname CODE: - RETVAL = tmpfile(); + RETVAL = PerlIO_tmpfile(); OUTPUT: RETVAL @@ -141,7 +132,7 @@ ungetc(handle, c) int c CODE: if (handle) - RETVAL = ungetc(c, handle); + RETVAL = PerlIO_ungetc(handle, c); else { RETVAL = -1; errno = EINVAL; @@ -154,7 +145,7 @@ ferror(handle) InputStream handle CODE: if (handle) - RETVAL = ferror(handle); + RETVAL = PerlIO_error(handle); else { RETVAL = -1; errno = EINVAL; @@ -167,7 +158,7 @@ fflush(handle) OutputStream handle CODE: if (handle) - RETVAL = Fflush(handle); + RETVAL = PerlIO_flush(handle); else { RETVAL = -1; errno = EINVAL; @@ -181,9 +172,11 @@ setbuf(handle, buf) char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; CODE: if (handle) +#ifdef PERLIO_IS_STDIO setbuf(handle, buf); - - +#else + not_here("IO::Handle::setbuf"); +#endif SysRet setvbuf(handle, buf, type, size) @@ -192,6 +185,7 @@ setvbuf(handle, buf, type, size) int type int size CODE: +#ifdef PERLIO_IS_STDIO #ifdef _IOFBF /* Should be HAS_SETVBUF once Configure tests for that */ if (handle) RETVAL = setvbuf(handle, buf, type, size); @@ -202,6 +196,9 @@ setvbuf(handle, buf, type, size) #else RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); #endif /* _IOFBF */ +#else + not_here("IO::Handle::setvbuf"); +#endif OUTPUT: RETVAL diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index aaba77c056..f2086049cf 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -186,7 +186,7 @@ require Exporter; @FileHandle::ISA = qw(IO::Handle); -$VERSION = sprintf("%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/); +$VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/); @EXPORT_OK = qw( autoflush @@ -259,8 +259,6 @@ sub new_from_fd { IO::Handle::fdopen($fh, @_) or return undef; bless $fh, $class; - $fh->_ref_fd; - $fh; } # FileHandle::DESTROY use to call close(). This creates a problem diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm index 208be0cf53..ed8c2bb983 100644 --- a/ext/IO/lib/IO/Select.pm +++ b/ext/IO/lib/IO/Select.pm @@ -49,7 +49,9 @@ handle with the same C<fileno> is specified then only the last one is cached. =item remove ( HANDLES ) -Remove all the given handles from the object. +Remove all the given handles from the object. This method also works +by the C<fileno> of the handles. So the exact handles that were added +need not be passed, just handles that have an equivalent C<fileno> =item can_read ( [ TIMEOUT ] ) @@ -66,6 +68,12 @@ Same as C<can_read> except check for handles that can be written to. Same as C<can_read> except check for handles that have an error condition, for example EOF. +=item count () + +Returns the number of handles that the object will check for when +one of the C<can_> methods is called or the object is passed to +the C<select> static method. + =item select ( READ, WRITE, ERROR [, TIMEOUT ] ) C<select> is a static method, that is you call it with the package name @@ -132,12 +140,16 @@ $VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); # This is only so we can do version checking +sub VEC_BITS {0} +sub FD_COUNT {1} +sub FIRST_FD {2} + sub new { my $self = shift; my $type = ref($self) || $self; - my $vec = bless [''], $type; + my $vec = bless [undef,0], $type; $vec->add(@_) if @_; @@ -150,14 +162,19 @@ sub add my $vec = shift; my $f; + $vec->[VEC_BITS] = '' unless defined $vec->[VEC_BITS]; + foreach $f (@_) { my $fn = $f =~ /^\d+$/ ? $f : fileno($f); next unless defined $fn; - vec($vec->[0],$fn++,1) = 1; - $vec->[$fn] = $f; + vec($vec->[VEC_BITS],$fn,1) = 1; + $vec->[FD_COUNT] += 1 + unless defined $vec->[$fn+FIRST_FD]; + $vec->[$fn+FIRST_FD] = $f; } + $vec->[VEC_BITS] = undef unless $vec->count; } sub remove @@ -170,9 +187,11 @@ sub remove my $fn = $f =~ /^\d+$/ ? $f : fileno($f); next unless defined $fn; - vec($vec->[0],$fn++,1) = 0; - $vec->[$fn] = undef; + vec($vec->[VEC_BITS],$fn,1) = 0; + $vec->[$fn+FIRST_FD] = undef; + $vec->[FD_COUNT] -= 1; } + $vec->[VEC_BITS] = undef unless $vec->count; } sub can_read @@ -180,7 +199,7 @@ sub can_read my $vec = shift; my $timeout = shift; - my $r = $vec->[0]; + my $r = $vec->[VEC_BITS] or return (); select($r,undef,undef,$timeout) > 0 ? _handles($vec, $r) @@ -192,7 +211,7 @@ sub can_write my $vec = shift; my $timeout = shift; - my $w = $vec->[0]; + my $w = $vec->[VEC_BITS] or return (); select(undef,$w,undef,$timeout) > 0 ? _handles($vec, $w) @@ -204,13 +223,19 @@ sub has_error my $vec = shift; my $timeout = shift; - my $e = $vec->[0]; + my $e = $vec->[VEC_BITS] or return (); select(undef,undef,$e,$timeout) > 0 ? _handles($vec, $e) : (); } +sub count +{ + my $vec = shift; + $vec->[FD_COUNT]; +} + sub _max { my($a,$b,$c) = @_; @@ -231,28 +256,28 @@ sub select my($r,$w,$e,$t) = @_; my @result = (); - my $rb = defined $r ? $r->[0] : undef; - my $wb = defined $w ? $e->[0] : undef; - my $eb = defined $e ? $w->[0] : undef; + my $rb = defined $r ? $r->[VEC_BITS] : undef; + my $wb = defined $w ? $e->[VEC_BITS] : undef; + my $eb = defined $e ? $w->[VEC_BITS] : undef; if(select($rb,$wb,$eb,$t) > 0) { my @r = (); my @w = (); my @e = (); - my $i = _max(defined $r ? scalar(@$r) : 0, - defined $w ? scalar(@$w) : 0, - defined $e ? scalar(@$e) : 0); + my $i = _max(defined $r ? scalar(@$r)-1 : 0, + defined $w ? scalar(@$w)-1 : 0, + defined $e ? scalar(@$e)-1 : 0); - for( ; $i > 0 ; $i--) + for( ; $i >= FIRST_FD ; $i--) { - my $j = $i - 1; + my $j = $i - FIRST_FD; push(@r, $r->[$i]) - if defined $r->[$i] && vec($rb, $j, 1); + if defined $rb && defined $r->[$i] && vec($rb, $j, 1); push(@w, $w->[$i]) - if defined $w->[$i] && vec($wb, $j, 1); + if defined $wb && defined $w->[$i] && vec($wb, $j, 1); push(@e, $e->[$i]) - if defined $e->[$i] && vec($eb, $j, 1); + if defined $eb && defined $e->[$i] && vec($eb, $j, 1); } @result = (\@r, \@w, \@e); @@ -267,14 +292,15 @@ sub _handles my @h = (); my $i; - for($i = scalar(@$vec) - 1 ; $i > 0 ; $i--) + for($i = scalar(@$vec) - 1 ; $i >= FIRST_FD ; $i--) { next unless defined $vec->[$i]; push(@h, $vec->[$i]) - if vec($bits,$i - 1,1); + if vec($bits,$i - FIRST_FD,1); } @h; } 1; + diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index be81d9a64e..5f2a8ef76a 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -76,7 +76,8 @@ use Exporter; @ISA = qw(IO::Handle); # This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ... -$VERSION = do{my @r=(q$Revision: 1.8$=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; + +$VERSION = do{my @r=(q$Revision: 1.9 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; sub import { my $pkg = shift; @@ -131,7 +132,7 @@ sub connect { local($SIG{ALRM}) = $timeout ? sub { undef $fh; } : $SIG{ALRM} || 'DEFAULT'; - eval { + eval { croak 'connect: Bad address' if(@_ == 2 && !defined $_[1]); @@ -140,17 +141,17 @@ sub connect { $timeout = 0; } - my $ok = eval { connect($fh, $addr) }; + my $ok = connect($fh, $addr); alarm(0) if($timeout); - croak "connect: timeout" - unless defined $fh; - - undef $fh unless $ok; + croak "connect: timeout" + unless defined $fh; + undef $fh unless $ok; }; + $fh; } @@ -544,14 +545,14 @@ Graham Barr <Graham.Barr@tiuk.ti.com> =head1 REVISION -$Revision: 1.8 $ +$Revision: 1.9 $ The VERSION is derived from the revision turning each number after the first dot into a 2 digit number so - Revision 1.8 => VERSION 1.08 - Revision 1.2.3 => VERSION 1.0203 - + Revision 1.8 => VERSION 1.08 + Revision 1.2.3 => VERSION 1.0203 + =head1 COPYRIGHT Copyright (c) 1995 Graham Barr. All rights reserved. This program is free diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 928f68020b..5d9d63f897 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -233,7 +233,7 @@ PROTOTYPES: ENABLE BOOT: assert(maxo < OP_MASK_BUF_SIZE); - opset_len = (maxo / 8) + 1; + opset_len = (maxo + 7) / 8; if (opcode_debug >= 1) warn("opset_len %d\n", opset_len); op_names_init(); diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 3ba3c5b426..69849b1bcb 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -1,4 +1,5 @@ #include "EXTERN.h" +#define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" #include <ctype.h> @@ -245,13 +246,6 @@ char *cuserid _((char *)); #define waitpid(a,b,c) not_here("waitpid") #endif -#ifndef HAS_FGETPOS -#define fgetpos(a,b) not_here("fgetpos") -#endif -#ifndef HAS_FSETPOS -#define fsetpos(a,b) not_here("fsetpos") -#endif - #ifndef HAS_MBLEN #ifndef mblen #define mblen(a,b) not_here("mblen") diff --git a/ext/POSIX/mkposixman.pl b/ext/POSIX/mkposixman.pl new file mode 100644 index 0000000000..3daa1bff7b --- /dev/null +++ b/ext/POSIX/mkposixman.pl @@ -0,0 +1,1134 @@ +#!/tmp/perl5 -w +#!/tmp/perl5 + +# Ramrodded by Dean Roehrich. +# +# Submissions for function descriptions are needed. Don't write a tutorial, +# and don't repeat things that can be found in the system's manpages, +# just give a quick 2-3 line note and a one-line example. +# +# Check the latest version of the Perl5 Module List for Dean's current +# email address (listed as DMR). +# +my $VERS = 951129; # yymmdd + +local *main::XS; +local *main::PM; + +open( XS, "<POSIX.xs" ) || die "Unable to open POSIX.xs"; +open( PM, "<POSIX.pm" ) || die "Unable to open POSIX.pm"; +close STDOUT; +open( STDOUT, ">POSIX.pod" ) || die "Unable to open POSIX.pod"; + +print <<'EOQ'; +=head1 NAME + +POSIX - Perl interface to IEEE Std 1003.1 + +=head1 SYNOPSIS + + use POSIX; + use POSIX qw(setsid); + use POSIX qw(:errno_h :fcntl_h); + + printf "EINTR is %d\n", EINTR; + + $sess_id = POSIX::setsid(); + + $fd = POSIX::open($path, O_CREAT|O_EXCL|O_WRONLY, 0644); + # note: that's a filedescriptor, *NOT* a filehandle + +=head1 DESCRIPTION + +The POSIX module permits you to access all (or nearly all) the standard +POSIX 1003.1 identifiers. Many of these identifiers have been given Perl-ish +interfaces. Things which are C<#defines> in C, like EINTR or O_NDELAY, are +automatically exported into your namespace. All functions are only exported +if you ask for them explicitly. Most likely people will prefer to use the +fully-qualified function names. + +This document gives a condensed list of the features available in the POSIX +module. Consult your operating system's manpages for general information on +most features. Consult L<perlfunc> for functions which are noted as being +identical to Perl's builtin functions. + +The first section describes POSIX functions from the 1003.1 specification. +The second section describes some classes for signal objects, TTY objects, +and other miscellaneous objects. The remaining sections list various +constants and macros in an organization which roughly follows IEEE Std +1003.1b-1993. + +=head1 NOTE + +The POSIX module is probably the most complex Perl module supplied with +the standard distribution. It incorporates autoloading, namespace games, +and dynamic loading of code that's in Perl, C, or both. It's a great +source of wisdom. + +=head1 CAVEATS + +A few functions are not implemented because they are C specific. If you +attempt to call these, they will print a message telling you that they +aren't implemented, and suggest using the Perl equivalent should one +exist. For example, trying to access the setjmp() call will elicit the +message "setjmp() is C-specific: use eval {} instead". + +Furthermore, some evil vendors will claim 1003.1 compliance, but in fact +are not so: they will not pass the PCTS (POSIX Compliance Test Suites). +For example, one vendor may not define EDEADLK, or the semantics of the +errno values set by open(2) might not be quite right. Perl does not +attempt to verify POSIX compliance. That means you can currently +successfully say "use POSIX", and then later in your program you find +that your vendor has been lax and there's no usable ICANON macro after +all. This could be construed to be a bug. + +EOQ + +use strict; + + +my $constants = {}; +my $macros = {}; +my $packages = []; +my $posixpack = Package->new( 'POSIX' ); +my $descriptions = Description->new; + +get_constants( 'XS', $constants, $macros ); +get_functions( 'XS', $packages, $posixpack ); +get_PMfunctions( 'PM', $packages, $posixpack, $descriptions ); + + +# It is possible that the matches of setup_*() may depend on +# the matches of an earlier setup_*(). If you change the order, +# be careful that you're getting only what you want, and no more. +# +my $termios_flags = setup_termios( $constants ); +my $wait_stuff = setup_wait( $constants, $macros ); +my $stat = setup_file_char( $constants, $macros ); +my $port = setup_pat( $constants, '^_POSIX' ); +my $sc = setup_pat( $constants, '^_SC_' ); +my $pc = setup_pat( $constants, '^_PC_' ); +my $fcntl = setup_pat( $constants, '^([FO]_|FD_)' ); +my $sigs = setup_pat( $constants, '^(SIG|SA_)' ); +my $float = setup_pat( $constants, '^(L?DBL_|FLT_)' ); +my $locale = setup_pat( $constants, '^LC_' ); +my $stdio = setup_pat( $constants, '(^BUFSIZ$)|(^L_)|(^_IO...$)|(^EOF$)|(^FILENAME_MAX$)|(^TMP_MAX$)' ); +my $stdlib = setup_pat( $constants, '(^EXIT_)|(^MB_CUR_MAX$)|(^RAND_MAX$)' ); +my $limits = setup_pat( $constants, '(_MAX$)|(_MIN$)|(_BIT$)|(^MAX_)|(_BUF$)' ); +my $math = setup_pat( $constants, '^HUGE_VAL$' ); +my $time = setup_pat( $constants, '^CL' ); +my $unistd = setup_pat( $constants, '(_FILENO$)|(^SEEK_...$)|(^._OK$)' ); +my $errno = setup_pat( $constants, '^E' ); + +print_posix( $posixpack, $descriptions ); +print_classes( $packages, $constants, $termios_flags, $descriptions ); +print_misc( 'Pathname Constants', $pc ); +print_misc( 'POSIX Constants', $port ); +print_misc( 'System Configuration', $sc ); +print_misc( 'Errno', $errno ); +print_misc( 'Fcntl', $fcntl ); +print_misc( 'Float', $float ); +print_misc( 'Limits', $limits ); +print_misc( 'Locale', $locale ); +print_misc( 'Math', $math ); +print_misc( 'Signal', $sigs ); +print_misc( 'Stat', $stat ); +print_misc( 'Stdlib', $stdlib ); +print_misc( 'Stdio', $stdio ); +print_misc( 'Time', $time ); +print_misc( 'Unistd', $unistd ); +print_misc( 'Wait', $wait_stuff ); + +print_vers( $VERS ); + +dregs( $macros, $constants ); + +exit(0); + +Unimplemented. + +sub dregs { + my $macros = shift; + my $constants = shift; + + foreach (keys %$macros){ + warn "Unknown macro $_ in the POSIX.xs module.\n"; + } + foreach (keys %$constants){ + warn "Unknown constant $_ in the POSIX.xs module.\n"; + } +} + +sub get_constants { + no strict 'refs'; + my $fh = shift; + my $constants = shift; + my $macros = shift; + my $v; + + while(<$fh>){ + last if /^constant/; + } + while(<$fh>){ # }{{ + last if /^}/; + if( /return\s+([^;]+)/ ){ + $v = $1; + # skip non-symbols + if( $v !~ /^\d+$/ ){ + # remove any C casts + $v =~ s,\(.*?\)\s*(\w),$1,; + # is it a macro? + if( $v =~ s/(\(.*?\))// ){ + $macros->{$v} = $1; + } + else{ + $constants->{$v} = 1; + } + } + } + } +} + +Close the file. This uses file descriptors such as those obtained by calling +C<POSIX::open>. + + $fd = POSIX::open( "foo", &POSIX::O_RDONLY ); + POSIX::close( $fd ); + +sub get_functions { + no strict 'refs'; + my $fh = shift; + my $packages = shift; + my $posixpack = shift; + my $header = 0; + my $pack = ''; + my $prefix = ''; + my( $x, $y ); + my( $curfuncs, $curpack ); + my $ret; + + while(<$fh>){ + if( /^MODULE.*?PACKAGE\s*=\s*([^\s]+)/ ){ + $pack = $1; + $prefix = ''; + if( /PREFIX\s*=\s*([^\n]+)/ ){ + $prefix = $1; + } + #print "package($pack) prefix($prefix)\n"; + if( $pack eq 'POSIX' ){ + $curpack = $posixpack; + } + else{ + $curpack = Package->new( $pack ); + push @$packages, $curpack; + } + $curfuncs = $curpack->curfuncs; + next; + } + + chop; + # find function header + if( /^[^\s]/ && ! /^#/ ){ + $ret = /^SysRet/ ? 2 : 1; + chop($x = <$fh>); + next if( $pack eq 'POSIX' and $x =~ /^constant/ ); + $x =~ /^(.*?)\s*\((.*?)\)/; + ($x,$y) = ($1, $2); # func,sig + $x =~ s/^$prefix//; + $curfuncs->{$x} = $ret; + ++$header + } + # leave function header + else{ + $header = 0; + } + } +} + + +sub get_PMfunctions { + no strict 'refs'; + my $fh = shift; + my $packages = shift; + my $posixpack = shift; + my $desc = shift; + my $pack = ''; + my( $curfuncs, $curpack ); + my $y; + my $x; + my $sub = ''; + + # find the second package statement. + while(<$fh>){ + if( /^package\s+(.*?);/ ){ + $pack = $1; + last if $pack ne 'POSIX'; + } + } + + # Check if this package is already + # being used. + $curpack = ''; + foreach (@$packages){ + if( $_->name eq $pack ){ + $curpack = $_; + last; + } + } + # maybe start a new package. + if( $curpack eq '' ){ + $curpack = Package->new( $pack ); + push @$packages, $curpack; + } + $curfuncs = $curpack->curfuncs; + + # now fetch functions + while(<$fh>){ + if( /^package\s+(.*?);/ ){ + $pack = $1; + if( $pack eq 'POSIX' ){ + $curpack = $posixpack; + } + else{ + # Check if this package is already + # being used. + $curpack = ''; + foreach (@$packages){ + if( $_->name() eq $pack ){ + $curpack = $_; + last; + } + } + # maybe start a new package. + if( $curpack eq '' ){ + $curpack = Package->new( $pack ); + push @$packages, $curpack; + } + } + $curfuncs = $curpack->curfuncs; + next; + } + if( /^sub\s+(.*?)\s/ ){ + $sub = $1; + + # special cases + if( $pack eq 'POSIX::SigAction' and + $sub eq 'new' ){ + $curfuncs->{$sub} = 1; + } + elsif( $pack eq 'POSIX' and $sub eq 'perror' ){ + $curfuncs->{$sub} = 1; + } + + next; + } + if( /usage.*?\((.*?)\)/ ){ + $y = $1; + $curfuncs->{$sub} = 1; + next; + } + if( /^\s+unimpl\s+"(.*?)"/ ){ + $y = $1; + $y =~ s/, stopped//; + $desc->append( $pack, $sub, $y ); + $curfuncs->{$sub} = 1; + next; + } + if( /^\s+redef\s+"(.*?)"/ ){ + $x = $1; + $y = "Use method C<$x> instead"; + $desc->append( $pack, $sub, $y ); + $curfuncs->{$sub} = 1; + next; + } + } +} + +Retrieves the value of a configurable limit on a file or directory. This +uses file descriptors such as those obtained by calling C<POSIX::open>. + +The following will determine the maximum length of the longest allowable +pathname on the filesystem which holds C</tmp/foo>. + + $fd = POSIX::open( "/tmp/foo", &POSIX::O_RDONLY ); + $path_max = POSIX::fpathconf( $fd, &POSIX::_PC_PATH_MAX ); +Return the mantissa and exponent of a floating-point number. + + ($mantissa, $exponent) = POSIX::frexp( 3.14 ); +Get file status. This uses file descriptors such as those obtained by +calling C<POSIX::open>. The data returned is identical to the data from +Perl's builtin C<stat> function. + + $fd = POSIX::open( "foo", &POSIX::O_RDONLY ); + @stats = POSIX::fstat( $fd ); + +sub print_posix { + my $pack = shift; + my $desc = shift; + + print "=head1 FUNCTIONS\n\n"; + print "=over 8\n\n"; + dumpfuncs( $pack, $desc ); + print "=back\n\n"; +} + +sub print_classes { + my $packages = shift; + my $constants = shift; + my $termios = shift; + my $desc = shift; + my $pack; + my @pkgs; + + print "=head1 CLASSES\n\n"; + @pkgs = sort { $main::a->name() cmp $main::b->name() } @$packages; + while( @pkgs ){ + $pack = shift @pkgs; + print "=head2 ", $pack->name(), "\n\n"; + print "=over 8\n\n"; + + dumpfuncs( $pack, $desc ); + + if( $pack->name() =~ /termios/i ){ + dumpflags( $termios ); + } + print "=back\n\n"; + } +} + +sub setup_termios { + my $constants = shift; + my $obj; + + $obj = { + 'c_iflag field' => [qw( BRKINT ICRNL IGNBRK IGNCR IGNPAR + INLCR INPCK ISTRIP IXOFF IXON + PARMRK )], + 'c_oflag field' => [qw( OPOST )], + 'c_cflag field' => [qw( CLOCAL CREAD CSIZE CS5 CS6 CS7 CS8 + CSTOPB HUPCL PARENB PARODD )], + 'c_lflag field' => [qw( ECHO ECHOE ECHOK ECHONL ICANON + IEXTEN ISIG NOFLSH TOSTOP )], + 'c_cc field' => [qw( VEOF VEOL VERASE VINTR VKILL VQUIT + VSUSP VSTART VSTOP VMIN VTIME NCCS )], + 'Baud rate' => [], + 'Terminal interface' => [], + }; + # look for baud rates in constants, add to termios + foreach (keys %$constants){ + if( /^B\d+$/ ){ + push @{$obj->{'Baud rate'}}, $_; + } + } + # look for TC* in constants, add to termios + foreach (keys %$constants){ + if( /^TC/ ){ + push @{$obj->{'Terminal interface'}}, $_; + } + } + # trim the constants + foreach (keys %$obj){ + trim_hash( 'Constant', $obj->{$_}, $constants ); + } + return $obj; +} + + +sub dumpfuncs { + my $pack = shift; + my $desc = shift; + my $curfuncs = $pack->curfuncs; + my $pname = $pack->name; + my $func; + my @funcs = sort keys %$curfuncs; + + if( exists $curfuncs->{'new'} ){ # do new first + @funcs = grep( $_ ne 'new', @funcs ); + unshift @funcs, 'new'; + } + while( @funcs ){ + $func = shift @funcs; + if( $func eq 'DESTROY' ){ + next; # don't do DESTROY + } + print "=item $func\n\n"; + if( $desc->print( $pname, $func, $curfuncs->{$func} ) ){ + # if it was printed, note that + delete $curfuncs->{$func}; + } + } +} + +sub dumpflags { + my $flags = shift; + my $field; + + foreach $field (sort keys %$flags){ + print "=item $field values\n\n"; + print join( ' ', @{$flags->{$field}} ), "\n\n"; + } +} + +sub setup_wait { + my $constants = shift; + my $macros = shift; + my $obj; + + $obj = { + 'Macros' => [qw( WIFEXITED WEXITSTATUS WIFSIGNALED + WTERMSIG WIFSTOPPED WSTOPSIG )], + 'Constants' => [qw( WNOHANG WUNTRACED )], + }; + trim_hash( 'Constant', $obj->{Constants}, $constants ); + trim_hash( 'Macro', $obj->{Macros}, $macros ); + return $obj; +} + +sub setup_file_char { + my $constants = shift; + my $macros = shift; + my $obj; + + $obj = { + 'Macros' => [], + 'Constants' => [], + }; + # find S_* constants and add to object. + foreach (sort keys %$constants){ + if( /^S_/ ){ + push @{$obj->{'Constants'}}, $_; + } + } + # find S_* macros and add to object. + foreach (sort keys %$macros){ + if( /^S_/ ){ + push @{$obj->{'Macros'}}, $_; + } + } + # trim the hashes + trim_hash( 'Constant', $obj->{Constants}, $constants ); + trim_hash( 'Macro', $obj->{Macros}, $macros ); + return $obj; +} + + +sub setup_pat { + my $constants = shift; + my $pat = shift; + my $obj; + + $obj = { 'Constants' => [] }; + foreach (sort keys %$constants){ + if( /$pat/ ){ + push @{$obj->{'Constants'}}, $_; + } + } + trim_hash( 'Constant', $obj->{Constants}, $constants ); + return $obj; +} + +Get numeric formatting information. Returns a reference to a hash +containing the current locale formatting values. + +The database for the B<de> (Deutsch or German) locale. + + $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" ); + print "Locale = $loc\n"; + $lconv = POSIX::localeconv(); + print "decimal_point = ", $lconv->{decimal_point}, "\n"; + print "thousands_sep = ", $lconv->{thousands_sep}, "\n"; + print "grouping = ", $lconv->{grouping}, "\n"; + print "int_curr_symbol = ", $lconv->{int_curr_symbol}, "\n"; + print "currency_symbol = ", $lconv->{currency_symbol}, "\n"; + print "mon_decimal_point = ", $lconv->{mon_decimal_point}, "\n"; + print "mon_thousands_sep = ", $lconv->{mon_thousands_sep}, "\n"; + print "mon_grouping = ", $lconv->{mon_grouping}, "\n"; + print "positive_sign = ", $lconv->{positive_sign}, "\n"; + print "negative_sign = ", $lconv->{negative_sign}, "\n"; + print "int_frac_digits = ", $lconv->{int_frac_digits}, "\n"; + print "frac_digits = ", $lconv->{frac_digits}, "\n"; + print "p_cs_precedes = ", $lconv->{p_cs_precedes}, "\n"; + print "p_sep_by_space = ", $lconv->{p_sep_by_space}, "\n"; + print "n_cs_precedes = ", $lconv->{n_cs_precedes}, "\n"; + print "n_sep_by_space = ", $lconv->{n_sep_by_space}, "\n"; + print "p_sign_posn = ", $lconv->{p_sign_posn}, "\n"; + print "n_sign_posn = ", $lconv->{n_sign_posn}, "\n"; +Move the read/write file pointer. This uses file descriptors such as +those obtained by calling C<POSIX::open>. + + $fd = POSIX::open( "foo", &POSIX::O_RDONLY ); + $off_t = POSIX::lseek( $fd, 0, &POSIX::SEEK_SET ); + +sub print_vers { + my $vers = shift; + + print "=head1 CREATION\n\n"; + print "This document generated by $0 version $vers.\n\n"; +} + +sub print_misc { + my $hdr = shift; + my $obj = shift; + my $item; + + print "=head1 ", uc($hdr), "\n\n"; + print "=over 8\n\n"; + foreach $item (sort keys %$obj){ + print "=item $item\n\n"; + print join( ' ', @{$obj->{$item}}), "\n\n"; + } + print "=back\n\n"; +} + +sub trim_hash { + my $name = shift; + my $av = shift; + my $hv = shift; + + foreach (@$av){ + if( exists $hv->{$_} ){ + delete $hv->{$_}; + } + else{ + warn "$name $_ is not in the POSIX.xs module"; + } + } +} + +{ package Package; ## Package package + + sub new { + my $type = shift; + my $pack = shift || die; + my $self = [ $pack, {} ]; + bless $self, $type; + } + sub name { + my $self = shift; + $self->[0]; + } + sub curfuncs { + my $self = shift; + $self->[1]; + } + sub DESTROY { + my $self = shift; + my $pack = $self->name; + foreach (keys %{$self->curfuncs}){ + if( $_ eq 'DESTROY' ){ + next; # don't expect much on DESTROY + } + warn "Function ". $pack . "::$_ did not have a description.\n"; + } + } +} +{ package Description; ## Function description + + sub new { + my $type = shift; + my $self = {}; + bless $self, $type; + $self->fetch; + return $self; + } + sub fetch { + my $self = shift; + my $pack = ''; + my $c; + my( $sub, $as ); + + while(<main::DATA>){ + next if /^#/; + $sub = $as = ''; + if( /^==(.*)/ ){ + $pack = $1; + next; + } + if( /^=([^\+]+)\+\+/ ){ + $sub = $1; + $as = $sub; + } + elsif( /^=([^\+]+)\+C/ ){ + $sub = $1; + $as = 'C'; + } + elsif( /^=([^\+]+)\+(\w+)/ ){ + $sub = $1; + $as = $2; + } + elsif( /^=(.*)/ ){ + $sub = $1; + } + + if( $sub ne '' ){ + $sub = $1; + $self->{$pack."::$sub"} = ''; + $c = \($self->{$pack."::$sub"}); + if( $as eq 'C' ){ + $$c .= "This is identical to the C function C<$sub()>.\n"; + } + elsif( $as ne '' ){ + $$c .= "This is identical to Perl's builtin C<$as()> function.\n"; + } + next; + } + $$c .= $_; + } + } + sub DESTROY { + my $self = shift; + foreach (keys %$self){ + warn "Function $_ is not in the POSIX.xs module.\n"; + } + } + sub append { + my $self = shift; + my $pack = shift; + my $sub = shift; + my $str = shift || die; + + if( exists $self->{$pack."::$sub"} ){ + $self->{$pack."::$sub"} .= "\n$str.\n"; + } + else{ + $self->{$pack."::$sub"} = "$str.\n"; + } + } + sub print { + my $self = shift; + my $pack = shift; + my $sub = shift; + my $rtype = shift || die; + my $ret = 0; + + if( exists $self->{$pack."::$sub"} ){ + if( $rtype > 1 ){ + $self->{$pack."::$sub"} =~ s/identical/similar/; + } + print $self->{$pack."::$sub"}, "\n"; + delete $self->{$pack."::$sub"}; + if( $rtype > 1 ){ + print "Returns C<undef> on failure.\n\n"; + } + $ret = 1; + } + $ret; + } +} + +Create an interprocess channel. This returns file descriptors like those +returned by C<POSIX::open>. + + ($fd0, $fd1) = POSIX::pipe(); + POSIX::write( $fd0, "hello", 5 ); + POSIX::read( $fd1, $buf, 5 ); +Read from a file. This uses file descriptors such as those obtained by +calling C<POSIX::open>. If the buffer C<$buf> is not large enough for the +read then Perl will extend it to make room for the request. + + $fd = POSIX::open( "foo", &POSIX::O_RDONLY ); + $bytes = POSIX::read( $fd, $buf, 3 ); +This is similar to the C function C<setpgid()>. +Detailed signal management. This uses C<POSIX::SigAction> objects for the +C<action> and C<oldaction> arguments. Consult your system's C<sigaction> +manpage for details. + +Synopsis: + + sigaction(sig, action, oldaction = 0) +Install a signal mask and suspend process until signal arrives. This uses +C<POSIX::SigSet> objects for the C<signal_mask> argument. Consult your +system's C<sigsuspend> manpage for details. + +Synopsis: + + sigsuspend(signal_mask) +This is identical to Perl's builtin C<sprintf()> function. +Convert date and time information to string. Returns the string. + +Synopsis: + + strftime(fmt, sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = 0) + +The month (C<mon>), weekday (C<wday>), and yearday (C<yday>) begin at zero. +I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The +year (C<year>) is given in years since 1900. I.e. The year 1995 is 95; the +year 2001 is 101. Consult your system's C<strftime()> manpage for details +about these and the other arguments. + +The string for Tuesday, December 12, 1995. + + $str = POSIX::strftime( "%A, %B %d, %Y", 0, 0, 0, 12, 11, 95, 2 ); + print "$str\n"; +String transformation. Returns the transformed string. + + $dst = POSIX::strxfrm( $src ); +Get name of current operating system. + + ($sysname, $nodename, $release, $version, $machine ) = POSIX::uname(); +Returns the current file position, in bytes. + + $pos = $fh->tell; +Get terminal control attributes. + +Obtain the attributes for stdin. + + $termios->getattr() + +Obtain the attributes for stdout. + + $termios->getattr( 1 ) +Set terminal control attributes. + +Set attributes immediately for stdout. + + $termios->setattr( 1, &POSIX::TCSANOW ); + +__END__ +########## +==POSIX::SigSet +=new +Create a new SigSet object. This object will be destroyed automatically +when it is no longer needed. Arguments may be supplied to initialize the +set. + +Create an empty set. + + $sigset = POSIX::SigSet->new; + +Create a set with SIGUSR1. + + $sigset = POSIX::SigSet->new( &POSIX::SIGUSR1 ); +=addset +Add a signal to a SigSet object. + + $sigset->addset( &POSIX::SIGUSR2 ); +=delset +Remove a signal from the SigSet object. + + $sigset->delset( &POSIX::SIGUSR2 ); +=emptyset +Initialize the SigSet object to be empty. + + $sigset->emptyset(); +=fillset +Initialize the SigSet object to include all signals. + + $sigset->fillset(); +=ismember +Tests the SigSet object to see if it contains a specific signal. + + if( $sigset->ismember( &POSIX::SIGUSR1 ) ){ + print "contains SIGUSR1\n"; + } +########## +==POSIX::Termios +=new +Create a new Termios object. This object will be destroyed automatically +when it is no longer needed. + + $termios = POSIX::Termios->new; +=getiflag +Retrieve the c_iflag field of a termios object. + + $c_iflag = $termios->getiflag; +=getoflag +Retrieve the c_oflag field of a termios object. + + $c_oflag = $termios->getoflag; +=getcflag +Retrieve the c_cflag field of a termios object. + + $c_cflag = $termios->getcflag; +=getlflag +Retrieve the c_lflag field of a termios object. + + $c_lflag = $termios->getlflag; +=getcc +Retrieve a value from the c_cc field of a termios object. The c_cc field is +an array so an index must be specified. + + $c_cc[1] = $termios->getcc(1); +=getospeed +Retrieve the output baud rate. + + $ospeed = $termios->getospeed; +=getispeed +Retrieve the input baud rate. + + $ispeed = $termios->getispeed; +=setiflag +Set the c_iflag field of a termios object. + + $termios->setiflag( &POSIX::BRKINT ); +=setoflag +Set the c_oflag field of a termios object. + + $termios->setoflag( &POSIX::OPOST ); +=setcflag +Set the c_cflag field of a termios object. + + $termios->setcflag( &POSIX::CLOCAL ); +=setlflag +Set the c_lflag field of a termios object. + + $termios->setlflag( &POSIX::ECHO ); +=setcc +Set a value in the c_cc field of a termios object. The c_cc field is an +array so an index must be specified. + + $termios->setcc( 1, &POSIX::VEOF ); +=setospeed +Set the output baud rate. + + $termios->setospeed( &POSIX::B9600 ); +=setispeed +Set the input baud rate. + + $termios->setispeed( &POSIX::B9600 ); +## +=setattr +=getattr +########## +==FileHandle +=new +=new_from_fd +=flush +=getc +=ungetc +=seek +=setbuf +=error +=clearerr +=tell +=getpos +=gets +=close +=new_tmpfile +=eof +=fileno +=setpos +=setvbuf +########## +==POSIX +=tolower+lc +=toupper+uc +=remove+unlink +=fabs+abs +=strstr+index +## +=closedir++ +=readdir++ +=rewinddir++ +=fcntl++ +=getgrgid++ +=getgrnam++ +=atan2++ +=cos++ +=exp++ +=abs++ +=log++ +=sin++ +=sqrt++ +=getpwnam++ +=getpwuid++ +=kill++ +=getc++ +=rename++ +=exit++ +=system++ +=chmod++ +=mkdir++ +=stat++ +=umask++ +=gmtime++ +=localtime++ +=time++ +=alarm++ +=chdir++ +=chown++ +=fork++ +=getlogin++ +=getpgrp++ +=getppid++ +=link++ +=rmdir++ +=sleep++ +=unlink++ +=utime++ +## +=perror+C +=pause+C +=tzset+C +=difftime+C +=ctime+C +=clock+C +=asctime+C +=strcoll+C +=abort+C +=tcgetpgrp+C +=setsid+C +=_exit+C +=tanh+C +=tan+C +=sinh+C +=log10+C +=ldexp+C +=fmod+C +=floor+C +=cosh+C +=ceil+C +=atan+C +=asin+C +=acos+C +## +=isatty +Returns a boolean indicating whether the specified filehandle is connected +to a tty. +=setuid +Sets the real user id for this process. +=setgid +Sets the real group id for this process. +=getpid +Returns the process's id. +=getuid +Returns the user's id. +=getegid +Returns the effective group id. +=geteuid +Returns the effective user id. +=getgid +Returns the user's real group id. +=getgroups +Returns the ids of the user's supplementary groups. +=getcwd +Returns the name of the current working directory. +=strerror +Returns the error string for the specified errno. +=getenv +Returns the value of the specified enironment variable. +=getchar +Returns one character from STDIN. +=raise +Sends the specified signal to the current process. +=gets +Returns one line from STDIN. +=printf +Prints the specified arguments to STDOUT. +=rewind +Seeks to the beginning of the file. +## +=tmpnam +Returns a name for a temporary file. + + $tmpfile = POSIX::tmpnam(); +=cuserid +Get the character login name of the user. + + $name = POSIX::cuserid(); +=ctermid +Generates the path name for controlling terminal. + + $path = POSIX::ctermid(); +=times +The times() function returns elapsed realtime since some point in the past +(such as system startup), user and system times for this process, and user +and system times used by child processes. All times are returned in clock +ticks. + + ($realtime, $user, $system, $cuser, $csystem) = POSIX::times(); + +Note: Perl's builtin C<times()> function returns four values, measured in +seconds. +=pow +Computes $x raised to the power $exponent. + + $ret = POSIX::pow( $x, $exponent ); +=errno +Returns the value of errno. + + $errno = POSIX::errno(); +=sysconf +Retrieves values of system configurable variables. + +The following will get the machine's clock speed. + + $clock_ticks = POSIX::sysconf( &POSIX::_SC_CLK_TCK ); +=pathconf +Retrieves the value of a configurable limit on a file or directory. + +The following will determine the maximum length of the longest allowable +pathname on the filesystem which holds C</tmp>. + + $path_max = POSIX::pathconf( "/tmp", &POSIX::_PC_PATH_MAX ); +=access +Determines the accessibility of a file. + + if( POSIX::access( "/", &POSIX::R_OK ) ){ + print "have read permission\n"; + } +=setlocale +Modifies and queries program's locale. + +The following will set the traditional UNIX system locale behavior. + +This document generated by ./mkposixman.PL version 19951212. +## +=waitpid +=wait +=fstat +=sprintf +=opendir +=creat +=ttyname +=tzname +=fpathconf +=mktime +=tcsendbreak +=tcflush +=tcflow +=tcdrain +=tcsetpgrp +=mkfifo +=strxfrm +=wctomb +=wcstombs +=mbtowc +=mbstowcs +=mblen +=write +=uname +=setpgid +=read +=pipe +=nice +=lseek +=dup2 +=dup +=close +=sigsuspend +=sigprocmask +=sigpending +=sigaction +=modf +=frexp +=localeconv +=open +=isxdigit +=isupper +=isspace +=ispunct +=isprint +=isgraph +=isdigit +=iscntrl +=isalpha +=isalnum +=islower +=assert +=strftime +########## +==POSIX::SigAction +=new +Creates a new SigAction object. This object will be destroyed automatically +when it is no longer needed. diff --git a/global.sym b/global.sym index 3db71f1417..5f0ef52bbe 100644 --- a/global.sym +++ b/global.sym @@ -40,11 +40,14 @@ curcop curcopdb curinterp curpad +cv_const_sv dc +debug dec_amg di div_amg div_ass_amg +do_undump ds egid envgv @@ -241,9 +241,10 @@ char* name; /* Failed obvious case - look for SUPER as last element of stash's name */ char *packname = HvNAME(stash); STRLEN len = strlen(packname); - if ((len -= 7) >= 0 && strEQ(packname+len,"::SUPER")) { + if (len >= 7 && strEQ(packname+len-7,"::SUPER")) { /* Now look for @.*::SUPER::ISA */ GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); + len -= 7; if (!gvp || (gv = *gvp) == (GV*)&sv_undef || !GvAV(gv)) { /* No @ISA in package ending in ::SUPER - drop suffix and see if there is an @ISA there @@ -20,7 +20,7 @@ #define Null(type) ((type)NULL) #define Nullch Null(char*) -#define Nullfp Null(FILE*) +#define Nullfp Null(PerlIO*) #define Nullsv Null(SV*) #ifdef TRUE diff --git a/hints/README.NeXT b/hints/README.NeXT new file mode 100644 index 0000000000..3e1a461913 --- /dev/null +++ b/hints/README.NeXT @@ -0,0 +1,56 @@ +OPENSTEP +-------- + +Support for OPENSTEP was added. Perl will build with as shared library. To build and install it, use this sequence: + +cd <wherever your perl source is> +sh Configure -des +DYLD_LIBRARY_PATH=`pwd`; export DYLD_LIBRARY_PATH +make +make test +make install + + +Depending on your shell, you might have to use + + setenv DYLD_LIBRARY_PATH `pwd` + +instead of + + DYLD_LIBRARY_PATH=`pwd`; export DYLD_LIBRARY_PATH + +Note: +During compilation/linking there are going to be some warnings, they do not seem to have any ill effects. + +Perl is going to be installed below the path /usr/local/OPENSTEP. This is done so that binaries for NEXTSTEP (3.2, 3.3 etc) will not be overwritten, since the OPENSTEP binaries will not work on those systems. Below is a part of my .zshrc file, that makes sure that the new OPENSTEP binaries are used on OPENSTEP: + +############################## +if(fgrep -s 'OPENSTEP 4.' /usr/lib/NextStep/software_version ) +then +path=(. /etc /usr/etc ~/Unix/bin /usr/local/OPENSTEP/bin /usr/local/bin /usr/local/netpbm/bin /usr/ucb /bin /usr/bin /usr/sybase/bin ~/Apps /LocalApps /NextApps /NextAdmin /NextDeveloper/Demos) +else +path=(. /etc /usr/etc ~/Unix/bin /usr/local/bin /usr/local/netpbm/bin /usr/ucb /bin /usr/bin /usr/sybase/bin ~/Apps /LocalApps /NextApps /NextAdmin /NextDeveloper/Demos) +fi +############################## + +You can change the installation path by changing 'prefix' in hints/next_4.sh before you run Configure. + + + +NEXTSTEP +-------- + +The hints file for NEXTSTEP (hints/next_3.sh) was changed: + +- Support for MAB was added +- perl's malloc is used now; this should take care of some problems with NEXTSTEP 3.2 + +perl should build and install fine with this sequence: + +cd <wherever your perl source is> +sh Configure -des +make +make test +make install + + diff --git a/hints/next_3.sh b/hints/next_3.sh index e9f616a3f3..38ad0ec7cc 100644 --- a/hints/next_3.sh +++ b/hints/next_3.sh @@ -1,11 +1,12 @@ -# This file has been put together by Anno Siegel <siegel@zrz.TU-Berlin.DE> -# and Andreas Koenig <k@franz.ww.TU-Berlin.DE>. Comments, questions, and -# improvements welcome! +# This file has been put together by Anno Siegel <siegel@zrz.TU-Berlin.DE>, +# Andreas Koenig <k@franz.ww.TU-Berlin.DE> and Gerd Knops <gerti@BITart.com>. +# Comments, questions, and improvements welcome! # # These hints work for NeXT 3.2 and 3.3. 3.0 has it's own # special hint file. +# -ccflags='-DUSE_NEXT_CTYPE' +ccflags='-DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC' POSIX_cflags='ccflags="-posix $ccflags"' ldflags='-u libsys_s' libswanted='dbm gdbm db' @@ -15,7 +16,12 @@ lddlflags='-nostdlib -r' # using GNU cc and try to specify -fpic for cccdlflags. cccdlflags=' ' +# +# Change the line below if you do not want to build 'quad-fat' +# binaries +# mab='-arch m68k -arch i386 -arch hppa -arch sparc' + archname='next-fat' ld='cc' @@ -23,20 +29,48 @@ i_utime='undef' groupstype='int' direntrytype='struct direct' d_strcoll='undef' + +###################################################################### +# THE MALLOC STORY +###################################################################### +# 1994: # the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails # with Larry's malloc on NS 3.2 due to broken sbrk() -usemymalloc='n' +# +# setting usemymalloc='n' was the solution back then. Later came +# reports that perl would run unstable on 3.2: +# +# From about perl5.002beta1h perl became unstable on the +# NeXT. Intermittent coredumps were frequent on 3.2 OS. There were +# reports, that the developer version of 3.3 didn't have problems, so it +# seemed pretty obvious that we had to work around an malloc bug in 3.2. +# This hints file reflects a patch to perl5.002_01 that introduces a +# home made sbrk routine (remember, NeXT's sbrk _never_ worked). This +# sbrk makes it possible to run perl with its own malloc. Thanks to +# Ilya who showed me the way to his sbrk for OS/2!! +# andreas koenig, 1996-06-16 +# +# So, this hintsfile is using perl's malloc. If you want to turn perl's +# malloc off, you need to change remove '-DUSE_PERL_SBRK' and +# '-DHIDEMYMALLOC' from the ccflags above and set usemymalloc below +# to 'n'. +# +###################################################################### +usemymalloc='y' + d_uname='define' d_setpgid='define' d_setsid='define' d_tcgetpgrp='define' d_tcsetpgrp='define' + # # On some NeXT machines, the timestamp put by ranlib is not correct, and # this may cause useless recompiles. Fix that by adding a sleep before # running ranlib. The '5' is an empirical number that's "long enough." -# (Thanks to Andreas Koenig <k@franz.ww.tu-berlin.de>) +# ranlib='sleep 5; /bin/ranlib' + # # There where reports that the compiler on HPPA machines # fails with the -O flag on pp.c. diff --git a/hints/next_3_2.sh b/hints/next_3_2.sh deleted file mode 100644 index 37bbf1694b..0000000000 --- a/hints/next_3_2.sh +++ /dev/null @@ -1,64 +0,0 @@ -# This file has been put together by Anno Siegel <siegel@zrz.TU-Berlin.DE> -# and Andreas Koenig <k@franz.ww.TU-Berlin.DE>. Comments, questions, and -# improvements welcome! -# -# These hints are intended for NeXT 3.2. - -# From about perl5.002beta1h perl became unstable on the -# NeXT. Intermittent coredumps were frequent on 3.2 OS. There were -# reports, that the developer version of 3.3 didn't have problems, so it -# seemed pretty obvious that we had to work around an malloc bug in 3.2. -# This hints file reflects a patch to perl5.002_01 that introduces a -# home made sbrk routine (remember, NeXT's sbrk _never_ worked). This -# sbrk makes it possible to run perl with its own malloc. Thanks to -# Ilya who showed me the way to his sbrk for OS/2!! -# andreas koenig, 1996-06-16 - -ccflags='-DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC' -POSIX_cflags='ccflags="-posix $ccflags"' -ldflags='-u libsys_s' -libswanted='dbm gdbm db' - -lddlflags='-r' -# Give cccdlflags an empty value since Configure will detect we are -# using GNU cc and try to specify -fpic for cccdlflags. -cccdlflags=' ' - -i_utime='undef' -groupstype='int' -direntrytype='struct direct' -d_strcoll='undef' - -# the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails -# with Larry's malloc on NS 3.2 due to broken sbrk() -###################################################################### -# above comment should stay here, but is not longer of importance # -# with -DUSE_PERL_SBRK and -DHIDEMYMALLOC we can now say 'yes' to # -# usemymalloc. We call this hintsfile next_3_2.sh, so folks with 3.3 # -# can decide what they prefer. Actually folks with 3.3 "user" version# -# will also need this hintsfile, but how can I discern which 3.3 it # -# is? # -###################################################################### -usemymalloc='y' - -d_uname='define' -d_setpgid='define' -d_setsid='define' -d_tcgetpgrp='define' -d_tcsetpgrp='define' - -# -# On some NeXT machines, the timestamp put by ranlib is not correct, and -# this may cause useless recompiles. Fix that by adding a sleep before -# running ranlib. The '5' is an empirical number that's "long enough." -# -ranlib='sleep 5; /bin/ranlib' - - -# -# There where reports that the compiler on HPPA machines -# fails with the -O flag on pp.c. -# -if [ `arch` = "hppa" ]; then -pp_cflags='optimize="-g"' -fi diff --git a/hints/next_3_3.sh b/hints/next_3_3.sh deleted file mode 100644 index e5dc1fd308..0000000000 --- a/hints/next_3_3.sh +++ /dev/null @@ -1,69 +0,0 @@ -# This file has been put together by Anno Siegel <siegel@zrz.TU-Berlin.DE> -# and Andreas Koenig <k@franz.ww.TU-Berlin.DE>. Comments, questions, and -# improvements welcome! -# - -# These hints are intended for NeXT 3.3. If you're running the 3.3 -# "user" version of the NeXT OS, you should not change the malloc -# related hints (USE_PERL_SBRK, HIDEMYMALLOC, usemymalloc). If you're -# running the 3.3 "dev" version of the OS, I do not know what to -# recommend (I have no 3.3 dev). - -# From about perl5.002beta1h perl became unstable on the -# NeXT. Intermittent coredumps were frequent on 3.2 OS. There were -# reports, that the developer version of 3.3 didn't have problems, so it -# seemed pretty obvious that we had to work around an malloc bug in 3.2. -# This hints file reflects a patch to perl5.002_01 that introduces a -# home made sbrk routine (remember, NeXT's sbrk _never_ worked). This -# sbrk makes it possible to run perl with its own malloc. Thanks to -# Ilya who showed me the way to his sbrk for OS/2!! -# andreas koenig, 1996-06-16 - -ccflags='-DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC' -POSIX_cflags='ccflags="-posix $ccflags"' -ldflags='-u libsys_s' -libswanted='dbm gdbm db' - -lddlflags='-r' -# Give cccdlflags an empty value since Configure will detect we are -# using GNU cc and try to specify -fpic for cccdlflags. -cccdlflags=' ' - -i_utime='undef' -groupstype='int' -direntrytype='struct direct' -d_strcoll='undef' - -# the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails -# with Larry's malloc on NS 3.2 due to broken sbrk() -###################################################################### -# above comment should stay here, but is not longer of importance # -# with -DUSE_PERL_SBRK and -DHIDEMYMALLOC we can now say 'yes' to # -# usemymalloc. We call this hintsfile next_3_2.sh, so folks with 3.3 # -# can decide what they prefer. Actually folks with 3.3 "user" version# -# will also need this hintsfile, but how can I discern which 3.3 it # -# is? # -###################################################################### -usemymalloc='y' - -d_uname='define' -d_setpgid='define' -d_setsid='define' -d_tcgetpgrp='define' -d_tcsetpgrp='define' - -# -# On some NeXT machines, the timestamp put by ranlib is not correct, and -# this may cause useless recompiles. Fix that by adding a sleep before -# running ranlib. The '5' is an empirical number that's "long enough." -# -ranlib='sleep 5; /bin/ranlib' - - -# -# There where reports that the compiler on HPPA machines -# fails with the -O flag on pp.c. -# -if [ `arch` = "hppa" ]; then -pp_cflags='optimize="-g"' -fi diff --git a/hints/next_4.sh b/hints/next_4.sh index 0e6b7e0271..70438dd4a2 100644 --- a/hints/next_4.sh +++ b/hints/next_4.sh @@ -1,4 +1,4 @@ -# Posix support has been removed from NextStep, expect test/POSIX to fail +###################################################################### # # IMPORTANT: before you run 'make', you need to enter one of these two # lines (depending on your shell): @@ -6,6 +6,10 @@ # or # setenv DYLD_LIBRARY_PATH `pwd` # +###################################################################### + +# Posix support has been removed from NextStep +# useposix='undef' altmake='gnumake' @@ -14,18 +18,28 @@ libswanted=' ' libc='/NextLibrary/Frameworks/System.framework/System' isnext_4='define' + +# +# Change the line below if you do not want to build 'quad-fat' +# binaries +# mab='-arch m68k -arch i386 -arch sparc' ldflags='-dynamic -prebind' lddlflags='-dynamic -bundle -undefined suppress' -ccflags='-dynamic -fno-common -DUSE_NEXT_CTYPE' +ccflags='-dynamic -fno-common -DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC' cccdlflags='none' ld='cc' -optimize='-g -O' +#optimize='-g -O' d_shrplib='define' dlext='bundle' so='dylib' +# +# The default prefix would be '/usr/local'. But since many people are +# likely to have still 3.3 machines on their network, we do not want +# to overwrite possibly existing 3.3 binaries. +# prefix='/usr/local/OPENSTEP' #archlib='/usr/lib/perl5' #archlibexp='/usr/lib/perl5' @@ -37,9 +51,33 @@ i_utime='undef' groupstype='int' direntrytype='struct direct' +###################################################################### +# THE MALLOC STORY +###################################################################### +# 1994: # the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails # with Larry's malloc on NS 3.2 due to broken sbrk() -usemymalloc='n' +# +# setting usemymalloc='n' was the solution back then. Later came +# reports that perl would run unstable on 3.2: +# +# From about perl5.002beta1h perl became unstable on the +# NeXT. Intermittent coredumps were frequent on 3.2 OS. There were +# reports, that the developer version of 3.3 didn't have problems, so it +# seemed pretty obvious that we had to work around an malloc bug in 3.2. +# This hints file reflects a patch to perl5.002_01 that introduces a +# home made sbrk routine (remember, NeXT's sbrk _never_ worked). This +# sbrk makes it possible to run perl with its own malloc. Thanks to +# Ilya who showed me the way to his sbrk for OS/2!! +# andreas koenig, 1996-06-16 +# +# So, this hintsfile is using perl's malloc. If you want to turn perl's +# malloc off, you need to change remove '-DUSE_PERL_SBRK' and +# '-DHIDEMYMALLOC' from the ccflags above and set usemymalloc below +# to 'n'. +# +###################################################################### +usemymalloc='y' clocktype='int' # diff --git a/hints/os2.sh b/hints/os2.sh index 1652cb7b2e..91138f4f22 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -16,6 +16,8 @@ bin_sh=`../UU/loc sh.exe /bin c:/bin d:/bin e:/bin f:/bin g:/bin h:/bin /bin` echo "####### Shell found at $bin_sh #############" >&4 +sh="$bin_sh" +startsh="#!$bin_sh" #osname="OS/2" sysman=`../UU/loc . /man/man1 c:/man/man1 c:/usr/man/man1 d:/man/man1 d:/usr/man/man1 e:/man/man1 e:/usr/man/man1 f:/man/man1 f:/usr/man/man1 g:/man/man1 g:/usr/man/man1 /usr/man/man1` @@ -74,10 +76,10 @@ else ar='emxomfar' plibext='.lib' d_fork='undef' - lddlflags='-Zdll -Zomf -Zcrtdll' + lddlflags='-Zdll -Zomf -Zmt -Zcrtdll' # Recursive regmatch may eat 2.5M of stack alone. - ldflags='-Zexe -Zomf -Zcrtdll -Zstack 32000' - ccflags='-Zomf -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS' + ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000' + ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS' use_clib='c_import' usedl='define' fi @@ -162,3 +164,35 @@ d_setprior='define' # Commented: #startsh='extproc ksh\\n#! sh' + +# Now install the external modules. We are in the ./hints directory. + +cd ../os2/OS2 + +if ! test -d ../../ext/OS2 ; then + mkdir ../../ext/OS2 +fi + +cp -rfu * ../../ext/OS2/ + +# Install tests: + +for xxx in * ; do + if $test -d $xxx/t; then + cp -uf $xxx/t/*.t ../../t/lib + else + if $test -d $xxx; then + cd $xxx + for yyy in * ; do + if $test -d $yyy/t; then + cp -uf $yyy/t/*.t ../../t/lib + fi + done + cd .. + fi + fi +done + + +# Now go back +cd ../../hints diff --git a/interp.sym b/interp.sym index a2f04c706d..33fb2c7b43 100644 --- a/interp.sym +++ b/interp.sym @@ -31,7 +31,6 @@ dbargs debdelim debname debstash -debug defgv defoutgv defstash @@ -40,7 +39,6 @@ diehook dirty dlevel dlmax -do_undump doextract doswitches dowarn diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index 341786da91..b70659a41c 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -1147,8 +1147,8 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) foreach $name ($self->lsdir($self->curdir)){ next if $name eq $self->curdir or $name eq $self->updir or $ignore{$name}; next unless $self->libscan($name); - next if -l $name; # We do not support symlinks at all if (-d $name){ + next if -l $name; # We do not support symlinks at all $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL")); } elsif ($name =~ /\.xs$/){ my($c); ($c = $name) =~ s/\.xs$/.c/; @@ -1365,14 +1365,11 @@ sub init_main { # It may also edit @modparts if required. if (defined &DynaLoader::mod2fname) { $modfname = &DynaLoader::mod2fname(\@modparts); - } elsif ($Is_OS2) { # Need manual correction if run with miniperl:-( - $modfname = substr($modfname, 0, 7) . '_'; - } - + } ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!([\w:]+::)?(\w+)$! ; - if (defined &DynaLoader::mod2fname or $Is_OS2) { + if (defined &DynaLoader::mod2fname) { # As of 5.001m, dl_os2 appends '_' $self->{DLBASE} = $modfname; } else { @@ -2609,14 +2606,14 @@ sub static_lib { my(@m); push(@m, <<'END'); $(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists + $(RM_RF) $@ END # If this extension has it's own library (eg SDBM_File) # then copy that to $(INST_STATIC) and add $(OBJECT) into it. push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB}; push @m, -q{ $(RM_RF) $@ - $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@ +q{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@ }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld $(CHMOD) 755 $@ }; diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 544dece638..a3307a1aa9 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -25,8 +25,9 @@ use vars qw( ); # use strict; -eval {require DynaLoader;}; # Get mod2fname, if defined. Will fail - # with miniperl. +# &DynaLoader::mod2fname should be available to miniperl, thus +# should be a pseudo-builtin (cmp. os2.c). +#eval {require DynaLoader;}; # # Set up the inheritance before we pull in the MM_* packages, because they diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm index 5c0173a508..3583194c4a 100644 --- a/lib/ExtUtils/Mksymlists.pm +++ b/lib/ExtUtils/Mksymlists.pm @@ -40,6 +40,7 @@ sub Mksymlists { } # We'll need this if we ever add any OS which uses mod2fname +# not as pseudo-builtin. # require DynaLoader; if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) { $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]); diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm index 2a89f20dde..387c40c128 100644 --- a/lib/Test/Harness.pm +++ b/lib/Test/Harness.pm @@ -5,7 +5,10 @@ use Exporter; use Benchmark; use Config; use FileHandle; -use vars qw($VERSION $verbose $switches $have_devel_corestack); +use strict; + +use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest + @ISA @EXPORT @EXPORT_OK); $have_devel_corestack = 0; $VERSION = "1.12"; @@ -14,6 +17,23 @@ $VERSION = "1.12"; @EXPORT= qw(&runtests); @EXPORT_OK= qw($verbose $switches); +format STDOUT_TOP = +Failed Test Status Wstat Total Fail Failed List of failed +------------------------------------------------------------------------------ +. + +format STDOUT = +@<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##% @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +{ $curtest->{name}, + $curtest->{estat}, + $curtest->{wstat}, + $curtest->{max}, + $curtest->{failed}, + $curtest->{percent}, + $curtest->{canon} +} +. + $verbose = 0; $switches = "-w"; @@ -21,7 +41,7 @@ $switches = "-w"; sub runtests { my(@tests) = @_; local($|) = 1; - my($test,$te,$ok,$next,$max,$pct); + my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests); my $totmax = 0; my $files = 0; my $bad = 0; @@ -82,6 +102,11 @@ sub runtests { } } $bad++; + $failedtests{$test} = { canon => '??', max => $max || '??', + failed => '??', + name => $test, percent => undef, + estat => $estatus, wstat => $wstatus, + }; } elsif ($ok == $max && $next == $max+1) { if ($max) { print "ok\n"; @@ -94,14 +119,30 @@ sub runtests { push @failed, $next..$max; } if (@failed) { - print canonfailed($max,@failed); + my ($txt, $canon) = canonfailed($max,@failed); + print $txt; + $failedtests{$test} = { canon => $canon, max => $max, + failed => scalar @failed, + name => $test, percent => 100*(scalar @failed)/$max, + estat => '', wstat => '', + }; } else { print "Don't know which tests failed: got $ok ok, expected $max\n"; + $failedtests{$test} = { canon => '??', max => $max, + failed => '??', + name => $test, percent => undef, + estat => '', wstat => '', + }; } $bad++; } elsif ($next == 0) { print "FAILED before any test output arrived\n"; $bad++; + $failedtests{$test} = { canon => '??', max => '??', + failed => '??', + name => $test, percent => undef, + estat => '', wstat => '', + }; } } my $t_total = timediff(new Benchmark, $t_start); @@ -117,9 +158,12 @@ sub runtests { $pct = sprintf("%.2f", $good / $total * 100); my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.", $totmax - $totok, $totmax, 100*$totok/$totmax; - if ($bad == 1) { - die "Failed 1 test script, $pct% okay.$subpct\n"; - } else { + my $script; + for $script (sort keys %failedtests) { + $curtest = $failedtests{$script}; + write; + } + if ($bad > 1) { die "Failed $bad/$total test scripts, $pct% okay.$subpct\n"; } } @@ -154,6 +198,7 @@ sub canonfailed ($@) { my @canon = (); my $min; my $last = $min = shift @failed; + my $canon; if (@failed) { for (@failed, $failed[-1]) { # don't forget the last one if ($_ > $last+1 || $_ == $last) { @@ -168,13 +213,16 @@ sub canonfailed ($@) { } local $" = ", "; push @result, "FAILED tests @canon\n"; + $canon = "@canon"; } else { push @result, "FAILED test $last\n"; + $canon = $last; } push @result, "\tFailed $failed/$max tests, "; push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n"; - join "", @result; + my $txt = join "", @result; + ($txt, $canon); } 1; diff --git a/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm index 317597cb83..33b683525d 100644 --- a/lib/Text/ParseWords.pm +++ b/lib/Text/ParseWords.pm @@ -115,7 +115,7 @@ sub quotewords { last; } else { - while (length($_) && !(/^$delim/ || /^['"\\]/)) { + while ($_ && !(/^$delim/ || /^['"\\]/)) { $snippet .= substr($_, 0, 1); substr($_, 0, 1) = ''; } diff --git a/makedepend.SH b/makedepend.SH index 931dd82655..93ab261a81 100755 --- a/makedepend.SH +++ b/makedepend.SH @@ -124,10 +124,12 @@ $sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d' $MAKE shlist || ($echo "Searching for .SH files..."; \ $echo *.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist) -# Now extract the dependency on makedepend.SH -# (it should reside in the main Makefile): +# Now extract the dependencies on makedepend.SH and Makefile.SH +# (they should reside in the main Makefile): mv .shlist .shlist.old $egrep -v '^makedepend\.SH' <.shlist.old >.shlist +mv .shlist .shlist.old +$egrep -v '^Makefile\.SH' <.shlist.old >.shlist rm .shlist.old if $test -s .deptmp; then @@ -22,6 +22,11 @@ #include "EXTERN.h" #include "perl.h" +#ifdef DEBUGGING +#undef DEBUG_m +#define DEBUG_m(a) if (debug & 128) a +#endif + /* I don't much care whether these are defined in sys/types.h--LAW */ #define u_char unsigned char @@ -64,7 +69,7 @@ union overhead { #define ov_rmagic ovu.ovu_rmagic }; -#ifdef debug +#ifdef DEBUGGING static void botch _((char *s)); #endif static void morecore _((int bucket)); @@ -160,10 +165,9 @@ extern char *sbrk(); * for a given block size. */ static u_int nmalloc[NBUCKETS]; -#include <stdio.h> #endif -#ifdef debug +#ifdef DEBUGGING #define ASSERT(p) if (!(p)) botch("p"); else static void botch(s) @@ -192,7 +196,7 @@ malloc(nbytes) #ifdef MSDOS if (nbytes > 0xffff) { - fprintf(stderr, "Allocation too large: %lx\n", (long)nbytes); + PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", (long)nbytes); my_exit(1); } #endif /* MSDOS */ @@ -231,7 +235,7 @@ malloc(nbytes) if ((p = (union overhead *)nextf[bucket]) == NULL) { #ifdef safemalloc if (!nomemok) { - fputs("Out of memory!\n", stderr); + PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); my_exit(1); } #else @@ -240,14 +244,14 @@ malloc(nbytes) } #ifdef safemalloc - DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) malloc %ld bytes\n", + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n", (unsigned long)(p+1),an++,(long)size)); #endif /* safemalloc */ /* remove from linked list */ #ifdef RCHECK if (*((int*)p) & (sizeof(union overhead) - 1)) - fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n", + PerlIO_printf(PerlIO_stderr(), "Corrupt malloc ptr 0x%lx at 0x%lx\n", (unsigned long)*((int*)p),(unsigned long)p); #endif nextf[bucket] = p->ov_next; @@ -390,7 +394,7 @@ free(mp) #endif #ifdef safemalloc - DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) free\n",(unsigned long)cp,an++)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(unsigned long)cp,an++)); #endif /* safemalloc */ if (cp == NULL) @@ -400,7 +404,7 @@ free(mp) #ifdef PACK_MALLOC bucket = OV_INDEX(op); #endif -#ifdef debug +#ifdef DEBUGGING ASSERT(OV_MAGIC(op, bucket) == MAGIC); /* make sure it was in use */ #else if (OV_MAGIC(op, bucket) != MAGIC) { @@ -467,7 +471,7 @@ realloc(mp, nbytes) #ifdef MSDOS if (nbytes > 0xffff) { - fprintf(stderr, "Reallocation too large: %lx\n", size); + PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size); my_exit(1); } #endif /* MSDOS */ @@ -542,8 +546,8 @@ realloc(mp, nbytes) #ifdef safemalloc #ifdef DEBUGGING if (debug & 128) { - fprintf(stderr,"0x%lx: (%05d) rfree\n",(unsigned long)res,an++); - fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n", + PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) rfree\n",(unsigned long)res,an++); + PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) realloc %ld bytes\n", (unsigned long)res,an++,(long)size); } #endif @@ -616,20 +620,20 @@ dump_mstats(s) topbucket = i; } if (s) - fprintf(stderr, "Memory allocation statistics %s (buckets 8..%d)\n", + PerlIO_printf(PerlIO_stderr(), "Memory allocation statistics %s (buckets 8..%d)\n", s, (1 << (topbucket + 3)) ); - fprintf(stderr, " %7d free: ", totfree); + PerlIO_printf(PerlIO_stderr(), " %7d free: ", totfree); for (i=0; i <= topbucket; i++) { - fprintf(stderr, (i<5)?" %5d":" %3d", nfree[i]); + PerlIO_printf(PerlIO_stderr(), (i<5)?" %5d":" %3d", nfree[i]); } - fprintf(stderr, "\n %7d used: ", totused); + PerlIO_printf(PerlIO_stderr(), "\n %7d used: ", totused); for (i=0; i <= topbucket; i++) { - fprintf(stderr, (i<5)?" %5d":" %3d", nmalloc[i]); + PerlIO_printf(PerlIO_stderr(), (i<5)?" %5d":" %3d", nmalloc[i]); } - fprintf(stderr, "\n"); + PerlIO_printf(PerlIO_stderr(), "\n"); #ifdef PACK_MALLOC if (sbrk_slack || start_slack) { - fprintf(stderr, "Odd ends: %7d bytes from sbrk(), %7d from malloc.\n", + PerlIO_printf(PerlIO_stderr(), "Odd ends: %7d bytes from sbrk(), %7d from malloc.\n", sbrk_slack, start_slack); } #endif @@ -646,32 +650,31 @@ dump_mstats(s) #ifdef USE_PERL_SBRK -#ifdef NeXT -#ifdef HIDEMYMALLOC -#undef malloc -#else -#include "Error: -DUSE_PERL_SBRK on the NeXT requires -DHIDEMYMALLOC" -#endif +# ifdef NeXT +# define PERL_SBRK_VIA_MALLOC +# endif + +# ifdef PERL_SBRK_VIA_MALLOC +# ifdef HIDEMYMALLOC +# undef malloc +# else +# include "Error: -DPERL_SBRK_VIA_MALLOC requires -DHIDEMYMALLOC" +# endif /* it may seem schizophrenic to use perl's malloc and let it call system */ /* malloc, the reason for that is only the 3.2 version of the OS that had */ /* frequent core dumps within nxzonefreenolock. This sbrk routine put an */ /* end to the cores */ -#define SYSTEM_ALLOC(a) malloc(a) - -#else - -/* OS/2 comes to mind ... */ - -#endif +# define SYSTEM_ALLOC(a) malloc(a) +# endif /* PERL_SBRK_VIA_MALLOC */ static IV Perl_sbrk_oldchunk; static long Perl_sbrk_oldsize; -#define PERLSBRK_32_K (1<<15) -#define PERLSBRK_64_K (1<<16) +# define PERLSBRK_32_K (1<<15) +# define PERLSBRK_64_K (1<<16) char * Perl_sbrk(size) @@ -707,7 +710,7 @@ int size; } #ifdef safemalloc - DEBUG_m(fprintf(stderr,"sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n", + DEBUG_m(PerlIO_printf(PerlIO_stderr(), "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n", size, reqsize, Perl_sbrk_oldsize, got)); #endif @@ -99,6 +99,7 @@ SV* sv; MGS* mgs; MAGIC* mg; MAGIC** mgp; + int mgp_valid = 0; ENTER; mgs = save_magic(sv); @@ -109,12 +110,16 @@ SV* sv; if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { (*vtbl->svt_get)(sv, mg); /* Ignore this magic if it's been deleted */ - if (*mgp == mg && (mg->mg_flags & MGf_GSKIP)) + if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) && (mg->mg_flags & MGf_GSKIP)) mgs->mgs_flags = 0; } /* Advance to next magic (complicated by possible deletion) */ - if (*mgp == mg) + if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) { mgp = &mg->mg_moremagic; + mgp_valid = 1; + } + else + mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */ } LEAVE; @@ -664,7 +669,7 @@ MAGIC* mg; if(psig_ptr[i]) sv_setsv(sv,psig_ptr[i]); else { - void (*origsig)(int); + void (*origsig) _((int)); /* get signal state without losing signals */ sig_trapped=0; origsig = rsignal(i,sig_trap); @@ -765,6 +770,8 @@ MAGIC* mg; *svp = 0; } else { + if(hints & HINT_STRICT_REFS) + die(no_symref,s,"a subroutine"); if (!strchr(s,':') && !strchr(s,'\'')) { sprintf(tokenbuf, "main::%s",s); sv_setpv(sv,tokenbuf); @@ -1454,6 +1461,10 @@ int sig; SV *sv; CV *cv; AV *oldstack; + + if(!psig_ptr[sig]) + die("Signal SIG%s received, but no signal handler set.\n", + sig_name[sig]); cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); if (!cv || !CvROOT(cv)) { @@ -24,6 +24,7 @@ Summary of my $package ($baserev patchlevel $PATCHLEVEL subversion $SUBVERSION) osname=$osname, osvers=$osvers, archname=$archname uname='$myuname' hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction + perlstdio=$d_perlstdio sfio=$d_sfio Compiler: cc='$cc', optimize='$optimize', gccversion=$gccversion cppflags='$cppflags' diff --git a/nostdio.h b/nostdio.h new file mode 100644 index 0000000000..3e1e665ef0 --- /dev/null +++ b/nostdio.h @@ -0,0 +1,25 @@ +/* This is an 1st attempt to stop other include files pulling + in real <stdio.h>. + A more ambitious set of possible symbols can be found in + sfio.h (inside an _cplusplus gard). +*/ +#if !defined(_STDIO_H) && !defined(FILE) && !defined(_STDIO_INCLUDED) +#define _STDIO_H +#define _STDIO_INCLUDED +struct _FILE; +#define FILE struct _FILE +#endif + +#define _CANNOT "CANNOT" + +#undef stdin +#undef stdout +#undef stderr +#undef getc +#undef putc +#undef clearerr +#undef fflush +#undef feof +#undef ferror +#undef fileno + @@ -321,7 +321,7 @@ U32 tmptype; } SvFLAGS(sv) |= tmptype; curpad = AvARRAY(comppad); - DEBUG_X(fprintf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); return (PADOFFSET)retval; } @@ -335,7 +335,7 @@ pad_sv(PADOFFSET po) { if (!po) croak("panic: pad_sv po"); - DEBUG_X(fprintf(Perl_debug_log, "Pad sv %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po)); return curpad[po]; /* eventually we'll turn this into a macro */ } @@ -353,7 +353,7 @@ pad_free(PADOFFSET po) croak("panic: pad_free curpad"); if (!po) croak("panic: pad_free po"); - DEBUG_X(fprintf(Perl_debug_log, "Pad free %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po)); if (curpad[po] && curpad[po] != &sv_undef) SvPADTMP_off(curpad[po]); if ((I32)po < padix) @@ -372,7 +372,7 @@ pad_swipe(PADOFFSET po) croak("panic: pad_swipe curpad"); if (!po) croak("panic: pad_swipe po"); - DEBUG_X(fprintf(Perl_debug_log, "Pad swipe %d\n", po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po)); SvPADTMP_off(curpad[po]); curpad[po] = NEWSV(1107,0); SvPADTMP_on(curpad[po]); @@ -387,7 +387,7 @@ pad_reset() if (AvARRAY(comppad) != curpad) croak("panic: pad_reset curpad"); - DEBUG_X(fprintf(Perl_debug_log, "Pad reset\n")); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n")); if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */ for (po = AvMAX(comppad); po > padix_floor; po--) { if (curpad[po] && curpad[po] != &sv_undef) @@ -2812,6 +2812,30 @@ CV* proto; return cv; } +SV * +cv_const_sv(cv) +CV *cv; +{ + OP *o; + SV *sv = Nullsv; + + if(cv && SvPOK(cv) && !SvCUR(cv)) { + for (o = CvSTART(cv); o; o = o->op_next) { + OPCODE type = o->op_type; + + if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) + continue; + if (type == OP_LEAVESUB || type == OP_RETURN) + break; + if (type != OP_CONST || sv) + return Nullsv; + + sv = ((SVOP*)o)->op_sv; + } + } + return sv; +} + CV * newSUB(floor,op,proto,block) I32 floor; @@ -2832,11 +2856,22 @@ OP *block; if (GvCVGEN(gv)) cv = 0; /* just a cached method */ else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { - if (dowarn && strNE(name, "BEGIN")) {/* already defined (or promised)? */ + SV* const_sv = cv_const_sv(cv); + + char *p = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch; + + if((!proto != !SvPOK(cv)) || (p && strNE(SvPV((SV*)cv,na), p))) { + warn("Prototype mismatch: (%s) vs (%s)", + SvPOK(cv) ? SvPV((SV*)cv,na) : "none", + p ? p : "none"); + } + + if ((const_sv || dowarn) && strNE(name, "BEGIN")) {/* already defined (or promised)? */ line_t oldline = curcop->cop_line; curcop->cop_line = copline; - warn("Subroutine %s redefined",name); + warn(const_sv ? "Constant subroutine %s redefined" + : "Subroutine %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); @@ -2864,8 +2899,6 @@ OP *block; if (proto) { char *p = SvPVx(((SVOP*)proto)->op_sv, na); - if (SvPOK(cv) && strNE(SvPV((SV*)cv,na), p)) - warn("Prototype mismatch: (%s) vs (%s)", SvPV((SV*)cv, na), p); sv_setpv((SV*)cv, p); op_free(proto); } diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs index 83227bb38b..72b4383c7d 100644 --- a/os2/Makefile.SHs +++ b/os2/Makefile.SHs @@ -41,6 +41,7 @@ perl5.def: perl.linkexp echo ' "dlopen"' >>$@ echo ' "dlsym"' >>$@ echo ' "dlerror"' >>$@ + echo ' "perl_init_i18nl10n"' >>$@ !NO!SUBS! if [ ! -z "$myttyname" ] ; then @@ -119,6 +120,11 @@ miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(aout_perllib) ext.libs perl_: $& aout_perlmain$(AOUT_OBJ_EXT) $(aout_perllib) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs $(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o perl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER) $(aout_static_ext) $(aout_perllib) `cat ext.libs` $(libs) +perl : perl__ + +perl__: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs + $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl__ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(perllib) `cat ext.libs` $(libs) -Zlinker /PM:PM + aout_clean: -rm *perl_.* *.o *.a lib/auto/*/*.a ext/*/Makefile.aout @@ -128,13 +134,22 @@ aout_install.perl: perl_ installperl ./perl_ installperl aout_test: perl_ - - cd t && (rm -f perl_$(EXE_EXT); $(LNS) ../perl_$(EXE_EXT) perl_$(EXE_EXT)) && ./perl_ TEST </dev/tty + - cd t && (rm -f perl_$(EXE_EXT); $(LNS) ../perl_$(EXE_EXT) perl$(EXE_EXT)) && ./perl TEST </dev/tty + +lib/auto/OS2/*/%.a : ext/OS2/%/Makefile.aout + cd ext/OS2/$(basename $(notdir $@)) ; make -f Makefile.aout config || echo "$make config failed, continuing anyway..." + cd ext/OS2/$(basename $(notdir $@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS= lib/auto/*/%.a : ext/%/Makefile.aout cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout config || echo "$make config failed, continuing anyway..." cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS= +.PRECIOUS : ext/%/Makefile.aout ext/OS2/%/Makefile.aout + +ext/OS2/%/Makefile.aout : miniperl_ + cd $(dir $@) ; ../../../miniperl_ -I ../../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl + ext/%/Makefile.aout : miniperl_ - cd $(dir $@) ; ../../miniperl_ Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl + cd $(dir $@) ; ../../miniperl_ -I ../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl !NO!SUBS! diff --git a/os2/OS2/ExtAttr/Changes b/os2/OS2/ExtAttr/Changes new file mode 100644 index 0000000000..55fdc5f6d5 --- /dev/null +++ b/os2/OS2/ExtAttr/Changes @@ -0,0 +1,5 @@ +Revision history for Perl extension OS2::ExtAttr. + +0.01 Sun Apr 21 11:07:04 1996 + - original version; created by h2xs 1.16 + diff --git a/os2/OS2/ExtAttr/ExtAttr.pm b/os2/OS2/ExtAttr/ExtAttr.pm new file mode 100644 index 0000000000..bebbcc963e --- /dev/null +++ b/os2/OS2/ExtAttr/ExtAttr.pm @@ -0,0 +1,186 @@ +package OS2::ExtAttr; + +use strict; +use vars qw($VERSION @ISA @EXPORT); + +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + +); +$VERSION = '0.01'; + +bootstrap OS2::ExtAttr $VERSION; + +# Preloaded methods go here. + +# Format of the array: +# 0 ead, 1 file name, 2 file handle. 3 length, 4 position, 5 need to write. + +sub TIEHASH { + my $class = shift; + my $ea = _create() || die "Cannot create EA: $!"; + my $file = shift; + my ($name, $handle); + if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') { + die "File handle is not opened" unless $handle = fileno $file; + _read($ea, undef, $handle, 0); + } else { + $name = $file; + _read($ea, $name, 0, 0); + } + bless [$ea, $name, $handle, 0, 0, 0], $class; +} + +sub DESTROY { + my $eas = shift; + # 0 means: discard eas which are not in $eas->[0]. + _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!" + if $eas->[5]; + _destroy( $eas->[0] ); +} + +sub FIRSTKEY { + my $eas = shift; + $eas->[3] = _count($eas->[0]); + $eas->[4] = 1; + return undef if $eas->[4] > $eas->[3]; + return _get_name($eas->[0], $eas->[4]); +} + +sub NEXTKEY { + my $eas = shift; + $eas->[4]++; + return undef if $eas->[4] > $eas->[3]; + return _get_name($eas->[0], $eas->[4]); +} + +sub FETCH { + my $eas = shift; + my $index = _find($eas->[0], shift); + return undef if $index <= 0; + return value($eas->[0], $index); +} + +sub EXISTS { + my $eas = shift; + return _find($eas->[0], shift) > 0; +} + +sub STORE { + my $eas = shift; + $eas->[5] = 1; + add($eas->[0], shift, shift) > 0 or die "Error setting EA: $!"; +} + +sub DELETE { + my $eas = shift; + my $index = _find($eas->[0], shift); + return undef if $index <= 0; + my $value = value($eas->[0], $index); + _delete($eas->[0], $index) and die "Error deleting EA: $!"; + $eas->[5] = 1; + return $value; +} + +sub CLEAR { + my $eas = shift; + _clear($eas->[0]); + $eas->[5] = 1; +} + +# Here are additional methods: + +*new = \&TIEHASH; + +sub copy { + my $eas = shift; + my $file = shift; + my ($name, $handle); + if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') { + die "File handle is not opened" unless $handle = fileno $file; + _write($eas->[0], undef, $handle, 0) or die "Cannot write EA: $!"; + } else { + $name = $file; + _write($eas->[0], $name, 0, 0) or die "Cannot write EA: $!"; + } +} + +sub update { + my $eas = shift; + # 0 means: discard eas which are not in $eas->[0]. + _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!"; +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is the stub of documentation for your module. You better edit it! + +=head1 NAME + +OS2::ExtAttr - Perl access to extended attributes. + +=head1 SYNOPSIS + + use OS2::ExtAttr; + tie %ea, 'OS2::ExtAttr', 'my.file'; + print $ea{eaname}; + $ea{myfield} = 'value'; + + untie %ea; + +=head1 DESCRIPTION + +The package provides low-level and high-level interface to Extended +Attributes under OS/2. + +=head2 High-level interface: C<tie> + +The only argument of tie() is a file name, or an open file handle. + +Note that all the changes of the tied hash happen in core, to +propagate it to disk the tied hash should be untie()ed or should go +out of scope. Alternatively, one may use the low-level C<update> +method on the corresponding object. Example: + + tied(%hash)->update; + +Note also that setting/getting EA flag is not supported by the +high-level interface, one should use the low-level interface +instead. To use it on a tied hash one needs undocumented way to find +C<eas> give the tied hash. + +=head2 Low-level interface + +Two low-level methods are supported by the objects: copy() and +update(). The copy() takes one argument: the name of a file to copy +the attributes to, or an opened file handle. update() takes no +arguments, and is discussed above. + +Three convenience functions are provided: + + value($eas, $key) + add($eas, $key, $value [, $flag]) + replace($eas, $key, $value [, $flag]) + +The default value for C<flag> is 0. + +In addition, all the C<_ea_*> and C<_ead_*> functions defined in EMX +library are supported, with leading C<_ea/_ead> stripped. + +=head1 AUTHOR + +Ilya Zakharevich, ilya@math.ohio-state.edu + +=head1 SEE ALSO + +perl(1). + +=cut diff --git a/os2/OS2/ExtAttr/ExtAttr.xs b/os2/OS2/ExtAttr/ExtAttr.xs new file mode 100644 index 0000000000..566b6595c8 --- /dev/null +++ b/os2/OS2/ExtAttr/ExtAttr.xs @@ -0,0 +1,193 @@ +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef __cplusplus +} +#endif + +#include "myea.h" + +SV * +my_eadvalue(_ead ead, int index) +{ + SV *sv; + int size = _ead_value_size(ead, index); + void *p; + + if (size == -1) { + die("Error getting size of EA: %s", strerror(errno)); + } + p = _ead_get_value(ead, index); + return newSVpv((char*)p, size); +} + +#define my_eadreplace(ead, index, sv, flag) \ + _ead_replace((ead), (index), flag, SvPVX(sv), SvCUR(sv)) + +#define my_eadadd(ead, name, sv, flag) \ + _ead_add((ead), (name), flag, SvPVX(sv), SvCUR(sv)) + + +MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = my_ead + +SV * +my_eadvalue(ead, index) + _ead ead + int index + +int +my_eadreplace(ead, index, sv, flag = 0) + _ead ead + int index + SV * sv + int flag + +int +my_eadadd(ead, name, sv, flag = 0) + _ead ead + char * name + SV * sv + int flag + +MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ea + + +void +_ea_free(ptr) + struct _ea * ptr + +int +_ea_get(dst, path, handle, name) + struct _ea * dst + char * path + int handle + char * name + +int +_ea_put(src, path, handle, name) + struct _ea * src + char * path + int handle + char * name + +int +_ea_remove(path, handle, name) + char * path + int handle + char * name + +MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ead + +int +_ead_add(ead, name, flags, value, size) + _ead ead + char * name + int flags + void * value + int size + +void +_ead_clear(ead) + _ead ead + +int +_ead_copy(dst_ead, src_ead, src_index) + _ead dst_ead + _ead src_ead + int src_index + +int +_ead_count(ead) + _ead ead + +_ead +_ead_create() + +int +_ead_delete(ead, index) + _ead ead + int index + +void +_ead_destroy(ead) + _ead ead + +int +_ead_fea2list_size(ead) + _ead ead + +void * +_ead_fea2list_to_fealist(src) + void * src + +void * +_ead_fealist_to_fea2list(src) + void * src + +int +_ead_find(ead, name) + _ead ead + char * name + +void * +_ead_get_fea2list(ead) + _ead ead + +int +_ead_get_flags(ead, index) + _ead ead + int index + +char * +_ead_get_name(ead, index) + _ead ead + int index + +void * +_ead_get_value(ead, index) + _ead ead + int index + +int +_ead_name_len(ead, index) + _ead ead + int index + +int +_ead_read(ead, path, handle, flags) + _ead ead + char * path + int handle + int flags + +int +_ead_replace(ead, index, flags, value, size) + _ead ead + int index + int flags + void * value + int size + +void +_ead_sort(ead) + _ead ead + +int +_ead_use_fea2list(ead, src) + _ead ead + void * src + +int +_ead_value_size(ead, index) + _ead ead + int index + +int +_ead_write(ead, path, handle, flags) + _ead ead + char * path + int handle + int flags diff --git a/os2/OS2/ExtAttr/MANIFEST b/os2/OS2/ExtAttr/MANIFEST new file mode 100644 index 0000000000..b1a8e80e77 --- /dev/null +++ b/os2/OS2/ExtAttr/MANIFEST @@ -0,0 +1,8 @@ +Changes +ExtAttr.pm +ExtAttr.xs +MANIFEST +Makefile.PL +myea.h +t/os2_ea.t +typemap diff --git a/os2/OS2/ExtAttr/Makefile.PL b/os2/OS2/ExtAttr/Makefile.PL new file mode 100644 index 0000000000..4e8498f10c --- /dev/null +++ b/os2/OS2/ExtAttr/Makefile.PL @@ -0,0 +1,10 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'OS2::ExtAttr', + 'VERSION_FROM' => 'ExtAttr.pm', # finds $VERSION + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' +); diff --git a/os2/OS2/ExtAttr/myea.h b/os2/OS2/ExtAttr/myea.h new file mode 100644 index 0000000000..ec4dc81f99 --- /dev/null +++ b/os2/OS2/ExtAttr/myea.h @@ -0,0 +1,2 @@ +#include <sys/ea.h> +#include <sys/ead.h> diff --git a/os2/OS2/ExtAttr/t/os2_ea.t b/os2/OS2/ExtAttr/t/os2_ea.t new file mode 100644 index 0000000000..c1024193c1 --- /dev/null +++ b/os2/OS2/ExtAttr/t/os2_ea.t @@ -0,0 +1,79 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..21\n"; } +END {print "not ok 1\n" unless $loaded;} +use OS2::ExtAttr; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +system 'cmd', '/c', 'del t.out'; +system 'cmd', '/c', 'echo OK > t.out'; + +{ + my %a; + tie %a, 'OS2::ExtAttr', 't.out'; + print "ok 2\n"; + + keys %a == 0 ? print "ok 3\n" : print "not ok 3\n"; + $a{'++'} = '---'; + print "ok 4\n"; + $a{'AAA'} = 'xyz'; + print "ok 5\n"; +} + +{ + my %a; + tie %a, 'OS2::ExtAttr', 't.out'; + print "ok 6\n"; + + my $c = keys %a; + $c == 2 ? print "ok 7\n" : print "not ok 7\n# c=$c\n"; + my @b = sort keys %a; + "@b" eq '++ AAA' ? print "ok 8\n" : print "not ok 8\n# keys=`@b'\n"; + $a{'++'} eq '---' ? print "ok 9\n" : print "not ok 9\n";; + $a{'AAA'} eq 'xyz' ? print "ok 10\n" : print "not ok 10\n# aaa->`$a{AAA}'\n"; + $c = delete $a{'++'}; + $c eq '---' ? print "ok 11\n" : print "not ok 11\n# deleted->`$c'\n";; +} + +print "ok 12\n"; + +{ + my %a; + tie %a, 'OS2::ExtAttr', 't.out'; + print "ok 13\n"; + + keys %a == 1 ? print "ok 14\n" : print "not ok 14\n"; + my @b = sort keys %a; + "@b" eq 'AAA' ? print "ok 15\n" : print "not ok 15\n"; + $a{'AAA'} eq 'xyz' ? print "ok 16\n" : print "not ok 16\n";; + ! exists $a{'+'} ? print "ok 17\n" : print "not ok 17\n";; + ! defined $a{'+'} ? print "ok 18\n" : print "not ok 18\n# ->`$a{'++'}'\n";; + ! exists $a{'++'} ? print "ok 19\n" : print "not ok 19\n";; + ! defined $a{'++'} ? print "ok 20\n" : print "not ok 20\n# ->`$a{'++'}'\n";; +} + +print "ok 21\n"; + diff --git a/os2/OS2/ExtAttr/typemap b/os2/OS2/ExtAttr/typemap new file mode 100644 index 0000000000..a5ff8d63ac --- /dev/null +++ b/os2/OS2/ExtAttr/typemap @@ -0,0 +1,2 @@ +struct _ea * T_PTR +_ead T_PTR diff --git a/os2/OS2/PrfDB/Changes b/os2/OS2/PrfDB/Changes new file mode 100644 index 0000000000..3e8bf3f580 --- /dev/null +++ b/os2/OS2/PrfDB/Changes @@ -0,0 +1,5 @@ +Revision history for Perl extension OS2::PrfDB. + +0.01 Tue Mar 26 19:35:27 1996 + - original version; created by h2xs 1.16 +0.02: Field do-not-close added to OS2::Prf::Hini. diff --git a/os2/OS2/PrfDB/MANIFEST b/os2/OS2/PrfDB/MANIFEST new file mode 100644 index 0000000000..fb96b03c5d --- /dev/null +++ b/os2/OS2/PrfDB/MANIFEST @@ -0,0 +1,7 @@ +Changes +MANIFEST +Makefile.PL +PrfDB.pm +PrfDB.xs +t/os2_prfdb.t +typemap diff --git a/os2/OS2/PrfDB/Makefile.PL b/os2/OS2/PrfDB/Makefile.PL new file mode 100644 index 0000000000..c591c0490c --- /dev/null +++ b/os2/OS2/PrfDB/Makefile.PL @@ -0,0 +1,10 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'OS2::PrfDB', + 'VERSION_FROM' => 'PrfDB.pm', # finds $VERSION + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' +); diff --git a/os2/OS2/PrfDB/PrfDB.pm b/os2/OS2/PrfDB/PrfDB.pm new file mode 100644 index 0000000000..d404c8b1d3 --- /dev/null +++ b/os2/OS2/PrfDB/PrfDB.pm @@ -0,0 +1,314 @@ +package OS2::PrfDB; + +use strict; +use vars qw($VERSION @ISA @EXPORT); + +require Exporter; +require DynaLoader; + +@ISA = qw(Exporter DynaLoader); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + AnyIni UserIni SystemIni + ); +$VERSION = '0.02'; + +bootstrap OS2::PrfDB $VERSION; + +# Preloaded methods go here. + +sub AnyIni { + new_from_int OS2::PrfDB::Hini OS2::Prf::System(0), + 'Anyone of two "systemish" databases', 1; +} + +sub UserIni { + new_from_int OS2::PrfDB::Hini OS2::Prf::System(1), 'User settings database', 1; +} + +sub SystemIni { + new_from_int OS2::PrfDB::Hini OS2::Prf::System(2),'System settings database',1; +} + +use vars qw{$debug @ISA}; +use Tie::Hash; +@ISA = qw{Tie::Hash}; + +# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator. + +sub TIEHASH { + die "Usage: tie %arr, OS2::PrfDB, filename\n" unless @_ == 2; + my ($obj, $file) = @_; + my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file + : new OS2::PrfDB::Hini $file; + die "Error opening profile database `$file': $!" unless $hini; + # print "tiehash `@_', hini $hini\n" if $debug; + bless [$hini, undef, undef]; +} + +sub STORE { + my ($self, $key, $val) = @_; + die unless @_ == 3; + die unless ref $val eq 'HASH'; + my %sub; + tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; + %sub = %$val; +} + +sub FETCH { + my ($self, $key) = @_; + die unless @_ == 2; + my %sub; + tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; + \%sub; +} + +sub DELETE { + my ($self, $key) = @_; + die unless @_ == 2; + my %sub; + tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key; + %sub = (); +} + +# CLEAR ???? - deletion of the whole + +sub EXISTS { + my ($self, $key) = @_; + die unless @_ == 2; + return OS2::Prf::GetLength($self->[0]->[0], $key, undef) >= 0; +} + +sub FIRSTKEY { + my $self = shift; + my $keys = OS2::Prf::Get($self->[0]->[0], undef, undef); + return undef unless defined $keys; + chop($keys); + $self->[1] = [split /\0/, $keys]; + # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug; + $self->[2] = 0; + return $self->[1]->[0]; + # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0])); +} + +sub NEXTKEY { + # print "nextkey `@_'\n" if $debug; + my $self = shift; + return undef unless $self->[2]++ < $#{$self->[1]}; + my $key = $self->[1]->[$self->[2]]; + return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key)); +} + +package OS2::PrfDB::Hini; + +sub new { + die "Usage: new OS2::PrfDB::Hini filename\n" unless @_ == 2; + shift; + my $file = shift; + my $hini = OS2::Prf::Open($file); + die "Error opening profile database `$file': $!" unless $hini; + bless [$hini, $file]; +} + +# Takes HINI and file name: + +sub new_from_int { shift; bless [@_] } + +# Internal structure 0 => HINI, 1 => filename, 2 => do-not-close. + +sub DESTROY { + my $self = shift; + my $hini = $self->[0]; + unless ($self->[2]) { + OS2::Prf::Close($hini) or die "Error closing profile `$self->[1]': $!"; + } +} + +package OS2::PrfDB::Sub; +use vars qw{$debug @ISA}; +use Tie::Hash; +@ISA = qw{Tie::Hash}; + +# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator, +# 3 => appname. + +sub TIEHASH { + die "Usage: tie %arr, OS2::PrfDB::Sub, filename, appname\n" unless @_ == 3; + my ($obj, $file, $app) = @_; + my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file + : new OS2::PrfDB::Hini $file; + die "Error opening profile database `$file': $!" unless $hini; + # print "tiehash `@_', hini $hini\n" if $debug; + bless [$hini, undef, undef, $app]; +} + +sub STORE { + my ($self, $key, $val) = @_; + die unless @_ == 3; + OS2::Prf::Set($self->[0]->[0], $self->[3], $key, $val); +} + +sub FETCH { + my ($self, $key) = @_; + die unless @_ == 2; + OS2::Prf::Get($self->[0]->[0], $self->[3], $key); +} + +sub DELETE { + my ($self, $key) = @_; + die unless @_ == 2; + OS2::Prf::Set($self->[0]->[0], $self->[3], $key, undef); +} + +# CLEAR ???? - deletion of the whole + +sub EXISTS { + my ($self, $key) = @_; + die unless @_ == 2; + return OS2::Prf::GetLength($self->[0]->[0], $self->[3], $key) >= 0; +} + +sub FIRSTKEY { + my $self = shift; + my $keys = OS2::Prf::Get($self->[0]->[0], $self->[3], undef); + return undef unless defined $keys; + chop($keys); + $self->[1] = [split /\0/, $keys]; + # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug; + $self->[2] = 0; + return $self->[1]->[0]; + # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0])); +} + +sub NEXTKEY { + # print "nextkey `@_'\n" if $debug; + my $self = shift; + return undef unless $self->[2]++ < $#{$self->[1]}; + my $key = $self->[1]->[$self->[2]]; + return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key)); +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is the stub of documentation for your module. You better edit it! + +=head1 NAME + +OS2::PrfDB - Perl extension for access to OS/2 setting database. + +=head1 SYNOPSIS + + use OS2::PrfDB; + tie %settings, OS2::PrfDB, 'my.ini'; + tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey'; + + print "$settings{firstkey}{subkey}\n"; + print "$subsettings{subkey}\n"; + + tie %system, OS2::PrfDB, SystemIni; + $system{myapp}{mykey} = "myvalue"; + + +=head1 DESCRIPTION + +The extention provides both high-level and low-level access to .ini +files. + +=head2 High level access + +High-level access is the tie-hash access via two packages: +C<OS2::PrfDB> and C<OS2::PrfDB::Sub>. First one supports one argument, +the name of the file to open, the second one the name of the file to +open and so called I<Application name>, or the primary key of the +database. + + tie %settings, OS2::PrfDB, 'my.ini'; + tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey'; + +One may substitute a handle for already opened ini-file instead of the +file name (obtained via low-level access functions). In particular, 3 +functions SystemIni(), UserIni(), and AnyIni() provide handles to the +"systemish" databases. AniIni will read from both, and write into User +database. + +=head2 Low-level access + +Low-level access functions reside in the package C<OS2::Prf>. They are + +=over 14 + +=item C<Open(file)> + +Opens the database, returns an I<integer handle>. + +=item C<Close(hndl)> + +Closes the database given an I<integer handle>. + +=item C<Get(hndl, appname, key)> + +Retrieves data from the database given 2-part-key C<appname> C<key>. +If C<key> is C<undef>, return the "\0" delimited list of C<key>s, +terminated by \0. If C<appname> is C<undef>, returns the list of +possible C<appname>s in the same form. + +=item C<GetLength(hndl, appname, key)> + +Same as above, but returns the length of the value. + +=item C<Set(hndl, appname, key, value [ , length ])> + +Sets the value. If the C<value> is not defined, removes the C<key>. If +the C<key> is not defined, removes the C<appname>. + +=item C<System(val)> + +Return an I<integer handle> associated with the system database. If +C<val> is 1, it is I<User> database, if 2, I<System> database, if +0, handle for "both" of them: the handle works for read from any one, +and for write into I<User> one. + +=item C<Profiles()> + +returns a reference to a list of two strings, giving names of the +I<User> and I<System> databases. + +=item C<SetUser(file)> + +B<(Not tested.)> Sets the profile name of the I<User> database. The +application should have a message queue to use this function! + +=back + +=head2 Integer handles + +To convert a name or an integer handle into an object acceptable as +argument to tie() interface, one may use the following functions from +the package C<OS2::Prf::Hini>: + +=over 14 + +=item C<new(package, file)> + +=item C<new_from_int(package, int_hndl [ , filename ])> + +=back + +=head2 Exports + +SystemIni(), UserIni(), and AnyIni(). + +=head1 AUTHOR + +Ilya Zakharevich, ilya@math.ohio-state.edu + +=head1 SEE ALSO + +perl(1). + +=cut + diff --git a/os2/OS2/PrfDB/PrfDB.xs b/os2/OS2/PrfDB/PrfDB.xs new file mode 100644 index 0000000000..a5b2c89ca6 --- /dev/null +++ b/os2/OS2/PrfDB/PrfDB.xs @@ -0,0 +1,131 @@ +#define INCL_WINSHELLDATA /* Or use INCL_WIN, INCL_PM, */ + +#ifdef __cplusplus +extern "C" { +#endif +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include <os2.h> +#ifdef __cplusplus +} +#endif + +#define Prf_Open(pszFileName) SaveWinError(PrfOpenProfile(Perl_hab, (pszFileName))) +#define Prf_Close(hini) (!CheckWinError(PrfCloseProfile(hini))) + +SV * +Prf_Get(HINI hini, PSZ app, PSZ key) { + ULONG len; + BOOL rc; + SV *sv; + + if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return &sv_undef; + sv = newSVpv("", 0); + SvGROW(sv, len); + if (CheckWinError(PrfQueryProfileData(hini, app, key, SvPVX(sv), &len)) + || (len == 0 && (app == NULL || key == NULL))) { /* Somewhy needed. */ + SvREFCNT_dec(sv); + return &sv_undef; + } + SvCUR_set(sv, len); + *SvEND(sv) = 0; + return sv; +} + +U32 +Prf_GetLength(HINI hini, PSZ app, PSZ key) { + U32 len; + + if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return -1; + return len; +} + +#define Prf_Set(hini, app, key, s, l) \ + (!(CheckWinError(PrfWriteProfileData(hini, app, key, s, l)))) + +#define Prf_System(key) \ + ( (key) ? ( (key) == 1 ? HINI_USERPROFILE \ + : ( (key) == 2 ? HINI_SYSTEMPROFILE \ + : (die("Wrong profile id %i", key), 0) )) \ + : HINI_PROFILE) + +SV* +Prf_Profiles() +{ + AV *av = newAV(); + SV *rv; + char user[257]; + char system[257]; + PRFPROFILE info = { 257, user, 257, system}; + + if (CheckWinError(PrfQueryProfile(Perl_hab, &info))) return &sv_undef; + if (info.cchUserName > 257 || info.cchSysName > 257) + die("Panic: Profile names too long"); + av_push(av, newSVpv(user, info.cchUserName - 1)); + av_push(av, newSVpv(system, info.cchSysName - 1)); + rv = newRV((SV*)av); + SvREFCNT_dec(av); + return rv; +} + +BOOL +Prf_SetUser(SV *sv) +{ + char user[257]; + char system[257]; + PRFPROFILE info = { 257, user, 257, system}; + + if (!SvPOK(sv)) die("User profile name not defined"); + if (SvCUR(sv) > 256) die("User profile name too long"); + if (CheckWinError(PrfQueryProfile(Perl_hab, &info))) return 0; + if (info.cchSysName > 257) + die("Panic: System profile name too long"); + info.cchUserName = SvCUR(sv) + 1; + info.pszUserName = SvPVX(sv); + return !CheckWinError(PrfReset(Perl_hab, &info)); +} + +MODULE = OS2::PrfDB PACKAGE = OS2::Prf PREFIX = Prf_ + +HINI +Prf_Open(pszFileName) + PSZ pszFileName; + +BOOL +Prf_Close(hini) + HINI hini; + +SV * +Prf_Get(hini, app, key) + HINI hini; + PSZ app; + PSZ key; + +int +Prf_Set(hini, app, key, s, l = (SvPOK(ST(3)) ? SvCUR(ST(3)): -1)) + HINI hini; + PSZ app; + PSZ key; + PSZ s; + ULONG l; + +U32 +Prf_GetLength(hini, app, key) + HINI hini; + PSZ app; + PSZ key; + +HINI +Prf_System(key) + int key; + +SV* +Prf_Profiles() + +BOOL +Prf_SetUser(sv) + SV *sv + +BOOT: + Acquire_hab(); diff --git a/os2/OS2/PrfDB/t/os2_prfdb.t b/os2/OS2/PrfDB/t/os2_prfdb.t new file mode 100644 index 0000000000..4c0883db50 --- /dev/null +++ b/os2/OS2/PrfDB/t/os2_prfdb.t @@ -0,0 +1,185 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::PrfDB\b/) { + print "1..0\n"; + exit 0; + } +} + +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..48\n"; } +END {print "not ok 1\n" unless $loaded;} +use OS2::PrfDB; +$loaded = 1; +use strict; + +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +my $inifile = "my.ini"; + +unlink $inifile if -w $inifile; + +my $ini = OS2::Prf::Open($inifile); +print( ($ini ? "": "not "), "ok 2\n# HINI=`$ini'\n"); + +print( (OS2::Prf::GetLength($ini,'aaa', 'bbb') != -1) ? + "not ok 3\n# err: `$^E'\n" : "ok 3\n"); + + +print( OS2::Prf::Set($ini,'aaa', 'bbb','xyz') ? "ok 4\n" : + "not ok 4\n# err: `$^E'\n"); + +my $len = OS2::Prf::GetLength($ini,'aaa', 'bbb'); +print( $len == 3 ? "ok 5\n" : "not ok 5# len: `$len' err: `$^E'\n"); + +my $val = OS2::Prf::Get($ini,'aaa', 'bbb'); +print( $val eq 'xyz' ? "ok 6\n" : "not ok 6# val: `$val' err: `$^E'\n"); + +$val = OS2::Prf::Get($ini,'aaa', undef); +print( $val eq "bbb\0" ? "ok 7\n" : "not ok 7# val: `$val' err: `$^E'\n"); + +$val = OS2::Prf::Get($ini, undef, undef); +print( $val eq "aaa\0" ? "ok 8\n" : "not ok 8# val: `$val' err: `$^E'\n"); + +my $res = OS2::Prf::Set($ini,'aaa', 'bbb',undef); +print( $res ? "ok 9\n" : "not ok 9# err: `$^E'\n"); + +$val = OS2::Prf::Get($ini, undef, undef); +print( (! defined $val) ? "ok 10\n" : "not ok 10# val: `$val' err: `$^E'\n"); + +$val = OS2::Prf::Get($ini,'aaa', undef); +print( (! defined $val) ? "ok 11\n" : "not ok 11# val: `$val' err: `$^E'\n"); + +print((OS2::Prf::Close($ini) ? "" : "not ") . "ok 12\n"); + +my $files = OS2::Prf::Profiles(); +print( (defined $files) ? "ok 13\n" : "not ok 13# err: `$^E'\n"); +print( (@$files == 2) ? "ok 14\n" : "not ok 14# `@$files' err: `$^E'\n"); +print "# `@$files'\n"; + +$ini = OS2::Prf::Open($inifile); +print( ($ini ? "": "not "), "ok 15\n# HINI=`$ini'\n"); + + +print( OS2::Prf::Set($ini,'aaa', 'ccc','xyz') ? "ok 16\n" : + "not ok 16\n# err: `$^E'\n"); + +print( OS2::Prf::Set($ini,'aaa', 'ddd','123') ? "ok 17\n" : + "not ok 17\n# err: `$^E'\n"); + +print( OS2::Prf::Set($ini,'bbb', 'xxx','abc') ? "ok 18\n" : + "not ok 18\n# err: `$^E'\n"); + +print( OS2::Prf::Set($ini,'bbb', 'yyy','456') ? "ok 19\n" : + "not ok 19\n# err: `$^E'\n"); + +my %hash1; + +tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa'; +$OS2::PrfDB::Sub::debug = 1; +print "ok 20\n"; + +my @a1 = keys %hash1; +print (@a1 == 2 ? "ok 21\n" : "not ok 21\n# `@a1'\n"); + +my @a2 = sort @a1; +print ("@a2" eq "ccc ddd" ? "ok 22\n" : "not ok 22\n# `@a2'\n"); + +$val = $hash1{ccc}; +print ($val eq "xyz" ? "ok 23\n" : "not ok 23\n# `$val'\n"); + +$val = $hash1{ddd}; +print ($val eq "123" ? "ok 24\n" : "not ok 24\n# `$val'\n"); + +print (exists $hash1{ccc} ? "ok 25\n" : "not ok 25\n# `$val'\n"); + +print (!exists $hash1{hhh} ? "ok 26\n" : "not ok 26\n# `$val'\n"); + +$hash1{hhh} = 12; +print (exists $hash1{hhh} ? "ok 27\n" : "not ok 27\n# `$val'\n"); + +$val = $hash1{hhh}; +print ($val eq "12" ? "ok 28\n" : "not ok 28\n# `$val'\n"); + +delete $hash1{ccc}; + +untie %hash1; +print "ok 29\n"; + +tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa'; +print "ok 30\n"; + +@a1 = keys %hash1; +print (@a1 == 2 ? "ok 31\n" : "not ok 31\n# `@a1'\n"); + +@a2 = sort @a1; +print ("@a2" eq "ddd hhh" ? "ok 32\n" : "not ok 32\n# `@a2'\n"); + +print (exists $hash1{hhh} ? "ok 33\n" : "not ok 33\n# `$val'\n"); + +$val = $hash1{hhh}; +print ($val eq "12" ? "ok 34\n" : "not ok 34\n# `$val'\n"); + +%hash1 = (); +print "ok 35\n"; + +%hash1 = ( hhh => 12, ddd => 5); + +untie %hash1; + +my %hash; + +tie %hash, 'OS2::PrfDB', $inifile; +print "ok 36\n"; + +@a1 = keys %hash; +print (@a1 == 2 ? "ok 37\n" : "not ok 37\n# `@a1'\n"); + +@a2 = sort @a1; +print ("@a2" eq "aaa bbb" ? "ok 38\n" : "not ok 38\n# `@a2'\n"); + +print (exists $hash{aaa} ? "ok 39\n" : "not ok 39\n# `$val'\n"); + +$val = $hash{aaa}; +print (ref $val eq "HASH" ? "ok 40\n" : "not ok 40\n# `$val'\n"); + +%hash1 = %$val; +print "ok 41\n"; + +@a1 = keys %hash1; +print (@a1 == 2 ? "ok 42\n" : "not ok 31\n# `@a1'\n"); + +@a2 = sort @a1; +print ("@a2" eq "ddd hhh" ? "ok 43\n" : "not ok 43\n# `@a2'\n"); + +print (exists $hash1{hhh} ? "ok 44\n" : "not ok 44\n# `$val'\n"); + +$val = $hash1{hhh}; +print ($val eq "12" ? "ok 45\n" : "not ok 45\n# `$val'\n"); + +$hash{nnn}{mmm} = 67; +print "ok 46\n"; + +untie %hash; + +my %hash2; + +tie %hash2, 'OS2::PrfDB', $inifile; +print "ok 47\n"; + +print ($hash2{nnn}->{mmm} eq "67" ? "ok 48\n" : "not ok 48\n# `$val'\n"); diff --git a/os2/OS2/PrfDB/typemap b/os2/OS2/PrfDB/typemap new file mode 100644 index 0000000000..0b91f3750a --- /dev/null +++ b/os2/OS2/PrfDB/typemap @@ -0,0 +1,14 @@ +BOOL T_IV +ULONG T_IV +HINI T_IV +HAB T_IV +PSZ T_PVNULL + +############################################################################# +INPUT +T_PVNULL + $var = ( SvOK($arg) ? ($type)SvPV($arg,na) : NULL ) +############################################################################# +OUTPUT +T_PVNULL + sv_setpv((SV*)$arg, $var); diff --git a/os2/OS2/Process/MANIFEST b/os2/OS2/Process/MANIFEST new file mode 100644 index 0000000000..0d90d15fca --- /dev/null +++ b/os2/OS2/Process/MANIFEST @@ -0,0 +1,4 @@ +MANIFEST +Makefile.PL +Process.pm +Process.xs diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL new file mode 100644 index 0000000000..ff4deabef6 --- /dev/null +++ b/os2/OS2/Process/Makefile.PL @@ -0,0 +1,10 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'OS2::Process', + 'VERSION' => '0.1', + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' +); diff --git a/os2/OS2/Process/Process.pm b/os2/OS2/Process/Process.pm new file mode 100644 index 0000000000..9216bb1e05 --- /dev/null +++ b/os2/OS2/Process/Process.pm @@ -0,0 +1,112 @@ +package OS2::Process; + +require Exporter; +require DynaLoader; +require AutoLoader; + +@ISA = qw(Exporter DynaLoader); +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. +@EXPORT = qw( + P_BACKGROUND + P_DEBUG + P_DEFAULT + P_DETACH + P_FOREGROUND + P_FULLSCREEN + P_MAXIMIZE + P_MINIMIZE + P_NOCLOSE + P_NOSESSION + P_NOWAIT + P_OVERLAY + P_PM + P_QUOTE + P_SESSION + P_TILDE + P_UNRELATED + P_WAIT + P_WINDOWED +); +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + local($constname); + ($constname = $AUTOLOAD) =~ s/.*:://; + $val = constant($constname, @_ ? $_[0] : 0); + if ($! != 0) { + if ($! =~ /Invalid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } + else { + ($pack,$file,$line) = caller; + die "Your vendor has not defined OS2::Process macro $constname, used at $file line $line. +"; + } + } + eval "sub $AUTOLOAD { $val }"; + goto &$AUTOLOAD; +} + +bootstrap OS2::Process; + +# Preloaded methods go here. + +# Autoload methods go after __END__, and are processed by the autosplit program. + +1; +__END__ + +=head1 NAME + +OS2::Process - exports constants for system() call on OS2. + +=head1 SYNOPSIS + + use OS2::Process; + $pid = system(P_PM+P_BACKGROUND, "epm.exe"); + +=head1 DESCRIPTION + +the builtin function system() under OS/2 allows an optional first +argument which denotes the mode of the process. Note that this argument is +recognized only if it is strictly numerical. + +You can use either one of the process modes: + + P_WAIT (0) = wait until child terminates (default) + P_NOWAIT = do not wait until child terminates + P_SESSION = new session + P_DETACH = detached + P_PM = PM program + +and optionally add PM and session option bits: + + P_DEFAULT (0) = default + P_MINIMIZE = minimized + P_MAXIMIZE = maximized + P_FULLSCREEN = fullscreen (session only) + P_WINDOWED = windowed (session only) + + P_FOREGROUND = foreground (if running in foreground) + P_BACKGROUND = background + + P_NOCLOSE = don't close window on exit (session only) + + P_QUOTE = quote all arguments + P_TILDE = MKS argument passing convention + P_UNRELATED = do not kill child when father terminates + +=head1 AUTHOR + +Andreas Kaiser <ak@ananke.s.bawue.de>. + +=head1 SEE ALSO + +C<spawn*>() system calls. + +=cut diff --git a/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs new file mode 100644 index 0000000000..bdb2ece7a0 --- /dev/null +++ b/os2/OS2/Process/Process.xs @@ -0,0 +1,154 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include <process.h> + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static unsigned long +constant(name, arg) +char *name; +int arg; +{ + errno = 0; + if (name[0] == 'P' && name[1] == '_') { + if (strEQ(name, "P_BACKGROUND")) +#ifdef P_BACKGROUND + return P_BACKGROUND; +#else + goto not_there; +#endif + if (strEQ(name, "P_DEBUG")) +#ifdef P_DEBUG + return P_DEBUG; +#else + goto not_there; +#endif + if (strEQ(name, "P_DEFAULT")) +#ifdef P_DEFAULT + return P_DEFAULT; +#else + goto not_there; +#endif + if (strEQ(name, "P_DETACH")) +#ifdef P_DETACH + return P_DETACH; +#else + goto not_there; +#endif + if (strEQ(name, "P_FOREGROUND")) +#ifdef P_FOREGROUND + return P_FOREGROUND; +#else + goto not_there; +#endif + if (strEQ(name, "P_FULLSCREEN")) +#ifdef P_FULLSCREEN + return P_FULLSCREEN; +#else + goto not_there; +#endif + if (strEQ(name, "P_MAXIMIZE")) +#ifdef P_MAXIMIZE + return P_MAXIMIZE; +#else + goto not_there; +#endif + if (strEQ(name, "P_MINIMIZE")) +#ifdef P_MINIMIZE + return P_MINIMIZE; +#else + goto not_there; +#endif + if (strEQ(name, "P_NOCLOSE")) +#ifdef P_NOCLOSE + return P_NOCLOSE; +#else + goto not_there; +#endif + if (strEQ(name, "P_NOSESSION")) +#ifdef P_NOSESSION + return P_NOSESSION; +#else + goto not_there; +#endif + if (strEQ(name, "P_NOWAIT")) +#ifdef P_NOWAIT + return P_NOWAIT; +#else + goto not_there; +#endif + if (strEQ(name, "P_OVERLAY")) +#ifdef P_OVERLAY + return P_OVERLAY; +#else + goto not_there; +#endif + if (strEQ(name, "P_PM")) +#ifdef P_PM + return P_PM; +#else + goto not_there; +#endif + if (strEQ(name, "P_QUOTE")) +#ifdef P_QUOTE + return P_QUOTE; +#else + goto not_there; +#endif + if (strEQ(name, "P_SESSION")) +#ifdef P_SESSION + return P_SESSION; +#else + goto not_there; +#endif + if (strEQ(name, "P_TILDE")) +#ifdef P_TILDE + return P_TILDE; +#else + goto not_there; +#endif + if (strEQ(name, "P_UNRELATED")) +#ifdef P_UNRELATED + return P_UNRELATED; +#else + goto not_there; +#endif + if (strEQ(name, "P_WAIT")) +#ifdef P_WAIT + return P_WAIT; +#else + goto not_there; +#endif + if (strEQ(name, "P_WINDOWED")) +#ifdef P_WINDOWED + return P_WINDOWED; +#else + goto not_there; +#endif + } + + errno = EINVAL; + return 0; + +not_there: + errno = ENOENT; + return 0; +} + + +MODULE = OS2::Process PACKAGE = OS2::Process + + +unsigned long +constant(name,arg) + char * name + int arg + diff --git a/os2/OS2/REXX/Changes b/os2/OS2/REXX/Changes new file mode 100644 index 0000000000..46b38ef46c --- /dev/null +++ b/os2/OS2/REXX/Changes @@ -0,0 +1,4 @@ +0.2: + After fixpak17 a lot of other places have mismatched lengths +returned in the REXXPool interface. + Also drop does not work on stems any more. diff --git a/os2/OS2/REXX/MANIFEST b/os2/OS2/REXX/MANIFEST new file mode 100644 index 0000000000..4ac81492e4 --- /dev/null +++ b/os2/OS2/REXX/MANIFEST @@ -0,0 +1,14 @@ +Changes +MANIFEST +Makefile.PL +REXX.pm +REXX.xs +t/rx_cmprt.t +t/rx_dllld.t +t/rx_objcall.t +t/rx_sql.test +t/rx_tiesql.test +t/rx_tievar.t +t/rx_tieydb.t +t/rx_varset.t +t/rx_vrexx.t diff --git a/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL new file mode 100644 index 0000000000..07f6cc67ea --- /dev/null +++ b/os2/OS2/REXX/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'OS2::REXX', + VERSION => '0.2', + XSPROTOARG => '-noprototypes', +); diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm new file mode 100644 index 0000000000..78e0cf917d --- /dev/null +++ b/os2/OS2/REXX/REXX.pm @@ -0,0 +1,387 @@ +package OS2::REXX; + +use Carp; +require Exporter; +require DynaLoader; +@ISA = qw(Exporter DynaLoader); +# Items to export into callers namespace by default +# (move infrequently used names to @EXPORT_OK below) +@EXPORT = qw(REXX_call REXX_eval REXX_eval_with); +# Other items we are prepared to export if requested +@EXPORT_OK = qw(drop); + +sub AUTOLOAD { + $AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/ + or confess("Undefined subroutine &$AUTOLOAD called"); + return undef if $1 eq "DESTROY"; + $_[0]->find($1) + or confess("Can't find entry '$1' to DLL '$_[0]->{File}'"); + goto &$AUTOLOAD; +} + +@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'}); +%dlls = (); + +bootstrap OS2::REXX; + +# Preloaded methods go here. Autoload methods go after __END__, and are +# processed by the autosplit program. + +# Cannot autoload, the autoloader is used for the REXX functions. + +sub load +{ + confess 'Usage: load OS2::REXX <file> [<dirs>]' unless $#_ >= 1; + my ($class, $file, @where) = (@_, @libs); + return $dlls{$file} if $dlls{$file}; + my $handle; + foreach (@where) { + $handle = DynaLoader::dl_load_file("$_/$file.dll"); + last if $handle; + } + return undef unless $handle; + eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');" + . "sub AUTOLOAD {" + . " \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;" + . " goto &OS2::REXX::AUTOLOAD;" + . "} 1;" or die "eval package $@"; + return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file"; +} + +sub find +{ + my $self = shift; + my $file = $self->{File}; + my $handle = $self->{Handle}; + my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : ""; + my $queue = $self->{Queue}; + foreach (@_) { + my $name = "OS2::REXX::${file}::$_"; + next if defined(&$name); + my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_) + || DynaLoader::dl_find_symbol($handle, $prefix.$_) + or return 0; + eval "package OS2::REXX::$file; sub $_". + "{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }". + "1;" + or die "eval sub"; + } + return 1; +} + +sub prefix +{ + my $self = shift; + $self->{Prefix} = shift; +} + +sub queue +{ + my $self = shift; + $self->{Queue} = shift; +} + +sub drop +{ # Supposedly should drop anything with + # the given prefix. Unfortunately a + # loop is needed after fixpack17. +&OS2::REXX::_drop(@_); +} + +sub dropall +{ # Supposedly should drop anything with + # the given prefix. Unfortunately a + # loop is needed after fixpack17. + &OS2::REXX::_drop(@_); # Try to drop them all. + my $name; + for (@_) { + if (/\.$/) { + OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator + while (($name) = OS2::REXX::_next($_)) { + OS2::REXX::_drop($_ . $name); + } + } + } +} + +sub TIESCALAR +{ + my ($obj, $name) = @_; + $name =~ s/^[\w!?]+/\U$&\E/; + return bless \$name, OS2::REXX::_SCALAR; +} + +sub TIEARRAY +{ + my ($obj, $name) = @_; + $name =~ s/^[\w!?]+/\U$&\E/; + return bless [$name, 0], OS2::REXX::_ARRAY; +} + +sub TIEHASH +{ + my ($obj, $name) = @_; + $name =~ s/^[\w!?]+/\U$&\E/; + return bless {Stem => $name}, OS2::REXX::_HASH; +} + +############################################################################# +package OS2::REXX::_SCALAR; + +sub FETCH +{ + return OS2::REXX::_fetch(${$_[0]}); +} + +sub STORE +{ + return OS2::REXX::_set(${$_[0]}, $_[1]); +} + +sub DESTROY +{ + return OS2::REXX::_drop(${$_[0]}); +} + +############################################################################# +package OS2::REXX::_ARRAY; + +sub FETCH +{ + $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; + return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1])); +} + +sub STORE +{ + $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1]; + return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]); +} + +############################################################################# +package OS2::REXX::_HASH; + +require Tie::Hash; +@ISA = ('Tie::Hash'); + +sub FIRSTKEY +{ + my ($self) = @_; + my $stem = $self->{Stem}; + + delete $self->{List} if exists $self->{List}; + + my @list = (); + my ($name, $value); + OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator + while (($name) = OS2::REXX::_next($stem)) { + push @list, $name; + } + my $key = pop @list; + + $self->{List} = \@list; + return $key; +} + +sub NEXTKEY +{ + return pop @{$_[0]->{List}}; +} + +sub EXISTS +{ + return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); +} + +sub FETCH +{ + return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]); +} + +sub STORE +{ + return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]); +} + +sub DELETE +{ + OS2::REXX::_drop($_[0]->{Stem}.$_[1]); +} + +############################################################################# +package OS2::REXX; + +1; +__END__ + +=head1 NAME + +OS2::REXX - access to DLLs with REXX calling convention and REXX runtime. + +=head2 NOTE + +By default, the REXX variable pool is not available, neither +to Perl, nor to external REXX functions. To enable it, you need to put +your code inside C<REXX_call> function. REXX functions which do not use +variables may be usable even without C<REXX_call> though. + +=head1 SYNOPSIS + + use OS2::REXX; + $ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!"; + @pid = $ydb->RxProcId(); + REXX_call { + tie $s, OS2::REXX, "TEST"; + $s = 1; + }; + +=head1 DESCRIPTION + +=head2 Load REXX DLL + + $dll = load OS2::REXX NAME [, WHERE]; + +NAME is DLL name, without path and extension. + +Directories are searched WHERE first (list of dirs), then environment +paths PERL5REXX, PERLREXX or, as last resort, PATH. + +The DLL is not unloaded when the variable dies. + +Returns DLL object reference, or undef on failure. + +=head2 Define function prefix: + + $dll->prefix(NAME); + +Define the prefix of external functions, prepended to the function +names used within your program, when looking for the entries in the +DLL. + +=head2 Example + + $dll = load OS2::REXX "RexxBase"; + $dll->prefix("RexxBase_"); + $dll->Init(); + +is the same as + + $dll = load OS2::REXX "RexxBase"; + $dll->RexxBase_Init(); + +=head2 Define queue: + + $dll->queue(NAME); + +Define the name of the REXX queue passed to all external +functions of this module. Defaults to "SESSION". + +Check for functions (optional): + + BOOL = $dll->find(NAME [, NAME [, ...]]); + +Returns true if all functions are available. + +=head2 Call external REXX function: + + $dll->function(arguments); + +Returns the return string if the return code is 0, else undef. +Dies with error message if the function is not available. + +=head1 Accessing REXX-runtime + +While calling functions with REXX signature does not require the presence +of the system REXX DLL, there are some actions which require REXX-runtime +present. Among them is the access to REXX variables by name. + +One enables REXX runtime by bracketing your code by + + REXX_call BLOCK; + +(trailing semicolon required!) or + + REXX_call \&subroutine_name; + +Inside such a call one has access to REXX variables (see below), and to + + REXX_eval EXPR; + REXX_eval_with EXPR, + subroutine_name_in_REXX => \&Perl_subroutine + +=head2 Bind scalar variable to REXX variable: + + tie $var, OS2::REXX, "NAME"; + +=head2 Bind array variable to REXX stem variable: + + tie @var, OS2::REXX, "NAME."; + +Only scalar operations work so far. No array assignments, no array +operations, ... FORGET IT. + +=head2 Bind hash array variable to REXX stem variable: + + tie %var, OS2::REXX, "NAME."; + +To access all visible REXX variables via hash array, bind to ""; + +No array assignments. No array operations, other than hash array +operations. Just like the *dbm based implementations. + +For the usual REXX stem variables, append a "." to the name, +as shown above. If the hash key is part of the stem name, for +example if you bind to "", you cannot use lower case in the stem +part of the key and it is subject to character set restrictions. + +=head2 Erase individual REXX variables (bound or not): + + OS2::REXX::drop("NAME" [, "NAME" [, ...]]); + +=head2 Erase REXX variables with given stem (bound or not): + + OS2::REXX::dropall("STEM" [, "STEM" [, ...]]); + +=head1 NOTES + +Note that while function and variable names are case insensitive in the +REXX language, function names exported by a DLL and the REXX variables +(as seen by Perl through the chosen API) are all case sensitive! + +Most REXX DLLs export function names all upper case, but there are a +few which export mixed case names (such as RxExtras). When trying to +find the entry point, both exact case and all upper case are searched. +If the DLL exports "RxNap", you have to specify the exact case, if it +exports "RXOPEN", you can use any case. + +To avoid interfering with subroutine names defined by Perl (DESTROY) +or used within the REXX module (prefix, find), it is best to use mixed +case and to avoid lowercase only or uppercase only names when calling +REXX functions. Be consistent. The same function written in different +ways results in different Perl stubs. + +There is no REXX interpolation on variable names, so the REXX variable +name TEST.ONE is not affected by some other REXX variable ONE. And it +is not the same variable as TEST.one! + +You cannot call REXX functions which are not exported by the DLL. +While most DLLs export all their functions, some, like RxFTP, export +only "...LoadFuncs", which registers the functions within REXX only. + +You cannot call 16-bit DLLs. The few interesting ones I found +(FTP,NETB,APPC) do not export their functions. + +I do not know whether the REXX API is reentrant with respect to +exceptions (signals) when the REXX top-level exception handler is +overridden. So unless you know better than I do, do not access REXX +variables (probably tied to Perl variables) or call REXX functions +which access REXX queues or REXX variables in signal handlers. + +See C<t/rx*.t> for examples. + +=head1 AUTHOR + +Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich +ilya@math.ohio-state.edu. + +=cut diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs new file mode 100644 index 0000000000..df7646c42e --- /dev/null +++ b/os2/OS2/REXX/REXX.xs @@ -0,0 +1,484 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define INCL_BASE +#define INCL_REXXSAA +#include <os2emx.h> + +#if 0 +#define INCL_REXXSAA +#pragma pack(1) +#define _Packed +#include <rexxsaa.h> +#pragma pack() +#endif + +extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *, + EXCEPTIONREGISTRATIONRECORD *, + CONTEXTRECORD *, + void *); + +static RXSTRING * strs; +static int nstrs; +static SHVBLOCK * vars; +static int nvars; +static char * trace; + +static RXSTRING rxcommand = { 9, "RXCOMMAND" }; +static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" }; +static RXSTRING rxfunction = { 11, "RXFUNCTION" }; + +static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret); + +#if 1 + #define Set RXSHV_SET + #define Fetch RXSHV_FETCH + #define Drop RXSHV_DROPV +#else + #define Set RXSHV_SYSET + #define Fetch RXSHV_SYFET + #define Drop RXSHV_SYDRO +#endif + +static long incompartment; + +static SV* +exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler) +{ + HMODULE hRexx, hRexxAPI; + BYTE buf[200]; + LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING, + PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING); + APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ, + RexxFunctionHandler *); + APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ); + RXSTRING args[1]; + RXSTRING inst[2]; + RXSTRING result; + USHORT retcode; + LONG rc; + SV *res; + + if (incompartment) die ("Attempt to reenter into REXX compartment"); + incompartment = 1; + + if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx) + || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI) + || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart) + || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe", + (PFN *)&pRexxRegisterFunctionExe) + || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction", + (PFN *)&pRexxDeregisterFunction)) { + die("REXX not available\n"); + } + + if (handlerName) + pRexxRegisterFunctionExe(handlerName, handler); + + MAKERXSTRING(args[0], NULL, 0); + MAKERXSTRING(inst[0], cmd, strlen(cmd)); + MAKERXSTRING(inst[1], NULL, 0); + MAKERXSTRING(result, NULL, 0); + rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL, + &retcode, &result); + + incompartment = 0; + pRexxDeregisterFunction("StartPerl"); + DosFreeModule(hRexxAPI); + DosFreeModule(hRexx); + if (!RXNULLSTRING(result)) { + res = newSVpv(RXSTRPTR(result), RXSTRLEN(result)); + DosFreeMem(RXSTRPTR(result)); + } else { + res = NEWSV(729,0); + } + if (rc || SvTRUE(GvSV(errgv))) { + if (SvTRUE(GvSV(errgv))) { + die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(errgv), na)) ; + } + die ("REXX compartment returned non-zero status %li", rc); + } + + return res; +} + +static SV* exec_cv; + +static ULONG +PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret) +{ + return PERLCALL(NULL, argc, argv, queue, ret); +} + +#define in_rexx_compartment() exec_in_REXX("return StartPerl()\r\n", \ + "StartPerl", PERLSTART) +#define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment()) +#define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \ + exec_in_REXX(cmd,name,PERLSTART)) +#define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL) + +static ULONG +PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret) +{ + EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception }; + int i, rc; + unsigned long len; + char *str; + char **arr; + dSP; + + DosSetExceptionHandler(&xreg); + + ENTER; + SAVETMPS; + PUSHMARK(sp); + +#if 0 + if (!my_perl) { + DosUnsetExceptionHandler(&xreg); + return 1; + } +#endif + + if (name) { + int ac = 0; + char **arr = alloca((argc + 1) * sizeof(char *)); + + for (i = 0; i < argc; ++i) + arr[ac++] = argv[i].strptr; + arr[ac] = NULL; + + rc = perl_call_argv(name, G_SCALAR | G_EVAL, arr); + } else if (exec_cv) { + SV *cv = exec_cv; + + exec_cv = NULL; + rc = perl_call_sv(cv, G_SCALAR | G_EVAL); + } else rc = -1; + + SPAGAIN; + + if (rc == 1 && SvOK(TOPs)) { + str = SvPVx(POPs, len); + if (len > 256) + if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) { + DosUnsetExceptionHandler(&xreg); + return 1; + } + memcpy(ret->strptr, str, len); + ret->strlength = len; + } + + PUTBACK ; + FREETMPS ; + LEAVE ; + + if (rc != 1) { + DosUnsetExceptionHandler(&xreg); + return 1; + } + + + DosUnsetExceptionHandler(&xreg); + return 0; +} + +static void +needstrs(int n) +{ + if (n > nstrs) { + if (strs) + free(strs); + nstrs = 2 * n; + strs = malloc(nstrs * sizeof(RXSTRING)); + } +} + +static void +needvars(int n) +{ + if (n > nvars) { + if (vars) + free(vars); + nvars = 2 * n; + vars = malloc(nvars * sizeof(SHVBLOCK)); + } +} + +static void +initialize(void) +{ + needstrs(8); + needvars(8); + trace = getenv("PERL_REXX_DEBUG"); +} + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static int +constant(name, arg) +char *name; +int arg; +{ + errno = EINVAL; + return 0; +} + + +MODULE = OS2::REXX PACKAGE = OS2::REXX + +BOOT: + initialize(); + +int +constant(name,arg) + char * name + int arg + +SV * +_call(name, address, queue="SESSION", ...) + char * name + void * address + char * queue + CODE: + { + ULONG rc; + int argc, i; + RXSTRING result; + UCHAR resbuf[256]; + RexxFunctionHandler *fcn = address; + argc = items-3; + needstrs(argc); + if (trace) + fprintf(stderr, "REXXCALL::_call name: '%s' args:", name); + for (i = 0; i < argc; ++i) { + STRLEN len; + char *ptr = SvPV(ST(3+i), len); + MAKERXSTRING(strs[i], ptr, len); + if (trace) + fprintf(stderr, " '%.*s'", len, ptr); + } + if (!*queue) + queue = "SESSION"; + if (trace) + fprintf(stderr, "\n"); + MAKERXSTRING(result, resbuf, sizeof resbuf); + rc = fcn(name, argc, strs, queue, &result); + if (trace) + fprintf(stderr, " rc=%X, result='%.*s'\n", rc, + result.strlength, result.strptr); + ST(0) = sv_newmortal(); + if (rc == 0) { + if (result.strptr) + sv_setpvn(ST(0), result.strptr, result.strlength); + else + sv_setpvn(ST(0), "", 0); + } + if (result.strptr && result.strptr != resbuf) + DosFreeMem(result.strptr); + } + +int +_set(name,value,...) + char * name + char * value + CODE: + { + int i; + int n = (items + 1) / 2; + ULONG rc; + needvars(n); + if (trace) + fprintf(stderr, "REXXCALL::_set"); + for (i = 0; i < n; ++i) { + SHVBLOCK * var = &vars[i]; + STRLEN namelen; + STRLEN valuelen; + name = SvPV(ST(2*i+0),namelen); + if (2*i+1 < items) { + value = SvPV(ST(2*i+1),valuelen); + } + else { + value = ""; + valuelen = 0; + } + var->shvcode = RXSHV_SET; + var->shvnext = &vars[i+1]; + var->shvnamelen = namelen; + var->shvvaluelen = valuelen; + MAKERXSTRING(var->shvname, name, namelen); + MAKERXSTRING(var->shvvalue, value, valuelen); + if (trace) + fprintf(stderr, " %.*s='%.*s'", + var->shvname.strlength, var->shvname.strptr, + var->shvvalue.strlength, var->shvvalue.strptr); + } + if (trace) + fprintf(stderr, "\n"); + vars[n-1].shvnext = NULL; + rc = RexxVariablePool(vars); + if (trace) + fprintf(stderr, " rc=%X\n", rc); + RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE; + } + OUTPUT: + RETVAL + +void +_fetch(name, ...) + char * name + PPCODE: + { + int i; + ULONG rc; + EXTEND(sp, items); + needvars(items); + if (trace) + fprintf(stderr, "REXXCALL::_fetch"); + for (i = 0; i < items; ++i) { + SHVBLOCK * var = &vars[i]; + STRLEN namelen; + name = SvPV(ST(i),namelen); + var->shvcode = RXSHV_FETCH; + var->shvnext = &vars[i+1]; + var->shvnamelen = namelen; + var->shvvaluelen = 0; + MAKERXSTRING(var->shvname, name, namelen); + MAKERXSTRING(var->shvvalue, NULL, 0); + if (trace) + fprintf(stderr, " '%s'", name); + } + if (trace) + fprintf(stderr, "\n"); + vars[items-1].shvnext = NULL; + rc = RexxVariablePool(vars); + if (!(rc & ~RXSHV_NEWV)) { + for (i = 0; i < items; ++i) { + int namelen; + SHVBLOCK * var = &vars[i]; + /* returned lengths appear to be swapped */ + /* but beware of "future bug fixes" */ + namelen = var->shvvalue.strlength; /* should be */ + if (var->shvvaluelen < var->shvvalue.strlength) + namelen = var->shvvaluelen; /* is */ + if (trace) + fprintf(stderr, " %.*s='%.*s'\n", + var->shvname.strlength, var->shvname.strptr, + namelen, var->shvvalue.strptr); + if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr) + PUSHs(&sv_undef); + else + PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr, + namelen))); + } + } else { + if (trace) + fprintf(stderr, " rc=%X\n", rc); + } + } + +void +_next(stem) + char * stem + PPCODE: + { + SHVBLOCK sv; + BYTE name[4096]; + ULONG rc; + int len = strlen(stem), namelen, valuelen; + if (trace) + fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem); + sv.shvcode = RXSHV_NEXTV; + sv.shvnext = NULL; + MAKERXSTRING(sv.shvvalue, NULL, 0); + do { + sv.shvnamelen = sizeof name; + sv.shvvaluelen = 0; + MAKERXSTRING(sv.shvname, name, sizeof name); + if (sv.shvvalue.strptr) { + DosFreeMem(sv.shvvalue.strptr); + MAKERXSTRING(sv.shvvalue, NULL, 0); + } + rc = RexxVariablePool(&sv); + } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0); + if (!rc) { + EXTEND(sp, 2); + /* returned lengths appear to be swapped */ + /* but beware of "future bug fixes" */ + namelen = sv.shvname.strlength; /* should be */ + if (sv.shvnamelen < sv.shvname.strlength) + namelen = sv.shvnamelen; /* is */ + valuelen = sv.shvvalue.strlength; /* should be */ + if (sv.shvvaluelen < sv.shvvalue.strlength) + valuelen = sv.shvvaluelen; /* is */ + if (trace) + fprintf(stderr, " %.*s='%.*s'\n", + namelen, sv.shvname.strptr, + valuelen, sv.shvvalue.strptr); + PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len))); + if (sv.shvvalue.strptr) { + PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen))); + DosFreeMem(sv.shvvalue.strptr); + } else + PUSHs(&sv_undef); + } else if (rc != RXSHV_LVAR) { + die("Error %i when in _next", rc); + } else { + if (trace) + fprintf(stderr, " rc=%X\n", rc); + } + } + +int +_drop(name,...) + char * name + CODE: + { + int i; + needvars(items); + for (i = 0; i < items; ++i) { + SHVBLOCK * var = &vars[i]; + STRLEN namelen; + name = SvPV(ST(i),namelen); + var->shvcode = RXSHV_DROPV; + var->shvnext = &vars[i+1]; + var->shvnamelen = namelen; + var->shvvaluelen = 0; + MAKERXSTRING(var->shvname, name, var->shvnamelen); + MAKERXSTRING(var->shvvalue, NULL, 0); + } + vars[items-1].shvnext = NULL; + RETVAL = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE; + } + OUTPUT: + RETVAL + +int +_register(name) + char * name + CODE: + RETVAL = RexxRegisterFunctionExe(name, PERLCALL); + OUTPUT: + RETVAL + +SV* +REXX_call(cv) + SV *cv + PROTOTYPE: & + +SV* +REXX_eval(cmd) + char *cmd + +SV* +REXX_eval_with(cmd,name,cv) + char *cmd + char *name + SV *cv diff --git a/os2/OS2/REXX/t/rx_cmprt.t b/os2/OS2/REXX/t/rx_cmprt.t new file mode 100644 index 0000000000..a73e43e36e --- /dev/null +++ b/os2/OS2/REXX/t/rx_cmprt.t @@ -0,0 +1,40 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +$| = 1; # Otherwise data from REXX may come first + +print "1..13\n"; + +$n = 1; +sub do_me { + print "ok $n\n"; + "OK"; +} + +@res = REXX_call(\&do_me); +print "ok 2\n"; +@res == 1 ? print "ok 3\n" : print "not ok 3\n"; +$res[0] eq "OK" ? print "ok 4\n" : print "not ok 4\n# `$res[0]'\n"; + +# Try again +$n = 5; +@res = REXX_call(\&do_me); +print "ok 6\n"; +@res == 1 ? print "ok 7\n" : print "not ok 7\n"; +$res[0] eq "OK" ? print "ok 8\n" : print "not ok 8\n# `$res[0]'\n"; + +REXX_call { print "ok 9\n" }; +REXX_eval 'say "ok 10"'; +# Try again +REXX_eval 'say "ok 11"'; +print "ok 12\n" if REXX_eval("return 2 + 3") eq 5; +REXX_eval_with 'say myfunc()', myfunc => sub {"ok 13"}; diff --git a/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t new file mode 100644 index 0000000000..317743f3cb --- /dev/null +++ b/os2/OS2/REXX/t/rx_dllld.t @@ -0,0 +1,36 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +$path = $ENV{LIBPATH} || $ENV{PATH} or die; +foreach $dir (split(';', $path)) { + next unless -f "$dir/YDBAUTIL.DLL"; + $found = "$dir/YDBAUTIL.DLL"; + last; +} +$found or die "1..0\n#Cannot find YDBAUTIL.DLL\n"; + +print "1..5\n"; + +$module = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n"; +print "ok 1\n"; + +$address = DynaLoader::dl_find_symbol($module, "RXPROCID") + or die "not ok 2\n# find\n"; +print "ok 2\n"; + +$result = OS2::REXX::_call("RxProcId", $address) or die "not ok 3\n# REXX"; +print "ok 3\n"; + +($pid, $ppid, $ssid) = split(/\s+/, $result); +$pid == $$ ? print "ok 4\n" : print "not ok 4\n# pid\n"; +$ssid == 1 ? print "ok 5\n" : print "not ok 5\n# pid\n"; +print "# pid=$pid, ppid=$ppid, ssid=$ssid\n"; diff --git a/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t new file mode 100644 index 0000000000..b4f04c308a --- /dev/null +++ b/os2/OS2/REXX/t/rx_objcall.t @@ -0,0 +1,33 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +# +# DLL +# +$ydba = load OS2::REXX "ydbautil" or die "1..0\n# load\n"; +print "1..5\n", "ok 1\n"; + +# +# function +# +@pid = $ydba->RxProcId(); +@pid == 1 ? print "ok 2\n" : print "not ok 2\n"; +@res = split " ", $pid[0]; +print "ok 3\n" if $res[0] == $$; +@pid = $ydba->RxProcId(); +@res = split " ", $pid[0]; +print "ok 4\n" if $res[0] == $$; +print "# @pid\n"; + +eval { $ydba->nixda(); }; +print "ok 5\n" if $@ =~ /^Can't find entry 'nixda\'/; + diff --git a/os2/OS2/REXX/t/rx_sql.test b/os2/OS2/REXX/t/rx_sql.test new file mode 100644 index 0000000000..4f984250a3 --- /dev/null +++ b/os2/OS2/REXX/t/rx_sql.test @@ -0,0 +1,97 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +sub stmt +{ + my ($s) = @_; + $s =~ s/\s*\n\s*/ /g; + $s =~ s/^\s+//; + $s =~ s/\s+$//; + return $s; +} + +sub sqlcode +{ + OS2::REXX::_fetch("SQLCA.SQLCODE"); +} + +sub sqlstate +{ + OS2::REXX::_fetch("SQLCA.SQLSTATE"); +} + +sub sql +{ + my ($stmt) = stmt(@_); + return 0 if OS2::REXX::_call("sqlexec", $sqlexec, "", $stmt); + return sqlcode() >= 0; +} + +sub dbs +{ + my ($stmt) = stmt(@_); + return 0 if OS2::REXX::_call("sqldbs", $sqldbs, "", $stmt); + return sqlcode() >= 0; +} + +sub error +{ + my ($where) = @_; + print "ERROR in $where: sqlcode=", sqlcode(), " sqlstate=", sqlstate(), "\n"; + dbs("GET MESSAGE INTO :MSG LINEWIDTH 75"); + my $msg = OS2::REXX::_fetch("MSG"); + print "\n", $msg; + exit 1; +} + +REXX_call { + + $sqlar = DynaLoader::dl_load_file("h:/sqllib/dll/sqlar.dll") or die "load"; + $sqldbs = DynaLoader::dl_find_symbol($sqlar, "SQLDBS") or die "find sqldbs"; + $sqlexec = DynaLoader::dl_find_symbol($sqlar, "SQLEXEC") or die "find sqlexec"; + + sql(<<) or error("connect"); + CONNECT TO sample IN SHARE MODE + + OS2::REXX::_set("STMT" => stmt(<<)); + SELECT name FROM sysibm.systables + + sql(<<) or error("prepare"); + PREPARE s1 FROM :stmt + + sql(<<) or error("declare"); + DECLARE c1 CURSOR FOR s1 + + sql(<<) or error("open"); + OPEN c1 + + while (1) { + sql(<<) or error("fetch"); + FETCH c1 INTO :name + + last if sqlcode() == 100; + + print "Table name is ", OS2::REXX::_fetch("NAME"), "\n"; + } + + sql(<<) or error("close"); + CLOSE c1 + + sql(<<) or error("rollback"); + ROLLBACK + + sql(<<) or error("disconnect"); + CONNECT RESET + +}; + +exit 0; diff --git a/os2/OS2/REXX/t/rx_tiesql.test b/os2/OS2/REXX/t/rx_tiesql.test new file mode 100644 index 0000000000..2947516755 --- /dev/null +++ b/os2/OS2/REXX/t/rx_tiesql.test @@ -0,0 +1,86 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +#extproc perl5 -Rx +#! perl + +use REXX; + +$db2 = load REXX "sqlar" or die "load"; +tie $sqlcode, REXX, "SQLCA.SQLCODE"; +tie $sqlstate, REXX, "SQLCA.SQLSTATE"; +tie %rexx, REXX, ""; + +sub stmt +{ + my ($s) = @_; + $s =~ s/\s*\n\s*/ /g; + $s =~ s/^\s+//; + $s =~ s/\s+$//; + return $s; +} + +sub sql +{ + my ($stmt) = stmt(@_); + return 0 if $db2->SqlExec($stmt); + return $sqlcode >= 0; +} + +sub dbs +{ + my ($stmt) = stmt(@_); + return 0 if $db2->SqlDBS($stmt); + return $sqlcode >= 0; +} + +sub error +{ + my ($where) = @_; + print "ERROR in $where: sqlcode=$sqlcode, sqlstate=$sqlstate\n"; + dbs("GET MESSAGE INTO :msg LINEWIDTH 75"); + print "\n", $rexx{'MSG'}; + exit 1; +} + +sql(<<) or error("connect"); + CONNECT TO sample IN SHARE MODE + +$rexx{'STMT'} = stmt(<<); + SELECT name FROM sysibm.systables + +sql(<<) or error("prepare"); + PREPARE s1 FROM :stmt + +sql(<<) or error("declare"); + DECLARE c1 CURSOR FOR s1 + +sql(<<) or error("open"); + OPEN c1 + +while (1) { + sql(<<) or error("fetch"); + FETCH c1 INTO :name + + last if $sqlcode == 100; + + print "Table name is $rexx{'NAME'}\n"; +} + +sql(<<) or error("close"); + CLOSE c1 + +sql(<<) or error("rollback"); + ROLLBACK + +sql(<<) or error("disconnect"); + CONNECT RESET + +exit 0; diff --git a/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t new file mode 100644 index 0000000000..6132e23f80 --- /dev/null +++ b/os2/OS2/REXX/t/rx_tievar.t @@ -0,0 +1,88 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +# +# DLL +# +load OS2::REXX "ydbautil" or die "1..0\n# load\n"; + +print "1..19\n"; + +REXX_call { + print "ok 1\n"; + + # + # scalar + # + tie $s, OS2::REXX, "TEST"; + print "ok 2\n"; + $s = 1; + print "ok 3\n" if $s eq 1; + print "not ok 3\n# `$s'\n" unless $s eq 1; + untie $s; + + # + # hash + # + + tie %all, OS2::REXX, ""; # all REXX vars + print "ok 4\n"; + + sub show { + # show all REXX vars + print "--@_--\n"; + foreach (keys %all) { + $v = $all{$_}; + print "$_ => $v\n"; + } + } + + sub check { + # check all REXX vars + my ($test, @arr) = @_; + my @rx; + foreach $key (sort keys %all) { push @rx, $key, $all{$key} } + if ("@rx" eq "@arr") {print "ok $test\n"} + else { print "not ok $test\n# expect `@arr', got `@rx'\n" } + } + + + tie %h, OS2::REXX, "TEST."; + print "ok 5\n"; + check(6); + + $h{"one"} = 1; + check(7, "TEST.one", 1); + + $h{"two"} = 2; + check(8, "TEST.one", 1, "TEST.two", 2); + + $h{"one"} = ""; + check(9, "TEST.one", "", "TEST.two", 2); + print "ok 10\n" if exists $h{"one"}; + print "ok 11\n" if exists $h{"two"}; + + delete $h{"one"}; + check(12, "TEST.two", 2); + print "ok 13\n" if not exists $h{"one"}; + print "ok 14\n" if exists $h{"two"}; + + OS2::REXX::dropall("TEST."); + print "ok 15\n"; + check(16); + print "ok 17\n" if not exists $h{"one"}; + print "ok 18\n" if not exists $h{"two"}; + + untie %h; + print "ok 19"; + +}; diff --git a/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t new file mode 100644 index 0000000000..8251051265 --- /dev/null +++ b/os2/OS2/REXX/t/rx_tieydb.t @@ -0,0 +1,31 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; +$rx = load OS2::REXX "ydbautil" or die "1..0\n# load\n"; # from RXU17.ZIP +print "1..7\n", "ok 1\n"; + +$rx->prefix("Rx"); # implicit function prefix +print "ok 2\n"; + +REXX_call { + tie @pib, OS2::REXX, "IB.P"; # bind array to REXX stem variable + print "ok 3\n"; + tie %tib, OS2::REXX, "IB.T."; # bind associative array to REXX stem var + print "ok 4\n"; + + $rx->GetInfoBlocks("IB."); # call REXX function + print "ok 5\n"; + defined $pib[6] ? print "ok 6\n" : print "not ok 6\n# pib\n"; + defined $tib{7} && $tib{7} =~ /^\d+$/ ? print "ok 7\n" + : print "not ok 7\n# tib\n"; + print "# Process status is ", unpack("I", $pib[6]), + ", thread ordinal is $tib{7}\n"; +}; diff --git a/os2/OS2/REXX/t/rx_varset.t b/os2/OS2/REXX/t/rx_varset.t new file mode 100644 index 0000000000..9d4f3b2e56 --- /dev/null +++ b/os2/OS2/REXX/t/rx_varset.t @@ -0,0 +1,39 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +print "1..9\n"; + +REXX_call { + OS2::REXX::_set("X" => sqrt(2)) and print "ok 1\n"; + $x = OS2::REXX::_fetch("X") and print "ok 2\n"; + if (abs($x - sqrt(2)) < 5e-15) { + print "ok 3\n"; + } else { print "not ok 3\n# sqrt(2) = @{[sqrt(2)]} != `$x'\n" } + OS2::REXX::_set("Y" => sqrt(3)) and print "ok 4\n"; + $i = 0; + $n = 4; + while (($name, $value) = OS2::REXX::_next("")) { + $i++; $n++; + if ($i <= 2 and $name eq "Y" ) { + if ($value eq sqrt(3)) { + print "ok $n\n"; + } else { + print "not ok $n\n# `$name' => `$value'\n" ; + } + } elsif ($i <= 2 and $name eq "X") { + print "ok $n\n" if $value eq sqrt(2); + } else { print "not ok 7\n# name `$name', value `$value'\n" } + } + print "ok 7\n" if $i == 2; + OS2::REXX::_drop("X") and print "ok 8\n"; + $x = OS2::REXX::_fetch("X") or print "ok 9\n"; +}; diff --git a/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t new file mode 100644 index 0000000000..a40749f55f --- /dev/null +++ b/os2/OS2/REXX/t/rx_vrexx.t @@ -0,0 +1,59 @@ +BEGIN { + chdir 't' if -d 't/lib'; + @INC = '../lib' if -d 'lib'; + require Config; import Config; + if (-d 'lib' and $Config{'extensions'} !~ /\bOS2::REXX\b/) { + print "1..0\n"; + exit 0; + } +} + +use OS2::REXX; + +$name = "VREXX"; +$path = $ENV{LIBPATH} || $ENV{PATH} or die; +foreach $dir (split(';', $path)) { + next unless -f "$dir/$name.DLL"; + $found = "$dir/$name.DLL"; + print "# found at `$found'\n"; + last; +} +$found or die "1..0\n#Cannot find $name.DLL\n"; + +print "1..10\n"; + +REXX_call { + $vrexx = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n"; + print "ok 1\n"; + $vinit = DynaLoader::dl_find_symbol($vrexx, "VINIT") or die "find vinit"; + print "ok 2\n"; + $vexit = DynaLoader::dl_find_symbol($vrexx, "VEXIT") or die "find vexit"; + print "ok 3\n"; + $vmsgbox = DynaLoader::dl_find_symbol($vrexx, "VMSGBOX") or die "find vmsgbox"; + print "ok 4\n"; + $vversion= DynaLoader::dl_find_symbol($vrexx, "VGETVERSION") or die "find vgetversion"; + print "ok 5\n"; + + $result = OS2::REXX::_call("VInit", $vinit) or die "VInit"; + print "ok 6\n"; + print "# VInit: $result\n"; + + OS2::REXX::_set("MBOX.0" => 4, + "MBOX.1" => "Perl VREXX Access Test", + "MBOX.2" => "", + "MBOX.3" => "(C) Andreas Kaiser", + "MBOX.4" => "December 1994") + or die "set var"; + print "ok 7\n"; + + $result = OS2::REXX::_call("VGetVersion", $vversion) or die "VMsgBox"; + print "ok 8\n"; + print "# VGetVersion: $result\n"; + + $result = OS2::REXX::_call("VMsgBox", $vmsgbox, "", "Perl", "MBOX", 1) or die "VMsgBox"; + print "ok 9\n"; + print "# VMsgBox: $result\n"; + + OS2::REXX::_call("VExit", $vexit); + print "ok 10\n"; +}; diff --git a/os2/README b/os2/README new file mode 100644 index 0000000000..785a6098bb --- /dev/null +++ b/os2/README @@ -0,0 +1,814 @@ +Contents: + Notes on the patch + IMPORTANT NOTE + Target + Binary Install + Reading the docs + Notes on build on OS/2 + Compile summary + Tests which fail + Calls to external programs + OS/2 extensions + Report from the battlefield on 5.002_01 + +Notes on the patch: +~~~~~~~~~~~~~~~~~~~ +patches should be applied as + patch -p0 <..... +All the diff.* files and POSIX.mkfifo should be applied. + +Additional files are available on + ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2 +including patched pdksh and gnumake, needed for build. + + <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +IMPORTANT NOTE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +Note with the release 5.003_01 the dynamically loadable libraries +should be rebuilt. In particular, DLLs are now created with the names +which contain a checksum, thus allowing workaround for OS/2 scheme of +caching DLLs. + +In particular, it is VERY IMPORTANT to have a correct perl.dll on +LIBPATH during build, otherwise DLLs with wrong names will be +created. Or have a perl.dll with the same naming convention for DLLs +(hopefully, it should not change any time soon), or remove it from +LIBPATH, add . to LIBPATH, wait until the build of DynaLoader fails, +and then move the built DLL into LIBPATH. + +I also used this possibility to change perl linking type to -Zmt. It +means that Perl now uses multithreaded CRTDLL, so your extensions can +be multithreaded (note that the perl core is not thread-safe so far, +so make sure you access Perl from one thread only). In particular, it +is no longer needed to statically link X11_s.lib if you compile +Perl/Tk/XFree. + +This newer port includes + . numeric first argument to system(), see OS2::Process docs; + . modules OS2::Process, OS2::REXX, OS2::PrfDB, OS2::ExtAttrib. + . {get,set,end}*ent may work now (not checked) +(most of this merged from ak's port). + +Note that static build of OS2::ExtAttrib fails some tests! + +Target: +~~~~~~~ + +This is not supposed to make a perfect Perl on OS/2. This patch is +concerned only with perfect _build_ of Perl on OS/2. Some good +features from Andreas Kaiser port missed this port. However, most of +the features are available (possibly in different form). + +!!! Note that [gs]etpriority functions in this port are compatible +!!! with *nix, not with ak's port!!! + +The priorities are absolute, go from 32 to -95, lower is quickier. 0 +is default, + +Binary Install: +~~~~~~~~~~~~~~ +This version of perl allows binary installation on another site. There +are two possibilities: + a) sh.exe is in the directory with the same name as on machine +where perl was compiled (f:/bin here), and perl library is installed +into the same directory as the built target (f:/perllib); + b) One of the above conditions is not true. Perl may be +informed about location of sh.exe via PERL_SH_DRIVE or PERL_SH_DIR +(see below). To relocate the perl library, one can + b1) either use the usual PERLLIB environment variable - but +you should deduce yourself which components should be put there, say, +by doing + perl -de 0 + x \@INC + q +in the directory of the perl library. Another problem with this is +that a module is missing, then perl will try to scan the builtin +directories nevertheless. If perl was intended to be installed on +f:/perllib, but your f: is a CDROM, then you may have some trouble. + b2) Best: binary edit perl.dll and perl_.exe (using perl +itself as a binary editor) to fix the paths. Note that the new paths +should be better no longer than the old. + b3) More convinient: set PERLLIB_PREFIX environment +variable. It should contain two components, separated by whitespace +and/or semicolon `;'. The first component is translated to the second +one if it is + a prefix of + a component of + Perl library lookup path. +Say, if you install perllibrary into c:/lib/perl/ instead of +f:/perllib/, set it to + set PERLLIB_PREFIX=f:/perllib/;c:/lib/perl/ + +Reading the docs: +~~~~~~~~~~~~~~~~ +If your `man' is correctly installed, you should just add +x:/perllib/man directory to the end of MANPATH like this: + set MANPATH=c:/man;f:/perllib/man +After this you can access the docs like this: + man perlfunc + man 3 less + man ExtUtils.MakeMaker +Note that dot is used as package separator for package documentation, +and as usual, sometimes you need to give the section - 3 above - to +avoid shadowing by the less(1) manpage. + +Alternatively, you can build HTML docs by running + pod2html +in x:/perllib/lib/pod directory. + +Alternatively, you can build IPF source by running + pod2ipf > perl.ipf +in x:/perllib/lib/pod directory, and build (excellent! - best of perl +docs available!) .INF documentation by running + ipfc /inf perl.ipf +Move it on your BOOKSHELF path, and now you may inspect docs by + view perl +or + view perl keyword_to_see + +Alternatively you may pick up precompiled HTML and .INF docs from the +net, as usual, .INF is available on CPAN/.../os2/ilyaz. + +There are also _very_ good docs in TexInfo and Adobe PDF format. + +Notes on build on OS/2: +~~~~~~~~~~~~~~~~~~~~~~~ +a) Make sure your sort is not the broken OS/2 one, and that you have /tmp +on the build partition. Make sure that your pdksh.exe, make.exe and +db.lib are OK (look elsewhere in this file). + +b) when extracting perl5.*.tar.gz you need to extract perl5.*/Configure +separately, since by default perl5.001m/configure may overwrite it; + like this: + tar vzxf perl5.004.tar.gz --case-sensitive perl5.004/Configure +or + tar --case-sensitive -vzxf perl5.004.tar.gz perl5.004/Configure + +c) Necessary manual intervention when compiling on OS/2: + + Need to put perl.dll on LIBPATH after it is created. + +d) Compile summary: + ~~~~~~~~~~~~~~~ +!!! At the end of this README is independent description of the build +!!! process by Rocco Caputo. + +# Look for hints/os2.sh and correct what is different on your system +# I have rather spartan configuration. + + # Prefix means where to install: +sh Configure -des -D prefix=f:/perl5.005 + # Note that you need to have /tmp/ ready. + # + # Ignore the message about missing `ln', and about `c' option + # to tr. +make + # Will probably die after build of miniperl (unless you have DLL + # from previous compile). Need to move DLL where it belongs + # + # Somehow with 5.002b3 I needed to type another make after pod2man +make + # some warnings in POSIX.c +make test + # some tests fail, 9 or 10 on my system (see the list at end). + # + # before this you should create subdirs bin and lib in the + # prefix directory (f:/perl5.005 above): + # + # To run finer tests, cd t && perl harness +make install + +e) At the end of July 1996 GNU make was too buggy for compile. +The maintainer has the patch (for a year now) that make it possible to +compile perl. The binaries are included in + ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2 +patches are available too. + +Note that the pdksh5.2.7 or later is required. + +!!!!!!!!!!!!!!!!! +If you see that some '/' became '\' in pdksh, you use an old pdksh! +Same with segfaults in Make 3.76 (?) - use my patched verions. +!!!!!!!!!!!!!!!!! + +f) As distributed the DB library db.a-db.lib is not suitable for +linking with -Zmt. A recompiled version must be available from my FTP +site in os2/db_mt.zip. + +!!!!!!!!!!!!!!!! +If you see: + 'errno' - unresolved external +it means you use a wrong db.lib. +!!!!!!!!!!!!!!!! + +Problems reported: + +a) one of the latest tr is broken, get an old one :-( + 1.11 works. (On compuserver?) +b) You need a perlglob.exe and link386. +c) Get rid of invalid perl.dll on your LIBPATH. + + +Send comments to ilya@math.ohio-state.edu. + +====================================================== +Requires 0.9b (well, provision are made to make it build under 0.9a6, +but they are not tested, please inform me on success). +(earlier than 0.9b ttyname was not present, it is hard to maintain this +difference automatically, though I try). +====================================================== + +Building with a.out style is supported by the `perl_' target of make. +Dynamic extensions are not possible with perl_.exe, since boot code +should return the retvalue on the Perl stack, the address of which is +not known to the extension. Moreover: The build process for `perl_' +DOES NOT KNOW about dependencies, so you should make sure that +anything is up-to-date, say, by doing + make perl.dll +first. + +The reason why compiling with a.out style executables leads to problems +with dynamic extensions is: + a) OS/2 does not export symbols from executables; + b) Thus if extension needs to import symbols from an application + the symbols for the application should reside in a .dll. + c) You cannot export data from a .dll compiled with a.out style. +On the other hand, aout-style compiled extension enjoys all the +(dis)advantages of fork(). + +====================================================== + +If you need to run PM code from perl, you may use PM mode executable +perl__.exe. It is subject to restrictions specific to PM programs: it +will close the VIO window the moment any PM call is performed. + +It is needed to run Perl/Tk (currently 7/96 - pre-alpha). + +====================================================== + +The reason why the executables are named perl_.exe and perl__.exe is +the following: Perl may parse #! lines in perl scripts to find out the +additional switches to enable. Thus there is a convention `What is a +perl executable - judging by name', and the above names conform to +this convention. + +====================================================== +Tests which fail +~~~~~~~~~~~~~~~~ +with OMF compile (fork works - and all the related +test - with A.OUT compile): + +io/fs.t: 2-5, 7-11, 18 as they should. +io/pipe: all, since open("|-") is not working (works with perl_.exe). +lib/"all the dbm".t: 1 test should fail (file permission). +lib/io_pipe io_sock, as they should: use fork. +op/fork all fail, as they should (except with perl_.exe) +op/stat 3 20 35 as they should, 39 (-t on /dev/null) ???? Sometimes 4 +- timing problem ???? + +Sometimes I have seen segfault in socket ????, only if run with Testing tools. + +A lot of `bad free'... in databases, bug in DB confirmed on other +platforms. You may disable it by setting PERL_BADFREE environment variable +to 0. + +Here is my result with OMF: + +Test Status Wstat Total Fail Success List of failed +------------------------------------------------------------------------------ +io/fs.t 22 10 45.45% 2-5, 7-11, 18 +io/pipe.t 1 256 8 ?? % ?? +lib/anydbm.t 12 1 8.33% 2 +lib/db-btree.t 86 1 1.16% 20 +lib/db-hash.t 43 1 2.33% 16 +lib/db-recno.t 35 1 2.86% 18 +lib/io_pipe.t 2 512 6 ?? % ?? +lib/io_sock.t 255 65280 5 ?? % ?? +lib/sdbm.t 12 1 8.33% 2 +op/exec.t 8 1 12.50% 5 +op/fork.t 255 65280 2 ?? % ?? +op/stat.t 56 4 7.14% 3, 20, 35, 39 +Failed 12/104 test scripts, 88.46% okay. 41/2224 subtests failed, 98.16% okay. + +and with A.OUT: + +Test Status Wstat Total Fail Failed List of failed +------------------------------------------------------------------------------ +io/fs.t 22 10 45.45% 2-5, 7-11, 18 +lib/anydbm.t 12 1 8.33% 2 +lib/db-btree.t 86 1 1.16% 20 +lib/db-hash.t 43 1 2.33% 16 +lib/db-recno.t 35 1 2.86% 18 +lib/sdbm.t 12 1 8.33% 2 +op/exec.t 8 1 12.50% 5 +op/stat.t 56 4 7.14% 3, 20, 35, 39 +Failed 8/104 test scripts, 92.31% okay. 20/2224 subtests failed, 99.10% okay. + +Note that op/exec.5 fail because I do not have /bin/sh on this drive. + +With newer configs I could not reproduce most the crashes. However, +after fixpak17 REXX variables acquire a trailing '\0' at end when go +through the variable pool (even if they had one), thus making some +REXX tests fail. + +======================================================= + +Calls to external programs: +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Due to a popular demand the perl external program calling has been +changed. _If_ perl needs to call an external program _via shell_, the +X:/bin/sh.exe will be called. The name of the shell is +overridable, as described below. + +Thus means that you need to pickup some copy of a sh.exe as well (I use one +from pdksh). The drive X: above is set up automatically during the +build, is settable in runtime from $ENV{PERL_SH_DRIVE}. Another way to +change it is to set $ENV{PERL_SH_DIR} to be the directory in which +sh.exe resides. + +Reasons: a consensus on perl5-porters was that perl should use one +non-overridable shell per platform. The obvious choices for OS/2 are cmd.exe +and sh.exe. Having perl build itself would be impossible with cmd.exe as +a shell, thus I picked up sh.exe. Thus assures almost 100% compatibility +with the scripts coming from *nix. + +Disadvantages: sh.exe calls external programs via fork/exec, and there is +_no_ functioning exec on OS/2. exec is emulated by EMX by asyncroneous call +while the caller waits for child completion (to pretend that pid did +not change). This means that 1 _extra_ copy of sh.exe is made active via +fork/exec, which may lead to some resources taken from the system. + +The long-term solution proposed on p5-p is to have a directive + use OS2::Cmd; +which will override system(), exec(), ``, and open(,' |'). With current +perl you may override only system(), readpipe() - the explicit version +of ``, and maybe exec(). The code will substitute a one-argument system +by CORE::system('cmd.exe', '/c', shift). + +If you have some working code for OS2::Cmd.pm, please send it to me, +I will include it into distribution. I have no need for such a module, so +cannot test it. + +=================================================== + +OS/2 extensions +~~~~~~~~~~~~~~~ +Since binaries cannot go into perl distribution, no extensions are +included. They are available in .../os2/ilyaz directory of CPAN, as +well as in my directory + ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2 + +I include 3 extensions by Andread Kaiser, OS2::REXX, OS2::UPM, and OS2::FTP, +into my ftp directory, mirrored on CPAN. I made +some minor changes needed to compile them by standard tools. I cannot +test UPM and FTP, so I will appreciate your feedback. Other extensions +there are OS2::ExtAttribs, OS2::PrfDB for tied access to EAs and .INI +files - and maybe some other extensions at the time you read it. + +Note that OS2 perl defines 2 pseudo-extension functions +OS2::Copy::copy and DynaLoader::mod2fname. + +The -R switch of older perl is deprecated. If you need to call a REXX code +which needs access to variables, include the call into a REXX compartment +created by + REXX_call {...block...}; + +Two new functions are supported by REXX code, + REXX_eval 'string'; + REXX_eval_with 'string', REXX_function_name => \&perl_sub_reference; + +If you have some other extensions you want to share, send the code to +me. At least two are available: tied access to EA's, and tied access +to system databases. + +================================================================== +== == +== User report [my comments in brackets, IZ] == +== == +== A web page: http://www.shadow.net/~troc/os2perl.html == +== == +================================================================== + +Starting in x:/usr/src, using 4OS2/32 2.5 as the command interpreter on +OS/2 2.30 with FixPak-17. DAX is installed, but this shouldn't be a +factor. Drive X is a TVFS virtual drive pointing to several physical +HPFS drives. + +>>> Make sure that no copies or perl are currently running. Miniperl + may fail during the build because it will find an older version + of perl.dll loaded in memory. + + Close any running perl scripts. + Shut down anything that might run perl scripts, like cron. + `emxload -l` to check for loaded versions of perl. + `emxload -u perl.exe` to unload them. + +>>> Pre-load some common utilities: + + emxload -e sh.exe make.exe ls.exe tr.exe id.exe sed.exe + SET GCCLOAD=30 (number of minutes to hold the compiler) +[grep egrep fgrep cat rm uniq basename uniq sort - are not bad too.] + The theory is that it's faster to demand-load the development tools + from virtual memory than it is to re-load and re-link them all the + time. This is definitely true with my system because swapfile.dat + is on a faster drive than my development environment. + + ls, tr, and id represent the GNU file, text, and shell utilities. + These may not be needed, but it makes sure that their respective + DLLs are in memory. + +>>> Unpack the perl 5_002_01 archive onto an HPFS partition. + + tar vxzf perl5_002_01.tar-gz + cd perl5.002_01 + +[Do not forget to extract Configure as described above.] + +>>> Read the README, keeping a copy open in another session for reference. + + start /c /fg less os2/README + +>>> Apply the OS/2 patches included with 5.002_01, as per the README. + + for %m in (os2\diff.*) patch -p0 < %m + patch -p0 < os2\POSIX.mkfifo + +[The patch below is already applied.] + +>>> You may need to apply this patch if you plan to run a non-standard + Configure (that is, if you defy the README). This patch will ensure + that Makefile inherits the libraries specified during Configure. + People running standard perl builds can probably ignore this patch. + +*** os2\Makefile.SHs Mon Mar 25 02:05:00 1996 +--- os2\Makefile.SHs.new Fri May 24 10:37:10 1996 +*************** +*** 9,15 **** + emximp -o perl.imp perl5.def + + perl.dll: $(obj) perl5.def perl$(OBJ_EXT) +! $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) -lsocket perl5.def + + perl5.def: perl.linkexp + echo "LIBRARY 'Perl' INITINSTANCE TERMINSTANCE" > $@ +--- 9,15 ---- + emximp -o perl.imp perl5.def + + perl.dll: $(obj) perl5.def perl$(OBJ_EXT) +! $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def + + perl5.def: perl.linkexp + echo "LIBRARY 'Perl' INITINSTANCE TERMINSTANCE" > $@ +*************** +*** 49,55 **** + cat perl.exports perl.map | sort | uniq -d | sed -e 's/\w\+/ "\0"/' > perl.linkexp + + perl.map: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT) +! $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o dummy.exe miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) -lsocket -lm -Zmap -Zlinker /map + awk '{if ($$3 == "") print $$2}' <dummy.map | sort | uniq > perl.map + rm dummy.exe dummy.map + +--- 49,55 ---- + cat perl.exports perl.map | sort | uniq -d | sed -e 's/\w\+/ "\0"/' > perl.linkexp + + perl.map: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT) +! $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o dummy.exe miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) $(libs) -Zmap -Zlinker /map + awk '{if ($$3 == "") print $$2}' <dummy.map | sort | uniq > perl.map + rm dummy.exe dummy.map + +>>> Apply the patches from Ilya's perl5.002_01 binary distribution: + + touch os2/dlfcn.h os2/dl_os2.c + patch -p1 < f:\perllib\README.fix1 + +>>> Run Configure. Most people can run it by following the README: + + sh Configure -des -D prefix=f:/usr/local + + Advanced perl users (experienced C programmers, recommended) can run + the interactive Configure and answer the questions. When in doubt + about an answer, check the EMX headers and documentation. Pick the + default answer if that doesn't help: + + sh Configure + +[Yet more advanced users just specify the answers on the command line +of Configure, like I did with prefix.] + + Note: You may need to wrap an answer in quotes if it contains + spaces. For example, "-lsocket -lm". + + Note: If you want to add some options to a long default, you can + use $* to include the default in your answer: "$* -DDEBUGGING". + + Configure warnings and errors, and possible work-arounds: + + I don't know where 'ln' is.... + (ignored; OS/2 doesn't have a ln command) + + nm didn't seem to work right. Trying emxomfar instead... + (nothing to worry about) + + The recommended value for $d_shrplib on this machine was "define"! + (kept the recommended value: y) + + Directory f:/usr/lib/perl5/os2/5.00201/CORE doesn't exist. + (created the directory from another window with + \usr\bin\mkdir -p f:/usr/lib/perl5/os2/5.00201/CORE + and then answered: y. Your directory may look different.) + +[Ignore this as well, install script will create it for you.] + + The recommended value for $i_dlfcn on this machine was "define"! + (kept the recommended value: y) + + The recommended value for $d_fork on this machine was "undef"! + (kept the recommended value: y) + + Figuring out the flag used by open() for non-blocking I/O... + Seems like we can use O_NONBLOCK. + This seems to be used for informative purposes only. + The errors that follow this (including a SIGPIPE) don't seem + to affect perl at all. These were safely ignored. + + What pager is used on your system? [/usr/ucb/more] + Had to answer "/usr/bin/less.exe" because Configure wants a + leading / (unix full path). Need to edit config.sh later with + the real full path to the pager, including the drive letter. + +[Apparently this setting is never used, so it is safe to ignore it.] + + Hmm... F:/USR/BIN/sed: Unterminated `s' command + Perl built fine even with this error, so it seems safe to + ignore. + + Things I did different from the defaults. Most (if not all) of these + are optional changes. They're listed here to show how good Configure + is at detecting the system setup. + +[I add the options to put it on command line of Configure, see below.] + + Selected 'none' for the man1 location. + (I prefer the pod2html version.) +[-D man1dir=none] + Selected 'none' for the man3 location. + (I prefer the pod2html version.) +[-D man3dir=none] + Changed the hostname and domain. + (I wanted to override a dynamic PPP address. This only + matters if other people will be using your perl build.) +[-D myhostname=my_host_name -D mydomain=.foo.org] + Fixed the e-mail address. + (Put in a known working e-mail address. This only matters + if other people will be using your perl build.) +[-D cf_email=root@myhostname.uucp] + Added some directories to the library search path. +[-D "libpth=f:/emx/lib/st f:/emx/lib"] + Added -g to the optimizer/debugger flags. +[-D optimize=-g] + Added "-lgdbm -ldb -lcrypt -lbsd" to the additional libraries. +[ -D "libs=-lsocket -lcrypt -lgdbm" + the rest of libraries will not be used] + +>>> Advanced users may want to edit config.sh when prompted by Configure. + Most (all?) of these changes aren't really necessary: + + d_getprior='define' + d_setprior='define' + (getpriority and setpriority are included in os2.c, but + Configure doesn't know to look there.) +[fixed already] + pager='f:/usr/bin/less.exe' + (Correcting Configure's insistence on a leading slash.) + bin_sh='f:/usr/bin/sh.exe' + (If Configure detects sh.exe somewhere else first. Example: + it saw sh.exe at /bin/sh.exe on my TVFS drive, but I want + perl to look for it on the physical F drive.) + aout_ccflags='... existing flags... -DDEBUGGING' + aout_cppflags='... existing flags... -DDEBUGGING' + (If you want to include DEBUGGING for the aout version.) +[Do not do it, -D optimize=-g will automatically add these flags.] + +>>> Allow Configure to make the build scripts. + +>>> Allow Configure to run `make depend`. Ignore the following warning: + + perl.h:861: warning: `DEBUGGING_MSTATS' redefined +[corrected now] + +>>> Rename any existing perl.dll, preventing anything from loading it and + saving a known working copy in case something goes wrong: + + mv /usr/lib/perl.dll /usr/lib/ilya-perl.dll + +>>> Run `make`, and ignore the following warnings: + + perl.h:861: warning: `DEBUGGING_MSTATS' redefined +[corrected now] + invalid preprocessing directive name + emxomf warning: Cycle detected by make_type + LINK386 : warning L4071: application type not specified; assuming WINDOWCOMPAT + Warning (will try anyway): No library found for -lposix + Warning (will try anyway): No library found for -lcposix + POSIX.c:203: warning: `mkfifo' redefined + POSIX.c:4603: warning: assignment makes pointer from integer without a cast + +>>> If `make` dies while "Making DynaLoader (static)", you'll need to + put miniperl in the OS/2 paths. This step is only necessary if `make` + can't find miniperl: +[I would be interested if somebody confirmes this.] + + cp perl.dll /usr/lib (where /usr/lib is in your LIBPATH) + cp miniperl.exe /usr/bin (where /usr/bin is in your PATH) + make (ignore the errors in the previous step) + + This should run to completion. + +>>> Test the build: + + make test + + These tests fail: + + io/fs..........FAILED on test 2 + + "OS/2 is not unix". Test 2 checks the link() command, which + is not supported by OS/2. + + io/pipe........f:/usr/bin/sh.exe: -c requires an argument + f:/usr/bin/sh.exe: -c requires an argument + The Unsupported function fork function is unimplemented at + io/pipe.t line 26. + FAILED on test 1 + + More "OS/2 is not unix" errors. Read ahead to find out + why fork() fails. + + op/exec........FAILED on test 4 + + if (system "true") {print "not ok 4\n";} else \ + {print "ok 4\n";} + + This fails for me, but changing it to read like this works: + + if (system '\usr\bin\true.cmd') {print "not ok 4\n";} \ + else {print "ok 4\n";} + + So you can count this as another "OS/2 is not unix". + + op/fork........The Unsupported function fork function is \ + unimplemented at op/fork.t line 8. + FAILED on test 1 + + The dynamically-loaded version of perl currently doesn't + support fork(). This is a known behavior of EMX. + + op/magic....... + Process terminated by SIGINT + ok + + The test passed even with the SIGINT message. I don't + know why, but I won't argue. + + op/stat........ls: /dev: No such file or directory + f:/usr/bin/sh.exe: ln: not found + ls: perl: No such file or directory + FAILED on test 3 + + "OS/2 is not unix". We don't have the ln command. + + lib/anydbm.....Bad free() ignored at lib/anydbm.t line 51. + Bad free() ignored at lib/anydbm.t line 51. + Bad free() ignored at lib/anydbm.t line 51. + Bad free() ignored during global destruction. + Bad free() ignored during global destruction. + Bad free() ignored during global destruction. + FAILED on test 2 + + Test 2 looks at the file permissions for a database. "OS/2 + is not unix" so the permissions aren't exactly what this test + expects. + + lib/db-btree...Bad free() ignored at lib/db-btree.t line 109. + Bad free() ignored at lib/db-btree.t line 221. + Bad free() ignored at lib/db-btree.t line 337. + Bad free() ignored at lib/db-btree.t line 349. + Bad free() ignored at lib/db-btree.t line 349. + Bad free() ignored at lib/db-btree.t line 399. + Bad free() ignored at lib/db-btree.t line 400. + Bad free() ignored at lib/db-btree.t line 401. + FAILED on test 20 + + Another file permissions test fails. + + lib/db-hash....Bad free() ignored at lib/db-hash.t line 101. + Bad free() ignored at lib/db-hash.t line 101. + Bad free() ignored at lib/db-hash.t line 101. + Bad free() ignored at lib/db-hash.t line 239. + Bad free() ignored at lib/db-hash.t line 239. + Bad free() ignored at lib/db-hash.t line 239. + Bad free() ignored at lib/db-hash.t line 253. + Bad free() ignored at lib/db-hash.t line 253. + Bad free() ignored at lib/db-hash.t line 253. + FAILED on test 16 + + Another file permissions test fails. + + lib/db-recno...Bad free() ignored at lib/db-recno.t line 138. + Bad free() ignored at lib/db-recno.t line 138. + FAILED on test 18 + + Another file permissions test fails. + + lib/gdbm.......FAILED on test 2 + + Another file permissions test fails. + + lib/sdbm.......FAILED on test 2 + + Another file permissions test fails. + + Failed 11/94 tests, 88.30% okay. + + All of which are known differences with unix or documented + behaviors in EMX. I re-run the test with Ilya's version, + and the same tests fail. This new build is a success. +[Note that bad free() mentioned above are bugs in the Berkeley +DB. They just are more visible under OS/2 with perl free(), because of +"rigid" function name resolution. You may disable it by setting +PERL_BADFREE environment variable to 0. + To get finer tests, cd to ./t and run + perl harness +] + + (Actually, Ilya's perl release fails an extra test because I don't + have sed in f:\emx.add. This shows how important it is to configure + and build perl yourself instead of grabbing pre-built binaries.) +[Hmm, should not happen... There is no mentions of full_sed under ./t +directory...] + +>>> Cross your fingers and install it: + + make install + + Warnings encountered and workarounds presented.: + + WARNING: You've never run 'make test'!!! (Installing anyway.) + (Lies! All lies! At least it still installs.) + + WARNING: Can't find libperl*.dll* to install into \ + f:/usr/lib/perl5/os2/5.00201/CORE. (Installing other things anyway.) + (Safe to ignore. The important one, libperl.lib, gets copied.) + + Couldn't copy f:/usr/bin/perl5.00201.exe to f:/usr/bin/perl.exe: \ + No such file or directory + cp /usr/bin/perl5.00201.exe /usr/bin/perl.exe + + Couldn't copy f:/usr/bin/perl.exe to /usr/bin/perl.exe: No such \ + file or directory + (I think this one is safe to ignore since the two directories + point to the same place.) + +>>> Laugh maniacally because you just built and installed your own copy + of perl, with all the paths set "just so" and with whatever little + psychotic modifications you've always wanted but were afraid to add. + +----------------------------------------------------------------------------- + +Development tools and versions: + + EMX 0.9b with emxfix04 applied. + + `ls --version` reports: 'GNU file utilities 3.12' + `tr --version` reports: 'tr - GNU textutils 1.14' + `id --version` reports: 'id - GNU sh-utils 1.12' + + `sed --version` reports: 'GNU sed version 2.05' + `awk --version` reports: 'Gnu Awk (gawk) 2.15, patchlevel 6' + `grep --version` reports an illegal option and: 'GNU grep version 2.0' + (this includes egrep) + + `sort --version` reports: 'sort - GNU textutils 1.14' + `uniq --version` reports: 'uniq - GNU textutils 1.14' + `find --version` reports: 'GNU find version 4.1' + + KSH_VERSION='@(#)PD KSH v5.2.4 96/01/17' + (Ilya's patched version.) + + `make --version` reports: 'GNU Make version 3.74' + (Ilya's patched version.) + + `emxrev` reports: + EMX : revision = 42 + EMXIO : revision = 40 + EMXLIBC : revision = 40 + EMXLIBCM : revision = 43 + EMXLIBCS : revision = 43 + EMXWRAP : revision = 40 + +----------------------------------------------------------------------------- + +Rocco +<troc@shadow.net> + diff --git a/os2/README.old b/os2/README.old deleted file mode 100644 index f49d6be1fa..0000000000 --- a/os2/README.old +++ /dev/null @@ -1,529 +0,0 @@ -This documentation to the previous version is somewhat applicable yet. -No system() extensions, no -R option, the exec/system with one argument -will use sh.exe only (if required). IZ - - Perl 5.001 for OS/2. - Patchlevel "m" - - Copyright (c) 1989,1990,1991,1992,1993,1994 Larry Wall - All rights reserved. - - OS/2 port Copyright (c) 1990, 1991, 1994-95 - Raymond Chen, Kai Uwe Rommel, Andreas Kaiser - -Version 5 port (this package) by Andreas Kaiser <ak@ananke.s.bawue.de> -(2:246/8506.9@fidonet). - -To run the executables supplied with this file, you have to install the -EMX runtime package emxrt.zip of version 0.9a05 (0.9a, fixlevel 5) or -later. - -The file emxrt.zip is available at ftp.rus.uni-stuttgart.de (the -origin), ftp-os2.nmsu.edu and many other places. - -The source code of the original Perl 5.0 distribution is not included -here. You can get it at ftp://ftp.wpi.edu:/perl5/perl5.001.tar.gz (and -many other places). - -For documentation of Perl 5, look at the files into the directory tree -"pod". For TeX or Postscript docs, get perlref-5.000.0.tar.gz. A LaTeX -and postscript reference card is available at - ftp.NL.net:/pub/comp/programming/languages/perl/perlref-5.000.0.tar.gz - prep.ai.mit.edu:/pub/gnu/perlref-5.000.0.tar.gz - -Many REXX DLLs complement the features available by standard Perl, -supporting system calls (YdbaUtil - RXU??.ZIP), xBase (RexxBase, -shareware), serial I/O (RxAsync) and basic PM dialogs (VRexx). These -packages can be found at many OS/2 FTP servers. - ------------------------------------------------------------------------------ -Installation: -------------- - -If you did not have HPFS up to now, this is the right time to reformat -your filesystem(s)... While Perl itself does not require HPFS, a lot -of Perl library files do. Or try EMXOPT=-t. - -copy perl5.exe perl5x.exe `some PATH dir` -copy os2\perlglob.exe `some PATH dir` -copy perl5.dll `some LIBPATH dir` - -set PERL5LIB=x:/your/own/perl/lib;y:/somewhere/perl5/lib - -The perl5 extension DLLs (POSIX_.DLL, REXX_.DLL, ...) do not need a -LIBPATH entry. - -Executables: ------------- - -perl5.exe,perl5.dll : DynaLoader, REXX support, external DLLs - - No fork. Running a command via open() returns 1 - instead of the child process id. - - Other modules supported via extension DLLs, no - builtins other than DynaLoader. - -perl5x.exe : No Dynaloader, no REXX. - - Supports fork. Running a command via open() uses fork - (slow) and correctly returns the child process id. - - POSIX and Socket modules builtin. No other extension - modules supported. - - Note that lib/Socket.pm and lib/POSIX.pm reflect - DLL use. If you need them with perl5x.exe, you - have to remove the "bootstrap" line. - ------------------------------------------------------------------------------ -Building: ---------- - -Requires: -- Perl5.001.tar.gz (Perl 5.001 sources). -- EMX 0.9a05 or later (Compiler). -- OS/2 Development Toolkit (or change REXX inc/lib references). -- Korn shell (ksh) or some other Unix-like shell named ksh. -- DMake, with group recipes configured for a Unix shell. -- Larry Walls "patch" program. -- Several Unix-like tools, such as cp, cat, touch, find, ... - -get Perl 5.001 source -apply patches\* -- "official unofficial" patches to 5.001 -apply os2\patches -- OS/2 platform patches -copy ext\DynaLoader\dl_os2.xs ext\DynaLoader\DynaLoader.xs -copy os2\config.sh . -copy os2\makefile.mk . - -If you do not have UPM (User Profile Management), remove "UPM" from -makefile.mk. - ------------------------------------------------------------------------------ -Not supported, bugs, "OS/2 is Not Unix": ----------------------------------------- - -Depending on whether you run perl5.exe or perl5x.exe, you can either -use extension modules and REXX, or fork, since the EMX implementation -of fork conflicts with DLL support. Remember that there is a hidden -fork in open(F, "-|") and open(F, "|-"). - -config.sh (Config.pm) lies. It shows d_fork='undef' even though it is -available in perl5x.exe. "dynamic_ext" and "extensions" are incorrect -for perl5x.exe. - -flock is available but does not yet work in EMX 0.9a. - -ttyname and ctermid do not work (return NULL). - -... and of course a lot of Unix-isms like process group, user and group -management, links, ... - -For details, look into config.sh and the EMX library reference. - -I did not test SDBM. I just added a lot of O_BINARY flags and compiled it. - -Several scripts of the test suite (see source distribution) fail due to -Unix-isms like /bin/sh, `echo *`, different quoting requirements, ... - -When opening a command pipe [such as open(F,"cat|")], perl5.exe -returns 1 instead of the child's process id. Perl5x.exe correctly -returns the process id. - -OS/2 does not have a true exec API (which is used both by the exec -function and when opening a command pipe with perl5x.exe). What -actually happens is the call of a subprocess with the father waiting -for the termination of its child. While waiting, the father still owns -all its resources (it passes signals to the child however) and there -may be some other side effects as well. - ------------------------------------------------------------------------------ -OS2::REXX Module (external library): ------------------------------------- - -NOTE: By default, the REXX variable pool is not available, neither to -Perl, nor to external REXX functions. To enable it, you have to start -Perl with the switch -R, which makes Perl call its interpreter through -REXX. REXX functions which do not use variables may be usable even -without -R though. - -Load REXX DLL: - - $dll = load OS2::REXX NAME [, WHERE]; - - NAME is DLL name, without path and extension. - - Directories are searched WHERE first (list of dirs), then - environment paths PERL5REXX, PERLREXX or, as last resort, PATH. - - The DLL is not unloaded when the variable dies. - - Returns DLL object reference, or undef on failure. - -Define function prefix: - - $dll->prefix(NAME); - - Define the prefix of external functions, prepended to the - function names used within your program, when looking for - the entries in the DLL. - - Example: - $dll = load OS2::REXX "RexxBase"; - $dll->prefix("RexxBase_"); - $dll->Init(); - is the same as - $dll = load OS2::REXX "RexxBase"; - $dll->RexxBase_Init(); - -Define queue: - - $dll->queue(NAME); - - Define the name of the REXX queue passed to all external - functions of this module. Defaults to "SESSION". - -Check for functions (optional): - - BOOL = $dll->find(NAME [, NAME [, ...]]); - - Returns true if all functions are available. - -Call external REXX function: - - $dll->function(arguments); - - Returns the return string if the return code is 0, else undef. - Dies with error message if the function is not available. - -Bind scalar variable to REXX variable: - - tie $var, OS2::REXX, "NAME"; - -Bind array variable to REXX stem variable: - - tie @var, OS2::REXX, "NAME."; - - Only scalar operations work so far. No array assignments, - no array operations, ... FORGET IT. - -Bind hash array variable to REXX stem variable: - - tie %var, OS2::REXX, "NAME."; - - To access all visible REXX variables via hash array, bind to ""; - - No array assignments. No array operations, other than hash array - operations. Just like the *dbm based implementations. - - For the usual REXX stem variables, append a "." to the name, - as shown above. If the hash key is part of the stem name, for - example if you bind to "", you cannot use lower case in the stem - part of the key and it is subject to character set restrictions. - -Erase individual REXX variables (bound or not): - - OS2::REXX::drop("NAME" [, "NAME" [, ...]]); - -Note that while function and variable names are case insensitive in the -REXX language, function names exported by a DLL and the REXX variables -(as seen by Perl through the chosen API) are all case sensitive! - -Most REXX DLLs export function names all upper case, but there are a -few which export mixed case names (such as RxExtras). When trying to -find the entry point, both exact case and all upper case are searched. -If the DLL exports "RxNap", you have to specify the exact case, if it -exports "RXOPEN", you can use any case. - -To avoid interfering with subroutine names defined by Perl (DESTROY) -or used within the REXX module (prefix, find), it is best to use mixed -case and to avoid lowercase only or uppercase only names when calling -REXX functions. Be consistent. The same function written in different -ways results in different Perl stubs. - -There is no REXX interpolation on variable names, so the REXX variable -name TEST.ONE is not affected by some other REXX variable ONE. And it -is not the same variable as TEXT.one! - -You cannot call REXX functions which are not exported by the DLL. -While most DLLs export all their functions, some, like RxFTP, export -only "...LoadFuncs", which registers the functions within REXX only. - -You cannot call 16-bit DLLs. The few interesting ones I found -(FTP,NETB,APPC) do not export their functions. - -I do not know whether the REXX API is reentrant with respect to -exceptions (signals) when the REXX top-level exception handler is -overridden. So unless you know better than I do, do not access REXX -variables (probably tied to Perl variables) or call REXX functions -which access REXX queues or REXX variables in signal handlers. - -See ext/OS2/REXX/rx*.pl for examples. - ------------------------------------------------------------------------------ -OS2::UPM (external library): ----------------------------- - -UPM constants (see <upm.h>) are exported automatically, functions only -on request. - -(USERID, TYPE) = local_user () - - return local user - -LIST = user_list (REMOTENODE="", REMOTETYPE_UPM_LOCAL) - LIST = 4 items per logged on user - [0] = user id - [1] = remote node name - [2] = remote node type (INT) - [3] = session id (INT) - -(USERID, TYPE) = local_logon () - - do a local logon, PM window, if not already logged on - -BOOL = logon (USERID, PASSWORD, AUTHCHECK=UPM_USER, REMOTENODE="", REMOTETYPE=UPM_LOCAL) -BOOL = logoff (USERID, REMOTENODE="", REMOTETYPE=UPM_LOCAL) - - logon/logoff process (DB2/2) - -BOOL = logon_user (USERID, PASSWORD, REMOTENODE="", REMOTETYPE=UPM_LOCAL) -BOOL = logoff_user (USERID, REMOTENODE="", REMOTETYPE=UPM_LOCAL) - - logon/logoff user - -ERRCODE = error () - - return UPM error code of last failure - -STRING = message (ERRCODE) - - return message text for supplied UPM error code - -Defaults: - REMOTETYPE = UPM_LOCAL - REMOTENODE = "" - AUTHCHECK = UPM_USER - ------------------------------------------------------------------------------ -OS2::FTP (external library): ----------------------------- - -$acct = new FTP "host", "userid", "passwd" [, "acct"] - - Create virtual FTP session - no login. - -FTP::logoff() - - Logoff all sessions. - -($msec, $address) = FTP::ping("host", pktlen); -$msec = FTP::ping($address, pktlen); - - Ping host. Returns milliseconds or negative error code. - $address is 32-bit number. - -$errno = $acct->errno(); - - Return last error code (FTP*). - -$text = FTP::message($errno); - - Return message test of last error. - -$status: <0 on error, >=0 on success. -$tfrtype: T_BINARY, T_ASCII, T_EBCDIC -"mode": "w" for overwrite, "a" for append - -$status = $acct->dir("local", "pattern"="*"); -$status = $acct->ls("local", "pattern"="*"); - -$status = $acct->chdir("dir"); -$status = $acct->mkdir("dir"); -$status = $acct->rmdir("dir"); -($status, $cwd) = $acct->getcwd(); - -$status = $acct->get("local", "remote"=local, "mode"="w", $tfrtype=T_BINARY); - -$status = $acct->put("local", "remote"=local, $tfrtype=T_BINARY); -$status = $acct->putunique("local", "remote"=local, $tfrtype=T_BINARY); -$status = $acct->append("local", "remote"=local, $tfrtype=T_BINARY); - -$status = $acct->rename("from", "to"); -$status = $acct->delete("name"); - -$status = $acct->proxy($source_acct, "dst_file", "src_file", $tfrtype=T_BINARY); - -$status = $acct->quote("string"); -$status = $acct->site("string"); -($status, $infostring) = $acct->sys(); - ------------------------------------------------------------------------------ -Other: ------- - - setpriority CLASS,PID,DELTA - - Set priority of process or process tree. - - PID: - >= 0: process only - < 0: process tree - - CLASS: - 0 no change - 1 idle-time (lowest) - 2 regular (dynamic priority) - 3 time-critical (highest) - 4 fixed-high (between regular and time-critical) - - DELTA: - -31..+31 - - getpriority IGNORED,PID - - Return priority of process or process tree. - - Bits 8..15 priority class (1..4) - Bits 0..7 priority within class (0..31) - - system LIST - - If the first element of LIST is an integer, it controls the - started child process or session as follows: - - 0 = wait until child terminates (default) - 1 = do not wait, use wait() or waitpid() for status - 4 = new session - 5 = detached - 6 = PM program - - PM and session options, or-ed in: - - 0x00000 = default - 0x00100 = minimized - 0x00200 = maximized - 0x00300 = fullscreen (session only) - 0x00400 = windowed (session only) - - 0x00000 = foreground (only if running in foreground) - 0x01000 = background - - 0x02000 = don't close window on exit (session only) - - 0x10000 = quote all arguments - 0x20000 = MKS argument passing convention - - If the control is not zero, system() does not wait until - the child terminates and the return code is the id of the - child process. - - If the control is not zero, and you do not call wait or - waitpid, the child status fills up memory. - - Note: If the program is started with a mode of 4 or 6, it may - be aborted when the starting program (perl) terminates. Later - releases of EMX.DLL will probably know yet another flag bit - to cut this fatal relationship. - - system STRING - exec STRING - - If the string starts with "@" or contains any of "%&|<>", - it is called as a shell command. Else the program is called - directly. - - If the environment variable SHELL is defined, it is used - instead of COMSPEC when running shell commands. It should - be a Unix-style shell. - - file checks (-X), stat(), ... - - When testing filenames, not handles, char-devices are detected - only when prefixed by "/dev/", so "/dev/con" is valid, "con" is - not. - - Currently, only /dev/con and /dev/tty are recognized. - ------------------------------------------------------------------------------ -History: - -15.12.94 Initial release (perl5000.zip). - -17.12.94 Moved REXX sub defn to find(). Hash array for functions no - longer required, allows overriding subs like "find". - - DLL entries are case sensitive, try both upper case and - exact case. - -18.12.94 Detect char- and block-devices (stat() hack). Some future - release may probably remove block device support, once - char-device support is built into EMX. - - Fixed perl5db tty check. - -22.12.94 EMX fixlevel 2 exports its exception handler, so now - signals work even when the REXX variable pool is enabled. - - Disabled error and exception popups. - -27.12.94 Case conversions of tied variables cleaned up. - - REXX (REXX.DLL, REXXAPI.DLL) now loaded on demand. - -7.1.95 Fixed Shell module (did not allow more than one argument). - -11.1.95 Accept drive letter as absolute path in do/require/use. - -13.1.95 Larrys memory-leak patches (#1, dated Friday 13). - -26.1.95 fcntl and ioctl were missing. fcntl was explicitly disabled - in its source code (ifndef DOSISH) and the ioctl enabler is - in the wrong place (unixish.h instead of config.sh). - -16.3.95 DosQueryFSAttach (stat hack) may crash the system. Now just - look for /dev/con and /dev/tty. - - Applied "pad_findlex" patch (patches/1). - -23.3.95 Support fork. Two executables, one for DLLs and one for fork. - -24.3.95 5.001 - -13.4.95 Patchlevel "c". - -21.4.95 Truncate names of extension DLLs to 8 chars - Warp no longer - accepts them (2.x did). - -22.4.95 Replaced EMX dirent by my own to get all directory entries - even when HPFS386 is used. Additionally, my implementation - is not restricted in the total size of the directory (a - conflict between Perls memory allocator and the one of the - EMX library DLL). - -27.4.95 Support for fork() disabled system() in DLL version. - -7.5.95 Added Tye McQueen's FileGlob. See File::KGlob*. - -12.5.95 Fixed Cwd. Fixed OS/2 dependencies in MakeMaker, with - a few Config.sh items added (separators, exe-extension). - - Moved UPM and REXX to OS2::. Combined REXXCALL and REXX. - Plain old REXX module is still available as passthru though. - - Perl DLLs now have an underscore appended to avoid name - conflicts with standard OS/2 DLLs (see DynaLoader.pm). - -13.5.95 Added FTP API support (OS2::FTP). - -2.7.95 Applied "official unofficial" patches up to level "m". - The modpods documentation now is in the modules themselves. - -4.7.95 Implement command pipes (my_popen) using fork instead of - standard popen in the fork version (perl5x.exe). While this - is a lot slower, it correctly returns the process id and - supports open(F,"-|") and open(F,"|-"). - - Use the same code for exec(CMD) as for system(CMD). - - Support socket functions (set|get|end)(host|net|proto|serv)ent. diff --git a/os2/diff.configure b/os2/diff.configure index 53aa16b4a2..f687898f0c 100644 --- a/os2/diff.configure +++ b/os2/diff.configure @@ -288,19 +288,21 @@ cryptlib=-lcrypt fi *************** -*** 5198,5204 **** - } +*** 5198,5205 **** EOM + : Call the object file tmp-dyna.o in case dlext=o. if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && -! $ld $lddlflags -o dyna.$dlext dyna.o > /dev/null 2>&1 && +! mv dyna.o tmp-dyna.o > /dev/null 2>&1 && +! $ld $lddlflags -o dyna.$dlext tmp-dyna.o > /dev/null 2>&1 && $cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then xxx=`./fred` case $xxx in ---- 5213,5219 ---- - } +--- 5213,5220 ---- EOM + : Call the object file tmp-dyna.o in case dlext=o. if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && -! $ld $lddlflags -o dyna.$dlext dyna$obj_ext > /dev/null 2>&1 && +! mv dyna$obj_ext tmp-dyna$obj_ext > /dev/null 2>&1 && +! $ld $lddlflags -o dyna.$dlext tmp-dyna$obj_ext > /dev/null 2>&1 && $cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then xxx=`./fred` case $xxx in diff --git a/os2/dlfcn.h b/os2/dlfcn.h index df2ea33d32..c96f97f82d 100644 --- a/os2/dlfcn.h +++ b/os2/dlfcn.h @@ -1,6 +1,3 @@ void *dlopen(char *path, int mode); void *dlsym(void *handle, char *symbol); char *dlerror(void); -void *dlopen(char *path, int mode); -void *dlsym(void *handle, char *symbol); -char *dlerror(void); @@ -1,10 +1,8 @@ #define INCL_DOS #define INCL_NOPM #define INCL_DOSFILEMGR -#ifndef NO_SYS_ALLOC -# define INCL_DOSMEMMGR -# define INCL_DOSERRORS -#endif /* ! defined NO_SYS_ALLOC */ +#define INCL_DOSMEMMGR +#define INCL_DOSERRORS #include <os2.h> /* @@ -137,10 +135,15 @@ result(int flag, int pid) int r, status; Signal_t (*ihand)(); /* place to save signal during system() */ Signal_t (*qhand)(); /* place to save signal during system() */ +#ifndef __EMX__ + RESULTCODES res; + int rpid; +#endif - if (pid < 0 || flag != 0) + if (pid < 0 || flag != 0) return pid; +#ifdef __EMX__ ihand = signal(SIGINT, SIG_IGN); qhand = signal(SIGQUIT, SIG_IGN); do { @@ -153,6 +156,15 @@ result(int flag, int pid) if (r < 0) return -1; return status & 0xFFFF; +#else + ihand = signal(SIGINT, SIG_IGN); + r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid); + signal(SIGINT, ihand); + statusvalue = res.codeResult << 8 | res.codeTerminate; + if (r) + return -1; + return statusvalue; +#endif } int @@ -170,7 +182,7 @@ register SV **sp; New(401,Argv, sp - mark + 1, char*); a = Argv; - if (mark < sp && SvIOKp(*(mark+1))) { + if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { ++mark; flag = SvIVx(*mark); } @@ -187,8 +199,12 @@ register SV **sp; if (flag == P_WAIT) flag = P_NOWAIT; - if (*Argv[0] != '/' && *Argv[0] != '\\') /* will swawnvp use PATH? */ + if (*Argv[0] != '/' && *Argv[0] != '\\' + && !(*Argv[0] && *Argv[1] == ':' + && (*Argv[2] == '/' || *Argv[2] != '\\')) + ) /* will swawnvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ + /* We should check PERL_SH* and PERLLIB_* as well? */ if (really && *(tmps = SvPV(really, na))) rc = result(trueflag, spawnvp(flag,tmps,Argv)); else @@ -203,9 +219,14 @@ register SV **sp; return rc; } +#define EXECF_SPAWN 0 +#define EXECF_EXEC 1 +#define EXECF_TRUEEXEC 2 + int -do_spawn(cmd) +do_spawn2(cmd, execf) char *cmd; +int execf; { register char **a; register char *s; @@ -254,10 +275,17 @@ char *cmd; break; } doshell: + if (execf == EXECF_TRUEEXEC) + return execl(shell,shell,copt,cmd,(char*)0); + else if (execf == EXECF_EXEC) + return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0); + /* In the ak code internal P_NOWAIT is P_WAIT ??? */ rc = result(P_WAIT, - spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); + spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); if (rc < 0 && dowarn) - warn("Can't spawn \"%s\": %s", shell, Strerror(errno)); + warn("Can't %s \"%s\": %s", + (execf == EXECF_SPAWN ? "spawn" : "exec"), + shell, Strerror(errno)); if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ return rc; } @@ -276,9 +304,16 @@ char *cmd; } *a = Nullch; if (Argv[0]) { - rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); + if (execf == EXECF_TRUEEXEC) + rc = execvp(Argv[0],Argv); + else if (execf == EXECF_EXEC) + rc = spawnvp(P_OVERLAY,Argv[0],Argv); + else + rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); if (rc < 0 && dowarn) - warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); + warn("Can't %s \"%s\": %s", + (execf == EXECF_SPAWN ? "spawn" : "exec"), + Argv[0], Strerror(errno)); if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ } else rc = -1; @@ -286,12 +321,36 @@ char *cmd; return rc; } +int +do_spawn(cmd) +char *cmd; +{ + return do_spawn2(cmd, EXECF_SPAWN); +} + +bool +do_exec(cmd) +char *cmd; +{ + return do_spawn2(cmd, EXECF_EXEC); +} + +bool +os2exec(cmd) +char *cmd; +{ + return do_spawn2(cmd, EXECF_TRUEEXEC); +} + #ifndef HAS_FORK FILE * my_popen(cmd,mode) char *cmd; char *mode; { +#ifdef TRYSHELL + return popen(cmd, mode); +#else char *shell = getenv("EMXSHELL"); FILE *res; @@ -299,6 +358,7 @@ char *mode; res = popen(cmd, mode); my_setenv("EMXSHELL", shell); return res; +#endif } #endif @@ -323,18 +383,54 @@ void * ctermid(x) { return 0; } void * ttyname(x) { return 0; } #endif -void * gethostent() { return 0; } -void * getnetent() { return 0; } -void * getprotoent() { return 0; } -void * getservent() { return 0; } -void sethostent(x) {} -void setnetent(x) {} -void setprotoent(x) {} -void setservent(x) {} -void endhostent(x) {} -void endnetent(x) {} -void endprotoent(x) {} -void endservent(x) {} +/*****************************************************************************/ +/* my socket forwarders - EMX lib only provides static forwarders */ + +static HMODULE htcp = 0; + +static void * +tcp0(char *name) +{ + static BYTE buf[20]; + PFN fcn; + if (!htcp) + DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); + if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) + return (void *) ((void * (*)(void)) fcn) (); + return 0; +} + +static void +tcp1(char *name, int arg) +{ + static BYTE buf[20]; + PFN fcn; + if (!htcp) + DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp); + if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0) + ((void (*)(int)) fcn) (arg); +} + +void * gethostent() { return tcp0("GETHOSTENT"); } +void * getnetent() { return tcp0("GETNETENT"); } +void * getprotoent() { return tcp0("GETPROTOENT"); } +void * getservent() { return tcp0("GETSERVENT"); } +void sethostent(x) { tcp1("SETHOSTENT", x); } +void setnetent(x) { tcp1("SETNETENT", x); } +void setprotoent(x) { tcp1("SETPROTOENT", x); } +void setservent(x) { tcp1("SETSERVENT", x); } +void endhostent() { tcp0("ENDHOSTENT"); } +void endnetent() { tcp0("ENDNETENT"); } +void endprotoent() { tcp0("ENDPROTOENT"); } +void endservent() { tcp0("ENDSERVENT"); } + +/*****************************************************************************/ +/* not implemented in C Set++ */ + +#ifndef __EMX__ +int setuid(x) { errno = EINVAL; return -1; } +int setgid(x) { errno = EINVAL; return -1; } +#endif /*****************************************************************************/ /* stat() hack for char/block device */ @@ -362,55 +458,22 @@ os2_stat(char *name, struct stat *st) #endif -#ifndef NO_SYS_ALLOC - -static char *oldchunk; -static long oldsize; +#ifdef USE_PERL_SBRK -#define _32_K (1<<15) -#define _64_K (1<<16) - -/* The real problem is that DosAllocMem will grant memory on 64K-chunks - * boundaries only. Note that addressable space for application memory - * is around 240M, thus we will run out of addressable space if we - * allocate around 14M worth of 4K segments. - * Thus we allocate memory in 64K chunks, and abandon the rest of the old - * chunk if the new is bigger than that rest. Also, we just allocate - * whatever is requested if the size is bigger that 32K. With this strategy - * we cannot lose more than 1/2 of addressable space. */ +/* SBRK() emulation, mostly moved to malloc.c. */ void * -sbrk(int size) -{ - char *got; - APIRET rc; - int small, reqsize; - - if (!size) return 0; - else if (size <= oldsize) { - got = oldchunk; - oldchunk += size; - oldsize -= size; - return (void *)got; - } else if (size >= _32_K) { - small = 0; - } else { - reqsize = size; - size = _64_K; - small = 1; - } - rc = DosAllocMem((void **)&got, size, PAG_COMMIT | PAG_WRITE); +sys_alloc(int size) { + void *got; + APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE); + if (rc == ERROR_NOT_ENOUGH_MEMORY) { return (void *) -1; } else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc); - if (small) { - /* Chunk is small, register the rest for future allocs. */ - oldchunk = got + reqsize; - oldsize = size - reqsize; - } - return (void *)got; + return got; } -#endif /* ! defined NO_SYS_ALLOC */ + +#endif /* USE_PERL_SBRK */ /* tmp path */ @@ -463,8 +526,8 @@ mod2fname(sv) SV *sv; { static char fname[9]; - int pos = 7; - int len; + int pos = 6, len, avlen; + unsigned int sum = 0; AV *av; SV *svp; char *s; @@ -473,13 +536,30 @@ mod2fname(sv) sv = SvRV(sv); if (SvTYPE(sv) != SVt_PVAV) croak("Not array reference given to mod2fname"); - if (av_len((AV*)sv) < 0) + + avlen = av_len((AV*)sv); + if (avlen < 0) croak("Empty array reference given to mod2fname"); - s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na); + + s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); strncpy(fname, s, 8); - if ((len=strlen(s)) < 7) pos = len; - fname[pos] = '_'; - fname[pos + 1] = '\0'; + len = strlen(s); + if (len < 6) pos = len; + while (*s) { + sum = 33 * sum + *(s++); /* Checksumming first chars to + * get the capitalization into c.s. */ + } + avlen --; + while (avlen >= 0) { + s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); + while (*s) { + sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */ + } + avlen --; + } + fname[pos] = 'A' + (sum % 26); + fname[pos + 1] = 'A' + (sum / 26 % 26); + fname[pos + 2] = '\0'; return (char *)fname; } @@ -525,9 +605,9 @@ Xs_OS2_init() newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); -#ifdef PERL_IS_AOUT gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); GvMULTI_on(gv); +#ifdef PERL_IS_AOUT sv_setiv(GvSV(gv), 1); #endif } @@ -542,10 +622,62 @@ Perl_OS2_init() OS2_Perl_data.xs_init = &Xs_OS2_init; if ( (shell = getenv("PERL_SH_DRIVE")) ) { sh_path[0] = shell[0]; + } else if ( (shell = getenv("PERL_SH_DIR")) ) { + int l = strlen(shell); + if (shell[l-1] == '/' || shell[l-1] == '\\') { + l--; + } + if (l > STATIC_FILE_LENGTH - 7) { + die("PERL_SH_DIR too long"); + } + strncpy(sh_path, shell, l); + strcpy(sh_path + l, "/sh.exe"); } } -char sh_path[33] = BIN_SH; +char sh_path[STATIC_FILE_LENGTH+1] = BIN_SH; + +char * +perllib_mangle(char *s, unsigned int l) +{ + static char *newp, *oldp; + static int newl, oldl, notfound; + static char ret[STATIC_FILE_LENGTH+1]; + + if (!newp && !notfound) { + newp = getenv("PERLLIB_PREFIX"); + if (newp) { + oldp = newp; + while (*newp && !isSPACE(*newp)) { + newp++; oldl++; /* Skip digits. */ + } + while (*newp && (isSPACE(*newp) || *newp == ';')) { + newp++; /* Skip whitespace. */ + } + newl = strlen(newp); + if (newl == 0 || oldl == 0) { + die("Malformed PERLLIB_PREFIX"); + } + } else { + notfound = 1; + } + } + if (!newp) { + return s; + } + if (l == 0) { + l = strlen(s); + } + if (l <= oldl || strnicmp(oldp, s, oldl) != 0) { + return s; + } + if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) { + die("Malformed PERLLIB_PREFIX"); + } + strncpy(ret, newp, newl); + strncpy(ret + newl, s + oldl, l - oldl); + return ret; +} extern void dlopen(); void *fakedl = &dlopen; /* Pull in dynaloading part. */ diff --git a/os2/os2ish.h b/os2/os2ish.h index 917f515112..12c6ad337e 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -45,7 +45,7 @@ #endif #define ABORT() kill(getpid(),SIGABRT); -#define BIT_BUCKET "/dev/null" /* Will this work? */ +#define BIT_BUCKET "/dev/nul" /* Will this work? */ void Perl_OS2_init(); @@ -62,8 +62,18 @@ void Perl_OS2_init(); #define dXSUB_SYS int fake = OS2_XS_init() #ifdef PERL_IS_AOUT -#define NO_SYS_ALLOC -#endif +# define HAS_FORK +/* # define HIDEMYMALLOC */ +/* # define PERL_SBRK_VIA_MALLOC */ /* gets off-page sbrk... */ +#else /* !PERL_IS_AOUT */ +# ifndef PERL_FOR_X2P +# define USE_PERL_SBRK +# endif +# define SYSTEM_ALLOC(a) sys_alloc(a) + +void *sys_alloc(int size); + +#endif /* !PERL_IS_AOUT */ #define TMPPATH tmppath #define TMPPATH1 "plXXXXXX" @@ -160,8 +170,11 @@ extern OS2_Perl_data_t OS2_Perl_data; set_Perl_HAB_f; \ } -extern char sh_path[33]; +#define STATIC_FILE_LENGTH 127 +extern char sh_path[STATIC_FILE_LENGTH+1]; #define SH_PATH sh_path +#define PERLLIB_MANGLE(s, n) perllib_mangle((s), (n)) +char *perllib_mangle(char *, unsigned int); char *os2error(int rc); diff --git a/os2/perl2cmd.pl b/os2/perl2cmd.pl index aa1c353f13..c17ab761aa 100644 --- a/os2/perl2cmd.pl +++ b/os2/perl2cmd.pl @@ -16,7 +16,8 @@ EOU $idir = $Config{installbin}; $indir =~ s|\\|/|g ; -foreach $file (<$idir/*.>) { +foreach $file (<$idir/*>) { + next if $file =~ /\.exe/i; $base = $file; $base =~ s/\.$//; # just in case... $base =~ s|.*/||; diff --git a/patchlevel.h b/patchlevel.h index 8aac9310d3..1e48707cf5 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 3 -#define SUBVERSION 1 +#define SUBVERSION 2 /* local_patches -- list of locally applied less-than-subversion patches. @@ -35,6 +35,10 @@ dEXT char rcsid[] = "perl.c\nPatch level: ###\n"; #endif #endif +#ifndef OSNAME +#define OSNAME "unknown" +#endif + static void find_beginning _((void)); static void incpush _((char *)); static void init_ids _((void)); @@ -132,6 +136,8 @@ register PerlInterpreter *sv_interp; localpatches = local_patches; /* For possible -v */ #endif + PerlIO_init(); /* Hook to IO system */ + fdpid = newAV(); /* for remembering popen pids by fd */ pidstatus = newHV();/* for remembering status of dead pids */ @@ -337,7 +343,7 @@ setuid perl scripts securely.\n"); calllist(endav); return(statusvalue); /* my_exit() was called */ case 3: - fprintf(stderr, "panic: top_env\n"); + PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); return 1; } @@ -388,15 +394,15 @@ setuid perl scripts securely.\n"); (void)mktemp(e_tmpname); if (!*e_tmpname) croak("Can't mktemp()"); - e_fp = fopen(e_tmpname,"w"); + e_fp = PerlIO_open(e_tmpname,"w"); if (!e_fp) croak("Cannot open temporary file"); } if (argv[1]) { - fputs(argv[1],e_fp); + PerlIO_puts(e_fp,argv[1]); argc--,argv++; } - (void)putc('\n', e_fp); + (void)PerlIO_putc(e_fp,'\n'); break; case 'I': taint_not("-I"); @@ -500,7 +506,7 @@ setuid perl scripts securely.\n"); if (!scriptname) scriptname = argv[0]; if (e_fp) { - if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) + if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) croak("Can't write to temp file for -e: %s", Strerror(errno)); e_fp = Nullfp; argc++,argv--; @@ -508,7 +514,7 @@ setuid perl scripts securely.\n"); } else if (scriptname == Nullch) { #ifdef MSDOS - if ( isatty(fileno(stdin)) ) + if ( isatty(PerlIO_fileno(PerlIO_stdin())) ) moreswitches("v"); #endif scriptname = "-"; @@ -619,7 +625,7 @@ PerlInterpreter *sv_interp; return(statusvalue); /* my_exit() was called */ case 3: if (!restartop) { - fprintf(stderr, "panic: restartop\n"); + PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); FREETMPS; return 1; } @@ -630,15 +636,15 @@ PerlInterpreter *sv_interp; break; } - DEBUG_r(fprintf(stderr, "%s $` $& $' support.\n", + DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n", sawampersand ? "Enabling" : "Omitting")); if (!restartop) { DEBUG_x(dump_all()); - DEBUG(fprintf(Perl_debug_log,"\nEXECUTING...\n\n")); + DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); if (minus_c) { - fprintf(stderr,"%s syntax OK\n", origfilename); + PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename); my_exit(0); } if (perldb && DBsingle) @@ -1037,6 +1043,9 @@ I32 namlen; # define PERLLIB_SEP ':' # endif #endif +#ifndef PERLLIB_MANGLE +# define PERLLIB_MANGLE(s,n) (s) +#endif static void incpush(p) @@ -1056,10 +1065,11 @@ char *p; p++; } if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { - av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p))); + av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)), + (STRLEN)(s - p))); p = s + 1; } else { - av_push(GvAVn(incgv), newSVpv(p, 0)); + av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0)); break; } } @@ -1277,22 +1287,21 @@ char *s; printf("\nThis is perl, version %s",patchlevel); #endif - fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout); - fputs("\n\t+ suidperl security patch", stdout); + printf("\n\nCopyright 1987-1996, Larry Wall\n"); + printf("\n\t+ suidperl security patch"); #ifdef MSDOS - fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", - stdout); + printf("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef OS2 - fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n", stdout); + printf("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-1996, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef atarist - fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); + printf("atariST series port, ++jrb bammi@cadence.com\n"); #endif - fputs("\n\ + printf("\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ -GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout); +GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); #ifdef MSDOS usage(origargv[0]); #endif @@ -1337,7 +1346,7 @@ my_unexec() status = unexec(buf, tokenbuf, &etext, sbrk(0), 0); if (status) - fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf); + PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf); exit(status); #else # ifdef VMS @@ -1456,7 +1465,7 @@ SV *sv; extidx = 0; do { #endif - DEBUG_p(fprintf(Perl_debug_log,"Looking for %s\n",tokenbuf)); + DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf)); retval = Stat(tokenbuf,&statbuf); #ifdef SEARCH_EXTS } while ( retval < 0 /* not there */ @@ -1496,9 +1505,9 @@ SV *sv; if (strEQ(origfilename,"-")) scriptname = ""; if (fdscript >= 0) { - rsfp = fdopen(fdscript,"r"); + rsfp = PerlIO_fdopen(fdscript,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ + fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } else if (preprocess) { @@ -1571,15 +1580,15 @@ sed %s -e \"/^[^#]/b\" \ } else if (!*scriptname) { taint_not("program input from stdin"); - rsfp = stdin; + rsfp = PerlIO_stdin(); } else { - rsfp = fopen(scriptname,"r"); + rsfp = PerlIO_open(scriptname,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ + fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } - if ((FILE*)rsfp == Nullfp) { + if ((PerlIO*)rsfp == Nullfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && @@ -1625,7 +1634,7 @@ char *scriptname; #ifdef DOSUID char *s, *s2; - if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ + if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */ croak("Can't stat script \"%s\"",origfilename); if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; @@ -1665,9 +1674,9 @@ char *scriptname; croak("Permission denied"); /* testing full pathname here */ if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { - (void)fclose(rsfp); + (void)PerlIO_close(rsfp); if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ - fprintf(rsfp, + PerlIO_printf(rsfp, "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\ (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n", uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino, @@ -1700,13 +1709,13 @@ char *scriptname; croak("Setuid/gid script is writable by world"); doswitches = FALSE; /* -s is insecure in suid */ curcop->cop_line++; - if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch || - strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */ + if (sv_gets(linestr, rsfp, 0) == Nullch || + strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */ croak("No #! line"); - s = tokenbuf+2; + s = SvPV(linestr,na)+2; if (*s == ' ') s++; while (!isSPACE(*s)) s++; - for (s2 = s; (s2 > tokenbuf+2 && + for (s2 = s; (s2 > SvPV(linestr,na)+2 && (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ; if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */ croak("Not a perl script"); @@ -1730,7 +1739,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #endif /* IAMSUID */ if (euid) { /* oops, we're not the setuid root perl */ - (void)fclose(rsfp); + (void)PerlIO_close(rsfp); #ifndef IAMSUID (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ @@ -1805,16 +1814,16 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); /* We absolutely must clear out any saved ids here, so we */ /* exec the real perl, substituting fd script for scriptname. */ /* (We pass script name as "subdir" of fd, which perl will grok.) */ - rewind(rsfp); - lseek(fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */ + PerlIO_rewind(rsfp); + lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */ for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ; if (!origargv[which]) croak("Permission denied"); - (void)sprintf(buf, "/dev/fd/%d/%.127s", fileno(rsfp), origargv[which]); + (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]); origargv[which] = buf; #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ + fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel); @@ -1824,7 +1833,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #else /* !DOSUID */ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW - Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ + Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) @@ -1850,7 +1859,7 @@ find_beginning() if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) croak("No Perl script found in input\n"); if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { - ungetc('\n',rsfp); /* to keep line count right */ + PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ doextract = FALSE; while (*s && !(isSPACE (*s) || *s == '#')) s++; s2 = s; @@ -1965,7 +1974,7 @@ nuke_stacks() Safefree(tmps_stack); } -static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ +static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ static void init_lexer() { @@ -1986,14 +1995,14 @@ init_predump_symbols() stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(stdingv); - IoIFP(GvIOp(stdingv)) = stdin; + IoIFP(GvIOp(stdingv)) = PerlIO_stdin(); tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv)); tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); GvMULTI_on(tmpgv); - IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout; + IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout(); setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); GvMULTI_on(tmpgv); @@ -2001,7 +2010,7 @@ init_predump_symbols() othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); GvMULTI_on(othergv); - IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr; + IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr(); tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); @@ -2200,7 +2209,7 @@ AV* list; return; case 3: if (!restartop) { - fprintf(stderr, "panic: restartop\n"); + PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); FREETMPS; break; } @@ -10,6 +10,18 @@ #define H_PERL 1 #define OVERLOAD +#ifdef PERL_FOR_X2P +/* + * This file is being used for x2p stuff. + * Above symbol is defined via -D in 'x2p/Makefile.SH' + * Decouple x2p stuff from some of perls more extreme eccentricities. + */ +#undef MULTIPLICITY +#undef EMBED +#undef USE_STDIO +#define USE_STDIO +#endif /* PERL_FOR_X2P */ + /* * STMT_START { statements; } STMT_END; * can be used as a single statement, as in @@ -101,7 +113,27 @@ # endif #endif -#include <stdio.h> +#ifndef _TYPES_ /* If types.h defines this it's easy. */ +# ifndef major /* Does everyone's types.h define this? */ +# include <sys/types.h> +# endif +#endif + +#ifdef __cplusplus +# ifndef I_STDARG +# define I_STDARG 1 +# endif +#endif + +#ifdef I_STDARG +# include <stdarg.h> +#else +# ifdef I_VARARGS +# include <varargs.h> +# endif +#endif + +#include "perlio.h" #ifdef USE_NEXT_CTYPE @@ -143,11 +175,11 @@ proto.h instead. I guess. The patch had no explanation. */ #ifdef MYMALLOC -# ifndef DONT_HIDEMYMALLOC -# define malloc Mymalloc -# define realloc Myremalloc -# define free Myfree -# define calloc Mycalloc +# ifdef HIDEMYMALLOC +# define malloc Perl_malloc +# define realloc Perl_realloc +# define free Perl_free +# define calloc Perl_calloc # endif # define safemalloc malloc # define saferealloc realloc @@ -240,12 +272,6 @@ # endif #endif -#ifndef _TYPES_ /* If types.h defines this it's easy. */ -# ifndef major /* Does everyone's types.h define this? */ -# include <sys/types.h> -# endif -#endif - #ifdef I_NETINET_IN # include <netinet/in.h> #endif @@ -527,6 +553,61 @@ typedef unsigned long UV; #endif +/* Previously these definitions used hardcoded figures. + * It is hoped these formula are more portable, although + * no data one way or another is presently known to me. + * The "PERL_" names are used because these calculated constants + * do not meet the ANSI requirements for LONG_MAX, etc., which + * need to be constants acceptable to #if - kja + * define PERL_LONG_MAX 2147483647L + * define PERL_LONG_MIN (-LONG_MAX - 1) + * define PERL ULONG_MAX 4294967295L + */ + +#ifdef I_LIMITS /* Needed for cast_xxx() functions below. */ +# include <limits.h> +#else +#ifdef I_VALUES +# include <values.h> +#endif +#endif + +#ifdef LONG_MAX +#define PERL_LONG_MAX LONG_MAX +#else +# ifdef MAXLONG /* Often used in <values.h> */ +# define PERL_LONG_MAX MAXLONG +# else +# define PERL_LONG_MAX ((long) ((~(unsigned long)0) >> 1)) +# endif +#endif + +#ifdef LONG_MIN +#define PERL_LONG_MIN LONG_MIN +#else +# ifdef MINLONG +# define PERL_LONG_MIN MINLONG +# else +# define PERL_LONG_MIN (-LONG_MAX - ((3 & -1) == 3)) +# endif +#endif + +#ifdef ULONG_MAX +#define PERL_ULONG_MAX ULONG_MAX +#else +# ifdef MAXULONG +# define PERL_ULONG_MAX MAXULONG +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +#endif + +#ifdef ULONG_MIN +#define PERL_ULONG_MIN ULONG_MIN +#else +# define ULONG_MIN 0L +#endif + typedef MEM_SIZE STRLEN; typedef struct op OP; @@ -600,6 +681,9 @@ typedef I32 (*filter_t) _((int, SV *, int)); #ifndef SH_PATH /* May be a variable. */ # define SH_PATH BIN_SH +#ifndef BIN_SH +# define BIN_SH "/bin/sh" +#endif #endif #ifndef HAS_PAUSE @@ -748,7 +832,7 @@ Gid_t getegid _((void)); #ifdef DEBUGGING #ifndef Perl_debug_log -#define Perl_debug_log stderr +#define Perl_debug_log PerlIO_stderr() #endif #define YYDEBUG 1 #define DEB(a) a @@ -869,15 +953,16 @@ I32 unlnk _((char*)); #define SCAN_TR 1 #define SCAN_REPL 2 +#ifdef MYMALLOC +# ifndef DEBUGGING_MSTATS +# define DEBUGGING_MSTATS +# endif +#endif + #ifdef DEBUGGING # ifndef register # define register # endif -# ifdef MYMALLOC -# ifndef DEBUGGING_MSTATS -# define DEBUGGING_MSTATS -# endif -# endif # define PAD_SV(po) pad_sv(po) #else # define PAD_SV(po) curpad[po] @@ -1160,7 +1245,7 @@ EXT YYSTYPE nextval[5]; /* value of next token, if any */ EXT I32 nexttype[5]; /* type of next token */ EXT I32 nexttoke; -EXT FILE * VOL rsfp INIT(Nullfp); +EXT PerlIO * VOL rsfp INIT(Nullfp); EXT SV * linestr; EXT char * bufptr; EXT char * oldbufptr; @@ -1235,6 +1320,9 @@ EXT char * regtill; /* How far we are required to go. */ EXT U16 regflags; /* are we folding, multilining? */ EXT char regprev; /* char before regbol, \n if none */ +EXT bool do_undump; /* -u or dump seen? */ +EXT VOL U32 debug; + /***********************************************/ /* Global only to current interpreter instance */ /***********************************************/ @@ -1285,11 +1373,9 @@ IEXT bool Isawstudy; /* do fbm_instr on all strings */ IEXT bool Isawi; /* study must assume case insensitive */ IEXT bool Isawvec; IEXT bool Iunsafe; -IEXT bool Ido_undump; /* -u or dump seen? */ IEXT char * Iinplace; IEXT char * Ie_tmpname; -IEXT FILE * Ie_fp; -IEXT VOL U32 Idebug; +IEXT PerlIO * Ie_fp; IEXT U32 Iperldb; /* This value may be raised by extensions for testing purposes */ IEXT int Iperl_destruct_level; /* 0=none, 1=full, 2=full with checks */ @@ -1455,20 +1541,6 @@ struct interpreter { extern "C" { #endif -#ifdef __cplusplus -# ifndef I_STDARG -# define I_STDARG 1 -# endif -#endif - -#ifdef I_STDARG -# include <stdarg.h> -#else -# ifdef I_VARARGS -# include <varargs.h> -# endif -#endif - #include "proto.h" #ifdef EMBED @@ -1654,4 +1726,12 @@ enum { }; #endif /* OVERLOAD */ +#if !defined(PERLIO_IS_STDIO) && defined(HAS_ATTRIBUTE) +/* + * Now we have __attribute__ out of the way + * Remap printf + */ +#define printf PerlIO_stdoutf +#endif + #endif /* Include guard */ diff --git a/perlio.c b/perlio.c new file mode 100644 index 0000000000..2da92c24d7 --- /dev/null +++ b/perlio.c @@ -0,0 +1,594 @@ +/* perlio.c + * + * Copyright (c) 1996, Nick Ing-Simmons + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +#define VOIDUSED 1 +#include "config.h" + +#define PERLIO_NOT_STDIO 0 +#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) +#define PerlIO FILE +#endif +/* + * This file provides those parts of PerlIO abstraction + * which are not #defined in perlio.h. + * Which these are depends on various Configure #ifdef's + */ + +#include "EXTERN.h" +#include "perl.h" + +#ifdef PERLIO_IS_STDIO + +void +PerlIO_init() +{ + /* Does nothing (yet) except force this file to be included + in perl binary. That allows this file to force inclusion + of other functions that may be required by loadable + extensions e.g. for FileHandle::tmpfile + */ +} + +#else /* PERLIO_IS_STDIO */ + +#ifdef USE_SFIO + +#undef HAS_FSETPOS +#undef HAS_FGETPOS + +/* This section is just to make sure these functions + get pulled in from libsfio.a +*/ + +#undef PerlIO_tmpfile +PerlIO * +PerlIO_tmpfile() +{ + return sftmp(0); +} + +void +PerlIO_init() +{ + /* Force this file to be included in perl binary. Which allows + * this file to force inclusion of other functions that may be + * required by loadable extensions e.g. for FileHandle::tmpfile + */ + + /* Hack + * sfio does its own 'autoflush' on stdout in common cases. + * Flush results in a lot of lseek()s to regular files and + * lot of small writes to pipes. + */ + sfset(sfstdout,SF_SHARE,0); +} + +#else + +/* Implement all the PerlIO interface using stdio. + - this should be only file to include <stdio.h> +*/ + +#undef PerlIO_stderr +PerlIO * +PerlIO_stderr() +{ + return (PerlIO *) stderr; +} + +#undef PerlIO_stdin +PerlIO * +PerlIO_stdin() +{ + return (PerlIO *) stdin; +} + +#undef PerlIO_stdout +PerlIO * +PerlIO_stdout() +{ + return (PerlIO *) stdout; +} + +#ifdef HAS_SETLINEBUF +extern void setlinebuf _((FILE *iop)); +#endif + +#undef PerlIO_fast_gets +int +PerlIO_fast_gets(f) +PerlIO *f; +{ +#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) + return 1; +#else + return 0; +#endif +} + +#undef PerlIO_has_cntptr +int +PerlIO_has_cntptr(f) +PerlIO *f; +{ +#if defined(USE_STDIO_PTR) + return 1; +#else + return 0; +#endif +} + +#undef PerlIO_canset_cnt +int +PerlIO_canset_cnt(f) +PerlIO *f; +{ +#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) + return 1; +#else + return 0; +#endif +} + +#undef PerlIO_set_cnt +void +PerlIO_set_cnt(f,cnt) +PerlIO *f; +int cnt; +{ + if (cnt < 0) + warn("Setting cnt to %d\n",cnt); +#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) + FILE_cnt(f) = cnt; +#else + croak("Cannot set 'cnt' of FILE * on this system"); +#endif +} + +#undef PerlIO_set_ptrcnt +void +PerlIO_set_ptrcnt(f,ptr,cnt) +PerlIO *f; +char *ptr; +int cnt; +{ + char *e = (char *)(FILE_base(f) + FILE_bufsiz(f)); + int ec = e - ptr; + if (ptr > e) + warn("Setting ptr %p > base %p\n",ptr, FILE_base(f)+FILE_bufsiz(f)); + if (cnt != ec) + warn("Setting cnt to %d, ptr implies %d\n",cnt,ec); +#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) + FILE_ptr(f) = (STDCHAR *) ptr; +#else + croak("Cannot set 'ptr' of FILE * on this system"); +#endif +#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) + FILE_cnt(f) = cnt; +#else + croak("Cannot set 'cnt' of FILE * on this system"); +#endif +} + +#undef PerlIO_get_cnt +int +PerlIO_get_cnt(f) +PerlIO *f; +{ +#ifdef FILE_cnt + return FILE_cnt(f); +#else + croak("Cannot get 'cnt' of FILE * on this system"); + return -1; +#endif +} + +#undef PerlIO_get_bufsiz +int +PerlIO_get_bufsiz(f) +PerlIO *f; +{ +#ifdef FILE_bufsiz + return FILE_bufsiz(f); +#else + croak("Cannot get 'bufsiz' of FILE * on this system"); + return -1; +#endif +} + +#undef PerlIO_get_ptr +char * +PerlIO_get_ptr(f) +PerlIO *f; +{ +#ifdef FILE_ptr + return (char *) FILE_ptr(f); +#else + croak("Cannot get 'ptr' of FILE * on this system"); + return NULL; +#endif +} + +#undef PerlIO_get_base +char * +PerlIO_get_base(f) +PerlIO *f; +{ +#ifdef FILE_base + return (char *) FILE_base(f); +#else + croak("Cannot get 'base' of FILE * on this system"); + return NULL; +#endif +} + +#undef PerlIO_has_base +int +PerlIO_has_base(f) +PerlIO *f; +{ +#ifdef FILE_base + return 1; +#else + return 0; +#endif +} + +#undef PerlIO_puts +int +PerlIO_puts(f,s) +PerlIO *f; +const char *s; +{ + return fputs(s,f); +} + +#undef PerlIO_open +PerlIO * +PerlIO_open(path,mode) +const char *path; +const char *mode; +{ + return fopen(path,mode); +} + +#undef PerlIO_fdopen +PerlIO * +PerlIO_fdopen(fd,mode) +int fd; +const char *mode; +{ + return fdopen(fd,mode); +} + + +#undef PerlIO_close +int +PerlIO_close(f) +PerlIO *f; +{ + return fclose(f); +} + +#undef PerlIO_eof +int +PerlIO_eof(f) +PerlIO *f; +{ + return feof(f); +} + +#undef PerlIO_getc +int +PerlIO_getc(f) +PerlIO *f; +{ + return fgetc(f); +} + +#undef PerlIO_error +int +PerlIO_error(f) +PerlIO *f; +{ + return ferror(f); +} + +#undef PerlIO_clearerr +void +PerlIO_clearerr(f) +PerlIO *f; +{ + clearerr(f); +} + +#undef PerlIO_flush +int +PerlIO_flush(f) +PerlIO *f; +{ + return Fflush(f); +} + +#undef PerlIO_fileno +int +PerlIO_fileno(f) +PerlIO *f; +{ + return fileno(f); +} + +#undef PerlIO_setlinebuf +void +PerlIO_setlinebuf(f) +PerlIO *f; +{ +#ifdef HAS_SETLINEBUF + setlinebuf(f); +#else + setvbuf(f, Nullch, _IOLBF, 0); +#endif +} + +#undef PerlIO_putc +int +PerlIO_putc(f,ch) +PerlIO *f; +int ch; +{ + putc(ch,f); +} + +#undef PerlIO_ungetc +int +PerlIO_ungetc(f,ch) +PerlIO *f; +int ch; +{ + ungetc(ch,f); +} + +#undef PerlIO_read +int +PerlIO_read(f,buf,count) +PerlIO *f; +void *buf; +size_t count; +{ + return fread(buf,1,count,f); +} + +#undef PerlIO_write +int +PerlIO_write(f,buf,count) +PerlIO *f; +const void *buf; +size_t count; +{ + return fwrite1(buf,1,count,f); +} + +#undef PerlIO_vprintf +int +PerlIO_vprintf(f,fmt,ap) +PerlIO *f; +const char *fmt; +va_list ap; +{ + return vfprintf(f,fmt,ap); +} + + +#undef PerlIO_tell +long +PerlIO_tell(f) +PerlIO *f; +{ + return ftell(f); +} + +#undef PerlIO_seek +int +PerlIO_seek(f,offset,whence) +PerlIO *f; +off_t offset; +int whence; +{ + return fseek(f,offset,whence); +} + +#undef PerlIO_rewind +void +PerlIO_rewind(f) +PerlIO *f; +{ + rewind(f); +} + +#undef PerlIO_printf +int +#ifdef I_STDARG +PerlIO_printf(PerlIO *f,const char *fmt,...) +#else +PerlIO_printf(f,fmt,va_alist) +PerlIO *f; +const char *fmt; +va_dcl +#endif +{ + va_list ap; + int result; +#ifdef I_STDARG + va_start(ap,fmt); +#else + va_start(ap); +#endif + result = vfprintf(f,fmt,ap); + va_end(ap); + return result; +} + +#undef PerlIO_stdoutf +int +#ifdef I_STDARG +PerlIO_stdoutf(const char *fmt,...) +#else +PerlIO_stdoutf(fmt, va_alist) +const char *fmt; +va_dcl +#endif +{ + va_list ap; + int result; +#ifdef I_STDARG + va_start(ap,fmt); +#else + va_start(ap); +#endif + result = PerlIO_vprintf(PerlIO_stdout(),fmt,ap); + va_end(ap); + return result; +} + +#undef PerlIO_tmpfile +PerlIO * +PerlIO_tmpfile() +{ + return tmpfile(); +} + +#undef PerlIO_importFILE +PerlIO * +PerlIO_importFILE(f,fl) +FILE *f; +int fl; +{ + return f; +} + +#undef PerlIO_exportFILE +FILE * +PerlIO_exportFILE(f,fl) +PerlIO *f; +int fl; +{ + return f; +} + +#undef PerlIO_findFILE +FILE * +PerlIO_findFILE(f) +PerlIO *f; +{ + return f; +} + +#undef PerlIO_releaseFILE +void +PerlIO_releaseFILE(p,f) +PerlIO *p; +FILE *f; +{ +} + +void +PerlIO_init() +{ + /* Does nothing (yet) except force this file to be included + in perl binary. That allows this file to force inclusion + of other functions that may be required by loadable + extensions e.g. for FileHandle::tmpfile + */ +} + +#endif /* USE_SFIO */ +#endif /* PERLIO_IS_STDIO */ + +#ifndef HAS_FSETPOS +#undef PerlIO_setpos +int +PerlIO_setpos(f,pos) +PerlIO *f; +const Fpos_t *pos; +{ + return PerlIO_seek(f,*pos,0); +} +#endif + +#ifndef HAS_FGETPOS +#undef PerlIO_getpos +int +PerlIO_getpos(f,pos) +PerlIO *f; +Fpos_t *pos; +{ + *pos = PerlIO_tell(f); + return 0; +} +#endif + +#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) + +int +vprintf(fd, pat, args) +FILE *fd; +char *pat, *args; +{ + _doprnt(pat, args, fd); + return 0; /* wrong, but perl doesn't use the return value */ +} + +#endif + +#ifndef PerlIO_vsprintf +int +PerlIO_vsprintf(s,n,fmt,ap) +char *s; +const char *fmt; +int n; +va_list ap; +{ + int val = vsprintf(s, fmt, ap); + if (n >= 0) + { + if (strlen(s) >= n) + { + PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n"); + my_exit(1); + } + } + return val; +} +#endif + +#ifndef PerlIO_sprintf +int +#ifdef I_STDARG +PerlIO_sprintf(char *s, int n, const char *fmt,...) +#else +PerlIO_sprintf(s, n, fmt, va_alist) +char *s; +int n; +const char *fmt; +va_dcl +#endif +{ + va_list ap; + int result; +#ifdef I_STDARG + va_start(ap,fmt); +#else + va_start(ap); +#endif + result = PerlIO_vsprintf(s, n, fmt, ap); + va_end(ap); + return result; +} +#endif + diff --git a/perlio.h b/perlio.h new file mode 100644 index 0000000000..bdf59d78be --- /dev/null +++ b/perlio.h @@ -0,0 +1,193 @@ +#ifndef H_PERLIO +#define H_PERLIO 1 + +/* Allow -DUSE_STDIO to force the issue for x2p directory */ +#ifdef USE_STDIO +#ifdef PERLIO_IS_STDIO +#undef PERLIO_IS_STDIO +#endif +#define PERLIO_IS_STDIO +#else +extern void PerlIO_init _((void)); +#endif + +#include "perlsdio.h" + +#ifndef PERLIO_IS_STDIO +#ifdef USE_SFIO +#include "perlsfio.h" +#endif /* USE_SFIO */ +#endif /* PERLIO_IS_STDIO */ + +#ifndef EOF +#define EOF (-1) +#endif + +/* This is to catch case with no stdio */ +#ifndef BUFSIZ +#define BUFSIZ 1024 +#endif + +#ifndef SEEK_SET +#define SEEK_SET 0 +#endif + +#ifndef SEEK_CUR +#define SEEK_CUR 1 +#endif + +#ifndef SEEK_END +#define SEEK_END 2 +#endif + +#ifndef PerlIO +struct _PerlIO; +#define PerlIO struct _PerlIO +#endif /* No PerlIO */ + +#ifndef Fpos_t +#define Fpos_t long +#endif + +#ifndef NEXT30_NO_ATTRIBUTE +#ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */ +#ifdef __attribute__ /* Avoid possible redefinition errors */ +#undef __attribute__ +#endif +#define __attribute__(attr) +#endif +#endif + +#ifndef PerlIO_stdoutf +extern int PerlIO_stdoutf _((const char *,...)) + __attribute__((format (printf, 1, 2))); +#endif +#ifndef PerlIO_puts +extern int PerlIO_puts _((PerlIO *,const char *)); +#endif +#ifndef PerlIO_open +extern PerlIO * PerlIO_open _((const char *,const char *)); +#endif +#ifndef PerlIO_close +extern int PerlIO_close _((PerlIO *)); +#endif +#ifndef PerlIO_eof +extern int PerlIO_eof _((PerlIO *)); +#endif +#ifndef PerlIO_error +extern int PerlIO_error _((PerlIO *)); +#endif +#ifndef PerlIO_clearerr +extern void PerlIO_clearerr _((PerlIO *)); +#endif +#ifndef PerlIO_getc +extern int PerlIO_getc _((PerlIO *)); +#endif +#ifndef PerlIO_putc +extern int PerlIO_putc _((PerlIO *,int)); +#endif +#ifndef PerlIO_flush +extern int PerlIO_flush _((PerlIO *)); +#endif +#ifndef PerlIO_ungetc +extern int PerlIO_ungetc _((PerlIO *,int)); +#endif +#ifndef PerlIO_fileno +extern int PerlIO_fileno _((PerlIO *)); +#endif +#ifndef PerlIO_fdopen +extern PerlIO * PerlIO_fdopen _((int, const char *)); +#endif +#ifndef PerlIO_importFILE +extern PerlIO * PerlIO_importFILE _((FILE *,int)); +#endif +#ifndef PerlIO_exportFILE +extern FILE * PerlIO_exportFILE _((PerlIO *,int)); +#endif +#ifndef PerlIO_findFILE +extern FILE * PerlIO_findFILE _((PerlIO *)); +#endif +#ifndef PerlIO_releaseFILE +extern void PerlIO_releaseFILE _((PerlIO *,FILE *)); +#endif +#ifndef PerlIO_read +extern int PerlIO_read _((PerlIO *,void *,size_t)); +#endif +#ifndef PerlIO_write +extern int PerlIO_write _((PerlIO *,const void *,size_t)); +#endif +#ifndef PerlIO_setlinebuf +extern void PerlIO_setlinebuf _((PerlIO *)); +#endif +#ifndef PerlIO_printf +extern int PerlIO_printf _((PerlIO *, const char *,...)) + __attribute__((format (printf, 2, 3))); +#endif +#ifndef PerlIO_sprintf +extern int PerlIO_sprintf _((char *, int, const char *,...)) + __attribute__((format (printf, 3, 4))); +#endif +#ifndef PerlIO_vprintf +extern int PerlIO_vprintf _((PerlIO *, const char *, va_list)); +#endif +#ifndef PerlIO_tell +extern long PerlIO_tell _((PerlIO *)); +#endif +#ifndef PerlIO_seek +extern int PerlIO_seek _((PerlIO *,off_t,int)); +#endif +#ifndef PerlIO_rewind +extern void PerlIO_rewind _((PerlIO *)); +#endif +#ifndef PerlIO_has_base +extern int PerlIO_has_base _((PerlIO *)); +#endif +#ifndef PerlIO_has_cntptr +extern int PerlIO_has_cntptr _((PerlIO *)); +#endif +#ifndef PerlIO_fast_gets +extern int PerlIO_fast_gets _((PerlIO *)); +#endif +#ifndef PerlIO_canset_cnt +extern int PerlIO_canset_cnt _((PerlIO *)); +#endif +#ifndef PerlIO_get_ptr +extern char * PerlIO_get_ptr _((PerlIO *)); +#endif +#ifndef PerlIO_get_cnt +extern int PerlIO_get_cnt _((PerlIO *)); +#endif +#ifndef PerlIO_set_cnt +extern void PerlIO_set_cnt _((PerlIO *,int)); +#endif +#ifndef PerlIO_set_ptrcnt +extern void PerlIO_set_ptrcnt _((PerlIO *,char *,int)); +#endif +#ifndef PerlIO_get_base +extern char * PerlIO_get_base _((PerlIO *)); +#endif +#ifndef PerlIO_get_bufsiz +extern int PerlIO_get_bufsiz _((PerlIO *)); +#endif +#ifndef PerlIO_tmpfile +extern PerlIO * PerlIO_tmpfile _((void)); +#endif +#ifndef PerlIO_stdin +extern PerlIO * PerlIO_stdin _((void)); +#endif +#ifndef PerlIO_stdout +extern PerlIO * PerlIO_stdout _((void)); +#endif +#ifndef PerlIO_stderr +extern PerlIO * PerlIO_stderr _((void)); +#endif +#ifndef PerlIO_getpos +extern int PerlIO_getpos _((PerlIO *,Fpos_t *)); +#endif +#ifndef PerlIO_setpos +extern int PerlIO_setpos _((PerlIO *,const Fpos_t *)); +#endif +#endif /* Include guard */ + + + diff --git a/perlsdio.h b/perlsdio.h new file mode 100644 index 0000000000..038148f1f4 --- /dev/null +++ b/perlsdio.h @@ -0,0 +1,230 @@ +/* + * Although we may not want stdio to be used including <stdio.h> here + * avoids issues where stdio.h has strange side effects + */ +#include <stdio.h> + +#ifdef PERLIO_IS_STDIO +/* + * Make this as close to original stdio as possible. + */ +#define PerlIO FILE +#define PerlIO_stderr() stderr +#define PerlIO_stdout() stdout +#define PerlIO_stdin() stdin + +#define PerlIO_printf fprintf +#define PerlIO_stdoutf printf +#define PerlIO_vprintf(f,fmt,a) vfprintf(f,fmt,a) +#define PerlIO_read(f,buf,count) fread(buf,1,count,f) +#define PerlIO_write(f,buf,count) fwrite1(buf,1,count,f) +#define PerlIO_open(path,mode) fopen(path,mode) +#define PerlIO_fdopen(fd,mode) fdopen(fd,mode) +#define PerlIO_close(f) fclose(f) +#define PerlIO_puts(f,s) fputs(s,f) +#define PerlIO_putc(f,c) fputc(c,f) +#define PerlIO_ungetc(f,c) ungetc(c,f) +#define PerlIO_getc(f) getc(f) +#define PerlIO_eof(f) feof(f) +#define PerlIO_error(f) ferror(f) +#define PerlIO_fileno(f) fileno(f) +#define PerlIO_clearerr(f) clearerr(f) +#define PerlIO_flush(f) Fflush(f) +#define PerlIO_tell(f) ftell(f) +#define PerlIO_seek(f,o,w) fseek(f,o,w) +#ifdef HAS_FGETPOS +#define PerlIO_getpos(f,p) fgetpos(f,p) +#endif +#ifdef HAS_FSETPOS +#define PerlIO_setpos(f,p) fsetpos(f,p) +#endif + +#define PerlIO_rewind(f) rewind(f) +#define PerlIO_tmpfile() tmpfile() + +#define PerlIO_importFILE(f,fl) (f) +#define PerlIO_exportFILE(f,fl) (f) +#define PerlIO_findFILE(f) (f) +#define PerlIO_releaseFILE(p,f) ((void) 0) + +#ifdef HAS_SETLINEBUF +#define PerlIO_setlinebuf(f) setlinebuf(f); +#else +#define PerlIO_setlinebuf(f) setvbuf(f, Nullch, _IOLBF, 0); +#endif + +/* Now our interface to Configure's FILE_xxx macros */ + +#ifdef USE_STDIO_PTR +#define PerlIO_has_cntptr(f) 1 +#define PerlIO_get_ptr(f) FILE_ptr(f) +#define PerlIO_get_cnt(f) FILE_cnt(f) + +#ifdef FILE_CNT_LVALUE +#define PerlIO_canset_cnt(f) 1 +#ifdef FILE_PTR_LVALUE +#define PerlIO_fast_gets(f) 1 +#endif +#define PerlIO_set_cnt(f,c) (FILE_cnt(f) = (c)) +#else +#define PerlIO_canset_cnt(f) 0 +#define PerlIO_set_cnt(f,c) abort() +#endif + +#ifdef FILE_PTR_LVALUE +#define PerlIO_set_ptrcnt(f,p,c) (FILE_ptr(f) = (p), PerlIO_set_cnt(f,c)) +#else +#define PerlIO_set_ptrcnt(f,p,c) abort() +#endif + +#else /* USE_STDIO_PTR */ + +#define PerlIO_has_cntptr(f) 0 +#define PerlIO_get_cnt(f) abort() +#define PerlIO_get_ptr(f) abort() +#define PerlIO_set_cnt(f,c) abort() +#define PerlIO_set_ptrcnt(f,p,c) abort() + +#endif /* USE_STDIO_PTR */ + +#ifndef PerlIO_fast_gets +#define PerlIO_fast_gets(f) 0 +#endif + + +#ifdef FILE_base +#define PerlIO_has_base(f) 1 +#define PerlIO_get_base(f) FILE_base(f) +#define PerlIO_get_bufsiz(f) FILE_bufsiz(f) +#else +#define PerlIO_has_base(f) 0 +#define PerlIO_get_base(f) abort() +#define PerlIO_get_bufsiz(f) abort() +#endif +#else /* PERLIO_IS_STDIO */ +#ifdef PERL_CORE +#ifndef PERLIO_NOT_STDIO +#define PERLIO_NOT_STDIO 1 +#endif +#endif +#ifdef PERLIO_NOT_STDIO +#if PERLIO_NOT_STDIO +/* + * Strong denial of stdio - make all stdio calls (we can think of) errors + */ +#include "nostdio.h" +#define fprintf _CANNOT _fprintf_ +#define stdin _CANNOT _stdin_ +#define stdout _CANNOT _stdout_ +#define stderr _CANNOT _stderr_ +#define tmpfile() _CANNOT _tmpfile_ +#define fclose(f) _CANNOT _fclose_ +#define fflush(f) _CANNOT _fflush_ +#define fopen(p,m) _CANNOT _fopen_ +#define freopen(p,m,f) _CANNOT _freopen_ +#define setbuf(f,b) _CANNOT _setbuf_ +#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ +#define fscanf _CANNOT _fscanf_ +#define vfprintf(f,fmt,a) _CANNOT _vfprintf_ +#define fgetc(f) _CANNOT _fgetc_ +#define fgets(s,n,f) _CANNOT _fgets_ +#define fputc(c,f) _CANNOT _fputc_ +#define fputs(s,f) _CANNOT _fputs_ +#define getc(f) _CANNOT _getc_ +#define putc(c,f) _CANNOT _putc_ +#define ungetc(c,f) _CANNOT _ungetc_ +#define fread(b,s,c,f) _CANNOT _fread_ +#define fwrite(b,s,c,f) _CANNOT _fwrite_ +#define fgetpos(f,p) _CANNOT _fgetpos_ +#define fseek(f,o,w) _CANNOT _fseek_ +#define fsetpos(f,p) _CANNOT _fsetpos_ +#define ftell(f) _CANNOT _ftell_ +#define rewind(f) _CANNOT _rewind_ +#define clearerr(f) _CANNOT _clearerr_ +#define feof(f) _CANNOT _feof_ +#define ferror(f) _CANNOT _ferror_ +#define __filbuf(f) _CANNOT __filbuf_ +#define __flsbuf(c,f) _CANNOT __flsbuf_ +#define _filbuf(f) _CANNOT _filbuf_ +#define _flsbuf(c,f) _CANNOT _flsbuf_ +#define fdopen(fd,p) _CANNOT _fdopen_ +#define fileno(f) _CANNOT _fileno_ +#define flockfile(f) _CANNOT _flockfile_ +#define ftrylockfile(f) _CANNOT _ftrylockfile_ +#define funlockfile(f) _CANNOT _funlockfile_ +#define getc_unlocked(f) _CANNOT _getc_unlocked_ +#define putc_unlocked(c,f) _CANNOT _putc_unlocked_ +#define popen(c,m) _CANNOT _popen_ +#define getw(f) _CANNOT _getw_ +#define putw(v,f) _CANNOT _putw_ +#define pclose(f) _CANNOT _pclose_ + +#else /* if PERLIO_NOT_STDIO */ +/* + * PERLIO_NOT_STDIO defined as 0 + * Declares that both PerlIO and stdio can be used + */ +#endif /* if PERLIO_NOT_STDIO */ +#else /* ifdef PERLIO_NOT_STDIO */ +/* + * PERLIO_NOT_STDIO not defined + * This is "source level" stdio compatibility mode. + */ +#include "nostdio.h" +#undef FILE +#define FILE PerlIO +#define fprintf PerlIO_printf +#define stdin PerlIO_stdin() +#define stdout PerlIO_stdout() +#define stderr PerlIO_stderr() +#define tmpfile() PerlIO_tmpfile() +#define fclose(f) PerlIO_close(f) +#define fflush(f) PerlIO_flush(f) +#define fopen(p,m) PerlIO_open(p,m) +#define vfprintf(f,fmt,a) PerlIO_vprintf(f,fmt,a) +#define fgetc(f) PerlIO_getc(f) +#define fputc(c,f) PerlIO_putc(f,c) +#define fputs(s,f) PerlIO_puts(f,s) +#define getc(f) PerlIO_getc(f) +#define getc_unlocked(f) PerlIO_getc(f) +#define putc(c,f) PerlIO_putc(f,c) +#define putc_unlocked(c,f) PerlIO_putc(c,f) +#define ungetc(c,f) PerlIO_ungetc(f,c) +#if 0 +/* return values of read/write need work */ +#define fread(b,s,c,f) PerlIO_read(f,b,(s*c)) +#define fwrite(b,s,c,f) PerlIO_write(f,b,(s*c)) +#else +#define fread(b,s,c,f) _CANNOT fread +#define fwrite(b,s,c,f) _CANNOT fwrite +#endif +#define fgetpos(f,p) PerlIO_getpos(f,p) +#define fseek(f,o,w) PerlIO_seek(f,o,w) +#define fsetpos(f,p) PerlIO_setpos(f,p) +#define ftell(f) PerlIO_tell(f) +#define rewind(f) PerlIO_rewind(f) +#define clearerr(f) PerlIO_clearerr(f) +#define feof(f) PerlIO_eof(f) +#define ferror(f) PerlIO_error(f) +#define fdopen(fd,p) PerlIO_fdopen(fd,p) +#define fileno(f) PerlIO_fileno(f) +#define popen(c,m) my_popen(c,m) +#define pclose(f) my_pclose(f) + +#define __filbuf(f) _CANNOT __filbuf_ +#define _filbuf(f) _CANNOT _filbuf_ +#define __flsbuf(c,f) _CANNOT __flsbuf_ +#define _flsbuf(c,f) _CANNOT _flsbuf_ +#define getw(f) _CANNOT _getw_ +#define putw(v,f) _CANNOT _putw_ +#define flockfile(f) _CANNOT _flockfile_ +#define ftrylockfile(f) _CANNOT _ftrylockfile_ +#define funlockfile(f) _CANNOT _funlockfile_ +#define freopen(p,m,f) _CANNOT _freopen_ +#define setbuf(f,b) _CANNOT _setbuf_ +#define setvbuf(f,b,x,s) _CANNOT _setvbuf_ +#define fscanf _CANNOT _fscanf_ +#define fgets(s,n,f) _CANNOT _fgets_ + +#endif /* ifdef PERLIO_NOT_STDIO */ +#endif /* PERLIO_IS_STDIO */ diff --git a/perlsfio.h b/perlsfio.h new file mode 100644 index 0000000000..8c9387fbd0 --- /dev/null +++ b/perlsfio.h @@ -0,0 +1,58 @@ +/* The next #ifdef should be redundant if Configure behaves ... */ +#ifdef I_SFIO +#include <sfio.h> +#endif + +extern Sfio_t* _stdopen _ARG_((int, const char*)); +extern int _stdprintf _ARG_((const char*, ...)); + +#define PerlIO Sfio_t +#define PerlIO_stderr() sfstderr +#define PerlIO_stdout() sfstdout +#define PerlIO_stdin() sfstdin + +#define PerlIO_printf sfprintf +#define PerlIO_stdoutf _stdprintf +#define PerlIO_vprintf(f,fmt,a) sfvprintf(f,fmt,a) +#define PerlIO_read(f,buf,count) sfread(f,buf,count) +#define PerlIO_write(f,buf,count) sfwrite(f,buf,count) +#define PerlIO_open(path,mode) sfopen(NULL,path,mode) +#define PerlIO_fdopen(fd,mode) _stdopen(fd,mode) +#define PerlIO_close(f) sfclose(f) +#define PerlIO_puts(f,s) sfputr(f,s,-1) +#define PerlIO_putc(f,c) sfputc(f,c) +#define PerlIO_ungetc(f,c) sfungetc(f,c) +#define PerlIO_sprintf sfsprintf +#define PerlIO_getc(f) sfgetc(f) +#define PerlIO_eof(f) sfeof(f) +#define PerlIO_error(f) sferror(f) +#define PerlIO_fileno(f) sffileno(f) +#define PerlIO_clearerr(f) sfclrerr(f) +#define PerlIO_flush(f) sfsync(f) +#define PerlIO_tell(f) sftell(f) +#define PerlIO_seek(f,o,w) sfseek(f,o,w) +#define PerlIO_rewind(f) (void) sfseek((f),0L,0) +#define PerlIO_tmpfile() sftmp(0) + +#define PerlIO_importFILE(f,fl) croak("Import from FILE * unimplemeted") +#define PerlIO_exportFILE(f,fl) croak("Export to FILE * unimplemeted") +#define PerlIO_findFILE(f) NULL +#define PerlIO_releaseFILE(p,f) croak("Release of FILE * unimplemeted") + +#define PerlIO_setlinebuf(f) sfset(f,SF_LINE,1) + +/* Now our interface to equivalent of Configure's FILE_xxx macros */ + +#define PerlIO_has_cntptr(f) 1 +#define PerlIO_get_ptr(f) ((f)->next) +#define PerlIO_get_cnt(f) ((f)->endr - (f)->next) +#define PerlIO_canset_cnt(f) 1 +#define PerlIO_fast_gets(f) 1 +#define PerlIO_set_ptrcnt(f,p,c) ((f)->next = (p)) +#define PerlIO_set_cnt(f,c) 1 + +#define PerlIO_has_base(f) 1 +#define PerlIO_get_base(f) ((f)->data) +#define PerlIO_get_bufsiz(f) ((f)->endr - (f)->data) + + @@ -1406,7 +1406,7 @@ yyloop: yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; - fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate, + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } #endif @@ -1416,7 +1416,7 @@ yyloop: { #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", + PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif if (yyssp >= yyss + yystacksize - 1) @@ -1471,7 +1471,7 @@ yyinrecovery: { #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery shifting to state %d\n", *yyssp, yytable[yyn]); #endif @@ -1501,7 +1501,7 @@ yyinrecovery: { #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: error recovery discarding state %d\n", *yyssp); #endif @@ -1520,7 +1520,7 @@ yyinrecovery: yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery discards token %d (%s)\n", yystate, yychar, yys); } @@ -1531,7 +1531,7 @@ yyinrecovery: yyreduce: #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; @@ -2250,7 +2250,7 @@ break; { #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state 0 to state %d\n", YYFINAL); #endif @@ -2266,7 +2266,7 @@ break; yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; - fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } #endif @@ -2281,7 +2281,7 @@ break; yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state %d to state %d\n", *yyssp, yystate); #endif @@ -62,3 +62,4 @@ typedef union { GV *gvval; } YYSTYPE; extern YYSTYPE yylval; +extern YYSTYPE yylval; diff --git a/plan9/fndvers b/plan9/fndvers index c45c42bdf9..ad622e7fe8 100644 --- a/plan9/fndvers +++ b/plan9/fndvers @@ -5,5 +5,10 @@ ed config.plan9 <<! g/_P9P_VERSION/s//$p9pvers/g g/_P9P_OBJTYPE/s//$objtype/g -w $1 +w config.h +! + +ed plan9/genconfig.pl<<! +g/_P9P_VERSION/s//$p9pvers/g +w plan9/genconfig.pl ! diff --git a/plan9/genconfig.pl b/plan9/genconfig.pl index 2ab6295884..edcaf338db 100644 --- a/plan9/genconfig.pl +++ b/plan9/genconfig.pl @@ -10,7 +10,7 @@ # #==== Locations of installed Perl components -$p9pvers="5.00301"; +$p9pvers="_P9P_VERSION"; $prefix=''; $p9p_objtype=$ENV{'objtype'}; $builddir="/sys/src/cmd/perl/$p9pvers"; diff --git a/plan9/mkfile b/plan9/mkfile index 65568b2b16..64f9fa46b7 100644 --- a/plan9/mkfile +++ b/plan9/mkfile @@ -1,6 +1,3 @@ -Content-type: text/plain; charset="us-ascii" -Content-disposition: attachment; filename="mkfile" - APE=/sys/src/ape < $APE/config <plan9/buildinfo @@ -69,7 +66,7 @@ perlmain.c: miniperl vms/writemain.pl ./miniperl vms/writemain.pl $extensions config.h: config.plan9 plan9/fndvers - plan9/fndvers config.h + plan9/fndvers cp config.h $archlib/CORE $perlshr(%):N: % @@ -80,8 +77,10 @@ $perlshr: ${ext_obj:%=$perlshr(%)} IO.c: miniperl ext/IO/IO.xs ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/IO/IO.xs > $target cp ext/IO/*.pm $privlib - if (test !-d $privlib/IO) mkdir $privlib/IO + if (test !-d $privlib/IO) { + mkdir $privlib/IO cp ext/IO/lib/IO/*.pm $privlib/IO + } Socket.$O: config.h Socket.c $CCCMD -I plan9 Socket.c @@ -139,11 +138,9 @@ man:V: $perlpods pod/pod2man.PL perl for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i pod/pod2man plan9/perlplan9.pod > $installman3dir/perlplan9 -nuke:V: +nuke clean:V: rm -f *.$O $extensions^.pm config.sh $perllib config.h $perlshr perlmain.c perl miniperl $archlib/Config.pm $ext_c - -clean:V: - rm -f *.$O config.sh miniperl t/perl + rm -rf $privlib/IO deleteman:V: rm -f $installman1dir/perl* $installman3dir/perl* diff --git a/plan9/perlplan9.doc b/plan9/perlplan9.doc index 4f7a057749..5fc6e0f3a6 100644 --- a/plan9/perlplan9.doc +++ b/plan9/perlplan9.doc @@ -1,5 +1,5 @@ - PERLTEST/PLAN9/PERLPLAN9(1) (perl ) PERLTEST/PLAN9/PERLPLAN9(1) + PLAN9/PERLPLAN9(1) (perl 5.003, patch 01) PLAN9/PERLPLAN9(1) NNNNAAAAMMMMEEEE perlplan9 - Plan 9-specific documentation for Perl @@ -34,8 +34,8 @@ Although Plan 9 Perl currently only provides static loading, it is built with a number of useful extensions. - These include Safe, FileHandle, Fcntl, and POSIX. Expect to - see others (and DynaLoading!) in the future. + These include Opcode, FileHandle, Fcntl, and POSIX. Expect + to see others (and DynaLoading!) in the future. WWWWhhhhaaaatttt''''ssss nnnnooootttt iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll @@ -52,9 +52,9 @@ The functions not currently implemented include: - Page 1 4/Jul/96 (printed 7/4/96) + Page 1 6/Aug/96 (printed 8/6/96) - PERLTEST/PLAN9/PERLPLAN9(1) (perl ) PERLTEST/PLAN9/PERLPLAN9(1) + PLAN9/PERLPLAN9(1) (perl 5.003, patch 01) PLAN9/PERLPLAN9(1) chown, chroot, dbmclose, dbmopen, getsockopt, setsockopt, recvmsg, sendmsg, getnetbyname, @@ -82,10 +82,10 @@ the world . . ." - Carl Sagan RRRReeeevvvviiiissssiiiioooonnnn ddddaaaatttteeee - This document was revised 04-July-1996 for Perl 5.003_1. + This document was revised 06-August-1996 for Perl 5.003_2. AAAAUUUUTTTTHHHHOOOORRRR Luther Huffman, lutherh@stratcom.com - Page 2 4/Jul/96 (printed 7/4/96) + Page 2 6/Aug/96 (printed 8/6/96) diff --git a/plan9/perlplan9.pod b/plan9/perlplan9.pod index 9f13f06e7e..f632d45abf 100644 --- a/plan9/perlplan9.pod +++ b/plan9/perlplan9.pod @@ -34,7 +34,7 @@ Perl. These you won't need to be worried about. Although Plan 9 Perl currently only provides static loading, it is built with a number of useful extensions. -These include Safe, FileHandle, Fcntl, and POSIX. Expect +These include Opcode, FileHandle, Fcntl, and POSIX. Expect to see others (and DynaLoading!) in the future. =head2 What's not in Plan 9 Perl @@ -80,7 +80,7 @@ world . . ." - Carl Sagan =head1 Revision date -This document was revised 04-July-1996 for Perl 5.003_1. +This document was revised 06-August-1996 for Perl 5.003_2. =head1 AUTHOR diff --git a/plan9/setup.rc b/plan9/setup.rc index c6ebe86fc8..6ac56dfe99 100644 --- a/plan9/setup.rc +++ b/plan9/setup.rc @@ -6,6 +6,7 @@ # Last modified 6/30/96 by: # Luther Huffman, Strategic Computer Solutions, Inc., lutherh@stratcom.com +awk -f versnum ../patchlevel.h . buildinfo builddir = `{ cd .. ; pwd } if(flag a) platforms = (386 mips sparc 68020) diff --git a/plan9/versnum b/plan9/versnum new file mode 100644 index 0000000000..83e46826c3 --- /dev/null +++ b/plan9/versnum @@ -0,0 +1,8 @@ +/PATCHLEVEL/ {base = $3} +/SUBVERSION/ {subvers = $3} +END { +if (subvers == 0) + printf "p9pvers = 5.%03d\n", base> "buildinfo"; +else + printf "p9pvers = 5.%03d_%02d\n" , base, subvers> "buildinfo"; +} diff --git a/pod/Makefile.PL b/pod/Makefile.PL new file mode 100644 index 0000000000..911bff83e3 --- /dev/null +++ b/pod/Makefile.PL @@ -0,0 +1,133 @@ +#!/usr/local/bin/perl + +use Config; +use File::Basename qw(&basename &dirname); + +# List explicitly here the variables you want Configure to +# generate. Metaconfig only looks for shell variables, so you +# have to mention them as if they were shell variables, not +# %Config entries. Thus you write +# $startperl +# to ensure Configure will look for $Config{startperl}. + +# This forces PL files to create target in same directory as PL file. +# This is so that make depend always knows where to find PL derivatives. +chdir(dirname($0)); +($file = basename($0)) =~ s/\.PL$//; +$file =~ s/\.pl$// + if ($Config{'osname'} eq 'VMS' or + $Config{'osname'} eq 'OS2'); # "case-forgiving" + +open OUT,">$file" or die "Can't create $file: $!"; + +print "Extracting $file (with variable substitutions)\n"; + +# In this section, perl variables will be expanded during extraction. +# You can use $Config{...} to use Configure variables. + +print OUT <<"!GROK!THIS!"; +!GROK!THIS! + +# In the following, perl variables are not expanded during extraction. + +print OUT <<'!NO!SUBS!'; +CONVERTERS = pod2html pod2latex pod2man pod2text + +all: $(CONVERTERS) man +!NO!SUBS! + +if (-x '../miniperl') { + print OUT "PERL = ..\/miniperl\n\n"; +} +else { + print OUT "PERL = ../miniperl\n\n"; +} + +@pods = <*.pod>; + +print OUT 'POD = '; +foreach (@pods) { + # Remove .pod suffix. Each section should add its own suffix. + s/\.pod$//; + print OUT "\t\\\n\t$_.pod"; +} +print OUT "\n\n"; + +print OUT 'MAN = '; +foreach (@pods) { + print OUT "\t\\\n\t$_.man"; +} +print OUT "\n\n"; + +print OUT 'HTML = '; +foreach (@pods) { + print OUT "\t\\\n\t$_.html"; +} +print OUT "\n\n"; + +print OUT 'TEX = '; +foreach (@pods) { + s/\.pod/.tex/; + print OUT "\t\\\n\t$_.tex"; +} +print OUT "\n\n"; + +print OUT <<'!NO!SUBS!'; +man: pod2man $(MAN) + +# pod2html normally runs on all the pods at once in order to build up +# cross-references. +html: pod2html + $(PERL) -I../lib pod2html $(POD) + +tex: pod2latex $(TEX) + +.SUFFIXES: .pm .pod .man + +.pm.man: pod2man + $(PERL) -I../lib pod2man $*.pm >$*.man + +.pod.man: pod2man + $(PERL) -I../lib pod2man $*.pod >$*.man + +.SUFFIXES: .mp .pod .html + +.pm.html: pod2html + $(PERL) -I../lib pod2html $*.pod + +.pod.html: pod2html + $(PERL) -I../lib pod2html $*.pod + +.SUFFIXES: .pm .pod .tex + +.pod.tex: pod2latex + $(PERL) -I../lib pod2latex $*.pod + +.pm.tex: pod2latex + $(PERL) -I../lib pod2latex $*.pod + +clean: + rm -f $(MAN) $(HTML) $(TEX) + +realclean: clean + rm -f $(CONVERTERS) + +distclean: realclean + +# Dependencies. +pod2latex: pod2latex.PL ../lib/Config.pm + $(PERL) -I../lib pod2latex.PL + +pod2html: pod2html.PL ../lib/Config.pm + $(PERL) -I ../lib pod2html.PL + +pod2man: pod2man.PL ../lib/Config.pm + $(PERL) -I ../lib pod2man.PL + +pod2text: pod2text.PL ../lib/Config.pm + $(PERL) -I ../lib pod2text.PL +!NO!SUBS! + +close OUT or die "Can't close $file: $!"; +chmod 0644, $file or die "Can't reset permissions for $file: $!\n"; +exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; diff --git a/pod/perl.pod b/pod/perl.pod index 725f473d8d..61aa1f4771 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -20,6 +20,7 @@ of sections: perl Perl overview (this section) perltoc Perl documentation table of contents + perldata Perl data structures perlsyn Perl syntax perlop Perl operators and precedence @@ -29,26 +30,31 @@ of sections: perlvar Perl predefined variables perlsub Perl subroutines perlmod Perl modules + perlform Perl formats + perlref Perl references perldsc Perl data structures intro perllol Perl data structures: lists of lists perlobj Perl objects perltie Perl objects hidden behind simple variables perlbot Perl OO tricks and examples + perlipc Perl interprocess communication + perldebug Perl debugging perldiag Perl diagnostic messages - perlform Perl formats - perlipc Perl interprocess communication perlsec Perl security perltrap Perl traps for the unwary perlstyle Perl style guide + + perlpod Perl plain old documentation + perlbook Perl book information + + perlembed Perl how to embed perl in your C or C++ app + perlapio Perl internal IO abstraction interface perlxs Perl XS application programming interface perlxstut Perl XS tutorial perlguts Perl internal functions for those doing extensions perlcall Perl calling conventions from C - perlembed Perl how to embed perl in your C or C++ app - perlpod Perl plain old documentation - perlbook Perl book information (If you're intending to read these straight through for the first time, the suggested order will tend to reduce the number of forward references.) @@ -59,7 +65,7 @@ Perl, but you'll also find third-party modules there. You should be able to view this with your man(1) program by including the proper directories in the appropriate start-up files. To find out where these are, type: - perl -le 'use Config; print "@Config{man1dir,man3dir}"' + perl -V:man.dir If the directories were F</usr/local/man/man1> and F</usr/local/man/man3>, you would only need to add F</usr/local/man> to your MANPATH. If diff --git a/pod/perlapio.pod b/pod/perlapio.pod new file mode 100644 index 0000000000..85900f157c --- /dev/null +++ b/pod/perlapio.pod @@ -0,0 +1,274 @@ +=head1 NAME + +perlio - perl's IO abstraction interface. + +=head1 SYNOPSIS + + PerlIO *PerlIO_stdin(void); + PerlIO *PerlIO_stdout(void); + PerlIO *PerlIO_stderr(void); + + PerlIO *PerlIO_open(const char *,const char *); + int PerlIO_close(PerlIO *); + + int PerlIO_stdoutf(const char *,...) + int PerlIO_puts(PerlIO *,const char *); + int PerlIO_putc(PerlIO *,int); + int PerlIO_write(PerlIO *,const void *,size_t); + int PerlIO_printf(PerlIO *, const char *,...); + int PerlIO_vprintf(PerlIO *, const char *, va_list); + int PerlIO_flush(PerlIO *); + + int PerlIO_eof(PerlIO *); + int PerlIO_error(PerlIO *); + void PerlIO_clearerr(PerlIO *); + + int PerlIO_getc(PerlIO *); + int PerlIO_ungetc(PerlIO *,int); + int PerlIO_read(PerlIO *,void *,size_t); + + int PerlIO_fileno(PerlIO *); + PerlIO *PerlIO_fdopen(int, const char *); + PerlIO *PerlIO_importFILE(FILE *); + FILE *PerlIO_exportFILE(PerlIO *); + FILE *PerlIO_findFILE(PerlIO *); + void PerlIO_releaseFILE(PerlIO *,FILE *); + + void PerlIO_setlinebuf(PerlIO *); + + long PerlIO_tell(PerlIO *); + int PerlIO_seek(PerlIO *,off_t,int); + int PerlIO_getpos(PerlIO *,Fpos_t *) + int PerlIO_setpos(PerlIO *,Fpos_t *) + void PerlIO_rewind(PerlIO *); + + int PerlIO_has_base(PerlIO *); + int PerlIO_has_cntptr(PerlIO *); + int PerlIO_fast_gets(PerlIO *); + int PerlIO_canset_cnt(PerlIO *); + + char *PerlIO_get_ptr(PerlIO *); + int PerlIO_get_cnt(PerlIO *); + void PerlIO_set_cnt(PerlIO *,int); + void PerlIO_set_ptrcnt(PerlIO *,char *,int); + char *PerlIO_get_base(PerlIO *); + int PerlIO_get_bufsiz(PerlIO *); + +=head1 DESCRIPTION + +Perl's source code should use the above functions instead of those +defined in ANSI C's I<stdio.h>, I<perlio.h> will the C<#define> them to +the I/O mechanism selected at Configure time. + +The functions are modeled on those in I<stdio.h>, but parameter order +has been "tidied up a little". + +=over 4 + +=item B<PerlIO *> + +This takes the place of FILE *. Unlike FILE * it should be treated as +opaque (it is probably safe to assume it is a pointer to something). + +=item B<PerlIO_stdin()>, B<PerlIO_stdout()>, B<PerlIO_stderr()> + +Use these rather than C<stdin>, C<stdout>, C<stderr>. They are written +to look like "function calls" rather than variables because this makes +it easier to I<make them> function calls if platform cannot export data +to loaded modules, or if (say) different "threads" might have different +values. + +=item B<PerlIO_open(path, mode)>, B<PerlIO_fdopen(fd,mode)> + +These correspond to fopen()/fdopen() arguments are the same. + +=item B<PerlIO_printf(f,fmt,...)>, B<PerlIO_vprintf(f,fmt,a)> + +These are is fprintf()/vfprintf equivalents. + +=item B<PerlIO_stdoutf(fmt,...)> + +This is printf() equivalent. printf is #defined to this function, +so it is (currently) legal to use printf(fmt,...) in perl sources. + +=item B<PerlIO_read(f,buf,count)>, B<PerlIO_write(f,buf,count)> + +These correspond to fread() and fwrite(). Note that arguments +are different, there is only one "count" and order has +"file" first. + +=item B<PerlIO_close(f)> + +=item B<PerlIO_puts(s,f)>, B<PerlIO_putc(c,f)> + +These correspond to fputs() and fputc(). +Note that arguments have been revised to have "file" first. + +=item B<PerlIO_ungetc(c,f)> + +This corresponds to ungetc(). +Note that arguments have been revised to have "file" first. + +=item B<PerlIO_getc(f)> + +This corresponds to getc(). + +=item B<PerlIO_eof(f)> + +This corresponds to feof(). + +=item B<PerlIO_error(f)> + +This corresponds to ferror(). + +=item B<PerlIO_fileno(f)> + +This corresponds to fileno(), note that on some platforms, +the meaning of "fileno" may not match UNIX. + +=item B<PerlIO_clearerr(f)> + +This corresponds to clearerr(), i.e. clears 'eof' and 'error' +flags for the "stream". + +=item B<PerlIO_flush(f)> + +This corresponds to fflush(). + +=item B<PerlIO_tell(f)> + +This corresponds to ftell(). + +=item B<PerlIO_seek(f,o,w)> + +This corresponds to fseek(). + +=item B<PerlIO_getpos(f,p)>, B<PerlIO_setpos(f,p)> + +These correspond to fgetpos() and fsetpos(). If platform does not +have the stdio calls then they are implemeted in terms of PerlIO_tell() +and PerlIO_seek(). + +=item B<PerlIO_rewind(f)> + +This corresponds to rewind(). Note may be redefined +in terms of PerlIO_seek() at some point. + +=item B<PerlIO_tmpfile()> + +This corresponds to tmpfile(), i.e. returns an anonymous +PerlIO which will automatically be deleted when closed. + +=back + +=head2 Co-existance with stdio + +There is outline support for co-existance of PerlIO with stdio. +Obviously if PerlIO is implemented in terms of stdio there is +no problem. However if perlio is implemented on top of (say) sfio +then mechanisms must exist to create a FILE * which can be passed +to library code which is going to use stdio calls. + +=over 4 + +=item B<PerlIO_importFILE(f,flags)> + +Used to get a PerlIO * from a FILE *. +May need additional arguments, interface under review. + +=item B<PerlIO_exportFILE(f,flags)> + +Given an PerlIO * return a 'native' FILE * suitable for +passing to code expecting to be compiled and linked with +ANSI C I<stdio.h>. + +The fact that such a FILE * has been 'exported' is recorded, +and may affect future PerlIO operations on the original +PerlIO *. + +=item B<PerlIO_findFILE(f)> + +Returns previously 'exported' FILE * (if any). +Place holder until interface is fully defined. + +=item B<PerlIO_releaseFILE(p,f)> + +Calling PerlIO_releaseFILE informs PerlIO that all use +of FILE * is complete. It is removed from list of 'exported' +FILE *s, and associated PerlIO * should revert to original +behaviour. + +=item B<PerlIO_setlinebuf(f)> + +This corresponds to setlinebuf(). Use is deprecated pending +further discussion. (Perl core I<only> uses it when "dumping" +is has nothing to do with $| auto-flush.) + +=back + +In addition to user API above there is an "implementation" interface +which allows perl to get at internals of PerlIO. +The following calls correspond to the various FILE_xxx macros determined +by Configure. This section is really only of interest to those +concerned with detailed perl-core behaviour or implementing a +PerlIO mapping. + +=over 4 + +=item B<PerlIO_has_cntptr(f)> + +Implementation can return pointer to current position in the "buffer" and +a count of bytes available in the buffer. + +=item B<PerlIO_get_ptr(f)> + +Return pointer to next readable byte in buffer. + +=item B<PerlIO_get_cnt(f)> + +Return count of readable bytes in the buffer. + +=item B<PerlIO_canset_cnt(f)> + +Implementation can adjust its idea of number of +bytes in the buffer. + +=item B<PerlIO_fast_gets(f)> + +Implementation has all the interfaces required to +allow perls fast code to handle <FILE> mechanism. + + PerlIO_fast_gets(f) = PerlIO_has_cntptr(f) && \ + PerlIO_canset_cnt(f) && \ + `Can set pointer into buffer' + +=item B<PerlIO_set_ptrcnt(f,p,c)> + +Set pointer into buffer, and a count of bytes still in the +buffer. Should only be used to set +pointer to within range implied by previous calls +to C<PerlIO_get_ptr> and C<PerlIO_get_cnt>. + +=item B<PerlIO_set_cnt(f,c)> + +Obscure - set count of bytes in the buffer. Deprecated. +Currently only used in doio.c to force count < -1 to -1. +Perhaps should be PerlIO_set_empty or similar. +This call may actually do nothing if "count" is deduced from pointer +and a "limit". + +=item B<PerlIO_has_base(f)> + +Implementation has a buffer, and can return pointer +to whole buffer and its size. Used by perl for B<-T> / B<-B> tests. +Other uses would be very obscure... + +=item B<PerlIO_get_base(f)> + +Return I<start> of buffer. + +=item B<PerlIO_get_bufsiz(f)> + +Return I<total size> of buffer. + +=back diff --git a/pod/perlobj.pod b/pod/perlobj.pod index 994edfe00e..acbd5314c8 100644 --- a/pod/perlobj.pod +++ b/pod/perlobj.pod @@ -295,11 +295,14 @@ C<can> checks to see if its object has a method called C<METHOD>, if it does then a reference to the sub is returned, if it does not then I<undef> is returned. -=item require_version ( VERSION ) +=item VERSION ( [ VERSION ] ) + +C<VERSION> returns the VERSION number of the class (package). If +an argument is given then it will check that the current version is not +less that the given argument. This method is normally called as a static +method. This method is also called when the C<VERSION> form of C<use> is +used. -C<require_version> will check that the current version of the package -is greater than C<VERSION>. This method is normally called as a static method. -This method is also called when the C<VERSION> form of C<use> is used. use A 1.2 qw(some imported subs); @@ -322,12 +325,6 @@ class, false if its object is the class (package) itself. Example $ref = bless [], 'A'; $ref->is_instance(); # True -=item require_version ( [ VERSION ] ) - -C<require_version> returns the VERSION number of the class (package). If -an argument is given then it will check that the current version is not -less that the given argument. - =back B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and @@ -570,8 +570,13 @@ PP(pp_predec) { dSP; if (SvIOK(TOPs)) { - --SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); + if (SvIVX(TOPs) == PERL_LONG_MIN) { + sv_setnv(TOPs, (double)SvIVX(TOPs) - 1.0); + } + else { + --SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); + } } else sv_dec(TOPs); @@ -584,8 +589,13 @@ PP(pp_postinc) dSP; dTARGET; sv_setsv(TARG, TOPs); if (SvIOK(TOPs)) { - ++SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); + if (SvIVX(TOPs) == PERL_LONG_MAX) { + sv_setnv(TOPs, (double)SvIVX(TOPs) + 1.0); + } + else { + ++SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); + } } else sv_inc(TOPs); @@ -601,8 +611,13 @@ PP(pp_postdec) dSP; dTARGET; sv_setsv(TARG, TOPs); if (SvIOK(TOPs)) { - --SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); + if (SvIVX(TOPs) == PERL_LONG_MIN) { + sv_setnv(TOPs, (double)SvIVX(TOPs) - 1.0); + } + else { + --SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); + } } else sv_dec(TOPs); @@ -212,9 +212,9 @@ PP(pp_formline) case FF_END: name = "END"; break; } if (arg >= 0) - fprintf(stderr, "%-16s%ld\n", name, (long) arg); + PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg); else - fprintf(stderr, "%-16s\n", name); + PerlIO_printf(PerlIO_stderr(), "%-16s\n", name); } ) switch (*fpc++) { case FF_LINEMARK: @@ -881,7 +881,7 @@ I32 cxix; while (cxstack_ix > cxix) { cx = &cxstack[cxstack_ix--]; - DEBUG_l(fprintf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1, + DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1, block_type[cx->cx_type])); /* Note: we don't need to restore the base context info till the end. */ switch (cx->cx_type) { @@ -987,7 +987,7 @@ char *message; POPBLOCK(cx,curpm); if (cx->cx_type != CXt_EVAL) { - fprintf(stderr, "panic: die %s", message); + PerlIO_printf(PerlIO_stderr(), "panic: die %s", message); my_exit(1); } POPEVAL(cx); @@ -1003,11 +1003,11 @@ char *message; return pop_return(); } } - fputs(message, stderr); - (void)Fflush(stderr); + PerlIO_printf(PerlIO_stderr(), "%s",message); + PerlIO_flush(PerlIO_stderr()); if (e_tmpname) { if (e_fp) { - fclose(e_fp); + PerlIO_close(e_fp); e_fp = Nullfp; } (void)UNLINK(e_tmpname); @@ -2064,7 +2064,7 @@ PP(pp_require) char *tmpname; SV** svp; I32 gimme = G_SCALAR; - FILE *tryrsfp = 0; + PerlIO *tryrsfp = 0; sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { @@ -2098,7 +2098,7 @@ PP(pp_require) #endif ) { - tryrsfp = fopen(tmpname,"r"); + tryrsfp = PerlIO_open(tmpname,"r"); } else { AV *ar = GvAVn(incgv); @@ -2113,7 +2113,7 @@ PP(pp_require) (void)sprintf(buf, "%s/%s", SvPVx(*av_fetch(ar, i, TRUE), na), name); #endif - tryrsfp = fopen(buf, "r"); + tryrsfp = PerlIO_open(buf, "r"); if (tryrsfp) { char *s = buf; @@ -2225,7 +2225,7 @@ PP(pp_leaveeval) I32 gimme; register CONTEXT *cx; OP *retop; - OP *saveop = op; + U8 save_flags = op -> op_flags; I32 optype; POPBLOCK(cx,newpm); @@ -2252,7 +2252,7 @@ PP(pp_leaveeval) } else { for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(TOPs) & SVs_TEMP)) + if (!(SvFLAGS(*mark) & SVs_TEMP)) *mark = sv_mortalcopy(*mark); /* in case LEAVE wipes old return values */ } @@ -2269,7 +2269,7 @@ PP(pp_leaveeval) lex_end(); LEAVE; - if (!(saveop->op_flags & OPf_SPECIAL)) + if (!(save_flags & OPf_SPECIAL)) sv_setpv(GvSV(errgv),""); RETURNOP(retop); @@ -2328,7 +2328,7 @@ PP(pp_leavetry) } else { for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))) + if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) *mark = sv_mortalcopy(*mark); /* in case LEAVE wipes old return values */ } @@ -252,8 +252,13 @@ PP(pp_preinc) { dSP; if (SvIOK(TOPs)) { - ++SvIVX(TOPs); - SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); + if (SvIVX(TOPs) == PERL_LONG_MAX) { + sv_setnv(TOPs, (double)(SvIVX(TOPs)) + 1.0 ); + } + else { + ++SvIVX(TOPs); + SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); + } } else sv_inc(TOPs); @@ -315,7 +320,7 @@ PP(pp_print) dSP; dMARK; dORIGMARK; GV *gv; IO *io; - register FILE *fp; + register PerlIO *fp; if (op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; @@ -351,7 +356,7 @@ PP(pp_print) break; MARK++; if (MARK <= SP) { - if (fwrite1(ofs, 1, ofslen, fp) == 0 || ferror(fp)) { + if (PerlIO_write(fp, ofs, ofslen) == 0 || PerlIO_error(fp)) { MARK--; break; } @@ -369,11 +374,11 @@ PP(pp_print) goto just_say_no; else { if (orslen) - if (fwrite1(ors, 1, orslen, fp) == 0 || ferror(fp)) + if (PerlIO_write(fp, ors, orslen) == 0 || PerlIO_error(fp)) goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) - if (Fflush(fp) == EOF) + if (PerlIO_flush(fp) == EOF) goto just_say_no; } } @@ -603,7 +608,6 @@ PP(pp_aassign) } break; case SVt_PVHV: { - char *tmps; SV *tmpstr; hash = (HV*)sv; @@ -616,16 +620,17 @@ PP(pp_aassign) sv = *(relem++); else sv = &sv_no, relem++; - tmps = SvPV(sv, len); tmpstr = NEWSV(29,0); if (*relem) sv_setsv(tmpstr,*relem); /* value */ *(relem++) = tmpstr; - (void)hv_store(hash,tmps,len,tmpstr,0); + (void)hv_store_ent(hash,sv,tmpstr,0); if (magic) mg_set(tmpstr); tainted = 0; } + if (relem == lastrelem) + warn("Odd number of elements in hash list"); } break; default: @@ -944,7 +949,7 @@ do_readline() register SV *sv; STRLEN tmplen = 0; STRLEN offset; - FILE *fp; + PerlIO *fp; register IO *io = GvIO(last_in_gv); register I32 type = op->op_type; @@ -984,7 +989,7 @@ do_readline() char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; char tmpfnam[L_tmpnam] = "SYS$SCRATCH:"; $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); - FILE *tmpfp; + PerlIO *tmpfp; STRLEN i; struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; @@ -1014,7 +1019,7 @@ do_readline() break; } } - if ((tmpfp = fopen(tmpfnam,"w+","fop=dlt")) != NULL) { + if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) { ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL); if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer); while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt, @@ -1032,7 +1037,7 @@ do_readline() while (*(--begin) != ']' && *begin != '>') ; ++begin; } - ok = (fputs(begin,tmpfp) != EOF); + ok = (PerlIO_puts(tmpfp,begin) != EOF); } if (cxt) (void)lib$find_file_end(&cxt); if (ok && sts != RMS$_NMF && @@ -1041,11 +1046,11 @@ do_readline() if (!(sts & 1)) { SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); } - fclose(tmpfp); + PerlIO_close(tmpfp); fp = NULL; } else { - rewind(tmpfp); + PerlIO_rewind(tmpfp); IoTYPE(io) = '<'; IoIFP(io) = fp = tmpfp; } @@ -1114,7 +1119,7 @@ do_readline() } for (;;) { if (!sv_gets(sv, fp, offset)) { - clearerr(fp); + PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { fp = nextargv(last_in_gv); if (fp) @@ -1206,24 +1211,23 @@ PP(pp_helem) { dSP; SV** svp; + HE* he; SV *keysv = POPs; - STRLEN keylen; - char *key = SvPV(keysv, keylen); HV *hv = (HV*)POPs; I32 lval = op->op_flags & OPf_MOD; if (SvTYPE(hv) != SVt_PVHV) RETPUSHUNDEF; - svp = hv_fetch(hv, key, keylen, lval); + he = hv_fetch_ent(hv, keysv, lval, 0); if (lval) { - if (!svp || *svp == &sv_undef) - DIE(no_helem, key); + if (!he || HeVAL(he) == &sv_undef) + DIE(no_helem, SvPV(keysv, na)); if (op->op_private & OPpLVAL_INTRO) - save_svref(svp); + save_svref(&HeVAL(he)); else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) - provide_ref(op, *svp); + provide_ref(op, HeVAL(he)); } - PUSHs(svp ? *svp : &sv_undef); + PUSHs(he ? HeVAL(he) : &sv_undef); RETURN; } @@ -99,7 +99,7 @@ static int dooneliner _((char *cmd, char *filename)); PP(pp_backtick) { dSP; dTARGET; - FILE *fp; + PerlIO *fp; char *tmps = POPp; TAINT_PROPER("``"); fp = my_popen(tmps, "r"); @@ -294,16 +294,16 @@ PP(pp_pipe_op) if (pipe(fd) < 0) goto badexit; - IoIFP(rstio) = fdopen(fd[0], "r"); - IoOFP(wstio) = fdopen(fd[1], "w"); + IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); + IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = '<'; IoTYPE(wstio) = '>'; if (!IoIFP(rstio) || !IoOFP(wstio)) { - if (IoIFP(rstio)) fclose(IoIFP(rstio)); + if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio)); else close(fd[0]); - if (IoOFP(wstio)) fclose(IoOFP(wstio)); + if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio)); else close(fd[1]); goto badexit; } @@ -322,13 +322,13 @@ PP(pp_fileno) dSP; dTARGET; GV *gv; IO *io; - FILE *fp; + PerlIO *fp; if (MAXARG < 1) RETPUSHUNDEF; gv = (GV*)POPs; if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) RETPUSHUNDEF; - PUSHi(fileno(fp)); + PUSHi(PerlIO_fileno(fp)); RETURN; } @@ -357,7 +357,7 @@ PP(pp_binmode) dSP; GV *gv; IO *io; - FILE *fp; + PerlIO *fp; if (MAXARG < 1) RETPUSHUNDEF; @@ -370,12 +370,12 @@ PP(pp_binmode) #ifdef DOSISH #ifdef atarist - if (!Fflush(fp) && (fp->_flag |= _IOBIN)) + if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) RETPUSHYES; else RETPUSHUNDEF; #else - if (setmode(fileno(fp), OP_BINARY) != -1) + if (setmode(PerlIO_fileno(fp), OP_BINARY) != -1) RETPUSHYES; else RETPUSHUNDEF; @@ -777,7 +777,7 @@ PP(pp_getc) RETPUSHUNDEF; TAINT_IF(1); sv_setpv(TARG, " "); - *SvPVX(TARG) = getc(IoIFP(GvIOp(gv))); /* should never be EOF */ + *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ PUSHTARG; RETURN; } @@ -856,13 +856,13 @@ PP(pp_leavewrite) dSP; GV *gv = cxstack[cxstack_ix].blk_sub.gv; register IO *io = GvIOp(gv); - FILE *ofp = IoOFP(io); - FILE *fp; + PerlIO *ofp = IoOFP(io); + PerlIO *fp; SV **newsp; I32 gimme; register CONTEXT *cx; - DEBUG_f(fprintf(Perl_debug_log,"left=%ld, todo=%ld\n", + DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n", (long)IoLINES_LEFT(io), (long)FmLINES(formtarget))); if (IoLINES_LEFT(io) < FmLINES(formtarget) && formtarget != toptarget) @@ -903,13 +903,13 @@ PP(pp_leavewrite) s++; } if (s) { - fwrite1(SvPVX(formtarget), s - SvPVX(formtarget), 1, ofp); + PerlIO_write(ofp, SvPVX(formtarget), s - SvPVX(formtarget)); sv_chop(formtarget, s); FmLINES(formtarget) -= IoLINES_LEFT(io); } } if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) - fwrite1(SvPVX(formfeed), SvCUR(formfeed), 1, ofp); + PerlIO_write(ofp, SvPVX(formfeed), SvCUR(formfeed)); IoLINES_LEFT(io) = IoPAGE_LEN(io); IoPAGE(io)++; formtarget = toptarget; @@ -946,15 +946,15 @@ PP(pp_leavewrite) if (dowarn) warn("page overflow"); } - if (!fwrite1(SvPVX(formtarget), 1, SvCUR(formtarget), ofp) || - ferror(fp)) + if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) || + PerlIO_error(fp)) PUSHs(&sv_no); else { FmLINES(formtarget) = 0; SvCUR_set(formtarget, 0); *SvEND(formtarget) = '\0'; if (IoFLAGS(io) & IOf_FLUSH) - (void)Fflush(fp); + (void)PerlIO_flush(fp); PUSHs(&sv_yes); } } @@ -968,7 +968,7 @@ PP(pp_prtf) dSP; dMARK; dORIGMARK; GV *gv; IO *io; - FILE *fp; + PerlIO *fp; SV *sv = NEWSV(0,0); if (op->op_flags & OPf_STACKED) @@ -1000,7 +1000,7 @@ PP(pp_prtf) goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) - if (Fflush(fp) == EOF) + if (PerlIO_flush(fp) == EOF) goto just_say_no; } SvREFCNT_dec(sv); @@ -1075,7 +1075,7 @@ PP(pp_sysread) if (op->op_type == OP_RECV) { bufsize = sizeof buf; buffer = SvGROW(bufsv, length+1); - length = recvfrom(fileno(IoIFP(io)), buffer, length, offset, + length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, (struct sockaddr *)buf, &bufsize); if (length < 0) RETPUSHUNDEF; @@ -1096,18 +1096,18 @@ PP(pp_sysread) #endif buffer = SvGROW(bufsv, length+offset+1); if (op->op_type == OP_SYSREAD) { - length = read(fileno(IoIFP(io)), buffer+offset, length); + length = read(PerlIO_fileno(IoIFP(io)), buffer+offset, length); } else #ifdef HAS_SOCKET__bad_code_maybe if (IoTYPE(io) == 's') { bufsize = sizeof buf; - length = recvfrom(fileno(IoIFP(io)), buffer+offset, length, 0, + length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0, (struct sockaddr *)buf, &bufsize); } else #endif - length = fread(buffer+offset, 1, length, IoIFP(io)); + length = PerlIO_read(IoIFP(io), buffer+offset, length); if (length < 0) goto say_undef; SvCUR_set(bufsv, length+offset); @@ -1167,18 +1167,18 @@ PP(pp_send) offset = 0; if (length > blen - offset) length = blen - offset; - length = write(fileno(IoIFP(io)), buffer+offset, length); + length = write(PerlIO_fileno(IoIFP(io)), buffer+offset, length); } #ifdef HAS_SOCKET else if (SP > MARK) { char *sockbuf; STRLEN mlen; sockbuf = SvPVx(*++MARK, mlen); - length = sendto(fileno(IoIFP(io)), buffer, blen, length, + length = sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length, (struct sockaddr *)sockbuf, mlen); } else - length = send(fileno(IoIFP(io)), buffer, blen, length); + length = send(PerlIO_fileno(IoIFP(io)), buffer, blen, length); #else else DIE(no_sock_func, "send"); @@ -1251,9 +1251,9 @@ PP(pp_truncate) do_ftruncate: if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || #ifdef HAS_TRUNCATE - ftruncate(fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #else - my_chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #endif result = 0; } @@ -1340,7 +1340,7 @@ PP(pp_ioctl) if (optype == OP_IOCTL) #ifdef HAS_IOCTL - retval = ioctl(fileno(IoIFP(io)), func, s); + retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s); #else DIE("ioctl is not implemented"); #endif @@ -1350,9 +1350,9 @@ PP(pp_ioctl) #else # ifdef HAS_FCNTL # if defined(OS2) && defined(__EMX__) - retval = fcntl(fileno(IoIFP(io)), func, (int)s); + retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); # else - retval = fcntl(fileno(IoIFP(io)), func, s); + retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); # endif # else DIE("fcntl is not implemented"); @@ -1384,7 +1384,7 @@ PP(pp_flock) I32 value; int argtype; GV *gv; - FILE *fp; + PerlIO *fp; #if !defined(HAS_FLOCK) && defined(HAS_LOCKF) # define flock lockf_emulate_flock @@ -1401,7 +1401,7 @@ PP(pp_flock) else fp = Nullfp; if (fp) { - value = (I32)(flock(fileno(fp), argtype) >= 0); + value = (I32)(flock(PerlIO_fileno(fp), argtype) >= 0); } else value = 0; @@ -1440,12 +1440,12 @@ PP(pp_socket) fd = socket(domain, type, protocol); if (fd < 0) RETPUSHUNDEF; - IoIFP(io) = fdopen(fd, "r"); /* stdio gets confused about sockets */ - IoOFP(io) = fdopen(fd, "w"); + IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */ + IoOFP(io) = PerlIO_fdopen(fd, "w"); IoTYPE(io) = 's'; if (!IoIFP(io) || !IoOFP(io)) { - if (IoIFP(io)) fclose(IoIFP(io)); - if (IoOFP(io)) fclose(IoOFP(io)); + if (IoIFP(io)) PerlIO_close(IoIFP(io)); + if (IoOFP(io)) PerlIO_close(IoOFP(io)); if (!IoIFP(io) && !IoOFP(io)) close(fd); RETPUSHUNDEF; } @@ -1484,18 +1484,18 @@ PP(pp_sockpair) TAINT_PROPER("socketpair"); if (socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; - IoIFP(io1) = fdopen(fd[0], "r"); - IoOFP(io1) = fdopen(fd[0], "w"); + IoIFP(io1) = PerlIO_fdopen(fd[0], "r"); + IoOFP(io1) = PerlIO_fdopen(fd[0], "w"); IoTYPE(io1) = 's'; - IoIFP(io2) = fdopen(fd[1], "r"); - IoOFP(io2) = fdopen(fd[1], "w"); + IoIFP(io2) = PerlIO_fdopen(fd[1], "r"); + IoOFP(io2) = PerlIO_fdopen(fd[1], "w"); IoTYPE(io2) = 's'; if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { - if (IoIFP(io1)) fclose(IoIFP(io1)); - if (IoOFP(io1)) fclose(IoOFP(io1)); + if (IoIFP(io1)) PerlIO_close(IoIFP(io1)); + if (IoOFP(io1)) PerlIO_close(IoOFP(io1)); if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]); - if (IoIFP(io2)) fclose(IoIFP(io2)); - if (IoOFP(io2)) fclose(IoOFP(io2)); + if (IoIFP(io2)) PerlIO_close(IoIFP(io2)); + if (IoOFP(io2)) PerlIO_close(IoOFP(io2)); if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]); RETPUSHUNDEF; } @@ -1521,7 +1521,7 @@ PP(pp_bind) addr = SvPV(addrsv, len); TAINT_PROPER("bind"); - if (bind(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) + if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; else RETPUSHUNDEF; @@ -1551,7 +1551,7 @@ PP(pp_connect) addr = SvPV(addrsv, len); TAINT_PROPER("connect"); - if (connect(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) + if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; else RETPUSHUNDEF; @@ -1577,7 +1577,7 @@ PP(pp_listen) if (!io || !IoIFP(io)) goto nuts; - if (listen(fileno(IoIFP(io)), backlog) >= 0) + if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) RETPUSHYES; else RETPUSHUNDEF; @@ -1620,15 +1620,15 @@ PP(pp_accept) if (IoIFP(nstio)) do_close(ngv, FALSE); - fd = accept(fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len); + fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len); if (fd < 0) goto badexit; - IoIFP(nstio) = fdopen(fd, "r"); - IoOFP(nstio) = fdopen(fd, "w"); + IoIFP(nstio) = PerlIO_fdopen(fd, "r"); + IoOFP(nstio) = PerlIO_fdopen(fd, "w"); IoTYPE(nstio) = 's'; if (!IoIFP(nstio) || !IoOFP(nstio)) { - if (IoIFP(nstio)) fclose(IoIFP(nstio)); - if (IoOFP(nstio)) fclose(IoOFP(nstio)); + if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); + if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio)); if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd); goto badexit; } @@ -1660,7 +1660,7 @@ PP(pp_shutdown) if (!io || !IoIFP(io)) goto nuts; - PUSHi( shutdown(fileno(IoIFP(io)), how) >= 0 ); + PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); RETURN; nuts: @@ -1707,7 +1707,7 @@ PP(pp_ssockopt) if (!io || !IoIFP(io)) goto nuts; - fd = fileno(IoIFP(io)); + fd = PerlIO_fileno(IoIFP(io)); switch (optype) { case OP_GSOCKOPT: SvGROW(sv, 257); @@ -1779,7 +1779,7 @@ PP(pp_getpeername) SvCUR_set(sv,256); *SvEND(sv) ='\0'; aint = SvCUR(sv); - fd = fileno(IoIFP(io)); + fd = PerlIO_fileno(IoIFP(io)); switch (optype) { case OP_GETSOCKNAME: if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0) @@ -1828,7 +1828,7 @@ PP(pp_stat) statgv = tmpgv; sv_setpv(statname, ""); if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || - Fstat(fileno(IoIFP(GvIOn(tmpgv))), &statcache) < 0) { + Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) < 0) { max = 0; laststatval = -1; } @@ -2176,7 +2176,7 @@ PP(pp_fttty) else gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO); if (GvIO(gv) && IoIFP(GvIOp(gv))) - fd = fileno(IoIFP(GvIOp(gv))); + fd = PerlIO_fileno(IoIFP(GvIOp(gv))); else if (isDIGIT(*tmps)) fd = atoi(tmps); else @@ -2221,25 +2221,29 @@ PP(pp_fttext) io = GvIO(statgv); } if (io && IoIFP(io)) { -#ifdef FILE_base - Fstat(fileno(IoIFP(io)), &statcache); + if (PerlIO_has_base(IoIFP(io))) { + Fstat(PerlIO_fileno(IoIFP(io)), &statcache); if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */ if (op->op_type == OP_FTTEXT) RETPUSHNO; else RETPUSHYES; - if (FILE_cnt(IoIFP(io)) <= 0) { - i = getc(IoIFP(io)); + if (PerlIO_get_cnt(IoIFP(io)) <= 0) { + i = PerlIO_getc(IoIFP(io)); if (i != EOF) - (void)ungetc(i, IoIFP(io)); + (void)PerlIO_ungetc(IoIFP(io),i); } - if (FILE_cnt(IoIFP(io)) <= 0) /* null file is anything */ + if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */ RETPUSHYES; - len = FILE_bufsiz(IoIFP(io)); - s = FILE_base(IoIFP(io)); -#else + len = PerlIO_get_bufsiz(IoIFP(io)); + s = (STDCHAR *) PerlIO_get_base(IoIFP(io)); + /* sfio can have large buffers - limit to 512 */ + if (len > 512) + len = 512; + } + else { DIE("-T and -B not implemented on filehandles"); -#endif + } } else { if (dowarn) @@ -2473,7 +2477,7 @@ char *filename; char *s, *save_filename = filename; int anum = 1; - FILE *myfp; + PerlIO *myfp; strcpy(mybuf, cmd); strcat(mybuf, " "); @@ -2485,7 +2489,8 @@ char *filename; myfp = my_popen(mybuf, "r"); if (myfp) { *mybuf = '\0'; - s = fgets(mybuf, sizeof mybuf, myfp); + /* Need to save/restore 'rs' ?? */ + s = sv_gets(tmpsv, myfp, 0); (void)my_pclose(myfp); if (s != Nullch) { for (errno = 1; errno < sys_nerr; errno++) { @@ -46,6 +46,7 @@ char* cpytill _((char* to, char* from, char* fromend, int delim, I32* retlen)); void croak _((char* pat,...)) __attribute__((format(printf,1,2),noreturn)); CV* cv_clone _((CV* proto)); void cv_undef _((CV* cv)); +SV* cv_const_sv _((CV* cv)); #ifdef DEBUGGING void cx_dump _((CONTEXT* cs)); #endif @@ -82,9 +83,9 @@ I32 do_msgrcv _((SV** mark, SV** sp)); I32 do_msgsnd _((SV** mark, SV** sp)); #endif bool do_open _((GV* gv, char* name, I32 len, - int as_raw, int rawmode, int rawperm, FILE* supplied_fp)); + int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp)); void do_pipe _((SV* sv, GV* rgv, GV* wgv)); -bool do_print _((SV* sv, FILE* fp)); +bool do_print _((SV* sv, PerlIO* fp)); OP * do_readline _((void)); I32 do_chomp _((SV* sv)); bool do_seek _((GV* gv, long pos, int whence)); @@ -235,8 +236,8 @@ I32 my_lstat _((void)); #ifndef HAS_MEMCMP I32 my_memcmp _((unsigned char* s1, unsigned char* s2, I32 len)); #endif -I32 my_pclose _((FILE* ptr)); -FILE* my_popen _((char* cmd, char* mode)); +I32 my_pclose _((PerlIO* ptr)); +PerlIO* my_popen _((char* cmd, char* mode)); void my_setenv _((char* nam, char* val)); I32 my_stat _((void)); #ifdef MYSWAP @@ -294,7 +295,7 @@ SV* newSVrv _((SV* rv, char* classname)); SV* newSVsv _((SV* old)); OP* newUNOP _((I32 type, I32 flags, OP* first)); OP * newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, OP* expr, OP* block, OP* cont)); -FILE* nextargv _((GV* gv)); +PerlIO* nextargv _((GV* gv)); char* ninstr _((char* big, char* bigend, char* little, char* lend)); OP * oopsCV _((OP* o)); void op_free _((OP* arg)); @@ -435,7 +436,7 @@ void sv_dump _((SV* sv)); I32 sv_eq _((SV* sv1, SV* sv2)); void sv_free _((SV* sv)); void sv_free_arenas _((void)); -char* sv_gets _((SV* sv, FILE* fp, I32 append)); +char* sv_gets _((SV* sv, PerlIO* fp, I32 append)); #ifndef DOSISH char* sv_grow _((SV* sv, I32 newlen)); #else @@ -244,7 +244,7 @@ PMOP* pm; if (sawplus && (!sawopen || !regsawback)) r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */ - DEBUG_r(fprintf(Perl_debug_log,"first %d next %d offset %d\n", + DEBUG_r(PerlIO_printf(Perl_debug_log, "first %d next %d offset %d\n", OP(first), OP(NEXTOPER(first)), first - scan)); /* * If there's something expensive in the r.e., find the @@ -1450,13 +1450,13 @@ regexp *r; s++; #endif op = OP(s); - fprintf(Perl_debug_log,"%2d%s", s-r->program, regprop(s)); /* Where, what. */ + PerlIO_printf(Perl_debug_log, "%2d%s", s-r->program, regprop(s)); /* Where, what. */ next = regnext(s); s += regarglen[(U8)op]; if (next == NULL) /* Next ptr. */ - fprintf(Perl_debug_log,"(0)"); + PerlIO_printf(Perl_debug_log, "(0)"); else - fprintf(Perl_debug_log,"(%d)", (s-r->program)+(next-s)); + PerlIO_printf(Perl_debug_log, "(%d)", (s-r->program)+(next-s)); s += 3; if (op == ANYOF) { s += 32; @@ -1464,34 +1464,34 @@ regexp *r; if (op == EXACTLY) { /* Literal string, where present. */ s++; - (void)putc(' ', Perl_debug_log); - (void)putc('<', Perl_debug_log); + (void)PerlIO_putc(Perl_debug_log, ' '); + (void)PerlIO_putc(Perl_debug_log, '<'); while (*s != '\0') { - (void)putc(*s, Perl_debug_log); + (void)PerlIO_putc(Perl_debug_log,*s); s++; } - (void)putc('>', Perl_debug_log); + (void)PerlIO_putc(Perl_debug_log, '>'); s++; } - (void)putc('\n', Perl_debug_log); + (void)PerlIO_putc(Perl_debug_log, '\n'); } /* Header fields of interest. */ if (r->regstart) - fprintf(Perl_debug_log,"start `%s' ", SvPVX(r->regstart)); + PerlIO_printf(Perl_debug_log, "start `%s' ", SvPVX(r->regstart)); if (r->regstclass) - fprintf(Perl_debug_log,"stclass `%s' ", regprop(r->regstclass)); + PerlIO_printf(Perl_debug_log, "stclass `%s' ", regprop(r->regstclass)); if (r->reganch & ROPT_ANCH) - fprintf(Perl_debug_log,"anchored "); + PerlIO_printf(Perl_debug_log, "anchored "); if (r->reganch & ROPT_SKIP) - fprintf(Perl_debug_log,"plus "); + PerlIO_printf(Perl_debug_log, "plus "); if (r->reganch & ROPT_IMPLICIT) - fprintf(Perl_debug_log,"implicit "); + PerlIO_printf(Perl_debug_log, "implicit "); if (r->regmust != NULL) - fprintf(Perl_debug_log,"must have \"%s\" back %ld ", SvPVX(r->regmust), + PerlIO_printf(Perl_debug_log, "must have \"%s\" back %ld ", SvPVX(r->regmust), (long) r->regback); - fprintf(Perl_debug_log, "minlen %ld ", (long) r->minlen); - fprintf(Perl_debug_log,"\n"); + PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen); + PerlIO_printf(Perl_debug_log, "\n"); } /* @@ -590,7 +590,7 @@ char *prog; #define sayNO goto no #define saySAME(x) if (x) goto yes; else goto no if (regnarrate) { - fprintf(Perl_debug_log, "%*s%2d%-8.8s\t<%.10s>\n", regindent*2, "", + PerlIO_printf(Perl_debug_log, "%*s%2d%-8.8s\t<%.10s>\n", regindent*2, "", scan - regprogram, regprop(scan), locinput); } #else @@ -806,7 +806,7 @@ char *prog; #ifdef DEBUGGING if (regnarrate) - fprintf(Perl_debug_log, "%*s %d %lx\n", regindent*2, "", + PerlIO_printf(Perl_debug_log, "%*s %d %lx\n", regindent*2, "", n, (long)cc); #endif @@ -986,7 +986,7 @@ char *prog; sayNO; break; default: - fprintf(stderr, "%x %d\n",(unsigned)scan,scan[1]); + PerlIO_printf(PerlIO_stderr(), "%x %d\n",(unsigned)scan,scan[1]); FAIL("regexp memory corruption"); } scan = next; @@ -47,7 +47,7 @@ runops() { do { if (debug) { if (watchaddr != 0 && *watchaddr != watchok) - fprintf(Perl_debug_log, "WARNING: %lx changed from %lx to %lx\n", + PerlIO_printf(Perl_debug_log, "WARNING: %lx changed from %lx to %lx\n", (long)watchaddr, (long)watchok, (long)*watchaddr); DEBUG_s(debstack()); DEBUG_t(debop(op)); @@ -65,23 +65,23 @@ OP *op; deb("%s", op_name[op->op_type]); switch (op->op_type) { case OP_CONST: - fprintf(Perl_debug_log, "(%s)", SvPEEK(cSVOP->op_sv)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOP->op_sv)); break; case OP_GVSV: case OP_GV: if (cGVOP->op_gv) { sv = NEWSV(0,0); gv_fullname(sv, cGVOP->op_gv); - fprintf(Perl_debug_log, "(%s)", SvPV(sv, na)); + PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, na)); SvREFCNT_dec(sv); } else - fprintf(Perl_debug_log, "(NULL)"); + PerlIO_printf(Perl_debug_log, "(NULL)"); break; default: break; } - fprintf(Perl_debug_log, "\n"); + PerlIO_printf(Perl_debug_log, "\n"); return 0; } @@ -91,7 +91,7 @@ char **addr; { watchaddr = addr; watchok = *addr; - fprintf(Perl_debug_log, "WATCHING, %lx is currently %lx\n", + PerlIO_printf(Perl_debug_log, "WATCHING, %lx is currently %lx\n", (long)watchaddr, (long)watchok); } @@ -112,7 +112,7 @@ debprofdump() return; for (i = 0; i < MAXO; i++) { if (profiledata[i]) - fprintf(Perl_debug_log, "%d\t%lu\n", i, profiledata[i]); + PerlIO_printf(Perl_debug_log, "%d\t%lu\n", i, profiledata[i]); } } @@ -613,88 +613,88 @@ void cx_dump(cx) CONTEXT* cx; { - fprintf(Perl_debug_log, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]); + PerlIO_printf(Perl_debug_log, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]); if (cx->cx_type != CXt_SUBST) { - fprintf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); - fprintf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop); - fprintf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); - fprintf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp); - fprintf(Perl_debug_log, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp); - fprintf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm); - fprintf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR"); + PerlIO_printf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp); + PerlIO_printf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop); + PerlIO_printf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp); + PerlIO_printf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp); + PerlIO_printf(Perl_debug_log, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp); + PerlIO_printf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm); + PerlIO_printf(Perl_debug_log, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR"); } switch (cx->cx_type) { case CXt_NULL: case CXt_BLOCK: break; case CXt_SUB: - fprintf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n", (long)cx->blk_sub.cv); - fprintf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n", (long)cx->blk_sub.gv); - fprintf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n", (long)cx->blk_sub.dfoutgv); - fprintf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", + PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", (long)cx->blk_sub.olddepth); - fprintf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", + PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", (int)cx->blk_sub.hasargs); break; case CXt_EVAL: - fprintf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", + PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", (long)cx->blk_eval.old_in_eval); - fprintf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n", + PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n", op_name[cx->blk_eval.old_op_type], op_desc[cx->blk_eval.old_op_type]); - fprintf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", + PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", cx->blk_eval.old_name); - fprintf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n", (long)cx->blk_eval.old_eval_root); break; case CXt_LOOP: - fprintf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", + PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", cx->blk_loop.label); - fprintf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n", + PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n", (long)cx->blk_loop.resetsp); - fprintf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%lx\n", (long)cx->blk_loop.redo_op); - fprintf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%lx\n", (long)cx->blk_loop.next_op); - fprintf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%lx\n", (long)cx->blk_loop.last_op); - fprintf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n", + PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n", (long)cx->blk_loop.iterix); - fprintf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n", (long)cx->blk_loop.iterary); - fprintf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%lx\n", (long)cx->blk_loop.itervar); if (cx->blk_loop.itervar) - fprintf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n", (long)cx->blk_loop.itersave); break; case CXt_SUBST: - fprintf(Perl_debug_log, "SB_ITERS = %ld\n", + PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n", (long)cx->sb_iters); - fprintf(Perl_debug_log, "SB_MAXITERS = %ld\n", + PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n", (long)cx->sb_maxiters); - fprintf(Perl_debug_log, "SB_SAFEBASE = %ld\n", + PerlIO_printf(Perl_debug_log, "SB_SAFEBASE = %ld\n", (long)cx->sb_safebase); - fprintf(Perl_debug_log, "SB_ONCE = %ld\n", + PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n", (long)cx->sb_once); - fprintf(Perl_debug_log, "SB_ORIG = %s\n", + PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n", cx->sb_orig); - fprintf(Perl_debug_log, "SB_DSTR = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%lx\n", (long)cx->sb_dstr); - fprintf(Perl_debug_log, "SB_TARG = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%lx\n", (long)cx->sb_targ); - fprintf(Perl_debug_log, "SB_S = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "SB_S = 0x%lx\n", (long)cx->sb_s); - fprintf(Perl_debug_log, "SB_M = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "SB_M = 0x%lx\n", (long)cx->sb_m); - fprintf(Perl_debug_log, "SB_STREND = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%lx\n", (long)cx->sb_strend); - fprintf(Perl_debug_log, "SB_SUBBASE = 0x%lx\n", + PerlIO_printf(Perl_debug_log, "SB_SUBBASE = 0x%lx\n", (long)cx->sb_subbase); break; } @@ -198,7 +198,7 @@ sv_report_used() svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { - fprintf(stderr, "****\n"); + PerlIO_printf(PerlIO_stderr(), "****\n"); sv_dump(sv); } ++sv; @@ -223,7 +223,7 @@ sv_clean_objs() if (SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) && SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "), + DEBUG_D((PerlIO_printf(PerlIO_stderr(), "Cleaning object ref:\n "), sv_dump(sv));) SvROK_off(sv); SvRV(sv) = 0; @@ -240,7 +240,7 @@ sv_clean_objs() svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "), + DEBUG_D((PerlIO_printf(PerlIO_stderr(), "Cleaning object ref:\n "), sv_dump(sv));) SvROK_off(sv); SvRV(sv) = 0; @@ -267,7 +267,7 @@ sv_clean_all() svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { - DEBUG_D((fprintf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); } @@ -971,7 +971,7 @@ unsigned long newlen; #ifdef MSDOS if (newlen >= 0x10000) { - fprintf(stderr, "Allocation too large: %lx\n", newlen); + PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", newlen); my_exit(1); } #endif /* MSDOS */ @@ -1208,7 +1208,7 @@ register SV *sv; return 0; } (void)SvIOK_on(sv); - DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2iv(%ld)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", (unsigned long)sv,(long)SvIVX(sv))); return SvIVX(sv); } @@ -1261,7 +1261,7 @@ register SV *sv; sv_upgrade(sv, SVt_PVNV); else sv_upgrade(sv, SVt_NV); - DEBUG_c(fprintf(Perl_debug_log,"0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv))); } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); @@ -1281,7 +1281,7 @@ register SV *sv; return 0.0; } SvNOK_on(sv); - DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); return SvNVX(sv); } @@ -1416,7 +1416,7 @@ STRLEN *lp; *lp = s - SvPVX(sv); SvCUR_set(sv, *lp); SvPOK_on(sv); - DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv))); return SvPVX(sv); tokensave: @@ -1713,6 +1713,7 @@ register SV *sstr; return; } if (SvPVX(dstr)) { + (void)SvOOK_off(dstr); /* backoff */ Safefree(SvPVX(dstr)); SvLEN(dstr)=SvCUR(dstr)=0; } @@ -2571,7 +2572,7 @@ register SV *str2; char * sv_gets(sv,fp,append) register SV *sv; -register FILE *fp; +register PerlIO *fp; I32 append; { char *rsptr; @@ -2581,16 +2582,6 @@ I32 append; register I32 cnt; I32 i; -#ifdef FAST_SV_GETS - /* - * We're going to steal some values from the stdio struct - * and put EVERYTHING in the innermost loop into registers. - */ - register STDCHAR *ptr; - STRLEN bpx; - I32 shortbuffered; -#endif - if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv) && curcop != &compiling) croak(no_modify); @@ -2614,23 +2605,40 @@ I32 append; if (RsPARA(rs)) { /* have to do this both before and after */ do { /* to make sure file boundaries work right */ - if (feof(fp)) + if (PerlIO_eof(fp)) return 0; - i = getc(fp); + i = PerlIO_getc(fp); if (i != '\n') { if (i == -1) return 0; - ungetc(i,fp); + PerlIO_ungetc(fp,i); break; } } while (i != EOF); } -#ifdef FAST_SV_GETS + /* See if we know enough about I/O mechanism to cheat it ! */ + + /* This used to be #ifdef test - it is made run-time test for ease + of abstracting out stdio interface. One call should be cheap + enough here - and may even be a macro allowing compile + time optimization. + */ + + if (PerlIO_fast_gets(fp)) { + + /* + * We're going to steal some values from the stdio struct + * and put EVERYTHING in the innermost loop into registers. + */ + register STDCHAR *ptr; + STRLEN bpx; + I32 shortbuffered; + /* Here is some breathtakingly efficient cheating */ - cnt = FILE_cnt(fp); /* get count into register */ + cnt = PerlIO_get_cnt(fp); /* get count into register */ (void)SvPOK_only(sv); /* validate pointer */ if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */ if (cnt > 80 && SvLEN(sv) > append) { @@ -2645,12 +2653,13 @@ I32 append; else shortbuffered = 0; bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ - ptr = FILE_ptr(fp); + ptr = (STDCHAR*)PerlIO_get_ptr(fp); for (;;) { screamer: if (cnt > 0) { if (rslen) { - while (--cnt >= 0) { /* this | eat */ + while (cnt > 0) { /* this | eat */ + cnt--; if ((*bp++ = *ptr++) == rslast) /* really | dust */ goto thats_all_folks; /* screams | sed :-) */ } @@ -2673,11 +2682,14 @@ I32 append; continue; } - FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */ - FILE_ptr(fp) = ptr; - i = _filbuf(fp); /* get more characters */ - cnt = FILE_cnt(fp); - ptr = FILE_ptr(fp); /* reregisterize cnt and ptr */ + PerlIO_set_ptrcnt(fp,(char *) ptr, cnt); /* deregisterize cnt and ptr */ + /* This used to call 'filbuf' in stdio form, but as that behaves like getc + when cnt <= 0 we use PerlIO_getc here to avoid another abstraction. + This may also avoid issues with different named 'filbuf' equivalents + */ + i = PerlIO_getc(fp); /* get more characters */ + cnt = PerlIO_get_cnt(fp); + ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ if (i == EOF) /* all done for ever? */ goto thats_really_all_folks; @@ -2687,7 +2699,7 @@ I32 append; SvGROW(sv, bpx + cnt + 2); bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ - *bp++ = i; /* store character from _filbuf */ + *bp++ = i; /* store character from PerlIO_getc */ if (rslen && (STDCHAR)i == rslast) /* all done for now? */ goto thats_all_folks; @@ -2696,45 +2708,36 @@ I32 append; thats_all_folks: if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || bcmp((char*)bp - rslen, rsptr, rslen)) - goto screamer; /* go back to the fray */ + goto screamer; /* go back to the fray */ thats_really_all_folks: if (shortbuffered) cnt += shortbuffered; - FILE_cnt(fp) = cnt; /* put these back or we're in trouble */ - FILE_ptr(fp) = ptr; + PerlIO_set_ptrcnt(fp,(char *) ptr, cnt); /* put these back or we're in trouble */ *bp = '\0'; - SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ - -#else /* SV_FAST_GETS */ - - /*The big, slow, and stupid way */ - + SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ + } + else { + /*The big, slow, and stupid way */ STDCHAR buf[8192]; -screamer: +screamer2: if (rslen) { - if (rslast == '\n') { - i = fgets(buf,sizeof buf,fp) == NULL ? EOF : *buf; - cnt = i == EOF ? 0 : strlen(buf); - } - else { - register STDCHAR *bpe = buf + sizeof(buf); - bp = buf; - while ((i = getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe) - ; /* keep reading */ - cnt = bp - buf; - } + register STDCHAR *bpe = buf + sizeof(buf); + bp = buf; + while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe) + ; /* keep reading */ + cnt = bp - buf; } else { - cnt = fread((char*)buf, 1, sizeof(buf), fp); - i = cnt ? !EOF : EOF; + cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); + i = cnt ? (U8)buf[cnt - 1] : EOF; } if (append) - sv_catpvn(sv, buf, cnt); + sv_catpvn(sv, (char *) buf, cnt); else - sv_setpvn(sv, buf, cnt); + sv_setpvn(sv, (char *) buf, cnt); if (i != EOF && /* joy */ (!rslen || @@ -2742,17 +2745,15 @@ screamer: bcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) { append = -1; - goto screamer; + goto screamer2; } } -#endif /* SV_FAST_GETS */ - if (RsPARA(rs)) { /* have to do this both before and after */ while (i != EOF) { /* to make sure file boundaries work right */ - i = getc(fp); + i = PerlIO_getc(fp); if (i != '\n') { - ungetc(i,fp); + PerlIO_ungetc(fp,i); break; } } @@ -2761,6 +2762,7 @@ screamer: return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } + void sv_inc(sv) register SV *sv; @@ -3265,7 +3267,7 @@ STRLEN *lp; if (!SvPOK(sv)) { SvPOK_on(sv); /* validate pointer */ SvTAINT(sv); - DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2pv(%s)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n", (unsigned long)sv,SvPVX(sv))); } } @@ -3467,7 +3469,7 @@ SV* sv; U32 type; if (!sv) { - fprintf(Perl_debug_log, "SV = 0\n"); + PerlIO_printf(Perl_debug_log, "SV = 0\n"); return; } @@ -3523,66 +3525,66 @@ SV* sv; *d++ = ')'; *d = '\0'; - fprintf(Perl_debug_log, "SV = "); + PerlIO_printf(Perl_debug_log, "SV = "); switch (type) { case SVt_NULL: - fprintf(Perl_debug_log,"NULL%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "NULL%s\n", tmpbuf); return; case SVt_IV: - fprintf(Perl_debug_log,"IV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "IV%s\n", tmpbuf); break; case SVt_NV: - fprintf(Perl_debug_log,"NV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "NV%s\n", tmpbuf); break; case SVt_RV: - fprintf(Perl_debug_log,"RV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "RV%s\n", tmpbuf); break; case SVt_PV: - fprintf(Perl_debug_log,"PV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PV%s\n", tmpbuf); break; case SVt_PVIV: - fprintf(Perl_debug_log,"PVIV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVIV%s\n", tmpbuf); break; case SVt_PVNV: - fprintf(Perl_debug_log,"PVNV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVNV%s\n", tmpbuf); break; case SVt_PVBM: - fprintf(Perl_debug_log,"PVBM%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVBM%s\n", tmpbuf); break; case SVt_PVMG: - fprintf(Perl_debug_log,"PVMG%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVMG%s\n", tmpbuf); break; case SVt_PVLV: - fprintf(Perl_debug_log,"PVLV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVLV%s\n", tmpbuf); break; case SVt_PVAV: - fprintf(Perl_debug_log,"PVAV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVAV%s\n", tmpbuf); break; case SVt_PVHV: - fprintf(Perl_debug_log,"PVHV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVHV%s\n", tmpbuf); break; case SVt_PVCV: - fprintf(Perl_debug_log,"PVCV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVCV%s\n", tmpbuf); break; case SVt_PVGV: - fprintf(Perl_debug_log,"PVGV%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVGV%s\n", tmpbuf); break; case SVt_PVFM: - fprintf(Perl_debug_log,"PVFM%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVFM%s\n", tmpbuf); break; case SVt_PVIO: - fprintf(Perl_debug_log,"PVIO%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "PVIO%s\n", tmpbuf); break; default: - fprintf(Perl_debug_log,"UNKNOWN%s\n", tmpbuf); + PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", tmpbuf); return; } if (type >= SVt_PVIV || type == SVt_IV) - fprintf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv)); + PerlIO_printf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv)); if (type >= SVt_PVNV || type == SVt_NV) - fprintf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); + PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); if (SvROK(sv)) { - fprintf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv)); + PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv)); sv_dump(SvRV(sv)); return; } @@ -3590,32 +3592,32 @@ SV* sv; return; if (type <= SVt_PVLV) { if (SvPVX(sv)) - fprintf(Perl_debug_log, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n", + PerlIO_printf(Perl_debug_log, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n", (long)SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv)); else - fprintf(Perl_debug_log, " PV = 0\n"); + PerlIO_printf(Perl_debug_log, " PV = 0\n"); } if (type >= SVt_PVMG) { if (SvMAGIC(sv)) { - fprintf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv)); + PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv)); } if (SvSTASH(sv)) - fprintf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv))); } switch (type) { case SVt_PVLV: - fprintf(Perl_debug_log, " TYPE = %c\n", LvTYPE(sv)); - fprintf(Perl_debug_log, " TARGOFF = %ld\n", (long)LvTARGOFF(sv)); - fprintf(Perl_debug_log, " TARGLEN = %ld\n", (long)LvTARGLEN(sv)); - fprintf(Perl_debug_log, " TARG = 0x%lx\n", (long)LvTARG(sv)); + PerlIO_printf(Perl_debug_log, " TYPE = %c\n", LvTYPE(sv)); + PerlIO_printf(Perl_debug_log, " TARGOFF = %ld\n", (long)LvTARGOFF(sv)); + PerlIO_printf(Perl_debug_log, " TARGLEN = %ld\n", (long)LvTARGLEN(sv)); + PerlIO_printf(Perl_debug_log, " TARG = 0x%lx\n", (long)LvTARG(sv)); sv_dump(LvTARG(sv)); break; case SVt_PVAV: - fprintf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv)); - fprintf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv)); - fprintf(Perl_debug_log, " FILL = %ld\n", (long)AvFILL(sv)); - fprintf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv)); - fprintf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv)); + PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv)); + PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv)); + PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILL(sv)); + PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv)); + PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv)); flags = AvFLAGS(sv); d = tmpbuf; *d = '\0'; @@ -3624,78 +3626,78 @@ SV* sv; if (flags & AVf_REUSED) strcat(d, "REUSED,"); if (*d) d[strlen(d)-1] = '\0'; - fprintf(Perl_debug_log, " FLAGS = (%s)\n", d); + PerlIO_printf(Perl_debug_log, " FLAGS = (%s)\n", d); break; case SVt_PVHV: - fprintf(Perl_debug_log, " ARRAY = 0x%lx\n",(long)HvARRAY(sv)); - fprintf(Perl_debug_log, " KEYS = %ld\n", (long)HvKEYS(sv)); - fprintf(Perl_debug_log, " FILL = %ld\n", (long)HvFILL(sv)); - fprintf(Perl_debug_log, " MAX = %ld\n", (long)HvMAX(sv)); - fprintf(Perl_debug_log, " RITER = %ld\n", (long)HvRITER(sv)); - fprintf(Perl_debug_log, " EITER = 0x%lx\n",(long) HvEITER(sv)); + PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n",(long)HvARRAY(sv)); + PerlIO_printf(Perl_debug_log, " KEYS = %ld\n", (long)HvKEYS(sv)); + PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)HvFILL(sv)); + PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)HvMAX(sv)); + PerlIO_printf(Perl_debug_log, " RITER = %ld\n", (long)HvRITER(sv)); + PerlIO_printf(Perl_debug_log, " EITER = 0x%lx\n",(long) HvEITER(sv)); if (HvPMROOT(sv)) - fprintf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv)); + PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv)); if (HvNAME(sv)) - fprintf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv)); + PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv)); break; case SVt_PVFM: case SVt_PVCV: if (SvPOK(sv)) - fprintf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na)); - fprintf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv)); - fprintf(Perl_debug_log, " START = 0x%lx\n", (long)CvSTART(sv)); - fprintf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv)); - fprintf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv)); - fprintf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32); - fprintf(stderr, " GV = 0x%lx", (long)CvGV(sv)); + PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na)); + PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv)); + PerlIO_printf(Perl_debug_log, " START = 0x%lx\n", (long)CvSTART(sv)); + PerlIO_printf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv)); + PerlIO_printf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv)); + PerlIO_printf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32); + PerlIO_printf(PerlIO_stderr(), " GV = 0x%lx", (long)CvGV(sv)); if (CvGV(sv) && GvNAME(CvGV(sv))) { - fprintf(stderr, " \"%s\"\n", GvNAME(CvGV(sv))); + PerlIO_printf(PerlIO_stderr(), " \"%s\"\n", GvNAME(CvGV(sv))); } else { - fprintf(stderr, "\n"); + PerlIO_printf(PerlIO_stderr(), "\n"); } - fprintf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv)); - fprintf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv)); - fprintf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv)); - fprintf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv)); + PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv)); + PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv)); + PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv)); + PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv)); if (type == SVt_PVFM) - fprintf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv)); + PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv)); break; case SVt_PVGV: - fprintf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv)); - fprintf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv)); - fprintf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); - fprintf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv)); - fprintf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv)); - fprintf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv)); - fprintf(Perl_debug_log, " IO = 0x%lx\n", (long)GvIOp(sv)); - fprintf(Perl_debug_log, " FORM = 0x%lx\n", (long)GvFORM(sv)); - fprintf(Perl_debug_log, " AV = 0x%lx\n", (long)GvAV(sv)); - fprintf(Perl_debug_log, " HV = 0x%lx\n", (long)GvHV(sv)); - fprintf(Perl_debug_log, " CV = 0x%lx\n", (long)GvCV(sv)); - fprintf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv)); - fprintf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv)); - fprintf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv)); - fprintf(Perl_debug_log, " FLAGS = 0x%x\n", (int)GvFLAGS(sv)); - fprintf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); - fprintf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv)); + PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv)); + PerlIO_printf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv)); + PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv)); + PerlIO_printf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv)); + PerlIO_printf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv)); + PerlIO_printf(Perl_debug_log, " IO = 0x%lx\n", (long)GvIOp(sv)); + PerlIO_printf(Perl_debug_log, " FORM = 0x%lx\n", (long)GvFORM(sv)); + PerlIO_printf(Perl_debug_log, " AV = 0x%lx\n", (long)GvAV(sv)); + PerlIO_printf(Perl_debug_log, " HV = 0x%lx\n", (long)GvHV(sv)); + PerlIO_printf(Perl_debug_log, " CV = 0x%lx\n", (long)GvCV(sv)); + PerlIO_printf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv)); + PerlIO_printf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv)); + PerlIO_printf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv)); + PerlIO_printf(Perl_debug_log, " FLAGS = 0x%x\n", (int)GvFLAGS(sv)); + PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv)); break; case SVt_PVIO: - fprintf(Perl_debug_log, " IFP = 0x%lx\n", (long)IoIFP(sv)); - fprintf(Perl_debug_log, " OFP = 0x%lx\n", (long)IoOFP(sv)); - fprintf(Perl_debug_log, " DIRP = 0x%lx\n", (long)IoDIRP(sv)); - fprintf(Perl_debug_log, " LINES = %ld\n", (long)IoLINES(sv)); - fprintf(Perl_debug_log, " PAGE = %ld\n", (long)IoPAGE(sv)); - fprintf(Perl_debug_log, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv)); - fprintf(Perl_debug_log, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv)); - fprintf(Perl_debug_log, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); - fprintf(Perl_debug_log, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv)); - fprintf(Perl_debug_log, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); - fprintf(Perl_debug_log, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv)); - fprintf(Perl_debug_log, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); - fprintf(Perl_debug_log, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv)); - fprintf(Perl_debug_log, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv)); - fprintf(Perl_debug_log, " TYPE = %c\n", IoTYPE(sv)); - fprintf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); + PerlIO_printf(Perl_debug_log, " IFP = 0x%lx\n", (long)IoIFP(sv)); + PerlIO_printf(Perl_debug_log, " OFP = 0x%lx\n", (long)IoOFP(sv)); + PerlIO_printf(Perl_debug_log, " DIRP = 0x%lx\n", (long)IoDIRP(sv)); + PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)IoLINES(sv)); + PerlIO_printf(Perl_debug_log, " PAGE = %ld\n", (long)IoPAGE(sv)); + PerlIO_printf(Perl_debug_log, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv)); + PerlIO_printf(Perl_debug_log, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv)); + PerlIO_printf(Perl_debug_log, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); + PerlIO_printf(Perl_debug_log, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv)); + PerlIO_printf(Perl_debug_log, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); + PerlIO_printf(Perl_debug_log, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv)); + PerlIO_printf(Perl_debug_log, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); + PerlIO_printf(Perl_debug_log, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv)); + PerlIO_printf(Perl_debug_log, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv)); + PerlIO_printf(Perl_debug_log, " TYPE = %c\n", IoTYPE(sv)); + PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); break; } } @@ -247,8 +247,8 @@ struct xpvio { MAGIC* xmg_magic; /* linked list of magicalness */ HV* xmg_stash; /* class package */ - FILE * xio_ifp; /* ifp and ofp are normally the same */ - FILE * xio_ofp; /* but sockets need separate streams */ + PerlIO * xio_ifp; /* ifp and ofp are normally the same */ + PerlIO * xio_ofp; /* but sockets need separate streams */ DIR * xio_dirp; /* for opendir, readdir, etc */ long xio_lines; /* $. */ long xio_page; /* $% */ diff --git a/t/comp/redef.t b/t/comp/redef.t new file mode 100644 index 0000000000..6a73ae1c2e --- /dev/null +++ b/t/comp/redef.t @@ -0,0 +1,79 @@ +#!./perl +# +# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> + +BEGIN { + $^W = 1; + $warn = ""; + $SIG{__WARN__} = sub { $warn .= join("",@_) } +} + +sub ok ($$) { + print $_[1] ? "ok " : "not ok ", $_[0], "\n"; +} + +print "1..18\n"; + +sub sub0 { 1 } +sub sub0 { 2 } + +ok 1, $warn =~ s/Subroutine sub0 redefined[^\n]+\n//s; + +sub sub1 { 1 } +sub sub1 () { 2 } + +ok 2, $warn =~ s/Prototype mismatch: \Q(none) vs ()\E[^\n]+\n//s; +ok 3, $warn =~ s/Subroutine sub1 redefined[^\n]+\n//s; + +sub sub2 { 1 } +sub sub2 ($) { 2 } + +ok 4, $warn =~ s/Prototype mismatch: \Q(none) vs ($)\E[^\n]+\n//s; +ok 5, $warn =~ s/Subroutine sub2 redefined[^\n]+\n//s; + +sub sub3 () { 1 } +sub sub3 { 2 } + +ok 6, $warn =~ s/Prototype mismatch: \Q() vs (none)\E[^\n]+\n//s; +ok 7, $warn =~ s/Constant subroutine sub3 redefined[^\n]+\n//s; + +sub sub4 () { 1 } +sub sub4 () { 2 } + +ok 8, $warn =~ s/Constant subroutine sub4 redefined[^\n]+\n//s; + +sub sub5 () { 1 } +sub sub5 ($) { 2 } + +ok 9, $warn =~ s/Prototype mismatch: \Q() vs ($)\E[^\n]+\n//s; +ok 10, $warn =~ s/Constant subroutine sub5 redefined[^\n]+\n//s; + +sub sub6 ($) { 1 } +sub sub6 { 2 } + +ok 11, $warn =~ s/Prototype mismatch: \Q($) vs (none)\E[^\n]+\n//s; +ok 12, $warn =~ s/Subroutine sub6 redefined[^\n]+\n//s; + +sub sub7 ($) { 1 } +sub sub7 () { 2 } + +ok 13, $warn =~ s/Prototype mismatch: \Q($) vs ()\E[^\n]+\n//s; +ok 14, $warn =~ s/Subroutine sub7 redefined[^\n]+\n//s; + +sub sub8 ($) { 1 } +sub sub8 ($) { 2 } + +ok 15, $warn =~ s/Subroutine sub8 redefined[^\n]+\n//s; + +sub sub9 ($@) { 1 } +sub sub9 ($) { 2 } + +ok 16, $warn =~ s/Prototype mismatch: \(\$\Q@) vs ($)\E[^\n]+\n//s; +ok 17, $warn =~ s/Subroutine sub9 redefined[^\n]+\n//s; + +ok 18, $_ eq ''; + +# If we got any errors that we were not expecting, then print them +print $_ if length $_; + + diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t index f3cf94487e..d5d97d7b3f 100755 --- a/t/lib/db-btree.t +++ b/t/lib/db-btree.t @@ -373,10 +373,12 @@ print( "@unknown" eq "" ? "ok 78\n" : "not ok 78\n") ; my @smith = $YY->get_dup('Smith') ; print( "@smith" eq "John" ? "ok 79\n" : "not ok 79\n") ; -my @wall = $YY->get_dup('Wall') ; -my %wall ; -@wall{@wall} = @wall ; -print( (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 80\n" : "not ok 80\n") ; +{ + my @wall = $YY->get_dup('Wall') ; + my %wall ; + @wall{@wall} = @wall ; + print( (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 80\n" : "not ok 80\n") ; +} # hash my %unknown = $YY->get_dup('Unknown', 1) ; @@ -385,7 +387,7 @@ print( keys %unknown == 0 ? "ok 81\n" : "not ok 81\n") ; my %smith = $YY->get_dup('Smith', 1) ; print( (keys %smith == 1 && $smith{'John'}) ? "ok 82\n" : "not ok 82\n") ; -my %wall = $YY->get_dup('Wall', 1) ; +%wall = $YY->get_dup('Wall', 1) ; print( (keys %wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 83\n" : "not ok 83\n") ; undef $YY ; diff --git a/t/lib/io_udp.t b/t/lib/io_udp.t index 84e5067b85..e85583fdb3 100755 --- a/t/lib/io_udp.t +++ b/t/lib/io_udp.t @@ -5,7 +5,8 @@ BEGIN { @INC = '../lib' if -d '../lib'; require Config; import Config; if ( ($Config{'extensions'} !~ /\bSocket\b/ || - $Config{'extensions'} !~ /\bIO\b/) && + $Config{'extensions'} !~ /\bIO\b/ || + $^O eq 'os2') && !(($^O eq 'VMS') && $Config{d_socket})) { print "1..0\n"; exit 0; @@ -18,8 +19,8 @@ print "1..3\n"; use Socket; use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); -$udpa = IO::Socket::INET->new(Proto => 'udp', Addr => 'localhost'); -$udpb = IO::Socket::INET->new(Proto => 'udp', Addr => 'localhost'); +$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); +$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); print "ok 1\n"; diff --git a/t/op/inc.t b/t/op/inc.t new file mode 100644 index 0000000000..aee91f798b --- /dev/null +++ b/t/op/inc.t @@ -0,0 +1,52 @@ +#!./perl + + +# $RCSfile$ + +print "1..6\n"; + +# Verify that addition/subtraction properly upgrade to doubles. +# These tests are only useful on machines with 32 bit longs, +# and one's complement negation, but shouldn't fail anywhere. + +$a = 2147483647; +$a++; +if ($a == 2147483648) + {print "ok 1\n"} +else + {print "not ok 1\n";} + +$a = 2147483647; +$c=++$a; +if ($a == 2147483648) + {print "ok 2\n"} +else + {print "not ok 2\n";} + +$a = 2147483647; +$a=$a+1; +if ($a == 2147483648) + {print "ok 3\n"} +else + {print "not ok 3\n";} + +$a = -2147483648; +$c=$a--; +if ($a == -2147483649) + {print "ok 4\n"} +else + {print "not ok 4\n";} + +$a = -2147483648; +$c=--$a; +if ($a == -2147483649) + {print "ok 5\n"} +else + {print "not ok 5\n";} + +$a = -2147483648; +$a=$a-1; +if ($a == -2147483649) + {print "ok 6\n"} +else + {print "not ok 6\n";} @@ -23,7 +23,7 @@ char *f; char *s; { if (tainting) { - DEBUG_u(fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid)); + DEBUG_u(PerlIO_printf(PerlIO_stderr(), "%s %d %d %d\n",s,tainted,uid, euid)); if (tainted) { char *ug = 0; if (euid != uid) @@ -44,9 +44,8 @@ static I32 sublex_start _((void)); #ifdef CRIPPLED_CC static int uni _((I32 f, char *s)); #endif -static char * filter_gets _((SV *sv, FILE *fp)); +static char * filter_gets _((SV *sv, PerlIO *fp)); static void restore_rsfp _((void *f)); -static SV * sub_const _((CV *cv)); /* The following are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). @@ -274,12 +273,12 @@ static void restore_rsfp(f) void *f; { - FILE *fp = (FILE*)f; + PerlIO *fp = (PerlIO*)f; - if (rsfp == stdin) - clearerr(rsfp); + if (rsfp == PerlIO_stdin()) + PerlIO_clearerr(rsfp); else if (rsfp && (rsfp != fp)) - fclose(rsfp); + PerlIO_close(rsfp); rsfp = fp; } @@ -356,10 +355,10 @@ register char *s; bufend = SvPVX(linestr) + SvCUR(linestr); if (preprocess && !in_eval) (void)my_pclose(rsfp); - else if ((FILE*)rsfp == stdin) - clearerr(stdin); + else if ((PerlIO*)rsfp == PerlIO_stdin()) + PerlIO_clearerr(rsfp); else - (void)fclose(rsfp); + (void)PerlIO_close(rsfp); rsfp = Nullfp; return s; } @@ -1111,8 +1110,8 @@ filter_read(idx, buf_sv, maxlen) /* ensure buf_sv is large enough */ SvGROW(buf_sv, old_len + maxlen) ; - if ((len = fread(SvPVX(buf_sv) + old_len, 1, maxlen, rsfp)) <= 0){ - if (ferror(rsfp)) + if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){ + if (PerlIO_error(rsfp)) return -1; /* error */ else return 0 ; /* end of file */ @@ -1121,7 +1120,7 @@ filter_read(idx, buf_sv, maxlen) } else { /* Want a line */ if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) { - if (ferror(rsfp)) + if (PerlIO_error(rsfp)) return -1; /* error */ else return 0 ; /* end of file */ @@ -1149,7 +1148,7 @@ filter_read(idx, buf_sv, maxlen) static char * filter_gets(sv,fp) register SV *sv; -register FILE *fp; +register PerlIO *fp; { if (rsfp_filters) { @@ -1350,7 +1349,7 @@ yylex() oldoldbufptr = oldbufptr; oldbufptr = s; DEBUG_p( { - fprintf(stderr,"### Tokener expecting %s at %s\n", exp_name[expect], s); + PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s); } ) retry: @@ -1423,10 +1422,10 @@ yylex() if (rsfp) { if (preprocess && !in_eval) (void)my_pclose(rsfp); - else if ((FILE*)rsfp == stdin) - clearerr(stdin); + else if ((PerlIO *)rsfp == PerlIO_stdin()) + PerlIO_clearerr(rsfp); else - (void)fclose(rsfp); + (void)PerlIO_close(rsfp); rsfp = Nullfp; } if (!in_eval && (minus_n || minus_p)) { @@ -2476,8 +2475,8 @@ yylex() last_lop = oldbufptr; last_lop_op = OP_ENTERSUB; /* Check for a constant sub */ - if (SvPOK(cv) && !SvCUR(cv)) { - SV *sv = sub_const(cv); + { + SV *sv = cv_const_sv(cv); if (sv) { SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); @@ -2568,13 +2567,13 @@ yylex() IoIFP(GvIOp(gv)) = rsfp; #if defined(HAS_FCNTL) && defined(F_SETFD) { - int fd = fileno(rsfp); + int fd = PerlIO_fileno(rsfp); fcntl(fd,F_SETFD,fd >= 3); } #endif if (preprocess) IoTYPE(GvIOp(gv)) = '|'; - else if ((FILE*)rsfp == stdin) + else if ((PerlIO*)rsfp == PerlIO_stdin()) IoTYPE(GvIOp(gv)) = '-'; else IoTYPE(GvIOp(gv)) = '<'; @@ -4987,27 +4986,6 @@ start_subparse() return oldsavestack_ix; } -SV * -sub_const(cv) -CV *cv; -{ - OP *o; - SV *sv = Nullsv; - - for (o = CvSTART(cv); o; o = o->op_next) { - OPCODE type = o->op_type; - - if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) - continue; - if (type == OP_LEAVESUB || type == OP_RETURN) - break; - if (type != OP_CONST || sv) - return Nullsv; - sv = ((SVOP*)o)->op_sv; - } - return sv; -} - int yywarn(s) char *s; @@ -5068,7 +5046,7 @@ char *s; else if (in_eval) sv_catpv(GvSV(errgv),buf); else - fputs(buf,stderr); + PerlIO_printf(PerlIO_stderr(), "%s",buf); if (++error_count >= 10) croak("%s has too many errors.\n", SvPVX(GvSV(curcop->cop_filegv))); diff --git a/universal.c b/universal.c index 830e2066ac..61a536b7fe 100644 --- a/universal.c +++ b/universal.c @@ -79,47 +79,32 @@ XS(XS_UNIVERSAL_isa) { dXSARGS; SV *sv, *rv; - char *name; + char *name, *type; + HV *stash; if (items != 2) croak("Usage: UNIVERSAL::isa(reference, kind)"); + stash = Nullhv; + type = Nullch; sv = ST(0); name = (char *)SvPV(ST(1),na); - if (!SvROK(sv)) { - rv = &sv_no; - } - else if((sv = (SV*)SvRV(sv)) && SvOBJECT(sv) && - &sv_yes == isa_lookup(SvSTASH(sv), name, strlen(name), 0)) { - rv = &sv_yes; + if (SvROK(sv)) { + sv = SvRV(sv); + type = sv_reftype(sv,0); + if(SvOBJECT(sv)) + stash = SvSTASH(sv); } else { - char *s; - - switch (SvTYPE(sv)) { - case SVt_NULL: - case SVt_IV: - case SVt_NV: - case SVt_RV: - case SVt_PV: - case SVt_PVIV: - case SVt_PVNV: - case SVt_PVBM: - case SVt_PVMG: s = "SCALAR"; break; - case SVt_PVLV: s = "LVALUE"; break; - case SVt_PVAV: s = "ARRAY"; break; - case SVt_PVHV: s = "HASH"; break; - case SVt_PVCV: s = "CODE"; break; - case SVt_PVGV: s = "GLOB"; break; - case SVt_PVFM: s = "FORMATLINE"; break; - case SVt_PVIO: s = "FILEHANDLE"; break; - default: s = "UNKNOWN"; break; - } - rv = strEQ(s,name) ? &sv_yes : &sv_no; + stash = gv_stashsv(sv, FALSE); } - ST(0) = rv; + ST(0) = (type && strEQ(type,name)) || + (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) + ? &sv_yes + : &sv_no; + XSRETURN(1); } @@ -29,10 +29,6 @@ # include <vfork.h> #endif -#ifdef I_LIMITS /* Needed for cast_xxx() functions below. */ -# include <limits.h> -#endif - /* Put this after #includes because fork and vfork prototypes may conflict. */ @@ -73,7 +69,7 @@ MEM_SIZE size; char *ptr; #ifdef MSDOS if (size > 0xffff) { - fprintf(stderr, "Allocation too large: %lx\n", size) FLUSH; + PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* MSDOS */ @@ -83,16 +79,16 @@ MEM_SIZE size; #endif ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ #if !(defined(I286) || defined(atarist)) - DEBUG_m(fprintf(Perl_debug_log,"0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); #else - DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); #endif if (ptr != Nullch) return ptr; else if (nomemok) return Nullch; else { - fputs(no_mem,stderr) FLUSH; + PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; my_exit(1); } /*NOTREACHED*/ @@ -116,7 +112,7 @@ unsigned long size; #ifdef MSDOS if (size > 0xffff) { - fprintf(stderr, "Reallocation too large: %lx\n", size) FLUSH; + PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* MSDOS */ @@ -130,13 +126,13 @@ unsigned long size; #if !(defined(I286) || defined(atarist)) DEBUG_m( { - fprintf(Perl_debug_log,"0x%x: (%05d) rfree\n",where,an++); - fprintf(Perl_debug_log,"0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); + PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++); + PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); } ) #else DEBUG_m( { - fprintf(Perl_debug_log,"0x%lx: (%05d) rfree\n",where,an++); - fprintf(Perl_debug_log,"0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); + PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++); + PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size); } ) #endif @@ -145,7 +141,7 @@ unsigned long size; else if (nomemok) return Nullch; else { - fputs(no_mem,stderr) FLUSH; + PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; my_exit(1); } /*NOTREACHED*/ @@ -158,9 +154,9 @@ safefree(where) char *where; { #if !(defined(I286) || defined(atarist)) - DEBUG_m( fprintf(Perl_debug_log,"0x%x: (%05d) free\n",where,an++)); + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",where,an++)); #else - DEBUG_m( fprintf(Perl_debug_log,"0x%lx: (%05d) free\n",where,an++)); + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",where,an++)); #endif if (where) { /*SUPPRESS 701*/ @@ -179,7 +175,7 @@ MEM_SIZE size; #ifdef MSDOS if (size * count > 0xffff) { - fprintf(stderr, "Allocation too large: %lx\n", size * count) FLUSH; + PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH; my_exit(1); } #endif /* MSDOS */ @@ -188,9 +184,9 @@ MEM_SIZE size; croak("panic: calloc"); #endif #if !(defined(I286) || defined(atarist)) - DEBUG_m(fprintf(stderr,"0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); + DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); #else - DEBUG_m(fprintf(stderr,"0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); + DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); #endif size *= count; ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ @@ -201,7 +197,7 @@ MEM_SIZE size; else if (nomemok) return Nullch; else { - fputs(no_mem,stderr) FLUSH; + PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; my_exit(1); } /*NOTREACHED*/ @@ -273,7 +269,7 @@ xstat() for (i = 0; i < MAXXCOUNT; i++) { if (xcount[i] > lastxcount[i]) { - fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); + PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); lastxcount[i] = xcount[i]; } } @@ -427,14 +423,14 @@ perl_init_i18nl10n(printwarn) if (setlocale(LC_CTYPE, "") == NULL && (lc_all || lc_ctype || lang)) { if (printwarn) { - fprintf(stderr, "warning: setlocale(LC_CTYPE, \"\") failed.\n"); - fprintf(stderr, + PerlIO_printf(PerlIO_stderr(), "warning: setlocale(LC_CTYPE, \"\") failed.\n"); + PerlIO_printf(PerlIO_stderr(), "warning: LC_ALL = \"%s\", LC_CTYPE = \"%s\", LANG = \"%s\",\n", lc_all ? lc_all : "(null)", lc_ctype ? lc_ctype : "(null)", lang ? lang : "(null)" ); - fprintf(stderr, "warning: falling back to the \"C\" locale.\n"); + PerlIO_printf(PerlIO_stderr(), "warning: falling back to the \"C\" locale.\n"); } ok = 0; if (setlocale(LC_CTYPE, "C") == NULL) @@ -518,7 +514,7 @@ I32 iflag; } BmRARE(sv) = s[rarest]; BmPREVIOUS(sv) = rarest; - DEBUG_r(fprintf(Perl_debug_log,"rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); + DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); } char * @@ -841,10 +837,10 @@ long a1, a2, a3, a4; if (s - s_start >= sizeof(buf)) { /* Ooops! */ if (usermess) - fputs(SvPVX(tmpstr), stderr); + PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr)); else - fputs(buf, stderr); - fputs("panic: message overflow - memory corrupted!\n",stderr); + PerlIO_puts(PerlIO_stderr(), buf); + PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n"); my_exit(1); } if (usermess) @@ -878,11 +874,11 @@ long a1, a2, a3, a4; restartop = die_where(message); Siglongjmp(top_env, 3); } - fputs(message,stderr); - (void)Fflush(stderr); + PerlIO_puts(PerlIO_stderr(),message); + (void)PerlIO_flush(PerlIO_stderr()); if (e_tmpname) { if (e_fp) { - fclose(e_fp); + PerlIO_close(e_fp); e_fp = Nullfp; } (void)UNLINK(e_tmpname); @@ -919,11 +915,11 @@ long a1, a2, a3, a4; perl_call_sv((SV*)cv, G_DISCARD); } else { - fputs(message,stderr); + PerlIO_puts(PerlIO_stderr(),message); #ifdef LEAKTEST DEBUG_L(xstat()); #endif - (void)Fflush(stderr); + (void)Fflush(PerlIO_stderr()); } } @@ -992,10 +988,10 @@ mess(pat, args) if (s - s_start >= sizeof(buf)) { /* Ooops! */ if (usermess) - fputs(SvPVX(tmpstr), stderr); + PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr)); else - fputs(buf, stderr); - fputs("panic: message overflow - memory corrupted!\n",stderr); + PerlIO_puts(PerlIO_stderr(), buf); + PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n"); my_exit(1); } if (usermess) @@ -1041,11 +1037,11 @@ croak(pat, va_alist) restartop = die_where(message); Siglongjmp(top_env, 3); } - fputs(message,stderr); - (void)Fflush(stderr); + PerlIO_puts(PerlIO_stderr(),message); + (void)PerlIO_flush(PerlIO_stderr()); if (e_tmpname) { if (e_fp) { - fclose(e_fp); + PerlIO_close(e_fp); e_fp = Nullfp; } (void)UNLINK(e_tmpname); @@ -1094,11 +1090,11 @@ warn(pat,va_alist) perl_call_sv((SV*)cv, G_DISCARD); } else { - fputs(message,stderr); + PerlIO_puts(PerlIO_stderr(),message); #ifdef LEAKTEST DEBUG_L(xstat()); #endif - (void)Fflush(stderr); + (void)PerlIO_flush(PerlIO_stderr()); } } #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ @@ -1258,14 +1254,6 @@ char *dest, *pat, *args; #endif } -int -vfprintf(fd, pat, args) -FILE *fd; -char *pat, *args; -{ - _doprnt(pat, args, fd); - return 0; /* wrong, but perl doesn't use the return value */ -} #endif /* HAS_VPRINTF */ #endif /* I_VARARGS || I_STDARGS */ @@ -1421,7 +1409,7 @@ VTOH(vtohl,long) #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c, same with OS/2. */ -FILE * +PerlIO * my_popen(cmd,mode) char *cmd; char *mode; @@ -1494,17 +1482,18 @@ char *mode; (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; forkprocess = pid; - return fdopen(p[this], mode); + return PerlIO_fdopen(p[this], mode); } #else #if defined(atarist) FILE *popen(); -FILE * +PerlIO * my_popen(cmd,mode) char *cmd; char *mode; { - return popen(cmd, mode); + /* Needs work for PerlIO ! */ + return popen(PerlIO_exportFILE(cmd), mode); } #endif @@ -1517,12 +1506,12 @@ char *s; int fd; struct stat tmpstatbuf; - fprintf(stderr,"%s", s); + PerlIO_printf(PerlIO_stderr(),"%s", s); for (fd = 0; fd < 32; fd++) { if (Fstat(fd,&tmpstatbuf) >= 0) - fprintf(stderr," %d",fd); + PerlIO_printf(PerlIO_stderr()," %d",fd); } - fprintf(stderr,"\n"); + PerlIO_printf(PerlIO_stderr(),"\n"); } #endif @@ -1557,18 +1546,18 @@ int newfd; #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ I32 my_pclose(ptr) -FILE *ptr; +PerlIO *ptr; { Signal_t (*hstat)(), (*istat)(), (*qstat)(); int status; SV **svp; int pid; - svp = av_fetch(fdpid,fileno(ptr),TRUE); + svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE); pid = (int)SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &sv_undef; - fclose(ptr); + PerlIO_close(ptr); #ifdef UTS if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif @@ -1663,9 +1652,13 @@ int status; int pclose(); I32 my_pclose(ptr) -FILE *ptr; +PerlIO *ptr; { - return pclose(ptr); + /* Needs work for PerlIO ! */ + FILE *f = PerlIO_findFILE(ptr); + I32 result = pclose(f); + PerlIO_releaseFILE(ptr,f); + return result; } #endif @@ -1715,29 +1708,6 @@ double f; #ifndef CASTI32 -/* Look for MAX and MIN integral values. If we can't find them, - we'll use 32-bit two's complement defaults. -*/ -#ifndef LONG_MAX -# ifdef MAXLONG /* Often used in <values.h> */ -# define LONG_MAX MAXLONG -# else -# define LONG_MAX 2147483647L -# endif -#endif - -#ifndef LONG_MIN -# define LONG_MIN (-LONG_MAX - 1) -#endif - -#ifndef ULONG_MAX -# ifdef MAXULONG -# define LONG_MAX MAXULONG -# else -# define ULONG_MAX 4294967295L -# endif -#endif - /* Unfortunately, on some systems the cast_uv() function doesn't work with the system-supplied definition of ULONG_MAX. The comparison (f >= ULONG_MAX) always comes out true. It must be a @@ -1749,17 +1719,17 @@ double f; --Andy Dougherty <doughera@lafcol.lafayette.edu> */ #ifndef MY_ULONG_MAX -# define MY_ULONG_MAX ((UV)LONG_MAX * (UV)2 + (UV)1) +# define MY_ULONG_MAX ((UV)PERL_LONG_MAX * (UV)2 + (UV)1) #endif I32 cast_i32(f) double f; { - if (f >= LONG_MAX) - return (I32) LONG_MAX; - if (f <= LONG_MIN) - return (I32) LONG_MIN; + if (f >= PERL_LONG_MAX) + return (I32) PERL_LONG_MAX; + if (f <= PERL_LONG_MIN) + return (I32) PERL_LONG_MIN; return (I32) f; } @@ -1767,10 +1737,10 @@ IV cast_iv(f) double f; { - if (f >= LONG_MAX) - return (IV) LONG_MAX; - if (f <= LONG_MIN) - return (IV) LONG_MIN; + if (f >= PERL_LONG_MAX) + return (IV) PERL_LONG_MAX; + if (f <= PERL_LONG_MIN) + return (IV) PERL_LONG_MIN; return (IV) f; } @@ -1865,3 +1835,17 @@ I32 *retlen; *retlen = s - start; return retval; } + + +#ifdef HUGE_VAL +/* + * This hack is to force load of "huge" support from libm.a + * So it is in perl for (say) POSIX to use. + * Needed for SunOS with Sun's 'acc' for example. + */ +double +Perl_huge() +{ + return HUGE_VAL; +} +#endif diff --git a/utils/h2ph.PL b/utils/h2ph.PL index 951705a6dc..d2d83c560e 100644 --- a/utils/h2ph.PL +++ b/utils/h2ph.PL @@ -34,7 +34,7 @@ $Config{'startperl'} 'ds 00 \"'; 'ig 00 '; -\$perlincl = "$Config{installsitearchlib}"; +\$perlincl = "$Config{archlibexp}"; # or {sitearchexp} !GROK!THIS! diff --git a/utils/h2xs.PL b/utils/h2xs.PL index e3d60ec0bc..4ef790eff0 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -118,6 +118,19 @@ to the templates. The default is 0.01. Omit the XS portion. Used to generate templates for a module which is not XS-based. +=item B<-x> + +Automatically generate XSUBs basing on function declarations in the +header file. The package C<C::Scan> should be installed. If this +option is specified, the name of the header file may look like +C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string, +but XSUBS are emited only for the declarations included from file NAME2. + +=item B<-F> + +Additional flags to specify to C preprocessor when scanning header for +function declarations. Should not be used without B<-x>. + =back =head1 EXAMPLES @@ -158,6 +171,17 @@ XS-based. h2xs -n DCE::rgynbase -p sec_rgy_ \ -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase + # Make XS with defines in perl.h, and function declarations + # visible from perl.h. Name of the extension is perl1. + # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)= + # Extra backslashes below because the string is passed to shell. + h2xs -xn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" \ + ../perl5_003_01/perl.h + + # Same with function declaration in proto.h as visible from perl.h. + perl H:\get\perl\perl5_003_01.try\utils\h2xs -xn perl1 \ + ../perl5_003_01/perl.h,proto.h + =head1 ENVIRONMENT No environment variables are used. @@ -172,11 +196,11 @@ L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>. =head1 DIAGNOSTICS -The usual warnings if it can't read or write the files involved. +The usual warnings if it cannot read or write the files involved. =cut -my( $H2XS_VERSION ) = '$Revision: 1.16 $' =~ /\$Revision:\s+([^\s]+)/; +my( $H2XS_VERSION ) = ' $Revision: 1.16 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; use Getopt::Std; @@ -195,6 +219,8 @@ version: $H2XS_VERSION -P Omit the stub POD section. -X Omit the XS portion. -v Specify a version number for this extension. + -x Autogenerate XSUBs using C::Scan. + -F Additional flags for C preprocessor (used with -x). -h Display this help message extra_libraries are any libraries that might be needed for loading the @@ -203,7 +229,7 @@ extra_libraries } -getopts("AOPXcfhxv:n:p:s:") || usage; +getopts("AOPXcfhxv:n:p:s:F:") || usage; usage if $opt_h; @@ -226,6 +252,8 @@ if( $path_h ){ warn "Nesting of headerfile ignored with -n\n"; } $path_h .= ".h" unless $path_h =~ /\.h$/; + $fullpath = $path_h; + $path_h =~ s/,.*$// if $opt_x; if ($^O eq 'VMS') { # Consider overrides of default location if ($path_h !~ m![:>\[]!) { my($hadsys) = ($path_h =~ s!^sys/!!i); @@ -252,7 +280,7 @@ if( $path_h ){ print "Matched $_ ($1)\n"; $_ = $1; next if /^_.*_h_*$/i; # special case, but for what? - if (defined $opt_p) + if (defined $opt_p) { if (!/^$opt_p(\d)/) { ++$prefix{$_} if s/^$opt_p//; } @@ -653,7 +681,16 @@ sub normalize_type { if ($opt_x) { require C::Scan; # Run-time directive require Config; # Run-time directive - my $c = new C::Scan 'filename' => $path_h; + my $c; + my $filter; + my $filename = $path_h; + my $addflags = $opt_F || ''; + if ($fullpath =~ /,/) { + $filename = $`; + $filter = $'; + } + $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, + 'add_cppflags' => $addflags; $c->set('includeDirs' => [$Config::Config{shrpdir}]); my $fdec = $c->get('parsed_fdecls'); diff --git a/vms/perly_c.vms b/vms/perly_c.vms index c4cbeabcf1..b1cb69cdfc 100644 --- a/vms/perly_c.vms +++ b/vms/perly_c.vms @@ -1407,7 +1407,7 @@ yyloop: yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; - fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate, + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } #endif @@ -1417,7 +1417,7 @@ yyloop: { #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", + PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif if (yyssp >= yyss + yystacksize - 1) @@ -1472,7 +1472,7 @@ yyinrecovery: { #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery shifting to state %d\n", *yyssp, yytable[yyn]); #endif @@ -1502,7 +1502,7 @@ yyinrecovery: { #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: error recovery discarding state %d\n", *yyssp); #endif @@ -1521,7 +1521,7 @@ yyinrecovery: yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery discards token %d (%s)\n", yystate, yychar, yys); } @@ -1532,7 +1532,7 @@ yyinrecovery: yyreduce: #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; @@ -2251,7 +2251,7 @@ break; { #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state 0 to state %d\n", YYFINAL); #endif @@ -2267,7 +2267,7 @@ break; yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; - fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", + PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } #endif @@ -2282,7 +2282,7 @@ break; yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) - fprintf(Perl_debug_log, + PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state %d to state %d\n", *yyssp, yystate); #endif @@ -349,7 +349,7 @@ kill_file(char *name) * VMS seem to return success on the unlock operation anyhow (after all * the unlock is successful), but others don't. */ - if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts == SS$_NORMAL; + if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL; if (aclsts & 1) aclsts = fndsts; if (!(aclsts & 1)) { set_errno(EVMSERR); diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH index e12a2de73f..260cfa4d64 100644 --- a/x2p/Makefile.SH +++ b/x2p/Makefile.SH @@ -87,7 +87,7 @@ obj = hash$(OBJ_EXT) $(mallocobj) str$(OBJ_EXT) util$(OBJ_EXT) walk$(OBJ_EXT) lintflags = -phbvxac .c$(OBJ_EXT): - $(CCCMD) $(MAB) $*.c + $(CCCMD) $(MAB) -DPERL_FOR_X2P $*.c all: $(public) $(private) $(util) touch all @@ -110,7 +110,7 @@ a2p.c: a2p.y -@touch a2p.c a2p$(OBJ_EXT): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h - $(CCCMD) $(LARGE) $(MAB) a2p.c + $(CCCMD) $(LARGE) $(MAB) -DPERL_FOR_X2P a2p.c clean: rm -f a2p *$(OBJ_EXT) diff --git a/x2p/cflags.SH b/x2p/cflags.SH index a781a7302e..87ff047f5d 100644 --- a/x2p/cflags.SH +++ b/x2p/cflags.SH @@ -75,7 +75,7 @@ for file do *) ;; esac - ccflags="`echo $ccflags | sed -e 's/-DEMBED//'`" + ccflags="`echo $ccflags | sed -e 's/-DMULTIPLICITY//'`" echo "$cc -c $ccflags $optimize $large $split" eval "$also "'"$cc -c $ccflags $optimize $large $split"' |