# Please remove the following files before applying this patch. # (You can feed this patch to 'sh' to do so.) rm -f hints/next_3_2.sh rm -f hints/next_3_3.sh rm -f os2/README.old exit Index: patchlevel.h *** perl5.003_01/patchlevel.h Tue Jul 30 23:11:53 1996 --- perl5.003_02/patchlevel.h Sat Aug 3 20:50:43 1996 *************** *** 1,5 **** #define PATCHLEVEL 3 ! #define SUBVERSION 1 /* local_patches -- list of locally applied less-than-subversion patches. --- 1,5 ---- #define PATCHLEVEL 3 ! #define SUBVERSION 2 /* local_patches -- list of locally applied less-than-subversion patches. Index: Changes *** perl5.003_01/Changes Tue Jul 30 23:10:51 1996 --- perl5.003_02/Changes Sat Aug 10 17:24:58 1996 *************** *** 7,12 **** --- 7,53 ---- 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 Index: Configure Prereq: 3.0.1.8 *** perl5.003_01/Configure Tue Jul 30 23:10:53 1996 --- perl5.003_02/Configure Thu Aug 8 17:48:52 1996 *************** *** 20,26 **** # $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] cat >/tmp/c1$$ </tmp/c1$$ <extract <<'EOS' CONFIG=true echo "Doing variable substitutions on .SH files..." if test -f MANIFEST; then --- 724,802 ---- : 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 <extract <>extract <<'EOS' CONFIG=true echo "Doing variable substitutions on .SH files..." if test -f MANIFEST; then *************** *** 1014,1020 **** 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). EOM echo $n "Continue? [n] $c" >&4 --- 1092,1098 ---- 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 (lwall@sems.com). EOM echo $n "Continue? [n] $c" >&4 *************** *** 1155,1161 **** : general instructions needman=true firsttime=true ! user=`( (logname) 2>/dev/null || whoami) 2>&1` if $contains "^$user\$" ../.config/instruct >/dev/null 2>&1; then firsttime=false echo " " --- 1233,1242 ---- : general instructions needman=true firsttime=true ! 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,1217 **** 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. This installation script affects things in two ways: --- 1292,1298 ---- 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 (lwall@sems.com) know how I blew it. This installation script affects things in two ways: *************** *** 1232,1305 **** 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 <&4 --- 1313,1318 ---- *************** *** 1555,1561 **** 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 : The metaconfig authors would also appreciate a copy... $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix --- 1568,1574 ---- 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 lwall@sems.com : The metaconfig authors would also appreciate a copy... $test -f /irix && osname=irix $test -f /xenix && osname=sco_xenix *************** *** 1628,1633 **** --- 1641,1649 ---- dgux) osname=dgux osvers="$3" ;; + dynixptx*) osname=dynixptx + osvers="$3" + ;; freebsd) osname=freebsd osvers="$3" ;; genix) osname=genix ;; *************** *** 1898,1903 **** --- 1914,1921 ---- 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,2320 **** 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` else patchlevel=0 subversion=0 fi ! echo "(You have $package $baserev PL$patchlevel sub$subversion.)" : set the prefixup variable, to restore leading tilda escape prefixup='case "$prefixexp" in --- 2326,2338 ---- 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` else patchlevel=0 subversion=0 fi ! echo "(You have $package $baserev patchlevel $patchlevel subversion $subversion.)" : set the prefixup variable, to restore leading tilda escape prefixup='case "$prefixexp" in *************** *** 2328,2341 **** case "$archlib" in '') case "$privlib" in ! '') ! 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}'` dflt="$privlib/$archname/$version" ;; esac --- 2346,2358 ---- case "$archlib" in '') case "$privlib" in ! '') 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}'` dflt="$privlib/$archname/$version" ;; esac *************** *** 2551,2556 **** --- 2568,2574 ---- 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,2704 **** fi cat < */ - 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); --- 4671,4676 ---- *************** *** 5653,5660 **** exit(0); } EOM if $cc $ccflags $cccdlflags -c dyna.c > /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` --- 5696,5704 ---- 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 && $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,6554 **** --- 6593,6649 ---- 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,6644 **** set sigaction d_sigaction eval $inlibc - : see if sigsetjmp exists echo " " case "$d_sigsetjmp" in '') ! $cat >set.c < sigjmp_buf env; int set = 1; --- 6728,6738 ---- set sigaction d_sigaction eval $inlibc : see if sigsetjmp exists echo " " case "$d_sigsetjmp" in '') ! $cat >set.c <<'EOP' #include sigjmp_buf env; int set = 1; *************** *** 6651,6675 **** exit(1); } EOP ! if $cc $ccflags $ldflags set.c -o set $libs >/dev/null 2>&1; then if ./set >/dev/null 2>&1; then echo "POSIX sigsetjmp found." >&4 val="$define" else ! $cat <&4 val="$undef" fi ;; *) val="$d_sigsetjmp" case "$d_sigsetjmp" in $define) echo "POSIX sigsetjmp found." >&4;; ! $undef) echo "Sigsetjmp not found." >&4;; esac ;; esac --- 6745,6770 ---- exit(1); } EOP ! 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 >&4 <&4 val="$undef" fi ;; *) val="$d_sigsetjmp" case "$d_sigsetjmp" in $define) echo "POSIX sigsetjmp found." >&4;; ! $undef) echo "sigsetjmp not found." >&4;; esac ;; esac *************** *** 7462,7470 **** '') $cat >try.c <<'EOCP' #if TRY & 1 ! void main() { #else ! main() { #endif extern void moo(); /* function returning void */ void (*goo)(); /* ptr to func returning void */ --- 7557,7565 ---- '') $cat >try.c <<'EOCP' #if TRY & 1 ! void sub() { #else ! sub() { #endif extern void moo(); /* function returning void */ void (*goo)(); /* ptr to func returning void */ *************** *** 7482,7489 **** #endif exit(0); } EOCP ! if $cc -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 --- 7577,7585 ---- #endif exit(0); } + main() { sub(); } EOCP ! 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,7507 **** 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 echo "It supports 1..." ! if $cc -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 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 voidflags=11 echo "But it supports 8." else --- 7588,7603 ---- fi else echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4 ! if $cc $ccflags -c -DTRY=1 try.c >/dev/null 2>&1; then echo "It supports 1..." ! if $cc $ccflags -c -DTRY=3 try.c >/dev/null 2>&1; then echo "It also supports 2..." ! 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 $ccflags -c -DTRY=11 try.c >/dev/null 2>&1; then voidflags=11 echo "But it supports 8." else *************** *** 7511,7521 **** fi else echo "It does not support 2..." ! if $cc -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 voidflags=5 echo "And it supports 4 but has not heard about 8." else --- 7607,7617 ---- fi else echo "It does not support 2..." ! 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 $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,8016 **** #include #include int main() { ! #ifdef NSIG ! printf("NSIG %d\n", NSIG); ! #else ! #ifdef _NSIG ! printf("NSIG %d\n", _NSIG); #endif #endif EOP echo $xxx | $tr ' ' '\012' | $sort | $uniq | $awk ' { --- 8100,8158 ---- #include #include int main() { ! ! /* 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,8151 **** printf("int\n"); else printf("long\n"); } EOM echo " " ! if $cc $ccflags $ldflags -o ssize ssize.c $libs > /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!)" $cat < /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 and run the test program--please enlighten me!)" $cat <& 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 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 --- 279,687 ---- 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/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 ! 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 Index: Makefile.SH *** perl5.003_01/Makefile.SH Tue Jul 30 23:10:56 1996 --- perl5.003_02/Makefile.SH Thu Aug 8 14:57:34 1996 *************** *** 43,49 **** # 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;; *) plibsuf=$lib_ext pldlflags="";; esac --- 43,55 ---- # 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 ! if test "$osname" = "os2" ; then ! d_shrplib=custom; ! shrpenv= ! plibsuf=$plibext ! fi ! ;; *) plibsuf=$lib_ext pldlflags="";; esac *************** *** 173,190 **** 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 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 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) obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS) --- 179,196 ---- 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 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 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) perlio$(OBJ_EXT) obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS) *************** *** 251,263 **** -@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) 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) 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) $(perllib): $& perl$(OBJ_EXT) $(obj) !NO!SUBS! --- 257,269 ---- -@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) $(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) $(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) $(DYNALOADER) $(static_ext) $(perllib) `cat ext.libs` $(libs) $(perllib): $& perl$(OBJ_EXT) $(obj) !NO!SUBS! *************** *** 272,284 **** else $spitshell >>Makefile <>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) --- 278,288 ---- else $spitshell >>Makefile <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 --- 372,378 ---- @ 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/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,489 **** test: miniperl perl preplibrary $(dynamic_ext) - cd t && (rm -f perl$(EXE_EXT); $(LNS) ../perl$(EXE_EXT) perl$(EXE_EXT)) && ./perl TEST .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. Index: cflags.SH *** perl5.003_01/cflags.SH Tue Jul 30 23:10:58 1996 --- perl5.003_02/cflags.SH Fri Aug 9 16:57:49 1996 *************** *** 123,130 **** optimize="$optdebug" fi ! echo "$cc -c $ccflags $optimize $perltype $large $split" ! eval "$also "'"$cc -c $ccflags $optimize $perltype $large $split"' . $TOP/config.sh --- 123,130 ---- optimize="$optdebug" fi ! echo "$cc -c -DPERL_CORE $ccflags $optimize $perltype $large $split" ! eval "$also "'"$cc -DPERL_CORE -c $ccflags $optimize $perltype $large $split"' . $TOP/config.sh Index: config_h.SH Prereq: 1.2 *** perl5.003_01/config_h.SH Tue Jul 30 23:10:59 1996 --- perl5.003_02/config_h.SH Thu Aug 8 17:48:52 1996 *************** *** 1,4 **** - #! /bin/sh case $CONFIG in '') if test -f config.sh; then TOP=.; --- 1,3 ---- *************** *** 12,29 **** . $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 <config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!' /* * This file was produced by running the config_h.SH script, which --- 11,20 ---- *************** *** 34,40 **** * 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 $ */ /* Configuration time: $cf_time --- 25,31 ---- * 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.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $ */ /* Configuration time: $cf_time *************** *** 1301,1316 **** */ #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 or - * 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". --- 1292,1297 ---- *************** *** 1335,1367 **** */ #define LOC_SED "$full_sed" /**/ /* 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. */ ! #define OSNAME "$osname" /**/ ! /* 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__ */ #define BYTEORDER 0x1234 #endif /* ENDIAN CHECK */ ! ! #endif /* !NeXT */ /* CSH: * This symbol, if defined, indicates that the C-shell exists. --- 1316,1351 ---- */ #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" /**/ ! /* BIN_SH: ! * Pathname to /bin/sh equivalent */ ! #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 __LITTLE_ENDIAN__ #define BYTEORDER 0x1234 + #else /* __BIG_ENDIAN__ */ + #define BYTEORDER 0x4321 #endif /* ENDIAN CHECK */ ! #endif /* NeXT */ /* CSH: * This symbol, if defined, indicates that the C-shell exists. *************** *** 1414,1439 **** */ #define Gconvert(x,n,t,b) $d_Gconvert /* Sigjmp_buf: ! * 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. */ /* Siglongjmp: ! * This macro is used in the same way as siglongjmp(), but will invoke ! * traditional longjmp() if siglongjmp isn't available. */ #$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) #else #define Sigjmp_buf jmp_buf ! #define Sigsetjmp(buf,save_mask) setjmp(buf) ! #define Siglongjmp(buf,retval) longjmp(buf,retval) #endif /* USE_DYNAMIC_LOADING: --- 1398,1437 ---- */ #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. */ /* Sigsetjmp: ! * 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. ! * 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)) #else #define Sigjmp_buf jmp_buf ! #define Sigsetjmp(buf,save_mask) setjmp((buf)) ! #define Siglongjmp(buf,retval) longjmp((buf),(retval)) #endif /* USE_DYNAMIC_LOADING: *************** *** 1459,1470 **** --- 1457,1476 ---- */ #$i_locale I_LOCALE /**/ + /* I_SFIO: + * This symbol, if defined, indicates to the C program that it should + * include . + */ + #$i_sfio I_SFIO /**/ + /* I_SYS_STAT: * This symbol, if defined, indicates to the C program that it should * include . */ #$i_sysstat I_SYS_STAT /**/ + #$i_values I_LIMITS /**/ + /* I_STDARG: * This symbol, if defined, indicates that exists and should * be included. *************** *** 1580,1596 **** */ #define SITELIB_EXP "$sitelibexp" /**/ /* 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 * some shell. */ #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 --- 1586,1607 ---- */ #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 or + * 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 * some shell. */ #define STARTPERL "$startperl" /**/ /* VOIDFLAGS: * This symbol indicates how much support of the void type is given by this Index: cop.h *** perl5.003_01/cop.h Tue Jul 30 23:11:00 1996 --- perl5.003_02/cop.h Thu Aug 8 13:31:09 1996 *************** *** 147,153 **** cx->blk_oldretsp = retstack_ix, \ cx->blk_oldpm = curpm, \ cx->blk_gimme = gimme; \ ! DEBUG_l( fprintf(stderr,"Entering block %ld, type %s\n", \ (long)cxstack_ix, block_type[t]); ) /* Exit a block (RETURN and LAST). */ --- 147,153 ---- cx->blk_oldretsp = retstack_ix, \ cx->blk_oldpm = curpm, \ cx->blk_gimme = gimme; \ ! 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,165 **** retstack_ix = cx->blk_oldretsp, \ pm = cx->blk_oldpm, \ gimme = cx->blk_gimme; \ ! DEBUG_l( fprintf(stderr,"Leaving block %ld, type %s\n", \ (long)cxstack_ix+1,block_type[cx->cx_type]); ) /* Continue a block elsewhere (NEXT and REDO). */ --- 159,165 ---- retstack_ix = cx->blk_oldretsp, \ pm = cx->blk_oldpm, \ gimme = cx->blk_gimme; \ ! 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). */ Index: deb.c *** perl5.003_01/deb.c Tue Jul 30 23:11:01 1996 --- perl5.003_02/deb.c Thu Aug 8 09:45:50 1996 *************** *** 30,41 **** register I32 i; GV* gv = curcop->cop_filegv; ! fprintf(Perl_debug_log,"(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "", (long)curcop->cop_line); for (i=0; icop_filegv; ! PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "", (long)curcop->cop_line); for (i=0; icop_filegv; ! fprintf(Perl_debug_log,"(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "", (long)curcop->cop_line); for (i=0; icop_filegv; ! PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "", (long)curcop->cop_line); for (i=0; i= i) break; ! fprintf(Perl_debug_log, i ? " => ... " : " => "); if (stack_base[0] != &sv_undef || stack_sp < stack_base) ! fprintf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); do { ++i; if (markscan <= markstack_ptr && *markscan < i) { do { ++markscan; ! putc('*', Perl_debug_log); } while (markscan <= markstack_ptr && *markscan < i); ! fprintf(Perl_debug_log, " "); } if (i > top) break; ! fprintf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); } while (1); ! fprintf(Perl_debug_log, "\n"); return 0; } #else --- 106,130 ---- if (*markscan >= i) break; ! PerlIO_printf(Perl_debug_log, i ? " => ... " : " => "); if (stack_base[0] != &sv_undef || stack_sp < stack_base) ! PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n"); do { ++i; if (markscan <= markstack_ptr && *markscan < i) { do { ++markscan; ! PerlIO_putc(Perl_debug_log, '*'); } while (markscan <= markstack_ptr && *markscan < i); ! PerlIO_printf(Perl_debug_log, " "); } if (i > top) break; ! PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i])); } while (1); ! PerlIO_printf(Perl_debug_log, "\n"); return 0; } #else Index: doio.c *** perl5.003_01/doio.c Tue Jul 30 23:11:01 1996 --- perl5.003_02/doio.c Thu Aug 8 13:34:52 1996 *************** *** 60,80 **** I32 len; int as_raw; int rawmode, rawperm; ! FILE *supplied_fp; { register IO *io = GvIOn(gv); ! FILE *saveifp = Nullfp; ! FILE *saveofp = Nullfp; char savetype = ' '; int writing = 0; ! FILE *fp; int fd; int result; forkprocess = 1; /* assume true if no fork */ if (IoIFP(io)) { ! fd = fileno(IoIFP(io)); if (IoTYPE(io) == '-') result = 0; else if (fd <= maxsysfd) { --- 60,80 ---- I32 len; int as_raw; int rawmode, rawperm; ! PerlIO *supplied_fp; { register IO *io = GvIOn(gv); ! PerlIO *saveifp = Nullfp; ! PerlIO *saveofp = Nullfp; char savetype = ' '; int writing = 0; ! PerlIO *fp; int fd; int result; forkprocess = 1; /* assume true if no fork */ if (IoIFP(io)) { ! fd = PerlIO_fileno(IoIFP(io)); if (IoTYPE(io) == '-') result = 0; else if (fd <= maxsysfd) { *************** *** 87,102 **** result = my_pclose(IoIFP(io)); else if (IoIFP(io) != IoOFP(io)) { if (IoOFP(io)) { ! result = fclose(IoOFP(io)); ! fclose(IoIFP(io)); /* clear stdio, fd already closed */ } else ! result = fclose(IoIFP(io)); } else ! result = fclose(IoIFP(io)); if (result == EOF && fd > maxsysfd) ! fprintf(stderr,"Warning: unable to close filehandle %s properly.\n", GvENAME(gv)); IoOFP(io) = IoIFP(io) = Nullfp; } --- 87,102 ---- result = my_pclose(IoIFP(io)); else if (IoIFP(io) != IoOFP(io)) { if (IoOFP(io)) { ! result = PerlIO_close(IoOFP(io)); ! PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ } else ! result = PerlIO_close(IoIFP(io)); } else ! result = PerlIO_close(IoIFP(io)); if (result == EOF && fd > maxsysfd) ! PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n", GvENAME(gv)); IoOFP(io) = IoIFP(io) = Nullfp; } *************** *** 109,115 **** if (fd == -1) fp = NULL; else { ! fp = fdopen(fd, ((result == 0) ? "r" : (result == 1) ? "w" : "r+")); if (!fp) --- 109,115 ---- if (fd == -1) fp = NULL; else { ! fp = PerlIO_fdopen(fd, ((result == 0) ? "r" : (result == 1) ? "w" : "r+")); if (!fp) *************** *** 183,189 **** goto say_false; } if (IoIFP(thatio)) { ! fd = fileno(IoIFP(thatio)); if (IoTYPE(thatio) == 's') IoTYPE(io) = 's'; } --- 183,189 ---- goto say_false; } if (IoIFP(thatio)) { ! fd = PerlIO_fileno(IoIFP(thatio)); if (IoTYPE(thatio) == 's') IoTYPE(io) = 's'; } *************** *** 192,198 **** } if (dodup) fd = dup(fd); ! if (!(fp = fdopen(fd,mode))) { if (dodup) close(fd); } --- 192,198 ---- } if (dodup) fd = dup(fd); ! if (!(fp = PerlIO_fdopen(fd,mode))) { if (dodup) close(fd); } *************** *** 202,212 **** /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; if (strEQ(name,"-")) { ! fp = stdout; IoTYPE(io) = '-'; } else { ! fp = fopen(name,mode); } } } --- 202,212 ---- /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; if (strEQ(name,"-")) { ! fp = PerlIO_stdout(); IoTYPE(io) = '-'; } else { ! fp = PerlIO_open(name,mode); } } } *************** *** 217,227 **** if (*name == '&') goto duplicity; if (strEQ(name,"-")) { ! fp = stdin; IoTYPE(io) = '-'; } else ! fp = fopen(name,mode); } else if (name[len-1] == '|') { name[--len] = '\0'; --- 217,227 ---- if (*name == '&') goto duplicity; if (strEQ(name,"-")) { ! fp = PerlIO_stdin(); IoTYPE(io) = '-'; } else ! fp = PerlIO_open(name,mode); } else if (name[len-1] == '|') { name[--len] = '\0'; *************** *** 240,250 **** /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; if (strEQ(name,"-")) { ! fp = stdin; IoTYPE(io) = '-'; } else ! fp = fopen(name,"r"); } } if (!fp) { --- 240,250 ---- /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; if (strEQ(name,"-")) { ! fp = PerlIO_stdin(); IoTYPE(io) = '-'; } else ! fp = PerlIO_open(name,"r"); } } if (!fp) { *************** *** 254,261 **** } if (IoTYPE(io) && IoTYPE(io) != '|' && IoTYPE(io) != '-') { ! if (Fstat(fileno(fp),&statbuf) < 0) { ! (void)fclose(fp); goto say_false; } if (S_ISSOCK(statbuf.st_mode)) --- 254,261 ---- } if (IoTYPE(io) && IoTYPE(io) != '|' && IoTYPE(io) != '-') { ! if (Fstat(PerlIO_fileno(fp),&statbuf) < 0) { ! (void)PerlIO_close(fp); goto say_false; } if (S_ISSOCK(statbuf.st_mode)) *************** *** 269,275 **** #endif ) { int buflen = sizeof tokenbuf; ! if (getsockname(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 */ --- 269,275 ---- #endif ) { int buflen = sizeof tokenbuf; ! 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,319 **** #endif } if (saveifp) { /* must use old fp? */ ! fd = fileno(saveifp); if (saveofp) { ! Fflush(saveofp); /* emulate fclose() */ if (saveofp != saveifp) { /* was a socket? */ ! fclose(saveofp); if (fd > 2) Safefree(saveofp); } } ! if (fd != fileno(fp)) { int pid; SV *sv; ! dup2(fileno(fp), fd); ! sv = *av_fetch(fdpid,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); } fp = saveifp; ! clearerr(fp); } #if defined(HAS_FCNTL) && defined(F_SETFD) ! fd = 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); IoIFP(io) = Nullfp; goto say_false; } --- 277,319 ---- #endif } if (saveifp) { /* must use old fp? */ ! fd = PerlIO_fileno(saveifp); if (saveofp) { ! PerlIO_flush(saveofp); /* emulate PerlIO_close() */ if (saveofp != saveifp) { /* was a socket? */ ! PerlIO_close(saveofp); if (fd > 2) Safefree(saveofp); } } ! if (fd != PerlIO_fileno(fp)) { int pid; SV *sv; ! 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; ! PerlIO_close(fp); } fp = saveifp; ! PerlIO_clearerr(fp); } #if defined(HAS_FCNTL) && defined(F_SETFD) ! 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) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) { ! PerlIO_close(fp); IoIFP(io) = Nullfp; goto say_false; } *************** *** 330,336 **** return FALSE; } ! FILE * nextargv(gv) register GV *gv; { --- 330,336 ---- return FALSE; } ! PerlIO * nextargv(gv) register GV *gv; { *************** *** 345,351 **** if (!argvoutgv) argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO); if (filemode & (S_ISUID|S_ISGID)) { ! Fflush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */ #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); #else --- 345,351 ---- if (!argvoutgv) argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO); if (filemode & (S_ISUID|S_ISGID)) { ! PerlIO_flush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */ #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); #else *************** *** 444,450 **** continue; } setdefout(argvoutgv); ! lastfd = fileno(IoIFP(GvIOp(argvoutgv))); (void)Fstat(lastfd,&statbuf); #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); --- 444,450 ---- continue; } setdefout(argvoutgv); ! lastfd = PerlIO_fileno(IoIFP(GvIOp(argvoutgv))); (void)Fstat(lastfd,&statbuf); #ifdef HAS_FCHMOD (void)fchmod(lastfd,filemode); *************** *** 464,470 **** return IoIFP(GvIOp(gv)); } else ! fprintf(stderr,"Can't open %s: %s\n",SvPV(sv, na), Strerror(errno)); } if (inplace) { (void)do_close(argvoutgv,FALSE); --- 464,470 ---- return IoIFP(GvIOp(gv)); } else ! PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",SvPV(sv, na), Strerror(errno)); } if (inplace) { (void)do_close(argvoutgv,FALSE); *************** *** 499,513 **** if (pipe(fd) < 0) goto badexit; ! IoIFP(rstio) = fdopen(fd[0], "r"); ! IoOFP(wstio) = fdopen(fd[1], "w"); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = '<'; IoTYPE(wstio) = '>'; if (!IoIFP(rstio) || !IoOFP(wstio)) { ! if (IoIFP(rstio)) fclose(IoIFP(rstio)); else close(fd[0]); ! if (IoOFP(wstio)) fclose(IoOFP(wstio)); else close(fd[1]); goto badexit; } --- 499,513 ---- if (pipe(fd) < 0) goto badexit; ! 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)) PerlIO_close(IoIFP(rstio)); else close(fd[0]); ! if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio)); else close(fd[1]); goto badexit; } *************** *** 573,583 **** 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 */ } else ! retval = (fclose(IoIFP(io)) != EOF); } IoOFP(io) = IoIFP(io) = Nullfp; } --- 573,583 ---- retval = TRUE; else { if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { /* a socket */ ! retval = (PerlIO_close(IoOFP(io)) != EOF); ! PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */ } else ! retval = (PerlIO_close(IoIFP(io)) != EOF); } IoOFP(io) = IoIFP(io) = Nullfp; } *************** *** 599,618 **** 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 ! ch = getc(IoIFP(io)); if (ch != EOF) { ! (void)ungetc(ch, IoIFP(io)); return FALSE; } ! #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) ! if (FILE_cnt(IoIFP(io)) < -1) ! FILE_cnt(IoIFP(io)) = -1; ! #endif if (op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ if (!nextargv(argvgv)) /* get another fp handy */ return TRUE; --- 599,618 ---- while (IoIFP(io)) { ! 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 = PerlIO_getc(IoIFP(io)); if (ch != EOF) { ! (void)PerlIO_ungetc(IoIFP(io),ch); return FALSE; } ! 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,647 **** goto phooey; #ifdef ULTRIX_STDIO_BOTCH ! if (feof(IoIFP(io))) ! (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ #endif ! return ftell(IoIFP(io)); phooey: if (dowarn) --- 637,647 ---- goto phooey; #ifdef ULTRIX_STDIO_BOTCH ! if (PerlIO_eof(IoIFP(io))) ! (void)PerlIO_seek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ #endif ! return PerlIO_tell(IoIFP(io)); phooey: if (dowarn) *************** *** 666,676 **** goto nuts; #ifdef ULTRIX_STDIO_BOTCH ! if (feof(IoIFP(io))) ! (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ #endif ! return fseek(IoIFP(io), pos, whence) >= 0; nuts: if (dowarn) --- 666,676 ---- goto nuts; #ifdef ULTRIX_STDIO_BOTCH ! if (PerlIO_eof(IoIFP(io))) ! (void)PerlIO_seek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */ #endif ! return PerlIO_seek(IoIFP(io), pos, whence) >= 0; nuts: if (dowarn) *************** *** 784,790 **** bool do_print(sv,fp) register SV *sv; ! FILE *fp; { register char *tmps; STRLEN len; --- 784,790 ---- bool do_print(sv,fp) register SV *sv; ! PerlIO *fp; { register char *tmps; STRLEN len; *************** *** 796,808 **** if (SvGMAGICAL(sv)) mg_get(sv); if (SvIOK(sv) && SvIVX(sv) != 0) { ! fprintf(fp, ofmt, (double)SvIVX(sv)); ! return !ferror(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); } } switch (SvTYPE(sv)) { --- 796,808 ---- if (SvGMAGICAL(sv)) mg_get(sv); if (SvIOK(sv) && SvIVX(sv) != 0) { ! 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) ) { ! PerlIO_printf(fp, ofmt, SvNVX(sv)); ! return !PerlIO_error(fp); } } switch (SvTYPE(sv)) { *************** *** 814,830 **** if (SvIOK(sv)) { if (SvGMAGICAL(sv)) mg_get(sv); ! fprintf(fp, "%ld", (long)SvIVX(sv)); ! return !ferror(fp); } /* FALL THROUGH */ default: tmps = SvPV(sv, len); break; } ! if (len && (fwrite1(tmps,1,len,fp) == 0 || ferror(fp))) return FALSE; ! return TRUE; } I32 --- 814,830 ---- if (SvIOK(sv)) { if (SvGMAGICAL(sv)) mg_get(sv); ! PerlIO_printf(fp, "%ld", (long)SvIVX(sv)); ! return !PerlIO_error(fp); } /* FALL THROUGH */ default: tmps = SvPV(sv, len); break; } ! if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp))) return FALSE; ! return !PerlIO_error(fp); } I32 *************** *** 844,850 **** statgv = tmpgv; sv_setpv(statname,""); laststype = OP_STAT; ! return (laststatval = Fstat(fileno(IoIFP(io)), &statcache)); } else { if (tmpgv == defgv) --- 844,850 ---- statgv = tmpgv; sv_setpv(statname,""); laststype = OP_STAT; ! return (laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache)); } else { if (tmpgv == defgv) *************** *** 955,960 **** --- 955,962 ---- } } + #ifndef OS2 + bool do_exec(cmd) char *cmd; *************** *** 1043,1048 **** --- 1045,1052 ---- do_execfree(); return FALSE; } + + #endif I32 apply(type,mark,sp) Index: doop.c *** perl5.003_01/doop.c Tue Jul 30 23:11:02 1996 --- perl5.003_02/doop.c Wed Aug 7 10:38:32 1996 *************** *** 320,326 **** /* end of switch, copy results */ *t = ch; if (xs == buf && xlen >= sizeof(buf)) { /* Ooops! */ ! fputs("panic: sprintf overflow - memory corrupted!\n",stderr); my_exit(1); } SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post); --- 320,326 ---- /* end of switch, copy results */ *t = ch; if (xs == buf && xlen >= sizeof(buf)) { /* Ooops! */ ! PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n"); my_exit(1); } SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post); Index: dump.c *** perl5.003_01/dump.c Tue Jul 30 23:11:03 1996 --- perl5.003_02/dump.c Thu Aug 8 09:45:51 1996 *************** *** 25,49 **** #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 if (main_root) dump_op(main_root); dump_packsubs(defstash); --- 25,37 ---- #ifdef I_STDARG static void dump(char *pat, ...); #else static void dump(); #endif void dump_all() { ! PerlIO_setlinebuf(Perl_debug_log); if (main_root) dump_op(main_root); dump_packsubs(defstash); *************** *** 119,136 **** dump("{\n"); if (op->op_seq) ! fprintf(Perl_debug_log, "%-4d", op->op_seq); else ! fprintf(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); else ! fprintf(Perl_debug_log, "(%d)\n", op->op_next->op_seq); } else ! fprintf(Perl_debug_log, "DONE\n"); dumplvl++; if (op->op_targ) { if (op->op_type == OP_NULL) --- 107,124 ---- dump("{\n"); if (op->op_seq) ! PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq); else ! PerlIO_printf(Perl_debug_log, " "); dump("TYPE = %s ===> ", op_name[op->op_type]); if (op->op_next) { if (op->op_seq) ! PerlIO_printf(Perl_debug_log, "%d\n", op->op_next->op_seq); else ! PerlIO_printf(Perl_debug_log, "(%d)\n", op->op_next->op_seq); } else ! PerlIO_printf(Perl_debug_log, "DONE\n"); dumplvl++; if (op->op_targ) { if (op->op_type == OP_NULL) *************** *** 255,285 **** case OP_ENTERLOOP: dump("REDO ===> "); if (cLOOP->op_redoop) ! fprintf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq); else ! fprintf(Perl_debug_log, "DONE\n"); dump("NEXT ===> "); if (cLOOP->op_nextop) ! fprintf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq); else ! fprintf(Perl_debug_log, "DONE\n"); dump("LAST ===> "); if (cLOOP->op_lastop) ! fprintf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq); else ! fprintf(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); else ! fprintf(Perl_debug_log, "DONE\n"); dump("FALSE ===> "); if (cCONDOP->op_false) ! fprintf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq); else ! fprintf(Perl_debug_log, "DONE\n"); break; case OP_MAPWHILE: case OP_GREPWHILE: --- 243,273 ---- case OP_ENTERLOOP: dump("REDO ===> "); if (cLOOP->op_redoop) ! PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq); else ! PerlIO_printf(Perl_debug_log, "DONE\n"); dump("NEXT ===> "); if (cLOOP->op_nextop) ! PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq); else ! PerlIO_printf(Perl_debug_log, "DONE\n"); dump("LAST ===> "); if (cLOOP->op_lastop) ! PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq); else ! PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_COND_EXPR: dump("TRUE ===> "); if (cCONDOP->op_true) ! PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq); else ! PerlIO_printf(Perl_debug_log, "DONE\n"); dump("FALSE ===> "); if (cCONDOP->op_false) ! PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq); else ! PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_MAPWHILE: case OP_GREPWHILE: *************** *** 287,295 **** case OP_AND: dump("OTHER ===> "); if (cLOGOP->op_other) ! fprintf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq); else ! fprintf(Perl_debug_log, "DONE\n"); break; case OP_PUSHRE: case OP_MATCH: --- 275,283 ---- case OP_AND: dump("OTHER ===> "); if (cLOGOP->op_other) ! PerlIO_printf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq); else ! PerlIO_printf(Perl_debug_log, "DONE\n"); break; case OP_PUSHRE: case OP_MATCH: *************** *** 315,326 **** SV *sv; if (!gv) { ! fprintf(Perl_debug_log,"{}\n"); return; } sv = sv_newmortal(); dumplvl++; ! fprintf(Perl_debug_log,"{\n"); gv_fullname(sv,gv); dump("GV_NAME = %s", SvPVX(sv)); if (gv != GvEGV(gv)) { --- 303,314 ---- SV *sv; if (!gv) { ! PerlIO_printf(Perl_debug_log, "{}\n"); return; } sv = sv_newmortal(); dumplvl++; ! PerlIO_printf(Perl_debug_log, "{\n"); gv_fullname(sv,gv); dump("GV_NAME = %s", SvPVX(sv)); if (gv != GvEGV(gv)) { *************** *** 400,407 **** I32 i; for (i = dumplvl*4; i; i--) ! (void)putc(' ',Perl_debug_log); ! fprintf(Perl_debug_log,arg1, arg2, arg3, arg4, arg5); } #else --- 388,395 ---- I32 i; for (i = dumplvl*4; i; i--) ! (void)PerlIO_putc(Perl_debug_log,' '); ! PerlIO_printf(Perl_debug_log, arg1, arg2, arg3, arg4, arg5); } #else *************** *** 419,427 **** { I32 i; va_list args; - #ifndef HAS_VPRINTF - int vfprintf(); - #endif #ifdef I_STDARG va_start(args, pat); --- 407,412 ---- *************** *** 429,436 **** va_start(args); #endif for (i = dumplvl*4; i; i--) ! (void)putc(' ',stderr); ! vfprintf(Perl_debug_log,pat,args); va_end(args); } #endif --- 414,421 ---- va_start(args); #endif for (i = dumplvl*4; i; i--) ! (void)PerlIO_putc(Perl_debug_log,' '); ! PerlIO_vprintf(Perl_debug_log,pat,args); va_end(args); } #endif Index: embed.h *** perl5.003_01/embed.h Tue Jul 30 23:11:06 1996 --- perl5.003_02/embed.h Thu Aug 8 14:21:08 1996 *************** *** 56,66 **** --- 56,69 ---- #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,525 **** #define my Perl_my #define my_bcopy Perl_my_bcopy #define my_bzero Perl_my_bzero ! #define my_chsize Perl_my_chsize #define my_exit Perl_my_exit #define my_htonl Perl_my_htonl #define my_lstat Perl_my_lstat --- 522,528 ---- #define my Perl_my #define my_bcopy Perl_my_bcopy #define my_bzero Perl_my_bzero ! #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,1107 **** /* Undefine symbols that were defined by EMBED. Somewhat ugly */ #undef curcop #undef envgv #undef siggv - #undef stack #undef tainting #define Argv (curinterp->IArgv) --- 1102,1110 ---- /* Undefine symbols that were defined by EMBED. Somewhat ugly */ #undef curcop + #undef curcopdb #undef envgv #undef siggv #undef tainting #define Argv (curinterp->IArgv) *************** *** 1137,1143 **** #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) --- 1140,1145 ---- *************** *** 1146,1152 **** #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) --- 1148,1153 ---- *************** *** 1292,1298 **** #define Idebdelim debdelim #define Idebname debname #define Idebstash debstash - #define Idebug debug #define Idefgv defgv #define Idefoutgv defoutgv #define Idefstash defstash --- 1293,1298 ---- *************** *** 1301,1307 **** #define Idirty dirty #define Idlevel dlevel #define Idlmax dlmax - #define Ido_undump do_undump #define Idoextract doextract #define Idoswitches doswitches #define Idowarn dowarn --- 1301,1306 ---- Index: embed.pl *** perl5.003_01/embed.pl Tue Jul 30 23:11:07 1996 --- perl5.003_02/embed.pl Mon Aug 5 10:59:17 1996 *************** *** 30,36 **** while() { s/[ \t]*#.*//; # Delete comments. next unless /\S/; ! s/(.*)/#define $1\t\tPerl_$1/; s/(................\t)\t/$1/; print EM $_; } --- 30,37 ---- while() { s/[ \t]*#.*//; # Delete comments. next unless /\S/; ! s/^\s*(\S+).*$/#define $1\t\tPerl_$1/; ! $global{$1} = 1; s/(................\t)\t/$1/; print EM $_; } *************** *** 47,65 **** /* Undefine symbols that were defined by EMBED. Somewhat ugly */ - #undef curcop - #undef envgv - #undef siggv - #undef stack - #undef tainting - END open(INT, ") { s/[ \t]*#.*//; # Delete comments. next unless /\S/; ! s/(.*)/#define $1\t\t(curinterp->I$1)/; s/(................\t)\t/$1/; print EM $_; } --- 48,72 ---- /* Undefine symbols that were defined by EMBED. Somewhat ugly */ END + + open(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, ") { s/[ \t]*#.*//; # Delete comments. next unless /\S/; ! s/^\s*(\S+).*$/#define $1\t\t(curinterp->I$1)/; s/(................\t)\t/$1/; print EM $_; } *************** *** 75,81 **** while () { s/[ \t]*#.*//; # Delete comments. next unless /\S/; ! s/(.*)/#define I$1\t\t$1/; s/(................\t)\t/$1/; print EM $_; } --- 82,88 ---- while () { s/[ \t]*#.*//; # Delete comments. next unless /\S/; ! s/^\s*(\S+).*$/#define I$1\t\t$1/; s/(................\t)\t/$1/; print EM $_; } Index: ext/DB_File/DB_File.pm *** perl5.003_01/ext/DB_File/DB_File.pm Tue Jul 30 23:11:08 1996 --- perl5.003_02/ext/DB_File/DB_File.pm Fri Aug 2 17:49:58 1996 *************** *** 273,290 **** [$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->sync([$flags]) ; $status = $X->fd ; ! $count = $X->get_dup($key) ; @list = $X->get_dup($key) ; %list = $X->get_dup($key, 1) ; --- 273,286 ---- [$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->sync([$flags]) ; $status = $X->fd ; ! $count = $X->get_dup($key) ; @list = $X->get_dup($key) ; %list = $X->get_dup($key, 1) ; *************** *** 320,330 **** 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 use it instead. - - When opening an existing database, you may omit the final three arguments - to C; 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 --- 316,321 ---- Index: ext/DynaLoader/Makefile.PL *** perl5.003_01/ext/DynaLoader/Makefile.PL Tue Jul 30 23:11:10 1996 --- perl5.003_02/ext/DynaLoader/Makefile.PL Fri Aug 9 17:08:26 1996 *************** *** 3,9 **** WriteMakefile( NAME => 'DynaLoader', LINKTYPE => 'static', ! DEFINE => '-DLIBC="$(LIBC)"', MAN3PODS => ' ', # Pods will be built by installman. SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? --- 3,9 ---- WriteMakefile( NAME => 'DynaLoader', LINKTYPE => 'static', ! DEFINE => '-DPERL_CORE -DLIBC="$(LIBC)"', MAN3PODS => ' ', # Pods will be built by installman. SKIP => [qw(dynamic dynamic_lib dynamic_bs)], XSPROTOARG => '-noprototypes', # XXX remove later? Index: ext/DynaLoader/dl_aix.xs Prereq: 1.5 *** perl5.003_01/ext/DynaLoader/dl_aix.xs Tue Oct 18 17:28:13 1994 --- perl5.003_02/ext/DynaLoader/dl_aix.xs Thu Aug 8 13:41:27 1996 *************** *** 527,535 **** dl_load_file(filename) char * filename CODE: ! DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, 1) ; ! DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; --- 527,535 ---- dl_load_file(filename) char * filename CODE: ! DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, 1) ; ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; *************** *** 542,551 **** void * libhandle char * symbolname CODE: ! DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); ! DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; --- 542,551 ---- void * libhandle char * symbolname CODE: ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; *************** *** 567,573 **** void * symref char * filename CODE: ! DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); --- 567,573 ---- void * symref char * filename CODE: ! 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))); Index: ext/DynaLoader/dl_dld.xs *** perl5.003_01/ext/DynaLoader/dl_dld.xs Fri Oct 20 01:11:17 1995 --- perl5.003_02/ext/DynaLoader/dl_dld.xs Thu Aug 8 13:41:27 1996 *************** *** 62,68 **** if (dlderr) { char *msg = dld_strerror(dlderr); SaveError("dld_init(%s) failed: %s", origargv[0], msg); ! DLDEBUG(1,fprintf(stderr,"%s", LastError)); } #ifdef __linux__ } --- 62,68 ---- if (dlderr) { char *msg = dld_strerror(dlderr); SaveError("dld_init(%s) failed: %s", origargv[0], msg); ! DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "%s", LastError)); } #ifdef __linux__ } *************** *** 83,94 **** int dlderr,x,max; GV *gv; RETVAL = filename; ! DLDEBUG(1,fprintf(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)); if (dlderr = dld_create_reference(sym)) { SaveError("dld_create_reference(%s): %s", sym, dld_strerror(dlderr)); --- 83,94 ---- int dlderr,x,max; GV *gv; RETVAL = 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,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,102 **** } } ! DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", filename)); if (dlderr = dld_link(filename)) { SaveError("dld_link(%s): %s", filename, dld_strerror(dlderr)); goto haverror; --- 96,102 ---- } } ! 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,117 **** 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)); if (dlderr = dld_link(sym)) { SaveError("dld_link(%s): %s", sym, dld_strerror(dlderr)); goto haverror; } } ! DLDEBUG(2,fprintf(stderr,"libref=%s\n", RETVAL)); haverror: ST(0) = sv_newmortal() ; if (dlderr == 0) --- 105,117 ---- max = AvFILL(dl_resolve_using); for (x = 0; x <= max; x++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0)); ! 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,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL)); haverror: ST(0) = sv_newmortal() ; if (dlderr == 0) *************** *** 123,133 **** void * libhandle char * symbolname CODE: ! DLDEBUG(2,fprintf(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)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("dl_find_symbol: Unable to find '%s' symbol", symbolname) ; --- 123,133 ---- void * libhandle char * symbolname CODE: ! 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,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,163 **** void * symref char * filename CODE: ! DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); --- 157,163 ---- void * symref char * filename CODE: ! 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))); Index: ext/DynaLoader/dl_dlopen.xs *** perl5.003_01/ext/DynaLoader/dl_dlopen.xs Mon Feb 12 19:50:19 1996 --- perl5.003_02/ext/DynaLoader/dl_dlopen.xs Thu Aug 8 13:41:27 1996 *************** *** 151,159 **** if (dl_nonlazy) mode = RTLD_NOW; #endif ! DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; ! DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; --- 151,159 ---- if (dl_nonlazy) mode = RTLD_NOW; #endif ! DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; *************** *** 170,179 **** char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif ! DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); ! DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; --- 170,179 ---- char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; *************** *** 195,201 **** void * symref char * filename CODE: ! DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); --- 195,201 ---- void * symref char * filename CODE: ! 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))); Index: ext/DynaLoader/dl_hpux.xs *** perl5.003_01/ext/DynaLoader/dl_hpux.xs Fri Oct 20 01:13:15 1995 --- perl5.003_02/ext/DynaLoader/dl_hpux.xs Thu Aug 8 13:41:27 1996 *************** *** 52,68 **** 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)); obj = shl_load(sym, bind_type | BIND_NOSTART, 0L); if (obj == NULL) { goto end; } } ! DLDEBUG(1,fprintf(stderr,"dl_load_file(%s): ", filename)); obj = shl_load(filename, bind_type | BIND_NOSTART, 0L); ! DLDEBUG(2,fprintf(stderr," libref=%x\n", obj)); end: ST(0) = sv_newmortal() ; if (obj == NULL) --- 52,68 ---- max = AvFILL(dl_resolve_using); for (i = 0; i <= max; i++) { char *sym = SvPVX(*av_fetch(dl_resolve_using, i, 0)); ! 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,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename)); obj = shl_load(filename, bind_type | BIND_NOSTART, 0L); ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj)); end: ST(0) = sv_newmortal() ; if (obj == NULL) *************** *** 83,99 **** char symbolname_buf[MAXPATHLEN]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif ! DLDEBUG(2,fprintf(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)); 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)); } if (status == -1) { --- 83,99 ---- char symbolname_buf[MAXPATHLEN]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif ! 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,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,PerlIO_printf(PerlIO_stderr(), " symbolref(DATA) = %x\n", symaddr)); } if (status == -1) { *************** *** 117,123 **** void * symref char * filename CODE: ! DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); --- 117,123 ---- void * symref char * filename CODE: ! 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))); Index: ext/DynaLoader/dl_next.xs *** perl5.003_01/ext/DynaLoader/dl_next.xs Tue Jul 30 23:11:10 1996 --- perl5.003_02/ext/DynaLoader/dl_next.xs Thu Aug 8 13:41:27 1996 *************** *** 245,253 **** char * filename CODE: int mode = 1; ! DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; ! DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; --- 245,253 ---- char * filename CODE: int mode = 1; ! DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; *************** *** 264,273 **** char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif ! DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); ! DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; --- 264,273 ---- char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; *************** *** 289,295 **** void * symref char * filename CODE: ! DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); --- 289,295 ---- void * symref char * filename CODE: ! 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))); Index: ext/DynaLoader/dl_os2.xs *** perl5.003_01/ext/DynaLoader/dl_os2.xs Mon Mar 25 06:04:05 1996 --- perl5.003_02/ext/DynaLoader/dl_os2.xs Thu Aug 8 13:41:27 1996 *************** *** 126,134 **** #ifdef RTLD_LAZY mode = RTLD_LAZY; /* Solaris 2 */ #endif ! DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; ! DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; --- 126,134 ---- #ifdef RTLD_LAZY mode = RTLD_LAZY; /* Solaris 2 */ #endif ! DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", filename)); RETVAL = dlopen(filename, mode) ; ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; *************** *** 145,154 **** char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif ! DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); ! DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; --- 145,154 ---- char symbolname_buf[1024]; symbolname = dl_add_underscore(symbolname, symbolname_buf); #endif ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n", libhandle, symbolname)); RETVAL = dlsym(libhandle, symbolname); ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL)); ST(0) = sv_newmortal() ; if (RETVAL == NULL) SaveError("%s",dlerror()) ; *************** *** 173,179 **** void * symref char * filename CODE: ! DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); --- 173,179 ---- void * symref char * filename CODE: ! 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))); Index: ext/DynaLoader/dl_vms.xs *** perl5.003_01/ext/DynaLoader/dl_vms.xs Tue Jan 23 01:41:18 1996 --- perl5.003_02/ext/DynaLoader/dl_vms.xs Thu Aug 8 13:41:27 1996 *************** *** 126,132 **** 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)); return SS$_CONTINUE; } --- 126,132 ---- 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,PerlIO_printf(PerlIO_stderr(), "findsym_handler: received\n\t%s\n",LastError)); return SS$_CONTINUE; } *************** *** 177,187 **** 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)); /* 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)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; --- 177,187 ---- dlfab.fab$b_fns = strlen(vmsspec); dlfab.fab$l_dna = 0; dlfab.fab$b_dns = 0; ! 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,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,200 **** 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", dlnam.nam$b_name,vmsspec,deflen,defspec)); /* . . . and go back to expand it */ dlnam.nam$b_nop = 0; --- 194,200 ---- 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,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,208 **** 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)); if (!(sts & 1)) { dl_set_error(dlfab.fab$l_sts,dlfab.fab$l_stv); ST(0) = &sv_undef; --- 202,208 ---- dlfab.fab$b_dns = deflen; dlfab.fab$b_fns = dlnam.nam$b_name; sts = sys$parse(&dlfab); ! 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,223 **** else { /* Now find the actual file */ sts = sys$search(&dlfab); ! DLDEBUG(2,fprintf(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", dlnam.nam$b_rsl,dlnam.nam$l_rsa)); } } --- 210,223 ---- else { /* Now find the actual file */ sts = sys$search(&dlfab); ! 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,PerlIO_printf(PerlIO_stderr(), "\tresult = \\%.*s\\\n", dlnam.nam$b_rsl,dlnam.nam$l_rsa)); } } *************** *** 242,257 **** vmssts sts, failed = 0; void (*entry)(); ! DLDEBUG(1,fprintf(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", 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", sts,namlst[0].len,namlst[0].string)); if (!(sts & 1)) { failed = 1; --- 242,257 ---- vmssts sts, failed = 0; void (*entry)(); ! 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,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,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,287 **** 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", 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")); } else { symdsc.dsc$w_length = SvCUR(reqSV); symdsc.dsc$a_pointer = SvPVX(reqSV); ! DLDEBUG(2,fprintf(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)); if (!(sts&1)) { failed = 1; dl_set_error(sts,0); --- 267,287 ---- memcpy(dlptr->defspec.dsc$a_pointer + deflen, namlst[0].string + namlst[0].len, dlptr->defspec.dsc$w_length - deflen); ! 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,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,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,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts)); if (!(sts&1)) { failed = 1; dl_set_error(sts,0); *************** *** 311,323 **** void (*entry)(); vmssts sts; ! DLDEBUG(1,fprintf(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", (unsigned long int) entry)); if (!(sts & 1)) { /* error message already saved by findsym_handler */ --- 311,323 ---- void (*entry)(); vmssts sts; ! 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,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,345 **** void * symref char * filename CODE: ! DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n", perl_name, symref)); ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename))); --- 339,345 ---- void * symref char * filename CODE: ! 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))); Index: ext/DynaLoader/dlutils.c *** perl5.003_01/ext/DynaLoader/dlutils.c Tue Jul 30 23:11:10 1996 --- perl5.003_02/ext/DynaLoader/dlutils.c Thu Aug 8 13:42:04 1996 *************** *** 35,41 **** 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")); #ifdef DL_LOADONCEONLY if (!dl_loaded_files) dl_loaded_files = newHV(); /* provide cache for dl_*.xs if needed */ --- 35,41 ---- if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL ) dl_nonlazy = atoi(perl_dl_nonlazy); if (dl_nonlazy) ! 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,85 **** /* Copy message into LastError (including terminating null char) */ strncpy(LastError, message, len) ; ! DLDEBUG(2,fprintf(stderr,"DynaLoader: stored error msg '%s'\n",LastError)); } --- 79,85 ---- /* Copy message into LastError (including terminating null char) */ strncpy(LastError, message, len) ; ! DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError)); } Index: ext/FileHandle/FileHandle.xs *** perl5.003_01/ext/FileHandle/FileHandle.xs Tue Jul 30 23:11:11 1996 --- perl5.003_02/ext/FileHandle/FileHandle.xs Fri Aug 9 17:10:06 1996 *************** *** 1,10 **** #include "EXTERN.h" #include "perl.h" #include "XSUB.h" typedef int SysRet; ! typedef FILE * InputStream; ! typedef FILE * OutputStream; static int not_here(s) --- 1,11 ---- #include "EXTERN.h" + #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" typedef int SysRet; ! typedef PerlIO * InputStream; ! typedef PerlIO * OutputStream; static int not_here(s) *************** *** 64,98 **** fgetpos(handle) InputStream handle CODE: - #ifdef HAS_FGETPOS if (handle) { Fpos_t pos; ! fgetpos(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)); else { RETVAL = -1; errno = EINVAL; } - #else - RETVAL = (SysRet) not_here("fsetpos"); - #endif OUTPUT: RETVAL --- 65,91 ---- fgetpos(handle) InputStream handle CODE: if (handle) { Fpos_t pos; ! PerlIO_getpos(handle, &pos); ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); } else { ST(0) = &sv_undef; errno = EINVAL; } SysRet fsetpos(handle, pos) InputStream handle SV * pos CODE: if (handle) ! RETVAL = PerlIO_setpos(handle, (Fpos_t*)SvPVX(pos)); else { RETVAL = -1; errno = EINVAL; } OUTPUT: RETVAL *************** *** 102,108 **** int c CODE: if (handle) ! RETVAL = ungetc(c, handle); else { RETVAL = -1; errno = EINVAL; --- 95,101 ---- int c CODE: if (handle) ! RETVAL = PerlIO_ungetc(handle, c); else { RETVAL = -1; errno = EINVAL; *************** *** 114,120 **** new_tmpfile(packname = "FileHandle") char * packname CODE: ! RETVAL = tmpfile(); OUTPUT: RETVAL --- 107,113 ---- new_tmpfile(packname = "FileHandle") char * packname CODE: ! RETVAL = PerlIO_tmpfile(); OUTPUT: RETVAL *************** *** 123,129 **** InputStream handle CODE: if (handle) ! RETVAL = ferror(handle); else { RETVAL = -1; errno = EINVAL; --- 116,122 ---- InputStream handle CODE: if (handle) ! RETVAL = PerlIO_error(handle); else { RETVAL = -1; errno = EINVAL; *************** *** 136,142 **** OutputStream handle CODE: if (handle) ! RETVAL = Fflush(handle); else { RETVAL = -1; errno = EINVAL; --- 129,135 ---- OutputStream handle CODE: if (handle) ! RETVAL = PerlIO_flush(handle); else { RETVAL = -1; errno = EINVAL; *************** *** 149,157 **** OutputStream handle char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; CODE: if (handle) setbuf(handle, buf); ! SysRet --- 142,153 ---- 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,166 **** --- 157,163 ---- 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,176 **** --- 168,176 ---- #else RETVAL = (SysRet) not_here("setvbuf"); #endif /* _IOFBF */ + #else + RETVAL = (SysRet) not_here("setvbuf"); + #endif OUTPUT: RETVAL Index: ext/IO/IO.xs *** perl5.003_01/ext/IO/IO.xs Tue Jul 30 23:11:12 1996 --- perl5.003_02/ext/IO/IO.xs Sat Aug 10 14:34:25 1996 *************** *** 1,13 **** #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef I_UNISTD # include #endif typedef int SysRet; ! typedef FILE * InputStream; ! typedef FILE * OutputStream; static int not_here(s) --- 1,18 ---- #include "EXTERN.h" + #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" + #ifdef I_UNISTD # include #endif + #ifdef I_FCNTL + # include + #endif typedef int SysRet; ! typedef PerlIO * InputStream; ! typedef PerlIO * OutputStream; static int not_here(s) *************** *** 62,73 **** #else return FALSE; #endif - if (strEQ(name, "SEEK_EOF")) - #ifdef SEEK_EOF - { *pval = SEEK_EOF; return TRUE; } - #else - return FALSE; - #endif break; } --- 67,72 ---- *************** *** 81,115 **** fgetpos(handle) InputStream handle CODE: - #ifdef HAS_FGETPOS if (handle) { Fpos_t pos; ! fgetpos(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)); else { RETVAL = -1; errno = EINVAL; } - #else - RETVAL = (SysRet) not_here("IO::Seekable::fsetpos"); - #endif OUTPUT: RETVAL --- 80,106 ---- fgetpos(handle) InputStream handle CODE: if (handle) { Fpos_t pos; ! PerlIO_getpos(handle, &pos); ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); } else { ST(0) = &sv_undef; errno = EINVAL; } SysRet fsetpos(handle, pos) InputStream handle SV * pos CODE: if (handle) ! RETVAL = PerlIO_setpos(handle, (Fpos_t*)SvPVX(pos)); else { RETVAL = -1; errno = EINVAL; } OUTPUT: RETVAL *************** *** 119,125 **** new_tmpfile(packname = "IO::File") char * packname CODE: ! RETVAL = tmpfile(); OUTPUT: RETVAL --- 110,116 ---- new_tmpfile(packname = "IO::File") char * packname CODE: ! RETVAL = PerlIO_tmpfile(); OUTPUT: RETVAL *************** *** 141,147 **** int c CODE: if (handle) ! RETVAL = ungetc(c, handle); else { RETVAL = -1; errno = EINVAL; --- 132,138 ---- int c CODE: if (handle) ! RETVAL = PerlIO_ungetc(handle, c); else { RETVAL = -1; errno = EINVAL; *************** *** 154,160 **** InputStream handle CODE: if (handle) ! RETVAL = ferror(handle); else { RETVAL = -1; errno = EINVAL; --- 145,151 ---- InputStream handle CODE: if (handle) ! RETVAL = PerlIO_error(handle); else { RETVAL = -1; errno = EINVAL; *************** *** 167,173 **** OutputStream handle CODE: if (handle) ! RETVAL = Fflush(handle); else { RETVAL = -1; errno = EINVAL; --- 158,164 ---- OutputStream handle CODE: if (handle) ! RETVAL = PerlIO_flush(handle); else { RETVAL = -1; errno = EINVAL; *************** *** 181,189 **** char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; CODE: if (handle) setbuf(handle, buf); ! ! SysRet setvbuf(handle, buf, type, size) --- 172,182 ---- 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,197 **** --- 185,191 ---- 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,207 **** --- 196,204 ---- #else RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); #endif /* _IOFBF */ + #else + not_here("IO::Handle::setvbuf"); + #endif OUTPUT: RETVAL Index: ext/IO/lib/IO/Handle.pm *** perl5.003_01/ext/IO/lib/IO/Handle.pm Tue Jul 30 23:11:14 1996 --- perl5.003_02/ext/IO/lib/IO/Handle.pm Tue Jul 23 14:28:12 1996 *************** *** 186,192 **** @FileHandle::ISA = qw(IO::Handle); ! $VERSION = sprintf("%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/); @EXPORT_OK = qw( autoflush --- 186,192 ---- @FileHandle::ISA = qw(IO::Handle); ! $VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/); @EXPORT_OK = qw( autoflush *************** *** 259,266 **** IO::Handle::fdopen($fh, @_) or return undef; bless $fh, $class; - $fh->_ref_fd; - $fh; } # FileHandle::DESTROY use to call close(). This creates a problem --- 259,264 ---- Index: ext/IO/lib/IO/Select.pm *** perl5.003_01/ext/IO/lib/IO/Select.pm Tue Jul 30 23:11:15 1996 --- perl5.003_02/ext/IO/lib/IO/Select.pm Fri Aug 9 09:18:14 1996 *************** *** 49,55 **** =item remove ( HANDLES ) ! Remove all the given handles from the object. =item can_read ( [ TIMEOUT ] ) --- 49,57 ---- =item remove ( HANDLES ) ! Remove all the given handles from the object. This method also works ! by the C of the handles. So the exact handles that were added ! need not be passed, just handles that have an equivalent C =item can_read ( [ TIMEOUT ] ) *************** *** 66,71 **** --- 68,79 ---- Same as C 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 methods is called or the object is passed to + the C is a static method, that is you call it with the package name *************** *** 132,143 **** @ISA = qw(Exporter); # This is only so we can do version checking sub new { my $self = shift; my $type = ref($self) || $self; ! my $vec = bless [''], $type; $vec->add(@_) if @_; --- 140,155 ---- @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 [undef,0], $type; $vec->add(@_) if @_; *************** *** 150,163 **** my $vec = shift; my $f; foreach $f (@_) { my $fn = $f =~ /^\d+$/ ? $f : fileno($f); next unless defined $fn; ! vec($vec->[0],$fn++,1) = 1; ! $vec->[$fn] = $f; } } sub remove --- 162,180 ---- 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->[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,178 **** my $fn = $f =~ /^\d+$/ ? $f : fileno($f); next unless defined $fn; ! vec($vec->[0],$fn++,1) = 0; ! $vec->[$fn] = undef; } } sub can_read --- 187,197 ---- my $fn = $f =~ /^\d+$/ ? $f : fileno($f); next unless defined $fn; ! 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,186 **** my $vec = shift; my $timeout = shift; ! my $r = $vec->[0]; select($r,undef,undef,$timeout) > 0 ? _handles($vec, $r) --- 199,205 ---- my $vec = shift; my $timeout = shift; ! my $r = $vec->[VEC_BITS] or return (); select($r,undef,undef,$timeout) > 0 ? _handles($vec, $r) *************** *** 192,198 **** my $vec = shift; my $timeout = shift; ! my $w = $vec->[0]; select(undef,$w,undef,$timeout) > 0 ? _handles($vec, $w) --- 211,217 ---- my $vec = shift; my $timeout = shift; ! my $w = $vec->[VEC_BITS] or return (); select(undef,$w,undef,$timeout) > 0 ? _handles($vec, $w) *************** *** 204,216 **** my $vec = shift; my $timeout = shift; ! my $e = $vec->[0]; select(undef,undef,$e,$timeout) > 0 ? _handles($vec, $e) : (); } sub _max { my($a,$b,$c) = @_; --- 223,241 ---- my $vec = shift; my $timeout = shift; ! 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,258 **** 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; 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); ! for( ; $i > 0 ; $i--) { ! my $j = $i - 1; push(@r, $r->[$i]) ! if defined $r->[$i] && vec($rb, $j, 1); push(@w, $w->[$i]) ! if defined $w->[$i] && vec($wb, $j, 1); push(@e, $e->[$i]) ! if defined $e->[$i] && vec($eb, $j, 1); } @result = (\@r, \@w, \@e); --- 256,283 ---- my($r,$w,$e,$t) = @_; my @result = (); ! 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)-1 : 0, ! defined $w ? scalar(@$w)-1 : 0, ! defined $e ? scalar(@$e)-1 : 0); ! for( ; $i >= FIRST_FD ; $i--) { ! my $j = $i - FIRST_FD; push(@r, $r->[$i]) ! if defined $rb && defined $r->[$i] && vec($rb, $j, 1); push(@w, $w->[$i]) ! if defined $wb && defined $w->[$i] && vec($wb, $j, 1); push(@e, $e->[$i]) ! if defined $eb && defined $e->[$i] && vec($eb, $j, 1); } @result = (\@r, \@w, \@e); *************** *** 267,280 **** my @h = (); my $i; ! for($i = scalar(@$vec) - 1 ; $i > 0 ; $i--) { next unless defined $vec->[$i]; push(@h, $vec->[$i]) ! if vec($bits,$i - 1,1); } @h; } 1; --- 292,306 ---- my @h = (); my $i; ! for($i = scalar(@$vec) - 1 ; $i >= FIRST_FD ; $i--) { next unless defined $vec->[$i]; push(@h, $vec->[$i]) ! if vec($bits,$i - FIRST_FD,1); } @h; } 1; + Index: ext/IO/lib/IO/Socket.pm *** perl5.003_01/ext/IO/lib/IO/Socket.pm Tue Jul 30 23:11:16 1996 --- perl5.003_02/ext/IO/lib/IO/Socket.pm Tue Jul 23 14:28:12 1996 *************** *** 76,83 **** @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}; sub import { my $pkg = shift; my $callpkg = caller; --- 76,84 ---- @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.9 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; + sub import { my $pkg = shift; my $callpkg = caller; *************** *** 131,137 **** local($SIG{ALRM}) = $timeout ? sub { undef $fh; } : $SIG{ALRM} || 'DEFAULT'; ! eval { croak 'connect: Bad address' if(@_ == 2 && !defined $_[1]); --- 132,138 ---- local($SIG{ALRM}) = $timeout ? sub { undef $fh; } : $SIG{ALRM} || 'DEFAULT'; ! eval { croak 'connect: Bad address' if(@_ == 2 && !defined $_[1]); *************** *** 140,156 **** $timeout = 0; } ! my $ok = eval { connect($fh, $addr) }; alarm(0) if($timeout); ! croak "connect: timeout" ! unless defined $fh; ! ! undef $fh unless $ok; }; $fh; } --- 141,157 ---- $timeout = 0; } ! my $ok = connect($fh, $addr); alarm(0) if($timeout); ! croak "connect: timeout" ! unless defined $fh; + undef $fh unless $ok; }; + $fh; } *************** *** 544,557 **** =head1 REVISION ! $Revision: 1.8 $ 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 ! =head1 COPYRIGHT Copyright (c) 1995 Graham Barr. All rights reserved. This program is free --- 545,558 ---- =head1 REVISION ! $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 ! =head1 COPYRIGHT Copyright (c) 1995 Graham Barr. All rights reserved. This program is free Index: ext/Opcode/Opcode.xs *** perl5.003_01/ext/Opcode/Opcode.xs Tue Jul 30 23:11:18 1996 --- perl5.003_02/ext/Opcode/Opcode.xs Mon Aug 5 15:51:06 1996 *************** *** 233,239 **** BOOT: assert(maxo < OP_MASK_BUF_SIZE); ! opset_len = (maxo / 8) + 1; if (opcode_debug >= 1) warn("opset_len %d\n", opset_len); op_names_init(); --- 233,239 ---- BOOT: assert(maxo < OP_MASK_BUF_SIZE); ! opset_len = (maxo + 7) / 8; if (opcode_debug >= 1) warn("opset_len %d\n", opset_len); op_names_init(); Index: ext/POSIX/POSIX.xs *** perl5.003_01/ext/POSIX/POSIX.xs Mon Mar 25 06:04:06 1996 --- perl5.003_02/ext/POSIX/POSIX.xs Fri Aug 9 17:10:21 1996 *************** *** 1,4 **** --- 1,5 ---- #include "EXTERN.h" + #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" #include *************** *** 243,255 **** #endif #ifndef HAS_WAITPID #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 --- 244,249 ---- Index: ext/POSIX/mkposixman.pl *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/ext/POSIX/mkposixman.pl Mon Feb 19 18:31:03 1996 *************** *** 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.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 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. + + $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. + + The following will determine the maximum length of the longest allowable + pathname on the filesystem which holds C. + + $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. The data returned is identical to the data from + Perl's builtin C 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 (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. + + $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(){ + 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 on failure.\n\n"; + } + $ret = 1; + } + $ret; + } + } + + Create an interprocess channel. This returns file descriptors like those + returned by C. + + ($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. 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. + Detailed signal management. This uses C objects for the + C and C arguments. Consult your system's C + manpage for details. + + Synopsis: + + sigaction(sig, action, oldaction = 0) + Install a signal mask and suspend process until signal arrives. This uses + C objects for the C argument. Consult your + system's C manpage for details. + + Synopsis: + + sigsuspend(signal_mask) + This is identical to Perl's builtin C 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), weekday (C), and yearday (C) begin at zero. + I.e. January is 0, not 1; Sunday is 0, not 1; January 1st is 0, not 1. The + year (C) is given in years since 1900. I.e. The year 1995 is 95; the + year 2001 is 101. Consult your system's C 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 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. + + $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. Index: global.sym *** perl5.003_01/global.sym Tue Jul 30 23:11:20 1996 --- perl5.003_02/global.sym Tue Aug 6 10:00:51 1996 *************** *** 40,50 **** --- 40,53 ---- curcopdb curinterp curpad + cv_const_sv dc + debug dec_amg di div_amg div_ass_amg + do_undump ds egid envgv Index: gv.c *** perl5.003_01/gv.c Tue Jul 30 23:11:21 1996 --- perl5.003_02/gv.c Sat Aug 3 09:11:03 1996 *************** *** 241,249 **** /* 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")) { /* Now look for @.*::SUPER::ISA */ GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); 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 --- 241,250 ---- /* Failed obvious case - look for SUPER as last element of stash's name */ char *packname = HvNAME(stash); STRLEN len = strlen(packname); ! 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 Index: handy.h *** perl5.003_01/handy.h Tue Jul 30 23:11:22 1996 --- perl5.003_02/handy.h Thu Aug 1 10:10:26 1996 *************** *** 20,26 **** #define Null(type) ((type)NULL) #define Nullch Null(char*) ! #define Nullfp Null(FILE*) #define Nullsv Null(SV*) #ifdef TRUE --- 20,26 ---- #define Null(type) ((type)NULL) #define Nullch Null(char*) ! #define Nullfp Null(PerlIO*) #define Nullsv Null(SV*) #ifdef TRUE Index: hints/README.NeXT *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/hints/README.NeXT Thu Aug 1 10:18:19 1996 *************** *** 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 + 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 + sh Configure -des + make + make test + make install + + Index: hints/next_3.sh *** perl5.003_01/hints/next_3.sh Tue Jul 30 23:11:24 1996 --- perl5.003_02/hints/next_3.sh Thu Aug 1 09:21:20 1996 *************** *** 1,11 **** ! # This file has been put together by Anno Siegel ! # and Andreas Koenig . 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' POSIX_cflags='ccflags="-posix $ccflags"' ldflags='-u libsys_s' libswanted='dbm gdbm db' --- 1,12 ---- ! # This file has been put together by Anno Siegel , ! # Andreas Koenig and Gerd Knops . ! # 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 -DUSE_PERL_SBRK -DHIDEMYMALLOC' POSIX_cflags='ccflags="-posix $ccflags"' ldflags='-u libsys_s' libswanted='dbm gdbm db' *************** *** 15,21 **** --- 16,27 ---- # 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,42 **** 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() ! usemymalloc='n' 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 ) ranlib='sleep 5; /bin/ranlib' # # There where reports that the compiler on HPPA machines # fails with the -O flag on pp.c. --- 29,76 ---- 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() ! # ! # 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." ! # ranlib='sleep 5; /bin/ranlib' + # # There where reports that the compiler on HPPA machines # fails with the -O flag on pp.c. Index: hints/next_4.sh *** perl5.003_01/hints/next_4.sh Tue Jul 30 23:11:24 1996 --- perl5.003_02/hints/next_4.sh Thu Aug 1 09:28:33 1996 *************** *** 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): --- 1,4 ---- ! ###################################################################### # # IMPORTANT: before you run 'make', you need to enter one of these two # lines (depending on your shell): *************** *** 6,11 **** --- 6,15 ---- # or # setenv DYLD_LIBRARY_PATH `pwd` # + ###################################################################### + + # Posix support has been removed from NextStep + # useposix='undef' altmake='gnumake' *************** *** 14,31 **** libc='/NextLibrary/Frameworks/System.framework/System' isnext_4='define' mab='-arch m68k -arch i386 -arch sparc' ldflags='-dynamic -prebind' lddlflags='-dynamic -bundle -undefined suppress' ! ccflags='-dynamic -fno-common -DUSE_NEXT_CTYPE' cccdlflags='none' ld='cc' ! optimize='-g -O' d_shrplib='define' dlext='bundle' so='dylib' prefix='/usr/local/OPENSTEP' #archlib='/usr/lib/perl5' #archlibexp='/usr/lib/perl5' --- 18,45 ---- 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 -DUSE_PERL_SBRK -DHIDEMYMALLOC' cccdlflags='none' ld='cc' ! #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,45 **** groupstype='int' direntrytype='struct direct' # 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' clocktype='int' # --- 51,83 ---- 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() ! # ! # 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' # Index: hints/os2.sh *** perl5.003_01/hints/os2.sh Tue Jul 30 23:11:25 1996 --- perl5.003_02/hints/os2.sh Mon Aug 5 09:23:40 1996 *************** *** 16,21 **** --- 16,23 ---- 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,83 **** ar='emxomfar' plibext='.lib' d_fork='undef' ! lddlflags='-Zdll -Zomf -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' use_clib='c_import' usedl='define' fi --- 76,85 ---- ar='emxomfar' plibext='.lib' d_fork='undef' ! lddlflags='-Zdll -Zomf -Zmt -Zcrtdll' # Recursive regmatch may eat 2.5M of stack alone. ! 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,164 **** --- 164,198 ---- # 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 Index: interp.sym *** perl5.003_01/interp.sym Tue Jul 30 23:11:27 1996 --- perl5.003_02/interp.sym Mon Aug 5 11:14:00 1996 *************** *** 31,37 **** debdelim debname debstash - debug defgv defoutgv defstash --- 31,36 ---- *************** *** 40,46 **** dirty dlevel dlmax - do_undump doextract doswitches dowarn --- 39,44 ---- Index: lib/ExtUtils/MM_Unix.pm Prereq: 1.105 *** perl5.003_01/lib/ExtUtils/MM_Unix.pm Tue Jul 30 23:11:31 1996 --- perl5.003_02/lib/ExtUtils/MM_Unix.pm Mon Aug 5 09:20:59 1996 *************** *** 1147,1154 **** 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){ $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL")); } elsif ($name =~ /\.xs$/){ my($c); ($c = $name) =~ s/\.xs$/.c/; --- 1147,1154 ---- 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); 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,1378 **** # 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) { # As of 5.001m, dl_os2 appends '_' $self->{DLBASE} = $modfname; } else { --- 1365,1375 ---- # It may also edit @modparts if required. if (defined &DynaLoader::mod2fname) { $modfname = &DynaLoader::mod2fname(\@modparts); ! } ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!([\w:]+::)?(\w+)$! ; ! if (defined &DynaLoader::mod2fname) { # As of 5.001m, dl_os2 appends '_' $self->{DLBASE} = $modfname; } else { *************** *** 2609,2622 **** my(@m); push(@m, <<'END'); $(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists 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) $@ }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld $(CHMOD) 755 $@ }; --- 2606,2619 ---- 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{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@ }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld $(CHMOD) 755 $@ }; Index: lib/ExtUtils/MakeMaker.pm *** perl5.003_01/lib/ExtUtils/MakeMaker.pm Tue Jul 30 23:11:33 1996 --- perl5.003_02/lib/ExtUtils/MakeMaker.pm Mon Aug 5 09:20:59 1996 *************** *** 25,32 **** ); # use strict; ! eval {require DynaLoader;}; # Get mod2fname, if defined. Will fail ! # with miniperl. # # Set up the inheritance before we pull in the MM_* packages, because they --- 25,33 ---- ); # use strict; ! # &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 Index: lib/ExtUtils/Mksymlists.pm *** perl5.003_01/lib/ExtUtils/Mksymlists.pm Mon Jun 24 01:52:59 1996 --- perl5.003_02/lib/ExtUtils/Mksymlists.pm Mon Aug 5 09:20:59 1996 *************** *** 40,45 **** --- 40,46 ---- } # 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}) ]); Index: lib/Test/Harness.pm *** perl5.003_01/lib/Test/Harness.pm Tue Jul 30 23:11:38 1996 --- perl5.003_02/lib/Test/Harness.pm Mon Aug 5 09:20:58 1996 *************** *** 5,11 **** use Benchmark; use Config; use FileHandle; ! use vars qw($VERSION $verbose $switches $have_devel_corestack); $have_devel_corestack = 0; $VERSION = "1.12"; --- 5,14 ---- use Benchmark; use Config; use FileHandle; ! use strict; ! ! use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest ! @ISA @EXPORT @EXPORT_OK); $have_devel_corestack = 0; $VERSION = "1.12"; *************** *** 14,19 **** --- 17,39 ---- @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,27 **** sub runtests { my(@tests) = @_; local($|) = 1; ! my($test,$te,$ok,$next,$max,$pct); my $totmax = 0; my $files = 0; my $bad = 0; --- 41,47 ---- sub runtests { my(@tests) = @_; local($|) = 1; ! my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests); my $totmax = 0; my $files = 0; my $bad = 0; *************** *** 82,87 **** --- 102,112 ---- } } $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,107 **** push @failed, $next..$max; } if (@failed) { ! print canonfailed($max,@failed); } else { print "Don't know which tests failed: got $ok ok, expected $max\n"; } $bad++; } elsif ($next == 0) { print "FAILED before any test output arrived\n"; $bad++; } } my $t_total = timediff(new Benchmark, $t_start); --- 119,148 ---- push @failed, $next..$max; } if (@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,125 **** $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 { die "Failed $bad/$total test scripts, $pct% okay.$subpct\n"; } } --- 158,169 ---- $pct = sprintf("%.2f", $good / $total * 100); my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.", $totmax - $totok, $totmax, 100*$totok/$totmax; ! 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,159 **** --- 198,204 ---- 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,180 **** } local $" = ", "; push @result, "FAILED tests @canon\n"; } else { push @result, "FAILED test $last\n"; } push @result, "\tFailed $failed/$max tests, "; push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n"; ! join "", @result; } 1; --- 213,228 ---- } 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"; ! my $txt = join "", @result; ! ($txt, $canon); } 1; Index: lib/Text/ParseWords.pm *** perl5.003_01/lib/Text/ParseWords.pm Tue Jul 30 23:11:38 1996 --- perl5.003_02/lib/Text/ParseWords.pm Thu Aug 8 14:03:59 1996 *************** *** 115,121 **** last; } else { ! while (length($_) && !(/^$delim/ || /^['"\\]/)) { $snippet .= substr($_, 0, 1); substr($_, 0, 1) = ''; } --- 115,121 ---- last; } else { ! while ($_ && !(/^$delim/ || /^['"\\]/)) { $snippet .= substr($_, 0, 1); substr($_, 0, 1) = ''; } Index: makedepend.SH *** perl5.003_01/makedepend.SH Tue Jul 30 23:11:47 1996 --- perl5.003_02/makedepend.SH Mon Aug 5 09:20:58 1996 *************** *** 124,133 **** $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): mv .shlist .shlist.old $egrep -v '^makedepend\.SH' <.shlist.old >.shlist rm .shlist.old if $test -s .deptmp; then --- 124,135 ---- $MAKE shlist || ($echo "Searching for .SH files..."; \ $echo *.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist) ! # 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 Index: malloc.c *** perl5.003_01/malloc.c Tue Jul 30 23:11:48 1996 --- perl5.003_02/malloc.c Thu Aug 8 13:32:27 1996 *************** *** 22,27 **** --- 22,32 ---- #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,70 **** #define ov_rmagic ovu.ovu_rmagic }; ! #ifdef debug static void botch _((char *s)); #endif static void morecore _((int bucket)); --- 69,75 ---- #define ov_rmagic ovu.ovu_rmagic }; ! #ifdef DEBUGGING static void botch _((char *s)); #endif static void morecore _((int bucket)); *************** *** 160,169 **** * for a given block size. */ static u_int nmalloc[NBUCKETS]; - #include #endif ! #ifdef debug #define ASSERT(p) if (!(p)) botch("p"); else static void botch(s) --- 165,173 ---- * for a given block size. */ static u_int nmalloc[NBUCKETS]; #endif ! #ifdef DEBUGGING #define ASSERT(p) if (!(p)) botch("p"); else static void botch(s) *************** *** 192,198 **** #ifdef MSDOS if (nbytes > 0xffff) { ! fprintf(stderr, "Allocation too large: %lx\n", (long)nbytes); my_exit(1); } #endif /* MSDOS */ --- 196,202 ---- #ifdef MSDOS if (nbytes > 0xffff) { ! PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", (long)nbytes); my_exit(1); } #endif /* MSDOS */ *************** *** 231,237 **** if ((p = (union overhead *)nextf[bucket]) == NULL) { #ifdef safemalloc if (!nomemok) { ! fputs("Out of memory!\n", stderr); my_exit(1); } #else --- 235,241 ---- if ((p = (union overhead *)nextf[bucket]) == NULL) { #ifdef safemalloc if (!nomemok) { ! PerlIO_puts(PerlIO_stderr(),"Out of memory!\n"); my_exit(1); } #else *************** *** 240,253 **** } #ifdef safemalloc ! DEBUG_m(fprintf(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", (unsigned long)*((int*)p),(unsigned long)p); #endif nextf[bucket] = p->ov_next; --- 244,257 ---- } #ifdef safemalloc ! 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)) ! 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,396 **** #endif #ifdef safemalloc ! DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) free\n",(unsigned long)cp,an++)); #endif /* safemalloc */ if (cp == NULL) --- 394,400 ---- #endif #ifdef safemalloc ! DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(unsigned long)cp,an++)); #endif /* safemalloc */ if (cp == NULL) *************** *** 400,406 **** #ifdef PACK_MALLOC bucket = OV_INDEX(op); #endif ! #ifdef debug ASSERT(OV_MAGIC(op, bucket) == MAGIC); /* make sure it was in use */ #else if (OV_MAGIC(op, bucket) != MAGIC) { --- 404,410 ---- #ifdef PACK_MALLOC bucket = OV_INDEX(op); #endif ! #ifdef DEBUGGING ASSERT(OV_MAGIC(op, bucket) == MAGIC); /* make sure it was in use */ #else if (OV_MAGIC(op, bucket) != MAGIC) { *************** *** 467,473 **** #ifdef MSDOS if (nbytes > 0xffff) { ! fprintf(stderr, "Reallocation too large: %lx\n", size); my_exit(1); } #endif /* MSDOS */ --- 471,477 ---- #ifdef MSDOS if (nbytes > 0xffff) { ! PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size); my_exit(1); } #endif /* MSDOS */ *************** *** 542,549 **** #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", (unsigned long)res,an++,(long)size); } #endif --- 546,553 ---- #ifdef safemalloc #ifdef DEBUGGING if (debug & 128) { ! 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,635 **** topbucket = i; } if (s) ! fprintf(stderr, "Memory allocation statistics %s (buckets 8..%d)\n", s, (1 << (topbucket + 3)) ); ! fprintf(stderr, " %7d free: ", totfree); for (i=0; i <= topbucket; i++) { ! fprintf(stderr, (i<5)?" %5d":" %3d", nfree[i]); } ! fprintf(stderr, "\n %7d used: ", totused); for (i=0; i <= topbucket; i++) { ! fprintf(stderr, (i<5)?" %5d":" %3d", nmalloc[i]); } ! fprintf(stderr, "\n"); #ifdef PACK_MALLOC if (sbrk_slack || start_slack) { ! fprintf(stderr, "Odd ends: %7d bytes from sbrk(), %7d from malloc.\n", sbrk_slack, start_slack); } #endif --- 620,639 ---- topbucket = i; } if (s) ! PerlIO_printf(PerlIO_stderr(), "Memory allocation statistics %s (buckets 8..%d)\n", s, (1 << (topbucket + 3)) ); ! PerlIO_printf(PerlIO_stderr(), " %7d free: ", totfree); for (i=0; i <= topbucket; i++) { ! PerlIO_printf(PerlIO_stderr(), (i<5)?" %5d":" %3d", nfree[i]); } ! PerlIO_printf(PerlIO_stderr(), "\n %7d used: ", totused); for (i=0; i <= topbucket; i++) { ! PerlIO_printf(PerlIO_stderr(), (i<5)?" %5d":" %3d", nmalloc[i]); } ! PerlIO_printf(PerlIO_stderr(), "\n"); #ifdef PACK_MALLOC if (sbrk_slack || start_slack) { ! PerlIO_printf(PerlIO_stderr(), "Odd ends: %7d bytes from sbrk(), %7d from malloc.\n", sbrk_slack, start_slack); } #endif *************** *** 646,677 **** #ifdef USE_PERL_SBRK ! #ifdef NeXT ! #ifdef HIDEMYMALLOC ! #undef malloc ! #else ! #include "Error: -DUSE_PERL_SBRK on the NeXT 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 static IV Perl_sbrk_oldchunk; static long Perl_sbrk_oldsize; ! #define PERLSBRK_32_K (1<<15) ! #define PERLSBRK_64_K (1<<16) char * Perl_sbrk(size) --- 650,680 ---- #ifdef USE_PERL_SBRK ! # 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) + # 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) char * Perl_sbrk(size) *************** *** 707,713 **** } #ifdef safemalloc ! DEBUG_m(fprintf(stderr,"sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n", size, reqsize, Perl_sbrk_oldsize, got)); #endif --- 710,716 ---- } #ifdef safemalloc ! 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 Index: mg.c *** perl5.003_01/mg.c Tue Jul 30 23:11:48 1996 --- perl5.003_02/mg.c Fri Aug 9 10:10:42 1996 *************** *** 99,104 **** --- 99,105 ---- MGS* mgs; MAGIC* mg; MAGIC** mgp; + int mgp_valid = 0; ENTER; mgs = save_magic(sv); *************** *** 109,120 **** 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)) mgs->mgs_flags = 0; } /* Advance to next magic (complicated by possible deletion) */ ! if (*mgp == mg) mgp = &mg->mg_moremagic; } LEAVE; --- 110,125 ---- if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { (*vtbl->svt_get)(sv, mg); /* Ignore this magic if it's been deleted */ ! 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 (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,670 **** if(psig_ptr[i]) sv_setsv(sv,psig_ptr[i]); else { ! void (*origsig)(int); /* get signal state without losing signals */ sig_trapped=0; origsig = rsignal(i,sig_trap); --- 669,675 ---- if(psig_ptr[i]) sv_setsv(sv,psig_ptr[i]); else { ! void (*origsig) _((int)); /* get signal state without losing signals */ sig_trapped=0; origsig = rsignal(i,sig_trap); *************** *** 765,770 **** --- 770,777 ---- *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,1459 **** --- 1461,1470 ---- 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)) { Index: myconfig *** perl5.003_01/myconfig Tue Jul 30 23:11:49 1996 --- perl5.003_02/myconfig Thu Aug 8 15:54:08 1996 *************** *** 24,29 **** --- 24,30 ---- 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' Index: nostdio.h *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/nostdio.h Sat Aug 10 13:05:20 1996 *************** *** 0 **** --- 1,25 ---- + /* This is an 1st attempt to stop other include files pulling + in real . + 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 + Index: op.c *** perl5.003_01/op.c Tue Jul 30 23:11:50 1996 --- perl5.003_02/op.c Thu Aug 8 09:45:53 1996 *************** *** 321,327 **** } SvFLAGS(sv) |= tmptype; curpad = AvARRAY(comppad); ! DEBUG_X(fprintf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); return (PADOFFSET)retval; } --- 321,327 ---- } SvFLAGS(sv) |= tmptype; curpad = AvARRAY(comppad); ! DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype])); return (PADOFFSET)retval; } *************** *** 335,341 **** { if (!po) croak("panic: pad_sv po"); ! DEBUG_X(fprintf(Perl_debug_log, "Pad sv %d\n", po)); return curpad[po]; /* eventually we'll turn this into a macro */ } --- 335,341 ---- { if (!po) croak("panic: pad_sv 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,359 **** croak("panic: pad_free curpad"); if (!po) croak("panic: pad_free po"); ! DEBUG_X(fprintf(Perl_debug_log, "Pad free %d\n", po)); if (curpad[po] && curpad[po] != &sv_undef) SvPADTMP_off(curpad[po]); if ((I32)po < padix) --- 353,359 ---- croak("panic: pad_free curpad"); if (!po) croak("panic: pad_free 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,378 **** croak("panic: pad_swipe curpad"); if (!po) croak("panic: pad_swipe po"); ! DEBUG_X(fprintf(Perl_debug_log, "Pad swipe %d\n", po)); SvPADTMP_off(curpad[po]); curpad[po] = NEWSV(1107,0); SvPADTMP_on(curpad[po]); --- 372,378 ---- croak("panic: pad_swipe curpad"); if (!po) croak("panic: pad_swipe 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,393 **** if (AvARRAY(comppad) != curpad) croak("panic: pad_reset curpad"); ! DEBUG_X(fprintf(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) --- 387,393 ---- if (AvARRAY(comppad) != curpad) croak("panic: pad_reset curpad"); ! 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,2817 **** --- 2812,2841 ---- 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,2842 **** 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)? */ line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn("Subroutine %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); --- 2856,2877 ---- if (GvCVGEN(gv)) cv = 0; /* just a cached method */ else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { ! 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(const_sv ? "Constant subroutine %s redefined" ! : "Subroutine %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); *************** *** 2864,2871 **** 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); } --- 2899,2904 ---- Index: os2/Makefile.SHs *** perl5.003_01/os2/Makefile.SHs Tue Jul 30 23:11:52 1996 --- perl5.003_02/os2/Makefile.SHs Mon Aug 5 09:23:41 1996 *************** *** 41,46 **** --- 41,47 ---- echo ' "dlopen"' >>$@ echo ' "dlsym"' >>$@ echo ' "dlerror"' >>$@ + echo ' "perl_init_i18nl10n"' >>$@ !NO!SUBS! if [ ! -z "$myttyname" ] ; then *************** *** 119,124 **** --- 120,130 ---- 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,140 **** ./perl_ installperl aout_test: perl_ ! - cd t && (rm -f perl_$(EXE_EXT); $(LNS) ../perl_$(EXE_EXT) perl_$(EXE_EXT)) && ./perl_ TEST [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 + + 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 + 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 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 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 Index: os2/OS2/ExtAttr/ExtAttr.xs *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/ExtAttr/ExtAttr.xs Mon Aug 5 09:23:41 1996 *************** *** 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 Index: os2/OS2/ExtAttr/MANIFEST *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/ExtAttr/MANIFEST Mon Aug 5 09:23:41 1996 *************** *** 0 **** --- 1,8 ---- + Changes + ExtAttr.pm + ExtAttr.xs + MANIFEST + Makefile.PL + myea.h + t/os2_ea.t + typemap Index: os2/OS2/ExtAttr/Makefile.PL *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/ExtAttr/Makefile.PL Mon Aug 5 09:23:41 1996 *************** *** 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' + ); Index: os2/OS2/ExtAttr/myea.h *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/ExtAttr/myea.h Mon Aug 5 09:23:41 1996 *************** *** 0 **** --- 1,2 ---- + #include + #include Index: os2/OS2/ExtAttr/t/os2_ea.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/ExtAttr/t/os2_ea.t Mon Aug 5 09:23:41 1996 *************** *** 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"; + Index: os2/OS2/ExtAttr/typemap *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/ExtAttr/typemap Mon Aug 5 09:23:41 1996 *************** *** 0 **** --- 1,2 ---- + struct _ea * T_PTR + _ead T_PTR Index: os2/OS2/PrfDB/Changes *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/PrfDB/Changes Mon Aug 5 09:23:41 1996 *************** *** 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. Index: os2/OS2/PrfDB/MANIFEST *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/PrfDB/MANIFEST Mon Aug 5 09:23:41 1996 *************** *** 0 **** --- 1,7 ---- + Changes + MANIFEST + Makefile.PL + PrfDB.pm + PrfDB.xs + t/os2_prfdb.t + typemap Index: os2/OS2/PrfDB/Makefile.PL *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/PrfDB/Makefile.PL Mon Aug 5 09:23:41 1996 *************** *** 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' + ); Index: os2/OS2/PrfDB/PrfDB.pm *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/PrfDB/PrfDB.pm Mon Aug 5 09:23:42 1996 *************** *** 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 and C. 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, 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. They are + + =over 14 + + =item C + + Opens the database, returns an I. + + =item C + + Closes the database given an I. + + =item C + + Retrieves data from the database given 2-part-key C C. + If C is C, return the "\0" delimited list of Cs, + terminated by \0. If C is C, returns the list of + possible Cs in the same form. + + =item C + + Same as above, but returns the length of the value. + + =item C + + Sets the value. If the C is not defined, removes the C. If + the C is not defined, removes the C. + + =item C + + Return an I associated with the system database. If + C is 1, it is I database, if 2, I database, if + 0, handle for "both" of them: the handle works for read from any one, + and for write into I one. + + =item C + + returns a reference to a list of two strings, giving names of the + I and I databases. + + =item C + + B<(Not tested.)> Sets the profile name of the I 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: + + =over 14 + + =item C + + =item C + + =back + + =head2 Exports + + SystemIni(), UserIni(), and AnyIni(). + + =head1 AUTHOR + + Ilya Zakharevich, ilya@math.ohio-state.edu + + =head1 SEE ALSO + + perl(1). + + =cut + Index: os2/OS2/PrfDB/PrfDB.xs *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/PrfDB/PrfDB.xs Mon Aug 5 09:23:42 1996 *************** *** 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 + #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(); Index: os2/OS2/PrfDB/t/os2_prfdb.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/PrfDB/t/os2_prfdb.t Mon Aug 5 09:23:42 1996 *************** *** 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"); Index: os2/OS2/PrfDB/typemap *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/PrfDB/typemap Mon Aug 5 09:23:42 1996 *************** *** 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); Index: os2/OS2/Process/MANIFEST *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/Process/MANIFEST Mon Aug 5 09:23:42 1996 *************** *** 0 **** --- 1,4 ---- + MANIFEST + Makefile.PL + Process.pm + Process.xs Index: os2/OS2/Process/Makefile.PL *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/Process/Makefile.PL Mon Aug 5 09:23:42 1996 *************** *** 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' + ); Index: os2/OS2/Process/Process.pm *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/Process/Process.pm Mon Aug 5 09:23:42 1996 *************** *** 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 . + + =head1 SEE ALSO + + C() system calls. + + =cut Index: os2/OS2/Process/Process.xs *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/Process/Process.xs Mon Aug 5 09:23:42 1996 *************** *** 0 **** --- 1,154 ---- + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + + #include + + 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 + Index: os2/OS2/REXX/Changes *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/Changes Mon Aug 5 09:23:42 1996 *************** *** 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. Index: os2/OS2/REXX/MANIFEST *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/MANIFEST Mon Aug 5 09:23:42 1996 *************** *** 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 Index: os2/OS2/REXX/Makefile.PL *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/Makefile.PL Mon Aug 5 09:23:42 1996 *************** *** 0 **** --- 1,7 ---- + use ExtUtils::MakeMaker; + + WriteMakefile( + NAME => 'OS2::REXX', + VERSION => '0.2', + XSPROTOARG => '-noprototypes', + ); Index: os2/OS2/REXX/REXX.pm *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/REXX.pm Mon Aug 5 09:23:42 1996 *************** *** 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 []' 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 function. REXX functions which do not use + variables may be usable even without C 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 for examples. + + =head1 AUTHOR + + Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich + ilya@math.ohio-state.edu. + + =cut Index: os2/OS2/REXX/REXX.xs *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/REXX.xs Mon Aug 5 09:23:42 1996 *************** *** 0 **** --- 1,484 ---- + #include "EXTERN.h" + #include "perl.h" + #include "XSUB.h" + + #define INCL_BASE + #define INCL_REXXSAA + #include + + #if 0 + #define INCL_REXXSAA + #pragma pack(1) + #define _Packed + #include + #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 Index: os2/OS2/REXX/t/rx_cmprt.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/t/rx_cmprt.t Mon Aug 5 09:23:43 1996 *************** *** 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"}; Index: os2/OS2/REXX/t/rx_dllld.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/t/rx_dllld.t Mon Aug 5 09:23:43 1996 *************** *** 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"; Index: os2/OS2/REXX/t/rx_objcall.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/t/rx_objcall.t Mon Aug 5 09:23:43 1996 *************** *** 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\'/; + Index: os2/OS2/REXX/t/rx_sql.test *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/t/rx_sql.test Mon Aug 5 09:23:43 1996 *************** *** 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; Index: os2/OS2/REXX/t/rx_tiesql.test *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/t/rx_tiesql.test Mon Aug 5 09:23:43 1996 *************** *** 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; Index: os2/OS2/REXX/t/rx_tievar.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/t/rx_tievar.t Mon Aug 5 09:23:43 1996 *************** *** 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"; + + }; Index: os2/OS2/REXX/t/rx_tieydb.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/t/rx_tieydb.t Mon Aug 5 09:23:43 1996 *************** *** 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"; + }; Index: os2/OS2/REXX/t/rx_varset.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/t/rx_varset.t Mon Aug 5 09:23:43 1996 *************** *** 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"; + }; Index: os2/OS2/REXX/t/rx_vrexx.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/OS2/REXX/t/rx_vrexx.t Mon Aug 5 09:23:43 1996 *************** *** 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"; + }; Index: os2/README *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/os2/README Fri Aug 9 09:10:10 1996 *************** *** 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}' 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}' 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 + + Index: os2/diff.configure *** perl5.003_01/os2/diff.configure Tue Jan 23 01:45:42 1996 --- perl5.003_02/os2/diff.configure Fri Aug 9 09:10:09 1996 *************** *** 288,306 **** cryptlib=-lcrypt fi *************** ! *** 5198,5204 **** ! } EOM if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && ! ! $ld $lddlflags -o dyna.$dlext 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 ---- ! } EOM if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 && ! ! $ld $lddlflags -o dyna.$dlext 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 --- 288,308 ---- cryptlib=-lcrypt fi *************** ! *** 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 && ! ! 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,5220 ---- 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$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 Index: os2/dlfcn.h *** perl5.003_01/os2/dlfcn.h Tue Jul 30 23:11:52 1996 --- perl5.003_02/os2/dlfcn.h Mon Aug 5 09:23:41 1996 *************** *** 1,6 **** 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,3 ---- Index: os2/os2.c *** perl5.003_01/os2/os2.c Tue Jul 30 23:11:53 1996 --- perl5.003_02/os2/os2.c Mon Aug 5 09:23:43 1996 *************** *** 1,10 **** #define INCL_DOS #define INCL_NOPM #define INCL_DOSFILEMGR ! #ifndef NO_SYS_ALLOC ! # define INCL_DOSMEMMGR ! # define INCL_DOSERRORS ! #endif /* ! defined NO_SYS_ALLOC */ #include /* --- 1,8 ---- #define INCL_DOS #define INCL_NOPM #define INCL_DOSFILEMGR ! #define INCL_DOSMEMMGR ! #define INCL_DOSERRORS #include /* *************** *** 137,146 **** int r, status; Signal_t (*ihand)(); /* place to save signal during system() */ Signal_t (*qhand)(); /* place to save signal during system() */ ! if (pid < 0 || flag != 0) return pid; ihand = signal(SIGINT, SIG_IGN); qhand = signal(SIGQUIT, SIG_IGN); do { --- 135,149 ---- 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) return pid; + #ifdef __EMX__ ihand = signal(SIGINT, SIG_IGN); qhand = signal(SIGQUIT, SIG_IGN); do { *************** *** 153,158 **** --- 156,170 ---- 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,176 **** New(401,Argv, sp - mark + 1, char*); a = Argv; ! if (mark < sp && SvIOKp(*(mark+1))) { ++mark; flag = SvIVx(*mark); } --- 182,188 ---- New(401,Argv, sp - mark + 1, char*); a = Argv; ! if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) { ++mark; flag = SvIVx(*mark); } *************** *** 187,194 **** if (flag == P_WAIT) flag = P_NOWAIT; ! if (*Argv[0] != '/' && *Argv[0] != '\\') /* will swawnvp use PATH? */ TAINT_ENV(); /* testing IFS here is overkill, probably */ if (really && *(tmps = SvPV(really, na))) rc = result(trueflag, spawnvp(flag,tmps,Argv)); else --- 199,210 ---- if (flag == P_WAIT) flag = P_NOWAIT; ! 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,211 **** return rc; } int ! do_spawn(cmd) char *cmd; { register char **a; register char *s; --- 219,232 ---- return rc; } + #define EXECF_SPAWN 0 + #define EXECF_EXEC 1 + #define EXECF_TRUEEXEC 2 + int ! do_spawn2(cmd, execf) char *cmd; + int execf; { register char **a; register char *s; *************** *** 254,263 **** break; } doshell: rc = result(P_WAIT, ! spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); if (rc < 0 && dowarn) ! warn("Can't spawn \"%s\": %s", shell, Strerror(errno)); if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ return rc; } --- 275,291 ---- 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)); if (rc < 0 && dowarn) ! 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,284 **** } *a = Nullch; if (Argv[0]) { ! rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv)); if (rc < 0 && dowarn) ! warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno)); if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ } else rc = -1; --- 304,319 ---- } *a = Nullch; if (Argv[0]) { ! 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 %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,297 **** --- 321,356 ---- 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,304 **** --- 358,364 ---- res = popen(cmd, mode); my_setenv("EMXSHELL", shell); return res; + #endif } #endif *************** *** 323,340 **** 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) {} /*****************************************************************************/ /* stat() hack for char/block device */ --- 383,436 ---- void * ttyname(x) { return 0; } #endif ! /*****************************************************************************/ ! /* 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,417 **** #endif ! #ifndef NO_SYS_ALLOC ! ! static char *oldchunk; ! static long oldsize; ! ! #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. */ 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); 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; } - #endif /* ! defined NO_SYS_ALLOC */ /* tmp path */ char *tmppath = TMPPATH1; --- 458,480 ---- #endif ! #ifdef USE_PERL_SBRK ! /* SBRK() emulation, mostly moved to malloc.c. */ void * ! 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); ! return got; } + #endif /* USE_PERL_SBRK */ + /* tmp path */ char *tmppath = TMPPATH1; *************** *** 463,470 **** SV *sv; { static char fname[9]; ! int pos = 7; ! int len; AV *av; SV *svp; char *s; --- 526,533 ---- SV *sv; { static char fname[9]; ! int pos = 6, len, avlen; ! unsigned int sum = 0; AV *av; SV *svp; char *s; *************** *** 473,485 **** sv = SvRV(sv); if (SvTYPE(sv) != SVt_PVAV) croak("Not array reference given to mod2fname"); ! if (av_len((AV*)sv) < 0) croak("Empty array reference given to mod2fname"); ! s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na); strncpy(fname, s, 8); ! if ((len=strlen(s)) < 7) pos = len; ! fname[pos] = '_'; ! fname[pos + 1] = '\0'; return (char *)fname; } --- 536,565 ---- sv = SvRV(sv); if (SvTYPE(sv) != SVt_PVAV) croak("Not array reference given to mod2fname"); ! ! avlen = av_len((AV*)sv); ! if (avlen < 0) croak("Empty array reference given to mod2fname"); ! ! s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na); strncpy(fname, s, 8); ! 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,533 **** 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); sv_setiv(GvSV(gv), 1); #endif } --- 605,613 ---- newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file); newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file); gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV); GvMULTI_on(gv); + #ifdef PERL_IS_AOUT sv_setiv(GvSV(gv), 1); #endif } *************** *** 542,551 **** OS2_Perl_data.xs_init = &Xs_OS2_init; if ( (shell = getenv("PERL_SH_DRIVE")) ) { sh_path[0] = shell[0]; } } ! char sh_path[33] = BIN_SH; extern void dlopen(); void *fakedl = &dlopen; /* Pull in dynaloading part. */ --- 622,683 ---- 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[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. */ Index: os2/os2ish.h *** perl5.003_01/os2/os2ish.h Tue Jul 30 23:11:53 1996 --- perl5.003_02/os2/os2ish.h Mon Aug 5 09:23:43 1996 *************** *** 45,51 **** #endif #define ABORT() kill(getpid(),SIGABRT); ! #define BIT_BUCKET "/dev/null" /* Will this work? */ void Perl_OS2_init(); --- 45,51 ---- #endif #define ABORT() kill(getpid(),SIGABRT); ! #define BIT_BUCKET "/dev/nul" /* Will this work? */ void Perl_OS2_init(); *************** *** 62,70 **** #define dXSUB_SYS int fake = OS2_XS_init() #ifdef PERL_IS_AOUT ! #define NO_SYS_ALLOC ! #endif #define TMPPATH tmppath #define TMPPATH1 "plXXXXXX" extern char *tmppath; --- 62,80 ---- #define dXSUB_SYS int fake = OS2_XS_init() #ifdef PERL_IS_AOUT ! # 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" extern char *tmppath; *************** *** 160,167 **** set_Perl_HAB_f; \ } ! extern char sh_path[33]; #define SH_PATH sh_path char *os2error(int rc); --- 170,180 ---- set_Perl_HAB_f; \ } ! #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); Index: os2/perl2cmd.pl *** perl5.003_01/os2/perl2cmd.pl Mon Mar 25 06:05:01 1996 --- perl5.003_02/os2/perl2cmd.pl Mon Aug 5 09:23:43 1996 *************** *** 16,22 **** $idir = $Config{installbin}; $indir =~ s|\\|/|g ; ! foreach $file (<$idir/*.>) { $base = $file; $base =~ s/\.$//; # just in case... $base =~ s|.*/||; --- 16,23 ---- $idir = $Config{installbin}; $indir =~ s|\\|/|g ; ! foreach $file (<$idir/*>) { ! next if $file =~ /\.exe/i; $base = $file; $base =~ s/\.$//; # just in case... $base =~ s|.*/||; Index: perl.c *** perl5.003_01/perl.c Tue Jul 30 23:11:54 1996 --- perl5.003_02/perl.c Fri Aug 9 17:00:50 1996 *************** *** 35,40 **** --- 35,44 ---- #endif #endif + #ifndef OSNAME + #define OSNAME "unknown" + #endif + static void find_beginning _((void)); static void incpush _((char *)); static void init_ids _((void)); *************** *** 132,137 **** --- 136,143 ---- 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,343 **** calllist(endav); return(statusvalue); /* my_exit() was called */ case 3: ! fprintf(stderr, "panic: top_env\n"); return 1; } --- 343,349 ---- calllist(endav); return(statusvalue); /* my_exit() was called */ case 3: ! PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); return 1; } *************** *** 388,402 **** (void)mktemp(e_tmpname); if (!*e_tmpname) croak("Can't mktemp()"); ! e_fp = fopen(e_tmpname,"w"); if (!e_fp) croak("Cannot open temporary file"); } if (argv[1]) { ! fputs(argv[1],e_fp); argc--,argv++; } ! (void)putc('\n', e_fp); break; case 'I': taint_not("-I"); --- 394,408 ---- (void)mktemp(e_tmpname); if (!*e_tmpname) croak("Can't mktemp()"); ! e_fp = PerlIO_open(e_tmpname,"w"); if (!e_fp) croak("Cannot open temporary file"); } if (argv[1]) { ! PerlIO_puts(e_fp,argv[1]); argc--,argv++; } ! (void)PerlIO_putc(e_fp,'\n'); break; case 'I': taint_not("-I"); *************** *** 500,506 **** if (!scriptname) scriptname = argv[0]; if (e_fp) { ! if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp)) croak("Can't write to temp file for -e: %s", Strerror(errno)); e_fp = Nullfp; argc++,argv--; --- 506,512 ---- if (!scriptname) scriptname = argv[0]; if (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,514 **** } else if (scriptname == Nullch) { #ifdef MSDOS ! if ( isatty(fileno(stdin)) ) moreswitches("v"); #endif scriptname = "-"; --- 514,520 ---- } else if (scriptname == Nullch) { #ifdef MSDOS ! if ( isatty(PerlIO_fileno(PerlIO_stdin())) ) moreswitches("v"); #endif scriptname = "-"; *************** *** 619,625 **** return(statusvalue); /* my_exit() was called */ case 3: if (!restartop) { ! fprintf(stderr, "panic: restartop\n"); FREETMPS; return 1; } --- 625,631 ---- return(statusvalue); /* my_exit() was called */ case 3: if (!restartop) { ! PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); FREETMPS; return 1; } *************** *** 630,644 **** break; } ! DEBUG_r(fprintf(stderr, "%s $` $& $' support.\n", sawampersand ? "Enabling" : "Omitting")); if (!restartop) { DEBUG_x(dump_all()); ! DEBUG(fprintf(Perl_debug_log,"\nEXECUTING...\n\n")); if (minus_c) { ! fprintf(stderr,"%s syntax OK\n", origfilename); my_exit(0); } if (perldb && DBsingle) --- 636,650 ---- break; } ! DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n", sawampersand ? "Enabling" : "Omitting")); if (!restartop) { DEBUG_x(dump_all()); ! DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); if (minus_c) { ! PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename); my_exit(0); } if (perldb && DBsingle) *************** *** 1037,1042 **** --- 1043,1051 ---- # define PERLLIB_SEP ':' # endif #endif + #ifndef PERLLIB_MANGLE + # define PERLLIB_MANGLE(s,n) (s) + #endif static void incpush(p) *************** *** 1056,1065 **** p++; } if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { ! av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p))); p = s + 1; } else { ! av_push(GvAVn(incgv), newSVpv(p, 0)); break; } } --- 1065,1075 ---- p++; } if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) { ! av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)), ! (STRLEN)(s - p))); p = s + 1; } else { ! av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0)); break; } } *************** *** 1277,1298 **** printf("\nThis is perl, version %s",patchlevel); #endif ! fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout); ! fputs("\n\t+ suidperl security patch", stdout); #ifdef MSDOS ! fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n", ! stdout); #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); #endif #ifdef atarist ! fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout); #endif ! fputs("\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); #ifdef MSDOS usage(origargv[0]); #endif --- 1287,1307 ---- printf("\nThis is perl, version %s",patchlevel); #endif ! printf("\n\nCopyright 1987-1996, Larry Wall\n"); ! printf("\n\t+ suidperl security patch"); #ifdef MSDOS ! printf("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); #endif #ifdef OS2 ! 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 ! printf("atariST series port, ++jrb bammi@cadence.com\n"); #endif ! 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"); #ifdef MSDOS usage(origargv[0]); #endif *************** *** 1337,1343 **** status = unexec(buf, tokenbuf, &etext, sbrk(0), 0); if (status) ! fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf); exit(status); #else # ifdef VMS --- 1346,1352 ---- status = unexec(buf, tokenbuf, &etext, sbrk(0), 0); if (status) ! PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n", tokenbuf, buf); exit(status); #else # ifdef VMS *************** *** 1456,1462 **** extidx = 0; do { #endif ! DEBUG_p(fprintf(Perl_debug_log,"Looking for %s\n",tokenbuf)); retval = Stat(tokenbuf,&statbuf); #ifdef SEARCH_EXTS } while ( retval < 0 /* not there */ --- 1465,1471 ---- extidx = 0; do { #endif ! 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,1504 **** if (strEQ(origfilename,"-")) scriptname = ""; if (fdscript >= 0) { ! rsfp = fdopen(fdscript,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) ! fcntl(fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } else if (preprocess) { --- 1505,1513 ---- if (strEQ(origfilename,"-")) scriptname = ""; if (fdscript >= 0) { ! rsfp = PerlIO_fdopen(fdscript,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) ! fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } else if (preprocess) { *************** *** 1571,1585 **** } else if (!*scriptname) { taint_not("program input from stdin"); ! rsfp = stdin; } else { ! rsfp = fopen(scriptname,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) ! fcntl(fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } ! if ((FILE*)rsfp == Nullfp) { #ifdef DOSUID #ifndef IAMSUID /* in case script is not readable before setuid */ if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 && --- 1580,1594 ---- } else if (!*scriptname) { taint_not("program input from stdin"); ! rsfp = PerlIO_stdin(); } else { ! rsfp = PerlIO_open(scriptname,"r"); #if defined(HAS_FCNTL) && defined(F_SETFD) ! fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */ #endif } ! 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,1631 **** #ifdef DOSUID char *s, *s2; ! if (Fstat(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; --- 1634,1640 ---- #ifdef DOSUID char *s, *s2; ! 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,1673 **** croak("Permission denied"); /* testing full pathname here */ if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { ! (void)fclose(rsfp); if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ ! fprintf(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, --- 1674,1682 ---- croak("Permission denied"); /* testing full pathname here */ if (tmpstatbuf.st_dev != statbuf.st_dev || tmpstatbuf.st_ino != statbuf.st_ino) { ! (void)PerlIO_close(rsfp); if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */ ! 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,1712 **** 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 */ croak("No #! line"); ! s = tokenbuf+2; if (*s == ' ') s++; while (!isSPACE(*s)) s++; ! for (s2 = s; (s2 > tokenbuf+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"); --- 1709,1721 ---- croak("Setuid/gid script is writable by world"); doswitches = FALSE; /* -s is insecure in suid */ curcop->cop_line++; ! if (sv_gets(linestr, rsfp, 0) == Nullch || ! strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */ croak("No #! line"); ! s = SvPV(linestr,na)+2; if (*s == ' ') s++; while (!isSPACE(*s)) s++; ! 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,1736 **** #endif /* IAMSUID */ if (euid) { /* oops, we're not the setuid root perl */ ! (void)fclose(rsfp); #ifndef IAMSUID (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ --- 1739,1745 ---- #endif /* IAMSUID */ if (euid) { /* oops, we're not the setuid root perl */ ! (void)PerlIO_close(rsfp); #ifndef IAMSUID (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel); execv(buf, origargv); /* try again */ *************** *** 1805,1820 **** /* 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 */ 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]); origargv[which] = buf; #if defined(HAS_FCNTL) && defined(F_SETFD) ! fcntl(fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel); --- 1814,1829 ---- /* 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.) */ ! 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", PerlIO_fileno(rsfp), origargv[which]); origargv[which] = buf; #if defined(HAS_FCNTL) && defined(F_SETFD) ! fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */ #endif (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel); *************** *** 1824,1830 **** #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 */ if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID) || (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) --- 1833,1839 ---- #else /* !DOSUID */ if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW ! 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,1856 **** 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 */ doextract = FALSE; while (*s && !(isSPACE (*s) || *s == '#')) s++; s2 = s; --- 1859,1865 ---- if ((s = sv_gets(linestr, rsfp, 0)) == Nullch) croak("No Perl script found in input\n"); if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) { ! PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ doextract = FALSE; while (*s && !(isSPACE (*s) || *s == '#')) s++; s2 = s; *************** *** 1965,1971 **** Safefree(tmps_stack); } ! static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ static void init_lexer() { --- 1974,1980 ---- Safefree(tmps_stack); } ! static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */ static void init_lexer() { *************** *** 1986,1999 **** stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(stdingv); ! IoIFP(GvIOp(stdingv)) = 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; setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); GvMULTI_on(tmpgv); --- 1995,2008 ---- stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(stdingv); ! 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)) = PerlIO_stdout(); setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); GvMULTI_on(tmpgv); *************** *** 2001,2007 **** othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); GvMULTI_on(othergv); ! IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr; tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); GvMULTI_on(tmpgv); GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv)); --- 2010,2016 ---- othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); GvMULTI_on(othergv); ! 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,2206 **** return; case 3: if (!restartop) { ! fprintf(stderr, "panic: restartop\n"); FREETMPS; break; } --- 2209,2215 ---- return; case 3: if (!restartop) { ! PerlIO_printf(PerlIO_stderr(), "panic: restartop\n"); FREETMPS; break; } Index: perl.h *** perl5.003_01/perl.h Tue Jul 30 23:11:55 1996 --- perl5.003_02/perl.h Fri Aug 9 16:14:37 1996 *************** *** 10,16 **** --- 10,28 ---- #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 * if (x) STMT_START { ... } STMT_END; else ... *************** *** 101,107 **** # endif #endif ! #include #ifdef USE_NEXT_CTYPE --- 113,139 ---- # endif #endif ! #ifndef _TYPES_ /* If types.h defines this it's easy. */ ! # ifndef major /* Does everyone's types.h define this? */ ! # include ! # endif ! #endif ! ! #ifdef __cplusplus ! # ifndef I_STDARG ! # define I_STDARG 1 ! # endif ! #endif ! ! #ifdef I_STDARG ! # include ! #else ! # ifdef I_VARARGS ! # include ! # endif ! #endif ! ! #include "perlio.h" #ifdef USE_NEXT_CTYPE *************** *** 143,153 **** 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 # endif # define safemalloc malloc # define saferealloc realloc --- 175,185 ---- proto.h instead. I guess. The patch had no explanation. */ #ifdef MYMALLOC ! # 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,251 **** # endif #endif - #ifndef _TYPES_ /* If types.h defines this it's easy. */ - # ifndef major /* Does everyone's types.h define this? */ - # include - # endif - #endif - #ifdef I_NETINET_IN # include #endif --- 272,277 ---- *************** *** 527,532 **** --- 553,613 ---- 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 + #else + #ifdef I_VALUES + # include + #endif + #endif + + #ifdef LONG_MAX + #define PERL_LONG_MAX LONG_MAX + #else + # ifdef MAXLONG /* Often used in */ + # 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,605 **** --- 681,689 ---- #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,754 **** #ifdef DEBUGGING #ifndef Perl_debug_log ! #define Perl_debug_log stderr #endif #define YYDEBUG 1 #define DEB(a) a --- 832,838 ---- #ifdef DEBUGGING #ifndef Perl_debug_log ! #define Perl_debug_log PerlIO_stderr() #endif #define YYDEBUG 1 #define DEB(a) a *************** *** 869,883 **** #define SCAN_TR 1 #define SCAN_REPL 2 #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] --- 953,968 ---- #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 # define PAD_SV(po) pad_sv(po) #else # define PAD_SV(po) curpad[po] *************** *** 1160,1166 **** EXT I32 nexttype[5]; /* type of next token */ EXT I32 nexttoke; ! EXT FILE * VOL rsfp INIT(Nullfp); EXT SV * linestr; EXT char * bufptr; EXT char * oldbufptr; --- 1245,1251 ---- EXT I32 nexttype[5]; /* type of next token */ EXT I32 nexttoke; ! EXT PerlIO * VOL rsfp INIT(Nullfp); EXT SV * linestr; EXT char * bufptr; EXT char * oldbufptr; *************** *** 1235,1240 **** --- 1320,1328 ---- 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,1295 **** 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 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 */ --- 1373,1381 ---- IEXT bool Isawi; /* study must assume case insensitive */ IEXT bool Isawvec; IEXT bool Iunsafe; IEXT char * Iinplace; IEXT char * Ie_tmpname; ! 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,1474 **** extern "C" { #endif - #ifdef __cplusplus - # ifndef I_STDARG - # define I_STDARG 1 - # endif - #endif - - #ifdef I_STDARG - # include - #else - # ifdef I_VARARGS - # include - # endif - #endif - #include "proto.h" #ifdef EMBED --- 1541,1546 ---- *************** *** 1653,1657 **** --- 1725,1737 ---- copy_amg, neg_amg }; #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 */ Index: perlio.c *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/perlio.c Fri Aug 9 16:48:37 1996 *************** *** 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 + */ + + #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 + Index: perlio.h *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/perlio.h Fri Aug 9 16:21:03 1996 *************** *** 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 */ + + + Index: perlsdio.h *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/perlsdio.h Sat Aug 10 13:06:21 1996 *************** *** 0 **** --- 1,230 ---- + /* + * Although we may not want stdio to be used including here + * avoids issues where stdio.h has strange side effects + */ + #include + + #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 */ Index: perlsfio.h *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/perlsfio.h Fri Aug 9 11:41:37 1996 *************** *** 0 **** --- 1,58 ---- + /* The next #ifdef should be redundant if Configure behaves ... */ + #ifdef I_SFIO + #include + #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) + + Index: perly.c Prereq: 1.8 *** perl5.003_01/perly.c Tue Jul 30 23:11:56 1996 --- perl5.003_02/perly.c Thu Aug 8 09:16:10 1996 *************** *** 1406,1412 **** 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, yychar, yys); } #endif --- 1406,1412 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } #endif *************** *** 1416,1422 **** { #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif if (yyssp >= yyss + yystacksize - 1) --- 1416,1422 ---- { #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif if (yyssp >= yyss + yystacksize - 1) *************** *** 1471,1477 **** { #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: state %d, error recovery shifting to state %d\n", *yyssp, yytable[yyn]); #endif --- 1471,1477 ---- { #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery shifting to state %d\n", *yyssp, yytable[yyn]); #endif *************** *** 1501,1507 **** { #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: error recovery discarding state %d\n", *yyssp); #endif --- 1501,1507 ---- { #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: error recovery discarding state %d\n", *yyssp); #endif *************** *** 1520,1526 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(Perl_debug_log, "yydebug: state %d, error recovery discards token %d (%s)\n", yystate, yychar, yys); } --- 1520,1526 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery discards token %d (%s)\n", yystate, yychar, yys); } *************** *** 1531,1537 **** yyreduce: #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; --- 1531,1537 ---- yyreduce: #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; *************** *** 2250,2256 **** { #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: after reduction, shifting from state 0 to state %d\n", YYFINAL); #endif --- 2250,2256 ---- { #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state 0 to state %d\n", YYFINAL); #endif *************** *** 2266,2272 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } #endif --- 2266,2272 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } #endif *************** *** 2281,2287 **** yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: after reduction, shifting from state %d to state %d\n", *yyssp, yystate); #endif --- 2281,2287 ---- yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state %d to state %d\n", *yyssp, yystate); #endif Index: perly.h *** perl5.003_01/perly.h Tue Jul 30 23:11:57 1996 --- perl5.003_02/perly.h Thu Aug 8 09:16:10 1996 *************** *** 62,64 **** --- 62,65 ---- GV *gvval; } YYSTYPE; extern YYSTYPE yylval; + extern YYSTYPE yylval; Index: plan9/fndvers *** perl5.003_01/plan9/fndvers Tue Jul 30 23:12:01 1996 --- perl5.003_02/plan9/fndvers Sat Aug 3 19:40:06 1996 *************** *** 5,9 **** ed config.plan9 < $target cp ext/IO/*.pm $privlib ! 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 --- 77,86 ---- 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 cp ext/IO/lib/IO/*.pm $privlib/IO + } Socket.$O: config.h Socket.c $CCCMD -I plan9 Socket.c *************** *** 139,149 **** for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i pod/pod2man plan9/perlplan9.pod > $installman3dir/perlplan9 ! nuke: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 deleteman:V: rm -f $installman1dir/perl* $installman3dir/perl* --- 138,146 ---- for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i pod/pod2man plan9/perlplan9.pod > $installman3dir/perlplan9 ! nuke clean:V: rm -f *.$O $extensions^.pm config.sh $perllib config.h $perlshr perlmain.c perl miniperl $archlib/Config.pm $ext_c ! rm -rf $privlib/IO deleteman:V: rm -f $installman1dir/perl* $installman3dir/perl* Index: plan9/perlplan9.doc *** perl5.003_01/plan9/perlplan9.doc Tue Jul 30 23:12:03 1996 --- perl5.003_02/plan9/perlplan9.doc Tue Aug 6 13:42:44 1996 *************** *** 1,5 **** ! PERLTEST/PLAN9/PERLPLAN9(1) (perl ) PERLTEST/PLAN9/PERLPLAN9(1) NNNNAAAAMMMMEEEE perlplan9 - Plan 9-specific documentation for Perl --- 1,5 ---- ! PLAN9/PERLPLAN9(1) (perl 5.003, patch 01) PLAN9/PERLPLAN9(1) NNNNAAAAMMMMEEEE perlplan9 - Plan 9-specific documentation for Perl *************** *** 34,41 **** 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. WWWWhhhhaaaatttt''''ssss nnnnooootttt iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll --- 34,41 ---- Although Plan 9 Perl currently only provides static loading, it is built with a number of useful extensions. ! These include Opcode, FileHandle, Fcntl, and POSIX. Expect ! to see others (and DynaLoading!) in the future. WWWWhhhhaaaatttt''''ssss nnnnooootttt iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll *************** *** 52,60 **** The functions not currently implemented include: ! Page 1 4/Jul/96 (printed 7/4/96) ! PERLTEST/PLAN9/PERLPLAN9(1) (perl ) PERLTEST/PLAN9/PERLPLAN9(1) chown, chroot, dbmclose, dbmopen, getsockopt, setsockopt, recvmsg, sendmsg, getnetbyname, --- 52,60 ---- The functions not currently implemented include: ! Page 1 6/Aug/96 (printed 8/6/96) ! PLAN9/PERLPLAN9(1) (perl 5.003, patch 01) PLAN9/PERLPLAN9(1) chown, chroot, dbmclose, dbmopen, getsockopt, setsockopt, recvmsg, sendmsg, getnetbyname, *************** *** 82,91 **** the world . . ." - Carl Sagan RRRReeeevvvviiiissssiiiioooonnnn ddddaaaatttteeee ! This document was revised 04-July-1996 for Perl 5.003_1. AAAAUUUUTTTTHHHHOOOORRRR Luther Huffman, lutherh@stratcom.com ! Page 2 4/Jul/96 (printed 7/4/96) --- 82,91 ---- the world . . ." - Carl Sagan RRRReeeevvvviiiissssiiiioooonnnn ddddaaaatttteeee ! This document was revised 06-August-1996 for Perl 5.003_2. AAAAUUUUTTTTHHHHOOOORRRR Luther Huffman, lutherh@stratcom.com ! Page 2 6/Aug/96 (printed 8/6/96) Index: plan9/perlplan9.pod *** perl5.003_01/plan9/perlplan9.pod Tue Jul 30 23:12:03 1996 --- perl5.003_02/plan9/perlplan9.pod Tue Aug 6 13:37:20 1996 *************** *** 34,40 **** 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. =head2 What's not in Plan 9 Perl --- 34,40 ---- Although Plan 9 Perl currently only provides static loading, it is built with a number of useful extensions. ! 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,86 **** =head1 Revision date ! This document was revised 04-July-1996 for Perl 5.003_1. =head1 AUTHOR --- 80,86 ---- =head1 Revision date ! This document was revised 06-August-1996 for Perl 5.003_2. =head1 AUTHOR Index: plan9/setup.rc *** perl5.003_01/plan9/setup.rc Tue Jul 30 23:12:04 1996 --- perl5.003_02/plan9/setup.rc Sat Aug 3 19:32:35 1996 *************** *** 6,11 **** --- 6,12 ---- # 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) Index: plan9/versnum *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/plan9/versnum Sat Aug 3 19:43:19 1996 *************** *** 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"; + } Index: pod/Makefile.PL *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/pod/Makefile.PL Mon Feb 19 18:31:05 1996 *************** *** 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 ':'; Index: pod/perl.pod *** perl5.003_01/pod/perl.pod Tue Jul 30 23:12:04 1996 --- perl5.003_02/pod/perl.pod Wed Aug 7 09:39:48 1996 *************** *** 20,25 **** --- 20,26 ---- perl Perl overview (this section) perltoc Perl documentation table of contents + perldata Perl data structures perlsyn Perl syntax perlop Perl operators and precedence *************** *** 29,54 **** perlvar Perl predefined variables perlsub Perl subroutines perlmod Perl modules 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 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 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.) --- 30,60 ---- 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 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 (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,65 **** 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}"' If the directories were F and F, you would only need to add F to your MANPATH. If --- 65,71 ---- 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 -V:man.dir If the directories were F and F, you would only need to add F to your MANPATH. If Index: pod/perlapio.pod *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/pod/perlapio.pod Sat Aug 10 12:09:55 1996 *************** *** 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, I will the C<#define> them to + the I/O mechanism selected at Configure time. + + The functions are modeled on those in I, but parameter order + has been "tidied up a little". + + =over 4 + + =item B + + 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, B, B + + Use these rather than C, C, C. They are written + to look like "function calls" rather than variables because this makes + it easier to I function calls if platform cannot export data + to loaded modules, or if (say) different "threads" might have different + values. + + =item B, B + + These correspond to fopen()/fdopen() arguments are the same. + + =item B, B + + These are is fprintf()/vfprintf equivalents. + + =item B + + This is printf() equivalent. printf is #defined to this function, + so it is (currently) legal to use printf(fmt,...) in perl sources. + + =item B, B + + These correspond to fread() and fwrite(). Note that arguments + are different, there is only one "count" and order has + "file" first. + + =item B + + =item B, B + + These correspond to fputs() and fputc(). + Note that arguments have been revised to have "file" first. + + =item B + + This corresponds to ungetc(). + Note that arguments have been revised to have "file" first. + + =item B + + This corresponds to getc(). + + =item B + + This corresponds to feof(). + + =item B + + This corresponds to ferror(). + + =item B + + This corresponds to fileno(), note that on some platforms, + the meaning of "fileno" may not match UNIX. + + =item B + + This corresponds to clearerr(), i.e. clears 'eof' and 'error' + flags for the "stream". + + =item B + + This corresponds to fflush(). + + =item B + + This corresponds to ftell(). + + =item B + + This corresponds to fseek(). + + =item B, B + + 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 + + This corresponds to rewind(). Note may be redefined + in terms of PerlIO_seek() at some point. + + =item B + + 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 + + Used to get a PerlIO * from a FILE *. + May need additional arguments, interface under review. + + =item B + + Given an PerlIO * return a 'native' FILE * suitable for + passing to code expecting to be compiled and linked with + ANSI C I. + + The fact that such a FILE * has been 'exported' is recorded, + and may affect future PerlIO operations on the original + PerlIO *. + + =item B + + Returns previously 'exported' FILE * (if any). + Place holder until interface is fully defined. + + =item B + + 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 + + This corresponds to setlinebuf(). Use is deprecated pending + further discussion. (Perl core I 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 + + Implementation can return pointer to current position in the "buffer" and + a count of bytes available in the buffer. + + =item B + + Return pointer to next readable byte in buffer. + + =item B + + Return count of readable bytes in the buffer. + + =item B + + Implementation can adjust its idea of number of + bytes in the buffer. + + =item B + + Implementation has all the interfaces required to + allow perls fast code to handle mechanism. + + PerlIO_fast_gets(f) = PerlIO_has_cntptr(f) && \ + PerlIO_canset_cnt(f) && \ + `Can set pointer into buffer' + + =item B + + 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 and C. + + =item B + + 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 + + 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 + + Return I of buffer. + + =item B + + Return I of buffer. + + =back Index: pod/perlobj.pod *** perl5.003_01/pod/perlobj.pod Tue Jul 30 23:12:12 1996 --- perl5.003_02/pod/perlobj.pod Fri Aug 2 17:48:45 1996 *************** *** 295,305 **** if it does then a reference to the sub is returned, if it does not then I is returned. ! =item require_version ( VERSION ) ! C will check that the current version of the package ! is greater than C. This method is normally called as a static method. ! This method is also called when the C form of C is used. use A 1.2 qw(some imported subs); --- 295,308 ---- if it does then a reference to the sub is returned, if it does not then I is returned. ! =item VERSION ( [ VERSION ] ) ! C 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 form of C is ! used. ! use A 1.2 qw(some imported subs); *************** *** 321,332 **** $ref = bless [], 'A'; $ref->is_instance(); # True - - =item require_version ( [ VERSION ] ) - - C 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 --- 324,329 ---- Index: pp.c *** perl5.003_01/pp.c Tue Jul 30 23:12:22 1996 --- perl5.003_02/pp.c Fri Aug 9 11:02:03 1996 *************** *** 570,577 **** { dSP; if (SvIOK(TOPs)) { ! --SvIVX(TOPs); ! SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); } else sv_dec(TOPs); --- 570,582 ---- { dSP; if (SvIOK(TOPs)) { ! 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,591 **** dSP; dTARGET; sv_setsv(TARG, TOPs); if (SvIOK(TOPs)) { ! ++SvIVX(TOPs); ! SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); } else sv_inc(TOPs); --- 589,601 ---- dSP; dTARGET; sv_setsv(TARG, TOPs); if (SvIOK(TOPs)) { ! 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,608 **** dSP; dTARGET; sv_setsv(TARG, TOPs); if (SvIOK(TOPs)) { ! --SvIVX(TOPs); ! SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); } else sv_dec(TOPs); --- 611,623 ---- dSP; dTARGET; sv_setsv(TARG, TOPs); if (SvIOK(TOPs)) { ! 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); Index: pp_ctl.c *** perl5.003_01/pp_ctl.c Tue Jul 30 23:12:23 1996 --- perl5.003_02/pp_ctl.c Thu Aug 8 13:34:52 1996 *************** *** 212,220 **** case FF_END: name = "END"; break; } if (arg >= 0) ! fprintf(stderr, "%-16s%ld\n", name, (long) arg); else ! fprintf(stderr, "%-16s\n", name); } ) switch (*fpc++) { case FF_LINEMARK: --- 212,220 ---- case FF_END: name = "END"; break; } if (arg >= 0) ! PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg); else ! PerlIO_printf(PerlIO_stderr(), "%-16s\n", name); } ) switch (*fpc++) { case FF_LINEMARK: *************** *** 881,887 **** while (cxstack_ix > cxix) { cx = &cxstack[cxstack_ix--]; ! DEBUG_l(fprintf(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) { --- 881,887 ---- while (cxstack_ix > cxix) { cx = &cxstack[cxstack_ix--]; ! 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,993 **** POPBLOCK(cx,curpm); if (cx->cx_type != CXt_EVAL) { ! fprintf(stderr, "panic: die %s", message); my_exit(1); } POPEVAL(cx); --- 987,993 ---- POPBLOCK(cx,curpm); if (cx->cx_type != CXt_EVAL) { ! PerlIO_printf(PerlIO_stderr(), "panic: die %s", message); my_exit(1); } POPEVAL(cx); *************** *** 1003,1013 **** return pop_return(); } } ! fputs(message, stderr); ! (void)Fflush(stderr); if (e_tmpname) { if (e_fp) { ! fclose(e_fp); e_fp = Nullfp; } (void)UNLINK(e_tmpname); --- 1003,1013 ---- return pop_return(); } } ! PerlIO_printf(PerlIO_stderr(), "%s",message); ! PerlIO_flush(PerlIO_stderr()); if (e_tmpname) { if (e_fp) { ! PerlIO_close(e_fp); e_fp = Nullfp; } (void)UNLINK(e_tmpname); *************** *** 2064,2070 **** char *tmpname; SV** svp; I32 gimme = G_SCALAR; ! FILE *tryrsfp = 0; sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { --- 2064,2070 ---- char *tmpname; SV** svp; I32 gimme = G_SCALAR; ! PerlIO *tryrsfp = 0; sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { *************** *** 2098,2104 **** #endif ) { ! tryrsfp = fopen(tmpname,"r"); } else { AV *ar = GvAVn(incgv); --- 2098,2104 ---- #endif ) { ! tryrsfp = PerlIO_open(tmpname,"r"); } else { AV *ar = GvAVn(incgv); *************** *** 2113,2119 **** (void)sprintf(buf, "%s/%s", SvPVx(*av_fetch(ar, i, TRUE), na), name); #endif ! tryrsfp = fopen(buf, "r"); if (tryrsfp) { char *s = buf; --- 2113,2119 ---- (void)sprintf(buf, "%s/%s", SvPVx(*av_fetch(ar, i, TRUE), na), name); #endif ! tryrsfp = PerlIO_open(buf, "r"); if (tryrsfp) { char *s = buf; *************** *** 2225,2231 **** I32 gimme; register CONTEXT *cx; OP *retop; ! OP *saveop = op; I32 optype; POPBLOCK(cx,newpm); --- 2225,2231 ---- I32 gimme; register CONTEXT *cx; OP *retop; ! U8 save_flags = op -> op_flags; I32 optype; POPBLOCK(cx,newpm); *************** *** 2252,2258 **** } else { for (mark = newsp + 1; mark <= SP; mark++) ! if (!(SvFLAGS(TOPs) & SVs_TEMP)) *mark = sv_mortalcopy(*mark); /* in case LEAVE wipes old return values */ } --- 2252,2258 ---- } else { for (mark = newsp + 1; mark <= SP; mark++) ! if (!(SvFLAGS(*mark) & SVs_TEMP)) *mark = sv_mortalcopy(*mark); /* in case LEAVE wipes old return values */ } *************** *** 2269,2275 **** lex_end(); LEAVE; ! if (!(saveop->op_flags & OPf_SPECIAL)) sv_setpv(GvSV(errgv),""); RETURNOP(retop); --- 2269,2275 ---- lex_end(); LEAVE; ! if (!(save_flags & OPf_SPECIAL)) sv_setpv(GvSV(errgv),""); RETURNOP(retop); *************** *** 2328,2334 **** } else { for (mark = newsp + 1; mark <= SP; mark++) ! if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))) *mark = sv_mortalcopy(*mark); /* in case LEAVE wipes old return values */ } --- 2328,2334 ---- } else { for (mark = newsp + 1; mark <= SP; mark++) ! if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) *mark = sv_mortalcopy(*mark); /* in case LEAVE wipes old return values */ } Index: pp_hot.c *** perl5.003_01/pp_hot.c Tue Jul 30 23:12:24 1996 --- perl5.003_02/pp_hot.c Fri Aug 9 11:02:30 1996 *************** *** 252,259 **** { dSP; if (SvIOK(TOPs)) { ! ++SvIVX(TOPs); ! SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK); } else sv_inc(TOPs); --- 252,264 ---- { dSP; if (SvIOK(TOPs)) { ! 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,321 **** dSP; dMARK; dORIGMARK; GV *gv; IO *io; ! register FILE *fp; if (op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; --- 320,326 ---- dSP; dMARK; dORIGMARK; GV *gv; IO *io; ! register PerlIO *fp; if (op->op_flags & OPf_STACKED) gv = (GV*)*++MARK; *************** *** 351,357 **** break; MARK++; if (MARK <= SP) { ! if (fwrite1(ofs, 1, ofslen, fp) == 0 || ferror(fp)) { MARK--; break; } --- 356,362 ---- break; MARK++; if (MARK <= SP) { ! if (PerlIO_write(fp, ofs, ofslen) == 0 || PerlIO_error(fp)) { MARK--; break; } *************** *** 369,379 **** goto just_say_no; else { if (orslen) ! if (fwrite1(ors, 1, orslen, fp) == 0 || ferror(fp)) goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) ! if (Fflush(fp) == EOF) goto just_say_no; } } --- 374,384 ---- goto just_say_no; else { if (orslen) ! if (PerlIO_write(fp, ors, orslen) == 0 || PerlIO_error(fp)) goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) ! if (PerlIO_flush(fp) == EOF) goto just_say_no; } } *************** *** 603,609 **** } break; case SVt_PVHV: { - char *tmps; SV *tmpstr; hash = (HV*)sv; --- 608,613 ---- *************** *** 616,631 **** 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); if (magic) mg_set(tmpstr); tainted = 0; } } break; default: --- 620,636 ---- sv = *(relem++); else sv = &sv_no, relem++; tmpstr = NEWSV(29,0); if (*relem) sv_setsv(tmpstr,*relem); /* value */ *(relem++) = tmpstr; ! (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,950 **** register SV *sv; STRLEN tmplen = 0; STRLEN offset; ! FILE *fp; register IO *io = GvIO(last_in_gv); register I32 type = op->op_type; --- 949,955 ---- register SV *sv; STRLEN tmplen = 0; STRLEN offset; ! PerlIO *fp; register IO *io = GvIO(last_in_gv); register I32 type = op->op_type; *************** *** 984,990 **** char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; char tmpfnam[L_tmpnam] = "SYS$SCRATCH:"; $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); ! FILE *tmpfp; STRLEN i; struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; --- 989,995 ---- char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp; char tmpfnam[L_tmpnam] = "SYS$SCRATCH:"; $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;"); ! PerlIO *tmpfp; STRLEN i; struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; *************** *** 1014,1020 **** break; } } ! if ((tmpfp = fopen(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, --- 1019,1025 ---- break; } } ! 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,1038 **** while (*(--begin) != ']' && *begin != '>') ; ++begin; } ! ok = (fputs(begin,tmpfp) != EOF); } if (cxt) (void)lib$find_file_end(&cxt); if (ok && sts != RMS$_NMF && --- 1037,1043 ---- while (*(--begin) != ']' && *begin != '>') ; ++begin; } ! ok = (PerlIO_puts(tmpfp,begin) != EOF); } if (cxt) (void)lib$find_file_end(&cxt); if (ok && sts != RMS$_NMF && *************** *** 1041,1051 **** if (!(sts & 1)) { SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); } ! fclose(tmpfp); fp = NULL; } else { ! rewind(tmpfp); IoTYPE(io) = '<'; IoIFP(io) = fp = tmpfp; } --- 1046,1056 ---- if (!(sts & 1)) { SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts); } ! PerlIO_close(tmpfp); fp = NULL; } else { ! PerlIO_rewind(tmpfp); IoTYPE(io) = '<'; IoIFP(io) = fp = tmpfp; } *************** *** 1114,1120 **** } for (;;) { if (!sv_gets(sv, fp, offset)) { ! clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { fp = nextargv(last_in_gv); if (fp) --- 1119,1125 ---- } for (;;) { if (!sv_gets(sv, fp, offset)) { ! PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { fp = nextargv(last_in_gv); if (fp) *************** *** 1206,1229 **** { dSP; SV** svp; 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); if (lval) { ! if (!svp || *svp == &sv_undef) ! DIE(no_helem, key); if (op->op_private & OPpLVAL_INTRO) ! save_svref(svp); else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) ! provide_ref(op, *svp); } ! PUSHs(svp ? *svp : &sv_undef); RETURN; } --- 1211,1233 ---- { dSP; SV** svp; + HE* he; SV *keysv = POPs; HV *hv = (HV*)POPs; I32 lval = op->op_flags & OPf_MOD; if (SvTYPE(hv) != SVt_PVHV) RETPUSHUNDEF; ! he = hv_fetch_ent(hv, keysv, lval, 0); if (lval) { ! if (!he || HeVAL(he) == &sv_undef) ! DIE(no_helem, SvPV(keysv, na)); if (op->op_private & OPpLVAL_INTRO) ! save_svref(&HeVAL(he)); else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) ! provide_ref(op, HeVAL(he)); } ! PUSHs(he ? HeVAL(he) : &sv_undef); RETURN; } Index: pp_sys.c *** perl5.003_01/pp_sys.c Tue Jul 30 23:12:25 1996 --- perl5.003_02/pp_sys.c Thu Aug 8 10:10:10 1996 *************** *** 99,105 **** PP(pp_backtick) { dSP; dTARGET; ! FILE *fp; char *tmps = POPp; TAINT_PROPER("``"); fp = my_popen(tmps, "r"); --- 99,105 ---- PP(pp_backtick) { dSP; dTARGET; ! PerlIO *fp; char *tmps = POPp; TAINT_PROPER("``"); fp = my_popen(tmps, "r"); *************** *** 294,309 **** if (pipe(fd) < 0) goto badexit; ! IoIFP(rstio) = fdopen(fd[0], "r"); ! IoOFP(wstio) = fdopen(fd[1], "w"); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = '<'; IoTYPE(wstio) = '>'; if (!IoIFP(rstio) || !IoOFP(wstio)) { ! if (IoIFP(rstio)) fclose(IoIFP(rstio)); else close(fd[0]); ! if (IoOFP(wstio)) fclose(IoOFP(wstio)); else close(fd[1]); goto badexit; } --- 294,309 ---- if (pipe(fd) < 0) goto badexit; ! 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)) PerlIO_close(IoIFP(rstio)); else close(fd[0]); ! if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio)); else close(fd[1]); goto badexit; } *************** *** 322,334 **** dSP; dTARGET; GV *gv; IO *io; ! FILE *fp; if (MAXARG < 1) RETPUSHUNDEF; gv = (GV*)POPs; if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) RETPUSHUNDEF; ! PUSHi(fileno(fp)); RETURN; } --- 322,334 ---- dSP; dTARGET; GV *gv; IO *io; ! PerlIO *fp; if (MAXARG < 1) RETPUSHUNDEF; gv = (GV*)POPs; if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) RETPUSHUNDEF; ! PUSHi(PerlIO_fileno(fp)); RETURN; } *************** *** 357,363 **** dSP; GV *gv; IO *io; ! FILE *fp; if (MAXARG < 1) RETPUSHUNDEF; --- 357,363 ---- dSP; GV *gv; IO *io; ! PerlIO *fp; if (MAXARG < 1) RETPUSHUNDEF; *************** *** 370,381 **** #ifdef DOSISH #ifdef atarist ! if (!Fflush(fp) && (fp->_flag |= _IOBIN)) RETPUSHYES; else RETPUSHUNDEF; #else ! if (setmode(fileno(fp), OP_BINARY) != -1) RETPUSHYES; else RETPUSHUNDEF; --- 370,381 ---- #ifdef DOSISH #ifdef atarist ! if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN)) RETPUSHYES; else RETPUSHUNDEF; #else ! if (setmode(PerlIO_fileno(fp), OP_BINARY) != -1) RETPUSHYES; else RETPUSHUNDEF; *************** *** 777,783 **** RETPUSHUNDEF; TAINT_IF(1); sv_setpv(TARG, " "); ! *SvPVX(TARG) = getc(IoIFP(GvIOp(gv))); /* should never be EOF */ PUSHTARG; RETURN; } --- 777,783 ---- RETPUSHUNDEF; TAINT_IF(1); sv_setpv(TARG, " "); ! *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ PUSHTARG; RETURN; } *************** *** 856,868 **** dSP; GV *gv = cxstack[cxstack_ix].blk_sub.gv; register IO *io = GvIOp(gv); ! FILE *ofp = IoOFP(io); ! FILE *fp; SV **newsp; I32 gimme; register CONTEXT *cx; ! DEBUG_f(fprintf(Perl_debug_log,"left=%ld, todo=%ld\n", (long)IoLINES_LEFT(io), (long)FmLINES(formtarget))); if (IoLINES_LEFT(io) < FmLINES(formtarget) && formtarget != toptarget) --- 856,868 ---- dSP; GV *gv = cxstack[cxstack_ix].blk_sub.gv; register IO *io = GvIOp(gv); ! PerlIO *ofp = IoOFP(io); ! PerlIO *fp; SV **newsp; I32 gimme; register CONTEXT *cx; ! 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,915 **** s++; } if (s) { ! fwrite1(SvPVX(formtarget), s - SvPVX(formtarget), 1, ofp); sv_chop(formtarget, s); FmLINES(formtarget) -= IoLINES_LEFT(io); } } if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0) ! fwrite1(SvPVX(formfeed), SvCUR(formfeed), 1, ofp); IoLINES_LEFT(io) = IoPAGE_LEN(io); IoPAGE(io)++; formtarget = toptarget; --- 903,915 ---- s++; } if (s) { ! 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) ! PerlIO_write(ofp, SvPVX(formfeed), SvCUR(formfeed)); IoLINES_LEFT(io) = IoPAGE_LEN(io); IoPAGE(io)++; formtarget = toptarget; *************** *** 946,960 **** if (dowarn) warn("page overflow"); } ! if (!fwrite1(SvPVX(formtarget), 1, SvCUR(formtarget), ofp) || ! ferror(fp)) PUSHs(&sv_no); else { FmLINES(formtarget) = 0; SvCUR_set(formtarget, 0); *SvEND(formtarget) = '\0'; if (IoFLAGS(io) & IOf_FLUSH) ! (void)Fflush(fp); PUSHs(&sv_yes); } } --- 946,960 ---- if (dowarn) warn("page overflow"); } ! 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)PerlIO_flush(fp); PUSHs(&sv_yes); } } *************** *** 968,974 **** dSP; dMARK; dORIGMARK; GV *gv; IO *io; ! FILE *fp; SV *sv = NEWSV(0,0); if (op->op_flags & OPf_STACKED) --- 968,974 ---- dSP; dMARK; dORIGMARK; GV *gv; IO *io; ! PerlIO *fp; SV *sv = NEWSV(0,0); if (op->op_flags & OPf_STACKED) *************** *** 1000,1006 **** goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) ! if (Fflush(fp) == EOF) goto just_say_no; } SvREFCNT_dec(sv); --- 1000,1006 ---- goto just_say_no; if (IoFLAGS(io) & IOf_FLUSH) ! if (PerlIO_flush(fp) == EOF) goto just_say_no; } SvREFCNT_dec(sv); *************** *** 1075,1081 **** if (op->op_type == OP_RECV) { bufsize = sizeof buf; buffer = SvGROW(bufsv, length+1); ! length = recvfrom(fileno(IoIFP(io)), buffer, length, offset, (struct sockaddr *)buf, &bufsize); if (length < 0) RETPUSHUNDEF; --- 1075,1081 ---- if (op->op_type == OP_RECV) { bufsize = sizeof buf; buffer = SvGROW(bufsv, length+1); ! length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, (struct sockaddr *)buf, &bufsize); if (length < 0) RETPUSHUNDEF; *************** *** 1096,1113 **** #endif buffer = SvGROW(bufsv, length+offset+1); if (op->op_type == OP_SYSREAD) { ! length = read(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, (struct sockaddr *)buf, &bufsize); } else #endif ! length = fread(buffer+offset, 1, length, IoIFP(io)); if (length < 0) goto say_undef; SvCUR_set(bufsv, length+offset); --- 1096,1113 ---- #endif buffer = SvGROW(bufsv, length+offset+1); if (op->op_type == OP_SYSREAD) { ! 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(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0, (struct sockaddr *)buf, &bufsize); } else #endif ! length = PerlIO_read(IoIFP(io), buffer+offset, length); if (length < 0) goto say_undef; SvCUR_set(bufsv, length+offset); *************** *** 1167,1184 **** offset = 0; if (length > blen - offset) length = blen - offset; ! length = write(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, (struct sockaddr *)sockbuf, mlen); } else ! length = send(fileno(IoIFP(io)), buffer, blen, length); #else else DIE(no_sock_func, "send"); --- 1167,1184 ---- offset = 0; if (length > blen - offset) length = blen - offset; ! 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(PerlIO_fileno(IoIFP(io)), buffer, blen, length, (struct sockaddr *)sockbuf, mlen); } else ! length = send(PerlIO_fileno(IoIFP(io)), buffer, blen, length); #else else DIE(no_sock_func, "send"); *************** *** 1251,1259 **** do_ftruncate: if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || #ifdef HAS_TRUNCATE ! ftruncate(fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #else ! my_chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #endif result = 0; } --- 1251,1259 ---- do_ftruncate: if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || #ifdef HAS_TRUNCATE ! ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #else ! my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #endif result = 0; } *************** *** 1340,1346 **** if (optype == OP_IOCTL) #ifdef HAS_IOCTL ! retval = ioctl(fileno(IoIFP(io)), func, s); #else DIE("ioctl is not implemented"); #endif --- 1340,1346 ---- if (optype == OP_IOCTL) #ifdef HAS_IOCTL ! retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s); #else DIE("ioctl is not implemented"); #endif *************** *** 1350,1358 **** #else # ifdef HAS_FCNTL # if defined(OS2) && defined(__EMX__) ! retval = fcntl(fileno(IoIFP(io)), func, (int)s); # else ! retval = fcntl(fileno(IoIFP(io)), func, s); # endif # else DIE("fcntl is not implemented"); --- 1350,1358 ---- #else # ifdef HAS_FCNTL # if defined(OS2) && defined(__EMX__) ! retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); # else ! retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); # endif # else DIE("fcntl is not implemented"); *************** *** 1384,1390 **** I32 value; int argtype; GV *gv; ! FILE *fp; #if !defined(HAS_FLOCK) && defined(HAS_LOCKF) # define flock lockf_emulate_flock --- 1384,1390 ---- I32 value; int argtype; GV *gv; ! PerlIO *fp; #if !defined(HAS_FLOCK) && defined(HAS_LOCKF) # define flock lockf_emulate_flock *************** *** 1401,1407 **** else fp = Nullfp; if (fp) { ! value = (I32)(flock(fileno(fp), argtype) >= 0); } else value = 0; --- 1401,1407 ---- else fp = Nullfp; if (fp) { ! value = (I32)(flock(PerlIO_fileno(fp), argtype) >= 0); } else value = 0; *************** *** 1440,1451 **** fd = socket(domain, type, protocol); if (fd < 0) RETPUSHUNDEF; ! IoIFP(io) = fdopen(fd, "r"); /* stdio gets confused about sockets */ ! IoOFP(io) = 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) && !IoOFP(io)) close(fd); RETPUSHUNDEF; } --- 1440,1451 ---- fd = socket(domain, type, protocol); if (fd < 0) RETPUSHUNDEF; ! 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)) PerlIO_close(IoIFP(io)); ! if (IoOFP(io)) PerlIO_close(IoOFP(io)); if (!IoIFP(io) && !IoOFP(io)) close(fd); RETPUSHUNDEF; } *************** *** 1484,1501 **** TAINT_PROPER("socketpair"); if (socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; ! IoIFP(io1) = fdopen(fd[0], "r"); ! IoOFP(io1) = fdopen(fd[0], "w"); IoTYPE(io1) = 's'; ! IoIFP(io2) = fdopen(fd[1], "r"); ! IoOFP(io2) = 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) && !IoOFP(io1)) close(fd[0]); ! if (IoIFP(io2)) fclose(IoIFP(io2)); ! if (IoOFP(io2)) fclose(IoOFP(io2)); if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]); RETPUSHUNDEF; } --- 1484,1501 ---- TAINT_PROPER("socketpair"); if (socketpair(domain, type, protocol, fd) < 0) RETPUSHUNDEF; ! IoIFP(io1) = PerlIO_fdopen(fd[0], "r"); ! IoOFP(io1) = PerlIO_fdopen(fd[0], "w"); IoTYPE(io1) = 's'; ! 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)) PerlIO_close(IoIFP(io1)); ! if (IoOFP(io1)) PerlIO_close(IoOFP(io1)); if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]); ! if (IoIFP(io2)) PerlIO_close(IoIFP(io2)); ! if (IoOFP(io2)) PerlIO_close(IoOFP(io2)); if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]); RETPUSHUNDEF; } *************** *** 1521,1527 **** addr = SvPV(addrsv, len); TAINT_PROPER("bind"); ! if (bind(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; else RETPUSHUNDEF; --- 1521,1527 ---- addr = SvPV(addrsv, len); TAINT_PROPER("bind"); ! if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; else RETPUSHUNDEF; *************** *** 1551,1557 **** addr = SvPV(addrsv, len); TAINT_PROPER("connect"); ! if (connect(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; else RETPUSHUNDEF; --- 1551,1557 ---- addr = SvPV(addrsv, len); TAINT_PROPER("connect"); ! if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0) RETPUSHYES; else RETPUSHUNDEF; *************** *** 1577,1583 **** if (!io || !IoIFP(io)) goto nuts; ! if (listen(fileno(IoIFP(io)), backlog) >= 0) RETPUSHYES; else RETPUSHUNDEF; --- 1577,1583 ---- if (!io || !IoIFP(io)) goto nuts; ! if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) RETPUSHYES; else RETPUSHUNDEF; *************** *** 1620,1634 **** if (IoIFP(nstio)) do_close(ngv, FALSE); ! fd = accept(fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len); if (fd < 0) goto badexit; ! IoIFP(nstio) = fdopen(fd, "r"); ! IoOFP(nstio) = 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) && !IoOFP(nstio)) close(fd); goto badexit; } --- 1620,1634 ---- if (IoIFP(nstio)) do_close(ngv, FALSE); ! fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len); if (fd < 0) goto badexit; ! IoIFP(nstio) = PerlIO_fdopen(fd, "r"); ! IoOFP(nstio) = PerlIO_fdopen(fd, "w"); IoTYPE(nstio) = 's'; if (!IoIFP(nstio) || !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,1666 **** if (!io || !IoIFP(io)) goto nuts; ! PUSHi( shutdown(fileno(IoIFP(io)), how) >= 0 ); RETURN; nuts: --- 1660,1666 ---- if (!io || !IoIFP(io)) goto nuts; ! PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); RETURN; nuts: *************** *** 1707,1713 **** if (!io || !IoIFP(io)) goto nuts; ! fd = fileno(IoIFP(io)); switch (optype) { case OP_GSOCKOPT: SvGROW(sv, 257); --- 1707,1713 ---- if (!io || !IoIFP(io)) goto nuts; ! fd = PerlIO_fileno(IoIFP(io)); switch (optype) { case OP_GSOCKOPT: SvGROW(sv, 257); *************** *** 1779,1785 **** SvCUR_set(sv,256); *SvEND(sv) ='\0'; aint = SvCUR(sv); ! fd = fileno(IoIFP(io)); switch (optype) { case OP_GETSOCKNAME: if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0) --- 1779,1785 ---- SvCUR_set(sv,256); *SvEND(sv) ='\0'; aint = SvCUR(sv); ! fd = PerlIO_fileno(IoIFP(io)); switch (optype) { case OP_GETSOCKNAME: if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0) *************** *** 1828,1834 **** statgv = tmpgv; sv_setpv(statname, ""); if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || ! Fstat(fileno(IoIFP(GvIOn(tmpgv))), &statcache) < 0) { max = 0; laststatval = -1; } --- 1828,1834 ---- statgv = tmpgv; sv_setpv(statname, ""); if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) || ! Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) < 0) { max = 0; laststatval = -1; } *************** *** 2176,2182 **** else gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO); if (GvIO(gv) && IoIFP(GvIOp(gv))) ! fd = fileno(IoIFP(GvIOp(gv))); else if (isDIGIT(*tmps)) fd = atoi(tmps); else --- 2176,2182 ---- else gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO); if (GvIO(gv) && IoIFP(GvIOp(gv))) ! fd = PerlIO_fileno(IoIFP(GvIOp(gv))); else if (isDIGIT(*tmps)) fd = atoi(tmps); else *************** *** 2221,2245 **** io = GvIO(statgv); } if (io && IoIFP(io)) { ! #ifdef FILE_base ! Fstat(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 (i != EOF) ! (void)ungetc(i, IoIFP(io)); } ! if (FILE_cnt(IoIFP(io)) <= 0) /* null file is anything */ RETPUSHYES; ! len = FILE_bufsiz(IoIFP(io)); ! s = FILE_base(IoIFP(io)); ! #else DIE("-T and -B not implemented on filehandles"); ! #endif } else { if (dowarn) --- 2221,2249 ---- io = GvIO(statgv); } if (io && IoIFP(io)) { ! 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 (PerlIO_get_cnt(IoIFP(io)) <= 0) { ! i = PerlIO_getc(IoIFP(io)); if (i != EOF) ! (void)PerlIO_ungetc(IoIFP(io),i); } ! if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */ RETPUSHYES; ! 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"); ! } } else { if (dowarn) *************** *** 2473,2479 **** char *s, *save_filename = filename; int anum = 1; ! FILE *myfp; strcpy(mybuf, cmd); strcat(mybuf, " "); --- 2477,2483 ---- char *s, *save_filename = filename; int anum = 1; ! PerlIO *myfp; strcpy(mybuf, cmd); strcat(mybuf, " "); *************** *** 2485,2491 **** myfp = my_popen(mybuf, "r"); if (myfp) { *mybuf = '\0'; ! s = fgets(mybuf, sizeof mybuf, myfp); (void)my_pclose(myfp); if (s != Nullch) { for (errno = 1; errno < sys_nerr; errno++) { --- 2489,2496 ---- myfp = my_popen(mybuf, "r"); if (myfp) { *mybuf = '\0'; ! /* 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++) { Index: proto.h *** perl5.003_01/proto.h Tue Jul 30 23:12:25 1996 --- perl5.003_02/proto.h Tue Aug 6 12:55:04 1996 *************** *** 46,51 **** --- 46,52 ---- 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,90 **** 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)); void do_pipe _((SV* sv, GV* rgv, GV* wgv)); ! bool do_print _((SV* sv, FILE* fp)); OP * do_readline _((void)); I32 do_chomp _((SV* sv)); bool do_seek _((GV* gv, long pos, int whence)); --- 83,91 ---- I32 do_msgsnd _((SV** mark, SV** sp)); #endif bool do_open _((GV* gv, char* name, I32 len, ! int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp)); void do_pipe _((SV* sv, GV* rgv, GV* wgv)); ! bool do_print _((SV* sv, PerlIO* fp)); OP * do_readline _((void)); I32 do_chomp _((SV* sv)); bool do_seek _((GV* gv, long pos, int whence)); *************** *** 235,242 **** #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)); void my_setenv _((char* nam, char* val)); I32 my_stat _((void)); #ifdef MYSWAP --- 236,243 ---- #ifndef HAS_MEMCMP I32 my_memcmp _((unsigned char* s1, unsigned char* s2, I32 len)); #endif ! 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,300 **** 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)); char* ninstr _((char* big, char* bigend, char* little, char* lend)); OP * oopsCV _((OP* o)); void op_free _((OP* arg)); --- 295,301 ---- 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)); ! PerlIO* nextargv _((GV* gv)); char* ninstr _((char* big, char* bigend, char* little, char* lend)); OP * oopsCV _((OP* o)); void op_free _((OP* arg)); *************** *** 435,441 **** 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)); #ifndef DOSISH char* sv_grow _((SV* sv, I32 newlen)); #else --- 436,442 ---- I32 sv_eq _((SV* sv1, SV* sv2)); void sv_free _((SV* sv)); void sv_free_arenas _((void)); ! char* sv_gets _((SV* sv, PerlIO* fp, I32 append)); #ifndef DOSISH char* sv_grow _((SV* sv, I32 newlen)); #else Index: regcomp.c *** perl5.003_01/regcomp.c Tue Jul 30 23:12:26 1996 --- perl5.003_02/regcomp.c Thu Aug 8 09:45:57 1996 *************** *** 244,250 **** 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", OP(first), OP(NEXTOPER(first)), first - scan)); /* * If there's something expensive in the r.e., find the --- 244,250 ---- if (sawplus && (!sawopen || !regsawback)) r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */ ! 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,1462 **** s++; #endif op = OP(s); ! fprintf(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)"); else ! fprintf(Perl_debug_log,"(%d)", (s-r->program)+(next-s)); s += 3; if (op == ANYOF) { s += 32; --- 1450,1462 ---- s++; #endif op = OP(s); ! 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. */ ! PerlIO_printf(Perl_debug_log, "(0)"); else ! PerlIO_printf(Perl_debug_log, "(%d)", (s-r->program)+(next-s)); s += 3; if (op == ANYOF) { s += 32; *************** *** 1464,1497 **** if (op == EXACTLY) { /* Literal string, where present. */ s++; ! (void)putc(' ', Perl_debug_log); ! (void)putc('<', Perl_debug_log); while (*s != '\0') { ! (void)putc(*s, Perl_debug_log); s++; } ! (void)putc('>', Perl_debug_log); s++; } ! (void)putc('\n', Perl_debug_log); } /* Header fields of interest. */ if (r->regstart) ! fprintf(Perl_debug_log,"start `%s' ", SvPVX(r->regstart)); if (r->regstclass) ! fprintf(Perl_debug_log,"stclass `%s' ", regprop(r->regstclass)); if (r->reganch & ROPT_ANCH) ! fprintf(Perl_debug_log,"anchored "); if (r->reganch & ROPT_SKIP) ! fprintf(Perl_debug_log,"plus "); if (r->reganch & ROPT_IMPLICIT) ! fprintf(Perl_debug_log,"implicit "); if (r->regmust != NULL) ! fprintf(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"); } /* --- 1464,1497 ---- if (op == EXACTLY) { /* Literal string, where present. */ s++; ! (void)PerlIO_putc(Perl_debug_log, ' '); ! (void)PerlIO_putc(Perl_debug_log, '<'); while (*s != '\0') { ! (void)PerlIO_putc(Perl_debug_log,*s); s++; } ! (void)PerlIO_putc(Perl_debug_log, '>'); s++; } ! (void)PerlIO_putc(Perl_debug_log, '\n'); } /* Header fields of interest. */ if (r->regstart) ! PerlIO_printf(Perl_debug_log, "start `%s' ", SvPVX(r->regstart)); if (r->regstclass) ! PerlIO_printf(Perl_debug_log, "stclass `%s' ", regprop(r->regstclass)); if (r->reganch & ROPT_ANCH) ! PerlIO_printf(Perl_debug_log, "anchored "); if (r->reganch & ROPT_SKIP) ! PerlIO_printf(Perl_debug_log, "plus "); if (r->reganch & ROPT_IMPLICIT) ! PerlIO_printf(Perl_debug_log, "implicit "); if (r->regmust != NULL) ! PerlIO_printf(Perl_debug_log, "must have \"%s\" back %ld ", SvPVX(r->regmust), (long) r->regback); ! PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen); ! PerlIO_printf(Perl_debug_log, "\n"); } /* Index: regexec.c *** perl5.003_01/regexec.c Tue Jul 30 23:12:26 1996 --- perl5.003_02/regexec.c Thu Aug 8 13:34:52 1996 *************** *** 590,596 **** #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, "", scan - regprogram, regprop(scan), locinput); } #else --- 590,596 ---- #define sayNO goto no #define saySAME(x) if (x) goto yes; else goto no if (regnarrate) { ! PerlIO_printf(Perl_debug_log, "%*s%2d%-8.8s\t<%.10s>\n", regindent*2, "", scan - regprogram, regprop(scan), locinput); } #else *************** *** 806,812 **** #ifdef DEBUGGING if (regnarrate) ! fprintf(Perl_debug_log, "%*s %d %lx\n", regindent*2, "", n, (long)cc); #endif --- 806,812 ---- #ifdef DEBUGGING if (regnarrate) ! PerlIO_printf(Perl_debug_log, "%*s %d %lx\n", regindent*2, "", n, (long)cc); #endif *************** *** 986,992 **** sayNO; break; default: ! fprintf(stderr, "%x %d\n",(unsigned)scan,scan[1]); FAIL("regexp memory corruption"); } scan = next; --- 986,992 ---- sayNO; break; default: ! PerlIO_printf(PerlIO_stderr(), "%x %d\n",(unsigned)scan,scan[1]); FAIL("regexp memory corruption"); } scan = next; Index: run.c *** perl5.003_01/run.c Tue Jul 30 23:12:26 1996 --- perl5.003_02/run.c Thu Aug 8 09:45:57 1996 *************** *** 47,53 **** do { if (debug) { if (watchaddr != 0 && *watchaddr != watchok) ! fprintf(Perl_debug_log, "WARNING: %lx changed from %lx to %lx\n", (long)watchaddr, (long)watchok, (long)*watchaddr); DEBUG_s(debstack()); DEBUG_t(debop(op)); --- 47,53 ---- do { if (debug) { if (watchaddr != 0 && *watchaddr != watchok) ! 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,87 **** deb("%s", op_name[op->op_type]); switch (op->op_type) { case OP_CONST: ! fprintf(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)); SvREFCNT_dec(sv); } else ! fprintf(Perl_debug_log, "(NULL)"); break; default: break; } ! fprintf(Perl_debug_log, "\n"); return 0; } --- 65,87 ---- deb("%s", op_name[op->op_type]); switch (op->op_type) { case OP_CONST: ! 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); ! PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, na)); SvREFCNT_dec(sv); } else ! PerlIO_printf(Perl_debug_log, "(NULL)"); break; default: break; } ! PerlIO_printf(Perl_debug_log, "\n"); return 0; } *************** *** 91,97 **** { watchaddr = addr; watchok = *addr; ! fprintf(Perl_debug_log, "WATCHING, %lx is currently %lx\n", (long)watchaddr, (long)watchok); } --- 91,97 ---- { watchaddr = addr; watchok = *addr; ! PerlIO_printf(Perl_debug_log, "WATCHING, %lx is currently %lx\n", (long)watchaddr, (long)watchok); } *************** *** 112,118 **** return; for (i = 0; i < MAXO; i++) { if (profiledata[i]) ! fprintf(Perl_debug_log, "%d\t%lu\n", i, profiledata[i]); } } --- 112,118 ---- return; for (i = 0; i < MAXO; i++) { if (profiledata[i]) ! PerlIO_printf(Perl_debug_log, "%d\t%lu\n", i, profiledata[i]); } } Index: scope.c *** perl5.003_01/scope.c Tue Jul 30 23:12:27 1996 --- perl5.003_02/scope.c Thu Aug 8 09:45:57 1996 *************** *** 613,700 **** cx_dump(cx) CONTEXT* cx; { ! fprintf(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"); } switch (cx->cx_type) { case CXt_NULL: case CXt_BLOCK: break; case CXt_SUB: ! fprintf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n", (long)cx->blk_sub.cv); ! fprintf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n", (long)cx->blk_sub.gv); ! fprintf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n", (long)cx->blk_sub.dfoutgv); ! fprintf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", (long)cx->blk_sub.olddepth); ! fprintf(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", (long)cx->blk_eval.old_in_eval); ! fprintf(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", cx->blk_eval.old_name); ! fprintf(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", cx->blk_loop.label); ! fprintf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n", (long)cx->blk_loop.resetsp); ! fprintf(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", (long)cx->blk_loop.next_op); ! fprintf(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", (long)cx->blk_loop.iterix); ! fprintf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n", (long)cx->blk_loop.iterary); ! fprintf(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", (long)cx->blk_loop.itersave); break; case CXt_SUBST: ! fprintf(Perl_debug_log, "SB_ITERS = %ld\n", (long)cx->sb_iters); ! fprintf(Perl_debug_log, "SB_MAXITERS = %ld\n", (long)cx->sb_maxiters); ! fprintf(Perl_debug_log, "SB_SAFEBASE = %ld\n", (long)cx->sb_safebase); ! fprintf(Perl_debug_log, "SB_ONCE = %ld\n", (long)cx->sb_once); ! fprintf(Perl_debug_log, "SB_ORIG = %s\n", cx->sb_orig); ! fprintf(Perl_debug_log, "SB_DSTR = 0x%lx\n", (long)cx->sb_dstr); ! fprintf(Perl_debug_log, "SB_TARG = 0x%lx\n", (long)cx->sb_targ); ! fprintf(Perl_debug_log, "SB_S = 0x%lx\n", (long)cx->sb_s); ! fprintf(Perl_debug_log, "SB_M = 0x%lx\n", (long)cx->sb_m); ! fprintf(Perl_debug_log, "SB_STREND = 0x%lx\n", (long)cx->sb_strend); ! fprintf(Perl_debug_log, "SB_SUBBASE = 0x%lx\n", (long)cx->sb_subbase); break; } --- 613,700 ---- cx_dump(cx) CONTEXT* cx; { ! PerlIO_printf(Perl_debug_log, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]); if (cx->cx_type != CXt_SUBST) { ! 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: ! PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n", (long)cx->blk_sub.cv); ! PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n", (long)cx->blk_sub.gv); ! PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n", (long)cx->blk_sub.dfoutgv); ! PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n", (long)cx->blk_sub.olddepth); ! PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n", (int)cx->blk_sub.hasargs); break; case CXt_EVAL: ! PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n", (long)cx->blk_eval.old_in_eval); ! 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]); ! PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n", cx->blk_eval.old_name); ! PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n", (long)cx->blk_eval.old_eval_root); break; case CXt_LOOP: ! PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n", cx->blk_loop.label); ! PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n", (long)cx->blk_loop.resetsp); ! PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%lx\n", (long)cx->blk_loop.redo_op); ! PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%lx\n", (long)cx->blk_loop.next_op); ! PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%lx\n", (long)cx->blk_loop.last_op); ! PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n", (long)cx->blk_loop.iterix); ! PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n", (long)cx->blk_loop.iterary); ! PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%lx\n", (long)cx->blk_loop.itervar); if (cx->blk_loop.itervar) ! PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n", (long)cx->blk_loop.itersave); break; case CXt_SUBST: ! PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n", (long)cx->sb_iters); ! PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n", (long)cx->sb_maxiters); ! PerlIO_printf(Perl_debug_log, "SB_SAFEBASE = %ld\n", (long)cx->sb_safebase); ! PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n", (long)cx->sb_once); ! PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n", cx->sb_orig); ! PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%lx\n", (long)cx->sb_dstr); ! PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%lx\n", (long)cx->sb_targ); ! PerlIO_printf(Perl_debug_log, "SB_S = 0x%lx\n", (long)cx->sb_s); ! PerlIO_printf(Perl_debug_log, "SB_M = 0x%lx\n", (long)cx->sb_m); ! PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%lx\n", (long)cx->sb_strend); ! PerlIO_printf(Perl_debug_log, "SB_SUBBASE = 0x%lx\n", (long)cx->sb_subbase); break; } Index: sv.c *** perl5.003_01/sv.c Tue Jul 30 23:12:28 1996 --- perl5.003_02/sv.c Thu Aug 8 13:34:52 1996 *************** *** 198,204 **** svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { ! fprintf(stderr, "****\n"); sv_dump(sv); } ++sv; --- 198,204 ---- svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { ! PerlIO_printf(PerlIO_stderr(), "****\n"); sv_dump(sv); } ++sv; *************** *** 223,229 **** if (SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) && SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { ! DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "), sv_dump(sv));) SvROK_off(sv); SvRV(sv) = 0; --- 223,229 ---- if (SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) && SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { ! DEBUG_D((PerlIO_printf(PerlIO_stderr(), "Cleaning object ref:\n "), sv_dump(sv));) SvROK_off(sv); SvRV(sv) = 0; *************** *** 240,246 **** svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { ! DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "), sv_dump(sv));) SvROK_off(sv); SvRV(sv) = 0; --- 240,246 ---- svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { ! DEBUG_D((PerlIO_printf(PerlIO_stderr(), "Cleaning object ref:\n "), sv_dump(sv));) SvROK_off(sv); SvRV(sv) = 0; *************** *** 267,273 **** svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { ! DEBUG_D((fprintf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); } --- 267,273 ---- svend = &sva[SvREFCNT(sva)]; while (sv < svend) { if (SvTYPE(sv) != SVTYPEMASK) { ! DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); } *************** *** 971,977 **** #ifdef MSDOS if (newlen >= 0x10000) { ! fprintf(stderr, "Allocation too large: %lx\n", newlen); my_exit(1); } #endif /* MSDOS */ --- 971,977 ---- #ifdef MSDOS if (newlen >= 0x10000) { ! PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", newlen); my_exit(1); } #endif /* MSDOS */ *************** *** 1208,1214 **** return 0; } (void)SvIOK_on(sv); ! DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2iv(%ld)\n", (unsigned long)sv,(long)SvIVX(sv))); return SvIVX(sv); } --- 1208,1214 ---- return 0; } (void)SvIOK_on(sv); ! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", (unsigned long)sv,(long)SvIVX(sv))); return SvIVX(sv); } *************** *** 1261,1267 **** 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))); } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); --- 1261,1267 ---- sv_upgrade(sv, SVt_PVNV); else sv_upgrade(sv, SVt_NV); ! 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,1287 **** return 0.0; } SvNOK_on(sv); ! DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); return SvNVX(sv); } --- 1281,1287 ---- return 0.0; } SvNOK_on(sv); ! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv))); return SvNVX(sv); } *************** *** 1416,1422 **** *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))); return SvPVX(sv); tokensave: --- 1416,1422 ---- *lp = s - SvPVX(sv); SvCUR_set(sv, *lp); SvPOK_on(sv); ! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv))); return SvPVX(sv); tokensave: *************** *** 1713,1718 **** --- 1713,1719 ---- return; } if (SvPVX(dstr)) { + (void)SvOOK_off(dstr); /* backoff */ Safefree(SvPVX(dstr)); SvLEN(dstr)=SvCUR(dstr)=0; } *************** *** 2571,2577 **** char * sv_gets(sv,fp,append) register SV *sv; ! register FILE *fp; I32 append; { char *rsptr; --- 2572,2578 ---- char * sv_gets(sv,fp,append) register SV *sv; ! register PerlIO *fp; I32 append; { char *rsptr; *************** *** 2581,2596 **** 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); --- 2582,2587 ---- *************** *** 2614,2636 **** if (RsPARA(rs)) { /* have to do this both before and after */ do { /* to make sure file boundaries work right */ ! if (feof(fp)) return 0; ! i = getc(fp); if (i != '\n') { if (i == -1) return 0; ! ungetc(i,fp); break; } } while (i != EOF); } ! #ifdef FAST_SV_GETS /* Here is some breathtakingly efficient cheating */ ! cnt = FILE_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) { --- 2605,2644 ---- if (RsPARA(rs)) { /* have to do this both before and after */ do { /* to make sure file boundaries work right */ ! if (PerlIO_eof(fp)) return 0; ! i = PerlIO_getc(fp); if (i != '\n') { if (i == -1) return 0; ! PerlIO_ungetc(fp,i); break; } } while (i != EOF); } ! /* 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 = 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,2656 **** else shortbuffered = 0; bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ ! ptr = FILE_ptr(fp); for (;;) { screamer: if (cnt > 0) { if (rslen) { ! while (--cnt >= 0) { /* this | eat */ if ((*bp++ = *ptr++) == rslast) /* really | dust */ goto thats_all_folks; /* screams | sed :-) */ } --- 2653,2665 ---- else shortbuffered = 0; bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */ ! ptr = (STDCHAR*)PerlIO_get_ptr(fp); for (;;) { screamer: if (cnt > 0) { if (rslen) { ! while (cnt > 0) { /* this | eat */ ! cnt--; if ((*bp++ = *ptr++) == rslast) /* really | dust */ goto thats_all_folks; /* screams | sed :-) */ } *************** *** 2673,2683 **** 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 */ if (i == EOF) /* all done for ever? */ goto thats_really_all_folks; --- 2682,2695 ---- continue; } ! 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,2693 **** SvGROW(sv, bpx + cnt + 2); bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ ! *bp++ = i; /* store character from _filbuf */ if (rslen && (STDCHAR)i == rslast) /* all done for now? */ goto thats_all_folks; --- 2699,2705 ---- SvGROW(sv, bpx + cnt + 2); bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ ! *bp++ = i; /* store character from PerlIO_getc */ if (rslen && (STDCHAR)i == rslast) /* all done for now? */ goto thats_all_folks; *************** *** 2696,2740 **** thats_all_folks: if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || bcmp((char*)bp - rslen, rsptr, rslen)) ! 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; *bp = '\0'; ! SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */ ! ! #else /* SV_FAST_GETS */ ! ! /*The big, slow, and stupid way */ ! { STDCHAR buf[8192]; ! screamer: 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; ! } } else { ! cnt = fread((char*)buf, 1, sizeof(buf), fp); ! i = cnt ? !EOF : EOF; } if (append) ! sv_catpvn(sv, buf, cnt); else ! sv_setpvn(sv, buf, cnt); if (i != EOF && /* joy */ (!rslen || --- 2708,2743 ---- thats_all_folks: if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || bcmp((char*)bp - rslen, rsptr, rslen)) ! goto screamer; /* go back to the fray */ thats_really_all_folks: if (shortbuffered) cnt += shortbuffered; ! 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 { + /*The big, slow, and stupid way */ STDCHAR buf[8192]; ! screamer2: if (rslen) { ! 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 = PerlIO_read(fp,(char*)buf, sizeof(buf)); ! i = cnt ? (U8)buf[cnt - 1] : EOF; } if (append) ! sv_catpvn(sv, (char *) buf, cnt); else ! sv_setpvn(sv, (char *) buf, cnt); if (i != EOF && /* joy */ (!rslen || *************** *** 2742,2758 **** bcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) { append = -1; ! goto screamer; } } - #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); if (i != '\n') { ! ungetc(i,fp); break; } } --- 2745,2759 ---- bcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen))) { append = -1; ! goto screamer2; } } if (RsPARA(rs)) { /* have to do this both before and after */ while (i != EOF) { /* to make sure file boundaries work right */ ! i = PerlIO_getc(fp); if (i != '\n') { ! PerlIO_ungetc(fp,i); break; } } *************** *** 2761,2766 **** --- 2762,2768 ---- return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } + void sv_inc(sv) register SV *sv; *************** *** 3265,3271 **** if (!SvPOK(sv)) { SvPOK_on(sv); /* validate pointer */ SvTAINT(sv); ! DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2pv(%s)\n", (unsigned long)sv,SvPVX(sv))); } } --- 3267,3273 ---- if (!SvPOK(sv)) { SvPOK_on(sv); /* validate pointer */ SvTAINT(sv); ! DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n", (unsigned long)sv,SvPVX(sv))); } } *************** *** 3467,3473 **** U32 type; if (!sv) { ! fprintf(Perl_debug_log, "SV = 0\n"); return; } --- 3469,3475 ---- U32 type; if (!sv) { ! PerlIO_printf(Perl_debug_log, "SV = 0\n"); return; } *************** *** 3523,3588 **** *d++ = ')'; *d = '\0'; ! fprintf(Perl_debug_log, "SV = "); switch (type) { case SVt_NULL: ! fprintf(Perl_debug_log,"NULL%s\n", tmpbuf); return; case SVt_IV: ! fprintf(Perl_debug_log,"IV%s\n", tmpbuf); break; case SVt_NV: ! fprintf(Perl_debug_log,"NV%s\n", tmpbuf); break; case SVt_RV: ! fprintf(Perl_debug_log,"RV%s\n", tmpbuf); break; case SVt_PV: ! fprintf(Perl_debug_log,"PV%s\n", tmpbuf); break; case SVt_PVIV: ! fprintf(Perl_debug_log,"PVIV%s\n", tmpbuf); break; case SVt_PVNV: ! fprintf(Perl_debug_log,"PVNV%s\n", tmpbuf); break; case SVt_PVBM: ! fprintf(Perl_debug_log,"PVBM%s\n", tmpbuf); break; case SVt_PVMG: ! fprintf(Perl_debug_log,"PVMG%s\n", tmpbuf); break; case SVt_PVLV: ! fprintf(Perl_debug_log,"PVLV%s\n", tmpbuf); break; case SVt_PVAV: ! fprintf(Perl_debug_log,"PVAV%s\n", tmpbuf); break; case SVt_PVHV: ! fprintf(Perl_debug_log,"PVHV%s\n", tmpbuf); break; case SVt_PVCV: ! fprintf(Perl_debug_log,"PVCV%s\n", tmpbuf); break; case SVt_PVGV: ! fprintf(Perl_debug_log,"PVGV%s\n", tmpbuf); break; case SVt_PVFM: ! fprintf(Perl_debug_log,"PVFM%s\n", tmpbuf); break; case SVt_PVIO: ! fprintf(Perl_debug_log,"PVIO%s\n", tmpbuf); break; default: ! fprintf(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)); if (type >= SVt_PVNV || type == SVt_NV) ! fprintf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); if (SvROK(sv)) { ! fprintf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv)); sv_dump(SvRV(sv)); return; } --- 3525,3590 ---- *d++ = ')'; *d = '\0'; ! PerlIO_printf(Perl_debug_log, "SV = "); switch (type) { case SVt_NULL: ! PerlIO_printf(Perl_debug_log, "NULL%s\n", tmpbuf); return; case SVt_IV: ! PerlIO_printf(Perl_debug_log, "IV%s\n", tmpbuf); break; case SVt_NV: ! PerlIO_printf(Perl_debug_log, "NV%s\n", tmpbuf); break; case SVt_RV: ! PerlIO_printf(Perl_debug_log, "RV%s\n", tmpbuf); break; case SVt_PV: ! PerlIO_printf(Perl_debug_log, "PV%s\n", tmpbuf); break; case SVt_PVIV: ! PerlIO_printf(Perl_debug_log, "PVIV%s\n", tmpbuf); break; case SVt_PVNV: ! PerlIO_printf(Perl_debug_log, "PVNV%s\n", tmpbuf); break; case SVt_PVBM: ! PerlIO_printf(Perl_debug_log, "PVBM%s\n", tmpbuf); break; case SVt_PVMG: ! PerlIO_printf(Perl_debug_log, "PVMG%s\n", tmpbuf); break; case SVt_PVLV: ! PerlIO_printf(Perl_debug_log, "PVLV%s\n", tmpbuf); break; case SVt_PVAV: ! PerlIO_printf(Perl_debug_log, "PVAV%s\n", tmpbuf); break; case SVt_PVHV: ! PerlIO_printf(Perl_debug_log, "PVHV%s\n", tmpbuf); break; case SVt_PVCV: ! PerlIO_printf(Perl_debug_log, "PVCV%s\n", tmpbuf); break; case SVt_PVGV: ! PerlIO_printf(Perl_debug_log, "PVGV%s\n", tmpbuf); break; case SVt_PVFM: ! PerlIO_printf(Perl_debug_log, "PVFM%s\n", tmpbuf); break; case SVt_PVIO: ! PerlIO_printf(Perl_debug_log, "PVIO%s\n", tmpbuf); break; default: ! PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", tmpbuf); return; } if (type >= SVt_PVIV || type == SVt_IV) ! PerlIO_printf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv)); if (type >= SVt_PVNV || type == SVt_NV) ! PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); if (SvROK(sv)) { ! PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv)); sv_dump(SvRV(sv)); return; } *************** *** 3590,3621 **** return; if (type <= SVt_PVLV) { if (SvPVX(sv)) ! fprintf(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"); } if (type >= SVt_PVMG) { if (SvMAGIC(sv)) { ! fprintf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv)); } if (SvSTASH(sv)) ! fprintf(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)); 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)); flags = AvFLAGS(sv); d = tmpbuf; *d = '\0'; --- 3592,3623 ---- return; if (type <= SVt_PVLV) { if (SvPVX(sv)) ! 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 ! PerlIO_printf(Perl_debug_log, " PV = 0\n"); } if (type >= SVt_PVMG) { if (SvMAGIC(sv)) { ! PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv)); } if (SvSTASH(sv)) ! PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv))); } switch (type) { case SVt_PVLV: ! 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: ! 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,3701 **** if (flags & AVf_REUSED) strcat(d, "REUSED,"); if (*d) d[strlen(d)-1] = '\0'; ! fprintf(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)); if (HvPMROOT(sv)) ! fprintf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv)); if (HvNAME(sv)) ! fprintf(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)); if (CvGV(sv) && GvNAME(CvGV(sv))) { ! fprintf(stderr, " \"%s\"\n", GvNAME(CvGV(sv))); } else { ! fprintf(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)); if (type == SVt_PVFM) ! fprintf(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)); 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)); break; } } --- 3626,3703 ---- if (flags & AVf_REUSED) strcat(d, "REUSED,"); if (*d) d[strlen(d)-1] = '\0'; ! PerlIO_printf(Perl_debug_log, " FLAGS = (%s)\n", d); break; case SVt_PVHV: ! 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)) ! PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv)); if (HvNAME(sv)) ! PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv)); break; case SVt_PVFM: case SVt_PVCV: if (SvPOK(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))) { ! PerlIO_printf(PerlIO_stderr(), " \"%s\"\n", GvNAME(CvGV(sv))); } else { ! PerlIO_printf(PerlIO_stderr(), "\n"); } ! 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) ! PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv)); break; case SVt_PVGV: ! 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: ! 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; } } Index: sv.h *** perl5.003_01/sv.h Tue Jul 30 23:12:29 1996 --- perl5.003_02/sv.h Thu Aug 1 10:10:51 1996 *************** *** 247,254 **** 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 */ DIR * xio_dirp; /* for opendir, readdir, etc */ long xio_lines; /* $. */ long xio_page; /* $% */ --- 247,254 ---- MAGIC* xmg_magic; /* linked list of magicalness */ HV* xmg_stash; /* class package */ ! 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; /* $% */ Index: t/comp/redef.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/t/comp/redef.t Tue Aug 6 13:33:57 1996 *************** *** 0 **** --- 1,79 ---- + #!./perl + # + # Contributed by Graham Barr + + 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 $_; + + Index: t/lib/db-btree.t *** perl5.003_01/t/lib/db-btree.t Tue Jul 30 23:12:30 1996 --- perl5.003_02/t/lib/db-btree.t Fri Aug 2 17:49:58 1996 *************** *** 373,382 **** 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") ; # hash my %unknown = $YY->get_dup('Unknown', 1) ; --- 373,384 ---- 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") ; ! } # hash my %unknown = $YY->get_dup('Unknown', 1) ; *************** *** 385,391 **** 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) ; print( (keys %wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 83\n" : "not ok 83\n") ; undef $YY ; --- 387,393 ---- my %smith = $YY->get_dup('Smith', 1) ; print( (keys %smith == 1 && $smith{'John'}) ? "ok 82\n" : "not ok 82\n") ; ! %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 ; Index: t/lib/io_udp.t *** perl5.003_01/t/lib/io_udp.t Tue Jul 30 23:12:32 1996 --- perl5.003_02/t/lib/io_udp.t Mon Aug 5 09:20:59 1996 *************** *** 5,11 **** @INC = '../lib' if -d '../lib'; require Config; import Config; if ( ($Config{'extensions'} !~ /\bSocket\b/ || ! $Config{'extensions'} !~ /\bIO\b/) && !(($^O eq 'VMS') && $Config{d_socket})) { print "1..0\n"; exit 0; --- 5,12 ---- @INC = '../lib' if -d '../lib'; require Config; import Config; if ( ($Config{'extensions'} !~ /\bSocket\b/ || ! $Config{'extensions'} !~ /\bIO\b/ || ! $^O eq 'os2') && !(($^O eq 'VMS') && $Config{d_socket})) { print "1..0\n"; exit 0; *************** *** 18,25 **** 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'); print "ok 1\n"; --- 19,26 ---- use Socket; use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY); ! $udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); ! $udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost'); print "ok 1\n"; Index: t/op/inc.t *** /dev/null Sat Aug 10 16:48:02 1996 --- perl5.003_02/t/op/inc.t Thu Aug 8 12:33:39 1996 *************** *** 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";} Index: taint.c *** perl5.003_01/taint.c Tue Jan 17 20:50:13 1995 --- perl5.003_02/taint.c Thu Aug 8 13:34:52 1996 *************** *** 23,29 **** char *s; { if (tainting) { ! DEBUG_u(fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid)); if (tainted) { char *ug = 0; if (euid != uid) --- 23,29 ---- char *s; { if (tainting) { ! DEBUG_u(PerlIO_printf(PerlIO_stderr(), "%s %d %d %d\n",s,tainted,uid, euid)); if (tainted) { char *ug = 0; if (euid != uid) Index: toke.c *** perl5.003_01/toke.c Tue Jul 30 23:12:37 1996 --- perl5.003_02/toke.c Thu Aug 8 13:34:24 1996 *************** *** 44,52 **** #ifdef CRIPPLED_CC static int uni _((I32 f, char *s)); #endif ! static char * filter_gets _((SV *sv, FILE *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). --- 44,51 ---- #ifdef CRIPPLED_CC static int uni _((I32 f, char *s)); #endif ! static char * filter_gets _((SV *sv, PerlIO *fp)); static void restore_rsfp _((void *f)); /* 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,285 **** restore_rsfp(f) void *f; { ! FILE *fp = (FILE*)f; ! if (rsfp == stdin) ! clearerr(rsfp); else if (rsfp && (rsfp != fp)) ! fclose(rsfp); rsfp = fp; } --- 273,284 ---- restore_rsfp(f) void *f; { ! PerlIO *fp = (PerlIO*)f; ! if (rsfp == PerlIO_stdin()) ! PerlIO_clearerr(rsfp); else if (rsfp && (rsfp != fp)) ! PerlIO_close(rsfp); rsfp = fp; } *************** *** 356,365 **** bufend = SvPVX(linestr) + SvCUR(linestr); if (preprocess && !in_eval) (void)my_pclose(rsfp); ! else if ((FILE*)rsfp == stdin) ! clearerr(stdin); else ! (void)fclose(rsfp); rsfp = Nullfp; return s; } --- 355,364 ---- bufend = SvPVX(linestr) + SvCUR(linestr); if (preprocess && !in_eval) (void)my_pclose(rsfp); ! else if ((PerlIO*)rsfp == PerlIO_stdin()) ! PerlIO_clearerr(rsfp); else ! (void)PerlIO_close(rsfp); rsfp = Nullfp; return s; } *************** *** 1111,1118 **** /* 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)) return -1; /* error */ else return 0 ; /* end of file */ --- 1110,1117 ---- /* ensure buf_sv is large enough */ SvGROW(buf_sv, old_len + maxlen) ; ! 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,1127 **** } else { /* Want a line */ if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) { ! if (ferror(rsfp)) return -1; /* error */ else return 0 ; /* end of file */ --- 1120,1126 ---- } else { /* Want a line */ if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) { ! if (PerlIO_error(rsfp)) return -1; /* error */ else return 0 ; /* end of file */ *************** *** 1149,1155 **** static char * filter_gets(sv,fp) register SV *sv; ! register FILE *fp; { if (rsfp_filters) { --- 1148,1154 ---- static char * filter_gets(sv,fp) register SV *sv; ! register PerlIO *fp; { if (rsfp_filters) { *************** *** 1350,1356 **** oldoldbufptr = oldbufptr; oldbufptr = s; DEBUG_p( { ! fprintf(stderr,"### Tokener expecting %s at %s\n", exp_name[expect], s); } ) retry: --- 1349,1355 ---- oldoldbufptr = oldbufptr; oldbufptr = s; DEBUG_p( { ! PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s); } ) retry: *************** *** 1423,1432 **** if (rsfp) { if (preprocess && !in_eval) (void)my_pclose(rsfp); ! else if ((FILE*)rsfp == stdin) ! clearerr(stdin); else ! (void)fclose(rsfp); rsfp = Nullfp; } if (!in_eval && (minus_n || minus_p)) { --- 1422,1431 ---- if (rsfp) { if (preprocess && !in_eval) (void)my_pclose(rsfp); ! else if ((PerlIO *)rsfp == PerlIO_stdin()) ! PerlIO_clearerr(rsfp); else ! (void)PerlIO_close(rsfp); rsfp = Nullfp; } if (!in_eval && (minus_n || minus_p)) { *************** *** 2476,2483 **** last_lop = oldbufptr; last_lop_op = OP_ENTERSUB; /* Check for a constant sub */ ! if (SvPOK(cv) && !SvCUR(cv)) { ! SV *sv = sub_const(cv); if (sv) { SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); --- 2475,2482 ---- last_lop = oldbufptr; last_lop_op = OP_ENTERSUB; /* Check for a constant sub */ ! { ! SV *sv = cv_const_sv(cv); if (sv) { SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); *************** *** 2568,2580 **** IoIFP(GvIOp(gv)) = rsfp; #if defined(HAS_FCNTL) && defined(F_SETFD) { ! int fd = fileno(rsfp); fcntl(fd,F_SETFD,fd >= 3); } #endif if (preprocess) IoTYPE(GvIOp(gv)) = '|'; ! else if ((FILE*)rsfp == stdin) IoTYPE(GvIOp(gv)) = '-'; else IoTYPE(GvIOp(gv)) = '<'; --- 2567,2579 ---- IoIFP(GvIOp(gv)) = rsfp; #if defined(HAS_FCNTL) && defined(F_SETFD) { ! int fd = PerlIO_fileno(rsfp); fcntl(fd,F_SETFD,fd >= 3); } #endif if (preprocess) IoTYPE(GvIOp(gv)) = '|'; ! else if ((PerlIO*)rsfp == PerlIO_stdin()) IoTYPE(GvIOp(gv)) = '-'; else IoTYPE(GvIOp(gv)) = '<'; *************** *** 4987,5013 **** 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; --- 4986,4991 ---- *************** *** 5068,5074 **** else if (in_eval) sv_catpv(GvSV(errgv),buf); else ! fputs(buf,stderr); if (++error_count >= 10) croak("%s has too many errors.\n", SvPVX(GvSV(curcop->cop_filegv))); --- 5046,5052 ---- else if (in_eval) sv_catpv(GvSV(errgv),buf); else ! PerlIO_printf(PerlIO_stderr(), "%s",buf); if (++error_count >= 10) croak("%s has too many errors.\n", SvPVX(GvSV(curcop->cop_filegv))); Index: universal.c *** perl5.003_01/universal.c Tue Jul 30 23:12:38 1996 --- perl5.003_02/universal.c Fri Aug 2 17:48:45 1996 *************** *** 79,125 **** { dXSARGS; SV *sv, *rv; ! char *name; if (items != 2) croak("Usage: UNIVERSAL::isa(reference, kind)"); 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; - } 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; } ! ST(0) = rv; XSRETURN(1); } --- 79,110 ---- { dXSARGS; SV *sv, *rv; ! 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)) { ! sv = SvRV(sv); ! type = sv_reftype(sv,0); ! if(SvOBJECT(sv)) ! stash = SvSTASH(sv); } else { ! stash = gv_stashsv(sv, FALSE); } ! ST(0) = (type && strEQ(type,name)) || ! (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) ! ? &sv_yes ! : &sv_no; ! XSRETURN(1); } Index: util.c *** perl5.003_01/util.c Tue Jul 30 23:12:38 1996 --- perl5.003_02/util.c Fri Aug 9 11:02:05 1996 *************** *** 29,38 **** # include #endif - #ifdef I_LIMITS /* Needed for cast_xxx() functions below. */ - # include - #endif - /* Put this after #includes because fork and vfork prototypes may conflict. */ --- 29,34 ---- *************** *** 73,79 **** char *ptr; #ifdef MSDOS if (size > 0xffff) { ! fprintf(stderr, "Allocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* MSDOS */ --- 69,75 ---- char *ptr; #ifdef MSDOS if (size > 0xffff) { ! PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* MSDOS */ *************** *** 83,98 **** #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)); #else ! DEBUG_m(fprintf(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; my_exit(1); } /*NOTREACHED*/ --- 79,94 ---- #endif ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */ #if !(defined(I286) || defined(atarist)) ! DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size)); #else ! 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 { ! PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; my_exit(1); } /*NOTREACHED*/ *************** *** 116,122 **** #ifdef MSDOS if (size > 0xffff) { ! fprintf(stderr, "Reallocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* MSDOS */ --- 112,118 ---- #ifdef MSDOS if (size > 0xffff) { ! PerlIO_printf(PerlIO_stderr(), "Reallocation too large: %lx\n", size) FLUSH; my_exit(1); } #endif /* MSDOS */ *************** *** 130,142 **** #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); } ) #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); } ) #endif --- 126,138 ---- #if !(defined(I286) || defined(atarist)) DEBUG_m( { ! 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( { ! 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,151 **** else if (nomemok) return Nullch; else { ! fputs(no_mem,stderr) FLUSH; my_exit(1); } /*NOTREACHED*/ --- 141,147 ---- else if (nomemok) return Nullch; else { ! PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; my_exit(1); } /*NOTREACHED*/ *************** *** 158,166 **** char *where; { #if !(defined(I286) || defined(atarist)) ! DEBUG_m( fprintf(Perl_debug_log,"0x%x: (%05d) free\n",where,an++)); #else ! DEBUG_m( fprintf(Perl_debug_log,"0x%lx: (%05d) free\n",where,an++)); #endif if (where) { /*SUPPRESS 701*/ --- 154,162 ---- char *where; { #if !(defined(I286) || defined(atarist)) ! DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",where,an++)); #else ! DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",where,an++)); #endif if (where) { /*SUPPRESS 701*/ *************** *** 179,185 **** #ifdef MSDOS if (size * count > 0xffff) { ! fprintf(stderr, "Allocation too large: %lx\n", size * count) FLUSH; my_exit(1); } #endif /* MSDOS */ --- 175,181 ---- #ifdef MSDOS if (size * count > 0xffff) { ! PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size * count) FLUSH; my_exit(1); } #endif /* MSDOS */ *************** *** 188,196 **** 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)); #else ! DEBUG_m(fprintf(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 */ --- 184,192 ---- croak("panic: calloc"); #endif #if !(defined(I286) || defined(atarist)) ! DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size)); #else ! 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,207 **** else if (nomemok) return Nullch; else { ! fputs(no_mem,stderr) FLUSH; my_exit(1); } /*NOTREACHED*/ --- 197,203 ---- else if (nomemok) return Nullch; else { ! PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; my_exit(1); } /*NOTREACHED*/ *************** *** 273,279 **** for (i = 0; i < MAXXCOUNT; i++) { if (xcount[i] > lastxcount[i]) { ! fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); lastxcount[i] = xcount[i]; } } --- 269,275 ---- for (i = 0; i < MAXXCOUNT; i++) { if (xcount[i] > lastxcount[i]) { ! PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]); lastxcount[i] = xcount[i]; } } *************** *** 427,440 **** if (setlocale(LC_CTYPE, "") == NULL && (lc_all || lc_ctype || lang)) { if (printwarn) { ! fprintf(stderr, "warning: setlocale(LC_CTYPE, \"\") failed.\n"); ! fprintf(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"); } ok = 0; if (setlocale(LC_CTYPE, "C") == NULL) --- 423,436 ---- if (setlocale(LC_CTYPE, "") == NULL && (lc_all || lc_ctype || lang)) { if (printwarn) { ! 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)" ); ! PerlIO_printf(PerlIO_stderr(), "warning: falling back to the \"C\" locale.\n"); } ok = 0; if (setlocale(LC_CTYPE, "C") == NULL) *************** *** 518,524 **** } BmRARE(sv) = s[rarest]; BmPREVIOUS(sv) = rarest; ! DEBUG_r(fprintf(Perl_debug_log,"rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); } char * --- 514,520 ---- } BmRARE(sv) = s[rarest]; BmPREVIOUS(sv) = rarest; ! DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv))); } char * *************** *** 841,850 **** if (s - s_start >= sizeof(buf)) { /* Ooops! */ if (usermess) ! fputs(SvPVX(tmpstr), stderr); else ! fputs(buf, stderr); ! fputs("panic: message overflow - memory corrupted!\n",stderr); my_exit(1); } if (usermess) --- 837,846 ---- if (s - s_start >= sizeof(buf)) { /* Ooops! */ if (usermess) ! PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr)); else ! PerlIO_puts(PerlIO_stderr(), buf); ! PerlIO_puts(PerlIO_stderr(),"panic: message overflow - memory corrupted!\n"); my_exit(1); } if (usermess) *************** *** 878,888 **** restartop = die_where(message); Siglongjmp(top_env, 3); } ! fputs(message,stderr); ! (void)Fflush(stderr); if (e_tmpname) { if (e_fp) { ! fclose(e_fp); e_fp = Nullfp; } (void)UNLINK(e_tmpname); --- 874,884 ---- restartop = die_where(message); Siglongjmp(top_env, 3); } ! PerlIO_puts(PerlIO_stderr(),message); ! (void)PerlIO_flush(PerlIO_stderr()); if (e_tmpname) { if (e_fp) { ! PerlIO_close(e_fp); e_fp = Nullfp; } (void)UNLINK(e_tmpname); *************** *** 919,929 **** perl_call_sv((SV*)cv, G_DISCARD); } else { ! fputs(message,stderr); #ifdef LEAKTEST DEBUG_L(xstat()); #endif ! (void)Fflush(stderr); } } --- 915,925 ---- perl_call_sv((SV*)cv, G_DISCARD); } else { ! PerlIO_puts(PerlIO_stderr(),message); #ifdef LEAKTEST DEBUG_L(xstat()); #endif ! (void)Fflush(PerlIO_stderr()); } } *************** *** 992,1001 **** if (s - s_start >= sizeof(buf)) { /* Ooops! */ if (usermess) ! fputs(SvPVX(tmpstr), stderr); else ! fputs(buf, stderr); ! fputs("panic: message overflow - memory corrupted!\n",stderr); my_exit(1); } if (usermess) --- 988,997 ---- if (s - s_start >= sizeof(buf)) { /* Ooops! */ if (usermess) ! PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr)); else ! PerlIO_puts(PerlIO_stderr(), buf); ! PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n"); my_exit(1); } if (usermess) *************** *** 1041,1051 **** restartop = die_where(message); Siglongjmp(top_env, 3); } ! fputs(message,stderr); ! (void)Fflush(stderr); if (e_tmpname) { if (e_fp) { ! fclose(e_fp); e_fp = Nullfp; } (void)UNLINK(e_tmpname); --- 1037,1047 ---- restartop = die_where(message); Siglongjmp(top_env, 3); } ! PerlIO_puts(PerlIO_stderr(),message); ! (void)PerlIO_flush(PerlIO_stderr()); if (e_tmpname) { if (e_fp) { ! PerlIO_close(e_fp); e_fp = Nullfp; } (void)UNLINK(e_tmpname); *************** *** 1094,1104 **** perl_call_sv((SV*)cv, G_DISCARD); } else { ! fputs(message,stderr); #ifdef LEAKTEST DEBUG_L(xstat()); #endif ! (void)Fflush(stderr); } } #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ --- 1090,1100 ---- perl_call_sv((SV*)cv, G_DISCARD); } else { ! PerlIO_puts(PerlIO_stderr(),message); #ifdef LEAKTEST DEBUG_L(xstat()); #endif ! (void)PerlIO_flush(PerlIO_stderr()); } } #endif /* !defined(I_STDARG) && !defined(I_VARARGS) */ *************** *** 1258,1271 **** #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 */ --- 1254,1259 ---- *************** *** 1421,1427 **** #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c, same with OS/2. */ ! FILE * my_popen(cmd,mode) char *cmd; char *mode; --- 1409,1415 ---- #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c, same with OS/2. */ ! PerlIO * my_popen(cmd,mode) char *cmd; char *mode; *************** *** 1494,1510 **** (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; forkprocess = pid; ! return fdopen(p[this], mode); } #else #if defined(atarist) FILE *popen(); ! FILE * my_popen(cmd,mode) char *cmd; char *mode; { ! return popen(cmd, mode); } #endif --- 1482,1499 ---- (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; forkprocess = pid; ! return PerlIO_fdopen(p[this], mode); } #else #if defined(atarist) FILE *popen(); ! PerlIO * my_popen(cmd,mode) char *cmd; char *mode; { ! /* Needs work for PerlIO ! */ ! return popen(PerlIO_exportFILE(cmd), mode); } #endif *************** *** 1517,1528 **** int fd; struct stat tmpstatbuf; ! fprintf(stderr,"%s", s); for (fd = 0; fd < 32; fd++) { if (Fstat(fd,&tmpstatbuf) >= 0) ! fprintf(stderr," %d",fd); } ! fprintf(stderr,"\n"); } #endif --- 1506,1517 ---- int fd; struct stat tmpstatbuf; ! PerlIO_printf(PerlIO_stderr(),"%s", s); for (fd = 0; fd < 32; fd++) { if (Fstat(fd,&tmpstatbuf) >= 0) ! PerlIO_printf(PerlIO_stderr()," %d",fd); } ! PerlIO_printf(PerlIO_stderr(),"\n"); } #endif *************** *** 1557,1574 **** #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ I32 my_pclose(ptr) ! FILE *ptr; { Signal_t (*hstat)(), (*istat)(), (*qstat)(); int status; SV **svp; int pid; ! svp = av_fetch(fdpid,fileno(ptr),TRUE); pid = (int)SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &sv_undef; ! fclose(ptr); #ifdef UTS if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif --- 1546,1563 ---- #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */ I32 my_pclose(ptr) ! PerlIO *ptr; { Signal_t (*hstat)(), (*istat)(), (*qstat)(); int status; SV **svp; int pid; ! svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE); pid = (int)SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &sv_undef; ! PerlIO_close(ptr); #ifdef UTS if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif *************** *** 1663,1671 **** int pclose(); I32 my_pclose(ptr) ! FILE *ptr; { ! return pclose(ptr); } #endif --- 1652,1664 ---- int pclose(); I32 my_pclose(ptr) ! PerlIO *ptr; { ! /* Needs work for PerlIO ! */ ! FILE *f = PerlIO_findFILE(ptr); ! I32 result = pclose(f); ! PerlIO_releaseFILE(ptr,f); ! return result; } #endif *************** *** 1715,1743 **** #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 */ - # 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 --- 1708,1713 ---- *************** *** 1749,1765 **** --Andy Dougherty */ #ifndef MY_ULONG_MAX ! # define MY_ULONG_MAX ((UV)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; return (I32) f; } --- 1719,1735 ---- --Andy Dougherty */ #ifndef MY_ULONG_MAX ! # define MY_ULONG_MAX ((UV)PERL_LONG_MAX * (UV)2 + (UV)1) #endif I32 cast_i32(f) double f; { ! if (f >= PERL_LONG_MAX) ! return (I32) PERL_LONG_MAX; ! if (f <= PERL_LONG_MIN) ! return (I32) PERL_LONG_MIN; return (I32) f; } *************** *** 1767,1776 **** cast_iv(f) double f; { ! if (f >= LONG_MAX) ! return (IV) LONG_MAX; ! if (f <= LONG_MIN) ! return (IV) LONG_MIN; return (IV) f; } --- 1737,1746 ---- cast_iv(f) double f; { ! if (f >= PERL_LONG_MAX) ! return (IV) PERL_LONG_MAX; ! if (f <= PERL_LONG_MIN) ! return (IV) PERL_LONG_MIN; return (IV) f; } *************** *** 1865,1867 **** --- 1835,1851 ---- *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 Index: utils/h2ph.PL *** perl5.003_01/utils/h2ph.PL Tue Jul 30 23:12:39 1996 --- perl5.003_02/utils/h2ph.PL Sat Aug 3 09:59:32 1996 *************** *** 34,40 **** 'ds 00 \"'; 'ig 00 '; ! \$perlincl = "$Config{installsitearchlib}"; !GROK!THIS! --- 34,40 ---- 'ds 00 \"'; 'ig 00 '; ! \$perlincl = "$Config{archlibexp}"; # or {sitearchexp} !GROK!THIS! Index: utils/h2xs.PL *** perl5.003_01/utils/h2xs.PL Tue Jul 30 23:12:39 1996 --- perl5.003_02/utils/h2xs.PL Mon Aug 5 09:21:31 1996 *************** *** 118,123 **** --- 118,136 ---- 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 should be installed. If this + option is specified, the name of the header file may look like + C. 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,163 **** --- 171,187 ---- 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,182 **** =head1 DIAGNOSTICS ! The usual warnings if it can't read or write the files involved. =cut ! my( $H2XS_VERSION ) = '$Revision: 1.16 $' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; use Getopt::Std; --- 196,206 ---- =head1 DIAGNOSTICS ! The usual warnings if it cannot read or write the files involved. =cut ! my( $H2XS_VERSION ) = ' $Revision: 1.16 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; use Getopt::Std; *************** *** 195,200 **** --- 219,226 ---- -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,209 **** } ! getopts("AOPXcfhxv:n:p:s:") || usage; usage if $opt_h; --- 229,235 ---- } ! getopts("AOPXcfhxv:n:p:s:F:") || usage; usage if $opt_h; *************** *** 226,231 **** --- 252,259 ---- 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,258 **** print "Matched $_ ($1)\n"; $_ = $1; next if /^_.*_h_*$/i; # special case, but for what? ! if (defined $opt_p) if (!/^$opt_p(\d)/) { ++$prefix{$_} if s/^$opt_p//; } --- 280,286 ---- print "Matched $_ ($1)\n"; $_ = $1; next if /^_.*_h_*$/i; # special case, but for what? ! if (defined $opt_p) { if (!/^$opt_p(\d)/) { ++$prefix{$_} if s/^$opt_p//; } *************** *** 653,659 **** if ($opt_x) { require C::Scan; # Run-time directive require Config; # Run-time directive ! my $c = new C::Scan 'filename' => $path_h; $c->set('includeDirs' => [$Config::Config{shrpdir}]); my $fdec = $c->get('parsed_fdecls'); --- 681,696 ---- if ($opt_x) { require C::Scan; # Run-time directive require Config; # Run-time directive ! 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'); Index: vms/perly_c.vms Prereq: 1.8 *** perl5.003_01/vms/perly_c.vms Tue Jul 30 23:12:45 1996 --- perl5.003_02/vms/perly_c.vms Thu Aug 8 09:16:10 1996 *************** *** 1407,1413 **** 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, yychar, yys); } #endif --- 1407,1413 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate, yychar, yys); } #endif *************** *** 1417,1423 **** { #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif if (yyssp >= yyss + yystacksize - 1) --- 1417,1423 ---- { #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n", yystate, yytable[yyn]); #endif if (yyssp >= yyss + yystacksize - 1) *************** *** 1472,1478 **** { #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: state %d, error recovery shifting to state %d\n", *yyssp, yytable[yyn]); #endif --- 1472,1478 ---- { #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery shifting to state %d\n", *yyssp, yytable[yyn]); #endif *************** *** 1502,1508 **** { #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: error recovery discarding state %d\n", *yyssp); #endif --- 1502,1508 ---- { #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: error recovery discarding state %d\n", *yyssp); #endif *************** *** 1521,1527 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(Perl_debug_log, "yydebug: state %d, error recovery discards token %d (%s)\n", yystate, yychar, yys); } --- 1521,1527 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, error recovery discards token %d (%s)\n", yystate, yychar, yys); } *************** *** 1532,1538 **** yyreduce: #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; --- 1532,1538 ---- yyreduce: #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n", yystate, yyn, yyrule[yyn]); #endif yym = yylen[yyn]; *************** *** 2251,2257 **** { #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: after reduction, shifting from state 0 to state %d\n", YYFINAL); #endif --- 2251,2257 ---- { #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state 0 to state %d\n", YYFINAL); #endif *************** *** 2267,2273 **** yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } #endif --- 2267,2273 ---- yys = 0; if (yychar <= YYMAXTOKEN) yys = yyname[yychar]; if (!yys) yys = "illegal-symbol"; ! PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", YYFINAL, yychar, yys); } #endif *************** *** 2282,2288 **** yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) ! fprintf(Perl_debug_log, "yydebug: after reduction, shifting from state %d to state %d\n", *yyssp, yystate); #endif --- 2282,2288 ---- yystate = yydgoto[yym]; #if YYDEBUG if (yydebug) ! PerlIO_printf(Perl_debug_log, "yydebug: after reduction, shifting from state %d to state %d\n", *yyssp, yystate); #endif Index: vms/vms.c Prereq: 2.2 *** perl5.003_01/vms/vms.c Tue Jul 30 23:12:47 1996 --- perl5.003_02/vms/vms.c Mon Aug 5 08:32:44 1996 *************** *** 349,355 **** * 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 (aclsts & 1) aclsts = fndsts; if (!(aclsts & 1)) { set_errno(EVMSERR); --- 349,355 ---- * 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 (aclsts & 1) aclsts = fndsts; if (!(aclsts & 1)) { set_errno(EVMSERR); Index: x2p/Makefile.SH *** perl5.003_01/x2p/Makefile.SH Tue Jul 30 23:12:48 1996 --- perl5.003_02/x2p/Makefile.SH Tue Aug 6 13:17:52 1996 *************** *** 87,93 **** lintflags = -phbvxac .c$(OBJ_EXT): ! $(CCCMD) $(MAB) $*.c all: $(public) $(private) $(util) touch all --- 87,93 ---- lintflags = -phbvxac .c$(OBJ_EXT): ! $(CCCMD) $(MAB) -DPERL_FOR_X2P $*.c all: $(public) $(private) $(util) touch all *************** *** 110,116 **** -@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 clean: rm -f a2p *$(OBJ_EXT) --- 110,116 ---- -@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) -DPERL_FOR_X2P a2p.c clean: rm -f a2p *$(OBJ_EXT) Index: x2p/cflags.SH *** perl5.003_01/x2p/cflags.SH Tue Jul 30 23:12:49 1996 --- perl5.003_02/x2p/cflags.SH Tue Aug 6 13:18:16 1996 *************** *** 75,81 **** *) ;; esac ! ccflags="`echo $ccflags | sed -e 's/-DEMBED//'`" echo "$cc -c $ccflags $optimize $large $split" eval "$also "'"$cc -c $ccflags $optimize $large $split"' --- 75,81 ---- *) ;; esac ! ccflags="`echo $ccflags | sed -e 's/-DMULTIPLICITY//'`" echo "$cc -c $ccflags $optimize $large $split" eval "$also "'"$cc -c $ccflags $optimize $large $split"'