From: Charles Bailey Date: Fri, 4 Aug 2000 01:18:46 +0000 (+0000) Subject: YA resync with mainstem, including VMS patches from others X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4b19af017623bfa3bb72bb164598a517f586e0d3;p=p5sagit%2Fp5-mst-13.2.git YA resync with mainstem, including VMS patches from others p4raw-id: //depot/vmsperl@6514 --- diff --git a/AUTHORS b/AUTHORS index bf53871..3032d48 100644 --- a/AUTHORS +++ b/AUTHORS @@ -54,6 +54,7 @@ pueschel Norbert Pueschel pueschel@imsdd.meb.uni-bonn.de pvhp Peter Prymmer pvhp@forte.com raphael Raphael Manfredi Raphael_Manfredi@pobox.com rdieter Rex Dieter rdieter@math.unl.edu +rra Russ Allbery rra@stanford.edu rsanders Robert Sanders Robert.Sanders@linux.org roberto Ollivier Robert roberto@keltia.freenix.fr roderick Roderick Schertler roderick@argon.org @@ -62,6 +63,7 @@ tsanders Tony Sanders sanders@bsdi.com schinder Paul Schinder schinder@pobox.com scotth Scott Henry scotth@sgi.com seibert Greg Seibert seibert@Lynx.COM +simon Simon Cozens simon@brecon.co.uk spider Spider Boardman spider@Orb.Nashua.NH.US smccam Stephen McCamant smccam@uclink4.berkeley.edu sugalskd Dan Sugalski sugalskd@osshe.edu diff --git a/Configure b/Configure index 83a685d..54c85e2 100755 --- a/Configure +++ b/Configure @@ -20,7 +20,7 @@ # $Id: Head.U,v 3.0.1.9 1997/02/28 15:02:09 ram Exp $ # -# Generated on Fri Apr 28 23:33:15 EET DST 2000 [metaconfig 3.0 PL70] +# Generated on Wed Aug 2 03:07:08 EET DST 2000 [metaconfig 3.0 PL70] # (with additional metaconfig patches by perlbug@perl.com) cat >/tmp/c1$$ <checkcc +$startsh +EOS +cat <<'EOSC' >>checkcc +case "$cc" in +'') ;; +*) $rm -f try try.* + $cat >try.c <&4 + despair=yes + trygcc=yes + case "$cc" in + *gcc*) trygcc=no ;; + esac + case "`$cc -v -c try.c 2>&1`" in + *gcc*) trygcc=no ;; + esac + if $test X"$trygcc" = Xyes; then + if gcc -o try -c try.c; then + echo " " + echo "You seem to have a working gcc, though." >&4 + rp="Would you like to use it?" + dflt=y + if $test -f myread; then + . ./myread + else + if $test -f UU/myread; then + . ./UU/myread + else + echo "Cannot find myread, sorry. Aborting." >&2 + exit 1 + fi + fi + case "$ans" in + [yY]*) cc=gcc; ccflags=''; despair=no ;; + esac + fi + fi + if $test X"$despair" = Xyes; then + echo "You need to find a working C compiler." >&4 + echo "I cannot continue any further, aborting." >&4 + exit 1 + fi + fi + $rm -f try try.* + ;; +esac +EOSC + : determine whether symbolic links are supported echo " " $touch blurfl @@ -2163,6 +2223,7 @@ if test -f config.sh; then ;; esac fi +. ./UU/checkcc if test ! -f config.sh; then $cat </dev/null 2>&1 + case "$cc" in + '') modelcc="$cc" ;; + *) modelcc="cc" ;; + esac + ( $modelcc -o pdp11 pdp11.c ) >/dev/null 2>&1 if $test -f pdp11 && ./pdp11 2>/dev/null; then dflt='unsplit split' else @@ -3074,6 +3143,8 @@ fi if $test -f cc.cbu; then . ./cc.cbu fi +. ./checkcc + echo " " echo "Checking for GNU cc in disguise and/or its version number..." >&4 $cat >gccvers.c <&1|grep '/specs$'|sed 's!.*/[^-]*-[^-]*-\([^/]*\)/'$gccversion'/specs$!\1!'` + case "$gccosandvers" in + $osname) gccosandvers='' ;; # linux gccs seem to have no linux osvers, grr + $osname$osvers) ;; # looking good + $osname*) cat <&4 + +*** WHOA THERE!!! *** + + Your gcc has not been compiled for the exact release of + your operating system ($gccosandvers versus $osname$osvers). + + In general it is a good idea to keep gcc synchronized with + the operating system because otherwise serious problems + may ensue when trying to compile software, like Perl. + + I'm trying to be optimistic here, though, and will continue. + If later during the configuration and build icky compilation + problems appear (headerfile conflicts being the most common + manifestation), I suggest reinstalling the gcc to match + your operating system release. + +EOM + ;; + *) gccosandvers='' ;; # failed to parse, better be silent + esac + ;; +esac + + + + +: see how we invoke the C preprocessor +echo " " +echo "Now, how can we feed standard input to your C preprocessor..." >&4 +cat <<'EOT' >testcpp.c +#define ABC abc +#define XYZ xyz +ABC.XYZ +EOT +cd .. +if test ! -f cppstdin; then + if test "X$osname" = "Xaix" -a "X$gccversion" = X; then + # AIX cc -E doesn't show the absolute headerfile + # locations but we'll cheat by using the -M flag. + echo 'cat >.$$.c; rm -f .$$.u; '"$cc"' ${1+"$@"} -M -c .$$.c 2>/dev/null; test -s .$$.u && awk '"'"'$2 ~ /\.h$/ { print "# 0 \""$2"\"" }'"'"' .$$.u; rm -f .$$.o .$$.u; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' > cppstdin + else + echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin + fi +else + echo "Keeping your $hint cppstdin wrapper." +fi +chmod 755 cppstdin +wrapper=`pwd`/cppstdin +ok='false' +cd UU + +if $test "X$cppstdin" != "X" && \ + $cppstdin $cppminus testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 +then + echo "You used to use $cppstdin $cppminus so we'll use that again." + case "$cpprun" in + '') echo "But let's see if we can live without a wrapper..." ;; + *) + if $cpprun $cpplast testcpp.out 2>&1 && \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "(And we'll use $cpprun $cpplast to preprocess directly.)" + ok='true' + else + echo "(However, $cpprun $cpplast does not work, let's see...)" + fi + ;; + esac +else + case "$cppstdin" in + '') ;; + *) + echo "Good old $cppstdin $cppminus does not seem to be of any help..." + ;; + esac +fi + +if $ok; then + : nothing +elif echo 'Maybe "'"$cc"' -E" will work...'; \ + $cc -E testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ + $cc -E - testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yup, it does." + x_cpp="$cc -E" + x_minus='-'; +elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ + $cc -P testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Yipee, that works!" + x_cpp="$cc -P" + x_minus=''; +elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ + $cc -P - testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "At long last!" + x_cpp="$cc -P" + x_minus='-'; +elif echo 'No such luck, maybe "'$cpp'" will work...'; \ + $cpp testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "It works!" + x_cpp="$cpp" + x_minus=''; +elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ + $cpp - testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "Hooray, it works! I was beginning to wonder." + x_cpp="$cpp" + x_minus='-'; +elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ + $wrapper testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + x_cpp="$wrapper" + x_minus='' + echo "Eureka!" +else + dflt='' + rp="No dice. I can't find a C preprocessor. Name one:" + . ./myread + x_cpp="$ans" + x_minus='' + $x_cpp testcpp.out 2>&1 + if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then + echo "OK, that will do." >&4 + else +echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 + exit 1 + fi +fi + +case "$ok" in +false) + cppstdin="$x_cpp" + cppminus="$x_minus" + cpprun="$x_cpp" + cpplast="$x_minus" + set X $x_cpp + shift + case "$1" in + "$cpp") + echo "Perhaps can we force $cc -E using a wrapper..." + if $wrapper testcpp.out 2>&1; \ + $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 + then + echo "Yup, we can." + cppstdin="$wrapper" + cppminus=''; + else + echo "Nope, we'll have to live without it..." + fi + ;; + esac + case "$cpprun" in + "$wrapper") + cpprun='' + cpplast='' + ;; + esac + ;; +esac + +case "$cppstdin" in +"$wrapper"|'cppstdin') ;; +*) $rm -f $wrapper;; +esac +$rm -f testcpp.c testcpp.out : decide how portable to be. Allow command line overrides. case "$d_portable" in @@ -3277,6 +3528,7 @@ while test "$type"; do true) case "$ansexp" in /*) value="$ansexp" ;; + [a-zA-Z]:/*) value="$ansexp" ;; *) redo=true case "$already" in @@ -3404,7 +3656,7 @@ if $test -f /bin/mips && /bin/mips; then /bsd43 #endif EOCP - if $cc -E usr.c > usr.out && $contains / usr.out >/dev/null 2>&1; then + if cc -E usr.c > usr.out && $contains / usr.out >/dev/null 2>&1; then dflt='/bsd43/usr/include' incpath='/bsd43' mips_type='BSD 4.3' @@ -3437,154 +3689,6 @@ y) fn=d/ ;; esac -: see how we invoke the C preprocessor -echo " " -echo "Now, how can we feed standard input to your C preprocessor..." >&4 -cat <<'EOT' >testcpp.c -#define ABC abc -#define XYZ xyz -ABC.XYZ -EOT -cd .. -if test ! -f cppstdin; then - if test "X$osname" = "Xaix" -a "X$gccversion" = X; then - # AIX cc -E doesn't show the absolute headerfile - # locations but we'll cheat by using the -M flag. - echo 'cat >.$$.c; rm -f .$$.u; '"$cc"' ${1+"$@"} -M -c .$$.c 2>/dev/null; test -s .$$.u && awk '"'"'$2 ~ /\.h$/ { print "# 0 \""$2"\"" }'"'"' .$$.u; rm -f .$$.o .$$.u; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' > cppstdin - else - echo 'cat >.$$.c; '"$cc"' -E ${1+"$@"} .$$.c; rm .$$.c' >cppstdin - fi -else - echo "Keeping your $hint cppstdin wrapper." -fi -chmod 755 cppstdin -wrapper=`pwd`/cppstdin -ok='false' -cd UU - -if $test "X$cppstdin" != "X" && \ - $cppstdin $cppminus testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 -then - echo "You used to use $cppstdin $cppminus so we'll use that again." - case "$cpprun" in - '') echo "But let's see if we can live without a wrapper..." ;; - *) - if $cpprun $cpplast testcpp.out 2>&1 && \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "(And we'll use $cpprun $cpplast to preprocess directly.)" - ok='true' - else - echo "(However, $cpprun $cpplast does not work, let's see...)" - fi - ;; - esac -else - case "$cppstdin" in - '') ;; - *) - echo "Good old $cppstdin $cppminus does not seem to be of any help..." - ;; - esac -fi - -if $ok; then - : nothing -elif echo 'Maybe "'"$cc"' -E" will work...'; \ - $cc -E testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -E -" will work...'; \ - $cc -E - testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yup, it does." - x_cpp="$cc -E" - x_minus='-'; -elif echo 'Nope...maybe "'"$cc"' -P" will work...'; \ - $cc -P testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Yipee, that works!" - x_cpp="$cc -P" - x_minus=''; -elif echo 'Nope...maybe "'"$cc"' -P -" will work...'; \ - $cc -P - testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "At long last!" - x_cpp="$cc -P" - x_minus='-'; -elif echo 'No such luck, maybe "'$cpp'" will work...'; \ - $cpp testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "It works!" - x_cpp="$cpp" - x_minus=''; -elif echo 'Nixed again...maybe "'$cpp' -" will work...'; \ - $cpp - testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "Hooray, it works! I was beginning to wonder." - x_cpp="$cpp" - x_minus='-'; -elif echo 'Uh-uh. Time to get fancy. Trying a wrapper...'; \ - $wrapper testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - x_cpp="$wrapper" - x_minus='' - echo "Eureka!" -else - dflt='' - rp="No dice. I can't find a C preprocessor. Name one:" - . ./myread - x_cpp="$ans" - x_minus='' - $x_cpp testcpp.out 2>&1 - if $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 ; then - echo "OK, that will do." >&4 - else -echo "Sorry, I can't get that to work. Go find one and rerun Configure." >&4 - exit 1 - fi -fi - -case "$ok" in -false) - cppstdin="$x_cpp" - cppminus="$x_minus" - cpprun="$x_cpp" - cpplast="$x_minus" - set X $x_cpp - shift - case "$1" in - "$cpp") - echo "Perhaps can we force $cc -E using a wrapper..." - if $wrapper testcpp.out 2>&1; \ - $contains 'abc.*xyz' testcpp.out >/dev/null 2>&1 - then - echo "Yup, we can." - cppstdin="$wrapper" - cppminus=''; - else - echo "Nope, we'll have to live without it..." - fi - ;; - esac - case "$cpprun" in - "$wrapper") - cpprun='' - cpplast='' - ;; - esac - ;; -esac - -case "$cppstdin" in -"$wrapper"|'cppstdin') ;; -*) $rm -f $wrapper;; -esac -$rm -f testcpp.c testcpp.out - : Set private lib path case "$plibpth" in '') if ./mips; then @@ -8524,10 +8628,6 @@ eval $inlibc set endservent d_endsent eval $inlibc -: see if endspent exists -set endspent d_endspent -eval $inlibc - : Locate the flags for 'open()' echo " " $cat >open3.c <<'EOCP' @@ -9188,6 +9288,10 @@ esac set getcwd d_getcwd eval $inlibc +: see if getespwnam exists +set getespwnam d_getespwnam +eval $inlibc + : see if getfsstat exists set getfsstat d_getfsstat @@ -9366,6 +9470,10 @@ echo " " set d_getprotoprotos getprotoent $i_netdb netdb.h eval $hasproto +: see if getprpwnam exists +set getprpwnam d_getprpwnam +eval $inlibc + : see if getpwent exists set getpwent d_getpwent eval $inlibc @@ -9388,10 +9496,6 @@ echo " " set d_getservprotos getservent $i_netdb netdb.h eval $hasproto -: see if getspent exists -set getspent d_getspent -eval $inlibc - : see if getspnam exists set getspnam d_getspnam eval $inlibc @@ -9691,7 +9795,7 @@ echo 'int main() { long long x = 7; return 0; }' > try.c set try if eval $compile; then val="$define" - echo "You have have long long." + echo "You have long long." else val="$undef" echo "You do not have long long." @@ -10201,6 +10305,39 @@ esac $rm -f try.* try +case "$d_nv_preserves_uv" in +"$define") d_nv_preserves_uv_bits=`expr $uvsize \* 8` ;; +*) $echo "Checking how many bits of your UVs your NVs can preserve..." >&4 + $cat <try.c +#include +int main() { + $uvtype u = 0; + int n = 8 * $uvsize; + int i; + for (i = 0; i < n; i++) { + u = u << 1 | ($uvtype)1; + if (($uvtype)($nvtype)u != u) + break; + } + printf("%d\n", i); + exit(0); +} +EOP + set try + if eval $compile; then + d_nv_preserves_uv_bits="`./try$exe_ext`" + fi + case "$d_nv_preserves_uv_bits" in + [1-9]*) $echo "Your NVs can preserve $d_nv_preserves_uv_bits bits of your UVs." 2>&1 ;; + *) $echo "Can't figure out how many bits your NVs preserve." 2>&1 + d_nv_preserves_uv_bits="$undef" + ;; + esac + $rm -f try.* try + ;; +esac + + : check for off64_t echo " " @@ -10995,6 +11132,10 @@ eval $inlibc set setpriority d_setprior eval $inlibc +: see if setproctitle exists +set setproctitle d_setproctitle +eval $inlibc + : see if setpwent exists set setpwent d_setpwent eval $inlibc @@ -11027,10 +11168,6 @@ eval $inlibc set setsid d_setsid eval $inlibc -: see if setspent exists -set setspent d_setspent -eval $inlibc - : see if setvbuf exists set setvbuf d_setvbuf eval $inlibc @@ -14236,6 +14373,10 @@ eval $inhdr set ieeefp.h i_ieeefp eval $inhdr +: see if this is a libutil.h system +set libutil.h i_libutil +eval $inhdr + : see if locale.h is available set locale.h i_locale eval $inhdr @@ -14315,6 +14456,10 @@ eval $inhdr set poll.h i_poll eval $inhdr +: see if this is a prot.h system +set prot.h i_prot +eval $inhdr + echo " " $echo "Guessing which symbols your C compiler and preprocessor define..." >&4 $cat <<'EOSH' > Cppsym.know @@ -14886,6 +15031,12 @@ for xxx in $known_extensions ; do true|$define|y) avail_ext="$avail_ext $xxx" ;; esac ;; + Sys/Syslog|sys/syslog) + : XXX syslog requires socket + case "$d_socket" in + true|$define|y) avail_ext="$avail_ext $xxx" ;; + esac + ;; Thread|thread) case "$usethreads" in true|$define|y) avail_ext="$avail_ext $xxx" ;; @@ -15223,7 +15374,6 @@ d_endnent='$d_endnent' d_endpent='$d_endpent' d_endpwent='$d_endpwent' d_endsent='$d_endsent' -d_endspent='$d_endspent' d_eofnblk='$d_eofnblk' d_eunice='$d_eunice' d_fchmod='$d_fchmod' @@ -15247,6 +15397,7 @@ d_fstatvfs='$d_fstatvfs' d_ftello='$d_ftello' d_ftime='$d_ftime' d_getcwd='$d_getcwd' +d_getespwnam='$d_getespwnam' d_getfsstat='$d_getfsstat' d_getgrent='$d_getgrent' d_getgrps='$d_getgrps' @@ -15271,12 +15422,12 @@ d_getpgrp='$d_getpgrp' d_getppid='$d_getppid' d_getprior='$d_getprior' d_getprotoprotos='$d_getprotoprotos' +d_getprpwnam='$d_getprpwnam' d_getpwent='$d_getpwent' d_getsbyname='$d_getsbyname' d_getsbyport='$d_getsbyport' d_getsent='$d_getsent' d_getservprotos='$d_getservprotos' -d_getspent='$d_getspent' d_getspnam='$d_getspnam' d_gettimeod='$d_gettimeod' d_gnulibc='$d_gnulibc' @@ -15333,6 +15484,7 @@ d_munmap='$d_munmap' d_mymalloc='$d_mymalloc' d_nice='$d_nice' d_nv_preserves_uv='$d_nv_preserves_uv' +d_nv_preserves_uv_bits='$d_nv_preserves_uv_bits' d_off64_t='$d_off64_t' d_old_pthread_create_joinable='$d_old_pthread_create_joinable' d_oldpthreads='$d_oldpthreads' @@ -15387,6 +15539,7 @@ d_setpgid='$d_setpgid' d_setpgrp2='$d_setpgrp2' d_setpgrp='$d_setpgrp' d_setprior='$d_setprior' +d_setproctitle='$d_setproctitle' d_setpwent='$d_setpwent' d_setregid='$d_setregid' d_setresgid='$d_setresgid' @@ -15396,7 +15549,6 @@ d_setrgid='$d_setrgid' d_setruid='$d_setruid' d_setsent='$d_setsent' d_setsid='$d_setsid' -d_setspent='$d_setspent' d_setvbuf='$d_setvbuf' d_sfio='$d_sfio' d_shm='$d_shm' @@ -15496,6 +15648,7 @@ freetype='$freetype' full_ar='$full_ar' full_csh='$full_csh' full_sed='$full_sed' +gccosandvers='$gccosandvers' gccversion='$gccversion' gidformat='$gidformat' gidsign='$gidsign' @@ -15533,6 +15686,7 @@ i_grp='$i_grp' i_iconv='$i_iconv' i_ieeefp='$i_ieeefp' i_inttypes='$i_inttypes' +i_libutil='$i_libutil' i_limits='$i_limits' i_locale='$i_locale' i_machcthr='$i_machcthr' @@ -15546,6 +15700,7 @@ i_neterrno='$i_neterrno' i_netinettcp='$i_netinettcp' i_niin='$i_niin' i_poll='$i_poll' +i_prot='$i_prot' i_pthread='$i_pthread' i_pwd='$i_pwd' i_rpcsvcdbm='$i_rpcsvcdbm' diff --git a/MAINTAIN b/MAINTAIN index bc74f1e..b2e370d 100644 --- a/MAINTAIN +++ b/MAINTAIN @@ -31,6 +31,7 @@ INSTALL INTERN.h MANIFEST Makefile.SH +Makefile.micro simon objXSUB.h Policy_sh.SH Porting/* cfg @@ -56,6 +57,7 @@ README.dos dos README.hpux hpux README.lexwarn lexwarn README.machten machten +README.micro simon README.mpeix mpeix README.os2 os2 README.os390 mvs @@ -69,6 +71,7 @@ README.vos vos README.win32 win32 Todo Todo-5.005 +Todo.micro simon XSlock.h XSUB.h av.c @@ -434,10 +437,13 @@ lib/Pod/Checker.pm bradapp lib/Pod/Functions.pm lib/Pod/Html.pm tchrist lib/Pod/InputObjects.pm bradapp +lib/Pod/LaTeX.pm tjenness +lib/Pod/Man.pm rra lib/Pod/Parser.pm bradapp lib/Pod/PlainText.pm bradapp lib/Pod/Select.pm bradapp -lib/Pod/Text.pm tchrist +lib/Pod/Text.pm rra +lib/Pod/Text/* rra lib/Pod/Usage.pm bradapp lib/Search/Dict.pm lib/SelectSaver.pm @@ -588,7 +594,9 @@ pod/perllocale.pod locale pod/perllol.pod tchrist pod/perlmod.pod pod/perlmodinstall.pod jon -pod/perlmodlib.pod +pod/perlmodlib.pod simon +pod/perlmodlib.PL simon +pod/perlnewmod.pod simon pod/perlobj.pod pod/perlop.pod pod/perlpod.pod lwall @@ -843,6 +851,8 @@ taint.c thrdvar.h thread.h toke.c +uconfig.h simon +uconfig.sh simon universal.c unixish.h utf* lwall diff --git a/MANIFEST b/MANIFEST index 2500943..96eec9c 100644 --- a/MANIFEST +++ b/MANIFEST @@ -16,6 +16,7 @@ INTERN.h Included before domestic .h files MAINTAIN Who maintains which files MANIFEST This list of files Makefile.SH A script that generates Makefile +Makefile.micro microperl Makefile Policy_sh.SH Hold site-wide preferences between Configure runs. Porting/Contract Social contract for contributed modules in Perl core Porting/Glossary Glossary of config.sh variables @@ -42,6 +43,7 @@ README.epoc Notes about EPOC port README.hpux Notes about HP-UX port README.hurd Notes about GNU/Hurd port README.machten Notes about Power MachTen port +README.micro Notes about microperl README.mint Notes about Atari MiNT port README.mpeix Notes about MPE/iX port README.os2 Notes about OS/2 port @@ -56,6 +58,7 @@ README.vos Notes about Stratus VOS port README.win32 Notes about Win32 port Todo The Wishlist Todo-5.6 What needs doing before/during the 5.6.x release cycle +Todo.micro The Wishlist for microperl XSUB.h Include file for extension subroutines apollo/netinet/in.h Apollo DomainOS port: C header file frontend av.c Array value code @@ -239,6 +242,7 @@ ext/DynaLoader/dl_dld.xs GNU dld style implementation ext/DynaLoader/dl_dlopen.xs BSD/SunOS4&5 dlopen() style implementation ext/DynaLoader/dl_dyld.xs NeXT/Apple dyld implementation ext/DynaLoader/dl_hpux.xs HP-UX implementation +ext/DynaLoader/dl_mac.xs MacOS implementation ext/DynaLoader/dl_mpeix.xs MPE/iX implementation ext/DynaLoader/dl_next.xs NeXT implementation ext/DynaLoader/dl_none.xs Stub implementation @@ -247,6 +251,7 @@ ext/DynaLoader/dl_vms.xs VMS implementation ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files ext/DynaLoader/hints/aix.pl Hint for DynaLoader for named architecture ext/DynaLoader/hints/linux.pl Hint for DynaLoader for named architecture +ext/DynaLoader/hints/netbsd.pl Hint for DynaLoader for named architecture ext/DynaLoader/hints/openbsd.pl Hint for DynaLoader for named architecture ext/Errno/ChangeLog Errno perl module change log ext/Errno/Errno_pm.PL Errno perl module create script @@ -409,6 +414,7 @@ ext/re/re.xs re extension external subroutines ext/util/make_ext Used by Makefile to execute extension Makefiles ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info fakethr.h Fake threads header +fix_pl Fix up patchlevel.h for repository perls form.h Public declarations for the above global.sym Symbols that need hiding when embedded globals.c File to declare global symbols (for shared library) @@ -642,6 +648,7 @@ lib/Pod/Find.pm used by pod/splitpod lib/Pod/Functions.pm used by pod/splitpod lib/Pod/Html.pm Convert POD data to HTML lib/Pod/InputObjects.pm Pod-Parser - define objects for input streams +lib/Pod/LaTeX.pm Convert POD data to LaTeX lib/Pod/Man.pm Convert POD data to *roff lib/Pod/ParseUtils.pm Pod-Parser - pod utility functions lib/Pod/Parser.pm Pod-Parser - define base class for parsing POD @@ -715,7 +722,7 @@ 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/lib_pm.PL For "use lib", produces lib/lib.pm lib/locale.pm For "use locale" lib/look.pl A "look" equivalent lib/newgetopt.pl A perl library supporting long option parsing @@ -836,26 +843,37 @@ lib/unicode/Index.txt Unicode character database lib/unicode/Is/ASCII.pl Unicode character database lib/unicode/Is/Alnum.pl Unicode character database lib/unicode/Is/Alpha.pl Unicode character database +lib/unicode/Is/BidiAL.pl Unicode character database lib/unicode/Is/BidiAN.pl Unicode character database lib/unicode/Is/BidiB.pl Unicode character database +lib/unicode/Is/BidiBN.pl Unicode character database lib/unicode/Is/BidiCS.pl Unicode character database lib/unicode/Is/BidiEN.pl Unicode character database lib/unicode/Is/BidiES.pl Unicode character database lib/unicode/Is/BidiET.pl Unicode character database lib/unicode/Is/BidiL.pl Unicode character database +lib/unicode/Is/BidiLRE.pl Unicode character database +lib/unicode/Is/BidiLRO.pl Unicode character database +lib/unicode/Is/BidiNSM.pl Unicode character database lib/unicode/Is/BidiON.pl Unicode character database +lib/unicode/Is/BidiPDF.pl Unicode character database lib/unicode/Is/BidiR.pl Unicode character database +lib/unicode/Is/BidiRLE.pl Unicode character database +lib/unicode/Is/BidiRLO.pl Unicode character database lib/unicode/Is/BidiS.pl Unicode character database lib/unicode/Is/BidiWS.pl Unicode character database lib/unicode/Is/C.pl Unicode character database lib/unicode/Is/Cc.pl Unicode character database +lib/unicode/Is/Cf.pl Unicode character database lib/unicode/Is/Cn.pl Unicode character database lib/unicode/Is/Cntrl.pl Unicode character database lib/unicode/Is/Co.pl Unicode character database +lib/unicode/Is/Cs.pl Unicode character database lib/unicode/Is/DCcircle.pl Unicode character database lib/unicode/Is/DCcompat.pl Unicode character database lib/unicode/Is/DCfinal.pl Unicode character database lib/unicode/Is/DCfont.pl Unicode character database +lib/unicode/Is/DCfraction.pl Unicode character database lib/unicode/Is/DCinital.pl Unicode character database lib/unicode/Is/DCinitial.pl Unicode character database lib/unicode/Is/DCisolated.pl Unicode character database @@ -909,34 +927,53 @@ lib/unicode/Is/Lt.pl Unicode character database lib/unicode/Is/Lu.pl Unicode character database lib/unicode/Is/M.pl Unicode character database lib/unicode/Is/Mc.pl Unicode character database +lib/unicode/Is/Me.pl Unicode character database lib/unicode/Is/Mirrored.pl Unicode character database lib/unicode/Is/Mn.pl Unicode character database lib/unicode/Is/N.pl Unicode character database lib/unicode/Is/Nd.pl Unicode character database +lib/unicode/Is/Nl.pl Unicode character database lib/unicode/Is/No.pl Unicode character database lib/unicode/Is/P.pl Unicode character database +lib/unicode/Is/Pc.pl Unicode character database lib/unicode/Is/Pd.pl Unicode character database lib/unicode/Is/Pe.pl Unicode character database +lib/unicode/Is/Pf.pl Unicode character database +lib/unicode/Is/Pi.pl Unicode character database lib/unicode/Is/Po.pl Unicode character database lib/unicode/Is/Print.pl Unicode character database lib/unicode/Is/Ps.pl Unicode character database lib/unicode/Is/Punct.pl Unicode character database lib/unicode/Is/S.pl Unicode character database lib/unicode/Is/Sc.pl Unicode character database +lib/unicode/Is/Sk.pl Unicode character database lib/unicode/Is/Sm.pl Unicode character database lib/unicode/Is/So.pl Unicode character database lib/unicode/Is/Space.pl Unicode character database lib/unicode/Is/SylA.pl Unicode character database +lib/unicode/Is/SylAA.pl Unicode character database +lib/unicode/Is/SylAAI.pl Unicode character database +lib/unicode/Is/SylAI.pl Unicode character database lib/unicode/Is/SylC.pl Unicode character database lib/unicode/Is/SylE.pl Unicode character database +lib/unicode/Is/SylEE.pl Unicode character database lib/unicode/Is/SylI.pl Unicode character database +lib/unicode/Is/SylII.pl Unicode character database +lib/unicode/Is/SylN.pl Unicode character database lib/unicode/Is/SylO.pl Unicode character database +lib/unicode/Is/SylOO.pl Unicode character database lib/unicode/Is/SylU.pl Unicode character database lib/unicode/Is/SylV.pl Unicode character database lib/unicode/Is/SylWA.pl Unicode character database +lib/unicode/Is/SylWAA.pl Unicode character database lib/unicode/Is/SylWC.pl Unicode character database lib/unicode/Is/SylWE.pl Unicode character database +lib/unicode/Is/SylWEE.pl Unicode character database lib/unicode/Is/SylWI.pl Unicode character database +lib/unicode/Is/SylWII.pl Unicode character database +lib/unicode/Is/SylWO.pl Unicode character database +lib/unicode/Is/SylWOO.pl Unicode character database +lib/unicode/Is/SylWU.pl Unicode character database lib/unicode/Is/SylWV.pl Unicode character database lib/unicode/Is/Syllable.pl Unicode character database lib/unicode/Is/Upper.pl Unicode character database @@ -973,6 +1010,7 @@ lib/validate.pl Perl library supporting wholesale file mode validation lib/vars.pm Declare pseudo-imported global variables lib/warnings.pm For "use warnings" lib/warnings/register.pm For "use warnings::register" +lib/Win32.pod Documentation for Win32 extras makeaperl.SH perl script that produces a new perl binary makedef.pl Create symbol export lists for linking makedepend.SH Precursor to makedepend @@ -1082,17 +1120,16 @@ 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 Plan9 port: script to print version number -pod/Makefile Make pods into something else -pod/Win32.pod Documentation for Win32 extras -pod/buildtoc generate perltoc.pod +pod/Makefile.SH generate Makefile whichs makes pods into something else +pod/buildtoc.PL generate buildtoc which generates perltoc.pod pod/checkpods.PL Tool to check for common errors in pods -pod/perl.pod Top level perl man page +pod/perl.pod Top level perl documentation pod/perl5004delta.pod Changes from 5.003 to 5.004 pod/perl5005delta.pod Changes from 5.004 to 5.005 pod/perl56delta.pod Changes from 5.005 to 5.6 pod/perlapi.pod Perl API documentation (autogenerated) pod/perlapio.pod IO API info -pod/perlbook.pod Book info +pod/perlbook.pod Perl book information pod/perlboot.pod Beginner's Object-oriented Tutorial pod/perlbot.pod Object-oriented Bag o' Tricks pod/perlcall.pod Callback info @@ -1130,7 +1167,9 @@ pod/perllol.pod How to use lists of lists pod/perlmod.pod Module mechanism info pod/perlmodinstall.pod Installing CPAN Modules pod/perlmodlib.pod Module policy info +pod/perlmodlib.PL Generate pod/perlmodlib.pod pod/perlnumber.pod Semantics of numbers and numeric operations +pod/perlnewmod.pod Preparing a new module for distribution pod/perlobj.pod Object info pod/perlop.pod Operator info pod/perlopentut.pod open() tutorial @@ -1154,6 +1193,7 @@ pod/perltoot.pod Tom's object-oriented tutorial pod/perltootc.pod Tom's object-oriented tutorial (more on class data) pod/perltrap.pod Trap info pod/perlunicode.pod Unicode support info +pod/perlutil.pod Accompanying utilities explained pod/perlvar.pod Variable info pod/perlxs.pod XS api info pod/perlxstut.pod XS tutorial @@ -1333,6 +1373,7 @@ t/lib/safe2.t See if Safe works t/lib/sdbm.t See if SDBM_File works t/lib/searchdict.t See if Search::Dict works t/lib/selectsaver.t See if SelectSaver works +t/lib/selfloader.t See if SelfLoader works t/lib/socket.t See if Socket works t/lib/soundex.t See if Soundex works t/lib/symbol.t See if Symbol works @@ -1400,6 +1441,7 @@ t/op/method.t See if method calls 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/my_stash.t See if my Package works t/op/nothr5005.t local @_ test which does not work under use5005threads t/op/numconvert.t See if accessing fields does not change numeric values t/op/oct.t See if oct and hex work @@ -1528,6 +1570,8 @@ taint.c Tainting code thrdvar.h Per-thread variables thread.h Threading header toke.c The tokener +uconfig.h Configuration header for microperl +uconfig.sh Configuration script for microperl universal.c The default UNIVERSAL package methods unixish.h Defines that are assumed on Unix utf8.c Unicode routines diff --git a/Makefile.SH b/Makefile.SH index 285269d..caa647b 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -222,21 +222,24 @@ private = preplibrary lib/ExtUtils/Miniperl.pm lib/Config.pm # Files to be built with variable substitution before miniperl # is available. sh = Makefile.SH cflags.SH config_h.SH makeaperl.SH makedepend.SH \ - makedir.SH myconfig.SH writemain.SH + makedir.SH myconfig.SH writemain.SH pod/Makefile.SH shextract = Makefile cflags config.h makeaperl makedepend \ - makedir myconfig writemain + makedir myconfig writemain pod/Makefile # Files to be built with variable substitution after miniperl is # available. Dependencies handled manually below (for now). pl = pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL \ - pod/pod2usage.PL pod/podchecker.PL pod/podselect.PL + pod/pod2usage.PL pod/podchecker.PL pod/podselect.PL \ + pod/buildtoc.PL +# lib/lib.pm is not listed here because it has a rule of its own. plextract = pod/pod2html pod/pod2latex pod/pod2man pod/pod2text \ - pod/pod2usage pod/podchecker pod/podselect + pod/pod2usage pod/podchecker pod/podselect \ + pod/buildtoc -addedbyconf = UU $(shextract) $(plextract) pstruct +addedbyconf = UU $(shextract) $(plextract) lib/lib.pm pstruct h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h @@ -286,7 +289,7 @@ compile: all translators: miniperl lib/Config.pm FORCE @echo " "; echo " Making x2p stuff"; cd x2p; $(LDLIBPTH) $(MAKE) all -utilities: miniperl lib/Config.pm $(plextract) FORCE +utilities: miniperl lib/Config.pm $(plextract) lib/lib.pm FORCE @echo " "; echo " Making utilities"; cd utils; $(LDLIBPTH) $(MAKE) all @@ -304,7 +307,7 @@ opmini$(OBJ_EXT): op.c $(CCCMD) $(PLDLFLAGS) -DPERL_EXTERNAL_GLOB opmini.c $(RMS) opmini.c -miniperlmain$(OBJ_EXT): miniperlmain.c +miniperlmain$(OBJ_EXT): miniperlmain.c patchlevel.h $(CCCMD) $(PLDLFLAGS) $*.c perlmain.c: miniperlmain.c config.sh $(FIRSTMAKEFILE) @@ -322,6 +325,15 @@ ext.libs: $(static_ext) !NO!SUBS! +# if test -f .patch ; then $spitshell >>Makefile <<'!NO!SUBS!' +# patchlevel.h: .patch +# perl fix_pl || (make -f Makefile.micro && ./microperl fix_pl) +# $(SHELL) Makefile.SH + +!NO!SUBS! + +fi + # How to build libperl. This is still rather convoluted. # Load up custom Makefile.SH fragment for shared loading and executables: case "$osname" in @@ -526,6 +538,9 @@ lib/re.pm: ext/re/re.pm $(plextract): miniperl lib/Config.pm $(LDLIBPTH) ./miniperl -Ilib $@.PL +lib/lib.pm: miniperl lib/Config.pm + $(LDLIBPTH) ./miniperl -Ilib lib/lib_pm.PL + extra.pods: miniperl -@test -f extra.pods && rm -f `cat extra.pods` -@rm -f extra.pods @@ -635,6 +650,9 @@ regen_headers: FORCE -perl regcomp.pl -perl warnings.pl +regen_pods: FORCE + -cd pod; $(LDLIBPTH) make regen_pods + # Extensions: # Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will # automatically get built. There should ordinarily be no need to change @@ -675,7 +693,7 @@ _mopup: -rm -f perl.exp ext.libs extra.pods -rm -f perl.export perl.dll perl.libexp perl.map perl.def -rm -f perl.loadmap miniperl.loadmap perl.prelmap miniperl.prelmap - rm -f perl suidperl miniperl $(LIBPERL) + rm -f perl suidperl miniperl $(LIBPERL) libperl.* microperl # Do not 'make _tidy' directly. _tidy: @@ -696,7 +714,7 @@ _cleaner: -@for x in $(DYNALOADER) $(dynamic_ext) $(static_ext) $(nonxs_ext) ; do \ $(LDLIBPTH) sh ext/util/make_ext realclean $$x MAKE=$(MAKE) ; \ done - rm -f *.orig */*.orig *~ */*~ core core.*perl.*.? *perl.core t/core t/core.perl.*.? t/*perl.core t/misctmp* t/tmp* t/c t/perl .?*.c so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR) + rm -f core core.*perl.*.? *perl.core t/core t/core.perl.*.? t/*perl.core t/misctmp* t/forktmp* t/tmp* t/c t/perl .?*.c so_locations $(LIBPERL_NONSHR) $(MINIPERL_NONSHR) rm -rf $(addedbyconf) rm -f $(FIRSTMAKEFILE) $(FIRSTMAKEFILE).old rm -f $(private) diff --git a/Makefile.micro b/Makefile.micro new file mode 100644 index 0000000..1ac87b4 --- /dev/null +++ b/Makefile.micro @@ -0,0 +1,125 @@ +CC = cc +LD = $(CC) +DEFINES = -DPERL_CORE -DPERL_MICRO +CFLAGS = $(DEFINES) +LIBS = -lm +_O = .o + +all: microperl + +O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \ + uglobals$(_O) ugv$(_O) uhv$(_O) \ + umg$(_O) uperlmain$(_O) uop$(_O) \ + uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \ + upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) \ + uregcomp$(_O) uregexec$(_O) urun$(_O) \ + uscope$(_O) usv$(_O) utaint$(_O) utoke$(_O) \ + uuniversal$(_O) uutf8$(_O) uutil$(_O) uperlapi$(_O) + +microperl: $(O) + $(LD) -o $@ $(O) $(LIBS) + +H = av.h uconfig.h cop.h cv.h embed.h embedvar.h form.h gv.h handy.h \ + hv.h intrpvar.h iperlsys.h mg.h op.h opcode.h opnames.h patchlevel.h \ + perl.h perlsdio.h perlvars.h perly.h pp.h pp_proto.h proto.h \ + regexp.h scope.h sv.h thrdvar.h thread.h unixish.h utf8.h util.h \ + warnings.h + +HE = $(H) EXTERN.h + +clean: + -rm -f $(O) microperl + +distclean: clean + -rm -f uconfig.h + +uconfig.h: uconfig.sh config_h.SH + CONFIG_SH=uconfig.sh CONFIG_H=uconfig.h sh ./config_h.SH + +uav$(_O): $(HE) av.c + $(CC) -c -o $@ $(CFLAGS) av.c + +udeb$(_O): $(HE) deb.c + $(CC) -c -o $@ $(CFLAGS) deb.c + +udoio$(_O): $(HE) doio.c + $(CC) -c -o $@ $(CFLAGS) doio.c + +udoop$(_O): $(HE) doop.c + $(CC) -c -o $@ $(CFLAGS) doop.c + +udump$(_O): $(HE) dump.c regcomp.h regnodes.h + $(CC) -c -o $@ $(CFLAGS) dump.c + +uglobals$(_O): $(H) globals.c INTERN.h perlapi.h + $(CC) -c -o $@ $(CFLAGS) globals.c + +ugv$(_O): $(HE) gv.c + $(CC) -c -o $@ $(CFLAGS) gv.c + +uhv$(_O): $(HE) hv.c + $(CC) -c -o $@ $(CFLAGS) hv.c + +umg$(_O): $(HE) mg.c + $(CC) -c -o $@ $(CFLAGS) mg.c + +uperlmain$(_O): $(HE) miniperlmain.c + $(CC) -c -o $@ $(CFLAGS) miniperlmain.c + +uop$(_O): $(HE) op.c keywords.h + $(CC) -c -o $@ $(CFLAGS) op.c + +uperl$(_O): $(HE) perl.c + $(CC) -c -o $@ $(CFLAGS) perl.c + +uperlio$(_O): $(HE) perlio.c + $(CC) -c -o $@ $(CFLAGS) perlio.c + +uperly$(_O): $(HE) perly.c + $(CC) -c -o $@ $(CFLAGS) perly.c + +upp$(_O): $(HE) pp.c + $(CC) -c -o $@ $(CFLAGS) pp.c + +upp_ctl$(_O): $(HE) pp_ctl.c + $(CC) -c -o $@ $(CFLAGS) pp_ctl.c + +upp_hot$(_O): $(HE) pp_hot.c + $(CC) -c -o $@ $(CFLAGS) pp_hot.c + +upp_sys$(_O): $(HE) pp_sys.c + $(CC) -c -o $@ $(CFLAGS) pp_sys.c + +uregcomp$(_O): $(HE) regcomp.c regcomp.h regnodes.h INTERN.h + $(CC) -c -o $@ $(CFLAGS) regcomp.c + +uregexec$(_O): $(HE) regexec.c regcomp.h regnodes.h + $(CC) -c -o $@ $(CFLAGS) regexec.c + +urun$(_O): $(HE) run.c + $(CC) -c -o $@ $(CFLAGS) run.c + +uscope$(_O): $(HE) scope.c + $(CC) -c -o $@ $(CFLAGS) scope.c + +usv$(_O): $(HE) sv.c + $(CC) -c -o $@ $(CFLAGS) sv.c + +utaint$(_O): $(HE) taint.c + $(CC) -c -o $@ $(CFLAGS) taint.c + +utoke$(_O): $(HE) toke.c keywords.h + $(CC) -c -o $@ $(CFLAGS) toke.c + +uuniversal$(_O): $(HE) universal.c objXSUB.h XSUB.h + $(CC) -c -o $@ $(CFLAGS) universal.c + +uutf8$(_O): $(HE) utf8.c + $(CC) -c -o $@ $(CFLAGS) utf8.c + +uutil$(_O): $(HE) util.c + $(CC) -c -o $@ $(CFLAGS) util.c + +uperlapi$(_O): $(HE) perlapi.c perlapi.h + $(CC) -c -o $@ $(CFLAGS) perlapi.c + diff --git a/Porting/Glossary b/Porting/Glossary index f5ac6da..f1e7b8e 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -506,10 +506,6 @@ d_endsent (d_endsent.U): This variable conditionally defines HAS_ENDSERVENT if endservent() is available to close whatever was being used for service queries. -d_endspent (d_endspent.U): - This variable conditionally defines HAS_ENDSPENT if endspent() is - available to finalize the scan of SysV shadow password entries. - d_eofnblk (nblock_io.U): This variable conditionally defines EOF_NONBLOCK if EOF can be seen when reading from a non-blocking I/O source. @@ -620,6 +616,10 @@ d_getcwd (d_getcwd.U): indicates to the C program that the getcwd() routine is available to get the current working directory. +d_getespwnam (d_getespwnam.U): + This variable conditionally defines HAS_GETESPWNAM if getespwnam() is + available to retrieve enchanced (shadow) password entries by name. + d_getfsstat (d_getfsstat.U): This variable conditionally defines the HAS_GETFSSTAT symbol, which indicates to the C program that the getfsstat() routine is available. @@ -739,6 +739,10 @@ d_getprotoprotos (d_getprotoprotos.U): prototypes for the various getproto*() functions. See also netdbtype.U for probing for various netdb types. +d_getprpwnam (d_getprpwnam.U): + This variable conditionally defines HAS_GETPRPWNAM if getprpwnam() is + available to retrieve protected (shadow) password entries by name. + d_getpwent (d_getpwent.U): This variable conditionally defines the HAS_GETPWENT symbol, which indicates to the C program that the getpwent() routine is available @@ -766,10 +770,6 @@ d_getservprotos (d_getservprotos.U): prototypes for the various getserv*() functions. See also netdbtype.U for probing for various netdb types. -d_getspent (d_getspent.U): - This variable conditionally defines HAS_GETSPENT if getspent() is - available to retrieve SysV shadow password entries sequentially. - d_getspnam (d_getspnam.U): This variable conditionally defines HAS_GETSPNAM if getspnam() is available to retrieve SysV shadow password entries by name. @@ -1019,6 +1019,10 @@ d_nv_preserves_uv (perlxv.U): This variable indicates whether a variable of type nvtype can preserve all the bits a variable of type uvtype. +d_nv_preserves_uv_bits (perlxv.U): + This variable indicates how many of bits type uvtype + a variable nvtype can preserve. + d_off64_t (d_off64_t.U): This symbol will be defined if the C compiler supports off64_t. @@ -1351,10 +1355,6 @@ d_setsid (d_setsid.U): This variable conditionally defines HAS_SETSID if setsid() is available to set the process group ID. -d_setspent (d_setspent.U): - This variable conditionally defines HAS_SETSPENT if setspent() is - available to initialize the scan of SysV shadow password entries. - d_setvbuf (d_setvbuf.U): This variable conditionally defines the HAS_SETVBUF symbol, which indicates to the C program that the setvbuf() routine is available @@ -2018,6 +2018,10 @@ i_poll (i_poll.U): This variable conditionally defines the I_POLL symbol, and indicates whether a C program should include . +i_prot (i_prot.U): + This variable conditionally defines the I_PROT symbol, and indicates + whether a C program should include . + i_pthread (i_pthread.U): This variable conditionally defines the I_PTHREAD symbol, and indicates whether a C program should include . diff --git a/Porting/config.sh b/Porting/config.sh index ec7b131..c9e9f71 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -8,7 +8,7 @@ # Package name : perl5 # Source directory : . -# Configuration time: Fri Apr 28 23:34:47 EET DST 2000 +# Configuration time: Wed May 31 01:48:08 EET DST 2000 # Configured by : jhi # Target system : osf1 alpha.hut.fi v4.0 878 alpha @@ -59,7 +59,7 @@ ccflags='-pthread -std -DLANGUAGE_C' ccsymbols='__alpha=1 __LANGUAGE_C__=1 __osf__=1 __unix__=1 _LONGLONG=1 _SYSTYPE_BSD=1 SYSTYPE_BSD=1 unix=1' cf_by='jhi' cf_email='yourname@yourhost.yourplace.com' -cf_time='Fri Apr 28 23:34:47 EET DST 2000' +cf_time='Wed May 31 01:48:08 EET DST 2000' charsize='1' chgrp='' chmod='' @@ -136,7 +136,6 @@ d_endnent='define' d_endpent='define' d_endpwent='define' d_endsent='define' -d_endspent='undef' d_eofnblk='define' d_eunice='undef' d_fchmod='define' @@ -160,6 +159,7 @@ d_fstatvfs='define' d_ftello='undef' d_ftime='undef' d_getcwd='define' +d_getespwnam='undef' d_getfsstat='define' d_getgrent='define' d_getgrps='define' @@ -184,12 +184,12 @@ d_getpgrp='define' d_getppid='define' d_getprior='define' d_getprotoprotos='define' +d_getprpwnam='undef' d_getpwent='define' d_getsbyname='define' d_getsbyport='define' d_getsent='define' d_getservprotos='define' -d_getspent='undef' d_getspnam='undef' d_gettimeod='define' d_gnulibc='undef' @@ -246,6 +246,7 @@ d_munmap='define' d_mymalloc='undef' d_nice='define' d_nv_preserves_uv='undef' +d_nv_preserves_uv_bits='53' d_off64_t='undef' d_old_pthread_create_joinable='undef' d_oldpthreads='undef' @@ -309,7 +310,6 @@ d_setrgid='define' d_setruid='define' d_setsent='define' d_setsid='define' -d_setspent='undef' d_setvbuf='define' d_sfio='undef' d_shm='define' @@ -459,6 +459,7 @@ i_neterrno='undef' i_netinettcp='define' i_niin='define' i_poll='define' +i_prot='define' i_pthread='define' i_pwd='define' i_rpcsvcdbm='undef' diff --git a/Porting/config_H b/Porting/config_H index 46184ef..a2c196d 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -17,7 +17,7 @@ /* * Package name : perl5 * Source directory : . - * Configuration time: Fri Apr 28 23:34:47 EET DST 2000 + * Configuration time: Wed May 31 01:48:08 EET DST 2000 * Configured by : jhi * Target system : osf1 alpha.hut.fi v4.0 878 alpha */ @@ -1328,12 +1328,6 @@ */ #define HAS_ENDSERVENT /**/ -/* HAS_ENDSPENT: - * This symbol, if defined, indicates that the endspent system call is - * available to finalize the scan of SysV shadow password entries. - */ -/*#define HAS_ENDSPENT / **/ - /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in @@ -1405,6 +1399,12 @@ */ #define HAS_GETCWD /**/ +/* HAS_GETESPWNAM: + * This symbol, if defined, indicates that the getespwnam system call is + * available to retrieve enchanced (shadow) password entries by name. + */ +/*#define HAS_GETESPWNAM / **/ + /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. @@ -1535,6 +1535,12 @@ */ #define HAS_GETPROTO_PROTOS /**/ +/* HAS_GETPRPWNAM: + * This symbol, if defined, indicates that the getprpwnam system call is + * available to retrieve protected (shadow) password entries by name. + */ +/*#define HAS_GETPRPWNAM / **/ + /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. @@ -1556,12 +1562,6 @@ */ #define HAS_GETSERV_PROTOS /**/ -/* HAS_GETSPENT: - * This symbol, if defined, indicates that the getspent system call is - * available to retrieve SysV shadow password entries sequentially. - */ -/*#define HAS_GETSPENT / **/ - /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. @@ -1743,6 +1743,13 @@ #define HAS_MMAP /**/ #define Mmap_t void * /**/ +/* HAS_MODFL: + * This symbol, if defined, indicates that the modfl routine is + * available to split a long double x into a fractional part f and + * an integer part i such that |f| < 1.0 and (f + i) = x. + */ +#define HAS_MODFL /**/ + /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. @@ -1867,12 +1874,6 @@ */ #define HAS_SETSERVENT /**/ -/* HAS_SETSPENT: - * This symbol, if defined, indicates that the setspent system call is - * available to initialize the scan of SysV shadow password entries. - */ -/*#define HAS_SETSPENT / **/ - /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. @@ -2341,6 +2342,12 @@ */ #define I_POLL /**/ +/* I_PROT: + * This symbol, if defined, indicates that exists and + * should be included. + */ +#define I_PROT /**/ + /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . @@ -2670,7 +2677,11 @@ */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE - * can preserve all the bit of a variable of type UVSIZE. + * can preserve all the bits of a variable of type UVTYPE. + */ +/* NV_PRESERVES_UV_BITS: + * This symbol contains the number of bits a variable of type NVTYPE + * can preserve of a variable of type UVTYPE. */ #define IVTYPE long /**/ #define UVTYPE unsigned long /**/ @@ -2699,6 +2710,7 @@ #endif #define NVSIZE 8 /**/ #undef NV_PRESERVES_UV +#define NV_PRESERVES_UV_BITS 53 /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -3118,11 +3130,4 @@ #define PERL_XS_APIVERSION "5.6.0" #define PERL_PM_APIVERSION "5.005" -/* HAS_MODFL: - * This symbol, if defined, indicates that the modfl routine is - * available to split a long double x into a fractional part f and - * an integer part i such that |f| < 1.0 and (f + i) = x. - */ -#define HAS_MODFL /**/ - #endif diff --git a/Porting/p4desc b/Porting/p4desc index 0bf79da..2d1c9d8 100755 --- a/Porting/p4desc +++ b/Porting/p4desc @@ -6,7 +6,8 @@ # Gurusamy Sarathy # -use vars qw($thisfile $change $file $fnum $h $v $p4port @addfiles); +use vars qw($thisfile $change $file $fnum $h $v $p4port @addfiles + $branches $skip); BEGIN { $0 =~ s|^.*/||; @@ -18,6 +19,9 @@ BEGIN { elsif (/^-p(.*)$/) { $p4port = $1 || ' '; } + elsif (/^-b(.*)$/) { + $branches = $1; + } elsif (/^-v$/) { $v++; } @@ -30,20 +34,28 @@ BEGIN { } unless (@files) { @files = '-'; undef $^I; } @ARGV = @files; + $branches = '//depot/perl/' unless defined $branches; if ($h) { print STDERR < change-123.desc @@ -65,14 +77,28 @@ my $cur = m|^Affected files| ... m|^Differences|; # while we are within range if ($cur) { - if (m{^\.\.\. (//depot/.+?#\d+) (add|branch)$}) { - my $newfile = $1; - push @addfiles, $newfile; - warn "$newfile add, revision != 1!\n" unless $newfile =~ /#1$/; + if (m|^\.\.\. |) { + if (m|$branches|) { + if (m{^\.\.\. (//depot/.+?\#\d+) (add|branch)$}) { + my $newfile = $1; + push @addfiles, $newfile; + warn "$newfile add, revision != 1!\n" unless $newfile =~ /#1$/; + } + } else { + push @skipped, "# $_"; + $_ = ''; + } } warn "file [$file] line [$cur] file# [$fnum]\n" if $v; } +if (m|^==== //depot/|) { + $skip = !m|$branches|; + print "# Skipped because not under branches: $branches\n" if $skip; +} + +$_ = "# $_" if $skip; + if (/^Change (\d+) by/) { $_ = "\n\n" . $_ if $change; # start of a new change list $change = $1; @@ -84,6 +110,9 @@ if (/^Change (\d+) by/) { if (eof) { $_ .= newfiles(); + $_ .= join('', "\n", + "# Skipped because not under branches: $branches\n", + @skipped, "\n") if @skipped; } sub newfiles { diff --git a/README b/README index 0925b98..e846c30 100644 --- a/README +++ b/README @@ -22,8 +22,10 @@ Kit, in the file named "Artistic". If not, I'll be glad to provide one. You should also have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software Foundation, - Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. + along with this program in the file named "Copying". If not, write to the + Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307, USA or visit their web page on the internet at + http://www.gnu.org/copyleft/gpl.html. For those of you that choose to use the GNU General Public License, my interpretation of the GNU General Public License is that no Perl diff --git a/README.cygwin b/README.cygwin index eb6c289..2a95ab9 100644 --- a/README.cygwin +++ b/README.cygwin @@ -31,7 +31,7 @@ about this project can be found at: A recent net or commercial release of Cygwin is required. -At the time this document was written, Cygwin 1.1.1 was current. +At the time this document was last updated, Cygwin 1.1.2 was current. B At this point, minimal effort has been made to provide compatibility with old (beta) Cygwin releases. The focus has been to @@ -138,6 +138,11 @@ The MD5 port was done by Andy Piper: ftp://ftp.franken.de/pub/win32/develop/gnuwin32/cygwin/porters/Okhapkin_Sergey/libcrypt.tgz +There is also a Linux compatible 56 bit DES crypt port by Corinna +Vinschen: + + ftp://ftp.franken.de/pub/win32/develop/gnuwin32/cygwin/porters/Vinschen_Corinna/V1.1.1/crypt-1.0.tar.gz + =item * C<-lgdbm> (C) GDBM is available for Cygwin. GDBM's ndbm/dbm compatibility feature @@ -353,7 +358,10 @@ these options, these tests will fail: =head2 Hard Links FAT partitions do not support hard links (whereas NTFS does), in which -case Cygwin implements link() by copying the file. These tests will fail: +case Cygwin implements link() by copying the file. On remote (network) +drives Cygwin's stat() always sets C to 1, so the link count +for remote directories and files is not available. In both cases, +these tests will fail: Failed Test List of failed ------------------------------------ @@ -431,7 +439,9 @@ printable characters except these: : * ? " < > | -File names are case insensitive, but case preserving. +File names are case insensitive, but case preserving. A pathname +that contains a backslash is a Win32 pathname (and not subject to the +translations applied to POSIX style pathnames). =item * Text/Binary @@ -450,13 +460,13 @@ The text/binary issue is covered at length in the Cygwin documentation. =item * F<.exe> -The Cygwin stat() makes the F<.exe> extension transparent by looking for -F when you ask for F (unless a F also exists). Cygwin -does not require a F<.exe> extension, but I adds it automatically -when building a program. However, when accessing an executable as a -normal file (e.g., I in a makefile) the F<.exe> is not transparent. -The I included with Cygwin automatically appends a F<.exe> -when necessary. +The Cygwin stat(), lstat() and readlink() functions make the F<.exe> +extension transparent by looking for F when you ask for F +(unless a F also exists). Cygwin does not require a F<.exe> +extension, but I adds it automatically when building a program. +However, when accessing an executable as a normal file (e.g., I +in a makefile) the F<.exe> is not transparent. The I included +with Cygwin automatically appends a F<.exe> when necessary. =item * chown() @@ -558,6 +568,7 @@ be kept as clean as possible. - require MM_Cygwin.pm lib/ExtUtils/MM_Cygwin.pm - canonpath, cflags, manifypods, perl_archive + lib/File/Find.pm - on remote drives stat() always sets st_nlink to 1 lib/File/Spec/Unix.pm - preserve //unc lib/perl5db.pl - use stdin not /dev/tty utils/perlcc.PL - DynaLoader.a in compile, -DUSEIMPORTLIB @@ -586,4 +597,4 @@ Teun Burgers . =head1 HISTORY -Last updated: 5 May 2000 +Last updated: 20 June 2000 diff --git a/README.epoc b/README.epoc index b4bcca6..2163c46 100644 --- a/README.epoc +++ b/README.epoc @@ -4,7 +4,7 @@ Perl 5 README file for the EPOC operating system. Olaf Flebbe http://www.linuxstart.com/~oflebbe/perl/perl5.html -2000-02-20 +2000-05-15 ===================================================================== Introduction @@ -13,9 +13,8 @@ Introduction EPOC is a OS for palmtops and mobile phones. For more informations look at: http://www.symbian.com/ -This is a port of Perl version 5.5.650 to EPOC. It runs on the Perl -Series 5, Series 5mx and the Psion Revo. I have no reports for other -EPOC devices. +This is a port of Perl version 5.6.0 to EPOC. It runs on the Perl +Series 5, Series 5mx and the Psion Revo and on the Ericson M128. Features are left out, because of restrictions of the POSIX support. @@ -157,4 +156,4 @@ Support Status I'm offering this port "as is". You can ask me questions, but I can't guarantee I'll be able to answer them; I don't know much about Perl -internals myself; +internals myself. diff --git a/README.hpux b/README.hpux index 06b39b9..47d1afc 100644 --- a/README.hpux +++ b/README.hpux @@ -1,6 +1,6 @@ -If you read this file _as_is_, just ignore the funny characters you -see. It is written in the POD format (see pod/perlpod.pod) which is -specially designed to be readable as is. +If you read this file _as_is_, just ignore the funny characters you see. +It is written in the POD format (see pod/perlpod.pod) which is specially +designed to be readable as is. =head1 NAME @@ -8,33 +8,35 @@ README.hpux - Perl version 5 on Hewlett-Packard Unix (HP-UX) systems =head1 DESCRIPTION -This document describes various features of HP's Unix operating system (HP-UX) -that will affect how Perl version 5 (hereafter just Perl) is compiled and/or -runs. +This document describes various features of HP's Unix operating system +(HP-UX) that will affect how Perl version 5 (hereafter just Perl) is +compiled and/or runs. =head2 Compiling Perl 5 on HP-UX -An ANSI C compiler is required to build Perl. The C compiler that ships -with all HP-UX systems is a K&R compiler that can only be used to build -new kernels. +When compiling Perl, you must use an ANSI C compiler. The C compiler +that ships with all HP-UX systems is a K&R compiler that should only be +used to build new kernels. Perl can be compiled with either HP's ANSI C compiler or with gcc. The -former is recommended, as not only can it compile Perl with no difficulty, -but also can take advantage of features listed later that require the use -of HP compiler-specific command-line flags. +former is recommended, as not only can it compile Perl with no +difficulty, but also can take advantage of features listed later that +require the use of HP compiler-specific command-line flags. -If you decide to use gcc, make sure your installation is recent and complete, -and be sure to read the Perl README file for more gcc-specific details. +If you decide to use gcc, make sure your installation is recent and +complete, and be sure to read the Perl README file for more gcc-specific +details. =head2 PA-RISC -HP's current Unix systems run on its own Precision Architecture (PA-RISC) chip. -HP-UX used to run on the Motorola MC68000 family of chips, but any machine with -this chip in it is quite obsolete and this document will not attempt to address -issues for compiling Perl on the Motorola chipset. +HP's current Unix systems run on its own Precision Architecture +(PA-RISC) chip. HP-UX used to run on the Motorola MC68000 family of +chips, but any machine with this chip in it is quite obsolete and this +document will not attempt to address issues for compiling Perl on the +Motorola chipset. -The most recent version of PA-RISC at the time of this document's last update -is 2.0. +The most recent version of PA-RISC at the time of this document's last +update is 2.0. =head2 PA-RISC 1.0 @@ -42,8 +44,8 @@ The original version of PA-RISC, HP no longer sells any system with this chip. The following systems contain PA-RISC 1.0 chips: - 600, 635, 645, 800, 808, 815, 822, 825, 832, 834, 835, 840, - 842, 845, 850, 852, 855, 860, 865, 870, 890 + 600, 635, 645, 808, 815, 822, 825, 832, 834, 835, 840, 842, 845, 850, 852, + 855, 860, 865, 870, 890 =head2 PA-RISC 1.1 @@ -52,52 +54,58 @@ system. The following systems contain with PA-RISC 1.1 chips: - 705, 710, 712, 715, 720, 722, 725, 728, 730, 735, 743, 745, 747, 750, - 755, 770, 807S, 817S, 827S, 837S, 847S, 857S, 867S, 877S, 887S, 897S, - D200, D210, D220, D230, D250, D260, D310, D320, D330, D350, D360, D400, - E25, E35, E45, E55, F10, F20, F30, G30, G40, G50, G60, G70, H30, H40, - H50, H60, H70, I30, I40, I50, I60, I70, K100, K200, K210, K220, K400, - K410, K420, T500, T520 - + 705, 710, 712, 715, 720, 722, 725, 728, 730, 735, 742, 743, 745, 747, 750, + 755, 770, 777, 778, 779, 800, 801, 803, 806, 807, 809, 811, 813, 816, 817, + 819, 821, 826, 827, 829, 831, 837, 839, 841, 847, 849, 851, 856, 857, 859, + 867, 869, 877, 887, 891, 892, 897, A180, A180C, B115, B120, B132L, B132L+, + B160L, B180L, C100, C110, C115, C120, C160L, D200, D210, D220, D230, D250, + D260, D310, D320, D330, D350, D360, D410, DX0, DX5, DZO, E25, E35, E45, + E55, F10, F20, F30, G30, G40, G50, G60, G70, H20, H30, H40, H50, H60, H70, + I30, I40, I50, I60, I70, J200, J210, J210XC, K100, K200, K210, K220, K230, + K400, K410, K420, S700i, S715, S724, S760, T500, T520 =head2 PA-RISC 2.0 -The most recent upgrade to the PA-RISC design, it added support for 64-bit -integer data. +The most recent upgrade to the PA-RISC design, it added support for +64-bit integer data. -The following systems contain PA-RISC 2.0 chips (this is very likely to be -out of date): +As of the date of this document's last update, the following systems +contain PA-RISC 2.0 chips (this is very likely to be out of date): - D270, D280, D370, D380, K250, K260, K370, K380, K450, K460, K570, K580, - T600, V2200, N-class + 700, 780, 781, 782, 783, 785, 802, 804, 810, 820, 861, 871, 879, 889, 893, + 895, 896, 898, 899, B1000, C130, C140, C160, C180, C180+, C180-XP, C200+, + C400+, C3000, C360, CB260, D270, D280, D370, D380, D390, D650, J220, J2240, + J280, J282, J400, J410, J5000, J7000, K250, K260, K260-EG, K270, K360, + K370, K380, K450, K460, K460-EG, K460-XP, K470, K570, K580, L1000, L2000, + N4000, R380, R390, T540, T600, V2000, V2200, V2250, V2500 A complete list of models at the time the OS was built is in the file -/opt/langtools/lib/sched.models. -The first column corresponds to the output of the "uname -m" command -(without the leading "9000/"). -The second column is the PA-RISC version -and the third column is the exact chip type used. +/opt/langtools/lib/sched.models. The first column corresponds to the +output of the "uname -m" command (without the leading "9000/"). The +second column is the PA-RISC version and the third column is the exact +chip type used. =head2 Portability Between PA-RISC Versions An executable compiled on a PA-RISC 2.0 platform will not execute on a -PA-RISC 1.1 platform, even if they are running the same version of HP-UX. -If you are building Perl on a PA-RISC 2.0 platform and want that Perl to -to also run on a PA-RISC 1.1, the compiler flags +DAportable and +DS32 -should be used. +PA-RISC 1.1 platform, even if they are running the same version of +HP-UX. If you are building Perl on a PA-RISC 2.0 platform and want that +Perl to to also run on a PA-RISC 1.1, the compiler flags +DAportable and ++DS32 should be used. -It is no longer possible to compile PA-RISC 1.0 executables on either the -PA-RISC 1.1 or 2.0 platforms. +It is no longer possible to compile PA-RISC 1.0 executables on either +the PA-RISC 1.1 or 2.0 platforms. =head2 Building Dynamic Extensions on HP-UX HP-UX supports dynamically loadable libraries (shared libraries). Shared libraries end with the suffix .sl. -Shared libraries created on a platform using a particular PA-RISC version -are not usable on platforms using an earlier PA-RISC version by default. -However, this backwards compatibility may be enabled using the same -+DAportable compiler flag (with the same PA-RISC 1.0 caveat mentioned above). +Shared libraries created on a platform using a particular PA-RISC +version are not usable on platforms using an earlier PA-RISC version by +default. However, this backwards compatibility may be enabled using the +same +DAportable compiler flag (with the same PA-RISC 1.0 caveat +mentioned above). To create a shared library, the following steps must be performed: @@ -116,49 +124,46 @@ If these dependent libraries are not listed at shared library creation time, you will get fatal "Unresolved symbol" errors at run time when the library is loaded. -You may create a shared library that refers to another library, which -may be either an archive library or a shared library. If it is a -shared library, this is called a "dependent library". -The dependent library's name is recorded in the main shared library, -but it is not linked into the shared library. -Instead, it is loaded when the main shared library is loaded. +You may create a shared library that referers to another library, which +may be either an archive library or a shared library. If this second +library is a shared library, this is called a "dependent library". The +dependent library's name is recorded in the main shared library, but it +is not linked into the shared library. Instead, it is loaded when the +main shared library is loaded. This can cause problems if you build an +extension on one system and move it to another system where the +libraries may not be located in the same place as on the first system. If the referred library is an archive library, then it is treated as a simple collection of .o modules (all of which must contain PIC). These modules are then linked into the shared library. -Note that it is okay to create a library which contains a dependent library -that is already linked into perl. +Note that it is okay to create a library which contains a dependent +library that is already linked into perl. It is no longer possible to link PA-RISC 1.0 shared libraries. =head2 The HP ANSI C Compiler -When using this compiler to build Perl, you should make sure that -the flag -Aa is added to the cpprun and cppstdin variables in the -config.sh file. +When using this compiler to build Perl, you should make sure that the +flag -Aa is added to the cpprun and cppstdin variables in the config.sh +file (though see the section on 64-bit perl below). =head2 Using Large Files with Perl -Beginning with HP-UX version 10.20, files larger than 2GB (2^31) may be -created and manipulated. -Three separate methods of doing this are available. -Of these methods, -the best method for Perl is to compile using the -Duselargefiles -flag to Configure. -This will cause the -D_FILE_OFFSET_BITS=64 compiler flag to be used -when building Perl. -This causes Perl to be compiled using structures and functions in which -these are 64 bits wide, rather than 32 bits wide. -(Note that this will only work with HP's ANSI C compiler. -If you want to compile Perl using gcc, you will have to get a version -of the compiler that support 64-bit operations.) - -The one drawback to this approach is that -any extension which calls any file-manipulating C function -will need to be recompiled +Beginning with HP-UX version 10.20, files larger than 2GB (2^31 bytes) +may be created and manipulated. Three separate methods of doing this +are available. Of these methods, the best method for Perl is to compile +using the -Duselargefiles flag to Configure. This causes Perl to be +compiled using structures and functions in which these are 64 bits wide, +rather than 32 bits wide. (Note that this will only work with HP's ANSI +C compiler. If you want to compile Perl using gcc, you will have to get +a version of the compiler that support 64-bit operations.) + +There are some drawbacks to this approach. One is that any extension +which calls any file-manipulating C function will need to be recompiled (just follow the usual "perl Makefile.PL; make; make test; make install" procedure). + The list of functions that will need to recompiled is: creat, fgetpos, fopen, freopen, fsetpos, fstat, @@ -169,65 +174,91 @@ open, prealloc, stat, statvfs, statvfsdev, tmpfile, truncate, getrlimit, setrlimit +Another drawback is only valid for Perl versions before 5.6.0. This +drawback is that the seek and tell functions (both the builtin version +and POSIX module version) will not perform correctly. + +It is strongly recommended that you use this flag when you run +Configure. If you do not do this, but later answer the question about +large files when Configure asks you, you may get a configuration that +cannot be compiled, or that does not function as expected. + =head2 Threaded Perl It is impossible to compile a version of threaded Perl on any version of HP-UX before 10.30, and it is strongly suggested that you be running on HP-UX 11.00 at least. -To compile Perl with thread, add -Dusethreads to the arguments of Configure. -Ensure that the -D_POSIX_C_SOURCE=199506L compiler flag is automatically -added to the list of flags. Also make sure that -lpthread is listed before --lc in the list of libraries to link Perl with. +To compile Perl with threads, add -Dusethreads to the arguments of +Configure. Verify that the -D_POSIX_C_SOURCE=199506L compiler flag is +automatically added to the list of flags. Also make sure that -lpthread +is listed before -lc in the list of libraries to link Perl with. -As of the date of this document, -Perl threads are not fully supported on HP-UX. +As of the date of this document, Perl threads are not fully supported on +HP-UX. =head2 64-bit Perl -Beginning with HP-UX 11.00, programs compiled under HP-UX can take advantage -of the LP64 programming environment (LP64 means Longs and Pointers are 64 bits -wide). +Beginning with HP-UX 11.00, programs compiled under HP-UX can take +advantage of the LP64 programming environment (LP64 means Longs and +Pointers are 64 bits wide). -Work is being performed on Perl to make it 64-bit compliant on all versions -of Unix. Once this is complete, scalar variables will be able to hold -numbers larger than 2^32 with complete precision. +Work is being performed on Perl to make it 64-bit compliant on all +versions of Unix. Once this is complete, scalar variables will be able +to hold numbers larger than 2^32 with complete precision. As of the date of this document, Perl is not 64-bit compliant on HP-UX. -Should a user wish to experiment with compiling Perl in the LP64 environment, -use the -Duse64bitall flag to Configure. -This will force Perl to be compiled in a pure LP64 environment (via the -+DD64 flag). +Should a user wish to experiment with compiling Perl in the LP64 +environment, use the -Duse64bitall flag to Configure. This will force +Perl to be compiled in a pure LP64 environment (via the +DD64 flag). -You can also use the -Duse64bitint flag to Configure. -Although there are some minor differences between compiling Perl with -this flag versus the -Duse64bitall flag, -they should not be noticeable from a Perl user's perspective. +You can also use the -Duse64bitint flag to Configure. Although there +are some minor differences between compiling Perl with this flag versus +the -Duse64bitall flag, they should not be noticeable from a Perl user's +perspective. -In both cases, it is strongly recommended that you use these flags -when you run Configure. -If you do not use them, but answer the questions about 64-bit numbers -when Configure asks you, -you may get a configuration that cannot be compiled, or that does -not function as expected. +In both cases, it is strongly recommended that you use these flags when +you run Configure. If you do not use do this, but later answer the +questions about 64-bit numbers when Configure asks you, you may get a +configuration that cannot be compiled, or that does not function as +expected. -(Note that these Configure flags will only work with HP's ANSI C compiler. -If you want to compile Perl using gcc, you will have to get a version -of the compiler that support 64-bit operations.) +(Note that these Configure flags will only work with HP's ANSI C +compiler. If you want to compile Perl using gcc, you will have to get a +version of the compiler that support 64-bit operations.) =head2 GDBM and Threads -If you attempt to compile Perl with threads on an 11.X system and also link -in the GDBM library, then Perl will immediately core dump when it starts up. -The only workaround at this point is to relink the GDBM library under 11.X, -then relink it into Perl. +If you attempt to compile Perl with threads on an 11.X system and also +link in the GDBM library, then Perl will immediately core dump when it +starts up. The only workaround at this point is to relink the GDBM +library under 11.X, then relink it into Perl. =head2 NFS filesystems and utime(2) If you are compiling Perl on a remotely-mounted NFS filesystem, the test -io/fs.t may fail on test #18. -This appears to be a bug in HP-UX and no fix is currently available. +io/fs.t may fail on test #18. This appears to be a bug in HP-UX and no +fix is currently available. + +=head2 perl -P and // + +In HP-UX perl is compiled with flags that will cause problems if the +-P flag of Perl (preprocess Perl code with the C preprocessor before +perl sees it) is used. The problem is that C, being a C++-style +until-end-of-line comment, will disappear along with the remainder +of the line. This means that common Perl constructs like + + s/foo//; + +will turn into illegal code + + s/foo + +The workaround is to use some other quoting characters than /, +like for example ! + + s!foo!!; =head1 AUTHOR @@ -237,6 +268,6 @@ With much assistance regarding shared libraries from Marc Sabatella. =head1 DATE -Version 0.3: 2000/03/31 +Version 0.6.1: 2000/06/20 =cut diff --git a/README.micro b/README.micro new file mode 100644 index 0000000..da84453 --- /dev/null +++ b/README.micro @@ -0,0 +1,9 @@ +microperl is supposed to be able a really minimal perl, even more +minimal than miniperl. No Configure is needed to build microperl, +on the other hand this means that interfaces between Perl and your +operating system are left very -- minimal. + +All this is experimental. If you don't know what to do with microperl +you probably shouldn't. + + diff --git a/README.posix-bc b/README.posix-bc index 1105f67..3dd8ea2 100644 --- a/README.posix-bc +++ b/README.posix-bc @@ -1,28 +1,43 @@ -This is a first ported perl for the POSIX subsystem in BS2000 VERSION -'V121', OSD V3.1, POSIX Shell V03.1A55. It may work on other -versions, but that's the one we've tested it on. +This document is written in pod format hence there are punctuation +characters in in odd places. Do not worry, you've apparently got the +ASCII->EBCDIC translation worked out correctly. You can read more +about pod in pod/perlpod.pod or the short summary in the INSTALL file. + +=head1 NAME + +README.posix-bc - building and installing Perl for BS2000 POSIX. + +=head1 SYNOPSIS + +This document will help you Configure, build, test and install Perl +on BS2000 in the POSIX subsystem. + +=head1 DESCRIPTION + +This is a ported perl for the POSIX subsystem in BS2000 VERSION OSD +V3.1A. It may work on other versions, but that's the one we've tested +it on. You may need the following GNU programs in order to install perl: -gzip: +=head2 gzip We used version 1.2.4, which could be installed out of the box with one failure during 'make check'. -bison: +=head2 bison The yacc coming with BS2000 POSIX didn't work for us. So we had to use bison. We had to make a few changes to perl in order to use the pure (reentrant) parser of bison. We used version 1.25, but we had to add a few changes due to EBCDIC. - -UNPACKING: -========== +=head2 Unpacking To extract an ASCII tar archive on BS2000 POSIX you need an ASCII filesystem (we used the mountpoint /usr/local/ascii for this). Now -you extract the archive in the ASCII filesystem without I/O-conversion: +you extract the archive in the ASCII filesystem without +I/O-conversion: cd /usr/local/ascii export IO_CONVERSION=NO @@ -30,24 +45,20 @@ gunzip < /usr/local/src/perl.tar.gz | pax -r You may ignore the error message for the first element of the archive (this doesn't look like a tar archive / skipping to next file...), -it's only the directory which will be made anyway. +it's only the directory which will be created automatically anyway. After extracting the archive you copy the whole directory tree to your -EBCDIC filesystem. This time you use I/O-conversion: +EBCDIC filesystem. B: cd /usr/local/src IO_CONVERSION=YES cp -r /usr/local/ascii/perl5.005_02 ./ - -COMPILING: -========== +=head2 Compiling There is a "hints" file for posix-bc that specifies the correct values for most things. The major problem is (of course) the EBCDIC character -set. - -Configure did everything except the perl parser. +set. We have german EBCDIC version. Because of our problems with the native yacc we used GNU bison to generate a pure (=reentrant) parser for perly.y. So our yacc is @@ -85,16 +96,15 @@ We still use the normal yacc for a2p.y though!!! We made a softlink called byacc to distinguish between the two versions: ln -s /usr/bin/yacc /usr/local/bin/byacc - -We build perl using both GNU make and the native make. +We build perl using GNU make. We tried the native make once and it +worked too. -TESTING: -======== +=head2 Testing -We still got a few errors during 'make test'. Some of them are the -result of using bison. Bison prints 'parser error' instead of 'syntax -error', so we may ignore them. The following list shows +We still got a few errors during C. Some of them are the +result of using bison. Bison prints I instead of I, so we may ignore them. The following list shows our errors, your results may differ: op/numconvert.......FAILED tests 1409-1440 @@ -108,20 +118,45 @@ lib/complex.........FAILED tests 267, 487 lib/dumper..........FAILED tests 43, 45 Failed 11/231 test scripts, 95.24% okay. 57/10595 subtests failed, 99.46% okay. -INSTALLING: -=========== +=head2 Install We have no nroff on BS2000 POSIX (yet), so we ignored any errors while installing the documentation. -USING PERL: -=========== +=head2 Using Perl BS2000 POSIX doesn't support the shebang notation -('#!/usr/local/bin/perl'), so you have to use the following lines +(C<#!/usr/local/bin/perl>), so you have to use the following lines instead: : # use perl eval 'exec /usr/local/bin/perl -S $0 ${1+"$@"}' if $running_under_some_shell; + +=head1 AUTHORS + +Thomas Dorner + +=head1 SEE ALSO + +L, L. + +=head2 Mailing list + +The Perl Institute (http://www.perl.org/) maintains a perl-mvs mailing +list of interest to all folks building and/or using perl on EBCDIC +platforms. To subscibe, send a message of: + + subscribe perl-mvs + +to majordomo@perl.org. + +=head1 HISTORY + +This document was originally written by Thomas Dorner for the 5.005 +release of Perl. + +This document was podified for the 5.6 release of perl 11 July 2000. + +=cut diff --git a/Todo-5.6 b/Todo-5.6 index fac325c..d438969 100644 --- a/Todo-5.6 +++ b/Todo-5.6 @@ -12,7 +12,11 @@ Unicode support eliminate need for "use utf8;" autoload byte.pm when byte:: is seen by the parser check uv_to_utf8() calls for buffer overflow - (see also "Locales", "Regexen", and "Miscellaneous") + make \uXXXX (and \u{XXXX}?) where XXXX are hex digits + to work similarly to Unicode tech reports and Java + notation \uXXXX (and already existing \x{XXXX))? + more than four hexdigits? make also \U+XXXX work? + See also "Locales", "Regexen", and "Miscellaneous". Multi-threading support "use Thread;" under useithreads @@ -39,17 +43,18 @@ Namespace cleanup API-space: complete the list of things that constitute public api Configure - fix the vicious cyclic multidependency of cc <-> libpth <-> loclibpth - libswanted <-> usethreads <-> use64bitint <-> use64bitall <-> - uselargefiles <-> ... make configuring+building away from source directory work (VPATH et al) this is related to: cross-compilation configuring (see Todo) _r support (see Todo for mode detailed description) POSIX 1003.1 1996 Edition support--realtime stuff: POSIX semaphores, message queues, shared memory, realtime clocks, timers, signals (the metaconfig units mostly already exist for these) + PREFERABLY AS AN EXTENSION UNIX98 support: reader-writer locks, realtime/asynchronous IO + PREFERABLY AS AN EXTENSION IPv6 support: see RFC2292, RFC2553 + PREFERABLY AS AN EXTENSION + there already is Socket6 in CPAN Long doubles figure out where the PV->NV->PV conversion gets it wrong at least @@ -60,6 +65,7 @@ Long doubles 64-bit support Configure probe for quad_t, uquad_t, and (argh) u_quad_t, they might be in some systems the only thing working as quadtype and uquadtype. + more pain: long_long, u_long_long. Locales deprecate traditional/legacy locales? @@ -67,15 +73,16 @@ Locales figure out how to support Unicode locales suggestion: integrate the IBM Classes for Unicode (ICU) http://oss.software.ibm.com/developerworks/opensource/icu/project/ - and check out also the Locale Converter: + ICU is "portable, open-source Unicode library with: + charset-independent locales (with multiple locales + simultaneously supported in same thread; character + conversions; formatting/parsing for numbers, currencies, + date/time and messages; message catalogs (resources); + transliteration, collation, normalization, and text + boundaries (grapheme, word, line-break))". + Check out also the Locale Converter: http://alphaworks.ibm.com/tech/localeconverter - ICU is "portable, open-source Unicode library with: - charset-independent locales (with multiple locales simultaneously - supported in same thread; character conversions; formatting/parsing - for numbers, currencies, date/time and messages; message catalogs - (resources) ; transliteration, collation, normalization, and text - boundaries (grapheme, word, line-break))". - There is also 'iconv', either from XPG4 or GNU (glibc). + There is also the iconv interface, either from XPG4 or GNU (glibc). iconv is about character set conversions. Either ICU or iconv would be valuable to get integrated into Perl, Configure already probes for libiconv and . @@ -101,6 +108,9 @@ Regexen this is also a part of the Unicode 3.0: http://www.unicode.org/unicode/uni2book/u2.html executive summary: there are several different levels of 'equivalence' + trie optimization: factor out common suffixes (and prefixes?) + from |-alternating groups (both for exact strings and character + classes, use lookaheads?) approximate matching Security @@ -132,6 +142,7 @@ Miscellaneous (no metaconfig units yet for these). Don't forget finitel(), fp_classl(), fp_class_l(), (yes, both do, unfortunately, exist), and unorderedl(). + PREFERABLY AS AN EXTENSION. As of 5.6.1 there is cpp macro Perl_isnan(). fix the basic arithmetics (+ - * / %) to preserve IVness/UVness if both arguments are IVs/UVs @@ -156,3 +167,5 @@ Documentation spot-check all new modules for completeness better docs for pack()/unpack() reorg tutorials vs. reference sections + make roffitall to be dynamical about its pods and libs + diff --git a/Todo.micro b/Todo.micro new file mode 100644 index 0000000..76759b1 --- /dev/null +++ b/Todo.micro @@ -0,0 +1,9 @@ +- make creating uconfig.sh automatic (by pumpkin) + +- make creating Makefile.micro automatic (by pumpkin) + +- do away with fork/exec/wait? (system, popen should be enough?) + +- some of the uconfig.sh really needs to be probed (using cc) in buildtime: + (uConfigure? :-) native datatype widths and endianness come to mind + diff --git a/av.c b/av.c index 819887e..ef2c905 100644 --- a/av.c +++ b/av.c @@ -661,6 +661,14 @@ Perl_av_len(pTHX_ register AV *av) return AvFILL(av); } +/* +=for apidoc av_fill + +Ensure than an array has a given number of elements, equivalent to +Perl's C<$#array = $fill;>. + +=cut +*/ void Perl_av_fill(pTHX_ register AV *av, I32 fill) { @@ -708,6 +716,14 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill) (void)av_store(av,fill,&PL_sv_undef); } +/* +=for apidoc av_delete + +Deletes the element indexed by C from the array. Returns the +deleted element. C is currently ignored. + +=cut +*/ SV * Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) { @@ -758,10 +774,15 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) } /* - * This relies on the fact that uninitialized array elements - * are set to &PL_sv_undef. - */ +=for apidoc av_exists + +Returns true if the element indexed by C has been initialized. +This relies on the fact that uninitialized array elements are set to +C<&PL_sv_undef>. + +=cut +*/ bool Perl_av_exists(pTHX_ AV *av, I32 key) { diff --git a/av.h b/av.h index 6b66bfd..4a18430 100644 --- a/av.h +++ b/av.h @@ -32,8 +32,8 @@ struct xpvav { * real if the array needs to be modified in some way. Functions that * modify fake AVs check both flags to call av_reify() as appropriate. * - * Note that the Perl stack has neither flag set. (Thus, items that go - * on the stack are never refcounted.) + * Note that the Perl stack and @DB::args have neither flag set. (Thus, + * items that go on the stack are never refcounted.) * * These internal details are subject to change any time. AV * manipulations external to perl should not care about any of this. diff --git a/config_h.SH b/config_h.SH index 5bb7ddd..e66e0c5 100644 --- a/config_h.SH +++ b/config_h.SH @@ -1,29 +1,35 @@ +case "$CONFIG_SH" in +'') CONFIG_SH=config.sh ;; +esac +case "$CONFIG_H" in +'') CONFIG_H=config.h ;; +esac case $CONFIG in '') - if test -f config.sh; then TOP=.; - elif test -f ../config.sh; then TOP=..; - elif test -f ../../config.sh; then TOP=../..; - elif test -f ../../../config.sh; then TOP=../../..; - elif test -f ../../../../config.sh; then TOP=../../../..; + if test -f $CONFIG_SH; then TOP=.; + elif test -f ../$CONFIG_SH; then TOP=..; + elif test -f ../../$CONFIG_SH; then TOP=../..; + elif test -f ../../../$CONFIG_SH; then TOP=../../..; + elif test -f ../../../../$CONFIG_SH; then TOP=../../../..; else - echo "Can't find config.sh."; exit 1 + echo "Can't find $CONFIG_SH."; exit 1 fi - . $TOP/config.sh + . $TOP/$CONFIG_SH ;; esac case "$0" in */*) cd `expr X$0 : 'X\(.*\)/'` ;; esac -echo "Extracting config.h (with variable substitutions)" -sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-def!#undef!' +echo "Extracting $CONFIG_H (with variable substitutions)" +sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un-def!#undef!' /* * This file was produced by running the config_h.SH script, which - * gets its values from config.sh, which is generally produced by + * gets its values from $CONFIG_SH, which is generally produced by * running Configure. * * Feel free to modify any of this as the need arises. Note, however, * 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. + * For a more permanent change edit $CONFIG_SH and rerun config_h.SH. * * \$Id: Config_h.U,v 3.0.1.5 1997/02/28 14:57:43 ram Exp $ */ @@ -1198,18 +1204,18 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- * This macro surrounds its token with double quotes. */ #if $cpp_stuff == 1 -# define CAT2(a,b) a/**/b -# define STRINGIFY(a) "a" +#define CAT2(a,b) a/**/b +#define STRINGIFY(a) "a" /* If you can get stringification with catify, tell me how! */ #endif #if $cpp_stuff == 42 -# define PeRl_CaTiFy(a, b) a ## b -# define PeRl_StGiFy(a) #a +#define PeRl_CaTiFy(a, b) a ## b +#define PeRl_StGiFy(a) #a /* the additional level of indirection enables these macros to be * used as arguments to other macros. See K&R 2nd ed., page 231. */ -# define CAT2(a,b) PeRl_CaTiFy(a,b) -# define StGiFy(a) PeRl_StGiFy(a) -# define STRINGIFY(a) PeRl_StGiFy(a) +#define CAT2(a,b) PeRl_CaTiFy(a,b) +#define StGiFy(a) PeRl_StGiFy(a) +#define STRINGIFY(a) PeRl_StGiFy(a) #endif #if $cpp_stuff != 1 && $cpp_stuff != 42 # include "Bletch: How does this C preprocessor catenate tokens?" @@ -1342,12 +1348,6 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_endsent HAS_ENDSERVENT /**/ -/* HAS_ENDSPENT: - * This symbol, if defined, indicates that the endspent system call is - * available to finalize the scan of SysV shadow password entries. - */ -#$d_endspent HAS_ENDSPENT /**/ - /* HAS_FD_SET: * This symbol, when defined, indicates presence of the fd_set typedef * in @@ -1419,6 +1419,12 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_getcwd HAS_GETCWD /**/ +/* HAS_GETESPWNAM: + * This symbol, if defined, indicates that the getespwnam system call is + * available to retrieve enchanced (shadow) password entries by name. + */ +#$d_getespwnam HAS_GETESPWNAM /**/ + /* HAS_GETFSSTAT: * This symbol, if defined, indicates that the getfsstat routine is * available to stat filesystems in bulk. @@ -1549,6 +1555,12 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_getprotoprotos HAS_GETPROTO_PROTOS /**/ +/* HAS_GETPRPWNAM: + * This symbol, if defined, indicates that the getprpwnam system call is + * available to retrieve protected (shadow) password entries by name. + */ +#$d_getprpwnam HAS_GETPRPWNAM /**/ + /* HAS_GETPWENT: * This symbol, if defined, indicates that the getpwent routine is * available for sequential access of the passwd database. @@ -1570,12 +1582,6 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_getservprotos HAS_GETSERV_PROTOS /**/ -/* HAS_GETSPENT: - * This symbol, if defined, indicates that the getspent system call is - * available to retrieve SysV shadow password entries sequentially. - */ -#$d_getspent HAS_GETSPENT /**/ - /* HAS_GETSPNAM: * This symbol, if defined, indicates that the getspnam system call is * available to retrieve SysV shadow password entries by name. @@ -1757,6 +1763,13 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #$d_mmap HAS_MMAP /**/ #define Mmap_t $mmaptype /**/ +/* HAS_MODFL: + * This symbol, if defined, indicates that the modfl routine is + * available to split a long double x into a fractional part f and + * an integer part i such that |f| < 1.0 and (f + i) = x. + */ +#$d_modfl HAS_MODFL /**/ + /* HAS_MPROTECT: * This symbol, if defined, indicates that the mprotect system call is * available to modify the access protection of a memory mapped file. @@ -1869,6 +1882,12 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_setpent HAS_SETPROTOENT /**/ +/* HAS_SETPROCTITLE: + * This symbol, if defined, indicates that the setproctitle routine is + * available to set process title. + */ +#$d_setproctitle HAS_SETPROCTITLE /**/ + /* HAS_SETPWENT: * This symbol, if defined, indicates that the setpwent routine is * available for initializing sequential access of the passwd database. @@ -1881,12 +1900,6 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$d_setsent HAS_SETSERVENT /**/ -/* HAS_SETSPENT: - * This symbol, if defined, indicates that the setspent system call is - * available to initialize the scan of SysV shadow password entries. - */ -#$d_setspent HAS_SETSPENT /**/ - /* HAS_SETVBUF: * This symbol, if defined, indicates that the setvbuf routine is * available to change buffering on an open stdio stream. @@ -2355,6 +2368,12 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ #$i_poll I_POLL /**/ +/* I_PROT: + * This symbol, if defined, indicates that exists and + * should be included. + */ +#$i_prot I_PROT /**/ + /* I_PTHREAD: * This symbol, if defined, indicates to the C program that it should * include . @@ -2684,7 +2703,11 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- */ /* NV_PRESERVES_UV: * This symbol, if defined, indicates that a variable of type NVTYPE - * can preserve all the bit of a variable of type UVSIZE. + * can preserve all the bits of a variable of type UVTYPE. + */ +/* NV_PRESERVES_UV_BITS: + * This symbol contains the number of bits a variable of type NVTYPE + * can preserve of a variable of type UVTYPE. */ #define IVTYPE $ivtype /**/ #define UVTYPE $uvtype /**/ @@ -2713,6 +2736,7 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #endif #define NVSIZE $nvsize /**/ #$d_nv_preserves_uv NV_PRESERVES_UV +#define NV_PRESERVES_UV_BITS $d_nv_preserves_uv_bits /* IVdf: * This symbol defines the format string used for printing a Perl IV @@ -3132,12 +3156,11 @@ sed <config.h -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un- #define PERL_XS_APIVERSION "$xs_apiversion" #define PERL_PM_APIVERSION "$pm_apiversion" -/* HAS_MODFL: - * This symbol, if defined, indicates that the modfl routine is - * available to split a long double x into a fractional part f and - * an integer part i such that |f| < 1.0 and (f + i) = x. +/* I_LIBUTIL: + * This symbol, if defined, indicates that exists and + * should be included. */ -#$d_modfl HAS_MODFL /**/ +#$i_libutil I_LIBUTIL /**/ #endif !GROK!THIS! diff --git a/cop.h b/cop.h index e588675..4584a96 100644 --- a/cop.h +++ b/cop.h @@ -29,32 +29,33 @@ struct cop { # define CopFILE(c) ((c)->cop_file) # define CopFILEGV(c) (CopFILE(c) \ ? gv_fetchfile(CopFILE(c)) : Nullgv) -# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) /* XXX */ +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) # define CopFILESV(c) (CopFILE(c) \ ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) # define CopFILEAV(c) (CopFILE(c) \ ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) # define CopSTASHPV(c) ((c)->cop_stashpv) -# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savepv(pv)) /* XXX */ +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = savepv(pv)) # define CopSTASH(c) (CopSTASHPV(c) \ ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) # define CopSTASH_set(c,hv) CopSTASHPV_set(c, HvNAME(hv)) -# define CopSTASH_eq(c,hv) (hv \ +# define CopSTASH_eq(c,hv) ((hv) \ && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #else # define CopFILEGV(c) ((c)->cop_filegv) -# define CopFILEGV_set(c,gv) ((c)->cop_filegv = gv) -# define CopFILE_set(c,pv) ((c)->cop_filegv = gv_fetchfile(pv)) +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) # define CopSTASH(c) ((c)->cop_stash) -# define CopSTASH_set(c,hv) ((c)->cop_stash = hv) +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) -# define CopSTASHPV_set(c,pv) CopSTASH_set(c, gv_stashpv(pv,GV_ADD)) -# define CopSTASH_eq(c,hv) (CopSTASH(c) == hv) + /* cop_stash is not refcounted */ +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif /* USE_ITHREADS */ #define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv)) @@ -79,6 +80,7 @@ struct block_sub { U16 olddepth; U8 hasargs; U8 lval; /* XXX merge lval and hasargs? */ + SV ** oldcurpad; }; #define PUSHSUB(cx) \ @@ -105,13 +107,14 @@ struct block_sub { } STMT_END #endif /* USE_THREADS */ -#ifdef USE_ITHREADS - /* junk in @_ spells trouble when cloning CVs, so don't leave any */ -# define CLEAR_ARGARRAY() av_clear(cx->blk_sub.argarray) -#else -# define CLEAR_ARGARRAY() NOOP -#endif /* USE_ITHREADS */ - +/* junk in @_ spells trouble when cloning CVs and in pp_caller(), so don't + * leave any (a fast av_clear(ary), basically) */ +#define CLEAR_ARGARRAY(ary) \ + STMT_START { \ + AvMAX(ary) += AvARRAY(ary) - AvALLOC(ary); \ + SvPVX(ary) = (char*)AvALLOC(ary); \ + AvFILLp(ary) = -1; \ + } STMT_END #define POPSUB(cx,sv) \ STMT_START { \ @@ -124,10 +127,10 @@ struct block_sub { cx->blk_sub.argarray = newAV(); \ av_extend(cx->blk_sub.argarray, fill); \ AvFLAGS(cx->blk_sub.argarray) = AVf_REIFY; \ - PL_curpad[0] = (SV*)cx->blk_sub.argarray; \ + cx->blk_sub.oldcurpad[0] = (SV*)cx->blk_sub.argarray; \ } \ else { \ - CLEAR_ARGARRAY(); \ + CLEAR_ARGARRAY(cx->blk_sub.argarray); \ } \ } \ sv = (SV*)cx->blk_sub.cv; \ @@ -423,6 +426,7 @@ L. #define G_NOARGS 8 /* Don't construct a @_ array. */ #define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */ #define G_NODEBUG 32 /* Disable debugging at toplevel. */ +#define G_METHOD 64 /* Calling method. */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ diff --git a/cygwin/Makefile.SHs b/cygwin/Makefile.SHs index ca083d4..120e8ee 100644 --- a/cygwin/Makefile.SHs +++ b/cygwin/Makefile.SHs @@ -157,10 +157,15 @@ esac # libperl.a is _the_ library both in dll and static cases # $(LIBPERL)$(LIB_EXT) expands to this name dependless of build model # +# NOTE: The "-Wl,-Bstatic $(LLIBPERL) -Wl,-Bdynamic" is required to give +# the import library linking priority over the dynamic library, since both +# the .dll and .a are in the same directory. When the new standard for +# naming import/dynamic/static libraries emerges this should be updated. +# $spitshell >>Makefile <<'!NO!SUBS!' perl: $& perlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) $(DYNALOADER) $(static_ext) ext.libs - $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) + $(SHRPENV) $(LDLIBPTH) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) -Wl,-Bstatic $(LLIBPERL) -Wl,-Bdynamic `cat ext.libs` $(libs) pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL)$(LIB_EXT) $(DYNALOADER) $(static_ext) ext.libs $(SHRPENV) $(LDLIBPTH) purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LLIBPERL) `cat ext.libs` $(libs) diff --git a/doio.c b/doio.c index 0121633..7d52d6f 100644 --- a/doio.c +++ b/doio.c @@ -476,11 +476,13 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, SV *sv; PerlLIO_dup2(PerlIO_fileno(fp), fd); + LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,PerlIO_fileno(fp),TRUE); (void)SvUPGRADE(sv, SVt_IV); pid = SvIVX(sv); SvIVX(sv) = 0; sv = *av_fetch(PL_fdpid,fd,TRUE); + UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv, SVt_IV); SvIVX(sv) = pid; if (!was_fdopen) @@ -810,7 +812,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit) dTHR; if (ckWARN(WARN_UNOPENED)) Perl_warner(aTHX_ WARN_UNOPENED, - "Close on unopened file <%s>",GvENAME(gv)); + "Close on unopened file %s",GvENAME(gv)); SETERRNO(EBADF,SS$_IVCHAN); } return FALSE; @@ -877,7 +879,7 @@ Perl_do_eof(pTHX_ GV *gv) || IoIFP(io) == PerlIO_stderr())) { SV* sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); + gv_efullname4(sv, gv, Nullch, FALSE); Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output", SvPV_nolen(sv)); } @@ -1194,7 +1196,7 @@ Perl_my_stat(pTHX) if (tmpgv == PL_defgv) return PL_laststatval; if (ckWARN(WARN_UNOPENED)) - Perl_warner(aTHX_ WARN_UNOPENED, "Stat on unopened file <%s>", + Perl_warner(aTHX_ WARN_UNOPENED, "Stat on unopened file %s", GvENAME(tmpgv)); PL_statgv = Nullgv; sv_setpv(PL_statname,""); @@ -1915,6 +1917,9 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) id = SvIVx(*++mark); mstr = *++mark; + /* suppress warning when reading into undef var --jhi */ + if (! SvOK(mstr)) + sv_setpvn(mstr, "", 0); msize = SvIVx(*++mark); mtype = (long)SvIVx(*++mark); flags = SvIVx(*++mark); diff --git a/doop.c b/doop.c index 4224b0e..ba8a7e5 100644 --- a/doop.c +++ b/doop.c @@ -15,17 +15,34 @@ #define PERL_IN_DOOP_C #include "perl.h" +#ifndef PERL_MICRO #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include #endif +#endif + +#define HALF_UTF8_UPGRADE(start,end) \ + STMT_START { \ + if ((start)<(end)) { \ + U8* NeWsTr; \ + STRLEN LeN = (end) - (start); \ + NeWsTr = bytes_to_utf8(start, &LeN); \ + Safefree(start); \ + (start) = NeWsTr; \ + (end) = (start) + LeN; \ + } \ + } STMT_END STATIC I32 -S_do_trans_CC_simple(pTHX_ SV *sv) +S_do_trans_simple(pTHX_ SV *sv) { dTHR; U8 *s; + U8 *d; U8 *send; + U8 *dstart; I32 matches = 0; + I32 sutf = SvUTF8(sv); STRLEN len; short *tbl; I32 ch; @@ -37,25 +54,59 @@ S_do_trans_CC_simple(pTHX_ SV *sv) s = (U8*)SvPV(sv, len); send = s + len; - while (s < send) { - if ((ch = tbl[*s]) >= 0) { - matches++; - *s = ch; + /* First, take care of non-UTF8 input strings, because they're easy */ + if (!sutf) { + while (s < send) { + if ((ch = tbl[*s]) >= 0) { + matches++; + *s++ = ch; + } + else + s++; } - s++; + SvSETMAGIC(sv); + return matches; } - SvSETMAGIC(sv); + /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */ + Newz(0, d, len*2+1, U8); + dstart = d; + while (s < send) { + I32 ulen; + short c; + + ulen = 1; + /* Need to check this, otherwise 128..255 won't match */ + c = utf8_to_uv(s, &ulen); + if (c < 0x100 && (ch = tbl[(short)c]) >= 0) { + matches++; + if (ch < 0x80) + *d++ = ch; + else + d = uv_to_utf8(d,ch); + s += ulen; + } + else { /* No match -> copy */ + while (ulen--) + *d++ = *s++; + } + } + *d = '\0'; + sv_setpvn(sv, (const char*)dstart, d - dstart); + SvUTF8_on(sv); + SvLEN_set(sv, 2*len+1); + SvSETMAGIC(sv); return matches; } STATIC I32 -S_do_trans_CC_count(pTHX_ SV *sv) +S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */ { dTHR; U8 *s; U8 *send; I32 matches = 0; + I32 hasutf = SvUTF8(sv); STRLEN len; short *tbl; @@ -67,21 +118,33 @@ S_do_trans_CC_count(pTHX_ SV *sv) send = s + len; while (s < send) { - if (tbl[*s] >= 0) - matches++; - s++; + if (hasutf && *s & 0x80) + s += UTF8SKIP(s); + else { + UV c; + I32 ulen; + ulen = 1; + if (hasutf) + c = utf8_to_uv(s,&ulen); + else + c = *s; + if (c < 0x100 && tbl[c] >= 0) + matches++; + s += ulen; + } } return matches; } STATIC I32 -S_do_trans_CC_complex(pTHX_ SV *sv) +S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ { dTHR; U8 *s; U8 *send; U8 *d; + I32 hasutf = SvUTF8(sv); I32 matches = 0; STRLEN len; short *tbl; @@ -99,32 +162,40 @@ S_do_trans_CC_complex(pTHX_ SV *sv) U8* p = send; while (s < send) { - if ((ch = tbl[*s]) >= 0) { - *d = ch; - matches++; - if (p == d - 1 && *p == *d) - matches--; - else - p = d++; - } - else if (ch == -1) /* -1 is unmapped character */ - *d++ = *s; /* -2 is delete character */ - s++; + if (hasutf && *s & 0x80) + s += UTF8SKIP(s); + else { + if ((ch = tbl[*s]) >= 0) { + *d = ch; + matches++; + if (p == d - 1 && *p == *d) + matches--; + else + p = d++; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; /* -2 is delete character */ + s++; + } } } else { while (s < send) { - if ((ch = tbl[*s]) >= 0) { - *d = ch; - matches++; - d++; - } - else if (ch == -1) /* -1 is unmapped character */ - *d++ = *s; /* -2 is delete character */ - s++; + if (hasutf && *s & 0x80) + s += UTF8SKIP(s); + else { + if ((ch = tbl[*s]) >= 0) { + *d = ch; + matches++; + d++; + } + else if (ch == -1) /* -1 is unmapped character */ + *d++ = *s; /* -2 is delete character */ + s++; + } } } - matches += send - d; /* account for disappeared chars */ + matches += send - d; /* account for disappeared chars */ *d = '\0'; SvCUR_set(sv, d - (U8*)SvPVX(sv)); SvSETMAGIC(sv); @@ -133,12 +204,14 @@ S_do_trans_CC_complex(pTHX_ SV *sv) } STATIC I32 -S_do_trans_UU_simple(pTHX_ SV *sv) +S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */ { dTHR; U8 *s; U8 *send; U8 *d; + U8 *start; + U8 *dstart; I32 matches = 0; STRLEN len; @@ -149,43 +222,60 @@ S_do_trans_UU_simple(pTHX_ SV *sv) UV extra = none + 1; UV final; UV uv; + I32 isutf; + I32 howmany; + isutf = SvUTF8(sv); s = (U8*)SvPV(sv, len); send = s + len; + start = s; svp = hv_fetch(hv, "FINAL", 5, FALSE); if (svp) final = SvUV(*svp); - d = s; + /* d needs to be bigger than s, in case e.g. upgrading is required */ + Newz(0, d, len*2+1, U8); + dstart = d; while (s < send) { if ((uv = swash_fetch(rv, s)) < none) { s += UTF8SKIP(s); matches++; + if ((uv & 0x80) && !isutf++) + HALF_UTF8_UPGRADE(dstart,d); d = uv_to_utf8(d, uv); } else if (uv == none) { int i; - for (i = UTF8SKIP(s); i; i--) + i = UTF8SKIP(s); + if (i > 1 && !isutf++) + HALF_UTF8_UPGRADE(dstart,d); + while(i--) *d++ = *s++; } else if (uv == extra) { - s += UTF8SKIP(s); + int i; + i = UTF8SKIP(s); + s += i; matches++; + if (i > 1 && !isutf++) + HALF_UTF8_UPGRADE(dstart,d); d = uv_to_utf8(d, final); } else s += UTF8SKIP(s); } *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); + sv_setpvn(sv, (const char*)dstart, d - dstart); SvSETMAGIC(sv); + if (isutf) + SvUTF8_on(sv); return matches; } STATIC I32 -S_do_trans_UU_count(pTHX_ SV *sv) +S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */ { dTHR; U8 *s; @@ -200,6 +290,8 @@ S_do_trans_UU_count(pTHX_ SV *sv) UV uv; s = (U8*)SvPV(sv, len); + if (!SvUTF8(sv)) + s = bytes_to_utf8(s, &len); send = s + len; while (s < send) { @@ -212,189 +304,7 @@ S_do_trans_UU_count(pTHX_ SV *sv) } STATIC I32 -S_do_trans_UC_simple(pTHX_ SV *sv) -{ - dTHR; - U8 *s; - U8 *send; - U8 *d; - I32 matches = 0; - STRLEN len; - - SV* rv = (SV*)cSVOP->op_sv; - HV* hv = (HV*)SvRV(rv); - SV** svp = hv_fetch(hv, "NONE", 4, FALSE); - UV none = svp ? SvUV(*svp) : 0x7fffffff; - UV extra = none + 1; - UV final; - UV uv; - - s = (U8*)SvPV(sv, len); - send = s + len; - - svp = hv_fetch(hv, "FINAL", 5, FALSE); - if (svp) - final = SvUV(*svp); - - d = s; - while (s < send) { - if ((uv = swash_fetch(rv, s)) < none) { - s += UTF8SKIP(s); - matches++; - *d++ = (U8)uv; - } - else if (uv == none) { - I32 ulen; - uv = utf8_to_uv(s, &ulen); - s += ulen; - *d++ = (U8)uv; - } - else if (uv == extra) { - s += UTF8SKIP(s); - matches++; - *d++ = (U8)final; - } - else - s += UTF8SKIP(s); - } - *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); - SvSETMAGIC(sv); - - return matches; -} - -STATIC I32 -S_do_trans_CU_simple(pTHX_ SV *sv) -{ - dTHR; - U8 *s; - U8 *send; - U8 *d; - U8 *dst; - I32 matches = 0; - STRLEN len; - - SV* rv = (SV*)cSVOP->op_sv; - HV* hv = (HV*)SvRV(rv); - SV** svp = hv_fetch(hv, "NONE", 4, FALSE); - UV none = svp ? SvUV(*svp) : 0x7fffffff; - UV extra = none + 1; - UV final; - UV uv; - U8 tmpbuf[UTF8_MAXLEN]; - I32 bits = 16; - - s = (U8*)SvPV(sv, len); - send = s + len; - - svp = hv_fetch(hv, "BITS", 4, FALSE); - if (svp) - bits = (I32)SvIV(*svp); - - svp = hv_fetch(hv, "FINAL", 5, FALSE); - if (svp) - final = SvUV(*svp); - - Newz(801, d, len * (bits >> 3) + 1, U8); - dst = d; - - while (s < send) { - uv = *s++; - if (uv < 0x80) - tmpbuf[0] = uv; - else { - tmpbuf[0] = (( uv >> 6) | 0xc0); - tmpbuf[1] = (( uv & 0x3f) | 0x80); - } - - if ((uv = swash_fetch(rv, tmpbuf)) < none) { - matches++; - d = uv_to_utf8(d, uv); - } - else if (uv == none) - d = uv_to_utf8(d, s[-1]); - else if (uv == extra) { - matches++; - d = uv_to_utf8(d, final); - } - } - *d = '\0'; - sv_usepvn_mg(sv, (char*)dst, d - dst); - - return matches; -} - -/* utf-8 to latin-1 */ - -STATIC I32 -S_do_trans_UC_trivial(pTHX_ SV *sv) -{ - dTHR; - U8 *s; - U8 *send; - U8 *d; - STRLEN len; - - s = (U8*)SvPV(sv, len); - send = s + len; - - d = s; - while (s < send) { - if (*s < 0x80) - *d++ = *s++; - else { - I32 ulen; - UV uv = utf8_to_uv(s, &ulen); - s += ulen; - *d++ = (U8)uv; - } - } - *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); - SvSETMAGIC(sv); - - return SvCUR(sv); -} - -/* latin-1 to utf-8 */ - -STATIC I32 -S_do_trans_CU_trivial(pTHX_ SV *sv) -{ - dTHR; - U8 *s; - U8 *send; - U8 *d; - U8 *dst; - I32 matches; - STRLEN len; - - s = (U8*)SvPV(sv, len); - send = s + len; - - Newz(801, d, len * 2 + 1, U8); - dst = d; - - matches = send - s; - - while (s < send) { - if (*s < 0x80) - *d++ = *s++; - else { - UV uv = *s++; - *d++ = (( uv >> 6) | 0xc0); - *d++ = (( uv & 0x3f) | 0x80); - } - } - *d = '\0'; - sv_usepvn_mg(sv, (char*)dst, d - dst); - - return matches; -} - -STATIC I32 -S_do_trans_UU_complex(pTHX_ SV *sv) +S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */ { dTHR; U8 *s; @@ -402,8 +312,6 @@ S_do_trans_UU_complex(pTHX_ SV *sv) U8 *d; I32 matches = 0; I32 squash = PL_op->op_private & OPpTRANS_SQUASH; - I32 from_utf = PL_op->op_private & OPpTRANS_FROM_UTF; - I32 to_utf = PL_op->op_private & OPpTRANS_TO_UTF; I32 del = PL_op->op_private & OPpTRANS_DELETE; SV* rv = (SV*)cSVOP->op_sv; HV* hv = (HV*)SvRV(rv); @@ -414,6 +322,7 @@ S_do_trans_UU_complex(pTHX_ SV *sv) UV uv; STRLEN len; U8 *dst; + I32 isutf = SvUTF8(sv); s = (U8*)SvPV(sv, len); send = s + len; @@ -422,27 +331,14 @@ S_do_trans_UU_complex(pTHX_ SV *sv) if (svp) final = SvUV(*svp); - if (PL_op->op_private & OPpTRANS_GROWS) { - I32 bits = 16; - - svp = hv_fetch(hv, "BITS", 4, FALSE); - if (svp) - bits = (I32)SvIV(*svp); - - Newz(801, d, len * (bits >> 3) + 1, U8); + Newz(0, d, len*2+1, U8); dst = d; - } - else { - d = s; - dst = 0; - } if (squash) { UV puv = 0xfeedface; while (s < send) { - if (from_utf) { + if (SvUTF8(sv)) uv = swash_fetch(rv, s); - } else { U8 tmpbuf[2]; uv = *s++; @@ -454,63 +350,42 @@ S_do_trans_UU_complex(pTHX_ SV *sv) } uv = swash_fetch(rv, tmpbuf); } + if (uv < none) { matches++; if (uv != puv) { - if (uv >= 0x80 && to_utf) - d = uv_to_utf8(d, uv); - else - *d++ = (U8)uv; + if ((uv & 0x80) && !isutf++) + HALF_UTF8_UPGRADE(dst,d); + d = uv_to_utf8(d, uv); puv = uv; } - if (from_utf) - s += UTF8SKIP(s); + s += UTF8SKIP(s); continue; } else if (uv == none) { /* "none" is unmapped character */ - if (from_utf) { - if (*s < 0x80) - *d++ = *s++; - else if (to_utf) { - int i; - for (i = UTF8SKIP(s); i; --i) - *d++ = *s++; - } - else { - I32 ulen; - *d++ = (U8)utf8_to_uv(s, &ulen); - s += ulen; - } - } - else { /* must be to_utf only */ - d = uv_to_utf8(d, s[-1]); - } + I32 ulen; + *d++ = (U8)utf8_to_uv(s, &ulen); + s += ulen; puv = 0xfeedface; continue; } else if (uv == extra && !del) { matches++; if (uv != puv) { - if (final >= 0x80 && to_utf) - d = uv_to_utf8(d, final); - else - *d++ = (U8)final; + d = uv_to_utf8(d, final); puv = final; } - if (from_utf) - s += UTF8SKIP(s); + s += UTF8SKIP(s); continue; } - matches++; /* "none+1" is delete character */ - if (from_utf) - s += UTF8SKIP(s); + matches++; /* "none+1" is delete character */ + s += UTF8SKIP(s); } } else { while (s < send) { - if (from_utf) { + if (SvUTF8(sv)) uv = swash_fetch(rv, s); - } else { U8 tmpbuf[2]; uv = *s++; @@ -524,47 +399,24 @@ S_do_trans_UU_complex(pTHX_ SV *sv) } if (uv < none) { matches++; - if (uv >= 0x80 && to_utf) - d = uv_to_utf8(d, uv); - else - *d++ = (U8)uv; - if (from_utf) - s += UTF8SKIP(s); + d = uv_to_utf8(d, uv); + s += UTF8SKIP(s); continue; } else if (uv == none) { /* "none" is unmapped character */ - if (from_utf) { - if (*s < 0x80) - *d++ = *s++; - else if (to_utf) { - int i; - for (i = UTF8SKIP(s); i; --i) - *d++ = *s++; - } - else { - I32 ulen; - *d++ = (U8)utf8_to_uv(s, &ulen); - s += ulen; - } - } - else { /* must be to_utf only */ - d = uv_to_utf8(d, s[-1]); - } + I32 ulen; + *d++ = (U8)utf8_to_uv(s, &ulen); + s += ulen; continue; } else if (uv == extra && !del) { matches++; - if (final >= 0x80 && to_utf) - d = uv_to_utf8(d, final); - else - *d++ = (U8)final; - if (from_utf) - s += UTF8SKIP(s); + d = uv_to_utf8(d, final); + s += UTF8SKIP(s); continue; } - matches++; /* "none+1" is delete character */ - if (from_utf) - s += UTF8SKIP(s); + matches++; /* "none+1" is delete character */ + s += UTF8SKIP(s); } } if (dst) @@ -583,6 +435,8 @@ Perl_do_trans(pTHX_ SV *sv) { dTHR; STRLEN len; + I32 hasutf = (PL_op->op_private & + (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)); if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL)) Perl_croak(aTHX_ PL_no_modify); @@ -592,40 +446,29 @@ Perl_do_trans(pTHX_ SV *sv) return 0; if (!SvPOKp(sv)) (void)SvPV_force(sv, len); - (void)SvPOK_only(sv); + if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) + (void)SvPOK_only_UTF8(sv); DEBUG_t( Perl_deb(aTHX_ "2.TBL\n")); - switch (PL_op->op_private & 63) { + switch (PL_op->op_private & ~hasutf & 63) { case 0: - return do_trans_CC_simple(sv); - - case OPpTRANS_FROM_UTF: - return do_trans_UC_simple(sv); - - case OPpTRANS_TO_UTF: - return do_trans_CU_simple(sv); - - case OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF: - return do_trans_UU_simple(sv); + if (hasutf) + return do_trans_simple_utf8(sv); + else + return do_trans_simple(sv); case OPpTRANS_IDENTICAL: - return do_trans_CC_count(sv); - - case OPpTRANS_FROM_UTF|OPpTRANS_IDENTICAL: - return do_trans_UC_trivial(sv); - - case OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL: - return do_trans_CU_trivial(sv); - - case OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL: - return do_trans_UU_count(sv); + if (hasutf) + return do_trans_count_utf8(sv); + else + return do_trans_count(sv); default: - if (PL_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) - return do_trans_UU_complex(sv); /* could be UC or CU too */ + if (hasutf) + return do_trans_complex_utf8(sv); else - return do_trans_CC_complex(sv); + return do_trans_complex(sv); } } @@ -694,6 +537,7 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg) SvTAINTED_on(sv); } +/* XXX SvUTF8 support missing! */ UV Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) { @@ -826,6 +670,7 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) return retnum; } +/* XXX SvUTF8 support missing! */ void Perl_do_vecset(pTHX_ SV *sv) { @@ -841,6 +686,7 @@ Perl_do_vecset(pTHX_ SV *sv) if (!targ) return; s = (unsigned char*)SvPV_force(targ, targlen); + (void)SvPOK_only(targ); lval = SvUV(sv); offset = LvTARGOFF(sv); size = LvTARGLEN(sv); @@ -851,7 +697,7 @@ Perl_do_vecset(pTHX_ SV *sv) len = (offset + size + 7) / 8; /* required number of bytes */ if (len > targlen) { s = (unsigned char*)SvGROW(targ, len + 1); - (void)memzero(s + targlen, len - targlen + 1); + (void)memzero((char *)(s + targlen), len - targlen + 1); SvCUR_set(targ, len); } @@ -1059,6 +905,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) char *rsave; bool left_utf = DO_UTF8(left); bool right_utf = DO_UTF8(right); + I32 needlen; if (left_utf && !right_utf) sv_utf8_upgrade(right); @@ -1071,17 +918,23 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) rsave = rc = SvPV(right, rightlen); len = leftlen < rightlen ? leftlen : rightlen; lensave = len; - if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { + if ((left_utf || right_utf) && (sv == left || sv == right)) { + needlen = optype == OP_BIT_AND ? len : leftlen + rightlen; + Newz(801, dc, needlen + 1, char); + } + else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { STRLEN n_a; dc = SvPV_force(sv, n_a); if (SvCUR(sv) < len) { dc = SvGROW(sv, len + 1); (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); } + if (optype != OP_BIT_AND && (left_utf || right_utf)) + dc = SvGROW(sv, leftlen + rightlen + 1); } else { - I32 needlen = ((optype == OP_BIT_AND) - ? len : (leftlen > rightlen ? leftlen : rightlen)); + needlen = ((optype == OP_BIT_AND) + ? len : (leftlen > rightlen ? leftlen : rightlen)); Newz(801, dc, needlen + 1, char); (void)sv_usepvn(sv, dc, needlen); dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ @@ -1090,14 +943,11 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) (void)SvPOK_only(sv); if (left_utf || right_utf) { UV duc, luc, ruc; + char *dcsave = dc; STRLEN lulen = leftlen; STRLEN rulen = rightlen; - STRLEN dulen = 0; I32 ulen; - if (optype != OP_BIT_AND) - dc = SvGROW(sv, leftlen+rightlen+1); - switch (optype) { case OP_BIT_AND: while (lulen && rulen) { @@ -1110,8 +960,9 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) duc = luc & ruc; dc = (char*)uv_to_utf8((U8*)dc, duc); } - dulen = dc - SvPVX(sv); - SvCUR_set(sv, dulen); + if (sv == left || sv == right) + (void)sv_usepvn(sv, dcsave, needlen); + SvCUR_set(sv, dc - dcsave); break; case OP_BIT_XOR: while (lulen && rulen) { @@ -1137,8 +988,9 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) dc = (char*)uv_to_utf8((U8*)dc, duc); } mop_up_utf: - dulen = dc - SvPVX(sv); - SvCUR_set(sv, dulen); + if (sv == left || sv == right) + (void)sv_usepvn(sv, dcsave, needlen); + SvCUR_set(sv, dc - dcsave); if (rulen) sv_catpvn(sv, rc, rulen); else if (lulen) diff --git a/emacs/cperl-mode.el b/emacs/cperl-mode.el index f7d7a53..c6fa46c 100644 --- a/emacs/cperl-mode.el +++ b/emacs/cperl-mode.el @@ -2,7 +2,7 @@ ;;;; The following message is relative to GNU version of the module: -;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 1997 +;; Copyright (C) 1985, 86, 87, 1991--2000 ;; Free Software Foundation, Inc. ;; Author: Ilya Zakharevich and Bob Olson @@ -46,9 +46,10 @@ ;;; Commentary: -;; $Id: cperl-mode.el,v 4.19 1998/12/10 03:31:23 ilya Exp ilya $ +;; $Id: cperl-mode.el,v 4.32 2000/05/31 05:13:15 ilya Exp ilya $ -;;; Before RMS Emacs 20.3: To use this mode put the following into +;;; If your Emacs does not default to `cperl-mode' on Perl files: +;;; To use this mode put the following into ;;; your .emacs file: ;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) @@ -788,7 +789,7 @@ ;;; (`cperl-array-face'): One of definitions was garbled. ;;;; After 4.4: -;;; (`cperl-not-bad-regexp'): Updated. +;;; (`cperl-not-bad-style-regexp'): Updated. ;;; (`cperl-make-regexp-x'): Misprint in a message. ;;; (`cperl-find-pods-heres'): $a-1 ? foo : bar; was a regexp. ;;; `<< (' was considered a start of POD. @@ -908,6 +909,142 @@ ;;; (`cperl-calculate-indent'): Correct for labels when calculating ;;; indentation of continuations. ;;; Docstring updated. + +;;;; After 4.19: +;;; Minor (mostly spelling) corrections from 20.3.3 merged. + +;;;; After 4.20: +;;; (`cperl-tips'): Another workaround added. Sent to RMS for 20.4. + +;;;; After 4.21: +;;; (`cperl-praise'): Mention linear-time indent. +;;; (`cperl-find-pods-heres'): @if ? a : b was considered a REx. + +;;;; After 4.22: +;;; (`cperl-after-expr-p'): Make true after __END__. +;;; (`cperl-electric-pod'): "SYNOPSIS" was misspelled. + +;;;; After 4.23: +;;; (`cperl-beautify-regexp-piece'): Was not allowing for *? after a class. +;;; Allow for POSIX char-classes. +;;; Remove trailing whitespace when +;;; adding new linebreak. +;;; Add a level counter to stop shallow. +;;; Indents unprocessed groups rigidly. +;;; (`cperl-beautify-regexp'): Add an optional count argument to go that +;;; many levels deep. +;;; (`cperl-beautify-level'): Likewise +;;; Menu: Add new entries to Regexp menu to do one level +;;; (`cperl-contract-level'): Was entering an infinite loop +;;; (`cperl-find-pods-heres'): Typo (double quoting). +;;; Was detecting < $file > as FH instead of glob. +;;; Support for comments in RExen (except +;;; for m#\#comment#x), governed by +;;; `cperl-regexp-scan'. +;;; (`cperl-regexp-scan'): New customization variable. +;;; (`cperl-forward-re'): Improve logic of resetting syntax table. + +;;;; After 4.23 and: After 4.24: +;;; (`cperl-contract-levels'): Restore position. +;;; (`cperl-beautify-level'): Likewise. +;;; (`cperl-beautify-regexp'): Likewise. +;;; (`cperl-commentify'): Rudimental support for length=1 runs +;;; (`cperl-find-pods-heres'): Process 1-char long REx comments too /a#/x +;;; Processes REx-comments in #-delimited RExen. +;;; MAJOR BUG CORRECTED: after a misparse +;;; a body of a subroutine could be corrupted!!! +;;; One might need to reeval the function body +;;; to fix things. (A similar bug was +;;; present in `cperl-indent-region' eons ago.) +;;; To reproduce: +;; (defun foo () (let ((a '(t))) (insert (format "%s" a)) (setcar a 'BUG) t)) +;; (foo) +;; (foo) +;;; C-x C-e the above three lines (at end-of-line). First evaluation +;;; of `foo' inserts (t), second one inserts (BUG) ?! +;;; +;;; In CPerl it was triggered by inserting then deleting `/' at start of +;;; / a (?# asdf {[(}asdf )ef,/; + +;;;; After 4.25: +;;; (`cperl-commentify'): Was recognizing length=2 "strings" as length=1. +;;; (`imenu-example--create-perl-index'): +;;; Was not enforcing syntaxification-to-the-end. +;;; (`cperl-invert-if-unless'): Allow `for', `foreach'. +;;; (`cperl-find-pods-heres'): Quote `cperl-nonoverridable-face'. +;;; Mark qw(), m()x as indentable. +;;; (`cperl-init-faces'): Highlight `sysopen' too. +;;; Highlight $var in `for my $var' too. +;;; (`cperl-invert-if-unless'): Was leaving whitespace at end. +;;; (`cperl-linefeed'): Was splitting $var{$foo} if point after `{'. +;;; (`cperl-calculate-indent'): Remove old commented out code. +;;; Support (primitive) indentation of qw(), m()x. + + +;;;; After 4.26: +;;; (`cperl-problems'): Mention `fill-paragraph' on comment. \"" and +;;; q [] with intervening newlines. +;;; (`cperl-autoindent-on-semi'): New customization variable. +;;; (`cperl-electric-semi'): Use `cperl-autoindent-on-semi'. +;;; (`cperl-tips'): Mention how to make CPerl the default mode. +;;; (`cperl-mode'): Support `outline-minor-mode' +;;; (Thanks to Mark A. Hershberger). +;;; (`cperl-outline-level'): New function. +;;; (`cperl-highlight-variables-indiscriminately'): New customization var. +;;; (`cperl-init-faces'): Use `cperl-highlight-variables-indiscriminately'. +;;; (Thanks to Sean Kamath ). +;;; (`cperl-after-block-p'): Support CHECK and INIT. +;;; (`cperl-init-faces'): Likewise and "our". +;;; (Thanks to Doug MacEachern ). +;;; (`cperl-short-docs'): Likewise and "our". + + +;;;; After 4.27: +;;; (`cperl-find-pods-heres'): Recognize \"" as a string. +;;; Mark whitespace and comments between q and [] +;;; as `syntax-type' => `prestring'. +;;; Allow whitespace between << and "FOO". +;;; (`cperl-problems'): Remove \"" and q [] with intervening newlines. +;;; Mention multiple <")) - (setq over (looking-at "over\\>")) + (setq head1 (looking-at "head1\\>[ \t]*$")) + (setq over (and (looking-at "over\\>[ \t]*$") + (not (looking-at "over[ \t]*\n\n\n*=item\\>")))) (forward-char -1) (bolp)) (or (get-text-property (point) 'in-pod) (cperl-after-expr-p nil "{;:") (and (re-search-backward - "\\(\\`\n?\\|\n\n\\)=\\sw+" (point-min) t) + ;; "\\(\\`\n?\\|\n\n\\)=\\sw+" + "\\(\\`\n?\\|^\n\\)=\\sw+" + (point-min) t) (not (or (looking-at "=cut") (and cperl-use-syntax-table-text-property @@ -2806,12 +3008,12 @@ to nil." 'pod))))))))) (progn (save-excursion - (setq notlast (search-forward "\n\n=" nil t))) + (setq notlast (re-search-forward "^\n=" nil t))) (or notlast (progn (insert "\n\n=cut") (cperl-ensure-newlines 2) - (forward-sexp -2) + (forward-word -2) (if (and head1 (not (save-excursion @@ -2819,19 +3021,19 @@ to nil." (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>" nil t)))) ; Only one (progn - (forward-sexp 1) + (forward-word 1) (setq name (file-name-sans-extension (file-name-nondirectory (buffer-file-name))) p (point)) (insert " NAME\n\n" name - " - \n\n=head1 SYNOPSYS\n\n\n\n" + " - \n\n=head1 SYNOPSIS\n\n\n\n" "=head1 DESCRIPTION") (cperl-ensure-newlines 4) (goto-char p) - (forward-sexp 2) + (forward-word 2) (end-of-line) (setq really-delete t)) - (forward-sexp 1)))) + (forward-word 1)))) (if over (progn (setq p (point)) @@ -2839,7 +3041,7 @@ to nil." "=back") (cperl-ensure-newlines 2) (goto-char p) - (forward-sexp 1) + (forward-word 1) (end-of-line) (setq really-delete t))) (if (and delete really-delete) @@ -2908,6 +3110,7 @@ If in POD, insert appropriate lines." ; Leave the level of parens (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr ; Are at end + (cperl-after-block-p (point-min)) (progn (backward-sexp 1) (setq start (point-marker)) @@ -2995,7 +3198,9 @@ If in POD, insert appropriate lines." (interactive "P") (if cperl-auto-newline (cperl-electric-terminator arg) - (self-insert-command (prefix-numeric-value arg)))) + (self-insert-command (prefix-numeric-value arg)) + (if cperl-autoindent-on-semi + (cperl-indent-line)))) (defun cperl-electric-terminator (arg) "Insert character and correct line's indentation." @@ -3234,8 +3439,9 @@ Will not correct the indentation for labels, but will correct it for braces and closing parentheses and brackets.." (save-excursion (if (or - (memq (get-text-property (point) 'syntax-type) - '(pod here-doc here-doc-delim format)) + (and (memq (get-text-property (point) 'syntax-type) + '(pod here-doc here-doc-delim format)) + (not (get-text-property (point) 'indentable))) ;; before start of POD - whitespace found since do not have 'pod! (and (looking-at "[ \t]*\n=") (error "Spaces before pod section!")) @@ -3249,7 +3455,7 @@ and closing parentheses and brackets.." (following-char))) (in-pod (get-text-property (point) 'in-pod)) (pre-indent-point (point)) - p prop look-prop) + p prop look-prop is-block delim) (cond (in-pod ;; In the verbatim part, probably code example. What to do??? @@ -3286,48 +3492,18 @@ and closing parentheses and brackets.." (setcar (cddr parse-data) start)) ;; Before this point: end of statement (setq old-indent (nth 3 parse-data)))) - ;; (or parse-start (null symbol) - ;; (setq parse-start (symbol-value symbol) - ;; start-indent (nth 2 parse-start) - ;; parse-start (car parse-start))) - ;; (if parse-start - ;; (goto-char parse-start) - ;; (beginning-of-defun)) - ;; ;; Try to go out - ;; (while (< (point) indent-point) - ;; (setq start (point) parse-start start moved nil - ;; state (parse-partial-sexp start indent-point -1)) - ;; (if (> (car state) -1) nil - ;; ;; The current line could start like }}}, so the indentation - ;; ;; corresponds to a different level than what we reached - ;; (setq moved t) - ;; (beginning-of-line 2))) ; Go to the next line. - ;; (if start ; Not at the start of file - ;; (progn - ;; (goto-char start) - ;; (setq start-indent (current-indentation)) - ;; (if moved ; Should correct... - ;; (setq start-indent (- start-indent cperl-indent-level)))) - ;; (setq start-indent 0)) - ;; (if (< (point) indent-point) (setq parse-start (point))) - ;; (or state (setq state (parse-partial-sexp - ;; (point) indent-point -1 nil start-state))) - ;; (setq containing-sexp - ;; (or (car (cdr state)) - ;; (and (>= (nth 6 state) 0) old-containing-sexp)) - ;; old-containing-sexp nil start-state nil) -;;;; (while (< (point) indent-point) -;;;; (setq parse-start (point)) -;;;; (setq state (parse-partial-sexp (point) indent-point -1 nil start-state)) -;;;; (setq containing-sexp -;;;; (or (car (cdr state)) -;;;; (and (>= (nth 6 state) 0) old-containing-sexp)) -;;;; old-containing-sexp nil start-state nil)) - ;; (if symbol (set symbol (list indent-point state start-indent))) - ;; (goto-char indent-point) - (cond ((or (nth 3 state) (nth 4 state)) + (cond ((get-text-property (point) 'indentable) + ;; indent to just after the surrounding open, + ;; skip blanks if we do not close the expression. + (goto-char (1+ (previous-single-property-change (point) 'indentable))) + (or (memq char-after (append ")]}" nil)) + (looking-at "[ \t]*\\(#\\|$\\)") + (skip-chars-forward " \t")) + (current-column)) + ((or (nth 3 state) (nth 4 state)) ;; return nil or t if should not change this line (nth 4 state)) + ;; XXXX Do we need to special-case this? ((null containing-sexp) ;; Line is at top level. May be data or function definition, ;; or may be function argument declaration. @@ -3366,27 +3542,50 @@ and closing parentheses and brackets.." (list pre-indent-point))) 0) cperl-continued-statement-offset)))) - ((/= (char-after containing-sexp) ?{) - ;; line is expression, not statement: - ;; indent to just after the surrounding open, + ((not + (or (setq is-block + (and (setq delim (= (char-after containing-sexp) ?{)) + (save-excursion ; Is it a hash? + (goto-char containing-sexp) + (cperl-block-p)))) + cperl-indent-parens-as-block)) + ;; group is an expression, not a block: + ;; indent to just after the surrounding open parens, ;; skip blanks if we do not close the expression. (goto-char (1+ containing-sexp)) - (or (memq char-after (append ")]}" nil)) + (or (memq char-after + (append (if delim "}" ")]}") nil)) (looking-at "[ \t]*\\(#\\|$\\)") (skip-chars-forward " \t")) - (current-column)) - ((progn - ;; Containing-expr starts with \{. Check whether it is a hash. - (goto-char containing-sexp) - (not (cperl-block-p))) - (goto-char (1+ containing-sexp)) - (or (eq char-after ?\}) - (looking-at "[ \t]*\\(#\\|$\\)") - (skip-chars-forward " \t")) - (+ (current-column) ; Correct indentation of trailing ?\} - (if (eq char-after ?\}) (+ cperl-indent-level - cperl-close-paren-offset) + (+ (current-column) + (if (and delim + (eq char-after ?\})) + ;; Correct indentation of trailing ?\} + (+ cperl-indent-level cperl-close-paren-offset) 0))) +;;; ((and (/= (char-after containing-sexp) ?{) +;;; (not cperl-indent-parens-as-block)) +;;; ;; line is expression, not statement: +;;; ;; indent to just after the surrounding open, +;;; ;; skip blanks if we do not close the expression. +;;; (goto-char (1+ containing-sexp)) +;;; (or (memq char-after (append ")]}" nil)) +;;; (looking-at "[ \t]*\\(#\\|$\\)") +;;; (skip-chars-forward " \t")) +;;; (current-column)) +;;; ((progn +;;; ;; Containing-expr starts with \{. Check whether it is a hash. +;;; (goto-char containing-sexp) +;;; (and (not (cperl-block-p)) +;;; (not cperl-indent-parens-as-block))) +;;; (goto-char (1+ containing-sexp)) +;;; (or (eq char-after ?\}) +;;; (looking-at "[ \t]*\\(#\\|$\\)") +;;; (skip-chars-forward " \t")) +;;; (+ (current-column) ; Correct indentation of trailing ?\} +;;; (if (eq char-after ?\}) (+ cperl-indent-level +;;; cperl-close-paren-offset) +;;; 0))) (t ;; Statement level. Is it a continuation or a new statement? ;; Find previous non-comment character. @@ -3408,11 +3607,12 @@ and closing parentheses and brackets.." (beginning-of-line) (cperl-backward-to-noncomment containing-sexp)) ;; Now we get the answer. - ;; Had \?, too: - (if (not (or (memq (preceding-char) (append " ;{" '(nil))) + (if (not (or (eq (1- (point)) containing-sexp) + (memq (preceding-char) + (append (if is-block " ;{" " ,;{") '(nil))) (and (eq (preceding-char) ?\}) (cperl-after-block-and-statement-beg - containing-sexp)))) ; Was ?\, + containing-sexp)))) ;; This line is continuation of preceding line's statement; ;; indent `cperl-continued-statement-offset' more than the ;; previous line of the statement. @@ -3424,6 +3624,12 @@ and closing parentheses and brackets.." (+ (if (memq char-after (append "}])" nil)) 0 ; Closing parenth cperl-continued-statement-offset) + (if (or is-block + (not delim) + (not (eq char-after ?\}))) + 0 + ;; Now it is a hash reference + (+ cperl-indent-level cperl-close-paren-offset)) (if (looking-at "\\w+[ \t]*:") (if (> (current-indentation) cperl-min-label-indent) (- (current-indentation) cperl-label-offset) @@ -3479,6 +3685,12 @@ and closing parentheses and brackets.." (+ (if (and (bolp) (zerop cperl-indent-level)) (+ cperl-brace-offset cperl-continued-statement-offset) cperl-indent-level) + (if (or is-block + (not delim) + (not (eq char-after ?\}))) + 0 + ;; Now it is a hash reference + (+ cperl-indent-level cperl-close-paren-offset)) ;; Move back over whitespace before the openbrace. ;; If openbrace is not first nonwhite thing on the line, ;; add the cperl-brace-imaginary-offset. @@ -3766,8 +3978,11 @@ Returns true if comment is found." nil ;; We suppose that e is _after_ the end of construction, as after eol. (setq string (if string cperl-st-sfence cperl-st-cfence)) - (cperl-modify-syntax-type bb string) - (cperl-modify-syntax-type (1- e) string) + (if (> bb (- e 2)) + ;; one-char string/comment?! + (cperl-modify-syntax-type bb cperl-st-punct) + (cperl-modify-syntax-type bb string) + (cperl-modify-syntax-type (1- e) string)) (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) (put-text-property (1+ bb) (1- e) 'syntax-table cperl-string-syntax-table)) @@ -3777,6 +3992,7 @@ Returns true if comment is found." (not cperl-pod-here-fontify) (put-text-property bb e 'face (if string 'font-lock-string-face 'font-lock-comment-face))))) + (defvar cperl-starters '(( ?\( . ?\) ) ( ?\[ . ?\] ) ( ?\{ . ?\} ) @@ -3786,7 +4002,7 @@ Returns true if comment is found." &optional ostart oend) ;; Works *before* syntax recognition is done ;; May modify syntax-type text property if the situation is too hard - (let (b starter ender st i i2 go-forward) + (let (b starter ender st i i2 go-forward reset-st) (skip-chars-forward " \t") ;; ender means matching-char matcher. (setq b (point) @@ -3819,9 +4035,13 @@ Returns true if comment is found." (not ender)) ;; $ has TeXish matching rules, so $$ equiv $... (forward-char 2) + (setq reset-st (syntax-table)) (set-syntax-table st) (forward-sexp 1) - (set-syntax-table cperl-mode-syntax-table) + (if (<= (point) (1+ b)) + (error "Unfinished regular expression")) + (set-syntax-table reset-st) + (setq reset-st nil) ;; Now the problem is with m;blah;; (and (not ender) (eq (preceding-char) @@ -3858,6 +4078,8 @@ Returns true if comment is found." ender (nth 2 ender))))) (error (goto-char lim) (setq set-st nil) + (if reset-st + (set-syntax-table reset-st)) (or end (message "End of `%s%s%c ... %c' string/RE not found: %s" @@ -3873,7 +4095,7 @@ Returns true if comment is found." ;; i2: start of the second arg, if any (before delim iff `ender'). ;; ender: the last arg bounded by parens-like chars, the second one of them ;; starter: the starting delimiter of the first arg - ;; go-forward: has 2 args, and the second part is empth + ;; go-forward: has 2 args, and the second part is empty (list i i2 ender starter go-forward))) (defvar font-lock-string-face) @@ -3899,6 +4121,7 @@ Returns true if comment is found." ;; After-initial-line--to-end is marked `syntax-type' ==> `format' ;; d) 'Q'uoted string: ;; part between markers inclusive is marked `syntax-type' ==> `string' +;; part between `q' and the first marker is marked `syntax-type' ==> `prestring' (defun cperl-unwind-to-safe (before &optional end) ;; if BEFORE, go to the previous start-of-line on each step of unwinding @@ -3915,6 +4138,11 @@ Returns true if comment is found." (goto-char (setq pos (cperl-1- pos)))) ;; Up to the start (goto-char (point-min)))) + ;; Skip empty lines + (and (looking-at "\n*=") + (/= 0 (skip-chars-backward "\n")) + (forward-char)) + (setq pos (point)) (if end ;; Do the same for end, going small steps (progn @@ -3923,6 +4151,10 @@ Returns true if comment is found." end (next-single-property-change end 'syntax-type))) (or end pos))))) +(defvar cperl-nonoverridable-face) +(defvar font-lock-function-name-face) +(defvar font-lock-comment-face) + (defun cperl-find-pods-heres (&optional min max non-inter end ignore-max) "Scans the buffer for hard-to-parse Perl constructions. If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify @@ -3934,6 +4166,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', cperl-syntax-done-to min)) (or max (setq max (point-max))) (let* (face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb + is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2 (cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) (modified (buffer-modified-p)) @@ -3945,7 +4178,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (point-min))) (state (if use-syntax-state (cdr cperl-syntax-state))) - (st-l '(nil)) (err-l '(nil)) i2 + ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! + (st-l (list nil)) (err-l (list nil)) ;; Somehow font-lock may be not loaded yet... (font-lock-string-face (if (boundp 'font-lock-string-face) font-lock-string-face @@ -3957,6 +4191,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (boundp 'font-lock-function-name-face) font-lock-function-name-face 'font-lock-function-name-face)) + (font-lock-comment-face + (if (boundp 'font-lock-comment-face) + font-lock-comment-face + 'font-lock-comment-face)) (cperl-nonoverridable-face (if (boundp 'cperl-nonoverridable-face) cperl-nonoverridable-face @@ -3966,13 +4204,14 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', max)) (search (concat - "\\(\\`\n?\\|\n\n\\)=" + "\\(\\`\n?\\|^\n\\)=" "\\|" ;; One extra () before this: "<<" "\\(" ; 1 + 1 ;; First variant "BLAH" or just ``. - "\\([\"'`]\\)" ; 2 + 1 + "[ \t]*" ; Yes, whitespace is allowed! + "\\([\"'`]\\)" ; 2 + 1 = 3 "\\([^\"'`\n]*\\)" ; 3 + 1 "\\3" "\\|" @@ -4004,7 +4243,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\(\\") + ;; "\\(\\`\n?\\|^\n\\)=" + (if (looking-at "cut\\>") (if ignore-max nil ; Doing a chunk only (message "=cut is not preceded by a POD section") @@ -4047,61 +4292,64 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', b1 nil) ; error condition ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random - (or (re-search-forward "\n\n=cut\\>" stop-point 'toend) + (or (re-search-forward "^\n=cut\\>" stop-point 'toend) (progn - (message "End of a POD section not marked by =cut") - (setq b1 t) - (or (car err-l) (setcar err-l b)))) + (goto-char b) + (if (re-search-forward "\n=cut\\>" stop-point 'toend) + (progn + (message "=cut is not preceded by an empty line") + (setq b1 t) + (or (car err-l) (setcar err-l b)))))) (beginning-of-line 2) ; An empty line after =cut is not POD! (setq e (point)) - (if (and b1 (eobp)) - ;; Unrecoverable error - nil - (and (> e max) - (progn - (remove-text-properties - max e '(syntax-type t in-pod t syntax-table t - 'cperl-postpone t)) - (setq tmpend tb))) - (put-text-property b e 'in-pod t) - (put-text-property b e 'syntax-type 'in-pod) - (goto-char b) - (while (re-search-forward "\n\n[ \t]" e t) - ;; We start 'pod 1 char earlier to include the preceding line - (beginning-of-line) - (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) - (cperl-put-do-not-fontify b (point) t) - ;; mark the non-literal parts as PODs - (if cperl-pod-here-fontify - (cperl-postpone-fontification b (point) 'face face t)) - (re-search-forward "\n\n[^ \t\f\n]" e 'toend) - (beginning-of-line) - (setq b (point))) - (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) - (cperl-put-do-not-fontify (point) e t) + (and (> e max) + (progn + (remove-text-properties + max e '(syntax-type t in-pod t syntax-table t + cperl-postpone t + syntax-subtype t + rear-nonsticky t + indentable t)) + (setq tmpend tb))) + (put-text-property b e 'in-pod t) + (put-text-property b e 'syntax-type 'in-pod) + (goto-char b) + (while (re-search-forward "\n\n[ \t]" e t) + ;; We start 'pod 1 char earlier to include the preceding line + (beginning-of-line) + (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) + (cperl-put-do-not-fontify b (point) t) + ;; mark the non-literal parts as PODs (if cperl-pod-here-fontify - (progn - ;; mark the non-literal parts as PODs - (cperl-postpone-fontification (point) e 'face face t) - (goto-char bb) - (if (looking-at - "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") - ;; mark the headers - (cperl-postpone-fontification - (match-beginning 1) (match-end 1) - 'face head-face)) - (while (re-search-forward - ;; One paragraph - "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" - e 'toend) + (cperl-postpone-fontification b (point) 'face face t)) + (re-search-forward "\n\n[^ \t\f\n]" e 'toend) + (beginning-of-line) + (setq b (point))) + (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) + (cperl-put-do-not-fontify (point) e t) + (if cperl-pod-here-fontify + (progn + ;; mark the non-literal parts as PODs + (cperl-postpone-fontification (point) e 'face face t) + (goto-char bb) + (if (looking-at + "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") ;; mark the headers (cperl-postpone-fontification (match-beginning 1) (match-end 1) - 'face head-face)))) - (cperl-commentify bb e nil) - (goto-char e) - (or (eq e (point-max)) - (forward-char -1))))) ; Prepare for immediate pod start. + 'face head-face)) + (while (re-search-forward + ;; One paragraph + "^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" + e 'toend) + ;; mark the headers + (cperl-postpone-fontification + (match-beginning 1) (match-end 1) + 'face head-face)))) + (cperl-commentify bb e nil) + (goto-char e) + (or (eq e (point-max)) + (forward-char -1)))) ; Prepare for immediate pod start. ;; Here document ;; We do only one here-per-line ;; ;; One extra () before this: @@ -4239,16 +4487,16 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (or (memq bb '(?\$ ?\@ ?\% ?\* ?\#)) ; $#y (and (eq bb ?-) (eq c ?s)) ; -s file test - (and (eq bb ?\&) ; &&m/blah/ - (not (eq (char-after + (and (eq bb ?\&) + (not (eq (char-after ; &&m/blah/ (- (match-beginning b1) 2)) ?\&)))) ;; or <$file> (and (eq c ?\<) - ;; Do not stringify : + ;; Do not stringify , <$fh> : (save-match-data (looking-at - "\\s *\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\s *\\)?>")))) + "\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>")))) tb (match-beginning 0)) (goto-char (match-beginning b1)) (cperl-backward-to-noncomment (point-min)) @@ -4275,8 +4523,11 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (if (eq (preceding-char) ?-) ;; -d ?foo? is a RE (looking-at "[a-zA-Z]\\>") - (looking-at - "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>")))) + (and + (not (memq (preceding-char) + '(?$ ?@ ?& ?%))) + (looking-at + "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) (and (eq (preceding-char) ?.) (eq (char-after (- (point) 2)) ?.)) (bobp)) @@ -4301,9 +4552,12 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (goto-char b) (if (or bb (nth 3 state) (nth 4 state)) (goto-char i) + ;; Skip whitespace and comments... (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") (goto-char (match-end 0)) (skip-chars-forward " \t\n\f")) + (if (> (point) b) + (put-text-property b (point) 'syntax-type 'prestring)) ;; qtag means two-arg matcher, may be reset to ;; 2 or 3 later if some special quoting is needed. ;; e1 means matching-char matcher. @@ -4326,16 +4580,23 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', tail (if (and i (not tag)) (1- e1)) e (if i i e1) ; end of the first part - qtag nil) ; need to preserve backslashitis + qtag nil ; need to preserve backslashitis + is-x-REx nil) ; REx has //x modifier ;; Commenting \\ is dangerous, what about ( ? (and i tail (eq (char-after i) ?\\) (setq qtag t)) + (if (looking-at "\\sw*x") ; qr//x + (setq is-x-REx t)) (if (null i) ;; Considered as 1arg form (progn (cperl-commentify b (point) t) (put-text-property b (point) 'syntax-type 'string) + (if (or is-x-REx + ;; ignore other text properties: + (string-match "^qw$" argument)) + (put-text-property b (point) 'indentable t)) (and go (setq e1 (cperl-1+ e1)) (or (eobp) @@ -4352,9 +4613,13 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (progn (cperl-modify-syntax-type (1- (point)) cperl-st-ket) (cperl-modify-syntax-type i cperl-st-bra))) - (put-text-property b i 'syntax-type 'string)) + (put-text-property b i 'syntax-type 'string) + (if is-x-REx + (put-text-property b i 'indentable t))) (cperl-commentify b1 (point) t) (put-text-property b (point) 'syntax-type 'string) + (if is-x-REx + (put-text-property b i 'indentable t)) (if qtag (cperl-modify-syntax-type (1+ i) cperl-st-punct)) (setq tail nil))) @@ -4364,12 +4629,15 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (forward-word 1) ; skip modifiers s///s (if tail (cperl-commentify tail (point) t)) (cperl-postpone-fontification - e1 (point) 'face cperl-nonoverridable-face))) + e1 (point) 'face 'cperl-nonoverridable-face))) ;; Check whether it is m// which means "previous match" ;; and highlight differently - (if (and (eq e (+ 2 b)) - (string-match "^\\([sm]?\\|qr\\)$" argument) - ;; <> is already filtered out + (setq is-REx + (and (string-match "^\\([sm]?\\|qr\\)$" argument) + (or (not (= (length argument) 0)) + (not (eq c ?\<))))) + (if (and is-REx + (eq e (+ 2 b)) ;; split // *is* using zero-pattern (save-excursion (condition-case nil @@ -4390,7 +4658,56 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (cperl-postpone-fontification b (cperl-1+ b) 'face font-lock-constant-face) (cperl-postpone-fontification - (1- e) e 'face font-lock-constant-face)))) + (1- e) e 'face font-lock-constant-face))) + (if (and is-REx cperl-regexp-scan) + ;; Process RExen better + (save-excursion + (goto-char (1+ b)) + (while + (and (< (point) e) + (re-search-forward + (if is-x-REx + (if (eq (char-after b) ?\#) + "\\((\\?\\\\#\\)\\|\\(\\\\#\\)" + "\\((\\?#\\)\\|\\(#\\)") + (if (eq (char-after b) ?\#) + "\\((\\?\\\\#\\)" + "\\((\\?#\\)")) + (1- e) 'to-end)) + (goto-char (match-beginning 0)) + (setq REx-comment-start (point) + was-comment t) + (if (save-excursion + (and + ;; XXX not working if outside delimiter is # + (eq (preceding-char) ?\\) + (= (% (skip-chars-backward "$\\\\") 2) -1))) + ;; Not a comment, avoid loop: + (progn (setq was-comment nil) + (forward-char 1)) + (if (match-beginning 2) + (progn + (beginning-of-line 2) + (if (> (point) e) + (goto-char (1- e)))) + ;; Works also if the outside delimiters are (). + (or (search-forward ")" (1- e) 'toend) + (message + "Couldn't find end of (?#...)-comment in a REx, pos=%s" + REx-comment-start)))) + (if (>= (point) e) + (goto-char (1- e))) + (if was-comment + (progn + (setq REx-comment-end (point)) + (cperl-commentify + REx-comment-start REx-comment-end nil) + (cperl-postpone-fontification + REx-comment-start REx-comment-end + 'face font-lock-comment-face)))))) + (if (and is-REx is-x-REx) + (put-text-property (1+ b) (1- e) + 'syntax-subtype 'x-REx))) (if i2 (progn (cperl-postpone-fontification @@ -4443,7 +4760,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (goto-char bb)) ;; 1+6+2+1+1+2+1+1=15 extra () before this: ;; "__\\(END\\|DATA\\)__" - (t ; __END__, __DATA__ + ((match-beginning 16) ; __END__, __DATA__ (setq bb (match-end 0) b (match-beginning 0) state (parse-partial-sexp @@ -4454,7 +4771,21 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat (cperl-commentify b bb nil) (setq end t)) - (goto-char bb))) + (goto-char bb)) + ((match-beginning 17) ; "\\\\\\(['`\"]\\)" + (setq bb (match-end 0) + b (match-beginning 0)) + (goto-char b) + (skip-chars-backward "\\\\") + ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1)) + (setq state (parse-partial-sexp + state-point b nil nil state) + state-point b) + (if (or (nth 3 state) (nth 4 state) ) + nil + (cperl-modify-syntax-type b cperl-st-punct)) + (goto-char bb)) + (t (error "Error in regexp of the sniffer"))) (if (> (point) stop-point) (progn (if end @@ -4542,6 +4873,7 @@ CHARS is a string that contains good characters to have before us (however, (setq stop t)))) (or (bobp) ; ???? Needed (eq (point) lim) + (looking-at "[ \t]*__\\(END\\|DATA\\)__") ; After this anything goes (progn (if test (eval test) (or (memq (preceding-char) (append (or chars "{;") nil)) @@ -4661,7 +4993,7 @@ Returns some position at the last line." ;; Looking at: ;; foreach my $var (if (looking-at - "[ \t]*\\\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") + "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") (progn (setq ml (match-beginning 8)) (re-search-forward "[({]") @@ -5022,12 +5354,13 @@ indentation and initial hashes. Behaves usually outside of comment." (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) (index-meth-alist '()) meth - packages ends-ranges p + packages ends-ranges p marker (prev-pos 0) char fchar index index1 name (end-range 0) package) (goto-char (point-min)) (if noninteractive (message "Scanning Perl for index") (imenu-progress-message prev-pos 0)) + (cperl-update-syntaxification (point-max) (point-max)) ;; Search for the function (progn ;;save-match-data (while (re-search-forward @@ -5044,7 +5377,7 @@ indentation and initial hashes. Behaves usually outside of comment." nil) ((and (match-beginning 2) ; package or sub - ;; Skip if quoted (will not skip multi-line ''-comments :-(): + ;; Skip if quoted (will not skip multi-line ''-strings :-(): (null (get-text-property (match-beginning 1) 'syntax-table)) (null (get-text-property (match-beginning 1) 'syntax-type)) (null (get-text-property (match-beginning 1) 'in-pod))) @@ -5054,7 +5387,7 @@ indentation and initial hashes. Behaves usually outside of comment." ) ;; (if (looking-at "([^()]*)[ \t\n\f]*") ;; (goto-char (match-end 0))) ; Messes what follows - (setq char (following-char) + (setq char (following-char) ; ?\; for "sub foo () ;" meth nil p (point)) (while (and ends-ranges (>= p (car ends-ranges))) @@ -5077,16 +5410,18 @@ indentation and initial hashes. Behaves usually outside of comment." ;; ) ;; Skip this function name if it is a prototype declaration. (if (and (eq fchar ?s) (eq char ?\;)) nil - (setq index (imenu-example--name-and-position)) - (if (eq fchar ?p) nil - (setq name (buffer-substring (match-beginning 3) (match-end 3))) - (set-text-properties 0 (length name) nil name) + (setq name (buffer-substring (match-beginning 3) (match-end 3)) + marker (make-marker)) + (set-text-properties 0 (length name) nil name) + (set-marker marker (match-end 3)) + (if (eq fchar ?p) + (setq name (concat "package " name)) (cond ((string-match "[:']" name) (setq meth t)) ((> p end-range) nil) (t (setq name (concat package name) meth t)))) - (setcar index name) + (setq index (cons name marker)) (if (eq fchar ?p) (push index index-pack-alist) (push index index-alist)) @@ -5160,6 +5495,25 @@ indentation and initial hashes. Behaves usually outside of comment." index-alist)) (cperl-imenu-addback index-alist))) + +(defvar cperl-outline-regexp + (concat imenu-example--function-name-regexp-perl "\\|" "\\`")) + +;; Suggested by Mark A. Hershberger +(defun cperl-outline-level () + (looking-at outline-regexp) + (cond ((not (match-beginning 1)) 0) ; beginning-of-file + ((match-beginning 2) + (if (eq (char-after (match-beginning 2)) ?p) + 0 ; package + 1)) ; sub + ((match-beginning 5) + (if (eq (char-after (match-beginning 5)) ?1) + 1 ; head1 + 2)) ; head2 + (t 3))) ; should not happen + + (defvar cperl-compilation-error-regexp-alist ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" @@ -5242,8 +5596,7 @@ indentation and initial hashes. Behaves usually outside of comment." '("if" "until" "while" "elsif" "else" "unless" "for" "foreach" "continue" "exit" "die" "last" "goto" "next" "redo" "return" "local" "exec" "sub" "do" "dump" "use" - "require" "package" "eval" "my" "our" - "BEGIN" "END" "CHECK" "INIT") + "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT") "\\|") ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" ; In what follows we use `type' style @@ -5280,7 +5633,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" ;; "shutdown" "sin" "sleep" "socket" "socketpair" ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" - ;; "syscall" "sysread" "system" "syswrite" "tell" + ;; "syscall" "sysopen" "sysread" "system" "syswrite" "tell" ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" ;; "umask" "unlink" "unpack" "utime" "values" "vec" ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" @@ -5309,7 +5662,7 @@ indentation and initial hashes. Behaves usually outside of comment." "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" - "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|tem\\|write\\)\\|" + "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|" "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" @@ -5322,19 +5675,19 @@ indentation and initial hashes. Behaves usually outside of comment." (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "__END__" "INIT" "chomp" + ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "__END__" "chomp" ;; "chop" "defined" "delete" "do" "each" "else" "elsif" ;; "eval" "exists" "for" "foreach" "format" "goto" ;; "grep" "if" "keys" "last" "local" "map" "my" "next" - ;; "no" "our" "package" "pop" "pos" "print" "printf" "push" + ;; "no" "package" "pop" "pos" "print" "printf" "push" ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" ;; "sort" "splice" "split" "study" "sub" "tie" "tr" ;; "undef" "unless" "unshift" "untie" "until" "use" ;; "while" "y" "AUTOLOAD\\|BEGIN\\|CHECK\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" - "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|INIT\\|keys\\|" - "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our|" + "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|INIT\\|if\\|keys\\|" + "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|" "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" @@ -5372,6 +5725,10 @@ indentation and initial hashes. Behaves usually outside of comment." font-lock-constant-face) ; labels '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets 2 font-lock-constant-face) + ;; Uncomment to get perl-mode-like vars + ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) + ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" + ;;; (2 (cons font-lock-variable-name-face '(underline)))) (cond ((featurep 'font-lock-extra) '("^[ \t]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" (3 font-lock-variable-name-face) @@ -5386,10 +5743,10 @@ indentation and initial hashes. Behaves usually outside of comment." ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)" nil nil (1 font-lock-variable-name-face)))) - (t '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + (t '("^[ \t{}]*\\(my\\|local\\our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" 3 font-lock-variable-name-face))) - '("\\ is a synonym for <>. ARGVOUT Output filehandle with -i flag. BEGIN { ... } Immediately executed (during compilation) piece of code. END { ... } Pseudo-subroutine executed after the script finishes. +CHECK { ... } Pseudo-subroutine executed after the script is compiled. +INIT { ... } Pseudo-subroutine executed before the script starts running. DATA Input filehandle for what follows after __END__ or __DATA__. accept(NEWSOCKET,GENERICSOCKET) alarm(SECONDS) @@ -7113,6 +7495,7 @@ msgget(KEY,FLAGS) msgrcv(ID,VAR,SIZE,TYPE.FLAGS) msgsnd(ID,MSG,FLAGS) my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). +our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H). ... ne ... String inequality. next [LABEL] oct(EXPR) @@ -7281,14 +7664,18 @@ prototype \&SUB Returns prototype of the function given a reference. 'variable-documentation)) (setq buffer-read-only t))))) -(defun cperl-beautify-regexp-piece (b e embed) +(defun cperl-beautify-regexp-piece (b e embed level) ;; b is before the starting delimiter, e before the ending ;; e should be a marker, may be changed, but remains "correct". - (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code) + ;; EMBED is nil iff we process the whole REx. + ;; The REx is guarantied to have //x + ;; LEVEL shows how many levels deep to go + ;; position at enter and at leave is not defined + (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos) (if (not embed) (goto-char (1+ b)) (goto-char b) - (cond ((looking-at "(\\?\\\\#") ; badly commented (?#) + (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing (forward-char 2) (delete-char 1) (forward-char 1)) @@ -7306,8 +7693,9 @@ prototype \&SUB Returns prototype of the function given a reference. (goto-char e) (beginning-of-line) (if (re-search-forward "[^ \t]" e t) - (progn + (progn ; Something before the ending delimiter (goto-char e) + (delete-horizontal-space) (insert "\n") (indent-to-column c) (set-marker e (point)))) @@ -7350,17 +7738,27 @@ prototype \&SUB Returns prototype of the function given a reference. (setq tmp (point)) (if (looking-at "\\^?\\]") (goto-char (match-end 0))) - (or (re-search-forward "\\]\\([*+{?]\\)?" e t) + ;; XXXX POSIX classes?! + (while (and (not pos) + (re-search-forward "\\[:\\|\\]" e t)) + (if (eq (preceding-char) ?:) + (or (re-search-forward ":\\]" e t) + (error "[:POSIX:]-group in []-group not terminated")) + (setq pos t))) + (or (eq (preceding-char) ?\]) + (error "[]-group not terminated")) + (if (eq (following-char) ?\{) (progn - (goto-char (1- tmp)) - (error "[]-group not terminated"))) - (if (not (eq (preceding-char) ?\{)) nil - (forward-char -1) - (forward-sexp 1))) + (forward-sexp 1) + (and (eq (following-char) ??) + (forward-char 1))) + (re-search-forward "\\=\\([*+?]\\??\\)" e t))) ((match-beginning 7) ; () (goto-char (match-beginning 0)) - (or (eq (current-column) c1) + (setq pos (current-column)) + (or (eq pos c1) (progn + (delete-horizontal-space) (insert "\n") (indent-to-column c1))) (setq tmp (point)) @@ -7371,20 +7769,29 @@ prototype \&SUB Returns prototype of the function given a reference. ;; (error "()-group not terminated"))) (set-marker m (1- (point))) (set-marker m1 (point)) - (cond - ((not (match-beginning 8)) - (cperl-beautify-regexp-piece tmp m t)) - ((eq (char-after (+ 2 tmp)) ?\{) ; Code - t) - ((eq (char-after (+ 2 tmp)) ?\() ; Conditional - (goto-char (+ 2 tmp)) - (forward-sexp 1) - (cperl-beautify-regexp-piece (point) m t)) - ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind - (goto-char (+ 3 tmp)) - (cperl-beautify-regexp-piece (point) m t)) - (t - (cperl-beautify-regexp-piece tmp m t))) + (if (= level 1) + (if (progn ; indent rigidly if multiline + ;; In fact does not make a lot of sense, since + ;; the starting position can be already lost due + ;; to insertion of "\n" and " " + (goto-char tmp) + (search-forward "\n" m1 t)) + (indent-rigidly (point) m1 (- c1 pos))) + (setq level (1- level)) + (cond + ((not (match-beginning 8)) + (cperl-beautify-regexp-piece tmp m t level)) + ((eq (char-after (+ 2 tmp)) ?\{) ; Code + t) + ((eq (char-after (+ 2 tmp)) ?\() ; Conditional + (goto-char (+ 2 tmp)) + (forward-sexp 1) + (cperl-beautify-regexp-piece (point) m t level)) + ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind + (goto-char (+ 3 tmp)) + (cperl-beautify-regexp-piece (point) m t level)) + (t + (cperl-beautify-regexp-piece tmp m t level)))) (goto-char m1) (cond ((looking-at "[*+?]\\??") (goto-char (match-end 0))) @@ -7398,6 +7805,7 @@ prototype \&SUB Returns prototype of the function given a reference. (progn (or (eolp) (indent-for-comment)) (beginning-of-line 2)) + (delete-horizontal-space) (insert "\n")) (end-of-line) (setq inline nil)) @@ -7408,6 +7816,7 @@ prototype \&SUB Returns prototype of the function given a reference. (if (re-search-forward "[^ \t]" tmp t) (progn (goto-char tmp) + (delete-horizontal-space) (insert "\n")) ;; first at line (delete-region (point) tmp)) @@ -7417,6 +7826,7 @@ prototype \&SUB Returns prototype of the function given a reference. (setq spaces nil) (if (looking-at "[#\n]") (beginning-of-line 2) + (delete-horizontal-space) (insert "\n")) (end-of-line) (setq inline nil))) @@ -7425,8 +7835,8 @@ prototype \&SUB Returns prototype of the function given a reference. (insert " ")) (skip-chars-forward " \t")) (or (looking-at "[#\n]") - (error "unknown code \"%s\" in a regexp" (buffer-substring (point) - (1+ (point))))) + (error "unknown code \"%s\" in a regexp" + (buffer-substring (point) (1+ (point))))) (and inline (end-of-line 2))) ;; Special-case the last line of group (if (and (>= (point) (marker-position e)) @@ -7441,6 +7851,7 @@ prototype \&SUB Returns prototype of the function given a reference. (defun cperl-make-regexp-x () ;; Returns position of the start + ;; XXX this is called too often! Need to cache the result! (save-excursion (or cperl-use-syntax-table-text-property (error "I need to have a regexp marked!")) @@ -7471,15 +7882,19 @@ prototype \&SUB Returns prototype of the function given a reference. (forward-char 1))) b))) -(defun cperl-beautify-regexp () +(defun cperl-beautify-regexp (&optional deep) "do it. (Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." - (interactive) - (goto-char (cperl-make-regexp-x)) - (let ((b (point)) (e (make-marker))) - (forward-sexp 1) - (set-marker e (1- (point))) - (cperl-beautify-regexp-piece b e nil))) + (interactive "P") + (if deep + (prefix-numeric-value deep) + (setq deep -1)) + (save-excursion + (goto-char (cperl-make-regexp-x)) + (let ((b (point)) (e (make-marker))) + (forward-sexp 1) + (set-marker e (1- (point))) + (cperl-beautify-regexp-piece b e nil deep)))) (defun cperl-regext-to-level-start () "Goto start of an enclosing group in regexp. @@ -7501,61 +7916,67 @@ We suppose that the regexp is scanned already." \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) - (cperl-regext-to-level-start) - (let ((b (point)) (e (make-marker)) s c) - (forward-sexp 1) - (set-marker e (1- (point))) - (goto-char b) - (while (re-search-forward "\\(#\\)\\|\n" e t) - (cond - ((match-beginning 1) ; #-comment - (or c (setq c (current-indentation))) - (beginning-of-line 2) ; Skip - (setq s (point)) - (skip-chars-forward " \t") - (delete-region s (point)) - (indent-to-column c)) - (t - (delete-char -1) - (just-one-space)))))) + ;; (save-excursion ; Can't, breaks `cperl-contract-levels' + (cperl-regext-to-level-start) + (let ((b (point)) (e (make-marker)) s c) + (forward-sexp 1) + (set-marker e (1- (point))) + (goto-char b) + (while (re-search-forward "\\(#\\)\\|\n" e 'to-end) + (cond + ((match-beginning 1) ; #-comment + (or c (setq c (current-indentation))) + (beginning-of-line 2) ; Skip + (setq s (point)) + (skip-chars-forward " \t") + (delete-region s (point)) + (indent-to-column c)) + (t + (delete-char -1) + (just-one-space)))))) (defun cperl-contract-levels () "Find an enclosing group in regexp and contract all the kids. \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) - (condition-case nil - (cperl-regext-to-level-start) - (error ; We are outside outermost group - (goto-char (cperl-make-regexp-x)))) - (let ((b (point)) (e (make-marker)) s c) - (forward-sexp 1) - (set-marker e (1- (point))) - (goto-char (1+ b)) - (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) - (cond - ((match-beginning 1) ; Skip - nil) - (t ; Group - (cperl-contract-level)))))) - -(defun cperl-beautify-level () + (save-excursion + (condition-case nil + (cperl-regext-to-level-start) + (error ; We are outside outermost group + (goto-char (cperl-make-regexp-x)))) + (let ((b (point)) (e (make-marker)) s c) + (forward-sexp 1) + (set-marker e (1- (point))) + (goto-char (1+ b)) + (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) + (cond + ((match-beginning 1) ; Skip + nil) + (t ; Group + (cperl-contract-level))))))) + +(defun cperl-beautify-level (&optional deep) "Find an enclosing group in regexp and beautify it. \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." - (interactive) - (cperl-regext-to-level-start) - (let ((b (point)) (e (make-marker))) - (forward-sexp 1) - (set-marker e (1- (point))) - (cperl-beautify-regexp-piece b e nil))) + (interactive "P") + (if deep + (prefix-numeric-value deep) + (setq deep -1)) + (save-excursion + (cperl-regext-to-level-start) + (let ((b (point)) (e (make-marker))) + (forward-sexp 1) + (set-marker e (1- (point))) + (cperl-beautify-regexp-piece b e nil deep)))) (defun cperl-invert-if-unless () - "Changes `if (A) {B}' into `B if A;' if possible." + "Change `if (A) {B}' into `B if A;' etc if possible." (interactive) (or (looking-at "\\<") (forward-sexp -1)) - (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\)\\>") + (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") (let ((pos1 (point)) pos2 pos3 pos4 pos5 s1 s2 state p pos45 (s0 (buffer-substring (match-beginning 0) (match-end 0)))) @@ -7626,6 +8047,7 @@ We suppose that the regexp is scanned already." (forward-word 1) (setq pos1 (point)) (insert " " s1 ";") + (delete-horizontal-space) (forward-char -1) (delete-horizontal-space) (goto-char pos1) @@ -7633,14 +8055,14 @@ We suppose that the regexp is scanned already." (cperl-indent-line)) (error "`%s' (EXPR) not with an {BLOCK}" s0))) (error "`%s' not with an (EXPR)" s0))) - (error "Not at `if', `unless', `while', or `unless'"))) + (error "Not at `if', `unless', `while', `unless', `for' or `foreach'"))) ;;; By Anthony Foiani ;;; Getting help on modules in C-h f ? +;;; This is a modified version of `man'. ;;; Need to teach it how to lookup functions -(defvar Man-filter-list) (defun cperl-perldoc (word) - "Run a 'perldoc' on WORD." + "Run `perldoc' on WORD." (interactive (list (let* ((default-entry (cperl-word-at-point)) (input (read-string @@ -7664,15 +8086,18 @@ We suppose that the regexp is scanned already." (Man-getpage-in-background word))) (defun cperl-perldoc-at-point () - "Run a 'perldoc' on WORD." + "Run a `perldoc' on the word around point." (interactive) (cperl-perldoc (cperl-word-at-point))) -;;; By Nick Roberts (with changes) -(defvar pod2man-program "pod2man") +(defcustom pod2man-program "pod2man" + "*File name for `pod2man'." + :type 'file + :group 'cperl) +;;; By Nick Roberts (with changes) (defun cperl-pod-to-manpage () - "Create a virtual manpage in emacs from the Perl Online Documentation" + "Create a virtual manpage in Emacs from the Perl Online Documentation." (interactive) (require 'man) (let* ((pod2man-args (concat buffer-file-name " | nroff -man ")) @@ -7759,6 +8184,7 @@ We suppose that the regexp is scanned already." (defvar cperl-d-l nil) (defun cperl-fontify-syntaxically (end) ;; Some vars for debugging only + ;; (message "Syntaxifying...") (let (start (dbg (point)) (iend end) (istate (car cperl-syntax-state))) (and cperl-syntaxify-unwind @@ -7776,12 +8202,6 @@ We suppose that the regexp is scanned already." (and (> end start) (setq cperl-syntax-done-to start) ; In case what follows fails (cperl-find-pods-heres start end t nil t)) - ;;(setq cperl-d-l (cons (format "Syntaxifying %s..%s from %s to %s\n" - ;; dbg end start cperl-syntax-done-to) - ;; cperl-d-l)) - ;;(let ((standard-output (get-buffer "*Messages*"))) - ;;(princ (format "Syntaxifying %s..%s from %s to %s\n" - ;; dbg end start cperl-syntax-done-to))) (if (eq cperl-syntaxify-by-font-lock 'message) (message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s" dbg iend @@ -7809,7 +8229,7 @@ We suppose that the regexp is scanned already." (cperl-fontify-syntaxically to))))) (defvar cperl-version - (let ((v "$Revision: 4.19 $")) + (let ((v "$Revision: 4.32 $")) (string-match ":\\s *\\([0-9.]+\\)" v) (substring v (match-beginning 1) (match-end 1))) "Version of IZ-supported CPerl package this file is based on.") @@ -7817,4 +8237,3 @@ We suppose that the regexp is scanned already." (provide 'cperl-mode) ;;; cperl-mode.el ends here - diff --git a/embed.h b/embed.h index b19115f..f0bae6f 100644 --- a/embed.h +++ b/embed.h @@ -71,6 +71,7 @@ #define append_elem Perl_append_elem #define append_list Perl_append_list #define apply Perl_apply +#define apply_attrs_string Perl_apply_attrs_string #define avhv_delete_ent Perl_avhv_delete_ent #define avhv_exists_ent Perl_avhv_exists_ent #define avhv_fetch_ent Perl_avhv_fetch_ent @@ -229,6 +230,7 @@ #define gv_check Perl_gv_check #define gv_efullname Perl_gv_efullname #define gv_efullname3 Perl_gv_efullname3 +#define gv_efullname4 Perl_gv_efullname4 #define gv_fetchfile Perl_gv_fetchfile #define gv_fetchmeth Perl_gv_fetchmeth #define gv_fetchmethod Perl_gv_fetchmethod @@ -236,6 +238,7 @@ #define gv_fetchpv Perl_gv_fetchpv #define gv_fullname Perl_gv_fullname #define gv_fullname3 Perl_gv_fullname3 +#define gv_fullname4 Perl_gv_fullname4 #define gv_init Perl_gv_init #define gv_stashpv Perl_gv_stashpv #define gv_stashpvn Perl_gv_stashpvn @@ -269,6 +272,7 @@ #define instr Perl_instr #define io_close Perl_io_close #define invert Perl_invert +#define is_gv_magical Perl_is_gv_magical #define is_uni_alnum Perl_is_uni_alnum #define is_uni_alnumc Perl_is_uni_alnumc #define is_uni_idfirst Perl_is_uni_idfirst @@ -304,6 +308,7 @@ #define to_uni_title_lc Perl_to_uni_title_lc #define to_uni_lower_lc Perl_to_uni_lower_lc #define is_utf8_char Perl_is_utf8_char +#define is_utf8_string Perl_is_utf8_string #define is_utf8_alnum Perl_is_utf8_alnum #define is_utf8_alnumc Perl_is_utf8_alnumc #define is_utf8_idfirst Perl_is_utf8_idfirst @@ -570,6 +575,7 @@ #define save_freeop Perl_save_freeop #define save_freepv Perl_save_freepv #define save_generic_svref Perl_save_generic_svref +#define save_generic_pvref Perl_save_generic_pvref #define save_gp Perl_save_gp #define save_hash Perl_save_hash #define save_helem Perl_save_helem @@ -719,6 +725,8 @@ #define utf16_to_utf8_reversed Perl_utf16_to_utf8_reversed #define utf8_distance Perl_utf8_distance #define utf8_hop Perl_utf8_hop +#define utf8_to_bytes Perl_utf8_to_bytes +#define bytes_to_utf8 Perl_bytes_to_utf8 #define utf8_to_uv Perl_utf8_to_uv #define uv_to_utf8 Perl_uv_to_utf8 #define vivify_defelem Perl_vivify_defelem @@ -759,6 +767,9 @@ #endif #define runops_standard Perl_runops_standard #define runops_debug Perl_runops_debug +#if defined(USE_THREADS) +#define sv_lock Perl_sv_lock +#endif #define sv_catpvf_mg Perl_sv_catpvf_mg #define sv_vcatpvf_mg Perl_sv_vcatpvf_mg #define sv_catpv_mg Perl_sv_catpv_mg @@ -831,6 +842,7 @@ #define ptr_table_split Perl_ptr_table_split #endif #if defined(HAVE_INTERP_INTERN) +#define sys_intern_clear Perl_sys_intern_clear #define sys_intern_init Perl_sys_intern_init #endif #if defined(PERL_OBJECT) @@ -841,16 +853,12 @@ #define avhv_index S_avhv_index #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) -#define do_trans_CC_simple S_do_trans_CC_simple -#define do_trans_CC_count S_do_trans_CC_count -#define do_trans_CC_complex S_do_trans_CC_complex -#define do_trans_UU_simple S_do_trans_UU_simple -#define do_trans_UU_count S_do_trans_UU_count -#define do_trans_UU_complex S_do_trans_UU_complex -#define do_trans_UC_simple S_do_trans_UC_simple -#define do_trans_CU_simple S_do_trans_CU_simple -#define do_trans_UC_trivial S_do_trans_UC_trivial -#define do_trans_CU_trivial S_do_trans_CU_trivial +#define do_trans_simple S_do_trans_simple +#define do_trans_count S_do_trans_count +#define do_trans_complex S_do_trans_complex +#define do_trans_simple_utf8 S_do_trans_simple_utf8 +#define do_trans_count_utf8 S_do_trans_count_utf8 +#define do_trans_complex_utf8 S_do_trans_complex_utf8 #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) #define gv_init_sv S_gv_init_sv @@ -1089,6 +1097,7 @@ #define scan_trans S_scan_trans #define scan_word S_scan_word #define skipspace S_skipspace +#define swallow_bom S_swallow_bom #define checkcomma S_checkcomma #define force_ident S_force_ident #define incline S_incline @@ -1102,6 +1111,7 @@ #define sublex_push S_sublex_push #define sublex_start S_sublex_start #define filter_gets S_filter_gets +#define find_in_my_stash S_find_in_my_stash #define new_constant S_new_constant #define ao S_ao #define depcom S_depcom @@ -1539,6 +1549,7 @@ #define append_elem(a,b,c) Perl_append_elem(aTHX_ a,b,c) #define append_list(a,b,c) Perl_append_list(aTHX_ a,b,c) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) +#define apply_attrs_string(a,b,c,d) Perl_apply_attrs_string(aTHX_ a,b,c,d) #define avhv_delete_ent(a,b,c,d) Perl_avhv_delete_ent(aTHX_ a,b,c,d) #define avhv_exists_ent(a,b,c) Perl_avhv_exists_ent(aTHX_ a,b,c) #define avhv_fetch_ent(a,b,c,d) Perl_avhv_fetch_ent(aTHX_ a,b,c,d) @@ -1679,6 +1690,7 @@ #define gv_check(a) Perl_gv_check(aTHX_ a) #define gv_efullname(a,b) Perl_gv_efullname(aTHX_ a,b) #define gv_efullname3(a,b,c) Perl_gv_efullname3(aTHX_ a,b,c) +#define gv_efullname4(a,b,c,d) Perl_gv_efullname4(aTHX_ a,b,c,d) #define gv_fetchfile(a) Perl_gv_fetchfile(aTHX_ a) #define gv_fetchmeth(a,b,c,d) Perl_gv_fetchmeth(aTHX_ a,b,c,d) #define gv_fetchmethod(a,b) Perl_gv_fetchmethod(aTHX_ a,b) @@ -1686,6 +1698,7 @@ #define gv_fetchpv(a,b,c) Perl_gv_fetchpv(aTHX_ a,b,c) #define gv_fullname(a,b) Perl_gv_fullname(aTHX_ a,b) #define gv_fullname3(a,b,c) Perl_gv_fullname3(aTHX_ a,b,c) +#define gv_fullname4(a,b,c,d) Perl_gv_fullname4(aTHX_ a,b,c,d) #define gv_init(a,b,c,d,e) Perl_gv_init(aTHX_ a,b,c,d,e) #define gv_stashpv(a,b) Perl_gv_stashpv(aTHX_ a,b) #define gv_stashpvn(a,b,c) Perl_gv_stashpvn(aTHX_ a,b,c) @@ -1719,6 +1732,7 @@ #define instr(a,b) Perl_instr(aTHX_ a,b) #define io_close(a,b) Perl_io_close(aTHX_ a,b) #define invert(a) Perl_invert(aTHX_ a) +#define is_gv_magical(a,b,c) Perl_is_gv_magical(aTHX_ a,b,c) #define is_uni_alnum(a) Perl_is_uni_alnum(aTHX_ a) #define is_uni_alnumc(a) Perl_is_uni_alnumc(aTHX_ a) #define is_uni_idfirst(a) Perl_is_uni_idfirst(aTHX_ a) @@ -1754,6 +1768,7 @@ #define to_uni_title_lc(a) Perl_to_uni_title_lc(aTHX_ a) #define to_uni_lower_lc(a) Perl_to_uni_lower_lc(aTHX_ a) #define is_utf8_char(a) Perl_is_utf8_char(aTHX_ a) +#define is_utf8_string(a,b) Perl_is_utf8_string(aTHX_ a,b) #define is_utf8_alnum(a) Perl_is_utf8_alnum(aTHX_ a) #define is_utf8_alnumc(a) Perl_is_utf8_alnumc(aTHX_ a) #define is_utf8_idfirst(a) Perl_is_utf8_idfirst(aTHX_ a) @@ -2017,6 +2032,7 @@ #define save_freeop(a) Perl_save_freeop(aTHX_ a) #define save_freepv(a) Perl_save_freepv(aTHX_ a) #define save_generic_svref(a) Perl_save_generic_svref(aTHX_ a) +#define save_generic_pvref(a) Perl_save_generic_pvref(aTHX_ a) #define save_gp(a,b) Perl_save_gp(aTHX_ a,b) #define save_hash(a) Perl_save_hash(aTHX_ a) #define save_helem(a,b,c) Perl_save_helem(aTHX_ a,b,c) @@ -2160,10 +2176,12 @@ #define unsharepvn(a,b,c) Perl_unsharepvn(aTHX_ a,b,c) #define unshare_hek(a) Perl_unshare_hek(aTHX_ a) #define utilize(a,b,c,d,e) Perl_utilize(aTHX_ a,b,c,d,e) -#define utf16_to_utf8(a,b,c) Perl_utf16_to_utf8(aTHX_ a,b,c) -#define utf16_to_utf8_reversed(a,b,c) Perl_utf16_to_utf8_reversed(aTHX_ a,b,c) +#define utf16_to_utf8(a,b,c,d) Perl_utf16_to_utf8(aTHX_ a,b,c,d) +#define utf16_to_utf8_reversed(a,b,c,d) Perl_utf16_to_utf8_reversed(aTHX_ a,b,c,d) #define utf8_distance(a,b) Perl_utf8_distance(aTHX_ a,b) #define utf8_hop(a,b) Perl_utf8_hop(aTHX_ a,b) +#define utf8_to_bytes(a,b) Perl_utf8_to_bytes(aTHX_ a,b) +#define bytes_to_utf8(a,b) Perl_bytes_to_utf8(aTHX_ a,b) #define utf8_to_uv(a,b) Perl_utf8_to_uv(aTHX_ a,b) #define uv_to_utf8(a,b) Perl_uv_to_utf8(aTHX_ a,b) #define vivify_defelem(a) Perl_vivify_defelem(aTHX_ a) @@ -2202,6 +2220,9 @@ #endif #define runops_standard() Perl_runops_standard(aTHX) #define runops_debug() Perl_runops_debug(aTHX) +#if defined(USE_THREADS) +#define sv_lock(a) Perl_sv_lock(aTHX_ a) +#endif #define sv_vcatpvf_mg(a,b,c) Perl_sv_vcatpvf_mg(aTHX_ a,b,c) #define sv_catpv_mg(a,b) Perl_sv_catpv_mg(aTHX_ a,b) #define sv_catpvn_mg(a,b,c) Perl_sv_catpvn_mg(aTHX_ a,b,c) @@ -2270,6 +2291,7 @@ #define ptr_table_split(a) Perl_ptr_table_split(aTHX_ a) #endif #if defined(HAVE_INTERP_INTERN) +#define sys_intern_clear() Perl_sys_intern_clear(aTHX) #define sys_intern_init() Perl_sys_intern_init(aTHX) #endif #if defined(PERL_OBJECT) @@ -2280,16 +2302,12 @@ #define avhv_index(a,b,c) S_avhv_index(aTHX_ a,b,c) #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) -#define do_trans_CC_simple(a) S_do_trans_CC_simple(aTHX_ a) -#define do_trans_CC_count(a) S_do_trans_CC_count(aTHX_ a) -#define do_trans_CC_complex(a) S_do_trans_CC_complex(aTHX_ a) -#define do_trans_UU_simple(a) S_do_trans_UU_simple(aTHX_ a) -#define do_trans_UU_count(a) S_do_trans_UU_count(aTHX_ a) -#define do_trans_UU_complex(a) S_do_trans_UU_complex(aTHX_ a) -#define do_trans_UC_simple(a) S_do_trans_UC_simple(aTHX_ a) -#define do_trans_CU_simple(a) S_do_trans_CU_simple(aTHX_ a) -#define do_trans_UC_trivial(a) S_do_trans_UC_trivial(aTHX_ a) -#define do_trans_CU_trivial(a) S_do_trans_CU_trivial(aTHX_ a) +#define do_trans_simple(a) S_do_trans_simple(aTHX_ a) +#define do_trans_count(a) S_do_trans_count(aTHX_ a) +#define do_trans_complex(a) S_do_trans_complex(aTHX_ a) +#define do_trans_simple_utf8(a) S_do_trans_simple_utf8(aTHX_ a) +#define do_trans_count_utf8(a) S_do_trans_count_utf8(aTHX_ a) +#define do_trans_complex_utf8(a) S_do_trans_complex_utf8(aTHX_ a) #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) #define gv_init_sv(a,b) S_gv_init_sv(aTHX_ a,b) @@ -2527,6 +2545,7 @@ #define scan_trans(a) S_scan_trans(aTHX_ a) #define scan_word(a,b,c,d,e) S_scan_word(aTHX_ a,b,c,d,e) #define skipspace(a) S_skipspace(aTHX_ a) +#define swallow_bom(a) S_swallow_bom(aTHX_ a) #define checkcomma(a,b,c) S_checkcomma(aTHX_ a,b,c) #define force_ident(a,b) S_force_ident(aTHX_ a,b) #define incline(a) S_incline(aTHX_ a) @@ -2540,6 +2559,7 @@ #define sublex_push() S_sublex_push(aTHX) #define sublex_start() S_sublex_start(aTHX) #define filter_gets(a,b,c) S_filter_gets(aTHX_ a,b,c) +#define find_in_my_stash(a,b) S_find_in_my_stash(aTHX_ a,b) #define new_constant(a,b,c,d,e,f) S_new_constant(aTHX_ a,b,c,d,e,f) #define ao(a) S_ao(aTHX_ a) #define depcom() S_depcom(aTHX) @@ -2987,6 +3007,8 @@ #define append_list Perl_append_list #define Perl_apply CPerlObj::Perl_apply #define apply Perl_apply +#define Perl_apply_attrs_string CPerlObj::Perl_apply_attrs_string +#define apply_attrs_string Perl_apply_attrs_string #define Perl_avhv_delete_ent CPerlObj::Perl_avhv_delete_ent #define avhv_delete_ent Perl_avhv_delete_ent #define Perl_avhv_exists_ent CPerlObj::Perl_avhv_exists_ent @@ -3287,6 +3309,8 @@ #define gv_efullname Perl_gv_efullname #define Perl_gv_efullname3 CPerlObj::Perl_gv_efullname3 #define gv_efullname3 Perl_gv_efullname3 +#define Perl_gv_efullname4 CPerlObj::Perl_gv_efullname4 +#define gv_efullname4 Perl_gv_efullname4 #define Perl_gv_fetchfile CPerlObj::Perl_gv_fetchfile #define gv_fetchfile Perl_gv_fetchfile #define Perl_gv_fetchmeth CPerlObj::Perl_gv_fetchmeth @@ -3301,6 +3325,8 @@ #define gv_fullname Perl_gv_fullname #define Perl_gv_fullname3 CPerlObj::Perl_gv_fullname3 #define gv_fullname3 Perl_gv_fullname3 +#define Perl_gv_fullname4 CPerlObj::Perl_gv_fullname4 +#define gv_fullname4 Perl_gv_fullname4 #define Perl_gv_init CPerlObj::Perl_gv_init #define gv_init Perl_gv_init #define Perl_gv_stashpv CPerlObj::Perl_gv_stashpv @@ -3367,6 +3393,8 @@ #define io_close Perl_io_close #define Perl_invert CPerlObj::Perl_invert #define invert Perl_invert +#define Perl_is_gv_magical CPerlObj::Perl_is_gv_magical +#define is_gv_magical Perl_is_gv_magical #define Perl_is_uni_alnum CPerlObj::Perl_is_uni_alnum #define is_uni_alnum Perl_is_uni_alnum #define Perl_is_uni_alnumc CPerlObj::Perl_is_uni_alnumc @@ -3437,6 +3465,8 @@ #define to_uni_lower_lc Perl_to_uni_lower_lc #define Perl_is_utf8_char CPerlObj::Perl_is_utf8_char #define is_utf8_char Perl_is_utf8_char +#define Perl_is_utf8_string CPerlObj::Perl_is_utf8_string +#define is_utf8_string Perl_is_utf8_string #define Perl_is_utf8_alnum CPerlObj::Perl_is_utf8_alnum #define is_utf8_alnum Perl_is_utf8_alnum #define Perl_is_utf8_alnumc CPerlObj::Perl_is_utf8_alnumc @@ -3950,6 +3980,8 @@ #define save_freepv Perl_save_freepv #define Perl_save_generic_svref CPerlObj::Perl_save_generic_svref #define save_generic_svref Perl_save_generic_svref +#define Perl_save_generic_pvref CPerlObj::Perl_save_generic_pvref +#define save_generic_pvref Perl_save_generic_pvref #define Perl_save_gp CPerlObj::Perl_save_gp #define save_gp Perl_save_gp #define Perl_save_hash CPerlObj::Perl_save_hash @@ -4240,6 +4272,10 @@ #define utf8_distance Perl_utf8_distance #define Perl_utf8_hop CPerlObj::Perl_utf8_hop #define utf8_hop Perl_utf8_hop +#define Perl_utf8_to_bytes CPerlObj::Perl_utf8_to_bytes +#define utf8_to_bytes Perl_utf8_to_bytes +#define Perl_bytes_to_utf8 CPerlObj::Perl_bytes_to_utf8 +#define bytes_to_utf8 Perl_bytes_to_utf8 #define Perl_utf8_to_uv CPerlObj::Perl_utf8_to_uv #define utf8_to_uv Perl_utf8_to_uv #define Perl_uv_to_utf8 CPerlObj::Perl_uv_to_utf8 @@ -4311,6 +4347,10 @@ #define runops_standard Perl_runops_standard #define Perl_runops_debug CPerlObj::Perl_runops_debug #define runops_debug Perl_runops_debug +#if defined(USE_THREADS) +#define Perl_sv_lock CPerlObj::Perl_sv_lock +#define sv_lock Perl_sv_lock +#endif #define Perl_sv_catpvf_mg CPerlObj::Perl_sv_catpvf_mg #define sv_catpvf_mg Perl_sv_catpvf_mg #define Perl_sv_vcatpvf_mg CPerlObj::Perl_sv_vcatpvf_mg @@ -4448,6 +4488,8 @@ #define ptr_table_split Perl_ptr_table_split #endif #if defined(HAVE_INTERP_INTERN) +#define Perl_sys_intern_clear CPerlObj::Perl_sys_intern_clear +#define sys_intern_clear Perl_sys_intern_clear #define Perl_sys_intern_init CPerlObj::Perl_sys_intern_init #define sys_intern_init Perl_sys_intern_init #endif @@ -4461,26 +4503,18 @@ #define avhv_index S_avhv_index #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) -#define S_do_trans_CC_simple CPerlObj::S_do_trans_CC_simple -#define do_trans_CC_simple S_do_trans_CC_simple -#define S_do_trans_CC_count CPerlObj::S_do_trans_CC_count -#define do_trans_CC_count S_do_trans_CC_count -#define S_do_trans_CC_complex CPerlObj::S_do_trans_CC_complex -#define do_trans_CC_complex S_do_trans_CC_complex -#define S_do_trans_UU_simple CPerlObj::S_do_trans_UU_simple -#define do_trans_UU_simple S_do_trans_UU_simple -#define S_do_trans_UU_count CPerlObj::S_do_trans_UU_count -#define do_trans_UU_count S_do_trans_UU_count -#define S_do_trans_UU_complex CPerlObj::S_do_trans_UU_complex -#define do_trans_UU_complex S_do_trans_UU_complex -#define S_do_trans_UC_simple CPerlObj::S_do_trans_UC_simple -#define do_trans_UC_simple S_do_trans_UC_simple -#define S_do_trans_CU_simple CPerlObj::S_do_trans_CU_simple -#define do_trans_CU_simple S_do_trans_CU_simple -#define S_do_trans_UC_trivial CPerlObj::S_do_trans_UC_trivial -#define do_trans_UC_trivial S_do_trans_UC_trivial -#define S_do_trans_CU_trivial CPerlObj::S_do_trans_CU_trivial -#define do_trans_CU_trivial S_do_trans_CU_trivial +#define S_do_trans_simple CPerlObj::S_do_trans_simple +#define do_trans_simple S_do_trans_simple +#define S_do_trans_count CPerlObj::S_do_trans_count +#define do_trans_count S_do_trans_count +#define S_do_trans_complex CPerlObj::S_do_trans_complex +#define do_trans_complex S_do_trans_complex +#define S_do_trans_simple_utf8 CPerlObj::S_do_trans_simple_utf8 +#define do_trans_simple_utf8 S_do_trans_simple_utf8 +#define S_do_trans_count_utf8 CPerlObj::S_do_trans_count_utf8 +#define do_trans_count_utf8 S_do_trans_count_utf8 +#define S_do_trans_complex_utf8 CPerlObj::S_do_trans_complex_utf8 +#define do_trans_complex_utf8 S_do_trans_complex_utf8 #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) #define S_gv_init_sv CPerlObj::S_gv_init_sv @@ -4913,6 +4947,8 @@ #define scan_word S_scan_word #define S_skipspace CPerlObj::S_skipspace #define skipspace S_skipspace +#define S_swallow_bom CPerlObj::S_swallow_bom +#define swallow_bom S_swallow_bom #define S_checkcomma CPerlObj::S_checkcomma #define checkcomma S_checkcomma #define S_force_ident CPerlObj::S_force_ident @@ -4939,6 +4975,8 @@ #define sublex_start S_sublex_start #define S_filter_gets CPerlObj::S_filter_gets #define filter_gets S_filter_gets +#define S_find_in_my_stash CPerlObj::S_find_in_my_stash +#define find_in_my_stash S_find_in_my_stash #define S_new_constant CPerlObj::S_new_constant #define new_constant S_new_constant #define S_ao CPerlObj::S_ao diff --git a/embed.pl b/embed.pl index bbea4dc..e851a7a 100755 --- a/embed.pl +++ b/embed.pl @@ -916,6 +916,9 @@ START_EXTERN_C { return &(PL_##v); } #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHXo) \ { return &(PL_##v); } +#undef PERLVARIC +#define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHXo) \ + { return (const t *)&(PL_##v); } #include "perlvars.h" #undef PERLVAR @@ -1078,12 +1081,12 @@ my %apidocs; my %gutsdocs; my %docfuncs; -sub autodoc ($) { # parse a file and extract documentation info - my($fh) = @_; - my($in, $doc); - +sub autodoc ($$) { # parse a file and extract documentation info + my($fh,$file) = @_; + my($in, $doc, $line); FUNC: while (defined($in = <$fh>)) { + $line++; if ($in =~ /^=for\s+apidoc\s+(.*)\n/) { my $proto = $1; $proto = "||$proto" unless $proto =~ /\|/; @@ -1091,24 +1094,33 @@ FUNC: my $docs = ""; DOC: while (defined($doc = <$fh>)) { + $line++; last DOC if $doc =~ /^=\w+/; + if ($doc =~ m:^\*/$:) { + warn "=cut missing? $file:$line:$doc";; + last DOC; + } $docs .= $doc; } $docs = "\n$docs" if $docs and $docs !~ /^\n/; if ($flags =~ /m/) { if ($flags =~ /A/) { - $apidocs{$name} = [$flags, $docs, $ret, @args]; + $apidocs{$name} = [$flags, $docs, $ret, $file, @args]; } else { - $gutsdocs{$name} = [$flags, $docs, $ret, @args]; + $gutsdocs{$name} = [$flags, $docs, $ret, $file, @args]; } } else { - $docfuncs{$name} = [$flags, $docs, $ret, @args]; + $docfuncs{$name} = [$flags, $docs, $ret, $file, @args]; } - if ($doc =~ /^=for/) { - $in = $doc; - redo FUNC; + if (defined $doc) { + if ($doc =~ /^=for/) { + $in = $doc; + redo FUNC; + } + } else { + warn "$file:$line:$in"; } } } @@ -1116,8 +1128,10 @@ DOC: sub docout ($$$) { # output the docs for one function my($fh, $name, $docref) = @_; - my($flags, $docs, $ret, @args) = @$docref; + my($flags, $docs, $ret, $file, @args) = @$docref; + $docs .= "NOTE: this function is experimental and may change or be +removed without notice.\n\n" if $flags =~ /x/; $docs .= "NOTE: the perl_ form of this function is deprecated.\n\n" if $flags =~ /p/; @@ -1134,12 +1148,13 @@ sub docout ($$$) { # output the docs for one function print $fh "(" . join(", ", @args) . ")"; print $fh "\n\n"; } + print $fh "=for hackers\nFound in file $file\n\n"; } my $file; for $file (glob('*.c'), glob('*.h')) { open F, "< $file" or die "Cannot open $file for docs: $!\n"; - autodoc(\*F); + autodoc(\*F,$file); close F or die "Error closing $file: $!\n"; } @@ -1156,16 +1171,21 @@ walk_table { # load documented functions into approriate hash if ($flags =~ /A/) { my $docref = delete $docfuncs{$func}; warn "no docs for $func\n" unless $docref and @$docref; - $apidocs{$func} = [$docref->[0] . 'A', $docref->[1], $retval, @args]; + $docref->[0].="x" if $flags =~ /M/; + $apidocs{$func} = [$docref->[0] . 'A', $docref->[1], $retval, + $docref->[3], @args]; } else { my $docref = delete $docfuncs{$func}; - $gutsdocs{$func} = [$docref->[0], $docref->[1], $retval, @args]; + $gutsdocs{$func} = [$docref->[0], $docref->[1], $retval, + $docref->[3], @args]; } } return ""; } \*DOC; for (sort keys %docfuncs) { + # Have you used a full for apidoc or just a func name? + # Have you used Ap instead of Am in the for apidoc? warn "Unable to place $_!\n"; } @@ -1285,6 +1305,7 @@ __END__ : o has no compatibility macro (#define foo Perl_foo) : j not a member of CPerlObj : x not exported +: M may change : : Individual flags may be separated by whitespace. : @@ -1358,6 +1379,7 @@ Ap |bool |Gv_AMupdate |HV* stash p |OP* |append_elem |I32 optype|OP* head|OP* tail p |OP* |append_list |I32 optype|LISTOP* first|LISTOP* last p |I32 |apply |I32 type|SV** mark|SV** sp +Ap |void |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len Ap |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash Ap |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash Ap |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash @@ -1366,17 +1388,17 @@ Ap |HE* |avhv_iternext |AV *ar Ap |SV* |avhv_iterval |AV *ar|HE* entry Ap |HV* |avhv_keys |AV *ar Apd |void |av_clear |AV* ar -Ap |SV* |av_delete |AV* ar|I32 key|I32 flags -Ap |bool |av_exists |AV* ar|I32 key +Apd |SV* |av_delete |AV* ar|I32 key|I32 flags +Apd |bool |av_exists |AV* ar|I32 key Apd |void |av_extend |AV* ar|I32 key -Ap |AV* |av_fake |I32 size|SV** svp +p |AV* |av_fake |I32 size|SV** svp Apd |SV** |av_fetch |AV* ar|I32 key|I32 lval -Ap |void |av_fill |AV* ar|I32 fill +Apd |void |av_fill |AV* ar|I32 fill Apd |I32 |av_len |AV* ar Apd |AV* |av_make |I32 size|SV** svp Apd |SV* |av_pop |AV* ar Apd |void |av_push |AV* ar|SV* val -Ap |void |av_reify |AV* ar +p |void |av_reify |AV* ar Apd |SV* |av_shift |AV* ar Apd |SV** |av_store |AV* ar|I32 key|SV* val Apd |void |av_undef |AV* ar @@ -1511,7 +1533,7 @@ Ap |char* |vform |const char* pat|va_list* args Ap |void |free_tmps p |OP* |gen_constant_list|OP* o #if !defined(HAS_GETENV_LEN) -p |char* |getenv_len |char* key|unsigned long *len +p |char* |getenv_len |const char* key|unsigned long *len #endif Ap |void |gp_free |GV* gv Ap |GP* |gp_ref |GP* gp @@ -1523,6 +1545,7 @@ Ap |GV* |gv_autoload4 |HV* stash|const char* name|STRLEN len \ Ap |void |gv_check |HV* stash Ap |void |gv_efullname |SV* sv|GV* gv Ap |void |gv_efullname3 |SV* sv|GV* gv|const char* prefix +Ap |void |gv_efullname4 |SV* sv|GV* gv|const char* prefix|bool keepmain Ap |GV* |gv_fetchfile |const char* name Apd |GV* |gv_fetchmeth |HV* stash|const char* name|STRLEN len \ |I32 level @@ -1532,6 +1555,7 @@ Apd |GV* |gv_fetchmethod_autoload|HV* stash|const char* name \ Ap |GV* |gv_fetchpv |const char* name|I32 add|I32 sv_type Ap |void |gv_fullname |SV* sv|GV* gv Ap |void |gv_fullname3 |SV* sv|GV* gv|const char* prefix +Ap |void |gv_fullname4 |SV* sv|GV* gv|const char* prefix|bool keepmain Ap |void |gv_init |GV* gv|HV* stash|const char* name \ |STRLEN len|int multi Apd |HV* |gv_stashpv |const char* name|I32 create @@ -1567,6 +1591,7 @@ p |U32 |intro_my Ap |char* |instr |const char* big|const char* little p |bool |io_close |IO* io|bool not_implicit p |OP* |invert |OP* cmd +dp |bool |is_gv_magical |char *name|STRLEN len|U32 flags Ap |bool |is_uni_alnum |U32 c Ap |bool |is_uni_alnumc |U32 c Ap |bool |is_uni_idfirst |U32 c @@ -1602,6 +1627,7 @@ Ap |U32 |to_uni_upper_lc|U32 c Ap |U32 |to_uni_title_lc|U32 c Ap |U32 |to_uni_lower_lc|U32 c Ap |int |is_utf8_char |U8 *p +Ap |bool |is_utf8_string |U8 *s|STRLEN len Ap |bool |is_utf8_alnum |U8 *p Ap |bool |is_utf8_alnumc |U8 *p Ap |bool |is_utf8_idfirst|U8 *p @@ -1885,6 +1911,7 @@ Ap |void |save_freesv |SV* sv p |void |save_freeop |OP* o Ap |void |save_freepv |char* pv Ap |void |save_generic_svref|SV** sptr +Ap |void |save_generic_pvref|char** str Ap |void |save_gp |GV* gv|I32 empty Ap |HV* |save_hash |GV* gv Ap |void |save_helem |HV* hv|SV *key|SV **sptr @@ -1945,7 +1972,7 @@ Ap |NV |sv_nv |SV* sv Ap |char* |sv_pvn |SV *sv|STRLEN *len Ap |char* |sv_pvutf8n |SV *sv|STRLEN *len Ap |char* |sv_pvbyten |SV *sv|STRLEN *len -Ap |I32 |sv_true |SV *sv +Apd |I32 |sv_true |SV *sv p |void |sv_add_arena |char* ptr|U32 size|U32 flags Ap |int |sv_backoff |SV* sv Apd |SV* |sv_bless |SV* sv|HV* stash @@ -1957,9 +1984,9 @@ Apd |void |sv_catsv |SV* dsv|SV* ssv Apd |void |sv_chop |SV* sv|char* ptr p |void |sv_clean_all p |void |sv_clean_objs -Ap |void |sv_clear |SV* sv +Apd |void |sv_clear |SV* sv Apd |I32 |sv_cmp |SV* sv1|SV* sv2 -Ap |I32 |sv_cmp_locale |SV* sv1|SV* sv2 +Apd |I32 |sv_cmp_locale |SV* sv1|SV* sv2 #if defined(USE_LOCALE_COLLATE) Ap |char* |sv_collxfrm |SV* sv|STRLEN* nxp #endif @@ -1968,9 +1995,9 @@ Apd |void |sv_dec |SV* sv Ap |void |sv_dump |SV* sv Apd |bool |sv_derived_from|SV* sv|const char* name Apd |I32 |sv_eq |SV* sv1|SV* sv2 -Ap |void |sv_free |SV* sv +Apd |void |sv_free |SV* sv p |void |sv_free_arenas -Ap |char* |sv_gets |SV* sv|PerlIO* fp|I32 append +Apd |char* |sv_gets |SV* sv|PerlIO* fp|I32 append Apd |char* |sv_grow |SV* sv|STRLEN newlen Apd |void |sv_inc |SV* sv Apd |void |sv_insert |SV* bigsv|STRLEN offset|STRLEN len \ @@ -1978,7 +2005,7 @@ Apd |void |sv_insert |SV* bigsv|STRLEN offset|STRLEN len \ Apd |int |sv_isa |SV* sv|const char* name Apd |int |sv_isobject |SV* sv Apd |STRLEN |sv_len |SV* sv -Ap |STRLEN |sv_len_utf8 |SV* sv +Apd |STRLEN |sv_len_utf8 |SV* sv Apd |void |sv_magic |SV* sv|SV* obj|int how|const char* name \ |I32 namlen Apd |SV* |sv_mortalcopy |SV* oldsv @@ -1987,11 +2014,11 @@ Ap |SV* |sv_newref |SV* sv Ap |char* |sv_peek |SV* sv Ap |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp Ap |void |sv_pos_b2u |SV* sv|I32* offsetp -Ap |char* |sv_pvn_force |SV* sv|STRLEN* lp -Ap |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp +Apd |char* |sv_pvn_force |SV* sv|STRLEN* lp +Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp Ap |char* |sv_pvbyten_force|SV* sv|STRLEN* lp -Ap |char* |sv_reftype |SV* sv|int ob -Ap |void |sv_replace |SV* sv|SV* nsv +Apd |char* |sv_reftype |SV* sv|int ob +Apd |void |sv_replace |SV* sv|SV* nsv Ap |void |sv_report_used Ap |void |sv_reset |char* s|HV* stash Afpd |void |sv_setpvf |SV* sv|const char* pat|... @@ -2010,7 +2037,7 @@ Apd |void |sv_setpvn |SV* sv|const char* ptr|STRLEN len Apd |void |sv_setsv |SV* dsv|SV* ssv Ap |void |sv_taint |SV* sv Ap |bool |sv_tainted |SV* sv -Ap |int |sv_unmagic |SV* sv|int type +Apd |int |sv_unmagic |SV* sv|int type Apd |void |sv_unref |SV* sv Ap |void |sv_untaint |SV* sv Apd |bool |sv_upgrade |SV* sv|U32 mt @@ -2039,10 +2066,12 @@ Ap |void |unlock_condpair|void* svv Ap |void |unsharepvn |const char* sv|I32 len|U32 hash p |void |unshare_hek |HEK* hek p |void |utilize |int aver|I32 floor|OP* version|OP* id|OP* arg -Ap |U8* |utf16_to_utf8 |U16* p|U8 *d|I32 bytelen -Ap |U8* |utf16_to_utf8_reversed|U16* p|U8 *d|I32 bytelen +Ap |U8* |utf16_to_utf8 |U8* p|U8 *d|I32 bytelen|I32 *newlen +Ap |U8* |utf16_to_utf8_reversed|U8* p|U8 *d|I32 bytelen|I32 *newlen Ap |I32 |utf8_distance |U8 *a|U8 *b Ap |U8* |utf8_hop |U8 *s|I32 off +ApM |U8* |utf8_to_bytes |U8 *s|STRLEN len +ApM |U8* |bytes_to_utf8 |U8 *s|STRLEN *len Ap |UV |utf8_to_uv |U8 *s|I32* retlen Ap |U8* |uv_to_utf8 |U8 *d|UV uv p |void |vivify_defelem |SV* sv @@ -2083,6 +2112,9 @@ Ap |struct perl_vars *|GetVars #endif Ap |int |runops_standard Ap |int |runops_debug +#if defined(USE_THREADS) +Ap |SV* |sv_lock |SV *sv +#endif Afpd |void |sv_catpvf_mg |SV *sv|const char* pat|... Ap |void |sv_vcatpvf_mg |SV* sv|const char* pat|va_list* args Apd |void |sv_catpv_mg |SV *sv|const char *ptr @@ -2127,13 +2159,13 @@ Ap |char* |sv_2pvbyte_nolen|SV* sv Ap |char* |sv_pv |SV *sv Ap |char* |sv_pvutf8 |SV *sv Ap |char* |sv_pvbyte |SV *sv -Ap |void |sv_utf8_upgrade|SV *sv -Ap |bool |sv_utf8_downgrade|SV *sv|bool fail_ok -Ap |void |sv_utf8_encode |SV *sv +Apd |void |sv_utf8_upgrade|SV *sv +ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok +ApdM |void |sv_utf8_encode |SV *sv Ap |bool |sv_utf8_decode |SV *sv Ap |void |sv_force_normal|SV *sv Ap |void |tmps_grow |I32 n -Ap |SV* |sv_rvweaken |SV *sv +Apd |SV* |sv_rvweaken |SV *sv p |int |magic_killbackrefs|SV *sv|MAGIC *mg Ap |OP* |newANONATTRSUB |I32 floor|OP *proto|OP *attrs|OP *block Ap |CV* |newATTRSUB |I32 floor|OP *o|OP *proto|OP *attrs|OP *block @@ -2162,6 +2194,7 @@ Ap |void |ptr_table_store|PTR_TBL_t *tbl|void *oldsv|void *newsv Ap |void |ptr_table_split|PTR_TBL_t *tbl #endif #if defined(HAVE_INTERP_INTERN) +Ap |void |sys_intern_clear Ap |void |sys_intern_init #endif @@ -2177,16 +2210,12 @@ s |I32 |avhv_index |AV* av|SV* sv|U32 hash #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) -s |I32 |do_trans_CC_simple |SV *sv -s |I32 |do_trans_CC_count |SV *sv -s |I32 |do_trans_CC_complex |SV *sv -s |I32 |do_trans_UU_simple |SV *sv -s |I32 |do_trans_UU_count |SV *sv -s |I32 |do_trans_UU_complex |SV *sv -s |I32 |do_trans_UC_simple |SV *sv -s |I32 |do_trans_CU_simple |SV *sv -s |I32 |do_trans_UC_trivial |SV *sv -s |I32 |do_trans_CU_trivial |SV *sv +s |I32 |do_trans_simple |SV *sv +s |I32 |do_trans_count |SV *sv +s |I32 |do_trans_complex |SV *sv +s |I32 |do_trans_simple_utf8 |SV *sv +s |I32 |do_trans_count_utf8 |SV *sv +s |I32 |do_trans_complex_utf8 |SV *sv #endif #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT) @@ -2451,6 +2480,7 @@ s |char* |scan_trans |char *start s |char* |scan_word |char *s|char *dest|STRLEN destlen \ |int allow_package|STRLEN *slp s |char* |skipspace |char *s +s |char* |swallow_bom |U8 *s s |void |checkcomma |char *s|char *name|char *what s |void |force_ident |char *s|int kind s |void |incline |char *s @@ -2464,6 +2494,7 @@ s |I32 |sublex_done s |I32 |sublex_push s |I32 |sublex_start s |char * |filter_gets |SV *sv|PerlIO *fp|STRLEN append +s |HV * |find_in_my_stash|char *pkgname|I32 len s |SV* |new_constant |char *s|STRLEN len|const char *key|SV *sv \ |SV *pv|const char *type s |int |ao |int toketype diff --git a/embedvar.h b/embedvar.h index 889b4d4..10339b2 100644 --- a/embedvar.h +++ b/embedvar.h @@ -246,6 +246,7 @@ #define PL_exitlistlen (PERL_GET_INTERP->Iexitlistlen) #define PL_expect (PERL_GET_INTERP->Iexpect) #define PL_fdpid (PERL_GET_INTERP->Ifdpid) +#define PL_fdpid_mutex (PERL_GET_INTERP->Ifdpid_mutex) #define PL_filemode (PERL_GET_INTERP->Ifilemode) #define PL_forkprocess (PERL_GET_INTERP->Iforkprocess) #define PL_formfeed (PERL_GET_INTERP->Iformfeed) @@ -254,6 +255,7 @@ #define PL_gid (PERL_GET_INTERP->Igid) #define PL_glob_index (PERL_GET_INTERP->Iglob_index) #define PL_globalstash (PERL_GET_INTERP->Iglobalstash) +#define PL_he_arenaroot (PERL_GET_INTERP->Ihe_arenaroot) #define PL_he_root (PERL_GET_INTERP->Ihe_root) #define PL_hintgv (PERL_GET_INTERP->Ihintgv) #define PL_hints (PERL_GET_INTERP->Ihints) @@ -377,6 +379,7 @@ #define PL_subname (PERL_GET_INTERP->Isubname) #define PL_sv_arenaroot (PERL_GET_INTERP->Isv_arenaroot) #define PL_sv_count (PERL_GET_INTERP->Isv_count) +#define PL_sv_lock_mutex (PERL_GET_INTERP->Isv_lock_mutex) #define PL_sv_mutex (PERL_GET_INTERP->Isv_mutex) #define PL_sv_no (PERL_GET_INTERP->Isv_no) #define PL_sv_objcount (PERL_GET_INTERP->Isv_objcount) @@ -415,16 +418,27 @@ #define PL_widesyscalls (PERL_GET_INTERP->Iwidesyscalls) #define PL_xiv_arenaroot (PERL_GET_INTERP->Ixiv_arenaroot) #define PL_xiv_root (PERL_GET_INTERP->Ixiv_root) +#define PL_xnv_arenaroot (PERL_GET_INTERP->Ixnv_arenaroot) #define PL_xnv_root (PERL_GET_INTERP->Ixnv_root) +#define PL_xpv_arenaroot (PERL_GET_INTERP->Ixpv_arenaroot) #define PL_xpv_root (PERL_GET_INTERP->Ixpv_root) +#define PL_xpvav_arenaroot (PERL_GET_INTERP->Ixpvav_arenaroot) #define PL_xpvav_root (PERL_GET_INTERP->Ixpvav_root) +#define PL_xpvbm_arenaroot (PERL_GET_INTERP->Ixpvbm_arenaroot) #define PL_xpvbm_root (PERL_GET_INTERP->Ixpvbm_root) +#define PL_xpvcv_arenaroot (PERL_GET_INTERP->Ixpvcv_arenaroot) #define PL_xpvcv_root (PERL_GET_INTERP->Ixpvcv_root) +#define PL_xpvhv_arenaroot (PERL_GET_INTERP->Ixpvhv_arenaroot) #define PL_xpvhv_root (PERL_GET_INTERP->Ixpvhv_root) +#define PL_xpviv_arenaroot (PERL_GET_INTERP->Ixpviv_arenaroot) #define PL_xpviv_root (PERL_GET_INTERP->Ixpviv_root) +#define PL_xpvlv_arenaroot (PERL_GET_INTERP->Ixpvlv_arenaroot) #define PL_xpvlv_root (PERL_GET_INTERP->Ixpvlv_root) +#define PL_xpvmg_arenaroot (PERL_GET_INTERP->Ixpvmg_arenaroot) #define PL_xpvmg_root (PERL_GET_INTERP->Ixpvmg_root) +#define PL_xpvnv_arenaroot (PERL_GET_INTERP->Ixpvnv_arenaroot) #define PL_xpvnv_root (PERL_GET_INTERP->Ixpvnv_root) +#define PL_xrv_arenaroot (PERL_GET_INTERP->Ixrv_arenaroot) #define PL_xrv_root (PERL_GET_INTERP->Ixrv_root) #define PL_yychar (PERL_GET_INTERP->Iyychar) #define PL_yydebug (PERL_GET_INTERP->Iyydebug) @@ -511,6 +525,7 @@ #define PL_exitlistlen (vTHX->Iexitlistlen) #define PL_expect (vTHX->Iexpect) #define PL_fdpid (vTHX->Ifdpid) +#define PL_fdpid_mutex (vTHX->Ifdpid_mutex) #define PL_filemode (vTHX->Ifilemode) #define PL_forkprocess (vTHX->Iforkprocess) #define PL_formfeed (vTHX->Iformfeed) @@ -519,6 +534,7 @@ #define PL_gid (vTHX->Igid) #define PL_glob_index (vTHX->Iglob_index) #define PL_globalstash (vTHX->Iglobalstash) +#define PL_he_arenaroot (vTHX->Ihe_arenaroot) #define PL_he_root (vTHX->Ihe_root) #define PL_hintgv (vTHX->Ihintgv) #define PL_hints (vTHX->Ihints) @@ -642,6 +658,7 @@ #define PL_subname (vTHX->Isubname) #define PL_sv_arenaroot (vTHX->Isv_arenaroot) #define PL_sv_count (vTHX->Isv_count) +#define PL_sv_lock_mutex (vTHX->Isv_lock_mutex) #define PL_sv_mutex (vTHX->Isv_mutex) #define PL_sv_no (vTHX->Isv_no) #define PL_sv_objcount (vTHX->Isv_objcount) @@ -680,16 +697,27 @@ #define PL_widesyscalls (vTHX->Iwidesyscalls) #define PL_xiv_arenaroot (vTHX->Ixiv_arenaroot) #define PL_xiv_root (vTHX->Ixiv_root) +#define PL_xnv_arenaroot (vTHX->Ixnv_arenaroot) #define PL_xnv_root (vTHX->Ixnv_root) +#define PL_xpv_arenaroot (vTHX->Ixpv_arenaroot) #define PL_xpv_root (vTHX->Ixpv_root) +#define PL_xpvav_arenaroot (vTHX->Ixpvav_arenaroot) #define PL_xpvav_root (vTHX->Ixpvav_root) +#define PL_xpvbm_arenaroot (vTHX->Ixpvbm_arenaroot) #define PL_xpvbm_root (vTHX->Ixpvbm_root) +#define PL_xpvcv_arenaroot (vTHX->Ixpvcv_arenaroot) #define PL_xpvcv_root (vTHX->Ixpvcv_root) +#define PL_xpvhv_arenaroot (vTHX->Ixpvhv_arenaroot) #define PL_xpvhv_root (vTHX->Ixpvhv_root) +#define PL_xpviv_arenaroot (vTHX->Ixpviv_arenaroot) #define PL_xpviv_root (vTHX->Ixpviv_root) +#define PL_xpvlv_arenaroot (vTHX->Ixpvlv_arenaroot) #define PL_xpvlv_root (vTHX->Ixpvlv_root) +#define PL_xpvmg_arenaroot (vTHX->Ixpvmg_arenaroot) #define PL_xpvmg_root (vTHX->Ixpvmg_root) +#define PL_xpvnv_arenaroot (vTHX->Ixpvnv_arenaroot) #define PL_xpvnv_root (vTHX->Ixpvnv_root) +#define PL_xrv_arenaroot (vTHX->Ixrv_arenaroot) #define PL_xrv_root (vTHX->Ixrv_root) #define PL_yychar (vTHX->Iyychar) #define PL_yydebug (vTHX->Iyydebug) @@ -913,6 +941,7 @@ #define PL_exitlistlen (aTHXo->interp.Iexitlistlen) #define PL_expect (aTHXo->interp.Iexpect) #define PL_fdpid (aTHXo->interp.Ifdpid) +#define PL_fdpid_mutex (aTHXo->interp.Ifdpid_mutex) #define PL_filemode (aTHXo->interp.Ifilemode) #define PL_forkprocess (aTHXo->interp.Iforkprocess) #define PL_formfeed (aTHXo->interp.Iformfeed) @@ -921,6 +950,7 @@ #define PL_gid (aTHXo->interp.Igid) #define PL_glob_index (aTHXo->interp.Iglob_index) #define PL_globalstash (aTHXo->interp.Iglobalstash) +#define PL_he_arenaroot (aTHXo->interp.Ihe_arenaroot) #define PL_he_root (aTHXo->interp.Ihe_root) #define PL_hintgv (aTHXo->interp.Ihintgv) #define PL_hints (aTHXo->interp.Ihints) @@ -1044,6 +1074,7 @@ #define PL_subname (aTHXo->interp.Isubname) #define PL_sv_arenaroot (aTHXo->interp.Isv_arenaroot) #define PL_sv_count (aTHXo->interp.Isv_count) +#define PL_sv_lock_mutex (aTHXo->interp.Isv_lock_mutex) #define PL_sv_mutex (aTHXo->interp.Isv_mutex) #define PL_sv_no (aTHXo->interp.Isv_no) #define PL_sv_objcount (aTHXo->interp.Isv_objcount) @@ -1082,16 +1113,27 @@ #define PL_widesyscalls (aTHXo->interp.Iwidesyscalls) #define PL_xiv_arenaroot (aTHXo->interp.Ixiv_arenaroot) #define PL_xiv_root (aTHXo->interp.Ixiv_root) +#define PL_xnv_arenaroot (aTHXo->interp.Ixnv_arenaroot) #define PL_xnv_root (aTHXo->interp.Ixnv_root) +#define PL_xpv_arenaroot (aTHXo->interp.Ixpv_arenaroot) #define PL_xpv_root (aTHXo->interp.Ixpv_root) +#define PL_xpvav_arenaroot (aTHXo->interp.Ixpvav_arenaroot) #define PL_xpvav_root (aTHXo->interp.Ixpvav_root) +#define PL_xpvbm_arenaroot (aTHXo->interp.Ixpvbm_arenaroot) #define PL_xpvbm_root (aTHXo->interp.Ixpvbm_root) +#define PL_xpvcv_arenaroot (aTHXo->interp.Ixpvcv_arenaroot) #define PL_xpvcv_root (aTHXo->interp.Ixpvcv_root) +#define PL_xpvhv_arenaroot (aTHXo->interp.Ixpvhv_arenaroot) #define PL_xpvhv_root (aTHXo->interp.Ixpvhv_root) +#define PL_xpviv_arenaroot (aTHXo->interp.Ixpviv_arenaroot) #define PL_xpviv_root (aTHXo->interp.Ixpviv_root) +#define PL_xpvlv_arenaroot (aTHXo->interp.Ixpvlv_arenaroot) #define PL_xpvlv_root (aTHXo->interp.Ixpvlv_root) +#define PL_xpvmg_arenaroot (aTHXo->interp.Ixpvmg_arenaroot) #define PL_xpvmg_root (aTHXo->interp.Ixpvmg_root) +#define PL_xpvnv_arenaroot (aTHXo->interp.Ixpvnv_arenaroot) #define PL_xpvnv_root (aTHXo->interp.Ixpvnv_root) +#define PL_xrv_arenaroot (aTHXo->interp.Ixrv_arenaroot) #define PL_xrv_root (aTHXo->interp.Ixrv_root) #define PL_yychar (aTHXo->interp.Iyychar) #define PL_yydebug (aTHXo->interp.Iyydebug) @@ -1179,6 +1221,7 @@ #define PL_Iexitlistlen PL_exitlistlen #define PL_Iexpect PL_expect #define PL_Ifdpid PL_fdpid +#define PL_Ifdpid_mutex PL_fdpid_mutex #define PL_Ifilemode PL_filemode #define PL_Iforkprocess PL_forkprocess #define PL_Iformfeed PL_formfeed @@ -1187,6 +1230,7 @@ #define PL_Igid PL_gid #define PL_Iglob_index PL_glob_index #define PL_Iglobalstash PL_globalstash +#define PL_Ihe_arenaroot PL_he_arenaroot #define PL_Ihe_root PL_he_root #define PL_Ihintgv PL_hintgv #define PL_Ihints PL_hints @@ -1310,6 +1354,7 @@ #define PL_Isubname PL_subname #define PL_Isv_arenaroot PL_sv_arenaroot #define PL_Isv_count PL_sv_count +#define PL_Isv_lock_mutex PL_sv_lock_mutex #define PL_Isv_mutex PL_sv_mutex #define PL_Isv_no PL_sv_no #define PL_Isv_objcount PL_sv_objcount @@ -1348,16 +1393,27 @@ #define PL_Iwidesyscalls PL_widesyscalls #define PL_Ixiv_arenaroot PL_xiv_arenaroot #define PL_Ixiv_root PL_xiv_root +#define PL_Ixnv_arenaroot PL_xnv_arenaroot #define PL_Ixnv_root PL_xnv_root +#define PL_Ixpv_arenaroot PL_xpv_arenaroot #define PL_Ixpv_root PL_xpv_root +#define PL_Ixpvav_arenaroot PL_xpvav_arenaroot #define PL_Ixpvav_root PL_xpvav_root +#define PL_Ixpvbm_arenaroot PL_xpvbm_arenaroot #define PL_Ixpvbm_root PL_xpvbm_root +#define PL_Ixpvcv_arenaroot PL_xpvcv_arenaroot #define PL_Ixpvcv_root PL_xpvcv_root +#define PL_Ixpvhv_arenaroot PL_xpvhv_arenaroot #define PL_Ixpvhv_root PL_xpvhv_root +#define PL_Ixpviv_arenaroot PL_xpviv_arenaroot #define PL_Ixpviv_root PL_xpviv_root +#define PL_Ixpvlv_arenaroot PL_xpvlv_arenaroot #define PL_Ixpvlv_root PL_xpvlv_root +#define PL_Ixpvmg_arenaroot PL_xpvmg_arenaroot #define PL_Ixpvmg_root PL_xpvmg_root +#define PL_Ixpvnv_arenaroot PL_xpvnv_arenaroot #define PL_Ixpvnv_root PL_xpvnv_root +#define PL_Ixrv_arenaroot PL_xrv_arenaroot #define PL_Ixrv_root PL_xrv_root #define PL_Iyychar PL_yychar #define PL_Iyydebug PL_yydebug diff --git a/epoc/config.sh b/epoc/config.sh index 714185a..5b37e3a 100644 --- a/epoc/config.sh +++ b/epoc/config.sh @@ -79,7 +79,7 @@ cppsymbols='' crosscompile='define' cryptlib='' csh='csh' -d_Gconvert='sprintf((b),"%.*g",(n),(x))' +d_Gconvert='epoc_gcvt((x),(n),(b))' d_PRIEldbl='undef' d_PRIFldbl='undef' d_PRIGldbl='undef' @@ -134,7 +134,6 @@ d_endnent='undef' d_endpent='undef' d_endpwent='undef' d_endsent='undef' -d_endspent='undef' d_eofnblk='define' d_eunice='undef' d_fchmod='undef' @@ -156,6 +155,7 @@ d_fstatfs='define' d_fstatvfs='undef' d_ftello='undef' d_ftime='undef' +d_getespwnam='undef' d_getfsstat='undef' d_getgrent='undef' d_getgrps='undef' @@ -179,12 +179,12 @@ d_getpgrp='undef' d_getppid='undef' d_getprior='undef' d_getprotoprotos='define' +d_getprpwnam='undef' d_getpwent='undef' d_getsbyname='undef' d_getsbyport='undef' d_getsent='undef' d_getservprotos='define' -d_getspent='undef' d_getspnam='undef' d_gettimeod='define' d_gnulibc='undef' @@ -194,7 +194,7 @@ d_htonl='define' d_iconv='undef' d_index='undef' d_inetaton='define' -d_int64t='undef' +d_int64_t='undef' d_iovec_s='undef' d_isascii='define' d_isnan='define' @@ -305,7 +305,6 @@ d_setrgid='undef' d_setruid='undef' d_setsent='undef' d_setsid='undef' -d_setspent='undef' d_setvbuf='undef' d_sfio='undef' d_shm='undef' @@ -386,7 +385,7 @@ emacs='' eunicefix=':' exe_ext='' expr='expr' -extensions='Data/Dumper File/Glob IO Socket' +extensions='Data/Dumper File/Glob IO Socket Fcntl' fflushNULL='undef' fflushall='define' find='' @@ -436,6 +435,7 @@ i_neterrno='undef' i_netinettcp='define' i_niin='define' i_poll='undef' +i_prot='undef' i_pthread='undef' i_pwd='undef' i_rpcsvcdbm='undef' @@ -497,7 +497,7 @@ installstyle='' installusrbinperl='undef' installvendorlib='' intsize='4' -known_extensions='Data/Dumper File/Glob IO Socket' +known_extensions='Data/Dumper File/Glob IO Socket Fcntl' ksh='' large='' ld='echo' @@ -645,7 +645,7 @@ sleep='' smail='' small='' so='' -socksizetype='int' +socksizetype='size_t' sockethdr='' socketlib='' sort='sort' @@ -656,7 +656,7 @@ src='.' ssizetype='long' startperl='' startsh='#!/bin/sh' -static_ext='Data/Dumper File/Glob IO Socket' +static_ext='Data/Dumper File/Glob IO Socket Fcntl' stdchar='char' stdio_base='' stdio_bufsiz='' @@ -789,7 +789,164 @@ d_strtold='undef' d_strtoll='undef' d_strtouq='undef' d_nv_preserves_uv='define' +d_nv_preserves_uv_bits='32' +use5005threads='undef' +useithreads='undef' +inc_version_list=' ' +inc_version_list_init='0' +d_madvise='undef' +d_mkdtemp='undef' +d_mkstemp='undef' +d_mkstemps='undef' +d_mmap='undef' +d_mprotect='undef' +d_msync='undef' +d_munmap='undef' +d_qgcvt='undef' +d_socklen_t='undef' +d_vendorarch='' +i_iconv='undef' +i_ieeefp='undef' +i_sunmath='undef' +i_syslog='undef' +i_sysmman='undef' +i_sysutsname='undef' +installvendorarch='' +mmaptype='' +revision='5' +sizesize='4' +socksizetype='int' + +double='undef' +usemorebits='undef' +usemultiplicity='undef' +usemymalloc='n' +usenm='' +useopcode='' +useperlio='undef' +useposix='' +usesfio='' +useshrplib='' +usesocks='undef' +usethreads='undef' +usevendorprefix='' +usevfork='' +usrinc='' +uuname='' +vendorlib='' +vendorlib_stem='' +vendorlibexp='' +vendorprefix='' +vendorprefixexp='' +version='5.6.0' +vi='' +voidflags='15' +xlibpth='' +zcat='' +zip='' +# Configure command line arguments. +config_arg0='' +config_args='' +config_argc=11 +config_arg1='' +config_arg2='' +config_arg3='' +config_arg4='' +config_arg5='' +config_arg6='' +config_arg7='' +config_arg8='' +config_arg9='' +config_arg10='' +config_arg11='' +PERL_REVISION=5 +PERL_VERSION=6 +PERL_SUBVERSION=0 +PERL_API_REVISION=5 +PERL_API_VERSION=6 +PERL_API_SUBVERSION=0 +CONFIGDOTSH=true +# Variables propagated from previous config.sh file. +pp_sys_cflags='' +epocish_cflags='ccflags="$cflags -xc++"' +ivtype='int' +uvtype='unsigned int' +i8type='char' +u8type='unsigned char' +i16type='short' +u16type='unsigned short' +i32type='int' +u32type='unsigned int' +i64type='long long' +u64type='unsigned long long' +d_quad='define' +quadtype='long long' +quadtype='unsigned long long' +quadkind='QUAD_IS_LONG_LONG' +nvtype='double' +ivsize='4' +uvsize='4' +i8size='1' +u8size='1' +i16size='2' +u16size='2' +i32size='4' +u32size='4' +i64size='8' +u64size='8' +d_fs_data_s='undef' +d_fseeko='undef' +d_ldbl_dig='undef' +d_sqrtl='undef' +d_getmnt='undef' +d_statfs_f_flags='undef' +d_statfs_s='undef' +d_ustat='undef' +i_sysstatfs='undef' +i_sysvfs='undef' +i_ustat='undef' +uidsize='2' +uidsign='1' +gidsize='2' +gidsign='1' +ivdformat='"ld"' +uvuformat='"lu"' +uvoformat='"lo"' +uvxformat='"lx"' +uidformat='"hu"' +gidformat='"hu"' +d_strtold='undef' +d_strtoll='undef' +d_strtouq='undef' +d_nv_preserves_uv='define' use5005threads='undef' useithreads='undef' inc_version_list=' ' inc_version_list_init='0' +d_madvise='undef' +d_mkdtemp='undef' +d_mkstemp='undef' +d_mkstemps='undef' +d_mmap='undef' +d_mprotect='undef' +d_msync='undef' +d_munmap='undef' +d_qgcvt='undef' +d_socklen_t='undef' +d_vendorarch='' +i_iconv='undef' +i_ieeefp='undef' +i_sunmath='undef' +i_syslog='undef' +i_sysmman='undef' +i_sysutsname='undef' +installvendorarch='' +mmaptype='' +revision='5' +sizesize='4' +socksizetype='int' +xs_apiversion='5.005' +d_getcwd='define' +i_sysmode='undef' +d_vendorarch='undef' + diff --git a/epoc/createpkg.pl b/epoc/createpkg.pl index 6977bd3..77dafb1 100644 --- a/epoc/createpkg.pl +++ b/epoc/createpkg.pl @@ -3,11 +3,11 @@ use File::Find; use Cwd; -$VERSION="5.5"; -$PATCH="650"; -$EPOC_VERSION=19; +$VERSION="5.6"; +$PATCH="0"; +$EPOC_VERSION=20; $CROSSCOMPILEPATH=cwd; -$CROSSREPLACEPATH="H:\\devel\\perl5.5.650"; +$CROSSREPLACEPATH="H:\\perl"; sub filefound { diff --git a/epoc/epocish.c b/epoc/epocish.c index 134eaef..4963a2e5 100644 --- a/epoc/epocish.c +++ b/epoc/epocish.c @@ -6,7 +6,7 @@ * */ -/* This is indeed C++ Code !! */ +/* This is C++ Code !! */ #include @@ -31,4 +31,25 @@ epoc_spawn( char *cmd, char *cmdline) { return 0; } + + /* Workaround for defect atof(), see java defect list for epoc */ + double epoc_atof( const char* str) { + TReal64 aRes; + + TLex lex( _L( str)); + TInt err = lex.Val( aRes, TChar( '.')); + return aRes; + } + + void epoc_gcvt( double x, int digits, unsigned char *buf) { + TRealFormat trel; + + trel.iPlaces = digits; + trel.iPoint = TChar( '.'); + + TPtr result( buf, 80); + + result.Num( x, trel); + result.Append( TChar( 0)); + } } diff --git a/epoc/epocish.h b/epoc/epocish.h index f4be0ff..75a64fc 100644 --- a/epoc/epocish.h +++ b/epoc/epocish.h @@ -121,9 +121,6 @@ /* getsockname returns the size of struct sockaddr_in *without* padding */ #define BOGUS_GETNAME_RETURN 8 -/* Yes, size_t is size_t */ -#define Sock_size_t size_t - /* read() on a socket blocks until buf is filled completly, recv() returns each massage @@ -133,3 +130,13 @@ /* No /dev/random available*/ #define PERL_NO_DEV_RANDOM + +/* + work around for buggy atof(): + atof() in ER5 stdlib depends on locale. +*/ + +double epoc_atof( const char *ptr); +#define atof(a) epoc_atof(a) + + diff --git a/ext/B/B/Stash.pm b/ext/B/B/Stash.pm index b9b828f..f3a8247 100644 --- a/ext/B/B/Stash.pm +++ b/ext/B/B/Stash.pm @@ -2,6 +2,14 @@ # vishalb@hotmail.com package B::Stash; +=pod + +=head1 NAME + +B::Stash - show what stashes are loaded + +=cut + BEGIN { %Seen = %INC } CHECK { diff --git a/ext/DB_File/Makefile.PL b/ext/DB_File/Makefile.PL index cac6578..0414160 100644 --- a/ext/DB_File/Makefile.PL +++ b/ext/DB_File/Makefile.PL @@ -17,6 +17,7 @@ WriteMakefile( OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', XSPROTOARG => '-noprototypes', DEFINE => $OS2 || "", + INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") ); sub MY::postamble { diff --git a/ext/Data/Dumper/Dumper.xs b/ext/Data/Dumper/Dumper.xs index bb606f4..d3cf292 100644 --- a/ext/Data/Dumper/Dumper.xs +++ b/ext/Data/Dumper/Dumper.xs @@ -584,7 +584,10 @@ DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv, if (SvIOK(val)) { STRLEN len; - (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); + if (SvIsUV(val)) + (void) sprintf(tmpbuf, "%"UVuf, SvUV(val)); + else + (void) sprintf(tmpbuf, "%"IVdf, SvIV(val)); len = strlen(tmpbuf); sv_catpvn(retval, tmpbuf, len); } diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index 31e984f..7167a00 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -502,7 +502,7 @@ prof_record(pTHX) static void check_depth(pTHX_ void *foo) { - U32 need_depth = (U32)foo; + U32 need_depth = PTR2UV(foo); if (need_depth != g_depth) { if (need_depth > g_depth) { warn("garbled call depth when profiling"); diff --git a/ext/Devel/Peek/Peek.pm b/ext/Devel/Peek/Peek.pm index 080251b..101adcd 100644 --- a/ext/Devel/Peek/Peek.pm +++ b/ext/Devel/Peek/Peek.pm @@ -58,11 +58,11 @@ C. Devel::Peek also supplies C, C, and C which can query, increment, and decrement reference counts on SVs. This document will take a passive, and safe, approach to data debugging and for that it will describe only the C -function. For format of output of mstats() see +function. For more information on the format of output of mstat() see L>. Function C allows dumping of multiple values (useful when you -need to analize returns of functions). +need to analyze returns of functions). The global variable $Devel::Peek::pv_limit can be set to limit the number of character printed in various string values. Setting it to 0 diff --git a/ext/DynaLoader/DynaLoader_pm.PL b/ext/DynaLoader/DynaLoader_pm.PL index 55b8eca..b7b45d8 100644 --- a/ext/DynaLoader/DynaLoader_pm.PL +++ b/ext/DynaLoader/DynaLoader_pm.PL @@ -21,7 +21,7 @@ package DynaLoader; # feast like to keep their secret; for wonder makes the words of # praise louder.' -# (Quote from Tolkien sugested by Anno Siegel.) +# (Quote from Tolkien suggested by Anno Siegel.) # # See pod text at end of file for documentation. # See also ext/DynaLoader/README in source tree for other information. @@ -170,8 +170,8 @@ sub bootstrap { print STDERR "DynaLoader::bootstrap for $module ", ($Is_MacOS - ? "(auto/$modpname/$modfname.$dl_dlext)\n" : - "(:auto:$modpname:$modfname.$dl_dlext)\n") + ? "(:auto:$modpname:$modfname.$dl_dlext)\n" : + "(auto/$modpname/$modfname.$dl_dlext)\n") if $dl_debug; foreach (@INC) { diff --git a/ext/DynaLoader/dl_mac.xs b/ext/DynaLoader/dl_mac.xs new file mode 100644 index 0000000..136e6d5 --- /dev/null +++ b/ext/DynaLoader/dl_mac.xs @@ -0,0 +1,137 @@ +/* dl_mac.xs + * + * Platform: Macintosh CFM + * Author: Matthias Neeracher + * Adapted from dl_dlopen.xs reference implementation by + * Paul Marquess (pmarquess@bfsec.bt.co.uk) + * $Log: dl_mac.xs,v $ + * Revision 1.3 1998/04/07 01:47:24 neeri + * MacPerl 5.2.0r4b1 + * + * Revision 1.2 1997/08/08 16:39:18 neeri + * MacPerl 5.1.4b1 + time() fix + * + * Revision 1.1 1997/04/07 20:48:23 neeri + * Synchronized with MacPerl 5.1.4a1 + * + */ + +#define MAC_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include + + +#include "dlutils.c" /* SaveError() etc */ + +typedef CFragConnectionID ConnectionID; + +static ConnectionID ** connections; + +static void terminate(void) +{ + int size = GetHandleSize((Handle) connections) / sizeof(ConnectionID); + HLock((Handle) connections); + while (size) + CloseConnection(*connections + --size); + DisposeHandle((Handle) connections); + connections = nil; +} + +static void +dl_private_init(pTHX) +{ + (void)dl_generic_private_init(aTHX); +} + +MODULE = DynaLoader PACKAGE = DynaLoader + +BOOT: + (void)dl_private_init(aTHX); + + +ConnectionID +dl_load_file(filename, flags=0) + char * filename + int flags + PREINIT: + OSErr err; + FSSpec spec; + ConnectionID connID; + Ptr mainAddr; + Str255 errName; + CODE: + DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename)); + err = GUSIPath2FSp(filename, &spec); + if (!err) + err = + GetDiskFragment( + &spec, 0, 0, spec.name, kLoadCFrag, &connID, &mainAddr, errName); + if (!err) { + if (!connections) { + connections = (ConnectionID **)NewHandle(0); + atexit(terminate); + } + PtrAndHand((Ptr) &connID, (Handle) connections, sizeof(ConnectionID)); + RETVAL = connID; + } else + RETVAL = (ConnectionID) 0; + DLDEBUG(2,fprintf(stderr," libref=%d\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (err) + SaveError(aTHX_ "DynaLoader error [%d, %#s]", err, errName) ; + else + sv_setiv( ST(0), (IV)RETVAL); + +void * +dl_find_symbol(connID, symbol) + ConnectionID connID + Str255 symbol + CODE: + { + OSErr err; + Ptr symAddr; + CFragSymbolClass symClass; + DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%#s)\n", + connID, symbol)); + err = FindSymbol(connID, symbol, &symAddr, &symClass); + if (err) + symAddr = (Ptr) 0; + RETVAL = (void *) symAddr; + DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL)); + ST(0) = sv_newmortal() ; + if (err) + SaveError(aTHX_ "DynaLoader error [%d]!", err) ; + else + sv_setiv( ST(0), (IV)RETVAL); + } + +void +dl_undef_symbols() + PPCODE: + + + +# These functions should not need changing on any platform: + +void +dl_install_xsub(perl_name, symref, filename="$Package") + char * perl_name + 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))); + + +char * +dl_error() + CODE: + RETVAL = LastError ; + OUTPUT: + RETVAL + +# end. diff --git a/ext/DynaLoader/hints/netbsd.pl b/ext/DynaLoader/hints/netbsd.pl new file mode 100644 index 0000000..a0fbaf7 --- /dev/null +++ b/ext/DynaLoader/hints/netbsd.pl @@ -0,0 +1,3 @@ +# XXX Configure test needed? +# Some NetBSDs seem to have a dlopen() that won't accept relative paths +$self->{CCFLAGS} = $Config{ccflags} . ' -DDLOPEN_WONT_DO_RELATIVE_PATHS'; diff --git a/ext/File/Glob/Glob.pm b/ext/File/Glob/Glob.pm index 98ee34d..57bfa0d 100644 --- a/ext/File/Glob/Glob.pm +++ b/ext/File/Glob/Glob.pm @@ -138,6 +138,9 @@ sub csh_glob { $pat = $_ unless defined $pat; # extract patterns + $pat =~ s/^\s+//; # Protect against empty elements in + $pat =~ s/\s+$//; # things like < *.c> and <*.c >. + # These alone shouldn't trigger ParseWords. if ($pat =~ /\s/) { # XXX this is needed for compatibility with the csh # implementation in Perl. Need to support a flag diff --git a/ext/IPC/SysV/Makefile.PL b/ext/IPC/SysV/Makefile.PL index 60dd74d..f994950 100644 --- a/ext/IPC/SysV/Makefile.PL +++ b/ext/IPC/SysV/Makefile.PL @@ -31,7 +31,7 @@ WriteMakefile( 'clean' => {FILES => join(" ", map { "$_ */$_ */*/$_" } - qw(*% *.html *.b[ac]k *.old *.orig)) + qw(*% *.html *.b[ac]k *.old)) }, 'macro' => { INSTALLDIRS => 'perl' }, ); diff --git a/ext/NDBM_File/Makefile.PL b/ext/NDBM_File/Makefile.PL index 6ceab55..7b58601 100644 --- a/ext/NDBM_File/Makefile.PL +++ b/ext/NDBM_File/Makefile.PL @@ -5,4 +5,5 @@ WriteMakefile( MAN3PODS => {}, # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'NDBM_File.pm', + INC => ($^O eq "MacOS" ? "-i ::::db:include" : "") ); diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 581cbc9..e191ec7 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -250,7 +250,7 @@ PPCODE: save_aptr(&PL_endav); PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */ - save_hptr(&PL_defstash); /* save current default stack */ + save_hptr(&PL_defstash); /* save current default stash */ /* the assignment to global defstash changes our sense of 'main' */ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ save_hptr(&PL_curstash); @@ -263,6 +263,10 @@ PPCODE: sv_free((SV*)GvHV(gv)); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); + /* %INC must be clean for use/require in compartment */ + save_hash(PL_incgv); + GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV)))); + PUSHMARK(SP); perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */ SPAGAIN; /* for the PUTBACK added by xsubpp */ diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index 9416f70..252e5bb 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -565,9 +565,9 @@ sub chmod { sub fstat { usage "fstat(fd)" if @_ != 1; local *TMP; - open(TMP, "<&$_[0]"); # Gross. + CORE::open(TMP, "<&$_[0]"); # Gross. my @l = CORE::stat(TMP); - close(TMP); + CORE::close(TMP); @l; } @@ -893,7 +893,7 @@ sub load_imports { difftime mktime strftime tzset tzname)], unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET - STRERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK + STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index 08300e4..314147c 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -65,15 +65,19 @@ all. This could be construed to be a bug. =item _exit -This is identical to the C function C<_exit()>. +This is identical to the C function C<_exit()>. It exits the program +immediately which means among other things buffered I/O is B flushed. =item abort -This is identical to the C function C. +This is identical to the C function C. It terminates the +process with a C signal unless caught by a signal handler or +if the handler does not return normally (it e.g. does a C). =item abs -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, returning +the absolute value of its numerical argument. =item access @@ -83,83 +87,117 @@ Determines the accessibility of a file. print "have read permission\n"; } -Returns C on failure. +Returns C on failure. Note: do not use C for +security purposes. Between the C call and the operation +you are preparing for the permissions might change: a classic +I. =item acos -This is identical to the C function C. +This is identical to the C function C, returning +the arcus cosine of its numerical argument. See also L. =item alarm -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, +either for arming or disarming the C timer. =item asctime -This is identical to the C function C. +This is identical to the C function C. It returns +a string of the form + + "Fri Jun 2 18:22:13 2000\n\0" + +and it is called thusly + + $asctime = asctime($sec, $min, $hour, $mday, $mon, $year, + $wday, $yday, $isdst); + +The C<$mon> is zero-based: January equals C<0>. The C<$year> is +1900-based: 2001 equals C<101>. The C<$wday>, C<$yday>, and C<$isdst> +default to zero (and the first two are usually ignored anyway). =item asin -This is identical to the C function C. +This is identical to the C function C, returning +the arcus sine of its numerical argument. See also L. =item assert -Unimplemented. +Unimplemented, but you can use L and the L module +to achieve similar things. =item atan -This is identical to the C function C. +This is identical to the C function C, returning the +arcus tangent of its numerical argument. See also L. =item atan2 -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, returning +the arcus tangent defined by its two numerical arguments, the I +coordinate and the I coordinate. See also L. =item atexit -atexit() is C-specific: use END {} instead. +atexit() is C-specific: use C instead, see L. =item atof -atof() is C-specific. +atof() is C-specific. Perl converts strings to numbers transparently. +If you need to force a scalar to a number, add a zero to it. =item atoi -atoi() is C-specific. +atoi() is C-specific. Perl converts strings to numbers transparently. +If you need to force a scalar to a number, add a zero to it. +If you need to have just the integer part, see L. =item atol -atol() is C-specific. +atol() is C-specific. Perl converts strings to numbers transparently. +If you need to force a scalar to a number, add a zero to it. +If you need to have just the integer part, see L. =item bsearch -bsearch() not supplied. +bsearch() not supplied. For doing binary search on wordlists, +see L. =item calloc -calloc() is C-specific. +calloc() is C-specific. Perl does memory management transparently. =item ceil -This is identical to the C function C. +This is identical to the C function C, returning the smallest +integer value greater than or equal to the given numerical argument. =item chdir -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, allowing +one to change the working (default) directory, see L. =item chmod -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, allowing +one to change file and directory permissions, see L. =item chown -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, allowing one +to change file and directory owners and groups, see L. =item clearerr -Use method C instead. +Use the method L instead, to reset the error +state (if any) and EOF state (if any) of the given stream. =item clock -This is identical to the C function C. +This is identical to the C function C, returning the +amount of spent processor time in microseconds. =item close @@ -171,17 +209,23 @@ C. Returns C on failure. +See also L. + =item closedir -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for closing +a directory handle, see L. =item cos -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, for returning +the cosine of its numerical argument, see L. +See also L. =item cosh -This is identical to the C function C. +This is identical to the C function C, for returning +the hyperbolic cosine of its numeric argument. See also L. =item creat @@ -191,6 +235,8 @@ C. Use C to close the file. $fd = POSIX::creat( "foo", 0611 ); POSIX::close( $fd ); +See also L and its C flag. + =item ctermid Generates the path name for the controlling terminal. @@ -199,25 +245,30 @@ Generates the path name for the controlling terminal. =item ctime -This is identical to the C function C. +This is identical to the C function C and equivalent +to C, see L and L. =item cuserid -Get the character login name of the user. +Get the login name of the owner of the current process. $name = POSIX::cuserid(); =item difftime -This is identical to the C function C. +This is identical to the C function C, for returning +the time difference (in seconds) between two times (as returned +by C), see L. =item div -div() is C-specific. +div() is C-specific, use L on the usual C division and +the modulus C<%>. =item dup -This is similar to the C function C. +This is similar to the C function C, for duplicating a file +descriptor. This uses file descriptors such as those obtained by calling C. @@ -226,7 +277,8 @@ Returns C on failure. =item dup2 -This is similar to the C function C. +This is similar to the C function C, for duplicating a file +descriptor to an another known file descriptor. This uses file descriptors such as those obtained by calling C. @@ -239,57 +291,64 @@ Returns the value of errno. $errno = POSIX::errno(); +This identical to the numerical values of the C<$!>, see L. + =item execl -execl() is C-specific. +execl() is C-specific, see L. =item execle -execle() is C-specific. +execle() is C-specific, see L. =item execlp -execlp() is C-specific. +execlp() is C-specific, see L. =item execv -execv() is C-specific. +execv() is C-specific, see L. =item execve -execve() is C-specific. +execve() is C-specific, see L. =item execvp -execvp() is C-specific. +execvp() is C-specific, see L. =item exit -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for exiting the +program, see L. =item exp -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +returning the exponent (I-based) of the numerical argument, +see L. =item fabs -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for returning +the absolute value of the numerical argument, see L. =item fclose -Use method C instead. +Use method C instead, or see L. =item fcntl -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, +see L. =item fdopen -Use method C instead. +Use method C instead, or see L. =item feof -Use method C instead. +Use method C instead, or see L. =item ferror @@ -298,38 +357,49 @@ Use method C instead. =item fflush Use method C instead. +See also L. =item fgetc -Use method C instead. +Use method C instead, or see L. =item fgetpos -Use method C instead. +Use method C instead, or see L. =item fgets -Use method C instead. +Use method C instead. Similar to EE, also known +as L. =item fileno -Use method C instead. +Use method C instead, or see L. =item floor -This is identical to the C function C. +This is identical to the C function C, returning the largest +integer value less than or equal to the numerical argument. =item fmod This is identical to the C function C. + $r = modf($x, $y); + +It returns the remainder C<$r = $x - $n*$y>, where C<$n = trunc($x/$y)>. +The C<$r> has the same sign as C<$x> and magnitude (absolute value) +less than the magnitude of C<$y>. + =item fopen -Use method C instead. +Use method C instead, or see L. =item fork -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for duplicating the current process, see L +and L if you are in Windows. =item fpathconf @@ -346,45 +416,45 @@ Returns C on failure. =item fprintf -fprintf() is C-specific--use printf instead. +fprintf() is C-specific, see L instead. =item fputc -fputc() is C-specific--use print instead. +fputc() is C-specific, see L instead. =item fputs -fputs() is C-specific--use print instead. +fputs() is C-specific, see L instead. =item fread -fread() is C-specific--use read instead. +fread() is C-specific, see L instead. =item free -free() is C-specific. +free() is C-specific. Perl does memory management transparently. =item freopen -freopen() is C-specific--use open instead. +freopen() is C-specific, see L instead. =item frexp Return the mantissa and exponent of a floating-point number. - ($mantissa, $exponent) = POSIX::frexp( 3.14 ); + ($mantissa, $exponent) = POSIX::frexp( 1.234e56 ); =item fscanf -fscanf() is C-specific--use <> and regular expressions instead. +fscanf() is C-specific, use EE and regular expressions instead. =item fseek -Use method C instead. +Use method C instead, or see L. =item fsetpos -Use method C instead. +Use method C instead, or seek L. =item fstat @@ -397,174 +467,221 @@ Perl's builtin C function. =item ftell -Use method C instead. +Use method C instead, or see L. =item fwrite -fwrite() is C-specific--use print instead. +fwrite() is C-specific, see L instead. =item getc -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, +see L. =item getchar -Returns one character from STDIN. +Returns one character from STDIN. Identical to Perl's C, +see L. =item getcwd Returns the name of the current working directory. +See also L. =item getegid -Returns the effective group id. +Returns the effective group identifier. Similar to Perl' s builtin +variable C<$(>, see L. =item getenv Returns the value of the specified enironment variable. +The same information is available through the C<%ENV> array. =item geteuid -Returns the effective user id. +Returns the effective user identifier. Identical to Perl's builtin C<$E> +variable, see L. =item getgid -Returns the user's real group id. +Returns the user's real group identifier. Similar to Perl's builtin +variable C<$)>, see L. =item getgrgid -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +returning group entries by group identifiers, see +L. =item getgrnam -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +returning group entries by group names, see L. =item getgroups -Returns the ids of the user's supplementary groups. +Returns the ids of the user's supplementary groups. Similar to Perl's +builtin variable C<$)>, see L. =item getlogin -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +returning the user name associated with the current session, see +L. =item getpgrp -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +returning the prcess group identifier of the current process, see +L. =item getpid -Returns the process's id. +Returns the process identifier. Identical to Perl's builtin +variable C<$$>, see L. =item getppid -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +returning the process identifier of the parent process of the current +process , see L. =item getpwnam -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +returning user entries by user names, see L. =item getpwuid -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +returning user entries by user identifiers, see L. =item gets -Returns one line from STDIN. +Returns one line from C, similar to EE, also known +as the C function, see L. + +B: if you have C programs that still use C, be very +afraid. The C function is a source of endless grief because +it has no buffer overrun checks. It should B be used. The +C function should be preferred instead. =item getuid -Returns the user's id. +Returns the user's identifier. Identical to Perl's builtin C<$E> variable, +see L. =item gmtime -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +converting seconds since the epoch to a date in Greenwich Mean Time, +see L. =item isalnum This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead, or possibly the C construct. =item isalpha This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead. =item isatty Returns a boolean indicating whether the specified filehandle is connected -to a tty. +to a tty. Similar to the C<-t> operator, see L. =item iscntrl This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead. =item isdigit This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead, or the C construct. =item isgraph This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead. =item islower This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead. Do B use C. =item isprint This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead. =item ispunct This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead. =item isspace This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead, or the C construct. =item isupper This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead. Do B use C. =item isxdigit This is identical to the C function, except that it can apply to a single -character or to a whole string. +character or to a whole string. Consider using regular expressions and the +C construct instead, or simply C. =item kill -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for sending +signals to processes (often to terminate them), see L. =item labs -labs() is C-specific, use abs instead. +(For returning absolute values of long integers.) +labs() is C-specific, see L instead. =item ldexp -This is identical to the C function C. +This is identical to the C function C +for multiplying floating point numbers with powers of two. + + $x_quadrupled = POSIX::ldexp($x, 2); =item ldiv -ldiv() is C-specific, use / and int instead. +(For computing dividends of long integers.) +ldiv() is C-specific, use C and C instead. =item link -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for creating hard links into files, see L. =item localeconv 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. +Here is how to query the database for the B (Deutsch or German) locale. $loc = POSIX::setlocale( &POSIX::LC_ALL, "de" ); print "Locale = $loc\n"; @@ -590,19 +707,34 @@ The database for the B (Deutsch or German) locale. =item localtime -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +converting seconds since the epoch to a date see L. =item log -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, +returning the natural (I-based) logarithm of the numerical argument, +see L. =item log10 -This is identical to the C function C. +This is identical to the C function C, +returning the 10-base logarithm of the numerical argument. +You can also use + + sub log10 { log($_[0]) / log(10) } + +or + + sub log10 { log($_[0]) / 2.30258509299405 } + +or + + sub log10 { log($_[0]) * 0.434294481903252 } =item longjmp -longjmp() is C-specific: use die instead. +longjmp() is C-specific: use L instead. =item lseek @@ -616,49 +748,63 @@ Returns C on failure. =item malloc -malloc() is C-specific. +malloc() is C-specific. Perl does memory management transparently. =item mblen This is identical to the C function C. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item mbstowcs This is identical to the C function C. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item mbtowc This is identical to the C function C. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item memchr -memchr() is C-specific, use index() instead. +memchr() is C-specific, see L instead. =item memcmp -memcmp() is C-specific, use eq instead. +memcmp() is C-specific, use C instead, see L. =item memcpy -memcpy() is C-specific, use = instead. +memcpy() is C-specific, use C<=>, see L, or see L. =item memmove -memmove() is C-specific, use = instead. +memmove() is C-specific, use C<=>, see L, or see L. =item memset -memset() is C-specific, use x instead. +memset() is C-specific, use C instead, see L. =item mkdir -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for creating directories, see L. =item mkfifo -This is similar to the C function C. +This is similar to the C function C for creating +FIFO special files. -Returns C on failure. + if (mkfifo($path, $mode)) { .... + +Returns C on failure. The C<$mode> is similar to the +mode of C, see L. =item mktime @@ -689,13 +835,16 @@ Return the integral and fractional parts of a floating-point number. =item nice -This is similar to the C function C. +This is similar to the C function C, for changing +the scheduling preference of the current process. Positive +arguments mean more polite process, negative values more +needy process. Normal user processes can only be more polite. Returns C on failure. =item offsetof -offsetof() is C-specific. +offsetof() is C-specific, you probably want to see L instead. =item open @@ -720,6 +869,8 @@ Create a new file with mode 0640. Set up the file for writing. Returns C on failure. +See also L. + =item opendir Open a directory for reading. @@ -743,13 +894,17 @@ Returns C on failure. =item pause -This is similar to the C function C. +This is similar to the C function C, which suspends +the execution of the current process until a signal is received. Returns C on failure. =item perror -This is identical to the C function C. +This is identical to the C function C, which outputs to the +standard error stream the specified message followed by ": " and the +current error string. Use the C function and the C<$!> +variable instead, see L and L. =item pipe @@ -760,39 +915,45 @@ returned by C. POSIX::write( $fd0, "hello", 5 ); POSIX::read( $fd1, $buf, 5 ); +See also L. + =item pow -Computes $x raised to the power $exponent. +Computes C<$x> raised to the power C<$exponent>. $ret = POSIX::pow( $x, $exponent ); +You can also use the C<**> operator, see L. + =item printf -Prints the specified arguments to STDOUT. +Formats and prints the specified arguments to STDOUT. +See also L. =item putc -putc() is C-specific--use print instead. +putc() is C-specific, see L instead. =item putchar -putchar() is C-specific--use print instead. +putchar() is C-specific, see L instead. =item puts -puts() is C-specific--use print instead. +puts() is C-specific, see L instead. =item qsort -qsort() is C-specific, use sort instead. +qsort() is C-specific, see L instead. =item raise Sends the specified signal to the current process. +See also L and the C<$$> in L. =item rand -rand() is non-portable, use Perl's rand instead. +C is non-portable, see L instead. =item read @@ -805,21 +966,26 @@ read then Perl will extend it to make room for the request. Returns C on failure. +See also L. + =item readdir -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for reading directory entries, see L. =item realloc -realloc() is C-specific. +realloc() is C-specific. Perl does memory management transparently. =item remove -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for removing files, see L. =item rename -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for renaming files, see L. =item rewind @@ -827,23 +993,29 @@ Seeks to the beginning of the file. =item rewinddir -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function for +rewinding directory entry streams, see L. =item rmdir -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for removing (empty) directories, see L. =item scanf -scanf() is C-specific--use <> and regular expressions instead. +scanf() is C-specific, use EE and regular expressions instead, +see L. =item setgid -Sets the real group id for this process. +Sets the real group identifier for this process. +Identical to assigning a value to the Perl's builtin C<$)> variable, +see L. =item setjmp -setjmp() is C-specific: use eval {} instead. +C is C-specific: use C instead, +see L. =item setlocale @@ -879,17 +1051,21 @@ out which locales are available in your system. =item setpgid -This is similar to the C function C. +This is similar to the C function C for +setting the process group identifier of the current process. Returns C on failure. =item setsid -This is identical to the C function C. +This is identical to the C function C for +setting the session identifier of the current process. =item setuid -Sets the real user id for this process. +Sets the real user identifier for this process. +Identical to assigning a value to the Perl's builtin C<$E> variable, +see L. =item sigaction @@ -905,7 +1081,7 @@ Returns C on failure. =item siglongjmp -siglongjmp() is C-specific: use die instead. +siglongjmp() is C-specific: use L instead. =item sigpending @@ -933,7 +1109,8 @@ Returns C on failure. =item sigsetjmp -sigsetjmp() is C-specific: use eval {} instead. +C is C-specific: use C instead, +see L. =item sigsuspend @@ -949,63 +1126,80 @@ Returns C on failure. =item sin -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for returning the sine of the numerical argument, +see L. See also L. =item sinh -This is identical to the C function C. +This is identical to the C function C +for returning the hyperbolic sine of the numerical argument. +See also L. =item sleep -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for suspending the execution of the current for process +for certain number of seconds, see L. =item sprintf -This is identical to Perl's builtin C function. +This is similar to Perl's builtin C function +for returning a string that has the arguments formatted as requested, +see L. =item sqrt This is identical to Perl's builtin C function. +for returning the square root of the numerical argument, +see L. =item srand -srand(). +Give a seed the pseudorandom number generator, see L. =item sscanf -sscanf() is C-specific--use regular expressions instead. +sscanf() is C-specific, use regular expressions instead, +see L. =item stat -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for retutning information about files and directories. =item strcat -strcat() is C-specific, use .= instead. +strcat() is C-specific, use C<.=> instead, see L. =item strchr -strchr() is C-specific, use index() instead. +strchr() is C-specific, see L instead. =item strcmp -strcmp() is C-specific, use eq instead. +strcmp() is C-specific, use C or C instead, see L. =item strcoll -This is identical to the C function C. +This is identical to the C function C +for collating (comparing) strings transformed using +the C function. Not really needed since +Perl can do this transparently, see L. =item strcpy -strcpy() is C-specific, use = instead. +strcpy() is C-specific, use C<=> instead, see L. =item strcspn -strcspn() is C-specific, use regular expressions instead. +strcspn() is C-specific, use regular expressions instead, +see L. =item strerror Returns the error string for the specified errno. +Identical to the string form of the C<$!>, see L. =item strftime @@ -1034,39 +1228,38 @@ The string for Tuesday, December 12, 1995. =item strlen -strlen() is C-specific, use length instead. +strlen() is C-specific, use C instead, see L. =item strncat -strncat() is C-specific, use .= instead. +strncat() is C-specific, use C<.=> instead, see L. =item strncmp -strncmp() is C-specific, use eq instead. +strncmp() is C-specific, use C instead, see L. =item strncpy -strncpy() is C-specific, use = instead. - -=item stroul - -stroul() is C-specific. +strncpy() is C-specific, use C<=> instead, see L. =item strpbrk -strpbrk() is C-specific. +strpbrk() is C-specific, use regular expressions instead, +see L. =item strrchr -strrchr() is C-specific, use rindex() instead. +strrchr() is C-specific, see L instead. =item strspn -strspn() is C-specific. +strspn() is C-specific, use regular expressions instead, +see L. =item strstr -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, +see L. =item strtod @@ -1093,7 +1286,8 @@ When called in a scalar context strtod returns the parsed number. =item strtok -strtok() is C-specific. +strtok() is C-specific, use regular expressions instead, see +L, or L. =item strtol @@ -1127,12 +1321,12 @@ When called in a scalar context strtol returns the parsed number. =item strtoul -String to unsigned (long) integer translation. strtoul is identical -to strtol except that strtoul only parses unsigned integers. See -I for details. +String to unsigned (long) integer translation. strtoul() is identical +to strtol() except that strtoul() only parses unsigned integers. See +L for details. -Note: Some vendors supply strtod and strtol but not strtoul. -Other vendors that do suply strtoul parse "-1" as a valid value. +Note: Some vendors supply strtod() and strtol() but not strtoul(). +Other vendors that do supply strtoul() parse "-1" as a valid value. =item strxfrm @@ -1140,6 +1334,11 @@ String transformation. Returns the transformed string. $dst = POSIX::strxfrm( $src ); +Used in conjunction with the C function, see L. + +Not really needed since Perl can do this transparently, see +L. + =item sysconf Retrieves values of system configurable variables. @@ -1152,53 +1351,66 @@ Returns C on failure. =item system -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, see +L. =item tan -This is identical to the C function C. +This is identical to the C function C, returning the +tangent of the numerical argument. See also L. =item tanh -This is identical to the C function C. +This is identical to the C function C, returning the +hyperbolic tangent of the numerical argument. See also L. =item tcdrain -This is similar to the C function C. +This is similar to the C function C for draining +the output queue of its argument stream. Returns C on failure. =item tcflow -This is similar to the C function C. +This is similar to the C function C for controlling +the flow of its argument stream. Returns C on failure. =item tcflush -This is similar to the C function C. +This is similar to the C function C for flushing +the I/O buffers of its argumeny stream. Returns C on failure. =item tcgetpgrp -This is identical to the C function C. +This is identical to the C function C for returning the +process group identifier of the foreground process group of the controlling +terminal. =item tcsendbreak -This is similar to the C function C. +This is similar to the C function C for sending +a break on its argument stream. Returns C on failure. =item tcsetpgrp -This is similar to the C function C. +This is similar to the C function C for setting the +process group identifier of the foreground process group of the controlling +terminal. Returns C on failure. =item time -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for returning the number of seconds since the epoch +(whatever it is for the system), see L. =item times @@ -1214,7 +1426,7 @@ seconds. =item tmpfile -Use method C instead. +Use method C instead, or see L. =item tmpnam @@ -1222,17 +1434,26 @@ Returns a name for a temporary file. $tmpfile = POSIX::tmpnam(); +See also L. + =item tolower -This is identical to Perl's builtin C function. +This is identical to the C function, except that it can apply to a single +character or to a whole string. Consider using the C function, +see L, or the equivalent C<\L> operator inside doublequotish +strings. =item toupper -This is identical to Perl's builtin C function. +This is identical to the C function, except that it can apply to a single +character or to a whole string. Consider using the C function, +see L, or the equivalent C<\U> operator inside doublequotish +strings. =item ttyname -This is identical to the C function C. +This is identical to the C function C for returning the +name of the current terminal. =item tzname @@ -1243,17 +1464,31 @@ Retrieves the time conversion information from the C variable. =item tzset -This is identical to the C function C. +This is identical to the C function C for setting +the current timezone based on the environment variable C, +to be used by C, C, C, and C +functions. =item umask -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for setting (and querying) the file creation permission mask, +see L. =item uname Get name of current operating system. - ($sysname, $nodename, $release, $version, $machine ) = POSIX::uname(); + ($sysname, $nodename, $release, $version, $machine) = POSIX::uname(); + +Note that the actual meanings of the various fields are not +that well standardized, do not expect any great portability. +The C<$sysname> might be the name of the operating system, +the C<$nodename> might be the name of the host, the C<$release> +might be the (major) release number of the operating system, +the C<$version> might be the (minor) release number of the +operating system, and the C<$machine> might be a hardware identifier. +Maybe. =item ungetc @@ -1261,32 +1496,36 @@ Use method C instead. =item unlink -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for removing files, see L. =item utime -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function +for changing the time stamps of files and directories, +see L. =item vfprintf -vfprintf() is C-specific. +vfprintf() is C-specific, see L instead. =item vprintf -vprintf() is C-specific. +vprintf() is C-specific, see L instead. =item vsprintf -vsprintf() is C-specific. +vsprintf() is C-specific, see L instead. =item wait -This is identical to Perl's builtin C function. +This is identical to Perl's builtin C function, +see L. =item waitpid Wait for a child process to change state. This is identical to Perl's -builtin C function. +builtin C function, see L. $pid = POSIX::waitpid( -1, &POSIX::WNOHANG ); print "status = ", ($? / 256), "\n"; @@ -1294,10 +1533,16 @@ builtin C function. =item wcstombs This is identical to the C function C. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item wctomb This is identical to the C function C. +Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather +useless function. =item write @@ -1310,6 +1555,8 @@ calling C. Returns C on failure. +See also L. + =back =head1 CLASSES @@ -1715,7 +1962,7 @@ CLK_TCK CLOCKS_PER_SEC =item Constants -R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STRERR_FILENO W_OK X_OK +R_OK SEEK_CUR SEEK_END SEEK_SET STDIN_FILENO STDOUT_FILENO STDERR_FILENO W_OK X_OK =back @@ -1733,7 +1980,3 @@ WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG WIFSTOPPED WSTOPSIG =back -=head1 CREATION - -This document generated by ./mkposixman.PL version 19960129. - diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index b33e961..b8b80d4 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -55,6 +55,9 @@ #ifdef I_UNISTD #include #endif +#ifdef MACOS_TRADITIONAL +#undef fdopen +#endif #include #if defined(__VMS) && !defined(__POSIX_SOURCE) @@ -80,7 +83,7 @@ /* The non-POSIX CRTL times() has void return type, so we just get the current time directly */ - clock_t vms_times(struct tms *PL_bufptr) { + clock_t vms_times(struct tms *bufptr) { dTHX; clock_t retval; /* Get wall time and convert to 10 ms intervals to @@ -101,7 +104,7 @@ _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder)); # endif /* Fill in the struct tms using the CRTL routine . . .*/ - times((tbuffer_t *)PL_bufptr); + times((tbuffer_t *)bufptr); return (clock_t) retval; } # define times(t) vms_times(t) @@ -142,7 +145,7 @@ #else # ifndef HAS_MKFIFO -# ifdef OS2 +# if defined(OS2) || defined(MACOS_TRADITIONAL) # define mkfifo(a,b) not_here("mkfifo") # else /* !( defined OS2 ) */ # ifndef mkfifo @@ -151,12 +154,19 @@ # endif # endif /* !HAS_MKFIFO */ -# include -# include -# ifdef HAS_UNAME -# include +# ifdef MACOS_TRADITIONAL + struct tms { time_t tms_utime, tms_stime, tms_cutime, tms_cstime; }; +# define times(a) not_here("times") +# define ttyname(a) (char*)not_here("ttyname") +# define tzset() not_here("tzset") +# else +# include +# include +# ifdef HAS_UNAME +# include +# endif +# include # endif -# include # ifdef I_UTIME # include # endif @@ -2296,9 +2306,9 @@ constant(char *name, int arg) #else goto not_there; #endif - if (strEQ(name, "STRERR_FILENO")) -#ifdef STRERR_FILENO - return STRERR_FILENO; + if (strEQ(name, "STDERR_FILENO")) +#ifdef STDERR_FILENO + return STDERR_FILENO; #else goto not_there; #endif @@ -3352,7 +3362,7 @@ modf(x) PPCODE: double intvar; /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(modf(x,&intvar)))); + PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); PUSHs(sv_2mortal(newSVnv(intvar))); double diff --git a/ext/SDBM_File/SDBM_File.pm b/ext/SDBM_File/SDBM_File.pm index c5e26c8..438b8d0 100644 --- a/ext/SDBM_File/SDBM_File.pm +++ b/ext/SDBM_File/SDBM_File.pm @@ -20,14 +20,98 @@ SDBM_File - Tied access to sdbm files =head1 SYNOPSIS + use Fcntl; # For O_RDWR, O_CREAT, etc. use SDBM_File; - tie(%h, 'SDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640); + tie(%h, 'SDBM_File', 'filename', O_RDWR|O_CREAT, 0666) + or die "Couldn't tie SDBM file 'filename': $!; aborting"; + + # Now read and change the hash + $h{newkey} = newvalue; + print $h{oldkey}; + ... untie %h; =head1 DESCRIPTION -See L, L +C establishes a connection between a Perl hash variable and +a file in SDBM_File format;. You can manipulate the data in the file +just as if it were in a Perl hash, but when your program exits, the +data will remain in the file, to be used the next time your program +runs. + +Use C with the Perl built-in C function to establish +the connection between the variable and the file. The arguments to +C should be: + +=over 4 + +=item 1. + +The hash variable you want to tie. + +=item 2. + +The string C<"SDBM_File">. (Ths tells Perl to use the C +package to perform the functions of the hash.) + +=item 3. + +The name of the file you want to tie to the hash. + +=item 4. + +Flags. Use one of: + +=over 2 + +=item C + +Read-only access to the data in the file. + +=item C + +Write-only access to the data in the file. + +=item C + +Both read and write access. + +=back + +If you want to create the file if it does not exist, add C to +any of these, as in the example. If you omit C and the file +does not already exist, the C call will fail. + +=item 5. + +The default permissions to use if a new file is created. The actual +permissions will be modified by the user's umask, so you should +probably use 0666 here. (See L.) + +=back + +=head1 DIAGNOSTICS + +On failure, the C call returns an undefined value and probably +sets C<$!> to contain the reason the file could not be tied. + +=head2 C + +This warning is emmitted when you try to store a key or a value that +is too long. It means that the change was not recorded in the +database. See BUGS AND WARNINGS below. + + + +=head1 BUGS AND WARNINGS + +There are a number of limits on the size of the data that you can +store in the SDBM file. The most important is that the length of a +key, plus the length of its associated value, may not exceed 1008 +bytes. + +See L, L, L =cut diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm index 02f098d..025888d 100644 --- a/ext/Socket/Socket.pm +++ b/ext/Socket/Socket.pm @@ -325,116 +325,6 @@ sub sockaddr_un { } } -sub INADDR_ANY (); -sub INADDR_BROADCAST (); -sub INADDR_LOOPBACK (); -sub INADDR_LOOPBACK (); - -sub AF_802 (); -sub AF_APPLETALK (); -sub AF_CCITT (); -sub AF_CHAOS (); -sub AF_DATAKIT (); -sub AF_DECnet (); -sub AF_DLI (); -sub AF_ECMA (); -sub AF_GOSIP (); -sub AF_HYLINK (); -sub AF_IMPLINK (); -sub AF_INET (); -sub AF_LAT (); -sub AF_MAX (); -sub AF_NBS (); -sub AF_NIT (); -sub AF_NS (); -sub AF_OSI (); -sub AF_OSINET (); -sub AF_PUP (); -sub AF_SNA (); -sub AF_UNIX (); -sub AF_UNSPEC (); -sub AF_X25 (); -sub IOV_MAX (); -sub MSG_BCAST (); -sub MSG_CTLFLAGS (); -sub MSG_CTLIGNORE (); -sub MSG_CTRUNC (); -sub MSG_DONTROUTE (); -sub MSG_DONTWAIT (); -sub MSG_EOF (); -sub MSG_EOR (); -sub MSG_ERRQUEUE (); -sub MSG_FIN (); -sub MSG_MAXIOVLEN (); -sub MSG_MCAST (); -sub MSG_NOSIGNAL (); -sub MSG_OOB (); -sub MSG_PEEK (); -sub MSG_PROXY (); -sub MSG_RST (); -sub MSG_SYN (); -sub MSG_TRUNC (); -sub MSG_URG (); -sub MSG_WAITALL (); -sub PF_802 (); -sub PF_APPLETALK (); -sub PF_CCITT (); -sub PF_CHAOS (); -sub PF_DATAKIT (); -sub PF_DECnet (); -sub PF_DLI (); -sub PF_ECMA (); -sub PF_GOSIP (); -sub PF_HYLINK (); -sub PF_IMPLINK (); -sub PF_INET (); -sub PF_LAT (); -sub PF_MAX (); -sub PF_NBS (); -sub PF_NIT (); -sub PF_NS (); -sub PF_OSI (); -sub PF_OSINET (); -sub PF_PUP (); -sub PF_SNA (); -sub PF_UNIX (); -sub PF_UNSPEC (); -sub PF_X25 (); -sub SCM_CONNECT (); -sub SCM_CREDENTIALS (); -sub SCM_CREDS (); -sub SCM_RIGHTS (); -sub SCM_TIMESTAMP (); -sub SHUT_RD (); -sub SHUT_RDWR (); -sub SHUT_WR (); -sub SOCK_DGRAM (); -sub SOCK_RAW (); -sub SOCK_RDM (); -sub SOCK_SEQPACKET (); -sub SOCK_STREAM (); -sub SOL_SOCKET (); -sub SOMAXCONN (); -sub SO_ACCEPTCONN (); -sub SO_BROADCAST (); -sub SO_DEBUG (); -sub SO_DONTLINGER (); -sub SO_DONTROUTE (); -sub SO_ERROR (); -sub SO_KEEPALIVE (); -sub SO_LINGER (); -sub SO_OOBINLINE (); -sub SO_RCVBUF (); -sub SO_RCVLOWAT (); -sub SO_RCVTIMEO (); -sub SO_REUSEADDR (); -sub SO_SNDBUF (); -sub SO_SNDLOWAT (); -sub SO_SNDTIMEO (); -sub SO_TYPE (); -sub SO_USELOOPBACK (); -sub UIO_MAXIOV (); - sub AUTOLOAD { my($constname); ($constname = $AUTOLOAD) =~ s/.*:://; diff --git a/fix_pl b/fix_pl new file mode 100644 index 0000000..44c3f52 --- /dev/null +++ b/fix_pl @@ -0,0 +1,21 @@ +#!perl +# Not fixing perl, but fixing the patchlevel if this perl comes +# from the repository rather than an official release +exit unless -e ".patch"; +open PATCH, ".patch" or die "Couldn't open .patch: $!"; +open PLIN, "patchlevel.h" or die "Couldn't open patchlevel.h : $!"; +open PLOUT, ">patchlevel.new" or die "Couldn't write on patchlevel.new : $!"; +my $pl = ; +chomp ($pl); +$pl =~ s/\D//g; +my $seen=0; +while () { + if (/\t,NULL/ and $seen) { + print PLOUT "\t,\"devel-$pl\"\n"; + } + $seen++ if /local_patches\[\]/; + print PLOUT; +} +close PLOUT; close PLIN; +rename "patchlevel.new", "patchlevel.h" or die "Couldn't rename: $!"; +unlink ".patch"; diff --git a/global.sym b/global.sym index 796f851..89c8824 100644 --- a/global.sym +++ b/global.sym @@ -21,6 +21,7 @@ Perl_get_context Perl_set_context Perl_amagic_call Perl_Gv_AMupdate +Perl_apply_attrs_string Perl_avhv_delete_ent Perl_avhv_exists_ent Perl_avhv_fetch_ent @@ -32,14 +33,12 @@ Perl_av_clear Perl_av_delete Perl_av_exists Perl_av_extend -Perl_av_fake Perl_av_fetch Perl_av_fill Perl_av_len Perl_av_make Perl_av_pop Perl_av_push -Perl_av_reify Perl_av_shift Perl_av_store Perl_av_undef @@ -185,6 +184,7 @@ Perl_to_uni_upper_lc Perl_to_uni_title_lc Perl_to_uni_lower_lc Perl_is_utf8_char +Perl_is_utf8_string Perl_is_utf8_alnum Perl_is_utf8_alnumc Perl_is_utf8_idfirst @@ -336,6 +336,7 @@ Perl_save_destructor_x Perl_save_freesv Perl_save_freepv Perl_save_generic_svref +Perl_save_generic_pvref Perl_save_gp Perl_save_hash Perl_save_helem @@ -459,6 +460,8 @@ Perl_utf16_to_utf8 Perl_utf16_to_utf8_reversed Perl_utf8_distance Perl_utf8_hop +Perl_utf8_to_bytes +Perl_bytes_to_utf8 Perl_utf8_to_uv Perl_uv_to_utf8 Perl_warn @@ -479,6 +482,7 @@ Perl_safexfree Perl_GetVars Perl_runops_standard Perl_runops_debug +Perl_sv_lock Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg Perl_sv_catpv_mg @@ -540,4 +544,5 @@ Perl_ptr_table_new Perl_ptr_table_fetch Perl_ptr_table_store Perl_ptr_table_split +Perl_sys_intern_clear Perl_sys_intern_init diff --git a/gv.c b/gv.c index 5ab21b1..836fdb2 100644 --- a/gv.c +++ b/gv.c @@ -106,7 +106,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; GvCVGEN(gv) = 0; GvEGV(gv) = gv; - sv_magic((SV*)gv, (SV*)gv, '*', name, len); + sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0); GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; @@ -372,7 +372,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { - if (strEQ(name,"import")) + if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(stash, name, nend - name, TRUE); @@ -418,6 +418,9 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) return Nullgv; cv = GvCV(gv); + if (!CvROOT(cv)) + return Nullgv; + /* * Inheriting AUTOLOAD for non-methods works ... for now. */ @@ -435,9 +438,18 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); + ENTER; + +#ifdef USE_THREADS + sv_lock((SV *)varstash); +#endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); + LEAVE; varsv = GvSV(vargv); +#ifdef USE_THREADS + sv_lock(varsv); +#endif sv_setpv(varsv, HvNAME(stash)); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); @@ -907,6 +919,22 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) } void +Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) +{ + HV *hv = GvSTASH(gv); + if (!hv) { + (void)SvOK_off(sv); + return; + } + sv_setpv(sv, prefix ? prefix : ""); + if (keepmain || strNE(HvNAME(hv), "main")) { + sv_catpv(sv,HvNAME(hv)); + sv_catpvn(sv,"::", 2); + } + sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); +} + +void Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { HV *hv = GvSTASH(gv); @@ -921,6 +949,15 @@ Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) } void +Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) +{ + GV *egv = GvEGV(gv); + if (!egv) + egv = gv; + gv_fullname4(sv, egv, prefix, keepmain); +} + +void Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { GV *egv = GvEGV(gv); @@ -1580,3 +1617,110 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } } } + +/* +=for apidoc is_gv_magical + +Returns C if given the name of a magical GV. + +Currently only useful internally when determining if a GV should be +created even in rvalue contexts. + +C is not used at present but available for future extension to +allow selecting particular classes of magical variable. + +=cut +*/ +bool +Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) +{ + if (!len) + return FALSE; + + switch (*name) { + case 'I': + if (len == 3 && strEQ(name, "ISA")) + goto yes; + break; + case 'O': + if (len == 8 && strEQ(name, "OVERLOAD")) + goto yes; + break; + case 'S': + if (len == 3 && strEQ(name, "SIG")) + goto yes; + break; + case '\027': /* $^W & $^WARNING_BITS */ + if (len == 1 + || (len == 12 && strEQ(name, "\027ARNING_BITS")) + || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS"))) + { + goto yes; + } + break; + + case '&': + case '`': + case '\'': + case ':': + case '?': + case '!': + case '-': + case '#': + case '*': + case '[': + case '^': + case '~': + case '=': + case '%': + case '.': + case '(': + case ')': + case '<': + case '>': + case ',': + case '\\': + case '/': + case '|': + case '+': + case ';': + case ']': + case '\001': /* $^A */ + case '\003': /* $^C */ + case '\004': /* $^D */ + case '\005': /* $^E */ + case '\006': /* $^F */ + case '\010': /* $^H */ + case '\011': /* $^I, NOT \t in EBCDIC */ + case '\014': /* $^L */ + case '\017': /* $^O */ + case '\020': /* $^P */ + case '\023': /* $^S */ + case '\024': /* $^T */ + case '\026': /* $^V */ + if (len == 1) + goto yes; + break; + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + if (len > 1) { + char *end = name + len; + while (--end > name) { + if (!isDIGIT(*end)) + return FALSE; + } + } + yes: + return TRUE; + default: + break; + } + return FALSE; +} diff --git a/handy.h b/handy.h index 81f4745..9e6f223 100644 --- a/handy.h +++ b/handy.h @@ -261,7 +261,7 @@ C). /* =for apidoc Am|bool|isALNUM|char ch Returns a boolean indicating whether the C C is an ASCII alphanumeric -character or digit. +character (including underscore) or digit. =for apidoc Am|bool|isALPHA|char ch Returns a boolean indicating whether the C C is an ASCII alphabetic @@ -505,7 +505,7 @@ The XSUB-writer's interface to the C C function. The XSUB-writer's interface to the C C function, with cast. -=for apidoc Am|void|Safefree|void* src|void* dest|int nitems|type +=for apidoc Am|void|Safefree|void* ptr The XSUB-writer's interface to the C C function. =for apidoc Am|void|Move|void* src|void* dest|int nitems|type diff --git a/hints/aix.sh b/hints/aix.sh index d6f3dd7..8a29b93 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -206,30 +206,29 @@ EOCBU cat > UU/uselargefiles.cbu <<'EOCBU' case "$uselargefiles" in ''|$define|true|[yY]*) - lfcflags="`getconf XBS5_ILP32_OFFBIG_CFLAGS 2>/dev/null`" - lfldflags="`getconf XBS5_ILP32_OFFBIG_LDFLAGS 2>/dev/null`" +# Keep these at the left margin. +ccflags_largefiles="`getconf XBS5_ILP32_OFFBIG_CFLAGS 2>/dev/null`" +ldflags_largefiles="`getconf XBS5_ILP32_OFFBIG_LDFLAGS 2>/dev/null`" # _Somehow_ in AIX 4.3.1.0 the above getconf call manages to # insert(?) *something* to $ldflags so that later (in Configure) evaluating # $ldflags causes a newline after the '-b64' (the result of the getconf). # (nothing strange shows up in $ldflags even in hexdump; # so it may be something in the shell, instead?) # Try it out: just uncomment the below line and rerun Configure: -# echo >&4 "AIX 4.3.1.0 $lfldflags mystery" ; exit 1 +# echo >&4 "AIX 4.3.1.0 $ldflags_largefiles mystery" ; exit 1 # Just don't ask me how AIX does it, I spent hours wondering. - # Therefore the line re-evaluating lfldflags: it seems to fix + # Therefore the line re-evaluating ldflags_largefiles: it seems to fix # the whatever it was that AIX managed to break. --jhi - lfldflags="`echo $lfldflags`" - lflibs="`getconf XBS5_ILP32_OFFBIG_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" - case "$lfcflags$lfldflags$lflibs" in + ldflags_largefiles="`echo $ldflags_largefiles`" +# Keep this at the left margin. +libswanted_largefiles="`getconf XBS5_ILP32_OFFBIG_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" + case "$ccflags_largefiles$ldflags_largefiles$libs_largefiles" in '');; - *) ccflags="$ccflags $lfcflags" - ldflags="$ldflags $lfldflags" - libswanted="$libswanted $lflibs" + *) ccflags="$ccflags $ccflags_largefiles" + ldflags="$ldflags $ldflags_largefiles" + libswanted="$libswanted $libswanted_largefiles" ;; esac - lfcflags='' - lfldflags='' - lflibs='' ;; esac EOCBU @@ -279,18 +278,18 @@ int main (void) EOCP set size if eval $compile_ok; then - lfcpuwidth=`./size` - echo "You are running on $lfcpuwidth bit hardware." + qacpuwidth=`./size` + echo "You are running on $qacpuwidth bit hardware." else dflt="32" echo " " echo "(I can't seem to compile the test program. Guessing...)" rp="What is the width of your CPU (in bits)?" . ./myread - lfcpuwidth="$ans" + qacpuwidth="$ans" fi $rm -f size.c size - case "$lfcpuwidth" in + case "$qacpuwidth" in 32*) cat >&4 <; Tue Oct 4 12:01:34 EDT 1994 # Updated by Tony Sanders ; Sat Aug 23 12:47:45 MDT 1997 -# Added 3.1 with ELF dynamic libraries (NOT in 3.1 yet. Estimated for 4.0) -# SYSV IPC tested Ok so I re-enabled. +# Added 3.1 with ELF dynamic libraries (NOT in 3.1 yet. +# Estimated for 4.0) SYSV IPC tested Ok so I re-enabled. +# +# Updated to work in post-4.0 by Todd C. Miller +# +# Updated for threads by "Timur I. Bakeyev" # # To override the compiler on the command line: # ./Configure -Dcc=gcc2 @@ -18,7 +22,7 @@ d_voidsig='define' usemymalloc='n' # setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS versions. -# See http://www.bsdi.com/bsdi-man?setuid(2) +# See http://www.bsdi.com/bsdi-man?setuid(2) d_setregid='undef' d_setreuid='undef' d_setrgid='undef' @@ -85,8 +89,8 @@ case "$osvers" in libswanted="Xpm Xaw Xmu Xt SM ICE Xext X11 $libswanted" libswanted="rpc curses termcap $libswanted" ;; -4.0*) - # ELF dynamic link libraries starting in 4.0 (???) +4.*) + # ELF dynamic link libraries starting in 4.0 useshrplib='true' so='so' dlext='so' @@ -94,13 +98,34 @@ case "$osvers" in case "$cc" in '') cc='cc' # cc is gcc2 in 4.0 cccdlflags="-fPIC" - ccdlflags=" " ;; + ccdlflags="-rdynamic -Wl,-rpath,$privlib/$archname/CORE" + ;; esac case "$ld" in '') ld='ld' lddlflags="-shared -x $lddlflags" ;; esac - ;; + # Due usage of static pointer from crt.o + libswanted="util $libswanted" ;; esac +# This script UU/usethreads.cbu will get 'called-back' by Configure +# after it has prompted the user for whether to use threads. +cat > UU/usethreads.cbu <<'EOCBU' +case "$usethreads" in +$define|true|[yY]*) + case "$osvers" in + 3.*|4.*) ccflags="-D_REENTRANT $ccflags" + ;; + *) cat <&4 +I did not know that BSD/OS $osvers supports POSIX threads. + +Feel free to tell perlbug@perl.com otherwise. +EOM + exit 1 + ;; + esac + ;; +esac +EOCBU diff --git a/hints/dec_osf.sh b/hints/dec_osf.sh index db7b869..c110d1e 100644 --- a/hints/dec_osf.sh +++ b/hints/dec_osf.sh @@ -65,30 +65,38 @@ cc=${cc:-cc} # reset _DEC_cc_style= case "`$cc -v 2>&1 | grep cc`" in -*gcc*) _gcc_version=`$cc -v 2>&1 | grep "gcc version" | sed 's%^gcc version \([0-9]*\)\.\([0-9]*\) .*%\1 \2%'` +*gcc*) _gcc_version=`$cc --version 2>&1 | tr . ' '` set $_gcc_version - if test "$1" -lt 2 -o \( "$1" -eq 2 -a "$2" -lt 95 \); then + if test "$1" -lt 2 -o \( "$1" -eq 2 -a \( "$2" -lt 95 -o \( "$2" -eq 95 -a "$3" -lt 2 \) \) \); then cat >&4 <&4 < UU/uselargefiles.cbu <<'EOCBU' case "$uselargefiles" in ''|$define|true|[yY]*) # there are largefile flags available via getconf(1) - # but we cheat for now. - ccflags="$ccflags -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64" + # but we cheat for now. (Keep that in the left margin.) +ccflags_largefiles="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64" + + ccflags="$ccflags $ccflags_largefiles" if test -z "$ccisgcc" -a -z "$gccversion"; then # The strict ANSI mode (-Aa) doesn't like large files. diff --git a/hints/irix_6.sh b/hints/irix_6.sh index 8be23ac..ce301df 100644 --- a/hints/irix_6.sh +++ b/hints/irix_6.sh @@ -32,6 +32,14 @@ # Don't bother with -n32 unless you have the 7.1 or later compilers. # But there's no quick and light-weight way to check in 6.2. +# NOTE: some IRIX cc versions, e.g. 7.3.1.1m (try cc -version) have +# been known to have issues (coredumps) when compiling perl.c. +# If you've used -OPT:fast_io=ON and this happens, try removing it. +# If that fails, or you didn't use that, then try adjusting other +# optimization options (-LNO, -INLINE, -O3 to -O2, etcetera). +# The compiler bug has been reported to SGI. +# -- Allen Smith + # Let's assume we want to use 'cc -n32' by default, unless the # necessary libm is missing (which has happened at least twice) case "$cc" in @@ -226,8 +234,10 @@ esac # Don't groan about unused libraries. ldflags="$ldflags -Wl,-woff,84" +# workaround for an optimizer bug case "`$cc -version 2>&1`" in -*7.2.*) op_cflags='optimize=-O1' ;; # workaround for an optimizer bug +*7.2.*) op_cflags='optimize=-O1'; opmini_cflags='optimize=-O1' ;; +*7.3.1.*) op_cflags='optimize=-O2'; opmini_cflags='optimize=-O2' ;; esac # We don't want these libraries. diff --git a/hints/linux.sh b/hints/linux.sh index 4fb2f89..0fa46bd 100644 --- a/hints/linux.sh +++ b/hints/linux.sh @@ -282,7 +282,10 @@ cat > UU/uselargefiles.cbu <<'EOCBU' # after it has prompted the user for whether to use large files. case "$uselargefiles" in ''|$define|true|[yY]*) - ccflags="$ccflags -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64" +# Keep this in the left margin. +ccflags_largefiles="-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64" + + ccflags="$ccflags $ccflags_largefiles" ;; esac EOCBU diff --git a/hints/machten.sh b/hints/machten.sh index b4409c1..69f1635 100644 --- a/hints/machten.sh +++ b/hints/machten.sh @@ -46,10 +46,7 @@ # # MachTen 4.1.1's support for shadow password file access is incomplete: # disable its use completely. -d_endspent=${d_endspent:-undef} -d_getspent=${d_getspent:-undef} d_getspnam=${d_getspnam:-undef} -d_setspent=${d_setspent:-undef} # MachTen 4.1.1 does support dynamic loading, but perl doesn't # know how to use it yet. @@ -241,10 +238,9 @@ Similarly, when you see select the default answer: vfork() works, and avoids expensive data copying. -You may also see "WHOA THERE!!!" messages concerning \$d_endspent, -\$d_getspent, \$d_getspnam and \$d_setspent. In all cases, select the -default answer: MachTen's support for shadow password file access is -incomplete, and should not be used. +You may also see "WHOA THERE!!!" messages concerning \$d_getspnam. +Select the default answer: MachTen's support for shadow password +file access is incomplete, and should not be used. At the end of Configure, you will see a harmless message diff --git a/hints/mpeix.sh b/hints/mpeix.sh index 556d221..d2ca5f0 100644 --- a/hints/mpeix.sh +++ b/hints/mpeix.sh @@ -10,9 +10,10 @@ # Created for 5.003 by Mark Klein, mklein@dis.com. # Substantially revised for 5.004_01 by Mark Bixby, markb@cccd.edu. # Revised again for 5.004_69 by Mark Bixby, markb@cccd.edu. +# Revised for 5.6.0 by Mark Bixby, mbixby@power.net. # osname='mpeix' -osvers='5.5' # Isn't there a way to determine this dynamically? +osvers=`uname -r | sed -e 's/.[A-Z]\.\([0-9]\)\([0-9]\)\.[0-9][0-9]/\1.\2/'` # # Force Configure to use our wrapper mpeix/nm script # @@ -53,16 +54,34 @@ toke_cflags='ccflags="$ccflags -DARG_ZERO_IS_SCRIPT"' # Linking. # lddlflags='-b' -# What if you want additional libs (e.g. gdbm)? -# This should remove the unwanted libraries from $libswanted and -# add on whatever ones are needed instead. -libs="$libs -lbind -lsyslog -lcurses -lsvipc -lsocket -lm -lc" +# Delete bsd and BSD from the library list. Remove other randomly ordered +# libraries and then re-add them in their proper order (the MPE linker is +# order-sensitive). Add additional MPE-specific libraries. +for mpe_remove in bind bsd BSD c curses m socket str svipc syslog; do + set `echo " $libswanted " | sed -e 's/ / /g' -e "s/ $mpe_remove //"` + libswanted="$*" +done +libswanted="$libswanted bind syslog curses svipc socket str m c" loclibpth="$loclibpth /usr/local/lib /usr/contrib/lib /BIND/PUB/lib /SYSLOG/PUB" # # External functions and data items. # -# Does Configure *really* get *all* of these wrong? +# Q: Does Configure *really* get *all* of these wrong? # +# A: Yes. There are two MPE problems here. The 'undef' functions exist on MPE, +# but are merely dummy routines that return ENOTIMPL or ESYSERR. Since they're +# useless, let's just tell Perl to avoid them. Also, a few data items are +# 'undef' because while they may exist in structures, they are uninitialized. +# +# The 'define' cases are a bit weirder. MPE has a libc.a, libc.sl, and two +# special kernel shared libraries, /SYS/PUB/XL and /SYS/PUB/NL. Much of what +# is in libc.a is duplicated within XL and NL, so when we created libc.sl, we +# omitted the duplicated functions. Since Configure end ups scanning libc.sl, +# we need to 'define' the functions that had been removed. +# +# We don't want to scan XL or NL because we would find way too many POSIX or +# Unix named functions that are really vanilla MPE functions that do something +# completely different than on POSIX or Unix. d_crypt='define' d_difftime='define' d_dlerror='undef' @@ -100,7 +119,7 @@ d_wctomb='define' # # Include files. # -i_termios='undef' +i_termios='undef' # we have termios, but not the full set (just tcget/setattr) i_time='define' i_systime='undef' i_systimek='undef' @@ -109,3 +128,8 @@ timeincl='/usr/include/time.h' # Data types. # timetype='time_t' +# +# Functionality. +# +bincompat5005="$undef" +uselargefiles="$undef" diff --git a/hints/os2.sh b/hints/os2.sh index 1d9df36..0e9f786 100644 --- a/hints/os2.sh +++ b/hints/os2.sh @@ -93,7 +93,7 @@ if test "$libemx" = "X"; then echo "Cannot find C library!" >&2; fi libpth="`echo \"$LIBRARY_PATH\" | tr ';\\\' ' /'`" libpth="$libpth $libemx/mt $libemx" -set `emxrev -f emxlibcm` +set `cmd /c emxrev -f emxlibcm` emxcrtrev=$5 # indented to not put it into config.sh _defemxcrtrev=-D_EMX_CRT_REV_=$emxcrtrev diff --git a/hints/powerux.sh b/hints/powerux.sh index 4070c01..dc1b3d0 100644 --- a/hints/powerux.sh +++ b/hints/powerux.sh @@ -63,7 +63,7 @@ lddlflags='-Zlink=so' # i_ndbm='undef' -# I have no clude what perl thinks it wants for, but if +# I have no clue what perl thinks it wants for, but if # you include it in a program in PowerMAX without first including # the code don't compile... # diff --git a/hints/solaris_2.sh b/hints/solaris_2.sh index 8aee6d4..21b0b0e 100644 --- a/hints/solaris_2.sh +++ b/hints/solaris_2.sh @@ -374,9 +374,15 @@ cat > UU/uselargefiles.cbu <<'EOCBU' # after it has prompted the user for whether to use large files. case "$uselargefiles" in ''|$define|true|[yY]*) - ccflags="$ccflags `getconf LFS_CFLAGS 2>/dev/null`" - ldflags="$ldflags `getconf LFS_LDFLAGS 2>/dev/null`" - libswanted="$libswanted `getconf LFS_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" + +# Keep these in the left margin. +ccflags_largefiles="`getconf LFS_CFLAGS 2>/dev/null`" +ldflags_largefiles="`getconf LFS_LDFLAGS 2>/dev/null`" +libswanted_largefiles="`getconf LFS_LIBS 2>/dev/null|sed -e 's@^-l@@' -e 's@ -l@ @g`" + + ccflags="$ccflags $ccflags_largefiles" + ldflags="$ldflags $ldflags_largefiles" + libswanted="$libswanted $libswanted_largefiles" ;; esac EOCBU @@ -387,10 +393,10 @@ cat > UU/use64bitint.cbu <<'EOCBU' case "$use64bitint" in "$define"|true|[yY]*) case "`uname -r`" in - 2.[1-6]) + 5.[1-6]) cat >&4 <xpv_pv = (char*)PL_he_arenaroot; + PL_he_arenaroot = ptr; + + he = (HE*)ptr; heend = &he[1008 / sizeof(HE) - 1]; + PL_he_root = ++he; while (he < heend) { HeNEXT(he) = (HE*)(he + 1); he++; diff --git a/installperl b/installperl index 09ffc80..f296712 100755 --- a/installperl +++ b/installperl @@ -307,7 +307,7 @@ if (! $versiononly && ! samepath($installbin, '.') && ($^O ne 'dos') && ! $Is_VM my $mainperl_is_instperl = 0; -if ($Config{installusrbinperl} eq 'define' && +if ($Config{installusrbinperl} && $Config{installusrbinperl} eq 'define' && !$versiononly && !$nonono && !$Is_W32 && !$Is_VMS && -t STDIN && -t STDERR && -w $mainperldir && ! samepath($mainperldir, $installbin)) { my($usrbinperl) = "$mainperldir/$perl$exe_ext"; @@ -465,7 +465,7 @@ sub yn { my($prompt) = @_; my($answer); my($default) = $prompt =~ m/\[([yn])\]\s*$/i; - print $prompt; + print STDERR $prompt; chop($answer = ); $answer = $default if $answer =~ m/^\s*$/; ($answer =~ m/^[yY]/); diff --git a/intrpvar.h b/intrpvar.h index 8ed93f8..f84de79 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -245,19 +245,19 @@ PERLVARI(Ish_path, char *, SH_PATH)/* full path of shell */ PERLVAR(Isighandlerp, Sighandler_t) PERLVAR(Ixiv_arenaroot, XPV*) /* list of allocated xiv areas */ -PERLVAR(Ixiv_root, IV *) /* free xiv list--shared by interpreters */ -PERLVAR(Ixnv_root, NV *) /* free xnv list--shared by interpreters */ -PERLVAR(Ixrv_root, XRV *) /* free xrv list--shared by interpreters */ -PERLVAR(Ixpv_root, XPV *) /* free xpv list--shared by interpreters */ -PERLVAR(Ixpviv_root, XPVIV *) /* free xpviv list--shared by interpreters */ -PERLVAR(Ixpvnv_root, XPVNV *) /* free xpvnv list--shared by interpreters */ -PERLVAR(Ixpvcv_root, XPVCV *) /* free xpvcv list--shared by interpreters */ -PERLVAR(Ixpvav_root, XPVAV *) /* free xpvav list--shared by interpreters */ -PERLVAR(Ixpvhv_root, XPVHV *) /* free xpvhv list--shared by interpreters */ -PERLVAR(Ixpvmg_root, XPVMG *) /* free xpvmg list--shared by interpreters */ -PERLVAR(Ixpvlv_root, XPVLV *) /* free xpvlv list--shared by interpreters */ -PERLVAR(Ixpvbm_root, XPVBM *) /* free xpvbm list--shared by interpreters */ -PERLVAR(Ihe_root, HE *) /* free he list--shared by interpreters */ +PERLVAR(Ixiv_root, IV *) /* free xiv list */ +PERLVAR(Ixnv_root, NV *) /* free xnv list */ +PERLVAR(Ixrv_root, XRV *) /* free xrv list */ +PERLVAR(Ixpv_root, XPV *) /* free xpv list */ +PERLVAR(Ixpviv_root, XPVIV *) /* free xpviv list */ +PERLVAR(Ixpvnv_root, XPVNV *) /* free xpvnv list */ +PERLVAR(Ixpvcv_root, XPVCV *) /* free xpvcv list */ +PERLVAR(Ixpvav_root, XPVAV *) /* free xpvav list */ +PERLVAR(Ixpvhv_root, XPVHV *) /* free xpvhv list */ +PERLVAR(Ixpvmg_root, XPVMG *) /* free xpvmg list */ +PERLVAR(Ixpvlv_root, XPVLV *) /* free xpvlv list */ +PERLVAR(Ixpvbm_root, XPVBM *) /* free xpvbm list */ +PERLVAR(Ihe_root, HE *) /* free he list */ PERLVAR(Inice_chunk, char *) /* a nice chunk of memory to reuse */ PERLVAR(Inice_chunk_size, U32) /* how nice the chunk of memory is */ @@ -444,4 +444,26 @@ PERLVAR(IProc, struct IPerlProc*) PERLVAR(Iptr_table, PTR_TBL_t*) #endif +#ifdef USE_THREADS +PERLVAR(Ifdpid_mutex, perl_mutex) /* mutex for fdpid array */ +PERLVAR(Isv_lock_mutex, perl_mutex) /* mutex for SvLOCK macro */ +#endif + PERLVAR(Inullstash, HV *) /* illegal symbols end up here */ + +PERLVAR(Ixnv_arenaroot, XPV*) /* list of allocated xnv areas */ +PERLVAR(Ixrv_arenaroot, XPV*) /* list of allocated xrv areas */ +PERLVAR(Ixpv_arenaroot, XPV*) /* list of allocated xpv areas */ +PERLVAR(Ixpviv_arenaroot,XPVIV*) /* list of allocated xpviv areas */ +PERLVAR(Ixpvnv_arenaroot,XPVNV*) /* list of allocated xpvnv areas */ +PERLVAR(Ixpvcv_arenaroot,XPVCV*) /* list of allocated xpvcv areas */ +PERLVAR(Ixpvav_arenaroot,XPVAV*) /* list of allocated xpvav areas */ +PERLVAR(Ixpvhv_arenaroot,XPVHV*) /* list of allocated xpvhv areas */ +PERLVAR(Ixpvmg_arenaroot,XPVMG*) /* list of allocated xpvmg areas */ +PERLVAR(Ixpvlv_arenaroot,XPVLV*) /* list of allocated xpvlv areas */ +PERLVAR(Ixpvbm_arenaroot,XPVBM*) /* list of allocated xpvbm areas */ +PERLVAR(Ihe_arenaroot, XPV*) /* list of allocated he areas */ + +/* New variables must be added to the very end for binary compatibility. + * XSUB.h provides wrapper functions via perlapi.h that make this + * irrelevant, but not all code may be expected to #include XSUB.h. */ diff --git a/jpl/JNI/Makefile.PL b/jpl/JNI/Makefile.PL index 1a54b9d..754bde6 100644 --- a/jpl/JNI/Makefile.PL +++ b/jpl/JNI/Makefile.PL @@ -115,11 +115,12 @@ sub find_stuff { my ($candidates, $locations) = @_; - my $lib; + my ($pos,$lib); $wanted = sub { foreach my $name (@$candidates) { - if (/$name$/ and ! /green_threads/ and !/include-old/) { - $lib = $File::Find::name; + $pos = $File::Find::name; + if (/$name$/ && $pos !~ /green_threads/ && $pos !~ /include-old/) { + $lib = $pos; } } }; diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm index 8fd7d3b..c26db72 100644 --- a/lib/AutoLoader.pm +++ b/lib/AutoLoader.pm @@ -140,6 +140,11 @@ sub import { } } +sub unimport { + my $callpkg = caller; + eval "package $callpkg; sub AUTOLOAD;"; +} + 1; __END__ @@ -259,6 +264,12 @@ the package namespace. Variables pre-declared with this pragma will be visible to any autoloaded routines (but will not be invisible outside the package, unfortunately). +=head2 Not Using AutoLoader + +You can stop using AutoLoader by simply + + no AutoLoader; + =head2 B vs. B The B is similar in purpose to B: both delay the diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm index 0be3ae6..8640576 100644 --- a/lib/AutoSplit.pm +++ b/lib/AutoSplit.pm @@ -6,6 +6,7 @@ use Config qw(%Config); use Carp qw(carp); use File::Basename (); use File::Path qw(mkpath); +use File::Spec::Functions qw(curdir catfile); use strict; our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Verbose, $Keep, $Maxlen, $CheckForAutoloader, $CheckModTime); @@ -173,16 +174,23 @@ sub autosplit_lib_modules{ my(@modules) = @_; # list of Module names while(defined($_ = shift @modules)){ - s#::#/#g; # incase specified as ABC::XYZ + while (m#(.*?[^:])::([^:].*)#) { # in case specified as ABC::XYZ + $_ = catfile($1, $2); + } s|\\|/|g; # bug in ksh OS/2 s#^lib/##s; # incase specified as lib/*.pm + my($lib) = catfile(curdir(), "lib"); + if ($Is_VMS) { # may need to convert VMS-style filespecs + $lib =~ s#^\[\]#.\/#; + } + s#^$lib\W+##s; # incase specified as ./lib/*.pm if ($Is_VMS && /[:>\]]/) { # may need to convert VMS-style filespecs my ($dir,$name) = (/(.*])(.*)/s); $dir =~ s/.*lib[\.\]]//s; $dir =~ s#[\.\]]#/#g; $_ = $dir . $name; } - autosplit_file("lib/$_", "lib/auto", + autosplit_file(catfile($lib, $_), catfile($lib, "auto"), $Keep, $CheckForAutoloader, $CheckModTime); } 0; @@ -199,7 +207,7 @@ sub autosplit_file { local($/) = "\n"; # where to write output files - $autodir ||= "lib/auto"; + $autodir ||= catfile(curdir(), "lib", "auto"); if ($Is_VMS) { ($autodir = VMS::Filespec::unixpath($autodir)) =~ s|/\z||; $filename = VMS::Filespec::unixify($filename); # may have dirs @@ -245,6 +253,9 @@ sub autosplit_file { $def_package or die "Can't find 'package Name;' in $filename\n"; my($modpname) = _modpname($def_package); + if ($Is_VMS) { + $modpname = VMS::Filespec::unixify($modpname); # may have dirs + } # this _has_ to match so we have a reasonable timestamp file die "Package $def_package ($modpname.pm) does not ". @@ -264,11 +275,12 @@ sub autosplit_file { } } - print "AutoSplitting $filename ($autodir/$modpname)\n" + my($modnamedir) = catfile($autodir, $modpname); + print "AutoSplitting $filename ($modnamedir)\n" if $Verbose; - unless (-d "$autodir/$modpname"){ - mkpath("$autodir/$modpname",0,0777); + unless (-d "$modnamedir"){ + mkpath("$modnamedir",0,0777); } # We must try to deal with some SVR3 systems with a limit of 14 @@ -311,9 +323,10 @@ sub autosplit_file { push(@subnames, $fq_subname); my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3)); $modpname = _modpname($this_package); - mkpath("$autodir/$modpname",0,0777); - my($lpath) = "$autodir/$modpname/$lname.al"; - my($spath) = "$autodir/$modpname/$sname.al"; + my($modnamedir) = catfile($autodir, $modpname); + mkpath("$modnamedir",0,0777); + my($lpath) = catfile($modnamedir, "$lname.al"); + my($spath) = catfile($modnamedir, "$sname.al"); my $path; if (!$Is83 and open(OUT, ">$lpath")){ $path=$lpath; @@ -379,7 +392,7 @@ EOT opendir(OUTDIR,$dir); foreach (sort readdir(OUTDIR)){ next unless /\.al\z/; - my($file) = "$dir/$_"; + my($file) = catfile($dir, $_); $file = lc $file if $Is83 or $Is_VMS; next if $outfiles{$file}; print " deleting $file\n" if ($Verbose>=2); @@ -418,7 +431,9 @@ sub _modpname ($) { if ($^O eq 'MSWin32') { $modpname =~ s#::#\\#g; } else { - $modpname =~ s#::#/#g; + while ($modpname =~ m#(.*?[^:])::([^:].*)#) { + $modpname = catfile($1, $2); + } } $modpname; } diff --git a/lib/CGI/Util.pm b/lib/CGI/Util.pm index 0a5c48b..cb6dd8a 100644 --- a/lib/CGI/Util.pm +++ b/lib/CGI/Util.pm @@ -1,5 +1,13 @@ package CGI::Util; +=pod + +=head1 NAME + +CGI::Util - various utilities + +=cut + use strict; use vars '$VERSION','@EXPORT_OK','@ISA','$EBCDIC','@A2E'; require Exporter; diff --git a/lib/Cwd.pm b/lib/Cwd.pm index 9a92829..d86428c 100644 --- a/lib/Cwd.pm +++ b/lib/Cwd.pm @@ -70,7 +70,7 @@ kept up to date if all packages which use chdir import it from Cwd. use Carp; -$VERSION = '2.02'; +$VERSION = '2.03'; require Exporter; @ISA = qw(Exporter); @@ -200,63 +200,39 @@ sub chdir { 1; } -# Taken from Cwd.pm It is really getcwd with an optional -# parameter instead of '.' -# -sub abs_path -{ - my $start = @_ ? shift : '.'; - my($dotdots, $cwd, @pst, @cst, $dir, @tst); +# By Jeff "japhy" Pinyan (07/23/2000) +# usage: abs_path(PATHNAME) +# see the docs + +sub abs_path { + my $base = @_ ? $_[0] : "."; + my $path = ""; + my $file; + + do { + my @devino = (stat($base))[0,1] or + carp("stat($base): $!"), return; - unless (@cst = stat( $start )) - { - carp "stat($start): $!"; - return ''; + $base .= "/.."; + + opendir PREV, $base or carp("opendir($base): $!"), return; + while (defined($file = readdir PREV)) { + next if $file eq "." or $file eq ".."; + my @entry = (lstat("$base/$file"))[0,1] or + carp("lstat($base/$file): $!"), return; + last if $devino[0] == $entry[0] and $devino[1] == $entry[1]; } - $cwd = ''; - $dotdots = $start; - do - { - $dotdots .= '/..'; - @pst = @cst; - unless (opendir(PARENT, $dotdots)) - { - carp "opendir($dotdots): $!"; - return ''; - } - unless (@cst = stat($dotdots)) - { - carp "stat($dotdots): $!"; - closedir(PARENT); - return ''; - } - if ($pst[0] == $cst[0] && $pst[1] == $cst[1]) - { - $dir = undef; - } - else - { - do - { - unless (defined ($dir = readdir(PARENT))) - { - carp "readdir($dotdots): $!"; - closedir(PARENT); - return ''; - } - $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir")) - } - while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] || - $tst[1] != $pst[1]); - } - $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ; - closedir(PARENT); - } while (defined $dir); - chop($cwd) unless $cwd eq '/'; # drop the trailing / - $cwd; + closedir PREV; + + $path = (defined $file and $file) . "/$path"; + } while defined $file; + + length($path) > 1 and chop $path; + return $path; } + # added function alias for those of us more # used to the libc function. --tchrist 27-Jan-00 *realpath = \&abs_path; diff --git a/lib/English.pm b/lib/English.pm index f38c313..1ebc3de 100644 --- a/lib/English.pm +++ b/lib/English.pm @@ -9,6 +9,7 @@ English - use nice English (or awk) names for ugly punctuation variables =head1 SYNOPSIS + use English qw( -no_match_vars ) ; # Avoids regex performance penalty use English; ... if ($ERRNO =~ /denied/) { ... } @@ -27,29 +28,52 @@ $INPUT_RECORD_SEPARATOR if you are using the English module. See L for a complete list of these. -=head1 BUGS +=head1 PERFORMANCE -This module provokes sizeable inefficiencies for regular expressions, -due to unfortunate implementation details. If performance matters, -consider avoiding English. +This module can provoke sizeable inefficiencies for regular expressions, +due to unfortunate implementation details. If performance matters in +your application and you don't need $PREMATCH, $MATCH, or $POSTMATCH, +try doing + + use English qw( -no_match_vars ) ; + +. B =cut no warnings; +my $globbed_match ; + # Grandfather $NAME import sub import { my $this = shift; - my @list = @_; + my @list = grep { ! /^-no_match_vars$/ } @_ ; local $Exporter::ExportLevel = 1; + if ( @_ == @list ) { + *EXPORT = \@COMPLETE_EXPORT ; + $globbed_match ||= ( + eval q{ + *MATCH = *& ; + *PREMATCH = *` ; + *POSTMATCH = *' ; + 1 ; + } + || do { + require Carp ; + Carp::croak "Can't create English for match leftovers: $@" ; + } + ) ; + } + else { + *EXPORT = \@MINIMAL_EXPORT ; + } Exporter::import($this,grep {s/^\$/*/} @list); } -@EXPORT = qw( +@MINIMAL_EXPORT = qw( *ARG - *MATCH - *PREMATCH - *POSTMATCH *LAST_PAREN_MATCH *INPUT_LINE_NUMBER *NR @@ -102,15 +126,21 @@ sub import { @LAST_MATCH_END ); + +@MATCH_EXPORT = qw( + *MATCH + *PREMATCH + *POSTMATCH +); + +@COMPLETE_EXPORT = ( @MINIMAL_EXPORT, @MATCH_EXPORT ) ; + # The ground of all being. @ARG is deprecated (5.005 makes @_ lexical) *ARG = *_ ; # Matching. - *MATCH = *& ; - *PREMATCH = *` ; - *POSTMATCH = *' ; *LAST_PAREN_MATCH = *+ ; *LAST_MATCH_START = *-{ARRAY} ; *LAST_MATCH_END = *+{ARRAY} ; diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm index da22552..8e337d9 100644 --- a/lib/ExtUtils/MM_Unix.pm +++ b/lib/ExtUtils/MM_Unix.pm @@ -457,7 +457,7 @@ EOT push(@otherfiles, qw[./blib $(MAKE_APERL_FILE) $(INST_ARCHAUTODIR)/extralibs.all perlmain.c mon.out core core.*perl.*.? *perl.core so_locations pm_to_blib - *~ */*~ */*/*~ *$(OBJ_EXT) *$(LIB_EXT) perl.exe + *$(OBJ_EXT) *$(LIB_EXT) perl.exe $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def $(BASEEXT).exp ]); @@ -1249,11 +1249,6 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' next; } my($dev,$ino,$mode) = stat FIXIN; - # If they override perm_rwx, we won't notice it during fixin, - # because fixin is run through a new instance of MakeMaker. - # That is why we must run another CHMOD later. - $mode = oct($self->perm_rwx) unless $dev; - chmod $mode, $file; # Print out the new #! line (or equivalent). local $\; @@ -1261,7 +1256,15 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' print FIXOUT $shb, ; close FIXIN; close FIXOUT; - # can't rename open files on some DOSISH platforms + + # can't rename/chmod open files on some DOSISH platforms + + # If they override perm_rwx, we won't notice it during fixin, + # because fixin is run through a new instance of MakeMaker. + # That is why we must run another CHMOD later. + $mode = oct($self->perm_rwx) unless $dev; + chmod $mode, $file; + unless ( rename($file, "$file.bak") ) { warn "Can't rename $file to $file.bak: $!"; next; @@ -1276,6 +1279,7 @@ eval 'exec $interpreter $arg -S \$0 \${1+"\$\@"}' } unlink "$file.bak"; } continue { + close(FIXIN) if fileno(FIXIN); chmod oct($self->perm_rwx), $file or die "Can't reset permissions for $file: $!\n"; system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';; diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm index 1e6c61a..d21a56a 100644 --- a/lib/ExtUtils/MM_VMS.pm +++ b/lib/ExtUtils/MM_VMS.pm @@ -626,7 +626,7 @@ INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR} if ($self->has_link_code()) { push @m,' INST_STATIC = $(INST_ARCHAUTODIR)$(BASEEXT)$(LIB_EXT) -INST_DYNAMIC = $(INST_ARCHAUTODIR)$(BASEEXT).$(DLEXT) +INST_DYNAMIC = $(INST_ARCHAUTODIR)$(DLBASE).$(DLEXT) INST_BOOT = $(INST_ARCHAUTODIR)$(BASEEXT).bs '; } else { diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm index 9906fd5..bef12b5 100644 --- a/lib/ExtUtils/MakeMaker.pm +++ b/lib/ExtUtils/MakeMaker.pm @@ -82,7 +82,7 @@ if ($Is_OS2) { require ExtUtils::MM_OS2; } if ($Is_Mac) { - require ExtUtils::MM_Mac; + require ExtUtils::MM_MacOS; } if ($Is_Win32) { require ExtUtils::MM_Win32; diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap index a34cd4f..0260678 100644 --- a/lib/ExtUtils/typemap +++ b/lib/ExtUtils/typemap @@ -1,4 +1,3 @@ -# $Header: /home/rmb1/misc/CVS/perl5.005_61/lib/ExtUtils/typemap,v 1.3 1999/09/13 09:46:43 rmb1 Exp $ # basic C types int T_IV unsigned T_UV diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp index 5a71e89..1e9ff45 100755 --- a/lib/ExtUtils/xsubpp +++ b/lib/ExtUtils/xsubpp @@ -288,7 +288,7 @@ $END = "!End!\n\n"; # "impossible" keyword (multiple newline) # Match an XS keyword $BLOCK_re= '\s*(' . join('|', qw( REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT - CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE + CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL )) . "|$END)\\s*:"; @@ -573,6 +573,15 @@ sub GetAliases if $line ; } +sub ATTRS_handler () +{ + for (; !/^$BLOCK_re/o; $_ = shift(@line)) { + next unless /\S/; + TrimWhitespace($_) ; + push @Attributes, $_; + } +} + sub ALIAS_handler () { for (; !/^$BLOCK_re/o; $_ = shift(@line)) { @@ -847,7 +856,14 @@ EOM print("#line 1 \"$filename\"\n") if $WantLineNumbers; +firstmodule: while (<$FH>) { + if (/^=/) { + do { + next firstmodule if /^=cut\s*$/; + } while (<$FH>); + &Exit; + } last if ($Module, $Package, $Prefix) = /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; @@ -886,6 +902,16 @@ sub fetch_para { } for(;;) { + # Skip embedded PODs + while ($lastline =~ /^=/) { + while ($lastline = <$FH>) { + last if ($lastline =~ /^=cut\s*$/); + } + death ("Error: Unterminated pod") unless $lastline; + $lastline = <$FH>; + chomp $lastline; + $lastline =~ s/^\s+$//; + } if ($lastline !~ /^\s*#/ || # CPP directives: # ANSI: if ifdef ifndef elif else endif define undef @@ -1039,7 +1065,7 @@ while (fetch_para()) { last; } $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; - %XsubAliases = %XsubAliasValues = %Interfaces = (); + %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = (); $DoSetMagic = 1; $orig_args =~ s/\\\s*/ /g; # process line continuations @@ -1210,7 +1236,7 @@ EOF $gotRETVAL = 0; INPUT_handler() ; - process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ; + process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE") ; print Q<<"EOF" if $ScopeThisXSUB; # ENTER; @@ -1252,7 +1278,7 @@ EOF } print $deferred; - process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; + process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ; if (check_keyword("PPCODE")) { print_section(); @@ -1296,7 +1322,7 @@ EOF # $wantRETVAL set if 'RETVAL =' autogenerated ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; undef %outargs ; - process_keyword("POSTCALL|OUTPUT|ALIAS|PROTOTYPE"); + process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE"); # all OUTPUT done, so now push the return value on the stack if ($gotRETVAL && $RETVAL_code) { @@ -1341,7 +1367,7 @@ EOF generate_output($var_types{$_}, $num++, $_, 0, 1) for @in_out; # do cleanup - process_keyword("CLEANUP|ALIAS|PROTOTYPE") ; + process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ; print Q<<"EOF" if $ScopeThisXSUB; # ]] @@ -1431,6 +1457,12 @@ EOF EOF } } + elsif (@Attributes) { + push(@InitFileCode, Q<<"EOF"); +# cv = newXS(\"$pname\", XS_$Full_func_name, file); +# apply_attrs_string("$Package", cv, "@Attributes", 0); +EOF + } elsif ($interface) { while ( ($name, $value) = each %Interfaces) { $name = "$Package\::$name" unless $name =~ /::/; diff --git a/lib/File/Find.pm b/lib/File/Find.pm index ac73f1b..a9f190c 100644 --- a/lib/File/Find.pm +++ b/lib/File/Find.pm @@ -373,7 +373,7 @@ sub _find_opt { $name = $abs_dir . $_; - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } @@ -429,7 +429,7 @@ sub _find_dir($$$) { $_= ($no_chdir ? $dir_name : $dir_rel ); # prune may happen here $prune= 0; - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" next if $prune; } @@ -472,7 +472,7 @@ sub _find_dir($$$) { $name = $dir_pref . $FN; $_ = ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } @@ -496,13 +496,13 @@ sub _find_dir($$$) { else { $name = $dir_pref . $FN; $_= ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } else { $name = $dir_pref . $FN; $_= ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } } @@ -528,7 +528,7 @@ sub _find_dir($$$) { if ( substr($_,-2) eq '/.' ) { s|/\.$||; } - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } else { push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; last; @@ -584,13 +584,25 @@ sub _find_dir_symlnk($$$) { while (defined $SE) { unless ($bydepth) { + # change to parent directory + unless ($no_chdir) { + my $udir = $pdir_loc; + if ($untaint) { + $udir = $1 if $pdir_loc =~ m|$untaint_pat|; + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + next; + } + } $dir= $p_dir; $name= $dir_name; $_= ($no_chdir ? $dir_name : $dir_rel ); $fullname= $dir_loc; # prune may happen here $prune= 0; - &$wanted_callback; + lstat($_); # make sure file tests with '_' work + { &$wanted_callback }; # protect against wild "next" next if $prune; } @@ -640,7 +652,7 @@ sub _find_dir_symlnk($$$) { $fullname = $new_loc; $name = $dir_pref . $FN; $_ = ($no_chdir ? $name : $FN); - &$wanted_callback; + { &$wanted_callback }; # protect against wild "next" } } @@ -673,7 +685,8 @@ sub _find_dir_symlnk($$$) { s|/\.$||; } - &$wanted_callback; + lstat($_); # make sure file tests with '_' work + { &$wanted_callback }; # protect against wild "next" } else { push @Stack,[$dir_loc, $pdir_loc, $p_dir, $dir_rel,-1] if $bydepth; last; @@ -721,7 +734,8 @@ if ($^O eq 'VMS') { } $File::Find::dont_use_nlink = 1 - if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; + if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' || + $^O eq 'cygwin'; # Set dont_use_nlink in your hint file if your system's stat doesn't # report the number of links in a directory as an indication diff --git a/lib/File/Spec.pm b/lib/File/Spec.pm index ed26d76..40503c4 100644 --- a/lib/File/Spec.pm +++ b/lib/File/Spec.pm @@ -3,7 +3,7 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '0.81'; +$VERSION = 0.82 ; my %module = (MacOS => 'Mac', MSWin32 => 'Win32', diff --git a/lib/File/Spec/Mac.pm b/lib/File/Spec/Mac.pm index 5315d92..9ef55ec 100644 --- a/lib/File/Spec/Mac.pm +++ b/lib/File/Spec/Mac.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.1'; +$VERSION = '1.2'; @ISA = qw(File::Spec::Unix); @@ -192,12 +192,16 @@ folder named "HD" in the current working directory on a drive named "HD"), relative wins. Use ":" in the appropriate place in the path if you want to distinguish unambiguously. +As a special case, the file name '' is always considered to be absolute. + =cut sub file_name_is_absolute { my ($self,$file) = @_; if ($file =~ /:/) { return ($file !~ m/^:/s); + } elsif ( $file eq '' ) { + return 1 ; } else { return (! -e ":$file"); } @@ -307,6 +311,12 @@ sub catpath { =item abs2rel +See L for general documentation. + +Unlike Cabs2rel()>, this function will make +checks against the local filesystem if necessary. See +L for details. + =cut sub abs2rel { @@ -344,31 +354,15 @@ sub abs2rel { =item rel2abs -Converts a relative path to an absolute path. - - $abs_path = File::Spec->rel2abs( $destination ) ; - $abs_path = File::Spec->rel2abs( $destination, $base ) ; - -If $base is not present or '', then L is used. If $base is relative, -then it is converted to absolute form using L. This means that it -is taken to be relative to L. - -On systems with the concept of a volume, this assumes that both paths -are on the $base volume, and ignores the $destination volume. - -On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be -directories. - -If $path is absolute, it is cleaned up and returned using L. - -Based on code written by Shigio Yamaguchi. +See L for general documentation. -No checks against the filesystem are made. +Unlike Crel2abs()>, this function will make +checks against the local filesystem if necessary. See +L for details. =cut -sub rel2abs($;$;) { +sub rel2abs { my ($self,$path,$base ) = @_; if ( ! $self->file_name_is_absolute( $path ) ) { diff --git a/lib/File/Spec/Unix.pm b/lib/File/Spec/Unix.pm index 6ca26d7..a81c533 100644 --- a/lib/File/Spec/Unix.pm +++ b/lib/File/Spec/Unix.pm @@ -3,7 +3,7 @@ package File::Spec::Unix; use strict; use vars qw($VERSION); -$VERSION = '1.1'; +$VERSION = '1.2'; use Cwd; @@ -165,7 +165,12 @@ sub case_tolerant { =item file_name_is_absolute -Takes as argument a path and returns true, if it is an absolute path. +Takes as argument a path and returns true if it is an absolute path. + +This does not consult the local filesystem on Unix, Win32, or OS/2. It +does sometimes on MacOS (see L). +It does consult the working environment for VMS (see +L). =cut @@ -311,8 +316,8 @@ sub catpath { Takes a destination path and an optional base path returns a relative path from the base path to the destination path: - $rel_path = File::Spec->abs2rel( $destination ) ; - $rel_path = File::Spec->abs2rel( $destination, $base ) ; + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; If $base is not present or '', then L is used. If $base is relative, then it is converted to absolute form using L. This means that it @@ -328,9 +333,13 @@ directories. If $path is relative, it is converted to absolute form using L. This means that it is taken to be relative to L. -Based on code written by Shigio Yamaguchi. +No checks against the filesystem are made on most systems. On MacOS, +the filesystem may be consulted (see +L). On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. -No checks against the filesystem are made. +Based on code written by Shigio Yamaguchi. =cut @@ -388,15 +397,15 @@ sub abs2rel { Converts a relative path to an absolute path. - $abs_path = File::Spec->rel2abs( $destination ) ; - $abs_path = File::Spec->rel2abs( $destination, $base ) ; + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; If $base is not present or '', then L is used. If $base is relative, then it is converted to absolute form using L. This means that it is taken to be relative to L. On systems with the concept of a volume, this assumes that both paths -are on the $base volume, and ignores the $destination volume. +are on the $base volume, and ignores the $path volume. On systems that have a grammar that indicates filenames, this ignores the $base filename as well. Otherwise all path components are assumed to be @@ -404,13 +413,17 @@ directories. If $path is absolute, it is cleaned up and returned using L. -Based on code written by Shigio Yamaguchi. +No checks against the filesystem are made on most systems. On MacOS, +the filesystem may be consulted (see +L). On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. -No checks against the filesystem are made. +Based on code written by Shigio Yamaguchi. =cut -sub rel2abs($;$;) { +sub rel2abs { my ($self,$path,$base ) = @_; # Clean up $path diff --git a/lib/File/Spec/VMS.pm b/lib/File/Spec/VMS.pm index cc06ca6..60b0ec8 100644 --- a/lib/File/Spec/VMS.pm +++ b/lib/File/Spec/VMS.pm @@ -265,7 +265,7 @@ sub rootdir { Returns a string representation of the first writable directory from the following list or '' if none are writable: - sys$scratch + sys$scratch: $ENV{TMPDIR} =cut @@ -273,7 +273,7 @@ from the following list or '' if none are writable: my $tmpdir; sub tmpdir { return $tmpdir if defined $tmpdir; - foreach ('sys$scratch', $ENV{TMPDIR}) { + foreach ('sys$scratch:', $ENV{TMPDIR}) { next unless defined && -d && -w _; $tmpdir = $_; last; @@ -451,7 +451,7 @@ Use VMS syntax when converting filespecs. =cut -sub rel2abs($;$;) { +sub rel2abs { my $self = shift ; return vmspath(File::Spec::Unix::rel2abs( $self, @_ )) if ( join( '', @_ ) =~ m{/} ) ; diff --git a/lib/File/Spec/Win32.pm b/lib/File/Spec/Win32.pm index b8fe37b..f5d6cda 100644 --- a/lib/File/Spec/Win32.pm +++ b/lib/File/Spec/Win32.pm @@ -5,7 +5,7 @@ use Cwd; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '1.1'; +$VERSION = '1.2'; @ISA = qw(File::Spec::Unix); @@ -242,34 +242,6 @@ sub catpath { } -=item abs2rel - -Takes a destination path and an optional base path returns a relative path -from the base path to the destination path: - - $rel_path = File::Spec->abs2rel( $destination ) ; - $rel_path = File::Spec->abs2rel( $destination, $base ) ; - -If $base is not present or '', then L is used. If $base is relative, -then it is converted to absolute form using L. This means that it -is taken to be relative to L. - -On systems with the concept of a volume, this assumes that both paths -are on the $destination volume, and ignores the $base volume. - -On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be -directories. - -If $path is relative, it is converted to absolute form using L. -This means that it is taken to be relative to L. - -Based on code written by Shigio Yamaguchi. - -No checks against the filesystem are made. - -=cut - sub abs2rel { my($self,$path,$base) = @_; @@ -339,33 +311,8 @@ sub abs2rel { ) ; } -=item rel2abs - -Converts a relative path to an absolute path. - - $abs_path = File::Spec->rel2abs( $destination ) ; - $abs_path = File::Spec->rel2abs( $destination, $base ) ; - -If $base is not present or '', then L is used. If $base is relative, -then it is converted to absolute form using L. This means that it -is taken to be relative to L. - -Assumes that both paths are on the $base volume, and ignores the -$destination volume. - -On systems that have a grammar that indicates filenames, this ignores the -$base filename as well. Otherwise all path components are assumed to be -directories. - -If $path is absolute, it is cleaned up and returned using L. - -Based on code written by Shigio Yamaguchi. - -No checks against the filesystem are made. - -=cut -sub rel2abs($;$;) { +sub rel2abs { my ($self,$path,$base ) = @_; if ( ! $self->file_name_is_absolute( $path ) ) { diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm index 736ef3f..aac8b7a 100644 --- a/lib/File/Temp.pm +++ b/lib/File/Temp.pm @@ -92,6 +92,10 @@ use File::Path qw/ rmtree /; use Fcntl 1.03; use Errno qw( EEXIST ENOENT ENOTDIR EINVAL ); +# Need the Symbol package if we are running older perl +require Symbol if $] < 5.006; + + # use 'our' on v5.6.0 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG); @@ -99,8 +103,6 @@ $DEBUG = 0; # We are exporting functions -#require Exporter; -#@ISA = qw/Exporter/; use base qw/Exporter/; # Export list - to allow fine tuning of export table @@ -111,7 +113,7 @@ use base qw/Exporter/; tmpnam tmpfile mktemp - mkstemp + mkstemp mkstemps mkdtemp unlink0 @@ -129,13 +131,13 @@ Exporter::export_tags('POSIX','mktemp'); # Version number -$VERSION = '0.07'; +$VERSION = '0.09'; # This is a list of characters that can be used in random filenames my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k l m n o p q r s t u v w x y z - 0 1 2 3 4 5 6 7 8 9 _ + 0 1 2 3 4 5 6 7 8 9 _ /); # Maximum number of tries to make a temp file before failing @@ -155,12 +157,25 @@ use constant STANDARD => 0; use constant MEDIUM => 1; use constant HIGH => 2; +# OPENFLAGS. If we defined the flag to use with Sysopen here this gives +# us an optimisation when many temporary files are requested + +my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; + +for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 }; +} + + + # INTERNAL ROUTINES - not to be used outside of package # Generic routine for getting a temporary filename # modelled on OpenBSD _gettemp() in mktemp.c -# The template must contain X's that are to be replaced +# The template must contain X's that are to be replaced # with the random values # Arguments: @@ -216,7 +231,7 @@ sub _gettemp { # Read the options and merge with defaults %options = (%options, @_) if @_; - + # Can not open the file and make a directory in a single call if ($options{"open"} && $options{"mkdir"}) { carp "File::Temp::_gettemp: doopen and domkdir can not both be true\n"; @@ -268,11 +283,16 @@ sub _gettemp { $parent = File::Spec->curdir; } else { - # Put it back together without the last one - $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + if ($^O eq 'VMS') { # need volume to avoid relative dir spec + $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); + } else { - # ...and attach the volume (no filename) - $parent = File::Spec->catpath($volume, $parent, ''); + # Put it back together without the last one + $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); + + # ...and attach the volume (no filename) + $parent = File::Spec->catpath($volume, $parent, ''); + } } @@ -296,7 +316,7 @@ sub _gettemp { # that does not exist or is not writable unless (-d $parent && -w _) { - carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory" + carp "File::Temp::_gettemp: Parent directory ($parent) is not a directory" . " or is not writable\n"; return (); } @@ -320,19 +340,18 @@ sub _gettemp { # Calculate the flags that we wish to use for the sysopen # Some of these are not always available - my $openflags; - if ($options{"open"}) { +# my $openflags; +# if ($options{"open"}) { # Default set - $openflags = O_CREAT | O_EXCL | O_RDWR; +# $openflags = O_CREAT | O_EXCL | O_RDWR; - for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { - my ($bit, $func) = (0, "Fcntl::O_" . $oflag); - no strict 'refs'; - $openflags |= $bit if eval { $bit = &$func(); 1 }; - } +# for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/) { +# my ($bit, $func) = (0, "Fcntl::O_" . $oflag); +# no strict 'refs'; +# $openflags |= $bit if eval { $bit = &$func(); 1 }; +# } - } - +# } # Now try MAX_TRIES time to open the file for (my $i = 0; $i < MAX_TRIES; $i++) { @@ -343,7 +362,6 @@ sub _gettemp { # If we are running before perl5.6.0 we can not auto-vivify if ($] < 5.006) { - require Symbol; $fh = &Symbol::gensym; } @@ -359,7 +377,7 @@ sub _gettemp { umask(066); # Attempt to open the file - if ( sysopen($fh, $path, $openflags, 0600) ) { + if ( sysopen($fh, $path, $OPENFLAGS, 0600) ) { # Reset umask umask($umask); @@ -419,10 +437,10 @@ sub _gettemp { return (undef, $path) unless -e $path; - # Try again until MAX_TRIES + # Try again until MAX_TRIES } - + # Did not successfully open the tempfile/dir # so try again with a different set of random letters # No point in trying to increment unless we have only @@ -449,7 +467,7 @@ sub _gettemp { # Check for out of control looping if ($counter > $MAX_GUESS) { - carp "Tried to get a new temp name different to the previous value$MAX_GUESS times.\nSomething wrong with template?? ($template)"; + carp "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; return (); } @@ -469,6 +487,10 @@ sub _gettemp { # No arguments. Return value is the random character +# No longer called since _replace_XX runs a few percent faster if +# I inline the code. This is important if we are creating thousands of +# temporary files. + sub _randchar { $CHARS[ int( rand( $#CHARS ) ) ]; @@ -497,18 +519,18 @@ sub _replace_XX { # Don't want to always use substr when not required though. if ($ignore) { - substr($path, 0, - $ignore) =~ s/X(?=X*\z)/_randchar()/ge; + substr($path, 0, - $ignore) =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; } else { - $path =~ s/X(?=X*\z)/_randchar()/ge; + $path =~ s/X(?=X*\z)/$CHARS[ int( rand( $#CHARS ) ) ]/ge; } return $path; } # internal routine to check to see if the directory is safe -# First checks to see if the directory is not owned by the +# First checks to see if the directory is not owned by the # current user or root. Then checks to see if anyone else -# can write to the directory and if so, checks to see if +# can write to the directory and if so, checks to see if # it has the sticky bit set # Will not work on systems that do not support sticky bit @@ -530,6 +552,7 @@ sub _is_safe { # Stat path my @info = stat($path); return 0 unless scalar(@info); + return 1 if $^O eq 'VMS'; # owner delete control at file level # Check to see whether owner is neither superuser (or a system uid) nor me # Use the real uid from the $< variable @@ -567,6 +590,7 @@ sub _is_verysafe { require POSIX; my $path = shift; + return 1 if $^O eq 'VMS'; # owner delete control at file level # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined # and If it is not there do the extensive test @@ -626,19 +650,48 @@ sub _is_verysafe { # platform for files that are currently open. # Returns true if we can, false otherwise. -# Currently WinNT can not unlink an opened file +# Currently WinNT, OS/2 and VMS can not unlink an opened file +# On VMS this is because the O_EXCL flag is used to open the +# temporary file. Currently I do not know enough about the issues +# on VMS to decide whether O_EXCL is a requirement. sub _can_unlink_opened_file { - - $^O ne 'MSWin32' ? 1 : 0; + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS') { + return 0; + } else { + return 1; + } } +# internal routine to decide which security levels are allowed +# see safe_level() for more information on this + +# Controls whether the supplied security level is allowed + +# $cando = _can_do_level( $level ) + +sub _can_do_level { + + # Get security level + my $level = shift; + + # Always have to be able to do STANDARD + return 1 if $level == STANDARD; + + # Currently, the systems that can do HIGH or MEDIUM are identical + if ( $^O eq 'MSWin32' || $^O eq 'os2') { + return 0; + } else { + return 1; + } + +} # This routine sets up a deferred unlinking of a specified # filename and filehandle. It is used in the following cases: -# - Called by unlink0 if an opend file can not be unlinked +# - Called by unlink0 if an opened file can not be unlinked # - Called by tempfile() if files are to be removed on shutdown # - Called by tempdir() if directories are to be removed on shutdown @@ -650,71 +703,84 @@ sub _can_unlink_opened_file { # - isdir (flag to indicate that we are being given a directory) # [and hence no filehandle] -# Status is not referred since all the magic is done with END blocks +# Status is not referred to since all the magic is done with and END block -sub _deferred_unlink { +{ + # Will set up two lexical variables to contain all the files to be + # removed. One array for files, another for directories + # They will only exist in this block + # This means we only have to set up a single END block to remove all files + # @files_to_unlink contains an array ref with the filehandle and filename + my (@files_to_unlink, @dirs_to_unlink); + + # Set up an end block to use these arrays + END { + # Files + foreach my $file (@files_to_unlink) { + # close the filehandle without checking its state + # in order to make real sure that this is closed + # if its already closed then I dont care about the answer + # probably a better way to do this + close($file->[0]); # file handle is [0] + + if (-f $file->[1]) { # file name is [1] + unlink $file->[1] or warn "Error removing ".$file->[1]; + } + } + # Dirs + foreach my $dir (@dirs_to_unlink) { + if (-d $dir) { + rmtree($dir, $DEBUG, 1); + } + } - croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' - unless scalar(@_) == 3; - my ($fh, $fname, $isdir) = @_; + } - warn "Setting up deferred removal of $fname\n" - if $DEBUG; + # This is the sub called to register a file for deferred unlinking + # This could simply store the input parameters and defer everything + # until the END block. For now we do a bit of checking at this + # point in order to make sure that (1) we have a file/dir to delete + # and (2) we have been called with the correct arguments. + sub _deferred_unlink { - # If we have a directory, check that it is a directory - if ($isdir) { + croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' + unless scalar(@_) == 3; - if (-d $fname) { + my ($fh, $fname, $isdir) = @_; - # Directory exists so set up END block - # (quoted to preserve lexical variables) - eval q{ - END { - if (-d $fname) { - rmtree($fname, $DEBUG, 1); - } - } - 1; - } || die; + warn "Setting up deferred removal of $fname\n" + if $DEBUG; - } else { - carp "Request to remove directory $fname could not be completed since it does not exists!\n"; - } + # If we have a directory, check that it is a directory + if ($isdir) { + if (-d $fname) { - } else { + # Directory exists so store it + push (@dirs_to_unlink, $fname); - if (-f $fname) { - - # dile exists so set up END block - # (quoted to preserve lexical variables) - eval q{ - END { - # close the filehandle without checking its state - # in order to make real sure that this is closed - # if its already closed then I dont care about the answer - # probably a better way to do this - close($fh); - - if (-f $fname) { - unlink $fname - || warn "Error removing $fname"; - } - } - 1; - } || die; + } else { + carp "Request to remove directory $fname could not be completed since it does not exists!\n"; + } } else { - carp "Request to remove file $fname could not be completed since it is not there!\n"; - } + if (-f $fname) { + + # file exists so store handle and name for later removal + push(@files_to_unlink, [$fh, $fname]); + + } else { + carp "Request to remove file $fname could not be completed since it is not there!\n"; + } + + } - } -} +} =head1 FUNCTIONS @@ -807,7 +873,7 @@ sub tempfile { } - # Construct the template + # Construct the template # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc # functions or simply constructing a template and using _gettemp() @@ -829,11 +895,11 @@ sub tempfile { $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); } else { - + $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); } - + } # Now add a suffix @@ -846,13 +912,13 @@ sub tempfile { "open" => $options{'OPEN'}, "mkdir"=> 0 , "suffixlen" => length($options{'SUFFIX'}), - ) ); + ) ); # Set up an exit handler that can do whatever is right for the # system. Do not check return status since this is all done with # END blocks _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; - + # Return if (wantarray()) { @@ -867,7 +933,7 @@ sub tempfile { # Unlink the file. It is up to unlink0 to decide what to do with # this (whether to unlink now or to defer until later) unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; - + # Return just the filehandle. return $fh; } @@ -985,26 +1051,31 @@ sub tempdir { $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); } else { - + $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); } - + } # Create the directory my $tempdir; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } croak "Error in tempdir() using $template" unless ((undef, $tempdir) = _gettemp($template, - "open" => 0, + "open" => 0, "mkdir"=> 1 , - "suffixlen" => 0, - ) ); - + "suffixlen" => $suffixlen, + ) ); + # Install exit handler; must be dynamic to get lexical - if ( $options{'CLEANUP'} && -d $tempdir) { + if ( $options{'CLEANUP'} && -d $tempdir) { _deferred_unlink(undef, $tempdir, 1); - } + } # Return the dir name return $tempdir; @@ -1046,8 +1117,8 @@ sub mkstemp { my ($fh, $path); croak "Error in mkstemp using $template" - unless (($fh, $path) = _gettemp($template, - "open" => 1, + unless (($fh, $path) = _gettemp($template, + "open" => 1, "mkdir"=> 0 , "suffixlen" => 0, ) ); @@ -1085,7 +1156,7 @@ sub mkstemps { my $suffix = shift; $template .= $suffix; - + my ($fh, $path); croak "Error in mkstemps using $template" unless (($fh, $path) = _gettemp($template, @@ -1122,15 +1193,19 @@ sub mkdtemp { croak "Usage: mkdtemp(template)" if scalar(@_) != 1; - - my $template = shift; + my $template = shift; + my $suffixlen = 0; + if ($^O eq 'VMS') { # dir names can end in delimiters + $template =~ m/([\.\]:>]+)$/; + $suffixlen = length($1); + } my ($junk, $tmpdir); croak "Error creating temp directory from template $template\n" unless (($junk, $tmpdir) = _gettemp($template, - "open" => 0, + "open" => 0, "mkdir"=> 1 , - "suffixlen" => 0, + "suffixlen" => $suffixlen, ) ); return $tmpdir; @@ -1158,7 +1233,7 @@ sub mktemp { my ($tmpname, $junk); croak "Error getting name to temp file from template $template\n" unless (($junk, $tmpname) = _gettemp($template, - "open" => 0, + "open" => 0, "mkdir"=> 0 , "suffixlen" => 0, ) ); @@ -1217,7 +1292,7 @@ sub tmpnam { # Use a ten character template and append to tmpdir my $template = File::Spec->catfile($tmpdir, TEMPXXX); - + if (wantarray() ) { return mkstemp($template); } else { @@ -1320,11 +1395,11 @@ occasions this is not required. On some platforms, for example Windows NT, it is not possible to unlink an open file (the file must be closed first). On those -platforms, the actual unlinking is deferred until the program ends -and good status is returned. A check is still performed to make sure that -the filehandle and filename are pointing to the same thing (but not at the time -the end block is executed since the deferred removal may not have access to -the filehandle). +platforms, the actual unlinking is deferred until the program ends and +good status is returned. A check is still performed to make sure that +the filehandle and filename are pointing to the same thing (but not at +the time the end block is executed since the deferred removal may not +have access to the filehandle). Additionally, on Windows NT not all the fields returned by stat() can be compared. For example, the C and C fields seem to be different @@ -1334,6 +1409,10 @@ C, presumably because of caching issues even when using autoflush (this is usually overcome by waiting a while after writing to the tempfile before attempting to C it). +Finally, on NFS file systems the link count of the file handle does +not always go to zero immediately after unlinking. Currently, this +command is expected to fail on NFS disks. + =cut sub unlink0 { @@ -1352,7 +1431,7 @@ sub unlink0 { if ($fh[3] > 1 && $^W) { carp "unlink0: fstat found too many links; SB=@fh"; - } + } # Stat the path my @path = stat $path; @@ -1360,12 +1439,12 @@ sub unlink0 { unless (@path) { carp "unlink0: $path is gone already" if $^W; return; - } + } # this is no longer a file, but may be a directory, or worse unless (-f _) { confess "panic: $path is no longer a file: SB=@fh"; - } + } # Do comparison of each member of the array # On WinNT dev and rdev seem to be different @@ -1375,17 +1454,22 @@ sub unlink0 { my @okstat = (0..$#fh); # Use all by default if ($^O eq 'MSWin32') { @okstat = (1,2,3,4,5,7,8,9,10); + } elsif ($^O eq 'os2') { + @okstat = (0, 2..$#fh); } # Now compare each entry explicitly by number for (@okstat) { print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; - unless ($fh[$_] == $path[$_]) { + # Use eq rather than == since rdev, blksize, and blocks (6, 11, + # and 12) will be '' on platforms that do not support them. This + # is fine since we are only comparing integers. + unless ($fh[$_] eq $path[$_]) { warn "Did not match $_ element of stat\n" if $DEBUG; return 0; } } - + # attempt remove the file (does not work on some platforms) if (_can_unlink_opened_file()) { # XXX: do *not* call this on a directory; possible race @@ -1468,7 +1552,21 @@ run with MEDIUM or HIGH security. This is simply because the safety tests use functions from L that are not available in older versions of perl. The problem is that the version number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though -they are different versions..... +they are different versions. + +On systems that do not support the HIGH or MEDIUM safety levels +(for example Win NT or OS/2) any attempt to change the level will +be ignored. The decision to ignore rather than raise an exception +allows portable programs to be written with high security in mind +for the systems that can support this without those programs failing +on systems where the extra tests are irrelevant. + +If you really need to see whether the change has been accepted +simply examine the return value of C. + + $newlevel = File::Temp->safe_level( File::Temp::HIGH ); + die "Could not change to high security" + if $newlevel != File::Temp::HIGH; =cut @@ -1482,11 +1580,14 @@ they are different versions..... if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n"; } else { + # Dont allow this on perl 5.005 or earlier if ($] < 5.006 && $level != STANDARD) { # Cant do MEDIUM or HIGH checks croak "Currently requires perl 5.006 or newer to do the safe checks"; } - $LEVEL = $level; + # Check that we are allowed to change level + # Silently ignore if we can not. + $LEVEL = $level if _can_do_level($level); } } return $LEVEL; diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm index 46ebd68..5c9c69a 100644 --- a/lib/IPC/Open3.pm +++ b/lib/IPC/Open3.pm @@ -44,6 +44,9 @@ by an autogenerated filehandle. If so, you must pass a valid lvalue in the parameter slot so it can be overwritten in the caller, or an exception will be raised. +The filehandles may also be integers, in which case they are understood +as file descriptors. + open3() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C. However, C failures in the child are not detected. You'll have to @@ -84,6 +87,7 @@ The order of arguments differs from that of open2(). # fixed for 5.001 by Ulrich Kunitz # ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career # fixed for autovivving FHs, tchrist again +# allow fd numbers to be used, by Frank Tobin # # $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ # @@ -136,6 +140,15 @@ sub xclose { close $_[0] or croak "$Me: close($_[0]) failed: $!"; } +sub fh_is_fd { + return $_[0] =~ /\A=?(\d+)\z/; +} + +sub xfileno { + return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd + return fileno $_[0]; +} + my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32'; sub _open3 { @@ -164,9 +177,9 @@ sub _open3 { $dup_err = ($dad_err =~ s/^[<>]&//); # force unqualified filehandles into caller's package - $dad_wtr = qualify $dad_wtr, $package; - $dad_rdr = qualify $dad_rdr, $package; - $dad_err = qualify $dad_err, $package; + $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr); + $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr); + $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err); my $kid_rdr = gensym; my $kid_wtr = gensym; @@ -181,20 +194,20 @@ sub _open3 { # If she wants to dup the kid's stderr onto her stdout I need to # save a copy of her stdout before I put something else there. if ($dad_rdr ne $dad_err && $dup_err - && fileno($dad_err) == fileno(STDOUT)) { + && xfileno($dad_err) == fileno(STDOUT)) { my $tmp = gensym; xopen($tmp, ">&$dad_err"); $dad_err = $tmp; } if ($dup_wtr) { - xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr); + xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr); } else { xclose $dad_wtr; xopen \*STDIN, "<&=" . fileno $kid_rdr; } if ($dup_rdr) { - xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr); + xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr); } else { xclose $dad_rdr; xopen \*STDOUT, ">&=" . fileno $kid_wtr; @@ -204,8 +217,8 @@ sub _open3 { # I have to use a fileno here because in this one case # I'm doing a dup but the filehandle might be a reference # (from the special case above). - xopen \*STDERR, ">&" . fileno $dad_err - if fileno(STDERR) != fileno($dad_err); + xopen \*STDERR, ">&" . xfileno($dad_err) + if fileno(STDERR) != xfileno($dad_err); } else { xclose $dad_err; xopen \*STDERR, ">&=" . fileno $kid_err; diff --git a/lib/Net/Ping.pm b/lib/Net/Ping.pm index 2713383..40da9f3 100644 --- a/lib/Net/Ping.pm +++ b/lib/Net/Ping.pm @@ -442,7 +442,11 @@ hosts on a network. A ping object is first created with optional parameters, a variable number of hosts may be pinged multiple times and then the connection is closed. -You may choose one of three different protocols to use for the ping. +You may choose one of three different protocols to use for the +ping. The "udp" protocol is the default. Note that a live remote host +may still fail to be pingable by one or more of these protocols. For +example, www.microsoft.com is generally alive but not pingable. + With the "tcp" protocol the ping() method attempts to establish a connection to the remote host's echo port. If the connection is successfully established, the remote host is considered reachable. No diff --git a/lib/Pod/Html.pm b/lib/Pod/Html.pm index 89e3d0f..346495f 100644 --- a/lib/Pod/Html.pm +++ b/lib/Pod/Html.pm @@ -1438,8 +1438,10 @@ sub process_text1($$;$$){ } elsif( $func eq 'E' ){ # E - convert to character - $$rstr =~ s/^(\w+)>//; - $res = "&$1;"; + $$rstr =~ s/^([^>]*)>//; + my $escape = $1; + $escape =~ s/^(\d+|X[\dA-F]+)$/#$1/i; + $res = "&$escape;"; } elsif( $func eq 'F' ){ # F - italizice @@ -1940,7 +1942,7 @@ sub depod1($;$$){ $res .= $$rstr; } elsif( $func eq 'E' ){ # E - convert to character - $$rstr =~ s/^(\w+)>//; + $$rstr =~ s/^([^>]*)>//; $res .= $E2c{$1} || ""; } elsif( $func eq 'X' ){ # X<> - ignore diff --git a/lib/Pod/LaTeX.pm b/lib/Pod/LaTeX.pm new file mode 100644 index 0000000..8adb589 --- /dev/null +++ b/lib/Pod/LaTeX.pm @@ -0,0 +1,1567 @@ +package Pod::LaTeX; + +# Copyright (C) 2000 by Tim Jenness +# All Rights Reserved. + +=head1 NAME + +Pod::LaTeX - Convert Pod data to formatted Latex + +=head1 SYNOPSIS + + use Pod::LaTeX; + my $parser = Pod::LaTeX->new ( ); + + $parser->parse_from_filehandle; + + $parser->parse_from_file ('file.pod', 'file.tex'); + +=head1 DESCRIPTION + +C is a module to convert documentation in the Pod format +into Latex. The L|pod2latex> X command uses +this module for translation. + +C is a derived class from L. + +=cut + + +use strict; +require Pod::ParseUtils; +use base qw/ Pod::Select /; + +# use Data::Dumper; # for debugging +use Carp; + +use vars qw/ $VERSION %HTML_Escapes @LatexSections /; + +$VERSION = '0.52'; + +# Definitions of =headN -> latex mapping +@LatexSections = (qw/ + chapter + section + subsection + subsubsection + paragraph + subparagraph + /); + +# Standard escape sequences converted to Latex +# Up to "yuml" these are taken from the original pod2latex +# command written by Taro Kawagish (kawagish@imslab.co.jp) + +%HTML_Escapes = ( + 'amp' => '&', # ampersand + 'lt' => '$<$', # ' left chevron, less-than + 'gt' => '$>$', # ' right chevron, greater-than + 'quot' => '"', # double quote + + "Aacute" => "\\'{A}", # capital A, acute accent + "aacute" => "\\'{a}", # small a, acute accent + "Acirc" => "\\^{A}", # capital A, circumflex accent + "acirc" => "\\^{a}", # small a, circumflex accent + "AElig" => '\\AE', # capital AE diphthong (ligature) + "aelig" => '\\ae', # small ae diphthong (ligature) + "Agrave" => "\\`{A}", # capital A, grave accent + "agrave" => "\\`{a}", # small a, grave accent + "Aring" => '\\u{A}', # capital A, ring + "aring" => '\\u{a}', # small a, ring + "Atilde" => '\\~{A}', # capital A, tilde + "atilde" => '\\~{a}', # small a, tilde + "Auml" => '\\"{A}', # capital A, dieresis or umlaut mark + "auml" => '\\"{a}', # small a, dieresis or umlaut mark + "Ccedil" => '\\c{C}', # capital C, cedilla + "ccedil" => '\\c{c}', # small c, cedilla + "Eacute" => "\\'{E}", # capital E, acute accent + "eacute" => "\\'{e}", # small e, acute accent + "Ecirc" => "\\^{E}", # capital E, circumflex accent + "ecirc" => "\\^{e}", # small e, circumflex accent + "Egrave" => "\\`{E}", # capital E, grave accent + "egrave" => "\\`{e}", # small e, grave accent + "ETH" => '\\OE', # capital Eth, Icelandic + "eth" => '\\oe', # small eth, Icelandic + "Euml" => '\\"{E}', # capital E, dieresis or umlaut mark + "euml" => '\\"{e}', # small e, dieresis or umlaut mark + "Iacute" => "\\'{I}", # capital I, acute accent + "iacute" => "\\'{i}", # small i, acute accent + "Icirc" => "\\^{I}", # capital I, circumflex accent + "icirc" => "\\^{i}", # small i, circumflex accent + "Igrave" => "\\`{I}", # capital I, grave accent + "igrave" => "\\`{i}", # small i, grave accent + "Iuml" => '\\"{I}', # capital I, dieresis or umlaut mark + "iuml" => '\\"{i}', # small i, dieresis or umlaut mark + "Ntilde" => '\\~{N}', # capital N, tilde + "ntilde" => '\\~{n}', # small n, tilde + "Oacute" => "\\'{O}", # capital O, acute accent + "oacute" => "\\'{o}", # small o, acute accent + "Ocirc" => "\\^{O}", # capital O, circumflex accent + "ocirc" => "\\^{o}", # small o, circumflex accent + "Ograve" => "\\`{O}", # capital O, grave accent + "ograve" => "\\`{o}", # small o, grave accent + "Oslash" => "\\O", # capital O, slash + "oslash" => "\\o", # small o, slash + "Otilde" => "\\~{O}", # capital O, tilde + "otilde" => "\\~{o}", # small o, tilde + "Ouml" => '\\"{O}', # capital O, dieresis or umlaut mark + "ouml" => '\\"{o}', # small o, dieresis or umlaut mark + "szlig" => '\\ss{}', # small sharp s, German (sz ligature) + "THORN" => '\\L', # capital THORN, Icelandic + "thorn" => '\\l',, # small thorn, Icelandic + "Uacute" => "\\'{U}", # capital U, acute accent + "uacute" => "\\'{u}", # small u, acute accent + "Ucirc" => "\\^{U}", # capital U, circumflex accent + "ucirc" => "\\^{u}", # small u, circumflex accent + "Ugrave" => "\\`{U}", # capital U, grave accent + "ugrave" => "\\`{u}", # small u, grave accent + "Uuml" => '\\"{U}', # capital U, dieresis or umlaut mark + "uuml" => '\\"{u}', # small u, dieresis or umlaut mark + "Yacute" => "\\'{Y}", # capital Y, acute accent + "yacute" => "\\'{y}", # small y, acute accent + "yuml" => '\\"{y}', # small y, dieresis or umlaut mark + + # Added by TimJ + + "iexcl" => '!`', # inverted exclamation mark +# "cent" => ' ', # cent sign + "pound" => '\pounds', # (UK) pound sign +# "curren" => ' ', # currency sign +# "yen" => ' ', # yen sign +# "brvbar" => ' ', # broken vertical bar + "sect" => '\S', # section sign + "uml" => '\"{}', # diaresis + "copy" => '\copyright', # Copyright symbol +# "ordf" => ' ', # feminine ordinal indicator + "laquo" => '$\ll$', # ' # left pointing double angle quotation mark + "not" => '$\neg$', # ' # not sign + "shy" => '-', # soft hyphen +# "reg" => ' ', # registered trademark + "macr" => '$^-$', # ' # macron, overline + "deg" => '$^\circ$', # ' # degree sign + "plusmn" => '$\pm$', # ' # plus-minus sign + "sup2" => '$^2$', # ' # superscript 2 + "sup3" => '$^3$', # ' # superscript 3 + "acute" => "\\'{}", # acute accent + "micro" => '$\mu$', # micro sign + "para" => '\P', # pilcrow sign = paragraph sign + "middot" => '$\cdot$', # middle dot = Georgian comma + "cedil" => '\c{}', # cedilla + "sup1" => '$^1$', # ' # superscript 1 +# "ordm" => ' ', # masculine ordinal indicator + "raquo" => '$\gg$', # ' # right pointing double angle quotation mark + "frac14" => '$\frac{1}{4}$', # ' # vulgar fraction one quarter + "frac12" => '$\frac{1}{2}$', # ' # vulgar fraction one half + "frac34" => '$\frac{3}{4}$', # ' # vulgar fraction three quarters + "iquest" => "?'", # inverted question mark + "times" => '$\times$', # ' # multiplication sign + "divide" => '$\div$', # division sign + + # Greek letters using HTML codes + "alpha" => '$\alpha$', # ' + "beta" => '$\beta$', # ' + "gamma" => '$\gamma$', # ' + "delta" => '$\delta$', # ' + "epsilon"=> '$\epsilon$', # ' + "zeta" => '$\zeta$', # ' + "eta" => '$\eta$', # ' + "theta" => '$\theta$', # ' + "iota" => '$\iota$', # ' + "kappa" => '$\kappa$', # ' + "lambda" => '$\lambda$', # ' + "mu" => '$\mu$', # ' + "nu" => '$\nu$', # ' + "xi" => '$\xi$', # ' + "omicron"=> '$o$', # ' + "pi" => '$\pi$', # ' + "rho" => '$\rho$', # ' + "sigma" => '$\sigma$', # ' + "tau" => '$\tau$', # ' + "upsilon"=> '$\upsilon$', # ' + "phi" => '$\phi$', # ' + "chi" => '$\chi$', # ' + "psi" => '$\psi$', # ' + "omega" => '$\omega$', # ' + + "Alpha" => '$A$', # ' + "Beta" => '$B$', # ' + "Gamma" => '$\Gamma$', # ' + "Delta" => '$\Delta$', # ' + "Epsilon"=> '$E$', # ' + "Zeta" => '$Z$', # ' + "Eta" => '$H$', # ' + "Theta" => '$\Theta$', # ' + "Iota" => '$I$', # ' + "Kappa" => '$K$', # ' + "Lambda" => '$\Lambda$', # ' + "Mu" => '$M$', # ' + "Nu" => '$N$', # ' + "Xi" => '$\Xi$', # ' + "Omicron"=> '$O$', # ' + "Pi" => '$\Pi$', # ' + "Rho" => '$R$', # ' + "Sigma" => '$\Sigma$', # ' + "Tau" => '$T$', # ' + "Upsilon"=> '$\Upsilon$', # ' + "Phi" => '$\Phi$', # ' + "Chi" => '$X$', # ' + "Psi" => '$\Psi$', # ' + "Omega" => '$\Omega$', # ' + + +); + + +=head1 OBJECT METHODS + +The following methods are provided in this module. Methods inherited +from C are not described in the public interface. + +=over 4 + +=begin __PRIVATE__ + +=item C + +Initialise the object. This method is subclassed from C. +The base class method is invoked. This method defines the default +behaviour of the object unless overridden by supplying arguments to +the constructor. + +Internal settings are defaulted as well as the public instance data. +Internal hash values are accessed directly (rather than through +a method) and start with an underscore. + +This method should not be invoked by the user directly. + +=end __PRIVATE__ + +=cut + + + +# - An array for nested lists + +# Arguments have already been read by this point + +sub initialize { + my $self = shift; + + # print Dumper($self); + + # Internals + $self->{_Lists} = []; # For nested lists + $self->{_suppress_all_para} = 0; # For =begin blocks + $self->{_suppress_next_para} = 0; # For =for blocks + $self->{_dont_modify_any_para}=0; # For =begin blocks + $self->{_dont_modify_next_para}=0; # For =for blocks + $self->{_CURRENT_HEAD1} = ''; # Name of current HEAD1 section + + # Options - only initialise if not already set + + # Cause the '=head1 NAME' field to be treated specially + # The contents of the NAME paragraph will be converted + # to a section title. All subsequent =head1 will be converted + # to =head2 and down. Will not affect =head1's prior to NAME + # Assumes: 'Module - purpose' format + # Also creates a purpose field + # The name is used for Labeling of the subsequent subsections + $self->{ReplaceNAMEwithSection} = 0 + unless exists $self->{ReplaceNAMEwithSection}; + $self->{AddPreamble} = 1 # make full latex document + unless exists $self->{AddPreamble}; + $self->{StartWithNewPage} = 0 # Start new page for pod section + unless exists $self->{StartWithNewPage}; + $self->{TableOfContents} = 0 # Add table of contents + unless exists $self->{TableOfContents}; # only relevent if AddPreamble=1 + $self->{AddPostamble} = 1 # Add closing latex code at end + unless exists $self->{AddPostamble}; # effectively end{document} and index + $self->{MakeIndex} = 1 # Add index (only relevant AddPostamble + unless exists $self->{MakeIndex}; # and AddPreamble) + + $self->{UniqueLabels} = 1 # Use label unique for each pod + unless exists $self->{UniqueLabels}; # either based on the filename + # or supplied + + # Control the level of =head1. default is \section + # + $self->{Head1Level} = 1 # Offset in latex sections + unless exists $self->{Head1Level}; # 0 is chapter, 2 is subsection + + # Control at which level numbering of sections is turned off + # ie subsection becomes subsection* + # The numbering is relative to the latex sectioning commands + # and is independent of Pod heading level + # default is to number \section but not \subsection + $self->{LevelNoNum} = 2 + unless exists $self->{LevelNoNum}; + + # Label to be used as prefix to all internal section names + # If not defined will attempt to derive it from the filename + # This can not happen when running parse_from_filehandle though + # hence the ability to set the label externally + # The label could then be Pod::Parser_DESCRIPTION or somesuch + + $self->{Label} = undef # label to be used as prefix + unless exists $self->{Label}; # to all internal section names + + # These allow the caller to add arbritrary latex code to + # start and end of document. AddPreamble and AddPostamble are ignored + # if these are set. + # Also MakeIndex and TableOfContents are also ignored. + $self->{UserPreamble} = undef # User supplied start (AddPreamble =1) + unless exists $self->{Label}; + $self->{UserPostamble} = undef # Use supplied end (AddPostamble=1) + unless exists $self->{Label}; + + # Run base initialize + $self->SUPER::initialize; + +} + +=back + +=head2 Data Accessors + +The following methods are provided for accessing instance data. These +methods should be used for accessing configuration parameters rather +than assuming the object is a hash. + +Default values can be supplied by using these names as keys to a hash +of arguments when using the C constructor. + +=over 4 + +=item B + +Logical to control whether a C preamble is to be written. +If true, a valid C preamble is written before the pod data is written. +This is similar to: + + \documentclass{article} + \begin{document} + +but will be more complicated if table of contents and indexing are required. +Can be used to set or retrieve the current value. + + $add = $parser->AddPreamble(); + $parser->AddPreamble(1); + +If used in conjunction with C a full latex document will +be written that could be immediately processed by C. + +=cut + +sub AddPreamble { + my $self = shift; + if (@_) { + $self->{AddPreamble} = shift; + } + return $self->{AddPreamble}; +} + +=item B + +Logical to control whether a standard C ending is written to the output +file after the document has been processed. +In its simplest form this is simply: + + \end{document} + +but can be more complicated if a index is required. +Can be used to set or retrieve the current value. + + $add = $parser->AddPostamble(); + $parser->AddPostamble(1); + +If used in conjunction with C a full latex document will +be written that could be immediately processed by C. + +=cut + +sub AddPostamble { + my $self = shift; + if (@_) { + $self->{AddPostamble} = shift; + } + return $self->{AddPostamble}; +} + +=item B + +The C sectioning level that should be used to correspond to +a pod C<=head1> directive. This can be used, for example, to turn +a C<=head1> into a C C. This should hold a number +corresponding to the required position in an array containing the +following elements: + + [0] chapter + [1] section + [2] subsection + [3] subsubsection + [4] paragraph + [5] subparagraph + +Can be used to set or retrieve the current value: + + $parser->Head1Level(2); + $sect = $parser->Head1Level; + +Setting this number too high can result in sections that may not be reproducible +in the expected way. For example, setting this to 4 would imply that C<=head3> +do not have a corresponding C section (C<=head1> would correspond to +a C). + +A check is made to ensure that the supplied value is an integer in the +range 0 to 5. + +Default is for a value of 1 (i.e. a C
). + +=cut + +sub Head1Level { + my $self = shift; + if (@_) { + my $arg = shift; + if ($arg =~ /^\d$/ && $arg <= $#LatexSections) { + $self->{Head1Level} = $arg; + } else { + carp "Head1Level supplied ($arg) must be integer in range 0 to ".$#LatexSections . "- Ignoring\n"; + } + } + return $self->{Head1Level}; +} + +=item B